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.
21 gen_tag_n_con_monobind,
23 con2tag_RDR, tag2con_RDR, maxtag_RDR,
28 #include "HsVersions.h"
30 import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), GRHS(..),
31 Match(..), GRHSsAndBinds(..), Stmt(..), HsLit(..),
32 HsBinds(..), DoOrListComp(..),
35 import RdrHsSyn ( RdrName(..), varQual, varUnqual, mkOpApp,
36 RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat
38 import BasicTypes ( IfaceFlavour(..), RecFlag(..) )
39 import FieldLabel ( fieldLabelName )
40 import Id ( GenId, isNullaryDataCon, dataConTag,
41 dataConRawArgTys, fIRST_TAG,
42 isDataCon, DataCon, ConTag,
43 dataConFieldLabels, Id )
44 import Maybes ( maybeToBool )
45 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
46 modAndOcc, OccName, Name )
48 import PrimOp ( PrimOp(..) )
49 import PrelInfo -- Lots of RdrNames
50 import SrcLoc ( mkGeneratedSrcLoc, SrcLoc )
51 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon )
52 import Type ( isUnpointedType, isUnboxedType, Type )
53 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
54 floatPrimTy, doublePrimTy
56 import Util ( mapAccumL, zipEqual, zipWithEqual,
57 zipWith3Equal, nOfThem, panic, assertPanic )
59 import List ( partition, intersperse )
62 %************************************************************************
64 \subsection{Generating code, by derivable class}
66 %************************************************************************
68 %************************************************************************
70 \subsubsection{Generating @Eq@ instance declarations}
72 %************************************************************************
74 Here are the heuristics for the code we generate for @Eq@:
77 Let's assume we have a data type with some (possibly zero) nullary
78 data constructors and some ordinary, non-nullary ones (the rest,
79 also possibly zero of them). Here's an example, with both \tr{N}ullary
80 and \tr{O}rdinary data cons.
82 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
86 For the ordinary constructors (if any), we emit clauses to do The
90 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
91 (==) (O2 a1) (O2 a2) = a1 == a2
92 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
95 Note: if we're comparing unboxed things, e.g., if \tr{a1} and
96 \tr{a2} are \tr{Float#}s, then we have to generate
98 case (a1 `eqFloat#` a2) of
101 for that particular test.
104 If there are any nullary constructors, we emit a catch-all clause of
108 (==) a b = case (con2tag_Foo a) of { a# ->
109 case (con2tag_Foo b) of { b# ->
110 case (a# ==# b#) of {
115 If there aren't any nullary constructors, we emit a simpler
122 For the @(/=)@ method, we normally just use the default method.
124 If the type is an enumeration type, we could/may/should? generate
125 special code that calls @con2tag_Foo@, much like for @(==)@ shown
129 We thought about doing this: If we're also deriving @Ord@ for this
132 instance ... Eq (Foo ...) where
133 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
134 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
136 However, that requires that \tr{Ord <whatever>} was put in the context
137 for the instance decl, which it probably wasn't, so the decls
138 produced don't get through the typechecker.
142 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
146 tycon_loc = getSrcLoc tycon
147 (nullary_cons, nonnullary_cons)
148 | isNewTyCon tycon = ([], tyConDataCons tycon)
149 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
152 = if (null nullary_cons) then
153 case maybeTyConSingleCon tycon of
155 Nothing -> -- if cons don't match, then False
156 [([a_Pat, b_Pat], false_Expr)]
157 else -- calc. and compare the tags
159 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
160 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR true_Expr false_Expr))]
162 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
164 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
165 HsApp (HsVar not_RDR) (HsPar (mk_easy_App eq_RDR [a_RDR, b_RDR])))
167 ------------------------------------------------------------------
170 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
171 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
173 data_con_RDR = qual_orig_name data_con
174 con_arity = length tys_needed
175 as_needed = take con_arity as_RDRs
176 bs_needed = take con_arity bs_RDRs
177 tys_needed = dataConRawArgTys data_con
179 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
181 nested_eq_expr [] [] [] = true_Expr
182 nested_eq_expr tys as bs
183 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
185 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
188 %************************************************************************
190 \subsubsection{Generating @Ord@ instance declarations}
192 %************************************************************************
194 For a derived @Ord@, we concentrate our attentions on @compare@
196 compare :: a -> a -> Ordering
197 data Ordering = LT | EQ | GT deriving ()
200 We will use the same example data type as above:
202 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
207 We do all the other @Ord@ methods with calls to @compare@:
209 instance ... (Ord <wurble> <wurble>) where
210 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
211 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
212 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
213 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
215 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
216 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
218 -- compare to come...
222 @compare@ always has two parts. First, we use the compared
223 data-constructors' tags to deal with the case of different
226 compare a b = case (con2tag_Foo a) of { a# ->
227 case (con2tag_Foo b) of { b# ->
228 case (a# ==# b#) of {
230 False -> case (a# <# b#) of
235 cmp_eq = ... to come ...
239 We are only left with the ``help'' function @cmp_eq@, to deal with
240 comparing data constructors with the same tag.
242 For the ordinary constructors (if any), we emit the sorta-obvious
243 compare-style stuff; for our example:
245 cmp_eq (O1 a1 b1) (O1 a2 b2)
246 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
248 cmp_eq (O2 a1) (O2 a2)
251 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
252 = case (compare a1 a2) of {
255 EQ -> case compare b1 b2 of {
263 Again, we must be careful about unboxed comparisons. For example,
264 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
268 cmp_eq lt eq gt (O2 a1) (O2 a2)
270 -- or maybe the unfolded equivalent
274 For the remaining nullary constructors, we already know that the
281 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
285 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
288 = defaulted `AndMonoBinds` compare
290 tycon_loc = getSrcLoc tycon
291 --------------------------------------------------------------------
292 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
295 (if maybeToBool (maybeTyConSingleCon tycon) then
296 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
298 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
299 (cmp_tags_Expr eqH_Int_RDR ah_RDR bh_RDR
300 -- True case; they are equal
301 -- If an enumeration type we are done; else
302 -- recursively compare their components
303 (if isEnumerationTyCon tycon then
306 cmp_eq_Expr ltTag_Expr eqTag_Expr gtTag_Expr a_Expr b_Expr
308 -- False case; they aren't equal
309 -- So we need to do a less-than comparison on the tags
310 (cmp_tags_Expr ltH_Int_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr)))
312 tycon_data_cons = tyConDataCons tycon
313 (nullary_cons, nonnullary_cons)
314 | isNewTyCon tycon = ([], tyConDataCons tycon)
315 | otherwise = partition isNullaryDataCon tycon_data_cons
318 mk_FunMonoBind tycon_loc
320 (if null nonnullary_cons && (length nullary_cons == 1) then
321 -- catch this specially to avoid warnings
322 -- about overlapping patterns from the desugarer.
324 data_con = head nullary_cons
325 data_con_RDR = qual_orig_name data_con
326 pat = ConPatIn data_con_RDR []
328 [([pat,pat], eqTag_Expr)]
330 map pats_etc nonnullary_cons ++
331 -- leave out wildcards to silence desugarer.
332 (if length tycon_data_cons == 1 then
335 [([WildPatIn, WildPatIn], default_rhs)]))
338 = ([con1_pat, con2_pat],
339 nested_compare_expr tys_needed as_needed bs_needed)
341 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
342 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
344 data_con_RDR = qual_orig_name data_con
345 con_arity = length tys_needed
346 as_needed = take con_arity as_RDRs
347 bs_needed = take con_arity bs_RDRs
348 tys_needed = dataConRawArgTys data_con
350 nested_compare_expr [ty] [a] [b]
351 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
353 nested_compare_expr (ty:tys) (a:as) (b:bs)
354 = let eq_expr = nested_compare_expr tys as bs
355 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
357 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
358 -- inexhaustive patterns
359 | otherwise = eqTag_Expr -- Some nullary constructors;
360 -- Tags are equal, no args => return EQ
361 --------------------------------------------------------------------
363 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
365 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
366 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
367 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
368 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
369 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
370 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
371 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
372 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
374 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
375 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
376 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
377 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
380 %************************************************************************
382 \subsubsection{Generating @Enum@ instance declarations}
384 %************************************************************************
386 @Enum@ can only be derived for enumeration types. For a type
388 data Foo ... = N1 | N2 | ... | Nn
391 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
392 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
395 instance ... Enum (Foo ...) where
396 toEnum i = tag2con_Foo i
398 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
402 = case con2tag_Foo a of
403 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
406 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
410 = case con2tag_Foo a of { a# ->
411 case con2tag_Foo b of { b# ->
412 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
416 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
419 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
422 = to_enum `AndMonoBinds`
423 enum_from `AndMonoBinds`
424 enum_from_then `AndMonoBinds`
427 tycon_loc = getSrcLoc tycon
430 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
431 mk_easy_App (tag2con_RDR tycon) [a_RDR]
434 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
435 untag_Expr tycon [(a_RDR, ah_RDR)] $
436 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
437 HsPar (enum_from_to_Expr
438 (mk_easy_App mkInt_RDR [ah_RDR])
439 (HsVar (maxtag_RDR tycon)))
442 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
443 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
444 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
445 HsPar (enum_from_then_to_Expr
446 (mk_easy_App mkInt_RDR [ah_RDR])
447 (mk_easy_App mkInt_RDR [bh_RDR])
448 (HsVar (maxtag_RDR tycon)))
451 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
452 untag_Expr tycon [(a_RDR, ah_RDR)] $
453 (mk_easy_App mkInt_RDR [ah_RDR])
456 %************************************************************************
458 \subsubsection{Generating @Eval@ instance declarations}
460 %************************************************************************
463 gen_Eval_binds tycon = EmptyMonoBinds
466 %************************************************************************
468 \subsubsection{Generating @Bounded@ instance declarations}
470 %************************************************************************
473 gen_Bounded_binds tycon
474 = if isEnumerationTyCon tycon then
475 min_bound_enum `AndMonoBinds` max_bound_enum
477 ASSERT(length data_cons == 1)
478 min_bound_1con `AndMonoBinds` max_bound_1con
480 data_cons = tyConDataCons tycon
481 tycon_loc = getSrcLoc tycon
483 ----- enum-flavored: ---------------------------
484 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
485 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
487 data_con_1 = head data_cons
488 data_con_N = last data_cons
489 data_con_1_RDR = qual_orig_name data_con_1
490 data_con_N_RDR = qual_orig_name data_con_N
492 ----- single-constructor-flavored: -------------
493 arity = argFieldCount data_con_1
495 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
496 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
497 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
498 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
501 %************************************************************************
503 \subsubsection{Generating @Ix@ instance declarations}
505 %************************************************************************
507 Deriving @Ix@ is only possible for enumeration types and
508 single-constructor types. We deal with them in turn.
510 For an enumeration type, e.g.,
512 data Foo ... = N1 | N2 | ... | Nn
514 things go not too differently from @Enum@:
516 instance ... Ix (Foo ...) where
518 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
522 = case (con2tag_Foo a) of { a# ->
523 case (con2tag_Foo b) of { b# ->
524 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
529 then case (con2tag_Foo d -# con2tag_Foo a) of
531 else error "Ix.Foo.index: out of range"
535 p_tag = con2tag_Foo c
537 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
541 = case (con2tag_Foo a) of { a_tag ->
542 case (con2tag_Foo b) of { b_tag ->
543 case (con2tag_Foo c) of { c_tag ->
544 if (c_tag >=# a_tag) then
550 (modulo suitable case-ification to handle the unboxed tags)
552 For a single-constructor type (NB: this includes all tuples), e.g.,
554 data Foo ... = MkFoo a b Int Double c c
556 we follow the scheme given in Figure~19 of the Haskell~1.2 report
560 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
563 = if isEnumerationTyCon tycon
567 tycon_str = getOccString tycon
568 tycon_loc = getSrcLoc tycon
570 --------------------------------------------------------------
571 enum_ixes = enum_range `AndMonoBinds`
572 enum_index `AndMonoBinds` enum_inRange
575 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
576 untag_Expr tycon [(a_RDR, ah_RDR)] $
577 untag_Expr tycon [(b_RDR, bh_RDR)] $
578 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
579 HsPar (enum_from_to_Expr
580 (mk_easy_App mkInt_RDR [ah_RDR])
581 (mk_easy_App mkInt_RDR [bh_RDR]))
584 = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
585 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
586 untag_Expr tycon [(a_RDR, ah_RDR)] (
587 untag_Expr tycon [(d_RDR, dh_RDR)] (
589 grhs = unguardedRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc
592 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
593 [PatMatch (VarPatIn c_RDR)
594 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
598 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
603 = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
604 untag_Expr tycon [(a_RDR, ah_RDR)] (
605 untag_Expr tycon [(b_RDR, bh_RDR)] (
606 untag_Expr tycon [(c_RDR, ch_RDR)] (
607 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
608 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
613 --------------------------------------------------------------
615 = single_con_range `AndMonoBinds`
616 single_con_index `AndMonoBinds`
620 = case maybeTyConSingleCon tycon of -- just checking...
621 Nothing -> panic "get_Ix_binds"
622 Just dc -> if (any isUnpointedType (dataConRawArgTys dc)) then
623 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
627 con_arity = argFieldCount data_con
628 data_con_RDR = qual_orig_name data_con
630 as_needed = take con_arity as_RDRs
631 bs_needed = take con_arity bs_RDRs
632 cs_needed = take con_arity cs_RDRs
634 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
635 con_expr = mk_easy_App data_con_RDR cs_needed
637 --------------------------------------------------------------
639 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
640 HsDo ListComp stmts tycon_loc
642 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
644 [ReturnStmt con_expr]
646 mk_qual a b c = BindStmt (VarPatIn c)
647 (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
652 = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
653 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
655 mk_index multiply_by (l, u, i)
657 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
660 (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
661 ) times_RDR multiply_by
665 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
667 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
668 ) plus_RDR (HsLit (HsInt 1)))
672 = mk_easy_FunMonoBind tycon_loc inRange_RDR
673 [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
675 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
677 in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
680 %************************************************************************
682 \subsubsection{Generating @Read@ instance declarations}
684 %************************************************************************
686 Ignoring all the infix-ery mumbo jumbo (ToDo)
689 gen_Read_binds :: TyCon -> RdrNameMonoBinds
692 = reads_prec `AndMonoBinds` read_list
694 tycon_loc = getSrcLoc tycon
695 -----------------------------------------------------------------------
696 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
697 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
698 -----------------------------------------------------------------------
701 read_con_comprehensions
702 = map read_con (tyConDataCons tycon)
704 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
705 foldr1 append_Expr read_con_comprehensions
708 read_con data_con -- note: "b" is the string being "read"
710 data_con_RDR = qual_orig_name data_con
711 data_con_str= occNameString (getOccName data_con)
712 con_arity = argFieldCount data_con
713 con_expr = mk_easy_App data_con_RDR as_needed
714 nullary_con = con_arity == 0
715 labels = dataConFieldLabels data_con
716 lab_fields = length labels
718 as_needed = take con_arity as_RDRs
720 | lab_fields == 0 = take con_arity bs_RDRs
721 | otherwise = take (4*lab_fields + 1) bs_RDRs
722 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
725 (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
726 (HsApp (HsVar lex_RDR) c_Expr)
729 str_qual str res draw_from
731 (TuplePatIn [LitPatIn (HsString str), VarPatIn res])
732 (HsApp (HsVar lex_RDR) draw_from)
736 = let nm = occNameString (getOccName (fieldLabelName f))
738 [str_qual nm, str_qual SLIT("=")]
739 -- There might be spaces between the label and '='
743 snd (mapAccumL mk_qual
745 (zipWithEqual "as_needed"
746 (\ con_field draw_from -> (mk_read_qual con_field,
748 as_needed bs_needed))
751 mapAccumL mk_qual d_Expr
752 (zipEqual "bs_needed"
753 ((str_qual (SLIT("{")):
755 intersperse ([str_qual (_CONS_ ',' _NIL_)]) $
758 (\ as b -> as ++ [b])
760 (map read_label labels)
762 (map mk_read_qual as_needed))) ++ [str_qual (SLIT("}"))])
765 mk_qual draw_from (f, str_left)
766 = (HsVar str_left, -- what to draw from down the line...
767 f str_left draw_from)
769 mk_read_qual con_field res draw_from =
771 (TuplePatIn [VarPatIn con_field, VarPatIn res])
772 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
775 result_expr = ExplicitTuple [con_expr, if null bs_needed
777 else HsVar (last bs_needed)]
779 stmts = con_qual:field_quals ++ [ReturnStmt result_expr]
782 = if nullary_con then -- must be False (parens are surely optional)
784 else -- parens depend on precedence...
785 HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
788 readParen_Expr read_paren_arg $ HsPar $
789 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
790 HsDo ListComp stmts tycon_loc)
795 %************************************************************************
797 \subsubsection{Generating @Show@ instance declarations}
799 %************************************************************************
801 Ignoring all the infix-ery mumbo jumbo (ToDo)
804 gen_Show_binds :: TyCon -> RdrNameMonoBinds
807 = shows_prec `AndMonoBinds` show_list
809 tycon_loc = getSrcLoc tycon
810 -----------------------------------------------------------------------
811 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
812 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
813 -----------------------------------------------------------------------
815 = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
819 data_con_RDR = qual_orig_name data_con
820 con_arity = argFieldCount data_con
821 bs_needed = take con_arity bs_RDRs
822 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
823 nullary_con = con_arity == 0
824 labels = dataConFieldLabels data_con
825 lab_fields = length labels
828 = let nm = occNameString (getOccName data_con)
830 | nullary_con = _NIL_
831 | lab_fields == 0 = SLIT(" ")
832 | otherwise = SLIT("{")
835 mk_showString_app (nm _APPEND_ space_ocurly_maybe)
840 | lab_fields > 0 = [mk_showString_app (SLIT("}"))]
843 con:fs ++ ccurly_maybe
845 show_thingies = show_all show_con real_show_thingies_with_labs
848 = let nm = occNameString (getOccName (fieldLabelName l))
850 mk_showString_app (nm _APPEND_ SLIT("="))
852 mk_showString_app str = HsApp (HsVar showString_RDR)
853 (HsLit (HsString str))
856 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
859 real_show_thingies_with_labs
860 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
861 | otherwise = --Assumption: no of fields == no of labelled fields
862 -- (and in same order)
864 intersperse ([mk_showString_app (_CONS_ ',' SLIT(" "))]) $ -- Using SLIT()s containing ,s spells trouble.
865 zipWithEqual "gen_Show_binds"
867 (map show_label labels)
872 if nullary_con then -- skip the showParen junk...
873 ASSERT(null bs_needed)
874 ([a_Pat, con_pat], show_con)
877 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
878 (HsPar (nested_compose_Expr show_thingies)))
881 %************************************************************************
883 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
885 %************************************************************************
890 con2tag_Foo :: Foo ... -> Int#
891 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
892 maxtag_Foo :: Int -- ditto (NB: not unboxed)
895 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
900 = GenCon2Tag | GenTag2Con | GenMaxTag
902 gen_tag_n_con_monobind
903 :: (RdrName, -- (proto)Name for the thing in question
904 TyCon, -- tycon in question
908 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
909 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
911 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
914 = ASSERT(isDataCon var)
915 ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
917 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
918 var_RDR = qual_orig_name var
920 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
921 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++
922 [([WildPatIn], impossible_Expr)])
924 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
927 = ASSERT(isDataCon var)
928 ([lit_pat], HsVar var_RDR)
930 lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
931 var_RDR = qual_orig_name var
933 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
934 = mk_easy_FunMonoBind (getSrcLoc tycon)
935 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
937 max_tag = case (tyConDataCons tycon) of
938 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
942 %************************************************************************
944 \subsection{Utility bits for generating bindings}
946 %************************************************************************
948 @mk_easy_FunMonoBind fun pats binds expr@ generates:
950 fun pat1 pat2 ... patN = expr where binds
953 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
954 multi-clause definitions; it generates:
956 fun p1a p1b ... p1N = e1
957 fun p2a p2b ... p2N = e2
959 fun pMa pMb ... pMN = eM
963 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
964 -> [RdrNameMonoBinds] -> RdrNameHsExpr
967 mk_easy_FunMonoBind loc fun pats binds expr
968 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
970 mk_easy_Match loc pats binds expr
971 = mk_match loc pats expr (mkbind binds)
973 mkbind [] = EmptyBinds
974 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
975 -- The renamer expects everything in its input to be a
976 -- "recursive" MonoBinds, and it is its job to sort things out
979 mk_FunMonoBind :: SrcLoc -> RdrName
980 -> [([RdrNamePat], RdrNameHsExpr)]
983 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
984 mk_FunMonoBind loc fun pats_and_exprs
985 = FunMonoBind fun False{-not infix-}
986 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
989 mk_match loc pats expr binds
991 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS expr loc) binds))
994 paren p@(VarPatIn _) = p
995 paren other_p = ParPatIn other_p
999 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
1002 ToDo: Better SrcLocs.
1005 compare_Case, cmp_eq_Expr ::
1006 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1007 -> RdrNameHsExpr -> RdrNameHsExpr
1011 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1012 -> RdrNameHsExpr -> RdrNameHsExpr
1014 careful_compare_Case :: -- checks for primitive types...
1016 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1017 -> RdrNameHsExpr -> RdrNameHsExpr
1020 compare_Case = compare_gen_Case compare_RDR
1021 cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
1023 compare_gen_Case fun lt eq gt a b
1024 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1025 [PatMatch (ConPatIn ltTag_RDR [])
1026 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS lt mkGeneratedSrcLoc) EmptyBinds)),
1028 PatMatch (ConPatIn eqTag_RDR [])
1029 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS eq mkGeneratedSrcLoc) EmptyBinds)),
1031 PatMatch (ConPatIn gtTag_RDR [])
1032 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS gt mkGeneratedSrcLoc) EmptyBinds))]
1035 careful_compare_Case ty lt eq gt a b
1036 = if not (isUnboxedType ty) then
1037 compare_gen_Case compare_RDR lt eq gt a b
1039 else -- we have to do something special for primitive things...
1040 HsIf (genOpApp a relevant_eq_op b)
1042 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1045 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1046 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1048 assoc_ty_id tyids ty
1049 = if null res then panic "assoc_ty"
1052 res = [id | (ty',id) <- tyids, ty == ty']
1055 [(charPrimTy, eqH_Char_RDR)
1056 ,(intPrimTy, eqH_Int_RDR)
1057 ,(wordPrimTy, eqH_Word_RDR)
1058 ,(addrPrimTy, eqH_Addr_RDR)
1059 ,(floatPrimTy, eqH_Float_RDR)
1060 ,(doublePrimTy, eqH_Double_RDR)
1064 [(charPrimTy, ltH_Char_RDR)
1065 ,(intPrimTy, ltH_Int_RDR)
1066 ,(wordPrimTy, ltH_Word_RDR)
1067 ,(addrPrimTy, ltH_Addr_RDR)
1068 ,(floatPrimTy, ltH_Float_RDR)
1069 ,(doublePrimTy, ltH_Double_RDR)
1072 -----------------------------------------------------------------------
1074 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1076 and_Expr a b = genOpApp a and_RDR b
1077 append_Expr a b = genOpApp a append_RDR b
1079 -----------------------------------------------------------------------
1081 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1083 = if not (isUnboxedType ty) then
1085 else -- we have to do something special for primitive things...
1086 genOpApp a relevant_eq_op b
1088 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1092 argFieldCount :: Id -> Int -- Works on data and newtype constructors
1093 argFieldCount con = length (dataConRawArgTys con)
1097 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1098 untag_Expr tycon [] expr = expr
1099 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1100 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1101 [PatMatch (VarPatIn put_tag_here)
1102 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
1105 grhs = unguardedRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc
1107 cmp_tags_Expr :: RdrName -- Comparison op
1108 -> RdrName -> RdrName -- Things to compare
1109 -> RdrNameHsExpr -- What to return if true
1110 -> RdrNameHsExpr -- What to return if false
1113 cmp_tags_Expr op a b true_case false_case
1114 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1117 :: RdrNameHsExpr -> RdrNameHsExpr
1119 enum_from_then_to_Expr
1120 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1123 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1124 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1126 showParen_Expr, readParen_Expr
1127 :: RdrNameHsExpr -> RdrNameHsExpr
1130 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1131 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1133 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1135 nested_compose_Expr [e] = parenify e
1136 nested_compose_Expr (e:es)
1137 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1139 -- impossible_Expr is used in case RHSs that should never happen.
1140 -- We generate these to keep the desugarer from complaining that they *might* happen!
1141 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1143 parenify e@(HsVar _) = e
1144 parenify e = HsPar e
1146 -- genOpApp wraps brackets round the operator application, so that the
1147 -- renamer won't subsequently try to re-associate it.
1148 -- For some reason the renamer doesn't reassociate it right, and I can't
1149 -- be bothered to find out why just now.
1151 genOpApp e1 op e2 = mkOpApp e1 op e2
1155 qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
1157 a_RDR = varUnqual SLIT("a")
1158 b_RDR = varUnqual SLIT("b")
1159 c_RDR = varUnqual SLIT("c")
1160 d_RDR = varUnqual SLIT("d")
1161 ah_RDR = varUnqual SLIT("a#")
1162 bh_RDR = varUnqual SLIT("b#")
1163 ch_RDR = varUnqual SLIT("c#")
1164 dh_RDR = varUnqual SLIT("d#")
1165 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1166 rangeSize_RDR = varUnqual SLIT("rangeSize")
1168 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1169 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1170 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1172 a_Expr = HsVar a_RDR
1173 b_Expr = HsVar b_RDR
1174 c_Expr = HsVar c_RDR
1175 d_Expr = HsVar d_RDR
1176 ltTag_Expr = HsVar ltTag_RDR
1177 eqTag_Expr = HsVar eqTag_RDR
1178 gtTag_Expr = HsVar gtTag_RDR
1179 false_Expr = HsVar false_RDR
1180 true_Expr = HsVar true_RDR
1182 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1184 a_Pat = VarPatIn a_RDR
1185 b_Pat = VarPatIn b_RDR
1186 c_Pat = VarPatIn c_RDR
1187 d_Pat = VarPatIn d_RDR
1189 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1191 con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1192 tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1193 maxtag_RDR tycon = varUnqual (SLIT("maxtag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))