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.
12 #include "HsVersions.h"
23 gen_tag_n_con_monobind,
25 con2tag_RDR, tag2con_RDR, maxtag_RDR,
31 IMPORT_1_3(List(partition))
33 import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
34 GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt,
35 ArithSeqInfo, Sig, HsType, FixityDecl, Fake )
36 import RdrHsSyn ( RdrName(..), varQual, varUnqual,
37 SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat)
39 -- import RnHsSyn ( RenamedFixityDecl(..) )
41 import Id ( GenId, dataConNumFields, isNullaryDataCon, dataConTag,
42 dataConRawArgTys, fIRST_TAG,
43 isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) )
44 import Maybes ( maybeToBool )
45 import Name ( getOccString, getSrcLoc, occNameString, modAndOcc, OccName, Name )
47 import PrimOp ( PrimOp(..) )
48 import PrelInfo -- Lots of RdrNames
49 import SrcLoc ( mkGeneratedSrcLoc )
50 import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
51 import Type ( eqTy, isPrimType )
52 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
53 floatPrimTy, doublePrimTy
55 import Util ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
58 %************************************************************************
60 \subsection{Generating code, by derivable class}
62 %************************************************************************
64 %************************************************************************
66 \subsubsection{Generating @Eq@ instance declarations}
68 %************************************************************************
70 Here are the heuristics for the code we generate for @Eq@:
73 Let's assume we have a data type with some (possibly zero) nullary
74 data constructors and some ordinary, non-nullary ones (the rest,
75 also possibly zero of them). Here's an example, with both \tr{N}ullary
76 and \tr{O}rdinary data cons.
78 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
82 For the ordinary constructors (if any), we emit clauses to do The
86 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
87 (==) (O2 a1) (O2 a2) = a1 == a2
88 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
91 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
92 \tr{a2} are \tr{Float#}s, then we have to generate
94 case (a1 `eqFloat#` a2) of
97 for that particular test.
100 If there are any nullary constructors, we emit a catch-all clause of
104 (==) a b = case (con2tag_Foo a) of { a# ->
105 case (con2tag_Foo b) of { b# ->
106 case (a# ==# b#) of {
111 If there aren't any nullary constructors, we emit a simpler
118 For the @(/=)@ method, we normally just use the default method.
120 If the type is an enumeration type, we could/may/should? generate
121 special code that calls @con2tag_Foo@, much like for @(==)@ shown
125 We thought about doing this: If we're also deriving @Ord@ for this
128 instance ... Eq (Foo ...) where
129 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
130 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
132 However, that requires that \tr{Ord <whatever>} was put in the context
133 for the instance decl, which it probably wasn't, so the decls
134 produced don't get through the typechecker.
138 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
142 tycon_loc = getSrcLoc tycon
143 (nullary_cons, nonnullary_cons)
144 = partition isNullaryDataCon (tyConDataCons tycon)
147 = if (null nullary_cons) then
148 case maybeTyConSingleCon tycon of
150 Nothing -> -- if cons don't match, then False
151 [([a_Pat, b_Pat], false_Expr)]
152 else -- calc. and compare the tags
154 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
155 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
157 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
159 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
160 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
162 ------------------------------------------------------------------
165 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
166 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
168 data_con_RDR = qual_orig_name data_con
169 con_arity = length tys_needed
170 as_needed = take con_arity as_RDRs
171 bs_needed = take con_arity bs_RDRs
172 tys_needed = dataConRawArgTys data_con
174 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
176 nested_eq_expr [] [] [] = true_Expr
177 nested_eq_expr tys as bs
178 = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
180 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
183 %************************************************************************
185 \subsubsection{Generating @Ord@ instance declarations}
187 %************************************************************************
189 For a derived @Ord@, we concentrate our attentions on @compare@
191 compare :: a -> a -> Ordering
192 data Ordering = LT | EQ | GT deriving ()
195 We will use the same example data type as above:
197 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
202 We do all the other @Ord@ methods with calls to @compare@:
204 instance ... (Ord <wurble> <wurble>) where
205 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
206 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
207 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
208 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
210 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
211 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
213 -- compare to come...
217 @compare@ always has two parts. First, we use the compared
218 data-constructors' tags to deal with the case of different
221 compare a b = case (con2tag_Foo a) of { a# ->
222 case (con2tag_Foo b) of { b# ->
223 case (a# ==# b#) of {
225 False -> case (a# <# b#) of
230 cmp_eq = ... to come ...
234 We are only left with the ``help'' function @cmp_eq@, to deal with
235 comparing data constructors with the same tag.
237 For the ordinary constructors (if any), we emit the sorta-obvious
238 compare-style stuff; for our example:
240 cmp_eq (O1 a1 b1) (O1 a2 b2)
241 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
243 cmp_eq (O2 a1) (O2 a2)
246 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
247 = case (compare a1 a2) of {
250 EQ -> case compare b1 b2 of {
258 Again, we must be careful about unboxed comparisons. For example,
259 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
262 cmp_eq lt eq gt (O2 a1) (O2 a2)
264 -- or maybe the unfolded equivalent
268 For the remaining nullary constructors, we already know that the
276 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
279 = defaulted `AndMonoBinds` compare
281 tycon_loc = getSrcLoc tycon
282 --------------------------------------------------------------------
283 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
286 (if maybeToBool (maybeTyConSingleCon tycon) then
287 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
289 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
290 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
291 -- True case; they are equal
292 -- If an enumeration type we are done; else
293 -- recursively compare their components
294 (if isEnumerationTyCon tycon then
297 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
299 -- False case; they aren't equal
300 -- So we need to do a less-than comparison on the tags
301 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
303 (nullary_cons, nonnullary_cons)
304 = partition isNullaryDataCon (tyConDataCons tycon)
307 = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++ deflt_pats_etc)
310 = ([con1_pat, con2_pat],
311 nested_compare_expr tys_needed as_needed bs_needed)
313 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
314 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
316 data_con_RDR = qual_orig_name data_con
317 con_arity = length tys_needed
318 as_needed = take con_arity as_RDRs
319 bs_needed = take con_arity bs_RDRs
320 tys_needed = dataConRawArgTys data_con
322 nested_compare_expr [ty] [a] [b]
323 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
325 nested_compare_expr (ty:tys) (a:as) (b:bs)
326 = let eq_expr = nested_compare_expr tys as bs
327 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
330 = if null nullary_cons
332 else [([a_Pat, b_Pat], eqTag_Expr)]
333 --------------------------------------------------------------------
335 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
337 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
338 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
339 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
340 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
341 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
342 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
343 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
344 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
346 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
347 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
348 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
349 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
352 %************************************************************************
354 \subsubsection{Generating @Enum@ instance declarations}
356 %************************************************************************
358 @Enum@ can only be derived for enumeration types. For a type
360 data Foo ... = N1 | N2 | ... | Nn
363 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
364 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
367 instance ... Enum (Foo ...) where
368 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
372 = case con2tag_Foo a of
373 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
376 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
380 = case con2tag_Foo a of { a# ->
381 case con2tag_Foo b of { b# ->
382 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
386 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
389 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
392 = enum_from `AndMonoBinds`
393 enum_from_then `AndMonoBinds`
396 tycon_loc = getSrcLoc tycon
398 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
399 untag_Expr tycon [(a_RDR, ah_RDR)] $
400 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
401 HsPar (enum_from_to_Expr
402 (mk_easy_App mkInt_RDR [ah_RDR])
403 (HsVar (maxtag_RDR tycon)))
406 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
407 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
408 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
409 HsPar (enum_from_then_to_Expr
410 (mk_easy_App mkInt_RDR [ah_RDR])
411 (mk_easy_App mkInt_RDR [bh_RDR])
412 (HsVar (maxtag_RDR tycon)))
415 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
416 untag_Expr tycon [(a_RDR, ah_RDR)] $
417 (mk_easy_App mkInt_RDR [ah_RDR])
420 %************************************************************************
422 \subsubsection{Generating @Eval@ instance declarations}
424 %************************************************************************
427 gen_Eval_binds tycon = EmptyMonoBinds
430 %************************************************************************
432 \subsubsection{Generating @Bounded@ instance declarations}
434 %************************************************************************
437 gen_Bounded_binds tycon
438 = if isEnumerationTyCon tycon then
439 min_bound_enum `AndMonoBinds` max_bound_enum
441 ASSERT(length data_cons == 1)
442 min_bound_1con `AndMonoBinds` max_bound_1con
444 data_cons = tyConDataCons tycon
445 tycon_loc = getSrcLoc tycon
447 ----- enum-flavored: ---------------------------
448 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
449 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
451 data_con_1 = head data_cons
452 data_con_N = last data_cons
453 data_con_1_RDR = qual_orig_name data_con_1
454 data_con_N_RDR = qual_orig_name data_con_N
456 ----- single-constructor-flavored: -------------
457 arity = dataConNumFields data_con_1
459 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
460 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
461 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
462 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
465 %************************************************************************
467 \subsubsection{Generating @Ix@ instance declarations}
469 %************************************************************************
471 Deriving @Ix@ is only possible for enumeration types and
472 single-constructor types. We deal with them in turn.
474 For an enumeration type, e.g.,
476 data Foo ... = N1 | N2 | ... | Nn
478 things go not too differently from @Enum@:
480 instance ... Ix (Foo ...) where
482 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
486 = case (con2tag_Foo a) of { a# ->
487 case (con2tag_Foo b) of { b# ->
488 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
493 then case (con2tag_Foo d -# con2tag_Foo a) of
495 else error "Ix.Foo.index: out of range"
499 p_tag = con2tag_Foo c
501 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
505 = case (con2tag_Foo a) of { a_tag ->
506 case (con2tag_Foo b) of { b_tag ->
507 case (con2tag_Foo c) of { c_tag ->
508 if (c_tag >=# a_tag) then
514 (modulo suitable case-ification to handle the unboxed tags)
516 For a single-constructor type (NB: this includes all tuples), e.g.,
518 data Foo ... = MkFoo a b Int Double c c
520 we follow the scheme given in Figure~19 of the Haskell~1.2 report
524 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
527 = if isEnumerationTyCon tycon
531 tycon_str = getOccString tycon
532 tycon_loc = getSrcLoc tycon
534 --------------------------------------------------------------
535 enum_ixes = enum_range `AndMonoBinds`
536 enum_index `AndMonoBinds` enum_inRange
539 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
540 untag_Expr tycon [(a_RDR, ah_RDR)] $
541 untag_Expr tycon [(b_RDR, bh_RDR)] $
542 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
543 HsPar (enum_from_to_Expr
544 (mk_easy_App mkInt_RDR [ah_RDR])
545 (mk_easy_App mkInt_RDR [bh_RDR]))
548 = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
549 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
550 untag_Expr tycon [(a_RDR, ah_RDR)] (
551 untag_Expr tycon [(d_RDR, dh_RDR)] (
553 grhs = [OtherwiseGRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc]
556 (HsPar (OpApp (HsVar dh_RDR) (HsVar minusH_RDR) (HsVar ah_RDR)))
557 [PatMatch (VarPatIn c_RDR)
558 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
562 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
567 = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
568 untag_Expr tycon [(a_RDR, ah_RDR)] (
569 untag_Expr tycon [(b_RDR, bh_RDR)] (
570 untag_Expr tycon [(c_RDR, ch_RDR)] (
571 HsIf (HsPar (OpApp (HsVar ch_RDR) (HsVar geH_RDR) (HsVar ah_RDR))) (
572 (OpApp (HsVar ch_RDR) (HsVar leH_RDR) (HsVar bh_RDR))
577 --------------------------------------------------------------
578 single_con_ixes = single_con_range `AndMonoBinds`
579 single_con_index `AndMonoBinds` single_con_inRange
582 = case maybeTyConSingleCon tycon of -- just checking...
583 Nothing -> panic "get_Ix_binds"
584 Just dc -> if (any isPrimType (dataConRawArgTys dc)) then
585 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
589 con_arity = dataConNumFields data_con
590 data_con_RDR = qual_orig_name data_con
591 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
592 con_expr xs = mk_easy_App data_con_RDR xs
594 as_needed = take con_arity as_RDRs
595 bs_needed = take con_arity bs_RDRs
596 cs_needed = take con_arity cs_RDRs
598 --------------------------------------------------------------
600 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
601 ListComp (con_expr cs_needed) (zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed)
604 mk_qual a b c = GeneratorQual (VarPatIn c)
605 (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
609 = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
610 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
612 mk_index multiply_by (l, u, i)
614 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
617 (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
618 ) (HsVar times_RDR) multiply_by
622 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
624 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
625 ) (HsVar plus_RDR) (HsLit (HsInt 1)))
629 = mk_easy_FunMonoBind tycon_loc inRange_RDR
630 [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
632 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
634 in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
637 %************************************************************************
639 \subsubsection{Generating @Read@ instance declarations}
641 %************************************************************************
643 Ignoring all the infix-ery mumbo jumbo (ToDo)
646 gen_Read_binds :: TyCon -> RdrNameMonoBinds
649 = reads_prec `AndMonoBinds` read_list
651 tycon_loc = getSrcLoc tycon
652 -----------------------------------------------------------------------
653 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
654 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
655 -----------------------------------------------------------------------
658 read_con_comprehensions
659 = map read_con (tyConDataCons tycon)
661 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
662 foldl1 append_Expr read_con_comprehensions
665 read_con data_con -- note: "b" is the string being "read"
667 data_con_RDR = qual_orig_name data_con
668 data_con_str= occNameString (getOccName data_con)
669 con_arity = dataConNumFields data_con
670 as_needed = take con_arity as_RDRs
671 bs_needed = take con_arity bs_RDRs
672 con_expr = mk_easy_App data_con_RDR as_needed
673 nullary_con = isNullaryDataCon data_con
677 (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
678 (HsApp (HsVar lex_RDR) c_Expr)
680 field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed))
683 = if nullary_con then -- must be False (parens are surely optional)
685 else -- parens depend on precedence...
686 HsPar (OpApp a_Expr (HsVar gt_RDR) (HsLit (HsInt 9)))
689 readParen_Expr read_paren_arg $ HsPar $
690 HsLam (mk_easy_Match tycon_loc [c_Pat] [] (
691 ListComp (ExplicitTuple [con_expr,
692 if null bs_needed then d_Expr else HsVar (last bs_needed)])
693 (con_qual : field_quals)))
696 mk_qual draw_from (con_field, str_left)
697 = (HsVar str_left, -- what to draw from down the line...
699 (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
700 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from))
703 %************************************************************************
705 \subsubsection{Generating @Show@ instance declarations}
707 %************************************************************************
709 Ignoring all the infix-ery mumbo jumbo (ToDo)
712 gen_Show_binds :: TyCon -> RdrNameMonoBinds
715 = shows_prec `AndMonoBinds` show_list
717 tycon_loc = getSrcLoc tycon
718 -----------------------------------------------------------------------
719 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
720 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
721 -----------------------------------------------------------------------
723 = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
727 data_con_RDR = qual_orig_name data_con
728 con_arity = dataConNumFields data_con
729 bs_needed = take con_arity bs_RDRs
730 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
731 nullary_con = isNullaryDataCon data_con
734 = let nm = occNameString (getOccName data_con)
735 space_maybe = if nullary_con then _NIL_ else SLIT(" ")
737 HsApp (HsVar showString_RDR) (HsLit (HsString (nm _APPEND_ space_maybe)))
739 show_thingies = show_con : (spacified real_show_thingies)
742 = [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
745 if nullary_con then -- skip the showParen junk...
746 ASSERT(null bs_needed)
747 ([a_Pat, con_pat], show_con)
750 showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_RDR) (HsLit (HsInt 10))))
751 (HsPar (nested_compose_Expr show_thingies)))
755 spacified (x:xs) = (x : (HsVar showSpace_RDR) : spacified xs)
758 %************************************************************************
760 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
762 %************************************************************************
767 con2tag_Foo :: Foo ... -> Int#
768 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
769 maxtag_Foo :: Int -- ditto (NB: not unboxed)
772 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
777 = GenCon2Tag | GenTag2Con | GenMaxTag
779 gen_tag_n_con_monobind
780 :: (RdrName, -- (proto)Name for the thing in question
781 TyCon, -- tycon in question
785 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
786 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
788 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
791 = ASSERT(isDataCon var)
792 ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
794 pat = ConPatIn var_RDR (nOfThem (dataConNumFields var) WildPatIn)
795 var_RDR = qual_orig_name var
797 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
798 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
800 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
803 = ASSERT(isDataCon var)
804 ([lit_pat], HsVar var_RDR)
806 lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
807 var_RDR = qual_orig_name var
809 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
810 = mk_easy_FunMonoBind (getSrcLoc tycon)
811 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
813 max_tag = case (tyConDataCons tycon) of
814 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
817 %************************************************************************
819 \subsection{Utility bits for generating bindings}
821 %************************************************************************
823 @mk_easy_FunMonoBind fun pats binds expr@ generates:
825 fun pat1 pat2 ... patN = expr where binds
828 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
829 multi-clause definitions; it generates:
831 fun p1a p1b ... p1N = e1
832 fun p2a p2b ... p2N = e2
834 fun pMa pMb ... pMN = eM
838 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
839 -> [RdrNameMonoBinds] -> RdrNameHsExpr
842 mk_easy_FunMonoBind loc fun pats binds expr
843 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
845 mk_easy_Match loc pats binds expr
846 = mk_match loc pats expr (mkbind binds)
848 mkbind [] = EmptyBinds
849 mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
850 -- The renamer expects everything in its input to be a
851 -- "recursive" MonoBinds, and it is its job to sort things out
854 mk_FunMonoBind :: SrcLoc -> RdrName
855 -> [([RdrNamePat], RdrNameHsExpr)]
858 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
859 mk_FunMonoBind loc fun pats_and_exprs
860 = FunMonoBind fun False{-not infix-}
861 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
864 mk_match loc pats expr binds
866 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr loc] binds))
869 paren p@(VarPatIn _) = p
870 paren other_p = ParPatIn other_p
874 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
877 ToDo: Better SrcLocs.
880 compare_Case, cmp_eq_Expr ::
881 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
882 -> RdrNameHsExpr -> RdrNameHsExpr
886 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
887 -> RdrNameHsExpr -> RdrNameHsExpr
889 careful_compare_Case :: -- checks for primitive types...
891 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
892 -> RdrNameHsExpr -> RdrNameHsExpr
895 compare_Case = compare_gen_Case compare_RDR
896 cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
898 compare_gen_Case fun lt eq gt a b
899 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
900 [PatMatch (ConPatIn ltTag_RDR [])
901 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
903 PatMatch (ConPatIn eqTag_RDR [])
904 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
906 PatMatch (ConPatIn gtTag_RDR [])
907 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
910 careful_compare_Case ty lt eq gt a b
911 = if not (isPrimType ty) then
912 compare_gen_Case compare_RDR lt eq gt a b
914 else -- we have to do something special for primitive things...
915 HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b))
917 (HsIf (HsPar (OpApp a (HsVar relevant_lt_op) b)) lt gt mkGeneratedSrcLoc)
920 relevant_eq_op = assoc_ty_id eq_op_tbl ty
921 relevant_lt_op = assoc_ty_id lt_op_tbl ty
924 = if null res then panic "assoc_ty"
927 res = [id | (ty',id) <- tyids, eqTy ty ty']
930 [(charPrimTy, eqH_Char_RDR)
931 ,(intPrimTy, eqH_Int_RDR)
932 ,(wordPrimTy, eqH_Word_RDR)
933 ,(addrPrimTy, eqH_Addr_RDR)
934 ,(floatPrimTy, eqH_Float_RDR)
935 ,(doublePrimTy, eqH_Double_RDR)
939 [(charPrimTy, ltH_Char_RDR)
940 ,(intPrimTy, ltH_Int_RDR)
941 ,(wordPrimTy, ltH_Word_RDR)
942 ,(addrPrimTy, ltH_Addr_RDR)
943 ,(floatPrimTy, ltH_Float_RDR)
944 ,(doublePrimTy, ltH_Double_RDR)
947 -----------------------------------------------------------------------
949 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
951 and_Expr a b = OpApp a (HsVar and_RDR) b
952 append_Expr a b = OpApp a (HsVar append_RDR) b
954 -----------------------------------------------------------------------
956 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
958 = if not (isPrimType ty) then
959 OpApp a (HsVar eq_RDR) b
960 else -- we have to do something special for primitive things...
961 OpApp a (HsVar relevant_eq_op) b
963 relevant_eq_op = assoc_ty_id eq_op_tbl ty
967 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
968 untag_Expr tycon [] expr = expr
969 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
970 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
971 [PatMatch (VarPatIn put_tag_here)
972 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
975 grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
977 cmp_tags_Expr :: RdrName -- Comparison op
978 -> RdrName -> RdrName -- Things to compare
979 -> RdrNameHsExpr -- What to return if true
980 -> RdrNameHsExpr -- What to return if false
983 cmp_tags_Expr op a b true_case false_case
984 = HsIf (HsPar (OpApp (HsVar a) (HsVar op) (HsVar b))) true_case false_case mkGeneratedSrcLoc
987 :: RdrNameHsExpr -> RdrNameHsExpr
989 enum_from_then_to_Expr
990 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
993 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
994 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
996 showParen_Expr, readParen_Expr
997 :: RdrNameHsExpr -> RdrNameHsExpr
1000 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1001 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1003 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1005 nested_compose_Expr [e] = parenify e
1006 nested_compose_Expr (e:es)
1007 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1009 parenify e@(HsVar _) = e
1010 parenify e = HsPar e
1014 qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n }
1016 a_RDR = varUnqual SLIT("a")
1017 b_RDR = varUnqual SLIT("b")
1018 c_RDR = varUnqual SLIT("c")
1019 d_RDR = varUnqual SLIT("d")
1020 ah_RDR = varUnqual SLIT("a#")
1021 bh_RDR = varUnqual SLIT("b#")
1022 ch_RDR = varUnqual SLIT("c#")
1023 dh_RDR = varUnqual SLIT("d#")
1024 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1025 rangeSize_RDR = varUnqual SLIT("rangeSize")
1027 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1028 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1029 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1031 a_Expr = HsVar a_RDR
1032 b_Expr = HsVar b_RDR
1033 c_Expr = HsVar c_RDR
1034 d_Expr = HsVar d_RDR
1035 ltTag_Expr = HsVar ltTag_RDR
1036 eqTag_Expr = HsVar eqTag_RDR
1037 gtTag_Expr = HsVar gtTag_RDR
1038 false_Expr = HsVar false_RDR
1039 true_Expr = HsVar true_RDR
1041 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1043 a_Pat = VarPatIn a_RDR
1044 b_Pat = VarPatIn b_RDR
1045 c_Pat = VarPatIn c_RDR
1046 d_Pat = VarPatIn d_RDR
1048 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1051 = let (mod, nm) = modAndOcc tycon
1052 con2tag = SLIT("con2tag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
1054 varQual (mod, con2tag)
1057 = let (mod, nm) = modAndOcc tycon
1058 tag2con = SLIT("tag2con_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
1060 varQual (mod, tag2con)
1063 = let (mod, nm) = modAndOcc tycon
1064 maxtag = SLIT("maxtag_") _APPEND_ occNameString nm _APPEND_ SLIT("#")
1066 varQual (mod, maxtag)