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"
14 module TcGenDeriv {- (
46 gen_tag_n_con_monobind,
59 con2tag_FN, tag2con_FN, maxtag_FN,
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 ( RnName(..), RenamedFixityDecl(..) )
73 --import RnMonad4 -- initRn4, etc.
76 import Id ( GenId, dataConArity, dataConTag,
77 dataConSig, fIRST_TAG,
78 isDataCon, DataCon(..), ConTag(..) )
79 import IdUtils ( primOpId )
80 import Maybes ( maybeToBool )
81 --import Name ( Name(..) )
86 import SrcLoc ( mkGeneratedSrcLoc )
87 import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
88 import Type ( eqTy, isPrimType )
93 %************************************************************************
95 \subsection[TcGenDeriv-classes]{Generating code, by derivable class}
97 %************************************************************************
99 %************************************************************************
101 \subsubsection[TcGenDeriv-Eq]{Generating @Eq@ instance declarations}
103 %************************************************************************
105 Here are the heuristics for the code we generate for @Eq@:
108 Let's assume we have a data type with some (possibly zero) nullary
109 data constructors and some ordinary, non-nullary ones (the rest,
110 also possibly zero of them). Here's an example, with both \tr{N}ullary
111 and \tr{O}rdinary data cons.
113 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
117 For the ordinary constructors (if any), we emit clauses to do The
121 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
122 (==) (O2 a1) (O2 a2) = a1 == a2
123 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
126 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
127 \tr{a2} are \tr{Float#}s, then we have to generate
129 case (a1 `eqFloat#` a2) of
132 for that particular test.
135 If there are any nullary constructors, we emit a catch-all clause of
139 (==) a b = case (con2tag_Foo a) of { a# ->
140 case (con2tag_Foo b) of { b# ->
141 case (a# ==# b#) of {
146 If there aren't any nullary constructors, we emit a simpler
153 For the @(/=)@ method, we normally just use the default method.
155 If the type is an enumeration type, we could/may/should? generate
156 special code that calls @con2tag_Foo@, much like for @(==)@ shown
160 We thought about doing this: If we're also deriving @Ord@ for this
163 instance ... Eq (Foo ...) where
164 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
165 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
167 However, that requires that \tr{Ord <whatever>} was put in the context
168 for the instance decl, which it probably wasn't, so the decls
169 produced don't get through the typechecker.
173 foo_TcGenDeriv = panic "Nothing in TcGenDeriv LATER ToDo"
176 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
179 = case (partition (\ con -> dataConArity con == 0)
180 (tyConDataCons tycon))
181 of { (nullary_cons, nonnullary_cons) ->
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_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
198 ------------------------------------------------------------------
201 con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
202 con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
204 data_con_PN = Prel (WiredInId data_con)
205 as_needed = take (dataConArity data_con) as_PNs
206 bs_needed = take (dataConArity data_con) bs_PNs
207 tys_needed = case (dataConSig data_con) of
208 (_,_, arg_tys, _) -> arg_tys
210 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
212 nested_eq_expr [] [] [] = true_Expr
213 nested_eq_expr [ty] [a] [b] = eq_Expr ty (HsVar a) (HsVar b)
214 nested_eq_expr (t:ts) (a:as) (b:bs)
216 rest_expr = nested_eq_expr ts as bs
218 and_Expr (eq_Expr t (HsVar a) (HsVar b)) rest_expr
221 = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] (
222 HsApp (HsVar not_PN) (HsApp (HsApp (HsVar eq_PN) a_Expr) b_Expr)
226 %************************************************************************
228 \subsubsection[TcGenDeriv-Ord]{Generating @Ord@ instance declarations}
230 %************************************************************************
232 For a derived @Ord@, we concentrate our attentions on @compare@
234 compare :: a -> a -> Ordering
235 data Ordering = LT | EQ | GT deriving ()
238 We will use the same example data type as above:
240 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
245 We do all the other @Ord@ methods with calls to @compare@:
247 instance ... (Ord <wurble> <wurble>) where
248 a < b = case compare a b of { LT -> True; EQ -> False; GT -> False }
249 a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False }
250 a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True }
251 a > b = case compare a b of { LT -> False; EQ -> False; GT -> True }
253 max a b = case compare a b of { LT -> b; EQ -> a; GT -> a }
254 min a b = case compare a b of { LT -> a; EQ -> b; GT -> b }
256 -- compare to come...
260 @compare@ always has two parts. First, we use the compared
261 data-constructors' tags to deal with the case of different
264 compare a b = case (con2tag_Foo a) of { a# ->
265 case (con2tag_Foo b) of { b# ->
266 case (a# ==# b#) of {
268 False -> case (a# <# b#) of
273 cmp_eq = ... to come ...
277 We are only left with the ``help'' function @cmp_eq@, to deal with
278 comparing data constructors with the same tag.
280 For the ordinary constructors (if any), we emit the sorta-obvious
281 compare-style stuff; for our example:
283 cmp_eq (O1 a1 b1) (O1 a2 b2)
284 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
286 cmp_eq (O2 a1) (O2 a2)
289 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
290 = case (compare a1 a2) of {
293 EQ -> case compare b1 b2 of {
301 Again, we must be careful about unboxed comparisons. For example,
302 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
305 cmp_eq lt eq gt (O2 a1) (O2 a2)
307 -- or maybe the unfolded equivalent
311 For the remaining nullary constructors, we already know that the
319 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
322 = defaulted `AndMonoBinds` compare
324 --------------------------------------------------------------------
325 compare = mk_easy_FunMonoBind compare_PN
328 (if maybeToBool (maybeTyConSingleCon tycon) then
329 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
331 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
332 (cmp_tags_Expr eqH_PN ah_PN bh_PN
333 -- True case; they are equal
334 -- If an enumeration type we are done; else
335 -- recursively compare their components
336 (if isEnumerationTyCon tycon then
339 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
341 -- False case; they aren't equal
342 -- So we need to do a less-than comparison on the tags
343 (cmp_tags_Expr ltH_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
345 (nullary_cons, nonnullary_cons)
346 = partition (\ con -> dataConArity con == 0) (tyConDataCons tycon)
349 = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
352 = ([con1_pat, con2_pat],
353 nested_compare_expr tys_needed as_needed bs_needed)
355 con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
356 con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
358 data_con_PN = Prel (WiredInId data_con)
359 as_needed = take (dataConArity data_con) as_PNs
360 bs_needed = take (dataConArity data_con) bs_PNs
361 tys_needed = case (dataConSig data_con) of
362 (_,_, arg_tys, _) -> arg_tys
364 nested_compare_expr [ty] [a] [b]
365 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
367 nested_compare_expr (ty:tys) (a:as) (b:bs)
368 = let eq_expr = nested_compare_expr tys as bs
369 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
372 = if null nullary_cons
374 else [([a_Pat, b_Pat], eqTag_Expr)]
375 --------------------------------------------------------------------
377 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
379 lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
380 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
381 le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
382 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
383 ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
384 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
385 gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
386 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
388 max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
389 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
390 min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
391 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
394 %************************************************************************
396 \subsubsection[TcGenDeriv-Enum]{Generating @Enum@ instance declarations}
398 %************************************************************************
400 @Enum@ can only be derived for enumeration types. For a type
402 data Foo ... = N1 | N2 | ... | Nn
405 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
406 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
409 instance ... Enum (Foo ...) where
410 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
414 = case con2tag_Foo a of
415 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
418 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
422 = case con2tag_Foo a of { a# ->
423 case con2tag_Foo b of { b# ->
424 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
428 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
431 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
434 = enum_from `AndMonoBinds` enum_from_then
437 = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] (
438 untag_Expr tycon [(a_PN, ah_PN)] (
439 HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
441 (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
442 (HsVar (maxtag_PN tycon)))))
445 = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] (
446 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] (
447 HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
448 enum_from_then_to_Expr
449 (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
450 (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
451 (HsVar (maxtag_PN tycon)))))
454 %************************************************************************
456 \subsubsection[TcGenDeriv-Ix]{Generating @Ix@ instance declarations}
458 %************************************************************************
460 Deriving @Ix@ is only possible for enumeration types and
461 single-constructor types. We deal with them in turn.
463 For an enumeration type, e.g.,
465 data Foo ... = N1 | N2 | ... | Nn
467 things go not too differently from @Enum@:
469 instance ... Ix (Foo ...) where
471 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
475 = case (con2tag_Foo a) of { a# ->
476 case (con2tag_Foo b) of { b# ->
477 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
482 then case (con2tag_Foo d -# con2tag_Foo a) of
484 else error "Ix.Foo.index: out of range"
488 p_tag = con2tag_Foo c
490 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
494 = case (con2tag_Foo a) of { a_tag ->
495 case (con2tag_Foo b) of { b_tag ->
496 case (con2tag_Foo c) of { c_tag ->
497 if (c_tag >=# a_tag) then
503 (modulo suitable case-ification to handle the unboxed tags)
505 For a single-constructor type (NB: this includes all tuples), e.g.,
507 data Foo ... = MkFoo a b Int Double c c
509 we follow the scheme given in Figure~19 of the Haskell~1.2 report
513 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
516 = if isEnumerationTyCon tycon
520 tycon_str = _UNPK_ (snd (moduleNamePair tycon))
522 --------------------------------------------------------------
523 enum_ixes = enum_range `AndMonoBinds`
524 enum_index `AndMonoBinds` enum_inRange
527 = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] (
528 untag_Expr tycon [(a_PN, ah_PN)] (
529 untag_Expr tycon [(b_PN, bh_PN)] (
530 HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
532 (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
533 (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
537 = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
538 HsIf (HsApp (HsApp (HsVar inRange_PN) c_Expr) d_Expr) (
539 untag_Expr tycon [(a_PN, ah_PN)] (
540 untag_Expr tycon [(d_PN, dh_PN)] (
542 grhs = [OtherwiseGRHS (HsApp (HsVar mkInt_PN) (HsVar c_PN)) mkGeneratedSrcLoc]
545 (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN))
546 [PatMatch (VarPatIn c_PN)
547 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
551 HsApp (HsVar error_PN) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
556 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
557 untag_Expr tycon [(a_PN, ah_PN)] (
558 untag_Expr tycon [(b_PN, bh_PN)] (
559 untag_Expr tycon [(c_PN, ch_PN)] (
560 HsIf (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN)) (
561 (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
564 ) mkGeneratedSrcLoc))))
566 --------------------------------------------------------------
567 single_con_ixes = single_con_range `AndMonoBinds`
568 single_con_index `AndMonoBinds` single_con_inRange
571 = case maybeTyConSingleCon tycon of -- just checking...
572 Nothing -> panic "get_Ix_binds"
574 (_, _, arg_tys, _) = dataConSig dc
576 if any isPrimType arg_tys then
577 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
581 con_arity = dataConArity data_con
582 data_con_PN = Prel (WiredInId data_con)
583 con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
584 con_expr xs = foldl HsApp (HsVar data_con_PN) (map HsVar xs)
586 as_needed = take (dataConArity data_con) as_PNs
587 bs_needed = take (dataConArity data_con) bs_PNs
588 cs_needed = take (dataConArity data_con) cs_PNs
590 --------------------------------------------------------------
592 = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
593 ListComp (con_expr cs_needed) (zipWith3Equal mk_qual as_needed bs_needed cs_needed)
596 mk_qual a b c = GeneratorQual (VarPatIn c)
597 (HsApp (HsVar range_PN) (ExplicitTuple [HsVar a, HsVar b]))
601 = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
602 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
604 mk_index multiply_by (l, u, i)
606 (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
609 (HsApp (HsVar rangeSize_PN) (ExplicitTuple [HsVar l, HsVar u]))
610 ) (HsVar times_PN) multiply_by
614 = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
616 (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
617 ) (HsVar plus_PN) (HsLit (HsInt 1)))
621 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
622 foldl1 and_Expr (zipWith3Equal in_range as_needed bs_needed cs_needed))
624 in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
627 %************************************************************************
629 \subsubsection[TcGenDeriv-Text]{Generating @Show@ and @Read@ instance declarations}
631 %************************************************************************
633 Ignoring all the infix-ery mumbo jumbo (ToDo)
636 gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
637 gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> RdrNameMonoBinds
639 gen_Read_binds fixities tycon
640 = reads_prec `AndMonoBinds` read_list
642 -----------------------------------------------------------------------
643 read_list = mk_easy_FunMonoBind readList_PN [] []
644 (HsApp (HsVar _readList_PN) (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))
645 -----------------------------------------------------------------------
648 read_con_comprehensions
649 = map read_con (tyConDataCons tycon)
651 mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
652 foldl1 append_Expr read_con_comprehensions
655 read_con data_con -- note: "b" is the string being "read"
657 data_con_PN = Prel (WiredInId data_con)
658 data_con_str= snd (moduleNamePair data_con)
659 as_needed = take (dataConArity data_con) as_PNs
660 bs_needed = take (dataConArity data_con) bs_PNs
661 con_expr = foldl HsApp (HsVar data_con_PN) (map HsVar as_needed)
662 nullary_con = dataConArity data_con == 0
666 (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
667 (HsApp (HsVar lex_PN) c_Expr)
669 field_quals = snd (mapAccumL mk_qual d_Expr (as_needed `zip` bs_needed))
672 = if nullary_con then -- must be False (parens are surely optional)
674 else -- parens depend on precedence...
675 OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9))
678 readParen_Expr read_paren_arg (
679 HsLam (mk_easy_Match [c_Pat] [] (
680 ListComp (ExplicitTuple [con_expr,
681 if null bs_needed then d_Expr else HsVar (last bs_needed)])
682 (con_qual : field_quals)))
685 mk_qual draw_from (con_field, str_left)
686 = (HsVar str_left, -- what to draw from down the line...
688 (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
689 (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
692 gen_Show_binds fixities tycon
693 = shows_prec `AndMonoBinds` show_list
695 -----------------------------------------------------------------------
696 show_list = mk_easy_FunMonoBind showList_PN [] []
697 (HsApp (HsVar _showList_PN) (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0))))
698 -----------------------------------------------------------------------
700 = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
704 data_con_PN = Prel (WiredInId data_con)
705 bs_needed = take (dataConArity data_con) bs_PNs
706 con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
707 nullary_con = dataConArity data_con == 0
710 = let (mod, nm) = moduleNamePair data_con
711 space_maybe = if nullary_con then _NIL_ else SLIT(" ")
713 HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe)))
715 show_thingies = show_con : (spacified real_show_thingies)
718 = [ HsApp (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 10))) (HsVar b)
721 if nullary_con then -- skip the showParen junk...
722 ASSERT(null bs_needed)
723 ([a_Pat, con_pat], show_con)
726 showParen_Expr (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10)))
727 (nested_compose_Expr show_thingies))
731 spacified (x:xs) = (x : (HsVar showSpace_PN) : spacified xs)
734 %************************************************************************
736 \subsubsection[TcGenDeriv-Binary]{Generating @Binary@ instance declarations}
738 %************************************************************************
743 gen_Binary_binds :: TyCon -> RdrNameMonoBinds
745 gen_Binary_binds tycon
746 = panic "gen_Binary_binds"
749 %************************************************************************
751 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
753 %************************************************************************
758 con2tag_Foo :: Foo ... -> Int#
759 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
760 maxtag_Foo :: Int -- ditto (NB: not unboxed)
763 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
768 = GenCon2Tag | GenTag2Con | GenMaxTag
770 gen_tag_n_con_monobind
771 :: (RdrName, RnName, -- (proto)Name for the thing in question
772 TyCon, -- tycon in question
776 gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
777 = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
779 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
782 = ASSERT(isDataCon var)
783 ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
785 pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn)
786 var_PN = Prel (WiredInId var)
788 gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
789 = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
791 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
794 = ASSERT(isDataCon var)
795 ([lit_pat], HsVar var_PN)
797 lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
798 var_PN = Prel (WiredInId var)
800 gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
801 = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
803 max_tag = case (tyConDataCons tycon) of
804 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
807 %************************************************************************
809 \subsection[TcGenDeriv-bind-utils]{Utility bits for generating bindings}
811 %************************************************************************
813 @mk_easy_FunMonoBind fun pats binds expr@ generates:
815 fun pat1 pat2 ... patN = expr where binds
818 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
819 multi-clause definitions; it generates:
821 fun p1a p1b ... p1N = e1
822 fun p2a p2b ... p2N = e2
824 fun pMa pMb ... pMN = eM
828 mk_easy_FunMonoBind :: RdrName -> [RdrNamePat]
829 -> [RdrNameMonoBinds] -> RdrNameHsExpr
832 mk_easy_FunMonoBind fun pats binds expr
833 = FunMonoBind fun False{-not infix-} [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
835 mk_easy_Match pats binds expr
837 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds)))
840 mkbind [] = EmptyBinds
841 mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
842 -- The renamer expects everything in its input to be a
843 -- "recursive" MonoBinds, and it is its job to sort things out
846 mk_FunMonoBind :: RdrName
847 -> [([RdrNamePat], RdrNameHsExpr)]
850 mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
851 mk_FunMonoBind fun pats_and_exprs
852 = FunMonoBind fun False{-not infix-} (map mk_match pats_and_exprs) mkGeneratedSrcLoc
854 mk_match (pats, expr)
856 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] EmptyBinds))
861 compare_Case, cmp_eq_Expr ::
862 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
863 -> RdrNameHsExpr -> RdrNameHsExpr
867 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
868 -> RdrNameHsExpr -> RdrNameHsExpr
870 careful_compare_Case :: -- checks for primitive types...
872 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
873 -> RdrNameHsExpr -> RdrNameHsExpr
876 compare_Case = compare_gen_Case compare_PN
877 cmp_eq_Expr = compare_gen_Case cmp_eq_PN
879 compare_gen_Case fun lt eq gt a b
880 = HsCase (HsApp (HsApp (HsVar fun) a) b) {-of-}
881 [PatMatch (ConPatIn ltTag_PN [])
882 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
884 PatMatch (ConPatIn eqTag_PN [])
885 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
887 PatMatch (ConPatIn gtTag_PN [])
888 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
891 careful_compare_Case ty lt eq gt a b
892 = if not (isPrimType ty) then
893 compare_gen_Case compare_PN lt eq gt a b
895 else -- we have to do something special for primitive things...
896 HsIf (OpApp a (HsVar relevant_eq_op) b)
898 (HsIf (OpApp a (HsVar relevant_lt_op) b) lt gt mkGeneratedSrcLoc)
901 relevant_eq_op = assoc_ty_id eq_op_tbl ty
902 relevant_lt_op = assoc_ty_id lt_op_tbl ty
905 = if null res then panic "assoc_ty"
908 res = [id | (ty',id) <- tyids, eqTy ty ty']
911 (charPrimTy, Prel (WiredInId (primOpId CharEqOp))),
912 (intPrimTy, Prel (WiredInId (primOpId IntEqOp))),
913 (wordPrimTy, Prel (WiredInId (primOpId WordEqOp))),
914 (addrPrimTy, Prel (WiredInId (primOpId AddrEqOp))),
915 (floatPrimTy, Prel (WiredInId (primOpId FloatEqOp))),
916 (doublePrimTy, Prel (WiredInId (primOpId DoubleEqOp))) ]
919 (charPrimTy, Prel (WiredInId (primOpId CharLtOp))),
920 (intPrimTy, Prel (WiredInId (primOpId IntLtOp))),
921 (wordPrimTy, Prel (WiredInId (primOpId WordLtOp))),
922 (addrPrimTy, Prel (WiredInId (primOpId AddrLtOp))),
923 (floatPrimTy, Prel (WiredInId (primOpId FloatLtOp))),
924 (doublePrimTy, Prel (WiredInId (primOpId DoubleLtOp))) ]
926 -----------------------------------------------------------------------
928 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
930 and_Expr a b = OpApp a (HsVar and_PN) b
931 append_Expr a b = OpApp a (HsVar append_PN) b
933 -----------------------------------------------------------------------
935 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
937 = if not (isPrimType ty) then
938 OpApp a (HsVar eq_PN) b
939 else -- we have to do something special for primitive things...
940 OpApp a (HsVar relevant_eq_op) b
942 relevant_eq_op = assoc_ty_id eq_op_tbl ty
946 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
947 untag_Expr tycon [] expr = expr
948 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
949 = HsCase (HsApp (con2tag_Expr tycon) (HsVar untag_this)) {-of-}
950 [PatMatch (VarPatIn put_tag_here)
951 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
954 grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
956 cmp_tags_Expr :: RdrName -- Comparison op
957 -> RdrName -> RdrName -- Things to compare
958 -> RdrNameHsExpr -- What to return if true
959 -> RdrNameHsExpr -- What to return if false
962 cmp_tags_Expr op a b true_case false_case
963 = HsIf (OpApp (HsVar a) (HsVar op) (HsVar b)) true_case false_case mkGeneratedSrcLoc
966 :: RdrNameHsExpr -> RdrNameHsExpr
968 enum_from_then_to_Expr
969 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
972 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_PN) f) t2
973 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_PN) f) t) t2
975 showParen_Expr, readParen_Expr
976 :: RdrNameHsExpr -> RdrNameHsExpr
979 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2
980 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
982 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
984 nested_compose_Expr [e] = e
985 nested_compose_Expr (e:es)
986 = HsApp (HsApp (HsVar compose_PN) e) (nested_compose_Expr es)
994 ah_PN = Unk SLIT("a#")
995 bh_PN = Unk SLIT("b#")
996 ch_PN = Unk SLIT("c#")
997 dh_PN = Unk SLIT("d#")
998 cmp_eq_PN = Unk SLIT("cmp_eq")
999 rangeSize_PN = Unk SLIT("rangeSize")
1001 as_PNs = [ Unk (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1002 bs_PNs = [ Unk (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1003 cs_PNs = [ Unk (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1005 eq_PN = prelude_method SLIT("Eq") SLIT("==")
1006 ne_PN = prelude_method SLIT("Eq") SLIT("/=")
1007 le_PN = prelude_method SLIT("Ord") SLIT("<=")
1008 lt_PN = prelude_method SLIT("Ord") SLIT("<")
1009 ge_PN = prelude_method SLIT("Ord") SLIT(">=")
1010 gt_PN = prelude_method SLIT("Ord") SLIT(">")
1011 max_PN = prelude_method SLIT("Ord") SLIT("max")
1012 min_PN = prelude_method SLIT("Ord") SLIT("min")
1013 compare_PN = prelude_method SLIT("Ord") SLIT("compare")
1014 ltTag_PN = Prel (WiredInId ltDataCon)
1015 eqTag_PN = Prel (WiredInId eqDataCon)
1016 gtTag_PN = Prel (WiredInId gtDataCon)
1017 enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom")
1018 enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo")
1019 enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen")
1020 enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo")
1021 range_PN = prelude_method SLIT("Ix") SLIT("range")
1022 index_PN = prelude_method SLIT("Ix") SLIT("index")
1023 inRange_PN = prelude_method SLIT("Ix") SLIT("inRange")
1024 readsPrec_PN = prelude_method SLIT("Read") SLIT("readsPrec")
1025 readList_PN = prelude_method SLIT("Read") SLIT("readList")
1026 showsPrec_PN = prelude_method SLIT("Show") SLIT("showsPrec")
1027 showList_PN = prelude_method SLIT("Show") SLIT("showList")
1028 plus_PN = prelude_method SLIT("Num") SLIT("+")
1029 times_PN = prelude_method SLIT("Num") SLIT("*")
1031 false_PN = Prel (WiredInId falseDataCon)
1032 true_PN = Prel (WiredInId trueDataCon)
1033 eqH_PN = Prel (WiredInId (primOpId IntEqOp))
1034 geH_PN = Prel (WiredInId (primOpId IntGeOp))
1035 leH_PN = Prel (WiredInId (primOpId IntLeOp))
1036 ltH_PN = Prel (WiredInId (primOpId IntLtOp))
1037 minusH_PN = Prel (WiredInId (primOpId IntSubOp))
1038 and_PN = prelude_val pRELUDE SLIT("&&")
1039 not_PN = prelude_val pRELUDE SLIT("not")
1040 append_PN = prelude_val pRELUDE_LIST SLIT("++")
1041 map_PN = prelude_val pRELUDE_LIST SLIT("map")
1042 compose_PN = prelude_val pRELUDE SLIT(".")
1043 mkInt_PN = Prel (WiredInId intDataCon)
1044 error_PN = Prel (WiredInId eRROR_ID)
1045 showSpace_PN = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std
1046 showString_PN = prelude_val pRELUDE_TEXT SLIT("showString")
1047 showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen")
1048 readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen")
1049 lex_PN = prelude_val pRELUDE_TEXT SLIT("lex")
1050 _showList_PN = prelude_val pRELUDE_CORE SLIT("_showList")
1051 _readList_PN = prelude_val pRELUDE_CORE SLIT("_readList")
1053 prelude_val m s = Imp m s [m] s
1054 prelude_method c o = Imp pRELUDE_CORE o [pRELUDE_CORE] o -- class not used...
1060 ltTag_Expr = HsVar ltTag_PN
1061 eqTag_Expr = HsVar eqTag_PN
1062 gtTag_Expr = HsVar gtTag_PN
1063 false_Expr = HsVar false_PN
1064 true_Expr = HsVar true_PN
1066 con2tag_Expr tycon = HsVar (con2tag_PN tycon)
1068 a_Pat = VarPatIn a_PN
1069 b_Pat = VarPatIn b_PN
1070 c_Pat = VarPatIn c_PN
1071 d_Pat = VarPatIn d_PN
1074 con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> RdrName
1077 = let (mod, nm) = moduleNamePair tycon
1078 con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
1080 Imp mod con2tag [mod] con2tag
1083 = let (mod, nm) = moduleNamePair tycon
1084 tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
1086 Imp mod tag2con [mod] tag2con
1089 = let (mod, nm) = moduleNamePair tycon
1090 maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
1092 Imp mod maxtag [mod] maxtag
1095 con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> RnName
1098 = let (mod, nm) = moduleNamePair tycon
1099 tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
1101 mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc
1104 = let (mod, nm) = moduleNamePair tycon
1105 maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
1107 mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc
1110 = let (mod, nm) = moduleNamePair tycon
1111 con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
1113 mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc