2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[TcGenDeriv]{Generating derived instance declarations}
6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
7 ``official'' interface to deriving-related things.
9 This is where we do all the grimy bindings' generation.
21 gen_tag_n_con_monobind,
23 con2tag_RDR, tag2con_RDR, maxtag_RDR,
28 #include "HsVersions.h"
30 import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), GRHS(..),
31 Match(..), GRHSsAndBinds(..), Stmt(..), HsLit(..),
32 HsBinds(..), DoOrListComp(..),
35 import RdrHsSyn ( RdrName(..), varUnqual, mkOpApp,
36 RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat
38 import BasicTypes ( IfaceFlavour(..), RecFlag(..) )
39 import FieldLabel ( fieldLabelName )
40 import Id ( GenId, isNullaryDataCon, dataConTag,
41 dataConRawArgTys, fIRST_TAG,
42 isDataCon, DataCon, ConTag,
43 dataConFieldLabels, Id )
44 import Maybes ( maybeToBool )
45 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
46 modAndOcc, OccName, Name )
48 import PrimOp ( PrimOp(..) )
49 import PrelInfo -- Lots of RdrNames
50 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
51 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
52 import Type ( isUnpointedType, isUnboxedType, Type )
53 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
54 floatPrimTy, doublePrimTy
56 import Util ( mapAccumL, zipEqual, zipWithEqual,
57 zipWith3Equal, nOfThem, panic, assertPanic )
59 import List ( partition, intersperse )
62 %************************************************************************
64 \subsection{Generating code, by derivable class}
66 %************************************************************************
68 %************************************************************************
70 \subsubsection{Generating @Eq@ instance declarations}
72 %************************************************************************
74 Here are the heuristics for the code we generate for @Eq@:
77 Let's assume we have a data type with some (possibly zero) nullary
78 data constructors and some ordinary, non-nullary ones (the rest,
79 also possibly zero of them). Here's an example, with both \tr{N}ullary
80 and \tr{O}rdinary data cons.
82 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
86 For the ordinary constructors (if any), we emit clauses to do The
90 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
91 (==) (O2 a1) (O2 a2) = a1 == a2
92 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
95 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
96 \tr{a2} are \tr{Float#}s, then we have to generate
98 case (a1 `eqFloat#` a2) of
101 for that particular test.
104 If there are any nullary constructors, we emit a catch-all clause of
108 (==) a b = case (con2tag_Foo a) of { a# ->
109 case (con2tag_Foo b) of { b# ->
110 case (a# ==# b#) of {
115 If there aren't any nullary constructors, we emit a simpler
122 For the @(/=)@ method, we normally just use the default method.
124 If the type is an enumeration type, we could/may/should? generate
125 special code that calls @con2tag_Foo@, much like for @(==)@ shown
129 We thought about doing this: If we're also deriving @Ord@ for this
132 instance ... Eq (Foo ...) where
133 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
134 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
136 However, that requires that \tr{Ord <whatever>} was put in the context
137 for the instance decl, which it probably wasn't, so the decls
138 produced don't get through the typechecker.
142 deriveEq :: RdrName -- Class
143 -> RdrName -- Type constructor
144 -> [ (RdrName, [RdrType]) ] -- Constructors
145 -> (RdrContext, -- Context for the inst decl
146 [RdrBind], -- Binds in the inst decl
147 [RdrBind]) -- Extra value bindings outside
149 deriveEq clas tycon constrs
150 = (context, [eq_bind, ne_bind], [])
152 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
155 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
156 is_nullary (_, args) = null args
159 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
163 tycon_loc = getSrcLoc tycon
164 (nullary_cons, nonnullary_cons)
165 | isNewTyCon tycon = ([], tyConDataCons tycon)
166 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
169 = if (null nullary_cons) then
170 case maybeTyConSingleCon tycon of
172 Nothing -> -- if cons don't match, then False
173 [([a_Pat, b_Pat], false_Expr)]
174 else -- calc. and compare the tags
176 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
177 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
179 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
181 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
182 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
184 ------------------------------------------------------------------
187 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
188 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
190 data_con_RDR = qual_orig_name data_con
191 con_arity = length tys_needed
192 as_needed = take con_arity as_RDRs
193 bs_needed = take con_arity bs_RDRs
194 tys_needed = dataConRawArgTys data_con
196 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
198 nested_eq_expr [] [] [] = true_Expr
199 nested_eq_expr tys as bs
200 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
202 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
205 %************************************************************************
207 \subsubsection{Generating @Ord@ instance declarations}
209 %************************************************************************
211 For a derived @Ord@, we concentrate our attentions on @compare@
213 compare :: a -> a -> Ordering
214 data Ordering = LT | EQ | GT deriving ()
217 We will use the same example data type as above:
219 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
224 We do all the other @Ord@ methods with calls to @compare@:
226 instance ... (Ord <wurble> <wurble>) where
227 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
228 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
229 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
230 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
232 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
233 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
235 -- compare to come...
239 @compare@ always has two parts. First, we use the compared
240 data-constructors' tags to deal with the case of different
243 compare a b = case (con2tag_Foo a) of { a# ->
244 case (con2tag_Foo b) of { b# ->
245 case (a# ==# b#) of {
247 False -> case (a# <# b#) of
252 cmp_eq = ... to come ...
256 We are only left with the ``help'' function @cmp_eq@, to deal with
257 comparing data constructors with the same tag.
259 For the ordinary constructors (if any), we emit the sorta-obvious
260 compare-style stuff; for our example:
262 cmp_eq (O1 a1 b1) (O1 a2 b2)
263 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
265 cmp_eq (O2 a1) (O2 a2)
268 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
269 = case (compare a1 a2) of {
272 EQ -> case compare b1 b2 of {
280 Again, we must be careful about unboxed comparisons. For example,
281 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
285 cmp_eq lt eq gt (O2 a1) (O2 a2)
287 -- or maybe the unfolded equivalent
291 For the remaining nullary constructors, we already know that the
298 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
302 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
305 = defaulted `AndMonoBinds` compare
307 tycon_loc = getSrcLoc tycon
308 --------------------------------------------------------------------
309 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
312 (if maybeToBool (maybeTyConSingleCon tycon) then
313 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
315 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
316 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
317 -- True case; they are equal
318 -- If an enumeration type we are done; else
319 -- recursively compare their components
320 (if isEnumerationTyCon tycon then
323 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
325 -- False case; they aren't equal
326 -- So we need to do a less-than comparison on the tags
327 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
329 tycon_data_cons = tyConDataCons tycon
330 (nullary_cons, nonnullary_cons)
331 | isNewTyCon tycon = ([], tyConDataCons tycon)
332 | otherwise = partition isNullaryDataCon tycon_data_cons
335 mk_FunMonoBind tycon_loc
337 (if null nonnullary_cons && (length nullary_cons == 1) then
338 -- catch this specially to avoid warnings
339 -- about overlapping patterns from the desugarer.
341 data_con = head nullary_cons
342 data_con_RDR = qual_orig_name data_con
343 pat = ConPatIn data_con_RDR []
345 [([pat,pat], eqTag_Expr)]
347 map pats_etc nonnullary_cons ++
348 -- leave out wildcards to silence desugarer.
349 (if length tycon_data_cons == 1 then
352 [([WildPatIn, WildPatIn], default_rhs)]))
355 = ([con1_pat, con2_pat],
356 nested_compare_expr tys_needed as_needed bs_needed)
358 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
359 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
361 data_con_RDR = qual_orig_name data_con
362 con_arity = length tys_needed
363 as_needed = take con_arity as_RDRs
364 bs_needed = take con_arity bs_RDRs
365 tys_needed = dataConRawArgTys data_con
367 nested_compare_expr [ty] [a] [b]
368 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
370 nested_compare_expr (ty:tys) (a:as) (b:bs)
371 = let eq_expr = nested_compare_expr tys as bs
372 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
374 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
375 -- inexhaustive patterns
376 | otherwise = eqTag_Expr -- Some nullary constructors;
377 -- Tags are equal, no args => return EQ
378 --------------------------------------------------------------------
380 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
382 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
383 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
384 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
385 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
386 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
387 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
388 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
389 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
391 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
392 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
393 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
394 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
397 %************************************************************************
399 \subsubsection{Generating @Enum@ instance declarations}
401 %************************************************************************
403 @Enum@ can only be derived for enumeration types. For a type
405 data Foo ... = N1 | N2 | ... | Nn
408 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
409 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
412 instance ... Enum (Foo ...) where
413 toEnum i = tag2con_Foo i
415 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
419 = case con2tag_Foo a of
420 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
423 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
427 = case con2tag_Foo a of { a# ->
428 case con2tag_Foo b of { b# ->
429 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
433 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
436 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
439 = to_enum `AndMonoBinds`
440 enum_from `AndMonoBinds`
441 enum_from_then `AndMonoBinds`
444 tycon_loc = getSrcLoc tycon
447 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
448 mk_easy_App (tag2con_RDR tycon) [a_RDR]
451 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
452 untag_Expr tycon [(a_RDR, ah_RDR)] $
453 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
454 HsPar (enum_from_to_Expr
455 (mk_easy_App mkInt_RDR [ah_RDR])
456 (HsVar (maxtag_RDR tycon)))
459 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
460 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
461 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
462 HsPar (enum_from_then_to_Expr
463 (mk_easy_App mkInt_RDR [ah_RDR])
464 (mk_easy_App mkInt_RDR [bh_RDR])
465 (HsVar (maxtag_RDR tycon)))
468 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
469 untag_Expr tycon [(a_RDR, ah_RDR)] $
470 (mk_easy_App mkInt_RDR [ah_RDR])
473 %************************************************************************
475 \subsubsection{Generating @Eval@ instance declarations}
477 %************************************************************************
480 gen_Eval_binds tycon = EmptyMonoBinds
483 %************************************************************************
485 \subsubsection{Generating @Bounded@ instance declarations}
487 %************************************************************************
490 gen_Bounded_binds tycon
491 = if isEnumerationTyCon tycon then
492 min_bound_enum `AndMonoBinds` max_bound_enum
494 ASSERT(length data_cons == 1)
495 min_bound_1con `AndMonoBinds` max_bound_1con
497 data_cons = tyConDataCons tycon
498 tycon_loc = getSrcLoc tycon
500 ----- enum-flavored: ---------------------------
501 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
502 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
504 data_con_1 = head data_cons
505 data_con_N = last data_cons
506 data_con_1_RDR = qual_orig_name data_con_1
507 data_con_N_RDR = qual_orig_name data_con_N
509 ----- single-constructor-flavored: -------------
510 arity = argFieldCount data_con_1
512 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
513 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
514 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
515 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
518 %************************************************************************
520 \subsubsection{Generating @Ix@ instance declarations}
522 %************************************************************************
524 Deriving @Ix@ is only possible for enumeration types and
525 single-constructor types. We deal with them in turn.
527 For an enumeration type, e.g.,
529 data Foo ... = N1 | N2 | ... | Nn
531 things go not too differently from @Enum@:
533 instance ... Ix (Foo ...) where
535 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
539 = case (con2tag_Foo a) of { a# ->
540 case (con2tag_Foo b) of { b# ->
541 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
546 then case (con2tag_Foo d -# con2tag_Foo a) of
548 else error "Ix.Foo.index: out of range"
552 p_tag = con2tag_Foo c
554 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
558 = case (con2tag_Foo a) of { a_tag ->
559 case (con2tag_Foo b) of { b_tag ->
560 case (con2tag_Foo c) of { c_tag ->
561 if (c_tag >=# a_tag) then
567 (modulo suitable case-ification to handle the unboxed tags)
569 For a single-constructor type (NB: this includes all tuples), e.g.,
571 data Foo ... = MkFoo a b Int Double c c
573 we follow the scheme given in Figure~19 of the Haskell~1.2 report
577 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
580 = if isEnumerationTyCon tycon
584 tycon_str = getOccString tycon
585 tycon_loc = getSrcLoc tycon
587 --------------------------------------------------------------
588 enum_ixes = enum_range `AndMonoBinds`
589 enum_index `AndMonoBinds` enum_inRange
592 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
593 untag_Expr tycon [(a_RDR, ah_RDR)] $
594 untag_Expr tycon [(b_RDR, bh_RDR)] $
595 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
596 HsPar (enum_from_to_Expr
597 (mk_easy_App mkInt_RDR [ah_RDR])
598 (mk_easy_App mkInt_RDR [bh_RDR]))
601 = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
602 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
603 untag_Expr tycon [(a_RDR, ah_RDR)] (
604 untag_Expr tycon [(d_RDR, dh_RDR)] (
606 grhs = unguardedRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc
609 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
610 [PatMatch (VarPatIn c_RDR)
611 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
615 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
620 = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
621 untag_Expr tycon [(a_RDR, ah_RDR)] (
622 untag_Expr tycon [(b_RDR, bh_RDR)] (
623 untag_Expr tycon [(c_RDR, ch_RDR)] (
624 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
625 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
630 --------------------------------------------------------------
632 = single_con_range `AndMonoBinds`
633 single_con_index `AndMonoBinds`
637 = case maybeTyConSingleCon tycon of -- just checking...
638 Nothing -> panic "get_Ix_binds"
639 Just dc -> if (any isUnpointedType (dataConRawArgTys dc)) then
640 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
644 con_arity = argFieldCount data_con
645 data_con_RDR = qual_orig_name data_con
647 as_needed = take con_arity as_RDRs
648 bs_needed = take con_arity bs_RDRs
649 cs_needed = take con_arity cs_RDRs
651 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
652 con_expr = mk_easy_App data_con_RDR cs_needed
654 --------------------------------------------------------------
656 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
657 HsDo ListComp stmts tycon_loc
659 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
661 [ReturnStmt con_expr]
663 mk_qual a b c = BindStmt (VarPatIn c)
664 (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
669 = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
670 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
672 mk_index multiply_by (l, u, i)
674 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
677 (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
678 ) times_RDR multiply_by
682 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
684 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
685 ) plus_RDR (HsLit (HsInt 1)))
689 = mk_easy_FunMonoBind tycon_loc inRange_RDR
690 [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
692 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
694 in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
697 %************************************************************************
699 \subsubsection{Generating @Read@ instance declarations}
701 %************************************************************************
703 Ignoring all the infix-ery mumbo jumbo (ToDo)
706 gen_Read_binds :: TyCon -> RdrNameMonoBinds
709 = reads_prec `AndMonoBinds` read_list
711 tycon_loc = getSrcLoc tycon
712 -----------------------------------------------------------------------
713 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
714 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
715 -----------------------------------------------------------------------
718 read_con_comprehensions
719 = map read_con (tyConDataCons tycon)
721 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
722 foldr1 append_Expr read_con_comprehensions
725 read_con data_con -- note: "b" is the string being "read"
727 data_con_RDR = qual_orig_name data_con
728 data_con_str= occNameString (getOccName data_con)
729 con_arity = argFieldCount data_con
730 con_expr = mk_easy_App data_con_RDR as_needed
731 nullary_con = con_arity == 0
732 labels = dataConFieldLabels data_con
733 lab_fields = length labels
735 as_needed = take con_arity as_RDRs
737 | lab_fields == 0 = take con_arity bs_RDRs
738 | otherwise = take (4*lab_fields + 1) bs_RDRs
739 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
742 (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
743 (HsApp (HsVar lex_RDR) c_Expr)
746 str_qual str res draw_from
748 (TuplePatIn [LitPatIn (HsString str), VarPatIn res])
749 (HsApp (HsVar lex_RDR) draw_from)
753 = let nm = occNameString (getOccName (fieldLabelName f))
755 [str_qual nm, str_qual SLIT("=")]
756 -- There might be spaces between the label and '='
760 snd (mapAccumL mk_qual
762 (zipWithEqual "as_needed"
763 (\ con_field draw_from -> (mk_read_qual con_field,
765 as_needed bs_needed))
768 mapAccumL mk_qual d_Expr
769 (zipEqual "bs_needed"
770 ((str_qual (SLIT("{")):
772 intersperse ([str_qual (_CONS_ ',' _NIL_)]) $
775 (\ as b -> as ++ [b])
777 (map read_label labels)
779 (map mk_read_qual as_needed))) ++ [str_qual (SLIT("}"))])
782 mk_qual draw_from (f, str_left)
783 = (HsVar str_left, -- what to draw from down the line...
784 f str_left draw_from)
786 mk_read_qual con_field res draw_from =
788 (TuplePatIn [VarPatIn con_field, VarPatIn res])
789 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
792 result_expr = ExplicitTuple [con_expr, if null bs_needed
794 else HsVar (last bs_needed)]
796 stmts = con_qual:field_quals ++ [ReturnStmt result_expr]
799 = if nullary_con then -- must be False (parens are surely optional)
801 else -- parens depend on precedence...
802 HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
805 readParen_Expr read_paren_arg $ HsPar $
806 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
807 HsDo ListComp stmts tycon_loc)
812 %************************************************************************
814 \subsubsection{Generating @Show@ instance declarations}
816 %************************************************************************
818 Ignoring all the infix-ery mumbo jumbo (ToDo)
821 gen_Show_binds :: TyCon -> RdrNameMonoBinds
824 = shows_prec `AndMonoBinds` show_list
826 tycon_loc = getSrcLoc tycon
827 -----------------------------------------------------------------------
828 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
829 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
830 -----------------------------------------------------------------------
832 = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
836 data_con_RDR = qual_orig_name data_con
837 con_arity = argFieldCount data_con
838 bs_needed = take con_arity bs_RDRs
839 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
840 nullary_con = con_arity == 0
841 labels = dataConFieldLabels data_con
842 lab_fields = length labels
845 = let nm = occNameString (getOccName data_con)
847 | nullary_con = _NIL_
848 | lab_fields == 0 = SLIT(" ")
849 | otherwise = SLIT("{")
852 mk_showString_app (nm _APPEND_ space_ocurly_maybe)
857 | lab_fields > 0 = [mk_showString_app (SLIT("}"))]
860 con:fs ++ ccurly_maybe
862 show_thingies = show_all show_con real_show_thingies_with_labs
865 = let nm = occNameString (getOccName (fieldLabelName l))
867 mk_showString_app (nm _APPEND_ SLIT("="))
869 mk_showString_app str = HsApp (HsVar showString_RDR)
870 (HsLit (HsString str))
873 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
876 real_show_thingies_with_labs
877 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
878 | otherwise = --Assumption: no of fields == no of labelled fields
879 -- (and in same order)
881 intersperse ([mk_showString_app (_CONS_ ',' _NIL_)]) $ -- Using SLIT()s containing ,s spells trouble.
882 zipWithEqual "gen_Show_binds"
884 (map show_label labels)
889 if nullary_con then -- skip the showParen junk...
890 ASSERT(null bs_needed)
891 ([a_Pat, con_pat], show_con)
894 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
895 (HsPar (nested_compose_Expr show_thingies)))
898 %************************************************************************
900 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
902 %************************************************************************
907 con2tag_Foo :: Foo ... -> Int#
908 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
909 maxtag_Foo :: Int -- ditto (NB: not unboxed)
912 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
917 = GenCon2Tag | GenTag2Con | GenMaxTag
919 gen_tag_n_con_monobind
920 :: (RdrName, -- (proto)Name for the thing in question
921 TyCon, -- tycon in question
925 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
926 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
928 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
931 = ASSERT(isDataCon var)
932 ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
934 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
935 var_RDR = qual_orig_name var
937 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
938 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++
939 [([WildPatIn], impossible_Expr)])
941 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
944 = ASSERT(isDataCon var)
945 ([lit_pat], HsVar var_RDR)
947 lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
948 var_RDR = qual_orig_name var
950 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
951 = mk_easy_FunMonoBind (getSrcLoc tycon)
952 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
954 max_tag = case (tyConDataCons tycon) of
955 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
959 %************************************************************************
961 \subsection{Utility bits for generating bindings}
963 %************************************************************************
965 @mk_easy_FunMonoBind fun pats binds expr@ generates:
967 fun pat1 pat2 ... patN = expr where binds
970 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
971 multi-clause definitions; it generates:
973 fun p1a p1b ... p1N = e1
974 fun p2a p2b ... p2N = e2
976 fun pMa pMb ... pMN = eM
980 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
981 -> [RdrNameMonoBinds] -> RdrNameHsExpr
984 mk_easy_FunMonoBind loc fun pats binds expr
985 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
987 mk_easy_Match loc pats binds expr
988 = mk_match loc pats expr (mkbind binds)
990 mkbind [] = EmptyBinds
991 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
992 -- The renamer expects everything in its input to be a
993 -- "recursive" MonoBinds, and it is its job to sort things out
996 mk_FunMonoBind :: SrcLoc -> RdrName
997 -> [([RdrNamePat], RdrNameHsExpr)]
1000 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1001 mk_FunMonoBind loc fun pats_and_exprs
1002 = FunMonoBind fun False{-not infix-}
1003 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1006 mk_match loc pats expr binds
1008 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS expr loc) binds))
1011 paren p@(VarPatIn _) = p
1012 paren other_p = ParPatIn other_p
1016 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1019 ToDo: Better SrcLocs.
1022 compare_Case, cmp_eq_Expr ::
1023 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1024 -> RdrNameHsExpr -> RdrNameHsExpr
1028 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1029 -> RdrNameHsExpr -> RdrNameHsExpr
1031 careful_compare_Case :: -- checks for primitive types...
1033 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1034 -> RdrNameHsExpr -> RdrNameHsExpr
1037 compare_Case = compare_gen_Case compare_RDR
1038 cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
1040 compare_gen_Case fun lt eq gt a b
1041 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1042 [PatMatch (ConPatIn ltTag_RDR [])
1043 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS lt mkGeneratedSrcLoc) EmptyBinds)),
1045 PatMatch (ConPatIn eqTag_RDR [])
1046 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS eq mkGeneratedSrcLoc) EmptyBinds)),
1048 PatMatch (ConPatIn gtTag_RDR [])
1049 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS gt mkGeneratedSrcLoc) EmptyBinds))]
1052 careful_compare_Case ty lt eq gt a b
1053 = if not (isUnboxedType ty) then
1054 compare_gen_Case compare_RDR lt eq gt a b
1056 else -- we have to do something special for primitive things...
1057 HsIf (genOpApp a relevant_eq_op b)
1059 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1062 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1063 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1065 assoc_ty_id tyids ty
1066 = if null res then panic "assoc_ty"
1069 res = [id | (ty',id) <- tyids, ty == ty']
1072 [(charPrimTy, eqH_Char_RDR)
1073 ,(intPrimTy, eqH_Int_RDR)
1074 ,(wordPrimTy, eqH_Word_RDR)
1075 ,(addrPrimTy, eqH_Addr_RDR)
1076 ,(floatPrimTy, eqH_Float_RDR)
1077 ,(doublePrimTy, eqH_Double_RDR)
1081 [(charPrimTy, ltH_Char_RDR)
1082 ,(intPrimTy, ltH_Int_RDR)
1083 ,(wordPrimTy, ltH_Word_RDR)
1084 ,(addrPrimTy, ltH_Addr_RDR)
1085 ,(floatPrimTy, ltH_Float_RDR)
1086 ,(doublePrimTy, ltH_Double_RDR)
1089 -----------------------------------------------------------------------
1091 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1093 and_Expr a b = genOpApp a and_RDR b
1094 append_Expr a b = genOpApp a append_RDR b
1096 -----------------------------------------------------------------------
1098 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1100 = if not (isUnboxedType ty) then
1102 else -- we have to do something special for primitive things...
1103 genOpApp a relevant_eq_op b
1105 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1109 argFieldCount :: Id -> Int -- Works on data and newtype constructors
1110 argFieldCount con = length (dataConRawArgTys con)
1114 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1115 untag_Expr tycon [] expr = expr
1116 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1117 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1118 [PatMatch (VarPatIn put_tag_here)
1119 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
1122 grhs = unguardedRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc
1124 cmp_tags_Expr :: RdrName -- Comparison op
1125 -> RdrName -> RdrName -- Things to compare
1126 -> RdrNameHsExpr -- What to return if true
1127 -> RdrNameHsExpr -- What to return if false
1130 cmp_tags_Expr op a b true_case false_case
1131 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1134 :: RdrNameHsExpr -> RdrNameHsExpr
1136 enum_from_then_to_Expr
1137 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1140 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1141 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1143 showParen_Expr, readParen_Expr
1144 :: RdrNameHsExpr -> RdrNameHsExpr
1147 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1148 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1150 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1152 nested_compose_Expr [e] = parenify e
1153 nested_compose_Expr (e:es)
1154 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1156 -- impossible_Expr is used in case RHSs that should never happen.
1157 -- We generate these to keep the desugarer from complaining that they *might* happen!
1158 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1160 parenify e@(HsVar _) = e
1161 parenify e = HsPar e
1163 -- genOpApp wraps brackets round the operator application, so that the
1164 -- renamer won't subsequently try to re-associate it.
1165 -- For some reason the renamer doesn't reassociate it right, and I can't
1166 -- be bothered to find out why just now.
1168 genOpApp e1 op e2 = mkOpApp e1 op e2
1172 qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
1174 a_RDR = varUnqual SLIT("a")
1175 b_RDR = varUnqual SLIT("b")
1176 c_RDR = varUnqual SLIT("c")
1177 d_RDR = varUnqual SLIT("d")
1178 ah_RDR = varUnqual SLIT("a#")
1179 bh_RDR = varUnqual SLIT("b#")
1180 ch_RDR = varUnqual SLIT("c#")
1181 dh_RDR = varUnqual SLIT("d#")
1182 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1183 rangeSize_RDR = varUnqual SLIT("rangeSize")
1185 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1186 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1187 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1189 a_Expr = HsVar a_RDR
1190 b_Expr = HsVar b_RDR
1191 c_Expr = HsVar c_RDR
1192 d_Expr = HsVar d_RDR
1193 ltTag_Expr = HsVar ltTag_RDR
1194 eqTag_Expr = HsVar eqTag_RDR
1195 gtTag_Expr = HsVar gtTag_RDR
1196 false_Expr = HsVar false_RDR
1197 true_Expr = HsVar true_RDR
1199 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1201 a_Pat = VarPatIn a_RDR
1202 b_Pat = VarPatIn b_RDR
1203 c_Pat = VarPatIn c_RDR
1204 d_Pat = VarPatIn d_RDR
1206 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1208 con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1209 tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1210 maxtag_RDR tycon = varUnqual (SLIT("maxtag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))