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"
47 gen_tag_n_con_monobind,
60 con2tag_PN, tag2con_PN, maxtag_PN,
66 IMPORT_1_3(List(partition))
68 import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
69 GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qualifier(..), Stmt,
70 ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
71 import RdrHsSyn ( SYN_IE(RdrNameMonoBinds), SYN_IE(RdrNameHsExpr), SYN_IE(RdrNamePat) )
72 import RnHsSyn ( RenamedFixityDecl(..) )
75 import Id ( GenId, dataConNumFields, isNullaryDataCon, dataConTag,
76 dataConRawArgTys, fIRST_TAG,
77 isDataCon, SYN_IE(DataCon), SYN_IE(ConTag) )
78 import IdUtils ( primOpId )
79 import Maybes ( maybeToBool )
80 import Name ( origName, preludeQual, nameOf, RdrName(..), OrigName(..) )
81 import PrelMods ( pRELUDE, gHC__, iX )
82 import PrelVals ( eRROR_ID )
84 import PrimOp ( PrimOp(..) )
85 import SrcLoc ( mkGeneratedSrcLoc )
86 import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
87 import Type ( eqTy, isPrimType )
88 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
89 floatPrimTy, doublePrimTy
91 import TysWiredIn ( falseDataCon, trueDataCon, intDataCon )
93 import Util ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
96 %************************************************************************
98 \subsection{Generating code, by derivable class}
100 %************************************************************************
102 %************************************************************************
104 \subsubsection{Generating @Eq@ instance declarations}
106 %************************************************************************
108 Here are the heuristics for the code we generate for @Eq@:
111 Let's assume we have a data type with some (possibly zero) nullary
112 data constructors and some ordinary, non-nullary ones (the rest,
113 also possibly zero of them). Here's an example, with both \tr{N}ullary
114 and \tr{O}rdinary data cons.
116 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
120 For the ordinary constructors (if any), we emit clauses to do The
124 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
125 (==) (O2 a1) (O2 a2) = a1 == a2
126 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
129 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
130 \tr{a2} are \tr{Float#}s, then we have to generate
132 case (a1 `eqFloat#` a2) of
135 for that particular test.
138 If there are any nullary constructors, we emit a catch-all clause of
142 (==) a b = case (con2tag_Foo a) of { a# ->
143 case (con2tag_Foo b) of { b# ->
144 case (a# ==# b#) of {
149 If there aren't any nullary constructors, we emit a simpler
156 For the @(/=)@ method, we normally just use the default method.
158 If the type is an enumeration type, we could/may/should? generate
159 special code that calls @con2tag_Foo@, much like for @(==)@ shown
163 We thought about doing this: If we're also deriving @Ord@ for this
166 instance ... Eq (Foo ...) where
167 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
168 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
170 However, that requires that \tr{Ord <whatever>} was put in the context
171 for the instance decl, which it probably wasn't, so the decls
172 produced don't get through the typechecker.
176 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
180 (nullary_cons, nonnullary_cons)
181 = partition isNullaryDataCon (tyConDataCons tycon)
184 = if (null nullary_cons) then
185 case maybeTyConSingleCon tycon of
187 Nothing -> -- if cons don't match, then False
188 [([a_Pat, b_Pat], false_Expr)]
189 else -- calc. and compare the tags
191 untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)]
192 (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN true_Expr false_Expr))]
194 mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest)
195 `AndMonoBinds` boring_ne_method
197 ------------------------------------------------------------------
200 con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
201 con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
203 data_con_PN = qual_orig_name data_con
204 con_arity = length tys_needed
205 as_needed = take con_arity as_PNs
206 bs_needed = take con_arity bs_PNs
207 tys_needed = dataConRawArgTys data_con
209 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
211 nested_eq_expr [] [] [] = true_Expr
212 nested_eq_expr tys as bs
213 = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
215 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
218 = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] $
219 HsApp (HsVar not_PN) (HsPar (mk_easy_App eq_PN [a_PN, b_PN]))
222 %************************************************************************
224 \subsubsection{Generating @Ord@ instance declarations}
226 %************************************************************************
228 For a derived @Ord@, we concentrate our attentions on @compare@
230 compare :: a -> a -> Ordering
231 data Ordering = LT | EQ | GT deriving ()
234 We will use the same example data type as above:
236 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
241 We do all the other @Ord@ methods with calls to @compare@:
243 instance ... (Ord <wurble> <wurble>) where
244 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
245 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
246 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
247 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
249 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
250 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
252 -- compare to come...
256 @compare@ always has two parts. First, we use the compared
257 data-constructors' tags to deal with the case of different
260 compare a b = case (con2tag_Foo a) of { a# ->
261 case (con2tag_Foo b) of { b# ->
262 case (a# ==# b#) of {
264 False -> case (a# <# b#) of
269 cmp_eq = ... to come ...
273 We are only left with the ``help'' function @cmp_eq@, to deal with
274 comparing data constructors with the same tag.
276 For the ordinary constructors (if any), we emit the sorta-obvious
277 compare-style stuff; for our example:
279 cmp_eq (O1 a1 b1) (O1 a2 b2)
280 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
282 cmp_eq (O2 a1) (O2 a2)
285 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
286 = case (compare a1 a2) of {
289 EQ -> case compare b1 b2 of {
297 Again, we must be careful about unboxed comparisons. For example,
298 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
301 cmp_eq lt eq gt (O2 a1) (O2 a2)
303 -- or maybe the unfolded equivalent
307 For the remaining nullary constructors, we already know that the
315 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
318 = defaulted `AndMonoBinds` compare
320 --------------------------------------------------------------------
321 compare = mk_easy_FunMonoBind compare_PN
324 (if maybeToBool (maybeTyConSingleCon tycon) then
325 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
327 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
328 (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN
329 -- True case; they are equal
330 -- If an enumeration type we are done; else
331 -- recursively compare their components
332 (if isEnumerationTyCon tycon then
335 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
337 -- False case; they aren't equal
338 -- So we need to do a less-than comparison on the tags
339 (cmp_tags_Expr ltH_Int_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
341 (nullary_cons, nonnullary_cons)
342 = partition isNullaryDataCon (tyConDataCons tycon)
345 = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
348 = ([con1_pat, con2_pat],
349 nested_compare_expr tys_needed as_needed bs_needed)
351 con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
352 con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
354 data_con_PN = qual_orig_name data_con
355 con_arity = length tys_needed
356 as_needed = take con_arity as_PNs
357 bs_needed = take con_arity bs_PNs
358 tys_needed = dataConRawArgTys data_con
360 nested_compare_expr [ty] [a] [b]
361 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
363 nested_compare_expr (ty:tys) (a:as) (b:bs)
364 = let eq_expr = nested_compare_expr tys as bs
365 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
368 = if null nullary_cons
370 else [([a_Pat, b_Pat], eqTag_Expr)]
371 --------------------------------------------------------------------
373 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
375 lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
376 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
377 le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
378 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
379 ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
380 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
381 gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
382 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
384 max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
385 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
386 min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
387 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
390 %************************************************************************
392 \subsubsection{Generating @Enum@ instance declarations}
394 %************************************************************************
396 @Enum@ can only be derived for enumeration types. For a type
398 data Foo ... = N1 | N2 | ... | Nn
401 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
402 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
405 instance ... Enum (Foo ...) where
406 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
410 = case con2tag_Foo a of
411 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
414 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
418 = case con2tag_Foo a of { a# ->
419 case con2tag_Foo b of { b# ->
420 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
424 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
427 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
430 = enum_from `AndMonoBinds` enum_from_then
433 = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] $
434 untag_Expr tycon [(a_PN, ah_PN)] $
435 HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
436 HsPar (enum_from_to_Expr
437 (mk_easy_App mkInt_PN [ah_PN])
438 (HsVar (maxtag_PN tycon)))
441 = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] $
442 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] $
443 HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
444 HsPar (enum_from_then_to_Expr
445 (mk_easy_App mkInt_PN [ah_PN])
446 (mk_easy_App mkInt_PN [bh_PN])
447 (HsVar (maxtag_PN tycon)))
450 %************************************************************************
452 \subsubsection{Generating @Eval@ instance declarations}
454 %************************************************************************
457 gen_Eval_binds tycon = EmptyMonoBinds
460 %************************************************************************
462 \subsubsection{Generating @Bounded@ instance declarations}
464 %************************************************************************
467 gen_Bounded_binds tycon
468 = if isEnumerationTyCon tycon then
469 min_bound_enum `AndMonoBinds` max_bound_enum
471 ASSERT(length data_cons == 1)
472 min_bound_1con `AndMonoBinds` max_bound_1con
474 data_cons = tyConDataCons tycon
476 ----- enum-flavored: ---------------------------
477 min_bound_enum = mk_easy_FunMonoBind minBound_PN [] [] (HsVar data_con_1_PN)
478 max_bound_enum = mk_easy_FunMonoBind maxBound_PN [] [] (HsVar data_con_N_PN)
480 data_con_1 = head data_cons
481 data_con_N = last data_cons
482 data_con_1_PN = qual_orig_name data_con_1
483 data_con_N_PN = qual_orig_name data_con_N
485 ----- single-constructor-flavored: -------------
486 arity = dataConNumFields data_con_1
488 min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $
489 mk_easy_App data_con_1_PN (nOfThem arity minBound_PN)
490 max_bound_1con = mk_easy_FunMonoBind maxBound_PN [] [] $
491 mk_easy_App data_con_1_PN (nOfThem arity maxBound_PN)
494 %************************************************************************
496 \subsubsection{Generating @Ix@ instance declarations}
498 %************************************************************************
500 Deriving @Ix@ is only possible for enumeration types and
501 single-constructor types. We deal with them in turn.
503 For an enumeration type, e.g.,
505 data Foo ... = N1 | N2 | ... | Nn
507 things go not too differently from @Enum@:
509 instance ... Ix (Foo ...) where
511 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
515 = case (con2tag_Foo a) of { a# ->
516 case (con2tag_Foo b) of { b# ->
517 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
522 then case (con2tag_Foo d -# con2tag_Foo a) of
524 else error "Ix.Foo.index: out of range"
528 p_tag = con2tag_Foo c
530 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
534 = case (con2tag_Foo a) of { a_tag ->
535 case (con2tag_Foo b) of { b_tag ->
536 case (con2tag_Foo c) of { c_tag ->
537 if (c_tag >=# a_tag) then
543 (modulo suitable case-ification to handle the unboxed tags)
545 For a single-constructor type (NB: this includes all tuples), e.g.,
547 data Foo ... = MkFoo a b Int Double c c
549 we follow the scheme given in Figure~19 of the Haskell~1.2 report
553 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
556 = if isEnumerationTyCon tycon
560 tycon_str = _UNPK_ (nameOf (origName "gen_Ix_binds" tycon))
562 --------------------------------------------------------------
563 enum_ixes = enum_range `AndMonoBinds`
564 enum_index `AndMonoBinds` enum_inRange
567 = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] $
568 untag_Expr tycon [(a_PN, ah_PN)] $
569 untag_Expr tycon [(b_PN, bh_PN)] $
570 HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
571 HsPar (enum_from_to_Expr
572 (mk_easy_App mkInt_PN [ah_PN])
573 (mk_easy_App mkInt_PN [bh_PN]))
576 = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
577 HsIf (HsPar (mk_easy_App inRange_PN [c_PN, d_PN])) (
578 untag_Expr tycon [(a_PN, ah_PN)] (
579 untag_Expr tycon [(d_PN, dh_PN)] (
581 grhs = [OtherwiseGRHS (mk_easy_App mkInt_PN [c_PN]) mkGeneratedSrcLoc]
584 (HsPar (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN)))
585 [PatMatch (VarPatIn c_PN)
586 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
590 HsApp (HsVar error_PN) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
595 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
596 untag_Expr tycon [(a_PN, ah_PN)] (
597 untag_Expr tycon [(b_PN, bh_PN)] (
598 untag_Expr tycon [(c_PN, ch_PN)] (
599 HsIf (HsPar (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN))) (
600 (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
603 ) mkGeneratedSrcLoc))))
605 --------------------------------------------------------------
606 single_con_ixes = single_con_range `AndMonoBinds`
607 single_con_index `AndMonoBinds` single_con_inRange
610 = case maybeTyConSingleCon tycon of -- just checking...
611 Nothing -> panic "get_Ix_binds"
612 Just dc -> if (any isPrimType (dataConRawArgTys dc)) then
613 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
617 con_arity = dataConNumFields data_con
618 data_con_PN = qual_orig_name data_con
619 con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
620 con_expr xs = mk_easy_App data_con_PN xs
622 as_needed = take con_arity as_PNs
623 bs_needed = take con_arity bs_PNs
624 cs_needed = take con_arity cs_PNs
626 --------------------------------------------------------------
628 = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
629 ListComp (con_expr cs_needed) (zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed)
632 mk_qual a b c = GeneratorQual (VarPatIn c)
633 (HsApp (HsVar range_PN) (ExplicitTuple [HsVar a, HsVar b]))
637 = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
638 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
640 mk_index multiply_by (l, u, i)
642 (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
645 (HsApp (HsVar rangeSize_PN) (ExplicitTuple [HsVar l, HsVar u]))
646 ) (HsVar times_PN) multiply_by
650 = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
652 (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
653 ) (HsVar plus_PN) (HsLit (HsInt 1)))
657 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
658 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
660 in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
663 %************************************************************************
665 \subsubsection{Generating @Read@ instance declarations}
667 %************************************************************************
669 Ignoring all the infix-ery mumbo jumbo (ToDo)
672 gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
674 gen_Read_binds fixities tycon
675 = reads_prec `AndMonoBinds` read_list
677 -----------------------------------------------------------------------
678 read_list = mk_easy_FunMonoBind readList_PN [] []
679 (HsApp (HsVar readList___PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0)))))
680 -----------------------------------------------------------------------
683 read_con_comprehensions
684 = map read_con (tyConDataCons tycon)
686 mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
687 foldl1 append_Expr read_con_comprehensions
690 read_con data_con -- note: "b" is the string being "read"
692 data_con_PN = qual_orig_name data_con
693 data_con_str= nameOf (origName "gen_Read_binds" data_con)
694 con_arity = dataConNumFields data_con
695 as_needed = take con_arity as_PNs
696 bs_needed = take con_arity bs_PNs
697 con_expr = mk_easy_App data_con_PN as_needed
698 nullary_con = isNullaryDataCon data_con
702 (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
703 (HsApp (HsVar lex_PN) c_Expr)
705 field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed))
708 = if nullary_con then -- must be False (parens are surely optional)
710 else -- parens depend on precedence...
711 HsPar (OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9)))
714 readParen_Expr read_paren_arg $ HsPar $
715 HsLam (mk_easy_Match [c_Pat] [] (
716 ListComp (ExplicitTuple [con_expr,
717 if null bs_needed then d_Expr else HsVar (last bs_needed)])
718 (con_qual : field_quals)))
721 mk_qual draw_from (con_field, str_left)
722 = (HsVar str_left, -- what to draw from down the line...
724 (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
725 (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
728 %************************************************************************
730 \subsubsection{Generating @Show@ instance declarations}
732 %************************************************************************
734 Ignoring all the infix-ery mumbo jumbo (ToDo)
737 gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
739 gen_Show_binds fixities tycon
740 = shows_prec `AndMonoBinds` show_list
742 -----------------------------------------------------------------------
743 show_list = mk_easy_FunMonoBind showList_PN [] []
744 (HsApp (HsVar showList___PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))))
745 -----------------------------------------------------------------------
747 = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
751 data_con_PN = qual_orig_name data_con
752 con_arity = dataConNumFields data_con
753 bs_needed = take con_arity bs_PNs
754 con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
755 nullary_con = isNullaryDataCon data_con
758 = let (OrigName mod nm) = origName "gen_Show_binds" data_con
759 space_maybe = if nullary_con then _NIL_ else SLIT(" ")
761 HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe)))
763 show_thingies = show_con : (spacified real_show_thingies)
766 = [ HsApp (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 10))) (HsVar b)
769 if nullary_con then -- skip the showParen junk...
770 ASSERT(null bs_needed)
771 ([a_Pat, con_pat], show_con)
774 showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10))))
775 (HsPar (nested_compose_Expr show_thingies)))
779 spacified (x:xs) = (x : (HsVar showSpace_PN) : spacified xs)
782 %************************************************************************
784 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
786 %************************************************************************
791 con2tag_Foo :: Foo ... -> Int#
792 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
793 maxtag_Foo :: Int -- ditto (NB: not unboxed)
796 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
801 = GenCon2Tag | GenTag2Con | GenMaxTag
803 gen_tag_n_con_monobind
804 :: (RdrName, -- (proto)Name for the thing in question
805 TyCon, -- tycon in question
809 gen_tag_n_con_monobind (pn, tycon, GenCon2Tag)
810 = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
812 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
815 = ASSERT(isDataCon var)
816 ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
818 pat = ConPatIn var_PN (nOfThem (dataConNumFields var) WildPatIn)
819 var_PN = qual_orig_name var
821 gen_tag_n_con_monobind (pn, tycon, GenTag2Con)
822 = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
824 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
827 = ASSERT(isDataCon var)
828 ([lit_pat], HsVar var_PN)
830 lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
831 var_PN = qual_orig_name var
833 gen_tag_n_con_monobind (pn, tycon, GenMaxTag)
834 = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
836 max_tag = case (tyConDataCons tycon) of
837 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
840 %************************************************************************
842 \subsection{Utility bits for generating bindings}
844 %************************************************************************
846 @mk_easy_FunMonoBind fun pats binds expr@ generates:
848 fun pat1 pat2 ... patN = expr where binds
851 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
852 multi-clause definitions; it generates:
854 fun p1a p1b ... p1N = e1
855 fun p2a p2b ... p2N = e2
857 fun pMa pMb ... pMN = eM
861 mk_easy_FunMonoBind :: RdrName -> [RdrNamePat]
862 -> [RdrNameMonoBinds] -> RdrNameHsExpr
865 mk_easy_FunMonoBind fun pats binds expr
866 = FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
868 mk_easy_Match pats binds expr
869 = mk_match pats expr (mkbind binds)
871 mkbind [] = EmptyBinds
872 mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
873 -- The renamer expects everything in its input to be a
874 -- "recursive" MonoBinds, and it is its job to sort things out
877 mk_FunMonoBind :: RdrName
878 -> [([RdrNamePat], RdrNameHsExpr)]
881 mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
882 mk_FunMonoBind fun pats_and_exprs
883 = FunMonoBind fun False{-not infix-}
884 [ mk_match p e EmptyBinds | (p,e) <-pats_and_exprs ]
887 mk_match pats expr binds
889 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] binds))
892 paren p@(VarPatIn _) = p
893 paren other_p = ParPatIn other_p
897 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
901 compare_Case, cmp_eq_Expr ::
902 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
903 -> RdrNameHsExpr -> RdrNameHsExpr
907 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
908 -> RdrNameHsExpr -> RdrNameHsExpr
910 careful_compare_Case :: -- checks for primitive types...
912 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
913 -> RdrNameHsExpr -> RdrNameHsExpr
916 compare_Case = compare_gen_Case compare_PN
917 cmp_eq_Expr = compare_gen_Case cmp_eq_PN
919 compare_gen_Case fun lt eq gt a b
920 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
921 [PatMatch (ConPatIn ltTag_PN [])
922 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
924 PatMatch (ConPatIn eqTag_PN [])
925 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
927 PatMatch (ConPatIn gtTag_PN [])
928 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
931 careful_compare_Case ty lt eq gt a b
932 = if not (isPrimType ty) then
933 compare_gen_Case compare_PN lt eq gt a b
935 else -- we have to do something special for primitive things...
936 HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b))
938 (HsIf (HsPar (OpApp a (HsVar relevant_lt_op) b)) lt gt mkGeneratedSrcLoc)
941 relevant_eq_op = assoc_ty_id eq_op_tbl ty
942 relevant_lt_op = assoc_ty_id lt_op_tbl ty
945 = if null res then panic "assoc_ty"
948 res = [id | (ty',id) <- tyids, eqTy ty ty']
951 [(charPrimTy, eqH_Char_PN)
952 ,(intPrimTy, eqH_Int_PN)
953 ,(wordPrimTy, eqH_Word_PN)
954 ,(addrPrimTy, eqH_Addr_PN)
955 ,(floatPrimTy, eqH_Float_PN)
956 ,(doublePrimTy, eqH_Double_PN)
960 [(charPrimTy, ltH_Char_PN)
961 ,(intPrimTy, ltH_Int_PN)
962 ,(wordPrimTy, ltH_Word_PN)
963 ,(addrPrimTy, ltH_Addr_PN)
964 ,(floatPrimTy, ltH_Float_PN)
965 ,(doublePrimTy, ltH_Double_PN)
968 -----------------------------------------------------------------------
970 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
972 and_Expr a b = OpApp a (HsVar and_PN) b
973 append_Expr a b = OpApp a (HsVar append_PN) b
975 -----------------------------------------------------------------------
977 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
979 = if not (isPrimType ty) then
980 OpApp a (HsVar eq_PN) b
981 else -- we have to do something special for primitive things...
982 OpApp a (HsVar relevant_eq_op) b
984 relevant_eq_op = assoc_ty_id eq_op_tbl ty
988 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
989 untag_Expr tycon [] expr = expr
990 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
991 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
992 [PatMatch (VarPatIn put_tag_here)
993 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
996 grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
998 cmp_tags_Expr :: RdrName -- Comparison op
999 -> RdrName -> RdrName -- Things to compare
1000 -> RdrNameHsExpr -- What to return if true
1001 -> RdrNameHsExpr -- What to return if false
1004 cmp_tags_Expr op a b true_case false_case
1005 = HsIf (HsPar (OpApp (HsVar a) (HsVar op) (HsVar b))) true_case false_case mkGeneratedSrcLoc
1008 :: RdrNameHsExpr -> RdrNameHsExpr
1010 enum_from_then_to_Expr
1011 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1014 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_PN) f) t2
1015 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_PN) f) t) t2
1017 showParen_Expr, readParen_Expr
1018 :: RdrNameHsExpr -> RdrNameHsExpr
1021 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2
1022 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
1024 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1026 nested_compose_Expr [e] = parenify e
1027 nested_compose_Expr (e:es)
1028 = HsApp (HsApp (HsVar compose_PN) (parenify e)) (nested_compose_Expr es)
1030 parenify e@(HsVar _) = e
1031 parenify e = HsPar e
1035 qual_orig_name n = case (origName "qual_orig_name" n) of { OrigName m n -> Qual m n }
1037 a_PN = Unqual SLIT("a")
1038 b_PN = Unqual SLIT("b")
1039 c_PN = Unqual SLIT("c")
1040 d_PN = Unqual SLIT("d")
1041 ah_PN = Unqual SLIT("a#")
1042 bh_PN = Unqual SLIT("b#")
1043 ch_PN = Unqual SLIT("c#")
1044 dh_PN = Unqual SLIT("d#")
1045 cmp_eq_PN = Unqual SLIT("cmp_eq")
1046 rangeSize_PN = Qual iX SLIT("rangeSize")
1048 as_PNs = [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1049 bs_PNs = [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1050 cs_PNs = [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1052 eq_PN = preludeQual {-SLIT("Eq")-} SLIT("==")
1053 ne_PN = preludeQual {-SLIT("Eq")-} SLIT("/=")
1054 le_PN = preludeQual {-SLIT("Ord")-} SLIT("<=")
1055 lt_PN = preludeQual {-SLIT("Ord")-} SLIT("<")
1056 ge_PN = preludeQual {-SLIT("Ord")-} SLIT(">=")
1057 gt_PN = preludeQual {-SLIT("Ord")-} SLIT(">")
1058 max_PN = preludeQual {-SLIT("Ord")-} SLIT("max")
1059 min_PN = preludeQual {-SLIT("Ord")-} SLIT("min")
1060 compare_PN = preludeQual {-SLIT("Ord")-} SLIT("compare")
1061 minBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("minBound")
1062 maxBound_PN = preludeQual {-SLIT("Bounded")-} SLIT("maxBound")
1063 enumFrom_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFrom")
1064 enumFromTo_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromTo")
1065 enumFromThen_PN = preludeQual {-SLIT("Enum")-} SLIT("enumFromThen")
1066 enumFromThenTo_PN= preludeQual {-SLIT("Enum")-} SLIT("enumFromThenTo")
1067 range_PN = Qual iX SLIT("range")
1068 index_PN = Qual iX SLIT("index")
1069 inRange_PN = Qual iX SLIT("inRange")
1070 readsPrec_PN = preludeQual {-SLIT("Read")-} SLIT("readsPrec")
1071 readList_PN = preludeQual {-SLIT("Read")-} SLIT("readList")
1072 showsPrec_PN = preludeQual {-SLIT("Show")-} SLIT("showsPrec")
1073 showList_PN = preludeQual {-SLIT("Show")-} SLIT("showList")
1074 plus_PN = preludeQual {-SLIT("Num")-} SLIT("+")
1075 times_PN = preludeQual {-SLIT("Num")-} SLIT("*")
1076 ltTag_PN = preludeQual SLIT("LT")
1077 eqTag_PN = preludeQual SLIT("EQ")
1078 gtTag_PN = preludeQual SLIT("GT")
1080 eqH_Char_PN = prelude_primop CharEqOp
1081 ltH_Char_PN = prelude_primop CharLtOp
1082 eqH_Word_PN = prelude_primop WordEqOp
1083 ltH_Word_PN = prelude_primop WordLtOp
1084 eqH_Addr_PN = prelude_primop AddrEqOp
1085 ltH_Addr_PN = prelude_primop AddrLtOp
1086 eqH_Float_PN = prelude_primop FloatEqOp
1087 ltH_Float_PN = prelude_primop FloatLtOp
1088 eqH_Double_PN = prelude_primop DoubleEqOp
1089 ltH_Double_PN = prelude_primop DoubleLtOp
1090 eqH_Int_PN = prelude_primop IntEqOp
1091 ltH_Int_PN = prelude_primop IntLtOp
1092 geH_PN = prelude_primop IntGeOp
1093 leH_PN = prelude_primop IntLeOp
1094 minusH_PN = prelude_primop IntSubOp
1096 prelude_primop o = case (origName "prelude_primop" (primOpId o)) of { OrigName m n -> Qual m n }
1098 false_PN = preludeQual SLIT("False")
1099 true_PN = preludeQual SLIT("True")
1100 and_PN = preludeQual SLIT("&&")
1101 not_PN = preludeQual SLIT("not")
1102 append_PN = preludeQual SLIT("++")
1103 map_PN = preludeQual SLIT("map")
1104 compose_PN = preludeQual SLIT(".")
1105 mkInt_PN = preludeQual SLIT("I#")
1106 error_PN = preludeQual SLIT("error")
1107 showString_PN = preludeQual SLIT("showString")
1108 showParen_PN = preludeQual SLIT("showParen")
1109 readParen_PN = preludeQual SLIT("readParen")
1110 lex_PN = Qual gHC__ SLIT("lex")
1111 showSpace_PN = Qual gHC__ SLIT("showSpace")
1112 showList___PN = Qual gHC__ SLIT("showList__")
1113 readList___PN = Qual gHC__ SLIT("readList__")
1119 ltTag_Expr = HsVar ltTag_PN
1120 eqTag_Expr = HsVar eqTag_PN
1121 gtTag_Expr = HsVar gtTag_PN
1122 false_Expr = HsVar false_PN
1123 true_Expr = HsVar true_PN
1125 con2tag_Expr tycon = HsVar (con2tag_PN tycon)
1127 a_Pat = VarPatIn a_PN
1128 b_Pat = VarPatIn b_PN
1129 c_Pat = VarPatIn c_PN
1130 d_Pat = VarPatIn d_PN
1132 con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
1135 = let (OrigName mod nm) = origName "con2tag_PN" tycon
1136 con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
1141 = let (OrigName mod nm) = origName "tag2con_PN" tycon
1142 tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
1147 = let (OrigName mod nm) = origName "maxtag_PN" tycon
1148 maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")