2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
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"
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 ( ProtoNameMonoBinds(..), ProtoNameHsExpr(..), ProtoNamePat(..) )
71 import RnHsSyn ( 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(..) )
82 import NameTypes ( mkFullName, Provenance(..) )
87 import ProtoName ( ProtoName(..) )
88 import SrcLoc ( mkGeneratedSrcLoc )
89 import TyCon ( TyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
90 import Type ( eqTy, isPrimType )
95 %************************************************************************
97 \subsection[TcGenDeriv-classes]{Generating code, by derivable class}
99 %************************************************************************
101 %************************************************************************
103 \subsubsection[TcGenDeriv-Eq]{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 -> ProtoNameMonoBinds
178 = case (partition (\ con -> dataConArity con == 0)
179 (tyConDataCons tycon))
180 of { (nullary_cons, nonnullary_cons) ->
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_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
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 = Prel (WiredInVal data_con)
204 as_needed = take (dataConArity data_con) as_PNs
205 bs_needed = take (dataConArity data_con) bs_PNs
206 tys_needed = case (dataConSig data_con) of
207 (_,_, arg_tys, _) -> arg_tys
209 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
211 nested_eq_expr [] [] [] = true_Expr
212 nested_eq_expr [ty] [a] [b] = eq_Expr ty (HsVar a) (HsVar b)
213 nested_eq_expr (t:ts) (a:as) (b:bs)
215 rest_expr = nested_eq_expr ts as bs
217 and_Expr (eq_Expr t (HsVar a) (HsVar b)) rest_expr
220 = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] (
221 HsApp (HsVar not_PN) (HsApp (HsApp (HsVar eq_PN) a_Expr) b_Expr)
225 %************************************************************************
227 \subsubsection[TcGenDeriv-Ord]{Generating @Ord@ instance declarations}
229 %************************************************************************
231 For a derived @Ord@, we concentrate our attentions on @compare@
233 compare :: a -> a -> Ordering
234 data Ordering = LT | EQ | GT deriving ()
237 We will use the same example data type as above:
239 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
244 We do all the other @Ord@ methods with calls to @compare@:
246 instance ... (Ord <wurble> <wurble>) where
247 a < b = case compare a b of { LT -> True; EQ -> False; GT -> False }
248 a <= b = case compare a b of { LT -> True; EQ -> True; GT -> False }
249 a >= b = case compare a b of { LT -> False; EQ -> True; GT -> True }
250 a > b = case compare a b of { LT -> False; EQ -> False; GT -> True }
252 max a b = case compare a b of { LT -> b; EQ -> a; GT -> a }
253 min a b = case compare a b of { LT -> a; EQ -> b; GT -> b }
255 -- compare to come...
259 @compare@ always has two parts. First, we use the compared
260 data-constructors' tags to deal with the case of different
263 compare a b = case (con2tag_Foo a) of { a# ->
264 case (con2tag_Foo b) of { b# ->
265 case (a# ==# b#) of {
267 False -> case (a# <# b#) of
272 cmp_eq = ... to come ...
276 We are only left with the ``help'' function @cmp_eq@, to deal with
277 comparing data constructors with the same tag.
279 For the ordinary constructors (if any), we emit the sorta-obvious
280 compare-style stuff; for our example:
282 cmp_eq (O1 a1 b1) (O1 a2 b2)
283 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
285 cmp_eq (O2 a1) (O2 a2)
288 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
289 = case (compare a1 a2) of {
292 EQ -> case compare b1 b2 of {
300 Again, we must be careful about unboxed comparisons. For example,
301 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
304 cmp_eq lt eq gt (O2 a1) (O2 a2)
306 -- or maybe the unfolded equivalent
310 For the remaining nullary constructors, we already know that the
318 gen_Ord_binds :: TyCon -> ProtoNameMonoBinds
321 = defaulted `AndMonoBinds` compare
323 --------------------------------------------------------------------
324 compare = mk_easy_FunMonoBind compare_PN
327 (if maybeToBool (maybeTyConSingleCon tycon) then
328 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
330 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
331 (cmp_tags_Expr eqH_PN ah_PN bh_PN
332 -- True case; they are equal
333 -- If an enumeration type we are done; else
334 -- recursively compare their components
335 (if isEnumerationTyCon tycon then
338 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
340 -- False case; they aren't equal
341 -- So we need to do a less-than comparison on the tags
342 (cmp_tags_Expr ltH_PN ah_PN bh_PN ltTag_Expr gtTag_Expr)))
344 (nullary_cons, nonnullary_cons)
345 = partition (\ con -> dataConArity con == 0) (tyConDataCons tycon)
348 = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
351 = ([con1_pat, con2_pat],
352 nested_compare_expr tys_needed as_needed bs_needed)
354 con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
355 con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
357 data_con_PN = Prel (WiredInVal data_con)
358 as_needed = take (dataConArity data_con) as_PNs
359 bs_needed = take (dataConArity data_con) bs_PNs
360 tys_needed = case (dataConSig data_con) of
361 (_,_, arg_tys, _) -> arg_tys
363 nested_compare_expr [ty] [a] [b]
364 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
366 nested_compare_expr (ty:tys) (a:as) (b:bs)
367 = let eq_expr = nested_compare_expr tys as bs
368 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
371 = if null nullary_cons
373 else [([a_Pat, b_Pat], eqTag_Expr)]
374 --------------------------------------------------------------------
376 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
378 lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
379 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
380 le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
381 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
382 ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
383 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
384 gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
385 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
387 max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
388 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
389 min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
390 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
393 %************************************************************************
395 \subsubsection[TcGenDeriv-Enum]{Generating @Enum@ instance declarations}
397 %************************************************************************
399 @Enum@ can only be derived for enumeration types. For a type
401 data Foo ... = N1 | N2 | ... | Nn
404 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
405 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
408 instance ... Enum (Foo ...) where
409 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
413 = case con2tag_Foo a of
414 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
417 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
421 = case con2tag_Foo a of { a# ->
422 case con2tag_Foo b of { b# ->
423 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
427 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
430 gen_Enum_binds :: TyCon -> ProtoNameMonoBinds
433 = enum_from `AndMonoBinds` enum_from_then
436 = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] (
437 untag_Expr tycon [(a_PN, ah_PN)] (
438 HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
440 (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
441 (HsVar (maxtag_PN tycon)))))
444 = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] (
445 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] (
446 HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
447 enum_from_then_to_Expr
448 (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
449 (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
450 (HsVar (maxtag_PN tycon)))))
453 %************************************************************************
455 \subsubsection[TcGenDeriv-Ix]{Generating @Ix@ instance declarations}
457 %************************************************************************
459 Deriving @Ix@ is only possible for enumeration types and
460 single-constructor types. We deal with them in turn.
462 For an enumeration type, e.g.,
464 data Foo ... = N1 | N2 | ... | Nn
466 things go not too differently from @Enum@:
468 instance ... Ix (Foo ...) where
470 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
474 = case (con2tag_Foo a) of { a# ->
475 case (con2tag_Foo b) of { b# ->
476 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
481 then case (con2tag_Foo d -# con2tag_Foo a) of
483 else error "Ix.Foo.index: out of range"
487 p_tag = con2tag_Foo c
489 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
493 = case (con2tag_Foo a) of { a_tag ->
494 case (con2tag_Foo b) of { b_tag ->
495 case (con2tag_Foo c) of { c_tag ->
496 if (c_tag >=# a_tag) then
502 (modulo suitable case-ification to handle the unboxed tags)
504 For a single-constructor type (NB: this includes all tuples), e.g.,
506 data Foo ... = MkFoo a b Int Double c c
508 we follow the scheme given in Figure~19 of the Haskell~1.2 report
512 gen_Ix_binds :: TyCon -> ProtoNameMonoBinds
515 = if isEnumerationTyCon tycon
519 tycon_str = _UNPK_ (snd (getOrigName tycon))
521 --------------------------------------------------------------
522 enum_ixes = enum_range `AndMonoBinds`
523 enum_index `AndMonoBinds` enum_inRange
526 = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] (
527 untag_Expr tycon [(a_PN, ah_PN)] (
528 untag_Expr tycon [(b_PN, bh_PN)] (
529 HsApp (HsApp (HsVar map_PN) (HsVar (tag2con_PN tycon))) (
531 (HsApp (HsVar mkInt_PN) (HsVar ah_PN))
532 (HsApp (HsVar mkInt_PN) (HsVar bh_PN))
536 = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
537 HsIf (HsApp (HsApp (HsVar inRange_PN) c_Expr) d_Expr) (
538 untag_Expr tycon [(a_PN, ah_PN)] (
539 untag_Expr tycon [(d_PN, dh_PN)] (
541 grhs = [OtherwiseGRHS (HsApp (HsVar mkInt_PN) (HsVar c_PN)) mkGeneratedSrcLoc]
544 (OpApp (HsVar dh_PN) (HsVar minusH_PN) (HsVar ah_PN))
545 [PatMatch (VarPatIn c_PN)
546 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
550 HsApp (HsVar error_PN) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
555 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
556 untag_Expr tycon [(a_PN, ah_PN)] (
557 untag_Expr tycon [(b_PN, bh_PN)] (
558 untag_Expr tycon [(c_PN, ch_PN)] (
559 HsIf (OpApp (HsVar ch_PN) (HsVar geH_PN) (HsVar ah_PN)) (
560 (OpApp (HsVar ch_PN) (HsVar leH_PN) (HsVar bh_PN))
563 ) mkGeneratedSrcLoc))))
565 --------------------------------------------------------------
566 single_con_ixes = single_con_range `AndMonoBinds`
567 single_con_index `AndMonoBinds` single_con_inRange
570 = case maybeTyConSingleCon tycon of -- just checking...
571 Nothing -> panic "get_Ix_binds"
573 (_, _, arg_tys, _) = dataConSig dc
575 if any isPrimType arg_tys then
576 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
580 con_arity = dataConArity data_con
581 data_con_PN = Prel (WiredInVal data_con)
582 con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
583 con_expr xs = foldl HsApp (HsVar data_con_PN) (map HsVar xs)
585 as_needed = take (dataConArity data_con) as_PNs
586 bs_needed = take (dataConArity data_con) bs_PNs
587 cs_needed = take (dataConArity data_con) cs_PNs
589 --------------------------------------------------------------
591 = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
592 ListComp (con_expr cs_needed) (zipWith3Equal mk_qual as_needed bs_needed cs_needed)
595 mk_qual a b c = GeneratorQual (VarPatIn c)
596 (HsApp (HsVar range_PN) (ExplicitTuple [HsVar a, HsVar b]))
600 = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
601 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
603 mk_index multiply_by (l, u, i)
605 (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
608 (HsApp (HsVar rangeSize_PN) (ExplicitTuple [HsVar l, HsVar u]))
609 ) (HsVar times_PN) multiply_by
613 = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
615 (HsApp (HsApp (HsVar index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
616 ) (HsVar plus_PN) (HsLit (HsInt 1)))
620 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
621 foldl1 and_Expr (zipWith3Equal in_range as_needed bs_needed cs_needed))
623 in_range a b c = HsApp (HsApp (HsVar inRange_PN) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
626 %************************************************************************
628 \subsubsection[TcGenDeriv-Text]{Generating @Show@ and @Read@ instance declarations}
630 %************************************************************************
632 Ignoring all the infix-ery mumbo jumbo (ToDo)
635 gen_Read_binds :: [RenamedFixityDecl] -> TyCon -> ProtoNameMonoBinds
636 gen_Show_binds :: [RenamedFixityDecl] -> TyCon -> ProtoNameMonoBinds
638 gen_Read_binds fixities tycon
639 = reads_prec `AndMonoBinds` read_list
641 -----------------------------------------------------------------------
642 read_list = mk_easy_FunMonoBind readList_PN [] []
643 (HsApp (HsVar _readList_PN) (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 0))))
644 -----------------------------------------------------------------------
647 read_con_comprehensions
648 = map read_con (tyConDataCons tycon)
650 mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
651 foldl1 append_Expr read_con_comprehensions
654 read_con data_con -- note: "b" is the string being "read"
656 data_con_PN = Prel (WiredInVal data_con)
657 data_con_str= snd (getOrigName data_con)
658 as_needed = take (dataConArity data_con) as_PNs
659 bs_needed = take (dataConArity data_con) bs_PNs
660 con_expr = foldl HsApp (HsVar data_con_PN) (map HsVar as_needed)
661 nullary_con = dataConArity data_con == 0
665 (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
666 (HsApp (HsVar lex_PN) c_Expr)
668 field_quals = snd (mapAccumL mk_qual d_Expr (as_needed `zip` bs_needed))
671 = if nullary_con then -- must be False (parens are surely optional)
673 else -- parens depend on precedence...
674 OpApp a_Expr (HsVar gt_PN) (HsLit (HsInt 9))
677 readParen_Expr read_paren_arg (
678 HsLam (mk_easy_Match [c_Pat] [] (
679 ListComp (ExplicitTuple [con_expr,
680 if null bs_needed then d_Expr else HsVar (last bs_needed)])
681 (con_qual : field_quals)))
684 mk_qual draw_from (con_field, str_left)
685 = (HsVar str_left, -- what to draw from down the line...
687 (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
688 (HsApp (HsApp (HsVar readsPrec_PN) (HsLit (HsInt 10))) draw_from))
691 gen_Show_binds fixities tycon
692 = shows_prec `AndMonoBinds` show_list
694 -----------------------------------------------------------------------
695 show_list = mk_easy_FunMonoBind showList_PN [] []
696 (HsApp (HsVar _showList_PN) (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 0))))
697 -----------------------------------------------------------------------
699 = mk_FunMonoBind showsPrec_PN (map pats_etc (tyConDataCons tycon))
703 data_con_PN = Prel (WiredInVal data_con)
704 bs_needed = take (dataConArity data_con) bs_PNs
705 con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
706 nullary_con = dataConArity data_con == 0
709 = let (mod, nm) = getOrigName data_con
710 space_maybe = if nullary_con then _NIL_ else SLIT(" ")
712 HsApp (HsVar showString_PN) (HsLit (HsString (nm _APPEND_ space_maybe)))
714 show_thingies = show_con : (spacified real_show_thingies)
717 = [ HsApp (HsApp (HsVar showsPrec_PN) (HsLit (HsInt 10))) (HsVar b)
720 if nullary_con then -- skip the showParen junk...
721 ASSERT(null bs_needed)
722 ([a_Pat, con_pat], show_con)
725 showParen_Expr (OpApp a_Expr (HsVar ge_PN) (HsLit (HsInt 10)))
726 (nested_compose_Expr show_thingies))
730 spacified (x:xs) = (x : (HsVar showSpace_PN) : spacified xs)
733 %************************************************************************
735 \subsubsection[TcGenDeriv-Binary]{Generating @Binary@ instance declarations}
737 %************************************************************************
742 gen_Binary_binds :: TyCon -> ProtoNameMonoBinds
744 gen_Binary_binds tycon
745 = panic "gen_Binary_binds"
748 %************************************************************************
750 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
752 %************************************************************************
757 con2tag_Foo :: Foo ... -> Int#
758 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
759 maxtag_Foo :: Int -- ditto (NB: not unboxed)
762 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
767 = GenCon2Tag | GenTag2Con | GenMaxTag
769 gen_tag_n_con_monobind
770 :: (ProtoName, Name, -- (proto)Name for the thing in question
771 TyCon, -- tycon in question
773 -> ProtoNameMonoBinds
775 gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
776 = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
778 mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
781 = ASSERT(isDataCon var)
782 ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
784 pat = ConPatIn var_PN (nOfThem (dataConArity var) WildPatIn)
785 var_PN = Prel (WiredInVal var)
787 gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
788 = mk_FunMonoBind pn (map mk_stuff (tyConDataCons tycon))
790 mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameHsExpr)
793 = ASSERT(isDataCon var)
794 ([lit_pat], HsVar var_PN)
796 lit_pat = ConPatIn mkInt_PN [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
797 var_PN = Prel (WiredInVal var)
799 gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
800 = mk_easy_FunMonoBind pn [] [] (HsApp (HsVar mkInt_PN) (HsLit (HsIntPrim max_tag)))
802 max_tag = case (tyConDataCons tycon) of
803 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
806 %************************************************************************
808 \subsection[TcGenDeriv-bind-utils]{Utility bits for generating bindings}
810 %************************************************************************
812 @mk_easy_FunMonoBind fun pats binds expr@ generates:
814 fun pat1 pat2 ... patN = expr where binds
817 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
818 multi-clause definitions; it generates:
820 fun p1a p1b ... p1N = e1
821 fun p2a p2b ... p2N = e2
823 fun pMa pMb ... pMN = eM
827 mk_easy_FunMonoBind :: ProtoName -> [ProtoNamePat]
828 -> [ProtoNameMonoBinds] -> ProtoNameHsExpr
829 -> ProtoNameMonoBinds
831 mk_easy_FunMonoBind fun pats binds expr
832 = FunMonoBind fun [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
834 mk_easy_Match pats binds expr
836 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds)))
839 mkbind [] = EmptyBinds
840 mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
841 -- The renamer expects everything in its input to be a
842 -- "recursive" MonoBinds, and it is its job to sort things out
845 mk_FunMonoBind :: ProtoName
846 -> [([ProtoNamePat], ProtoNameHsExpr)]
847 -> ProtoNameMonoBinds
849 mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
850 mk_FunMonoBind fun pats_and_exprs
851 = FunMonoBind fun (map mk_match pats_and_exprs) mkGeneratedSrcLoc
853 mk_match (pats, expr)
855 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] EmptyBinds))
860 compare_Case, cmp_eq_Expr ::
861 ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
862 -> ProtoNameHsExpr -> ProtoNameHsExpr
866 -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
867 -> ProtoNameHsExpr -> ProtoNameHsExpr
869 careful_compare_Case :: -- checks for primitive types...
871 -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
872 -> ProtoNameHsExpr -> ProtoNameHsExpr
875 compare_Case = compare_gen_Case compare_PN
876 cmp_eq_Expr = compare_gen_Case cmp_eq_PN
878 compare_gen_Case fun lt eq gt a b
879 = HsCase (HsApp (HsApp (HsVar fun) a) b) {-of-}
880 [PatMatch (ConPatIn ltTag_PN [])
881 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
883 PatMatch (ConPatIn eqTag_PN [])
884 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
886 PatMatch (ConPatIn gtTag_PN [])
887 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
890 careful_compare_Case ty lt eq gt a b
891 = if not (isPrimType ty) then
892 compare_gen_Case compare_PN lt eq gt a b
894 else -- we have to do something special for primitive things...
895 HsIf (OpApp a (HsVar relevant_eq_op) b)
897 (HsIf (OpApp a (HsVar relevant_lt_op) b) lt gt mkGeneratedSrcLoc)
900 relevant_eq_op = assoc_ty_id eq_op_tbl ty
901 relevant_lt_op = assoc_ty_id lt_op_tbl ty
904 = if null res then panic "assoc_ty"
907 res = [id | (ty',id) <- tyids, eqTy ty ty']
910 (charPrimTy, Prel (WiredInVal (primOpId CharEqOp))),
911 (intPrimTy, Prel (WiredInVal (primOpId IntEqOp))),
912 (wordPrimTy, Prel (WiredInVal (primOpId WordEqOp))),
913 (addrPrimTy, Prel (WiredInVal (primOpId AddrEqOp))),
914 (floatPrimTy, Prel (WiredInVal (primOpId FloatEqOp))),
915 (doublePrimTy, Prel (WiredInVal (primOpId DoubleEqOp))) ]
918 (charPrimTy, Prel (WiredInVal (primOpId CharLtOp))),
919 (intPrimTy, Prel (WiredInVal (primOpId IntLtOp))),
920 (wordPrimTy, Prel (WiredInVal (primOpId WordLtOp))),
921 (addrPrimTy, Prel (WiredInVal (primOpId AddrLtOp))),
922 (floatPrimTy, Prel (WiredInVal (primOpId FloatLtOp))),
923 (doublePrimTy, Prel (WiredInVal (primOpId DoubleLtOp))) ]
925 -----------------------------------------------------------------------
927 and_Expr, append_Expr :: ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
929 and_Expr a b = OpApp a (HsVar and_PN) b
930 append_Expr a b = OpApp a (HsVar append_PN) b
932 -----------------------------------------------------------------------
934 eq_Expr :: Type -> ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
936 = if not (isPrimType ty) then
937 OpApp a (HsVar eq_PN) b
938 else -- we have to do something special for primitive things...
939 OpApp a (HsVar relevant_eq_op) b
941 relevant_eq_op = assoc_ty_id eq_op_tbl ty
945 untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameHsExpr -> ProtoNameHsExpr
946 untag_Expr tycon [] expr = expr
947 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
948 = HsCase (HsApp (con2tag_Expr tycon) (HsVar untag_this)) {-of-}
949 [PatMatch (VarPatIn put_tag_here)
950 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
953 grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
955 cmp_tags_Expr :: ProtoName -- Comparison op
956 -> ProtoName -> ProtoName -- Things to compare
957 -> ProtoNameHsExpr -- What to return if true
958 -> ProtoNameHsExpr -- What to return if false
961 cmp_tags_Expr op a b true_case false_case
962 = HsIf (OpApp (HsVar a) (HsVar op) (HsVar b)) true_case false_case mkGeneratedSrcLoc
965 :: ProtoNameHsExpr -> ProtoNameHsExpr
967 enum_from_then_to_Expr
968 :: ProtoNameHsExpr -> ProtoNameHsExpr -> ProtoNameHsExpr
971 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_PN) f) t2
972 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_PN) f) t) t2
974 showParen_Expr, readParen_Expr
975 :: ProtoNameHsExpr -> ProtoNameHsExpr
978 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_PN) e1) e2
979 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_PN) e1) e2
981 nested_compose_Expr :: [ProtoNameHsExpr] -> ProtoNameHsExpr
983 nested_compose_Expr [e] = e
984 nested_compose_Expr (e:es)
985 = HsApp (HsApp (HsVar compose_PN) e) (nested_compose_Expr es)
993 ah_PN = Unk SLIT("a#")
994 bh_PN = Unk SLIT("b#")
995 ch_PN = Unk SLIT("c#")
996 dh_PN = Unk SLIT("d#")
997 cmp_eq_PN = Unk SLIT("cmp_eq")
998 rangeSize_PN = Unk SLIT("rangeSize")
1000 as_PNs = [ Unk (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1001 bs_PNs = [ Unk (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1002 cs_PNs = [ Unk (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1004 eq_PN = prelude_method SLIT("Eq") SLIT("==")
1005 ne_PN = prelude_method SLIT("Eq") SLIT("/=")
1006 le_PN = prelude_method SLIT("Ord") SLIT("<=")
1007 lt_PN = prelude_method SLIT("Ord") SLIT("<")
1008 ge_PN = prelude_method SLIT("Ord") SLIT(">=")
1009 gt_PN = prelude_method SLIT("Ord") SLIT(">")
1010 max_PN = prelude_method SLIT("Ord") SLIT("max")
1011 min_PN = prelude_method SLIT("Ord") SLIT("min")
1012 compare_PN = prelude_method SLIT("Ord") SLIT("compare")
1013 ltTag_PN = Prel (WiredInVal ltDataCon)
1014 eqTag_PN = Prel (WiredInVal eqDataCon)
1015 gtTag_PN = Prel (WiredInVal gtDataCon)
1016 enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom")
1017 enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo")
1018 enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen")
1019 enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo")
1020 range_PN = prelude_method SLIT("Ix") SLIT("range")
1021 index_PN = prelude_method SLIT("Ix") SLIT("index")
1022 inRange_PN = prelude_method SLIT("Ix") SLIT("inRange")
1023 readsPrec_PN = prelude_method SLIT("Read") SLIT("readsPrec")
1024 readList_PN = prelude_method SLIT("Read") SLIT("readList")
1025 showsPrec_PN = prelude_method SLIT("Show") SLIT("showsPrec")
1026 showList_PN = prelude_method SLIT("Show") SLIT("showList")
1027 plus_PN = prelude_method SLIT("Num") SLIT("+")
1028 times_PN = prelude_method SLIT("Num") SLIT("*")
1030 false_PN = Prel (WiredInVal falseDataCon)
1031 true_PN = Prel (WiredInVal trueDataCon)
1032 eqH_PN = Prel (WiredInVal (primOpId IntEqOp))
1033 geH_PN = Prel (WiredInVal (primOpId IntGeOp))
1034 leH_PN = Prel (WiredInVal (primOpId IntLeOp))
1035 ltH_PN = Prel (WiredInVal (primOpId IntLtOp))
1036 minusH_PN = Prel (WiredInVal (primOpId IntSubOp))
1037 and_PN = prelude_val pRELUDE SLIT("&&")
1038 not_PN = prelude_val pRELUDE SLIT("not")
1039 append_PN = prelude_val pRELUDE_LIST SLIT("++")
1040 map_PN = prelude_val pRELUDE_LIST SLIT("map")
1041 compose_PN = prelude_val pRELUDE SLIT(".")
1042 mkInt_PN = Prel (WiredInVal intDataCon)
1043 error_PN = Prel (WiredInVal eRROR_ID)
1044 showSpace_PN = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std
1045 showString_PN = prelude_val pRELUDE_TEXT SLIT("showString")
1046 showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen")
1047 readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen")
1048 lex_PN = prelude_val pRELUDE_TEXT SLIT("lex")
1049 _showList_PN = prelude_val pRELUDE_CORE SLIT("_showList")
1050 _readList_PN = prelude_val pRELUDE_CORE SLIT("_readList")
1052 prelude_val m s = Imp m s [m] s
1053 prelude_method c o = Imp pRELUDE_CORE o [pRELUDE_CORE] o -- class not used...
1059 ltTag_Expr = HsVar ltTag_PN
1060 eqTag_Expr = HsVar eqTag_PN
1061 gtTag_Expr = HsVar gtTag_PN
1062 false_Expr = HsVar false_PN
1063 true_Expr = HsVar true_PN
1065 con2tag_Expr tycon = HsVar (con2tag_PN tycon)
1067 a_Pat = VarPatIn a_PN
1068 b_Pat = VarPatIn b_PN
1069 c_Pat = VarPatIn c_PN
1070 d_Pat = VarPatIn d_PN
1073 con2tag_PN, tag2con_PN, maxtag_PN :: TyCon -> ProtoName
1076 = let (mod, nm) = getOrigName tycon
1077 con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
1079 Imp mod con2tag [mod] con2tag
1082 = let (mod, nm) = getOrigName tycon
1083 tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
1085 Imp mod tag2con [mod] tag2con
1088 = let (mod, nm) = getOrigName tycon
1089 maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
1091 Imp mod maxtag [mod] maxtag
1094 con2tag_FN, tag2con_FN, maxtag_FN :: TyCon -> FullName
1097 = let (mod, nm) = getOrigName tycon
1098 tag2con = SLIT("tag2con_") _APPEND_ nm _APPEND_ SLIT("#")
1100 mkFullName mod tag2con InventedInThisModule NotExported mkGeneratedSrcLoc
1103 = let (mod, nm) = getOrigName tycon
1104 maxtag = SLIT("maxtag_") _APPEND_ nm _APPEND_ SLIT("#")
1106 mkFullName mod maxtag InventedInThisModule NotExported mkGeneratedSrcLoc
1109 = let (mod, nm) = getOrigName tycon
1110 con2tag = SLIT("con2tag_") _APPEND_ nm _APPEND_ SLIT("#")
1112 mkFullName mod con2tag InventedInThisModule NotExported mkGeneratedSrcLoc