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,
67 import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), Match(..), GRHSsAndBinds(..),
68 GRHS(..), HsExpr(..), HsLit(..), InPat(..), Qual(..), Stmt,
69 ArithSeqInfo, Sig, PolyType, FixityDecl, Fake )
70 import RdrHsSyn ( RdrNameMonoBinds(..), RdrNameHsExpr(..), RdrNamePat(..) )
71 import RnHsSyn ( RenamedFixityDecl(..) )
74 import Id ( GenId, dataConArity, isNullaryDataCon, dataConTag,
75 dataConRawArgTys, fIRST_TAG,
76 isDataCon, DataCon(..), ConTag(..) )
77 import IdUtils ( primOpId )
78 import Maybes ( maybeToBool )
79 import Name ( moduleNamePair, origName, RdrName(..) )
80 import PrelMods ( fromPrelude, pRELUDE, pRELUDE_BUILTIN, pRELUDE_LIST, pRELUDE_TEXT )
81 import PrelVals ( eRROR_ID )
83 import PrimOp ( PrimOp(..) )
84 import SrcLoc ( mkGeneratedSrcLoc )
85 import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
86 import Type ( eqTy, isPrimType )
87 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
88 floatPrimTy, doublePrimTy
90 import TysWiredIn ( falseDataCon, trueDataCon, intDataCon )
92 import Util ( mapAccumL, zipEqual, zipWith3Equal, nOfThem, panic, assertPanic )
95 %************************************************************************
97 \subsection{Generating code, by derivable class}
99 %************************************************************************
101 %************************************************************************
103 \subsubsection{Generating @Eq@ instance declarations}
105 %************************************************************************
107 Here are the heuristics for the code we generate for @Eq@:
110 Let's assume we have a data type with some (possibly zero) nullary
111 data constructors and some ordinary, non-nullary ones (the rest,
112 also possibly zero of them). Here's an example, with both \tr{N}ullary
113 and \tr{O}rdinary data cons.
115 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
119 For the ordinary constructors (if any), we emit clauses to do The
123 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
124 (==) (O2 a1) (O2 a2) = a1 == a2
125 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
128 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
129 \tr{a2} are \tr{Float#}s, then we have to generate
131 case (a1 `eqFloat#` a2) of
134 for that particular test.
137 If there are any nullary constructors, we emit a catch-all clause of
141 (==) a b = case (con2tag_Foo a) of { a# ->
142 case (con2tag_Foo b) of { b# ->
143 case (a# ==# b#) of {
148 If there aren't any nullary constructors, we emit a simpler
155 For the @(/=)@ method, we normally just use the default method.
157 If the type is an enumeration type, we could/may/should? generate
158 special code that calls @con2tag_Foo@, much like for @(==)@ shown
162 We thought about doing this: If we're also deriving @Ord@ for this
165 instance ... Eq (Foo ...) where
166 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
167 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
169 However, that requires that \tr{Ord <whatever>} was put in the context
170 for the instance decl, which it probably wasn't, so the decls
171 produced don't get through the typechecker.
175 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
179 (nullary_cons, nonnullary_cons)
180 = partition isNullaryDataCon (tyConDataCons tycon)
183 = if (null nullary_cons) then
184 case maybeTyConSingleCon tycon of
186 Nothing -> -- if cons don't match, then False
187 [([a_Pat, b_Pat], false_Expr)]
188 else -- calc. and compare the tags
190 untag_Expr tycon [(a_PN,ah_PN), (b_PN,bh_PN)]
191 (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN true_Expr false_Expr))]
193 mk_FunMonoBind eq_PN ((map pats_etc nonnullary_cons) ++ rest)
194 `AndMonoBinds` boring_ne_method
196 ------------------------------------------------------------------
199 con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
200 con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
202 data_con_PN = origName data_con
203 con_arity = dataConArity data_con
204 as_needed = take con_arity as_PNs
205 bs_needed = take con_arity bs_PNs
206 tys_needed = dataConRawArgTys data_con
208 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
210 nested_eq_expr [] [] [] = true_Expr
211 nested_eq_expr tys as bs
212 = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
214 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
216 nested_eq_expr [] [] [] = true_Expr
217 nested_eq_expr [ty] [a] [b] =
218 nested_eq_expr (t:ts) (a:as) (b:bs)
220 rest_expr = nested_eq_expr ts as bs
222 and_Expr (eq_Expr t (HsVar a) (HsVar b)) rest_expr
226 = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] $
227 HsApp (HsVar not_PN) (HsPar (mk_easy_App eq_PN [a_PN, b_PN]))
230 %************************************************************************
232 \subsubsection{Generating @Ord@ instance declarations}
234 %************************************************************************
236 For a derived @Ord@, we concentrate our attentions on @compare@
238 compare :: a -> a -> Ordering
239 data Ordering = LT | EQ | GT deriving ()
242 We will use the same example data type as above:
244 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
249 We do all the other @Ord@ methods with calls to @compare@:
251 instance ... (Ord <wurble> <wurble>) where
252 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
253 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
254 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
255 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
257 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
258 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
260 -- compare to come...
264 @compare@ always has two parts. First, we use the compared
265 data-constructors' tags to deal with the case of different
268 compare a b = case (con2tag_Foo a) of { a# ->
269 case (con2tag_Foo b) of { b# ->
270 case (a# ==# b#) of {
272 False -> case (a# <# b#) of
277 cmp_eq = ... to come ...
281 We are only left with the ``help'' function @cmp_eq@, to deal with
282 comparing data constructors with the same tag.
284 For the ordinary constructors (if any), we emit the sorta-obvious
285 compare-style stuff; for our example:
287 cmp_eq (O1 a1 b1) (O1 a2 b2)
288 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
290 cmp_eq (O2 a1) (O2 a2)
293 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
294 = case (compare a1 a2) of {
297 EQ -> case compare b1 b2 of {
305 Again, we must be careful about unboxed comparisons. For example,
306 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
309 cmp_eq lt eq gt (O2 a1) (O2 a2)
311 -- or maybe the unfolded equivalent
315 For the remaining nullary constructors, we already know that the
323 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
326 = defaulted `AndMonoBinds` compare
328 --------------------------------------------------------------------
329 compare = mk_easy_FunMonoBind compare_PN
332 (if maybeToBool (maybeTyConSingleCon tycon) then
333 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
335 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
336 (cmp_tags_Expr eqH_Int_PN ah_PN bh_PN
337 -- True case; they are equal
338 -- If an enumeration type we are done; else
339 -- recursively compare their components
340 (if isEnumerationTyCon tycon then
343 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
345 -- False case; they aren't equal
346 -- So we need to do a less-than comparison on the tags
347 (cmp_tags_Expr ltH_Int_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
349 (nullary_cons, nonnullary_cons)
350 = partition (\ con -> dataConArity con == 0) (tyConDataCons tycon)
353 = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
356 = ([con1_pat, con2_pat],
357 nested_compare_expr tys_needed as_needed bs_needed)
359 con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
360 con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
362 data_con_PN = origName data_con
363 con_arity = dataConArity data_con
364 as_needed = take con_arity as_PNs
365 bs_needed = take con_arity bs_PNs
366 tys_needed = dataConRawArgTys data_con
368 nested_compare_expr [ty] [a] [b]
369 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
371 nested_compare_expr (ty:tys) (a:as) (b:bs)
372 = let eq_expr = nested_compare_expr tys as bs
373 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
376 = if null nullary_cons
378 else [([a_Pat, b_Pat], eqTag_Expr)]
379 --------------------------------------------------------------------
381 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
383 lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
384 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
385 le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
386 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
387 ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
388 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
389 gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
390 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
392 max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
393 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
394 min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
395 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
398 %************************************************************************
400 \subsubsection{Generating @Enum@ instance declarations}
402 %************************************************************************
404 @Enum@ can only be derived for enumeration types. For a type
406 data Foo ... = N1 | N2 | ... | Nn
409 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
410 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
413 instance ... Enum (Foo ...) where
414 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
418 = case con2tag_Foo a of
419 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
422 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
426 = case con2tag_Foo a of { a# ->
427 case con2tag_Foo b of { b# ->
428 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
432 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
435 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
438 = enum_from `AndMonoBinds` enum_from_then
441 = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] $
442 untag_Expr tycon [(a_PN, ah_PN)] $
443 HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
444 HsPar (enum_from_to_Expr
445 (mk_easy_App mkInt_PN [ah_PN])
446 (HsVar (maxtag_PN tycon)))
449 = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] $
450 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] $
451 HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
452 HsPar (enum_from_then_to_Expr
453 (mk_easy_App mkInt_PN [ah_PN])
454 (mk_easy_App mkInt_PN [bh_PN])
455 (HsVar (maxtag_PN tycon)))
458 %************************************************************************
460 \subsubsection{Generating @Eval@ instance declarations}
462 %************************************************************************
465 gen_Eval_binds tycon = EmptyMonoBinds
468 %************************************************************************
470 \subsubsection{Generating @Bounded@ instance declarations}
472 %************************************************************************
475 gen_Bounded_binds tycon
476 = if isEnumerationTyCon tycon then
477 min_bound_enum `AndMonoBinds` max_bound_enum
479 ASSERT(length data_cons == 1)
480 min_bound_1con `AndMonoBinds` max_bound_1con
482 data_cons = tyConDataCons tycon
484 ----- enum-flavored: ---------------------------
485 min_bound_enum = mk_easy_FunMonoBind minBound_PN [] [] (HsVar data_con_1_PN)
486 max_bound_enum = mk_easy_FunMonoBind maxBound_PN [] [] (HsVar data_con_N_PN)
488 data_con_1 = head data_cons
489 data_con_N = last data_cons
490 data_con_1_PN = origName data_con_1
491 data_con_N_PN = origName data_con_N
493 ----- single-constructor-flavored: -------------
494 arity = dataConArity data_con_1
496 min_bound_1con = mk_easy_FunMonoBind minBound_PN [] [] $
497 mk_easy_App data_con_1_PN (nOfThem arity minBound_PN)
498 max_bound_1con = mk_easy_FunMonoBind maxBound_PN [] [] $
499 mk_easy_App data_con_1_PN (nOfThem arity maxBound_PN)
502 %************************************************************************
504 \subsubsection{Generating @Ix@ instance declarations}
506 %************************************************************************
508 Deriving @Ix@ is only possible for enumeration types and
509 single-constructor types. We deal with them in turn.
511 For an enumeration type, e.g.,
513 data Foo ... = N1 | N2 | ... | Nn
515 things go not too differently from @Enum@:
517 instance ... Ix (Foo ...) where
519 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
523 = case (con2tag_Foo a) of { a# ->
524 case (con2tag_Foo b) of { b# ->
525 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
530 then case (con2tag_Foo d -# con2tag_Foo a) of
532 else error "Ix.Foo.index: out of range"
536 p_tag = con2tag_Foo c
538 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
542 = case (con2tag_Foo a) of { a_tag ->
543 case (con2tag_Foo b) of { b_tag ->
544 case (con2tag_Foo c) of { c_tag ->
545 if (c_tag >=# a_tag) then
551 (modulo suitable case-ification to handle the unboxed tags)
553 For a single-constructor type (NB: this includes all tuples), e.g.,
555 data Foo ... = MkFoo a b Int Double c c
557 we follow the scheme given in Figure~19 of the Haskell~1.2 report
561 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
564 = if isEnumerationTyCon tycon
568 tycon_str = _UNPK_ (snd (moduleNamePair tycon))
570 --------------------------------------------------------------
571 enum_ixes = enum_range `AndMonoBinds`
572 enum_index `AndMonoBinds` enum_inRange
575 = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] $
576 untag_Expr tycon [(a_PN, ah_PN)] $
577 untag_Expr tycon [(b_PN, bh_PN)] $
578 HsApp (mk_easy_App map_PN [tag2con_PN tycon]) $
579 HsPar (enum_from_to_Expr
580 (mk_easy_App mkInt_PN [ah_PN])
581 (mk_easy_App mkInt_PN [bh_PN]))
584 = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
585 HsIf (HsPar (mk_easy_App inRange_PN [c_PN, d_PN])) (
586 untag_Expr tycon [(a_PN, ah_PN)] (
587 untag_Expr tycon [(d_PN, dh_PN)] (
589 grhs = [OtherwiseGRHS (mk_easy_App mkInt_PN [c_PN]) mkGeneratedSrcLoc]
592 (HsPar (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN)))
593 [PatMatch (VarPatIn c_PN)
594 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
598 HsApp (HsVar error_PN) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
603 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
604 untag_Expr tycon [(a_PN, ah_PN)] (
605 untag_Expr tycon [(b_PN, bh_PN)] (
606 untag_Expr tycon [(c_PN, ch_PN)] (
607 HsIf (HsPar (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN))) (
608 (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
611 ) mkGeneratedSrcLoc))))
613 --------------------------------------------------------------
614 single_con_ixes = single_con_range `AndMonoBinds`
615 single_con_index `AndMonoBinds` single_con_inRange
618 = case maybeTyConSingleCon tycon of -- just checking...
619 Nothing -> panic "get_Ix_binds"
620 Just dc -> if (any isPrimType (dataConRawArgTys dc)) then
621 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
625 con_arity = dataConArity data_con
626 data_con_PN = origName data_con
627 con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
628 con_expr xs = mk_easy_App data_con_PN xs
630 as_needed = take con_arity as_PNs
631 bs_needed = take con_arity bs_PNs
632 cs_needed = take con_arity cs_PNs
634 --------------------------------------------------------------
636 = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
637 ListComp (con_expr cs_needed) (zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed)
640 mk_qual a b c = GeneratorQual (VarPatIn c)
641 (HsApp (HsVar range_PN) (ExplicitTuple [HsVar a, HsVar b]))
645 = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
646 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
648 mk_index multiply_by (l, u, i)
650 (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
653 (HsApp (HsVar rangeSize_PN) (ExplicitTuple [HsVar l, HsVar u]))
654 ) (HsVar times_PN) multiply_by
658 = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
660 (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
661 ) (HsVar plus_PN) (HsLit (HsInt 1)))
665 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
666 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
668 in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
671 %************************************************************************
673 \subsubsection{Generating @Read@ instance declarations}
675 %************************************************************************
677 Ignoring all the infix-ery mumbo jumbo (ToDo)
680 gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
682 gen_Read_binds fixities tycon
683 = reads_prec `AndMonoBinds` read_list
685 -----------------------------------------------------------------------
686 read_list = mk_easy_FunMonoBind readList_PN [] []
687 (HsApp (HsVar _readList_PN) (HsPar (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0)))))
688 -----------------------------------------------------------------------
691 read_con_comprehensions
692 = map read_con (tyConDataCons tycon)
694 mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
695 foldl1 append_Expr read_con_comprehensions
698 read_con data_con -- note: "b" is the string being "read"
700 data_con_PN = origName data_con
701 data_con_str= snd (moduleNamePair data_con)
702 con_arity = dataConArity data_con
703 as_needed = take con_arity as_PNs
704 bs_needed = take con_arity bs_PNs
705 con_expr = mk_easy_App data_con_PN as_needed
706 nullary_con = isNullaryDataCon data_con
710 (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
711 (HsApp (HsVar lex_PN) c_Expr)
713 field_quals = snd (mapAccumL mk_qual d_Expr (zipEqual "as_needed" as_needed bs_needed))
716 = if nullary_con then -- must be False (parens are surely optional)
718 else -- parens depend on precedence...
719 HsPar (OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9)))
722 readParen_Expr read_paren_arg $ HsPar $
723 HsLam (mk_easy_Match [c_Pat] [] (
724 ListComp (ExplicitTuple [con_expr,
725 if null bs_needed then d_Expr else HsVar (last bs_needed)])
726 (con_qual : field_quals)))
729 mk_qual draw_from (con_field, str_left)
730 = (HsVar str_left, -- what to draw from down the line...
732 (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
733 (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
736 %************************************************************************
738 \subsubsection{Generating @Show@ instance declarations}
740 %************************************************************************
742 Ignoring all the infix-ery mumbo jumbo (ToDo)
745 gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
747 gen_Show_binds fixities tycon
748 = shows_prec `AndMonoBinds` show_list
750 -----------------------------------------------------------------------
751 show_list = mk_easy_FunMonoBind showList_PN [] []
752 (HsApp (HsVar _showList_PN) (HsPar (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0)))))
753 -----------------------------------------------------------------------
755 = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
759 data_con_PN = origName data_con
760 con_arity = dataConArity data_con
761 bs_needed = take con_arity bs_PNs
762 con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
763 nullary_con = isNullaryDataCon data_con
766 = let (mod, nm) = moduleNamePair data_con
767 space_maybe = if nullary_con then _NIL_ else SLIT(" ")
769 HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe)))
771 show_thingies = show_con : (spacified real_show_thingies)
774 = [ HsApp (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 10))) (HsVar b)
777 if nullary_con then -- skip the showParen junk...
778 ASSERT(null bs_needed)
779 ([a_Pat, con_pat], show_con)
782 showParen_Expr (HsPar (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10))))
783 (HsPar (nested_compose_Expr show_thingies)))
787 spacified (x:xs) = (x : (HsVar showSpace_PN) : spacified xs)
790 %************************************************************************
792 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
794 %************************************************************************
799 con2tag_Foo :: Foo ... -> Int#
800 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
801 maxtag_Foo :: Int -- ditto (NB: not unboxed)
804 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
809 = GenCon2Tag | GenTag2Con | GenMaxTag
811 gen_tag_n_con_monobind
812 :: (RdrName, -- (proto)Name for the thing in question
813 TyCon, -- tycon in question
817 gen_tag_n_con_monobind (pn, tycon, GenCon2Tag)
818 = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
820 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
823 = ASSERT(isDataCon var)
824 ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
826 pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn)
827 var_PN = origName var
829 gen_tag_n_con_monobind (pn, tycon, GenTag2Con)
830 = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
832 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
835 = ASSERT(isDataCon var)
836 ([lit_pat], HsVar var_PN)
838 lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
839 var_PN = origName var
841 gen_tag_n_con_monobind (pn, tycon, GenMaxTag)
842 = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
844 max_tag = case (tyConDataCons tycon) of
845 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
848 %************************************************************************
850 \subsection{Utility bits for generating bindings}
852 %************************************************************************
854 @mk_easy_FunMonoBind fun pats binds expr@ generates:
856 fun pat1 pat2 ... patN = expr where binds
859 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
860 multi-clause definitions; it generates:
862 fun p1a p1b ... p1N = e1
863 fun p2a p2b ... p2N = e2
865 fun pMa pMb ... pMN = eM
869 mk_easy_FunMonoBind :: RdrName -> [RdrNamePat]
870 -> [RdrNameMonoBinds] -> RdrNameHsExpr
873 mk_easy_FunMonoBind fun pats binds expr
874 = FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
876 mk_easy_Match pats binds expr
877 = mk_match pats expr (mkbind binds)
879 mkbind [] = EmptyBinds
880 mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
881 -- The renamer expects everything in its input to be a
882 -- "recursive" MonoBinds, and it is its job to sort things out
885 mk_FunMonoBind :: RdrName
886 -> [([RdrNamePat], RdrNameHsExpr)]
889 mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
890 mk_FunMonoBind fun pats_and_exprs
891 = FunMonoBind fun False{-not infix-}
892 [ mk_match p e EmptyBinds | (p,e) <-pats_and_exprs ]
895 mk_match pats expr binds
897 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] binds))
900 paren p@(VarPatIn _) = p
901 paren other_p = ParPatIn other_p
905 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
909 compare_Case, cmp_eq_Expr ::
910 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
911 -> RdrNameHsExpr -> RdrNameHsExpr
915 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
916 -> RdrNameHsExpr -> RdrNameHsExpr
918 careful_compare_Case :: -- checks for primitive types...
920 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
921 -> RdrNameHsExpr -> RdrNameHsExpr
924 compare_Case = compare_gen_Case compare_PN
925 cmp_eq_Expr = compare_gen_Case cmp_eq_PN
927 compare_gen_Case fun lt eq gt a b
928 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
929 [PatMatch (ConPatIn ltTag_PN [])
930 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
932 PatMatch (ConPatIn eqTag_PN [])
933 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
935 PatMatch (ConPatIn gtTag_PN [])
936 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
939 careful_compare_Case ty lt eq gt a b
940 = if not (isPrimType ty) then
941 compare_gen_Case compare_PN lt eq gt a b
943 else -- we have to do something special for primitive things...
944 HsIf (HsPar (OpApp a (HsVar relevant_eq_op) b))
946 (HsIf (HsPar (OpApp a (HsVar relevant_lt_op) b)) lt gt mkGeneratedSrcLoc)
949 relevant_eq_op = assoc_ty_id eq_op_tbl ty
950 relevant_lt_op = assoc_ty_id lt_op_tbl ty
953 = if null res then panic "assoc_ty"
956 res = [id | (ty',id) <- tyids, eqTy ty ty']
959 [(charPrimTy, eqH_Char_PN)
960 ,(intPrimTy, eqH_Int_PN)
961 ,(wordPrimTy, eqH_Word_PN)
962 ,(addrPrimTy, eqH_Addr_PN)
963 ,(floatPrimTy, eqH_Float_PN)
964 ,(doublePrimTy, eqH_Double_PN)
968 [(charPrimTy, ltH_Char_PN)
969 ,(intPrimTy, ltH_Int_PN)
970 ,(wordPrimTy, ltH_Word_PN)
971 ,(addrPrimTy, ltH_Addr_PN)
972 ,(floatPrimTy, ltH_Float_PN)
973 ,(doublePrimTy, ltH_Double_PN)
976 -----------------------------------------------------------------------
978 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
980 and_Expr a b = OpApp a (HsVar and_PN) b
981 append_Expr a b = OpApp a (HsVar append_PN) b
983 -----------------------------------------------------------------------
985 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
987 = if not (isPrimType ty) then
988 OpApp a (HsVar eq_PN) b
989 else -- we have to do something special for primitive things...
990 OpApp a (HsVar relevant_eq_op) b
992 relevant_eq_op = assoc_ty_id eq_op_tbl ty
996 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
997 untag_Expr tycon [] expr = expr
998 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
999 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1000 [PatMatch (VarPatIn put_tag_here)
1001 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
1004 grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
1006 cmp_tags_Expr :: RdrName -- Comparison op
1007 -> RdrName -> RdrName -- Things to compare
1008 -> RdrNameHsExpr -- What to return if true
1009 -> RdrNameHsExpr -- What to return if false
1012 cmp_tags_Expr op a b true_case false_case
1013 = HsIf (HsPar (OpApp (HsVar a) (HsVar op) (HsVar b))) true_case false_case mkGeneratedSrcLoc
1016 :: RdrNameHsExpr -> RdrNameHsExpr
1018 enum_from_then_to_Expr
1019 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1022 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_PN) f) t2
1023 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_PN) f) t) t2
1025 showParen_Expr, readParen_Expr
1026 :: RdrNameHsExpr -> RdrNameHsExpr
1029 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2
1030 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
1032 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1034 nested_compose_Expr [e] = parenify e
1035 nested_compose_Expr (e:es)
1036 = HsApp (HsApp (HsVar compose_PN) (parenify e)) (nested_compose_Expr es)
1038 parenify e@(HsVar _) = e
1039 parenify e = HsPar e
1043 a_PN = Unqual SLIT("a")
1044 b_PN = Unqual SLIT("b")
1045 c_PN = Unqual SLIT("c")
1046 d_PN = Unqual SLIT("d")
1047 ah_PN = Unqual SLIT("a#")
1048 bh_PN = Unqual SLIT("b#")
1049 ch_PN = Unqual SLIT("c#")
1050 dh_PN = Unqual SLIT("d#")
1051 cmp_eq_PN = Unqual SLIT("cmp_eq")
1052 rangeSize_PN = Unqual SLIT("rangeSize")
1054 as_PNs = [ Unqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1055 bs_PNs = [ Unqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1056 cs_PNs = [ Unqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1058 eq_PN = prelude_method SLIT("Eq") SLIT("==")
1059 ne_PN = prelude_method SLIT("Eq") SLIT("/=")
1060 le_PN = prelude_method SLIT("Ord") SLIT("<=")
1061 lt_PN = prelude_method SLIT("Ord") SLIT("<")
1062 ge_PN = prelude_method SLIT("Ord") SLIT(">=")
1063 gt_PN = prelude_method SLIT("Ord") SLIT(">")
1064 max_PN = prelude_method SLIT("Ord") SLIT("max")
1065 min_PN = prelude_method SLIT("Ord") SLIT("min")
1066 compare_PN = prelude_method SLIT("Ord") SLIT("compare")
1067 minBound_PN = prelude_method SLIT("Bounded") SLIT("minBound")
1068 maxBound_PN = prelude_method SLIT("Bounded") SLIT("maxBound")
1069 ltTag_PN = Unqual SLIT("LT")
1070 eqTag_PN = Unqual SLIT("EQ")
1071 gtTag_PN = Unqual SLIT("GT")
1072 enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom")
1073 enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo")
1074 enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen")
1075 enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo")
1076 range_PN = prelude_method SLIT("Ix") SLIT("range")
1077 index_PN = prelude_method SLIT("Ix") SLIT("index")
1078 inRange_PN = prelude_method SLIT("Ix") SLIT("inRange")
1079 readsPrec_PN = prelude_method SLIT("Read") SLIT("readsPrec")
1080 readList_PN = prelude_method SLIT("Read") SLIT("readList")
1081 showsPrec_PN = prelude_method SLIT("Show") SLIT("showsPrec")
1082 showList_PN = prelude_method SLIT("Show") SLIT("showList")
1083 plus_PN = prelude_method SLIT("Num") SLIT("+")
1084 times_PN = prelude_method SLIT("Num") SLIT("*")
1086 false_PN = prelude_val pRELUDE SLIT("False")
1087 true_PN = prelude_val pRELUDE SLIT("True")
1088 eqH_Char_PN = prelude_primop CharEqOp
1089 ltH_Char_PN = prelude_primop CharLtOp
1090 eqH_Word_PN = prelude_primop WordEqOp
1091 ltH_Word_PN = prelude_primop WordLtOp
1092 eqH_Addr_PN = prelude_primop AddrEqOp
1093 ltH_Addr_PN = prelude_primop AddrLtOp
1094 eqH_Float_PN = prelude_primop FloatEqOp
1095 ltH_Float_PN = prelude_primop FloatLtOp
1096 eqH_Double_PN = prelude_primop DoubleEqOp
1097 ltH_Double_PN = prelude_primop DoubleLtOp
1098 eqH_Int_PN = prelude_primop IntEqOp
1099 ltH_Int_PN = prelude_primop IntLtOp
1100 geH_PN = prelude_primop IntGeOp
1101 leH_PN = prelude_primop IntLeOp
1102 minusH_PN = prelude_primop IntSubOp
1103 and_PN = prelude_val pRELUDE SLIT("&&")
1104 not_PN = prelude_val pRELUDE SLIT("not")
1105 append_PN = prelude_val pRELUDE_LIST SLIT("++")
1106 map_PN = prelude_val pRELUDE_LIST SLIT("map")
1107 compose_PN = prelude_val pRELUDE SLIT(".")
1108 mkInt_PN = prelude_val pRELUDE_BUILTIN SLIT("I#")
1109 error_PN = prelude_val pRELUDE SLIT("error")
1110 showString_PN = prelude_val pRELUDE_TEXT SLIT("showString")
1111 showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen")
1112 readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen")
1113 lex_PN = prelude_val pRELUDE_TEXT SLIT("lex")
1114 showSpace_PN = prelude_val pRELUDE_TEXT SLIT("__showSpace")
1115 _showList_PN = prelude_val pRELUDE SLIT("__showList")
1116 _readList_PN = prelude_val pRELUDE SLIT("__readList")
1118 prelude_val m s = Unqual s
1119 prelude_method c o = Unqual o
1120 prelude_primop o = origName (primOpId o)
1126 ltTag_Expr = HsVar ltTag_PN
1127 eqTag_Expr = HsVar eqTag_PN
1128 gtTag_Expr = HsVar gtTag_PN
1129 false_Expr = HsVar false_PN
1130 true_Expr = HsVar true_PN
1132 con2tag_Expr tycon = HsVar (con2tag_PN tycon)
1134 a_Pat = VarPatIn a_PN
1135 b_Pat = VarPatIn b_PN
1136 c_Pat = VarPatIn c_PN
1137 d_Pat = VarPatIn d_PN
1139 con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
1142 = let (mod, nm) = moduleNamePair tycon
1143 con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
1145 (if fromPrelude mod then Unqual else Qual mod) con2tag
1148 = let (mod, nm) = moduleNamePair tycon
1149 tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
1151 (if fromPrelude mod then Unqual else Qual mod) tag2con
1154 = let (mod, nm) = moduleNamePair tycon
1155 maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
1157 (if fromPrelude mod then Unqual else Qual mod) maxtag