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"
45 gen_tag_n_con_monobind,
59 IMPORT_Trace -- ToDo:rm debugging
63 import AbsSyn -- the stuff being typechecked
65 import AbsPrel {-( trueDataCon, falseDataCon, intDataCon, eRROR_ID,
66 ltPrimDataCon, eqPrimDataCon, gtPrimDataCon,
67 charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
68 floatPrimTy, doublePrimTy
70 import PrimOps -- *********** ditto
72 import AbsUniType ( getTyConDataCons, isEnumerationTyCon,
73 maybeSingleConstructorTyCon, --UNUSED: preludeClassDerivedFor,
74 -- UNUSED: isEnumerationTyConMostly,
76 TauType(..), TyVarTemplate, ThetaType(..)
77 IF_ATTACK_PRAGMAS(COMMA cmpUniType)
79 import Id ( getDataConArity, getDataConTag,
80 getDataConSig, isNullaryDataCon, fIRST_TAG,
81 isDataCon, DataCon(..), ConTag(..), Id
83 import Maybes ( maybeToBool, Maybe(..) )
84 import Name ( Name(..) )
85 import ProtoName ( ProtoName(..) )
86 import RenameAuxFuns -- why not? take all of it...
87 import RenameMonad4 -- initRn4, etc.
88 import SrcLoc ( mkGeneratedSrcLoc )
89 import TcDeriv ( con2tag_PN, tag2con_PN, maxtag_PN,
90 TagThingWanted(..), DerivEqn(..)
92 import Unique -- some ClassKey stuff
96 %************************************************************************
98 \subsection[TcGenDeriv-classes]{Generating code, by derivable class}
100 %************************************************************************
102 %************************************************************************
104 \subsubsection[TcGenDeriv-Eq]{Generating @Eq@ instance declarations}
106 %************************************************************************
108 Here are the heuristics for the code we generate for @Eq@:
111 Let's assume we have a data type with some (possibly zero) nullary
112 data constructors and some ordinary, non-nullary ones (the rest,
113 also possibly zero of them). Here's an example, with both \tr{N}ullary
114 and \tr{O}rdinary data cons.
116 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
120 For the ordinary constructors (if any), we emit clauses to do The
124 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
125 (==) (O2 a1) (O2 a2) = a1 == a2
126 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
129 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
130 \tr{a2} are \tr{Float#}s, then we have to generate
132 case (a1 `eqFloat#` a2) of
135 for that particular test.
138 If there are any nullary constructors, we emit a catch-all clause of
142 (==) a b = case (con2tag_Foo a) of { a# ->
143 case (con2tag_Foo b) of { b# ->
144 case (a# ==# b#) of {
149 If there aren't any nullary constructors, we emit a simpler
156 For the @(/=)@ method, we normally just use the default method.
158 If the type is an enumeration type, we could/may/should? generate
159 special code that calls @con2tag_Foo@, much like for @(==)@ shown
163 We thought about doing this: If we're also deriving @Ord@ for this
166 instance ... Eq (Foo ...) where
167 (==) a b = case (tagCmp a b) of { _LT -> False; _EQ -> True ; _GT -> False}
168 (/=) a b = case (tagCmp a b) of { _LT -> True ; _EQ -> False; _GT -> True }
170 However, that requires that \tr{Ord <whatever>} was put in the context
171 for the instance decl, which it probably wasn't, so the decls
172 produced don't get through the typechecker.
176 gen_Eq_binds :: TyCon -> ProtoNameMonoBinds
179 = case (partition isNullaryDataCon (getTyConDataCons tycon))
180 of { (nullary_cons, nonnullary_cons) ->
183 = if null nullary_cons then
184 case maybeSingleConstructorTyCon 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 (getDataConArity data_con) as_PNs
205 bs_needed = take (getDataConArity data_con) bs_PNs
206 tys_needed = case (getDataConSig 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 (Var a) (Var 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 (Var a) (Var b)) rest_expr
220 = mk_easy_FunMonoBind ne_PN [a_Pat, b_Pat] [] (
221 App (Var not_PN) (App (App (Var 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 the non-standard
232 @_tagCmp@ method, which type:
234 _tagCmp :: a -> a -> _CMP_TAG
236 -- and the builtin tag type is:
238 data _CMP_TAG = _LT | _EQ | _GT deriving ()
241 (All this @_tagCmp@ stuff is due to the sterling analysis by Julian
244 We will use the same example data type as above:
246 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
251 We do all the other @Ord@ methods with calls to @_tagCmp@:
253 instance ... (Ord <wurble> <wurble>) where
254 a < b = case _tagCmp a b of { _LT -> True; _EQ -> False; _GT -> False }
255 a <= b = case _tagCmp a b of { _LT -> True; _EQ -> True; _GT -> False }
256 a >= b = case _tagCmp a b of { _LT -> False; _EQ -> True; _GT -> True }
257 a > b = case _tagCmp a b of { _LT -> False; _EQ -> False; _GT -> True }
259 max a b = case _tagCmp a b of { _LT -> b; _EQ -> a; _GT -> a }
260 min a b = case _tagCmp a b of { _LT -> a; _EQ -> a; _GT -> b }
262 -- _tagCmp to come...
266 @_tagCmp@ always has two parts. First, we use the compared
267 data-constructors' tags to deal with the case of different
270 _tagCmp a b = case (con2tag_Foo a) of { a# ->
271 case (con2tag_Foo b) of { b# ->
272 case (a# ==# b#) of {
274 False -> case (a# <# b#) of
279 cmp_eq = ... to come ...
283 We are only left with the ``help'' function @cmp_eq@, to deal with
284 comparing data constructors with the same tag.
286 For the ordinary constructors (if any), we emit the sorta-obvious
287 tagCmp-style stuff; for our example:
289 cmp_eq (O1 a1 b1) (O1 a2 b2)
290 = case (_tagCmp a1 a2) of { _LT -> _LT; _EQ -> _tagCmp b1 b2; _GT -> _GT }
292 cmp_eq (O2 a1) (O2 a2)
295 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
296 = case (_tagCmp a1 a2) of {
299 _EQ -> case _tagCmp b1 b2 of {
307 Again, we must be careful about unboxed comparisons. For example,
308 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
311 cmp_eq lt eq gt (O2 a1) (O2 a2)
313 -- or maybe the unfolded equivalent
317 For the remaining nullary constructors, we already know that the
325 gen_Ord_binds :: TyCon -> ProtoNameMonoBinds
328 = defaulted `AndMonoBinds` tagCmp
330 --------------------------------------------------------------------
331 tagCmp = mk_easy_FunMonoBind tagCmp_PN
334 (if maybeToBool (maybeSingleConstructorTyCon tycon) then
335 cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr
337 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)]
338 (cmp_tags_Expr eqH_PN ah_PN bh_PN
339 -- True case; they are equal
340 -- If an enumeration type we are done; else
341 -- recursively compare their components
342 (if isEnumerationTyCon tycon then
345 cmp_eq_Expr lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr a_Expr b_Expr
347 -- False case; they aren't equal
348 -- So we need to do a less-than comparison on the tags
349 (cmp_tags_Expr ltH_PN ah_PN bh_PN lt_TAG_Expr gt_TAG_Expr)))
351 (nullary_cons, nonnullary_cons)
352 = partition isNullaryDataCon (getTyConDataCons tycon)
355 = mk_FunMonoBind cmp_eq_PN (map pats_etc nonnullary_cons ++ deflt_pats_etc)
358 = ([con1_pat, con2_pat],
359 nested_tagCmp_expr tys_needed as_needed bs_needed)
361 con1_pat = ConPatIn data_con_PN (map VarPatIn as_needed)
362 con2_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
364 data_con_PN = Prel (WiredInVal data_con)
365 as_needed = take (getDataConArity data_con) as_PNs
366 bs_needed = take (getDataConArity data_con) bs_PNs
367 tys_needed = case (getDataConSig data_con) of
368 (_,_, arg_tys, _) -> arg_tys
370 nested_tagCmp_expr [ty] [a] [b]
371 = careful_tagCmp_Case ty lt_TAG_Expr eq_TAG_Expr gt_TAG_Expr (Var a) (Var b)
373 nested_tagCmp_expr (ty:tys) (a:as) (b:bs)
374 = let eq_expr = nested_tagCmp_expr tys as bs
375 in careful_tagCmp_Case ty lt_TAG_Expr eq_expr gt_TAG_Expr (Var a) (Var b)
378 = if null nullary_cons
380 else [([a_Pat, b_Pat], eq_TAG_Expr)]
381 --------------------------------------------------------------------
383 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
385 lt = mk_easy_FunMonoBind lt_PN [a_Pat, b_Pat] [] (
386 tagCmp_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
387 le = mk_easy_FunMonoBind le_PN [a_Pat, b_Pat] [] (
388 tagCmp_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
389 ge = mk_easy_FunMonoBind ge_PN [a_Pat, b_Pat] [] (
390 tagCmp_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
391 gt = mk_easy_FunMonoBind gt_PN [a_Pat, b_Pat] [] (
392 tagCmp_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
394 max_ = mk_easy_FunMonoBind max_PN [a_Pat, b_Pat] [] (
395 tagCmp_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
396 min_ = mk_easy_FunMonoBind min_PN [a_Pat, b_Pat] [] (
397 tagCmp_Case a_Expr a_Expr b_Expr a_Expr b_Expr)
400 %************************************************************************
402 \subsubsection[TcGenDeriv-Enum]{Generating @Enum@ instance declarations}
404 %************************************************************************
406 @Enum@ can only be derived for enumeration types. For a type
408 data Foo ... = N1 | N2 | ... | Nn
411 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
412 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
415 instance ... Enum (Foo ...) where
416 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
420 = case con2tag_Foo a of
421 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
424 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
428 = case con2tag_Foo a of { a# ->
429 case con2tag_Foo b of { b# ->
430 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
434 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
437 gen_Enum_binds :: TyCon -> ProtoNameMonoBinds
440 = enum_from `AndMonoBinds` enum_from_then
443 = mk_easy_FunMonoBind enumFrom_PN [a_Pat] [] (
444 untag_Expr tycon [(a_PN, ah_PN)] (
445 App (App (Var map_PN) (Var (tag2con_PN tycon))) (
447 (App (Var mkInt_PN) (Var ah_PN))
448 (Var (maxtag_PN tycon)))))
451 = mk_easy_FunMonoBind enumFromThen_PN [a_Pat, b_Pat] [] (
452 untag_Expr tycon [(a_PN, ah_PN), (b_PN, bh_PN)] (
453 App (App (Var map_PN) (Var (tag2con_PN tycon))) (
454 enum_from_then_to_Expr
455 (App (Var mkInt_PN) (Var ah_PN))
456 (App (Var mkInt_PN) (Var bh_PN))
457 (Var (maxtag_PN tycon)))))
460 %************************************************************************
462 \subsubsection[TcGenDeriv-Ix]{Generating @Ix@ instance declarations}
464 %************************************************************************
466 Deriving @Ix@ is only possible for enumeration types and
467 single-constructor types. We deal with them in turn.
469 For an enumeration type, e.g.,
471 data Foo ... = N1 | N2 | ... | Nn
473 things go not too differently from @Enum@:
475 instance ... Ix (Foo ...) where
477 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
481 = case (con2tag_Foo a) of { a# ->
482 case (con2tag_Foo b) of { b# ->
483 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
488 then case (con2tag_Foo d -# con2tag_Foo a) of
490 else error "Ix.Foo.index: out of range"
494 p_tag = con2tag_Foo c
496 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
500 = case (con2tag_Foo a) of { a_tag ->
501 case (con2tag_Foo b) of { b_tag ->
502 case (con2tag_Foo c) of { c_tag ->
503 if (c_tag >=# a_tag) then
509 (modulo suitable case-ification to handle the unboxed tags)
511 For a single-constructor type (NB: this includes all tuples), e.g.,
513 data Foo ... = MkFoo a b Int Double c c
515 we follow the scheme given in Figure~19 of the Haskell~1.2 report
519 gen_Ix_binds :: TyCon -> ProtoNameMonoBinds
522 = if isEnumerationTyCon tycon
526 tycon_str = _UNPK_ (snd (getOrigName tycon))
528 --------------------------------------------------------------
529 enum_ixes = enum_range `AndMonoBinds`
530 enum_index `AndMonoBinds` enum_inRange
533 = mk_easy_FunMonoBind range_PN [TuplePatIn [a_Pat, b_Pat]] [] (
534 untag_Expr tycon [(a_PN, ah_PN)] (
535 untag_Expr tycon [(b_PN, bh_PN)] (
536 App (App (Var map_PN) (Var (tag2con_PN tycon))) (
538 (App (Var mkInt_PN) (Var ah_PN))
539 (App (Var mkInt_PN) (Var bh_PN))
543 = mk_easy_FunMonoBind index_PN [AsPatIn c_PN (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
544 If (App (App (Var inRange_PN) c_Expr) d_Expr) (
545 untag_Expr tycon [(a_PN, ah_PN)] (
546 untag_Expr tycon [(d_PN, dh_PN)] (
548 grhs = [OtherwiseGRHS (App (Var mkInt_PN) (Var c_PN)) mkGeneratedSrcLoc]
550 Case (OpApp (Var dh_PN) (Var minusH_PN) (Var ah_PN)) {-of-}
551 [PatMatch (VarPatIn c_PN)
552 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
555 App (Var error_PN) (Lit (StringLit (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
560 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
561 untag_Expr tycon [(a_PN, ah_PN)] (
562 untag_Expr tycon [(b_PN, bh_PN)] (
563 untag_Expr tycon [(c_PN, ch_PN)] (
564 If (OpApp (Var ch_PN) (Var geH_PN) (Var ah_PN)) (
565 (OpApp (Var ch_PN) (Var leH_PN) (Var bh_PN))
570 --------------------------------------------------------------
571 single_con_ixes = single_con_range `AndMonoBinds`
572 single_con_index `AndMonoBinds` single_con_inRange
575 = case maybeSingleConstructorTyCon tycon of -- just checking...
576 Nothing -> panic "get_Ix_binds"
578 (_, _, arg_tys, _) = getDataConSig dc
580 if any isPrimType arg_tys then
581 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
585 con_arity = getDataConArity data_con
586 data_con_PN = Prel (WiredInVal data_con)
587 con_pat xs = ConPatIn data_con_PN (map VarPatIn xs)
588 con_expr xs = foldl App (Var data_con_PN) (map Var xs)
590 as_needed = take (getDataConArity data_con) as_PNs
591 bs_needed = take (getDataConArity data_con) bs_PNs
592 cs_needed = take (getDataConArity data_con) cs_PNs
594 --------------------------------------------------------------
596 = mk_easy_FunMonoBind range_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] (
597 ListComp (con_expr cs_needed) (zipWith3 mk_qual as_needed bs_needed cs_needed)
600 mk_qual a b c = GeneratorQual (VarPatIn c)
601 (App (Var range_PN) (ExplicitTuple [Var a, Var b]))
605 = mk_easy_FunMonoBind index_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
606 foldl mk_index (Lit (IntLit 0)) (zip3 as_needed bs_needed cs_needed))
608 mk_index multiply_by (l, u, i)
610 (App (App (Var index_PN) (ExplicitTuple [Var l, Var u])) (Var i))
613 (App (Var rangeSize_PN) (ExplicitTuple [Var l, Var u]))
614 ) (Var times_PN) multiply_by
618 = mk_easy_FunMonoBind rangeSize_PN [TuplePatIn [a_Pat, b_Pat]] [] (
620 (App (App (Var index_PN) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
621 ) (Var plus_PN) (Lit (IntLit 1)))
625 = mk_easy_FunMonoBind inRange_PN [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [] (
626 foldl1 and_Expr (zipWith3 in_range as_needed bs_needed cs_needed))
628 in_range a b c = App (App (Var inRange_PN) (ExplicitTuple [Var a, Var b])) (Var c)
631 %************************************************************************
633 \subsubsection[TcGenDeriv-Text]{Generating @Text@ instance declarations}
635 %************************************************************************
637 Deriving @Text@ is a pain. @show@ is commonly used; @read@ is rarely
638 used---but we're supposed to generate massive amounts of code for it
639 anyway. We provide a command-line flag to say ``Don't bother''
642 We just use the default methods for @showList@ and @readList@.
644 Also: ignoring all the infix-ery mumbo jumbo (ToDo)
646 The part of the Haskell report that deals with this (pages~147--151,
647 1.2~version) is an adequate guide to what needs to be done. Note that
648 this is where we may (eventually) use the fixity info that's been
652 gen_Text_binds :: [RenamedFixityDecl] -> Bool -> TyCon -> ProtoNameMonoBinds
654 gen_Text_binds fixities omit_derived_read tycon
655 = if omit_derived_read
657 else shows_prec `AndMonoBinds` reads_prec
659 -----------------------------------------------------------------------
661 = mk_FunMonoBind showsPrec_PN (map pats_etc (getTyConDataCons tycon))
665 data_con_PN = Prel (WiredInVal data_con)
666 bs_needed = take (getDataConArity data_con) bs_PNs
667 con_pat = ConPatIn data_con_PN (map VarPatIn bs_needed)
668 is_nullary_con = isNullaryDataCon data_con
671 = let (mod, nm) = getOrigName data_con
672 space_maybe = if is_nullary_con then _NIL_ else SLIT(" ")
674 App (Var showString_PN) (Lit (StringLit (nm _APPEND_ space_maybe)))
676 show_thingies = show_con : (spacified real_show_thingies)
679 = [ App (App (Var showsPrec_PN) (Lit (IntLit 10))) (Var b)
682 if is_nullary_con then -- skip the showParen junk...
683 ASSERT(null bs_needed)
684 ([a_Pat, con_pat], show_con)
687 showParen_Expr (OpApp a_Expr (Var ge_PN) (Lit (IntLit 10)))
688 (nested_compose_Expr show_thingies))
692 spacified (x:xs) = (x : (Var showSpace_PN) : spacified xs)
694 -----------------------------------------------------------------------
695 reads_prec -- ignore the infix game altogether
697 read_con_comprehensions
698 = map read_con (getTyConDataCons tycon)
700 mk_easy_FunMonoBind readsPrec_PN [a_Pat, b_Pat] [] (
701 foldl1 append_Expr read_con_comprehensions
704 read_con data_con -- note: "b" is the string being "read"
706 data_con_PN = Prel (WiredInVal data_con)
707 data_con_str= snd (getOrigName data_con)
708 as_needed = take (getDataConArity data_con) as_PNs
709 bs_needed = take (getDataConArity data_con) bs_PNs
710 con_expr = foldl App (Var data_con_PN) (map Var as_needed)
711 is_nullary_con = isNullaryDataCon data_con
715 (TuplePatIn [LitPatIn (StringLit data_con_str), d_Pat])
716 (App (Var lex_PN) c_Expr)
718 field_quals = snd (mapAccumL mk_qual d_Expr (as_needed `zip` bs_needed))
721 = if is_nullary_con then -- must be False (parens are surely optional)
723 else -- parens depend on precedence...
724 OpApp a_Expr (Var gt_PN) (Lit (IntLit 9))
727 readParen_Expr read_paren_arg (
728 Lam (mk_easy_Match [c_Pat] [] (
729 ListComp (ExplicitTuple [con_expr,
730 if null bs_needed then d_Expr else Var (last bs_needed)])
731 (con_qual : field_quals)))
734 mk_qual draw_from (con_field, str_left)
735 = (Var str_left, -- what to draw from down the line...
737 (TuplePatIn [VarPatIn con_field, VarPatIn str_left])
738 (App (App (Var readsPrec_PN) (Lit (IntLit 10))) draw_from))
741 %************************************************************************
743 \subsubsection[TcGenDeriv-Binary]{Generating @Binary@ instance declarations}
745 %************************************************************************
750 gen_Binary_binds :: TyCon -> ProtoNameMonoBinds
752 gen_Binary_binds tycon
753 = panic "gen_Binary_binds"
756 %************************************************************************
758 \subsection[TcGenDeriv-con2tag-tag2con]{Generating extra binds (@con2tag@ and @tag2con@)}
760 %************************************************************************
765 con2tag_Foo :: Foo ... -> Int#
766 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
767 maxtag_Foo :: Int -- ditto (NB: not unboxed)
770 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
774 gen_tag_n_con_monobind
775 :: (ProtoName, Name, -- (proto)Name for the thing in question
776 TyCon, -- tycon in question
778 -> ProtoNameMonoBinds
780 gen_tag_n_con_monobind (pn, _, tycon, GenCon2Tag)
781 = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
783 mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
786 = ASSERT(isDataCon var)
787 ([pat], Lit (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG))))
789 pat = ConPatIn var_PN (nOfThem (getDataConArity var) WildPatIn)
790 var_PN = Prel (WiredInVal var)
792 gen_tag_n_con_monobind (pn, _, tycon, GenTag2Con)
793 = mk_FunMonoBind pn (map mk_stuff (getTyConDataCons tycon))
795 mk_stuff :: DataCon -> ([ProtoNamePat], ProtoNameExpr)
798 = ASSERT(isDataCon var)
799 ([lit_pat], Var var_PN)
801 lit_pat = ConPatIn mkInt_PN [LitPatIn (IntPrimLit (toInteger ((getDataConTag var) - fIRST_TAG)))]
802 var_PN = Prel (WiredInVal var)
804 gen_tag_n_con_monobind (pn, _, tycon, GenMaxTag)
805 = mk_easy_FunMonoBind pn [] [] (App (Var mkInt_PN) (Lit (IntPrimLit max_tag)))
807 max_tag = case (getTyConDataCons tycon) of
808 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
811 %************************************************************************
813 \subsection[TcGenDeriv-bind-utils]{Utility bits for generating bindings}
815 %************************************************************************
817 @mk_easy_FunMonoBind fun pats binds expr@ generates:
819 fun pat1 pat2 ... patN = expr where binds
822 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
823 multi-clause definitions; it generates:
825 fun p1a p1b ... p1N = e1
826 fun p2a p2b ... p2N = e2
828 fun pMa pMb ... pMN = eM
832 mk_easy_FunMonoBind :: ProtoName -> [ProtoNamePat]
833 -> [ProtoNameMonoBinds] -> ProtoNameExpr
834 -> ProtoNameMonoBinds
836 mk_easy_FunMonoBind fun pats binds expr
837 = FunMonoBind fun [mk_easy_Match pats binds expr] mkGeneratedSrcLoc
839 mk_easy_Match pats binds expr
841 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] (mkbind binds)))
844 mkbind [] = EmptyBinds
845 mkbind bs = SingleBind (RecBind (foldr1 AndMonoBinds bs))
846 -- The renamer expects everything in its input to be a
847 -- "recursive" MonoBinds, and it is its job to sort things out
850 mk_FunMonoBind :: ProtoName
851 -> [([ProtoNamePat], ProtoNameExpr)]
852 -> ProtoNameMonoBinds
854 mk_FunMonoBind fun [] = panic "TcGenDeriv:mk_FunMonoBind"
855 mk_FunMonoBind fun pats_and_exprs
856 = FunMonoBind fun (map mk_match pats_and_exprs) mkGeneratedSrcLoc
858 mk_match (pats, expr)
860 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS expr mkGeneratedSrcLoc] EmptyBinds))
865 tagCmp_Case, cmp_eq_Expr ::
866 ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
867 -> ProtoNameExpr -> ProtoNameExpr
871 -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
872 -> ProtoNameExpr -> ProtoNameExpr
874 careful_tagCmp_Case :: -- checks for primitive types...
876 -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
877 -> ProtoNameExpr -> ProtoNameExpr
880 tagCmp_Case = tagCmp_gen_Case tagCmp_PN
881 cmp_eq_Expr = tagCmp_gen_Case cmp_eq_PN
883 tagCmp_gen_Case fun lt eq gt a b
884 = Case (App (App (Var fun) a) b) {-of-}
885 [PatMatch (ConPatIn lt_TAG_PN [])
886 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS lt mkGeneratedSrcLoc] EmptyBinds)),
888 PatMatch (ConPatIn eq_TAG_PN [])
889 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS eq mkGeneratedSrcLoc] EmptyBinds)),
891 PatMatch (ConPatIn gt_TAG_PN [])
892 (GRHSMatch (GRHSsAndBindsIn [OtherwiseGRHS gt mkGeneratedSrcLoc] EmptyBinds))]
894 careful_tagCmp_Case ty lt eq gt a b
895 = if not (isPrimType ty) then
896 tagCmp_gen_Case tagCmp_PN lt eq gt a b
898 else -- we have to do something special for primitive things...
899 If (OpApp a (Var relevant_eq_op) b)
901 (If (OpApp a (Var relevant_lt_op) b) lt gt)
903 relevant_eq_op = assoc "careful_tagCmp_Case" eq_op_tbl ty
904 relevant_lt_op = assoc "careful_tagCmp_Case" lt_op_tbl ty
907 (charPrimTy, Prel (WiredInVal (primOpId CharEqOp))),
908 (intPrimTy, Prel (WiredInVal (primOpId IntEqOp))),
909 (wordPrimTy, Prel (WiredInVal (primOpId WordEqOp))),
910 (addrPrimTy, Prel (WiredInVal (primOpId AddrEqOp))),
911 (floatPrimTy, Prel (WiredInVal (primOpId FloatEqOp))),
912 (doublePrimTy, Prel (WiredInVal (primOpId DoubleEqOp))) ]
915 (charPrimTy, Prel (WiredInVal (primOpId CharLtOp))),
916 (intPrimTy, Prel (WiredInVal (primOpId IntLtOp))),
917 (wordPrimTy, Prel (WiredInVal (primOpId WordLtOp))),
918 (addrPrimTy, Prel (WiredInVal (primOpId AddrLtOp))),
919 (floatPrimTy, Prel (WiredInVal (primOpId FloatLtOp))),
920 (doublePrimTy, Prel (WiredInVal (primOpId DoubleLtOp))) ]
922 -----------------------------------------------------------------------
924 and_Expr, append_Expr :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
926 and_Expr a b = OpApp a (Var and_PN) b
927 append_Expr a b = OpApp a (Var append_PN) b
929 -----------------------------------------------------------------------
931 eq_Expr :: UniType -> ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
933 = if not (isPrimType ty) then
934 OpApp a (Var eq_PN) b
935 else -- we have to do something special for primitive things...
936 OpApp a (Var relevant_eq_op) b
938 relevant_eq_op = assoc "eq_Expr" eq_op_tbl ty
942 untag_Expr :: TyCon -> [(ProtoName, ProtoName)] -> ProtoNameExpr -> ProtoNameExpr
943 untag_Expr tycon [] expr = expr
944 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
945 = Case (App (con2tag_Expr tycon) (Var untag_this)) {-of-}
946 [PatMatch (VarPatIn put_tag_here)
947 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
949 grhs = [OtherwiseGRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc]
951 cmp_tags_Expr :: ProtoName -- Comparison op
952 -> ProtoName -> ProtoName -- Things to compare
953 -> ProtoNameExpr -- What to return if true
954 -> ProtoNameExpr -- What to return if false
957 cmp_tags_Expr op a b true_case false_case
958 = If (OpApp (Var a) (Var op) (Var b)) true_case false_case
961 :: ProtoNameExpr -> ProtoNameExpr
963 enum_from_then_to_Expr
964 :: ProtoNameExpr -> ProtoNameExpr -> ProtoNameExpr
967 enum_from_to_Expr f t2 = App (App (Var enumFromTo_PN) f) t2
968 enum_from_then_to_Expr f t t2 = App (App (App (Var enumFromThenTo_PN) f) t) t2
970 showParen_Expr, readParen_Expr
971 :: ProtoNameExpr -> ProtoNameExpr
974 showParen_Expr e1 e2 = App (App (Var showParen_PN) e1) e2
975 readParen_Expr e1 e2 = App (App (Var readParen_PN) e1) e2
977 nested_compose_Expr :: [ProtoNameExpr] -> ProtoNameExpr
979 nested_compose_Expr [e] = e
980 nested_compose_Expr (e:es)
981 = App (App (Var compose_PN) e) (nested_compose_Expr es)
989 ah_PN = Unk SLIT("a#")
990 bh_PN = Unk SLIT("b#")
991 ch_PN = Unk SLIT("c#")
992 dh_PN = Unk SLIT("d#")
993 cmp_eq_PN = Unk SLIT("cmp_eq")
994 rangeSize_PN = Unk SLIT("rangeSize")
996 as_PNs = [ Unk (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
997 bs_PNs = [ Unk (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
998 cs_PNs = [ Unk (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1000 eq_PN = prelude_method SLIT("Eq") SLIT("==")
1001 ne_PN = prelude_method SLIT("Eq") SLIT("/=")
1002 le_PN = prelude_method SLIT("Ord") SLIT("<=")
1003 lt_PN = prelude_method SLIT("Ord") SLIT("<")
1004 ge_PN = prelude_method SLIT("Ord") SLIT(">=")
1005 gt_PN = prelude_method SLIT("Ord") SLIT(">")
1006 max_PN = prelude_method SLIT("Ord") SLIT("max")
1007 min_PN = prelude_method SLIT("Ord") SLIT("min")
1008 tagCmp_PN = prelude_method SLIT("Ord") SLIT("_tagCmp")
1009 lt_TAG_PN = Prel (WiredInVal ltPrimDataCon)
1010 eq_TAG_PN = Prel (WiredInVal eqPrimDataCon)
1011 gt_TAG_PN = Prel (WiredInVal gtPrimDataCon)
1012 enumFrom_PN = prelude_method SLIT("Enum") SLIT("enumFrom")
1013 enumFromTo_PN = prelude_method SLIT("Enum") SLIT("enumFromTo")
1014 enumFromThen_PN = prelude_method SLIT("Enum") SLIT("enumFromThen")
1015 enumFromThenTo_PN= prelude_method SLIT("Enum") SLIT("enumFromThenTo")
1016 range_PN = prelude_method SLIT("Ix") SLIT("range")
1017 index_PN = prelude_method SLIT("Ix") SLIT("index")
1018 inRange_PN = prelude_method SLIT("Ix") SLIT("inRange")
1019 readsPrec_PN = prelude_method SLIT("Text") SLIT("readsPrec")
1020 showsPrec_PN = prelude_method SLIT("Text") SLIT("showsPrec")
1021 plus_PN = prelude_method SLIT("Num") SLIT("+")
1022 times_PN = prelude_method SLIT("Num") SLIT("*")
1024 false_PN = Prel (WiredInVal falseDataCon)
1025 true_PN = Prel (WiredInVal trueDataCon)
1026 eqH_PN = Prel (WiredInVal (primOpId IntEqOp))
1027 geH_PN = Prel (WiredInVal (primOpId IntGeOp))
1028 leH_PN = Prel (WiredInVal (primOpId IntLeOp))
1029 ltH_PN = Prel (WiredInVal (primOpId IntLtOp))
1030 minusH_PN = Prel (WiredInVal (primOpId IntSubOp))
1031 and_PN = prelude_val pRELUDE SLIT("&&")
1032 not_PN = prelude_val pRELUDE SLIT("not")
1033 append_PN = prelude_val pRELUDE_LIST SLIT("++")
1034 map_PN = prelude_val pRELUDE_LIST SLIT("map")
1035 compose_PN = prelude_val pRELUDE SLIT(".")
1036 mkInt_PN = Prel (WiredInVal intDataCon)
1037 error_PN = Prel (WiredInVal eRROR_ID)
1038 showSpace_PN = prelude_val pRELUDE_TEXT SLIT("showSpace__") -- not quite std
1039 showString_PN = prelude_val pRELUDE_TEXT SLIT("showString")
1040 showParen_PN = prelude_val pRELUDE_TEXT SLIT("showParen")
1041 readParen_PN = prelude_val pRELUDE_TEXT SLIT("readParen")
1042 lex_PN = prelude_val pRELUDE_TEXT SLIT("lex")
1044 prelude_val m s = Imp m s [m] s
1045 prelude_method c o = Imp pRELUDE_CORE o [pRELUDE_CORE] o -- class not used...
1051 lt_TAG_Expr = Var lt_TAG_PN
1052 eq_TAG_Expr = Var eq_TAG_PN
1053 gt_TAG_Expr = Var gt_TAG_PN
1054 false_Expr = Var false_PN
1055 true_Expr = Var true_PN
1057 con2tag_Expr tycon = Var (con2tag_PN tycon)
1059 a_Pat = VarPatIn a_PN
1060 b_Pat = VarPatIn b_PN
1061 c_Pat = VarPatIn c_PN
1062 d_Pat = VarPatIn d_PN
1065 %************************************************************************
1067 \subsection[TcGenDeriv-misc-utils]{Miscellaneous utility bits for deriving}
1069 %************************************************************************
1073 hasCon2TagFun :: TyCon -> Bool
1075 = preludeClassDerivedFor ordClassKey tycon
1076 || isEnumerationTyConMostly tycon
1078 hasTag2ConFun :: TyCon -> Bool
1080 = isEnumerationTyCon tycon
1081 && (preludeClassDerivedFor ixClassKey tycon
1082 || preludeClassDerivedFor enumClassKey tycon)