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 Patern.
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 (nullary_cons, nonnullary_cons)
313 | isNewTyCon tycon = ([], tyConDataCons tycon)
314 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
317 = mk_FunMonoBind tycon_loc cmp_eq_RDR (map pats_etc nonnullary_cons ++
318 if ((length nonnullary_cons + length nullary_cons) == 1)
320 else [([WildPatIn, WildPatIn],
324 = ([con1_pat, con2_pat],
325 nested_compare_expr tys_needed as_needed bs_needed)
327 con1_pat = ConPatIn data_con_RDR (map VarPatIn as_needed)
328 con2_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
330 data_con_RDR = qual_orig_name data_con
331 con_arity = length tys_needed
332 as_needed = take con_arity as_RDRs
333 bs_needed = take con_arity bs_RDRs
334 tys_needed = dataConRawArgTys data_con
336 nested_compare_expr [ty] [a] [b]
337 = careful_compare_Case ty ltTag_Expr eqTag_Expr gtTag_Expr (HsVar a) (HsVar b)
339 nested_compare_expr (ty:tys) (a:as) (b:bs)
340 = let eq_expr = nested_compare_expr tys as bs
341 in careful_compare_Case ty ltTag_Expr eq_expr gtTag_Expr (HsVar a) (HsVar b)
343 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
344 -- inexhaustive patterns
345 | otherwise = eqTag_Expr -- Some nullary constructors;
346 -- Tags are equal, no args => return EQ
347 --------------------------------------------------------------------
349 defaulted = foldr1 AndMonoBinds [lt, le, ge, gt, max_, min_]
351 lt = mk_easy_FunMonoBind mkGeneratedSrcLoc lt_RDR [a_Pat, b_Pat] [] (
352 compare_Case true_Expr false_Expr false_Expr a_Expr b_Expr)
353 le = mk_easy_FunMonoBind mkGeneratedSrcLoc le_RDR [a_Pat, b_Pat] [] (
354 compare_Case true_Expr true_Expr false_Expr a_Expr b_Expr)
355 ge = mk_easy_FunMonoBind mkGeneratedSrcLoc ge_RDR [a_Pat, b_Pat] [] (
356 compare_Case false_Expr true_Expr true_Expr a_Expr b_Expr)
357 gt = mk_easy_FunMonoBind mkGeneratedSrcLoc gt_RDR [a_Pat, b_Pat] [] (
358 compare_Case false_Expr false_Expr true_Expr a_Expr b_Expr)
360 max_ = mk_easy_FunMonoBind mkGeneratedSrcLoc max_RDR [a_Pat, b_Pat] [] (
361 compare_Case b_Expr a_Expr a_Expr a_Expr b_Expr)
362 min_ = mk_easy_FunMonoBind mkGeneratedSrcLoc min_RDR [a_Pat, b_Pat] [] (
363 compare_Case a_Expr b_Expr b_Expr a_Expr b_Expr)
366 %************************************************************************
368 \subsubsection{Generating @Enum@ instance declarations}
370 %************************************************************************
372 @Enum@ can only be derived for enumeration types. For a type
374 data Foo ... = N1 | N2 | ... | Nn
377 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
378 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
381 instance ... Enum (Foo ...) where
382 toEnum i = tag2con_Foo i
384 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
388 = case con2tag_Foo a of
389 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
392 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
396 = case con2tag_Foo a of { a# ->
397 case con2tag_Foo b of { b# ->
398 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
402 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
405 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
408 = to_enum `AndMonoBinds`
409 enum_from `AndMonoBinds`
410 enum_from_then `AndMonoBinds`
413 tycon_loc = getSrcLoc tycon
416 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
417 mk_easy_App (tag2con_RDR tycon) [a_RDR]
420 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
421 untag_Expr tycon [(a_RDR, ah_RDR)] $
422 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
423 HsPar (enum_from_to_Expr
424 (mk_easy_App mkInt_RDR [ah_RDR])
425 (HsVar (maxtag_RDR tycon)))
428 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
429 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
430 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
431 HsPar (enum_from_then_to_Expr
432 (mk_easy_App mkInt_RDR [ah_RDR])
433 (mk_easy_App mkInt_RDR [bh_RDR])
434 (HsVar (maxtag_RDR tycon)))
437 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
438 untag_Expr tycon [(a_RDR, ah_RDR)] $
439 (mk_easy_App mkInt_RDR [ah_RDR])
442 %************************************************************************
444 \subsubsection{Generating @Eval@ instance declarations}
446 %************************************************************************
449 gen_Eval_binds tycon = EmptyMonoBinds
452 %************************************************************************
454 \subsubsection{Generating @Bounded@ instance declarations}
456 %************************************************************************
459 gen_Bounded_binds tycon
460 = if isEnumerationTyCon tycon then
461 min_bound_enum `AndMonoBinds` max_bound_enum
463 ASSERT(length data_cons == 1)
464 min_bound_1con `AndMonoBinds` max_bound_1con
466 data_cons = tyConDataCons tycon
467 tycon_loc = getSrcLoc tycon
469 ----- enum-flavored: ---------------------------
470 min_bound_enum = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] (HsVar data_con_1_RDR)
471 max_bound_enum = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] (HsVar data_con_N_RDR)
473 data_con_1 = head data_cons
474 data_con_N = last data_cons
475 data_con_1_RDR = qual_orig_name data_con_1
476 data_con_N_RDR = qual_orig_name data_con_N
478 ----- single-constructor-flavored: -------------
479 arity = argFieldCount data_con_1
481 min_bound_1con = mk_easy_FunMonoBind tycon_loc minBound_RDR [] [] $
482 mk_easy_App data_con_1_RDR (nOfThem arity minBound_RDR)
483 max_bound_1con = mk_easy_FunMonoBind tycon_loc maxBound_RDR [] [] $
484 mk_easy_App data_con_1_RDR (nOfThem arity maxBound_RDR)
487 %************************************************************************
489 \subsubsection{Generating @Ix@ instance declarations}
491 %************************************************************************
493 Deriving @Ix@ is only possible for enumeration types and
494 single-constructor types. We deal with them in turn.
496 For an enumeration type, e.g.,
498 data Foo ... = N1 | N2 | ... | Nn
500 things go not too differently from @Enum@:
502 instance ... Ix (Foo ...) where
504 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
508 = case (con2tag_Foo a) of { a# ->
509 case (con2tag_Foo b) of { b# ->
510 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
515 then case (con2tag_Foo d -# con2tag_Foo a) of
517 else error "Ix.Foo.index: out of range"
521 p_tag = con2tag_Foo c
523 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
527 = case (con2tag_Foo a) of { a_tag ->
528 case (con2tag_Foo b) of { b_tag ->
529 case (con2tag_Foo c) of { c_tag ->
530 if (c_tag >=# a_tag) then
536 (modulo suitable case-ification to handle the unboxed tags)
538 For a single-constructor type (NB: this includes all tuples), e.g.,
540 data Foo ... = MkFoo a b Int Double c c
542 we follow the scheme given in Figure~19 of the Haskell~1.2 report
546 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
549 = if isEnumerationTyCon tycon
553 tycon_str = getOccString tycon
554 tycon_loc = getSrcLoc tycon
556 --------------------------------------------------------------
557 enum_ixes = enum_range `AndMonoBinds`
558 enum_index `AndMonoBinds` enum_inRange
561 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [a_Pat, b_Pat]] [] $
562 untag_Expr tycon [(a_RDR, ah_RDR)] $
563 untag_Expr tycon [(b_RDR, bh_RDR)] $
564 HsApp (mk_easy_App map_RDR [tag2con_RDR tycon]) $
565 HsPar (enum_from_to_Expr
566 (mk_easy_App mkInt_RDR [ah_RDR])
567 (mk_easy_App mkInt_RDR [bh_RDR]))
570 = mk_easy_FunMonoBind tycon_loc index_RDR [AsPatIn c_RDR (TuplePatIn [a_Pat, b_Pat]), d_Pat] [] (
571 HsIf (HsPar (mk_easy_App inRange_RDR [c_RDR, d_RDR])) (
572 untag_Expr tycon [(a_RDR, ah_RDR)] (
573 untag_Expr tycon [(d_RDR, dh_RDR)] (
575 grhs = unguardedRHS (mk_easy_App mkInt_RDR [c_RDR]) tycon_loc
578 (genOpApp (HsVar dh_RDR) minusH_RDR (HsVar ah_RDR))
579 [PatMatch (VarPatIn c_RDR)
580 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
584 HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ ("Ix."++tycon_str++".index: out of range\n"))))
589 = mk_easy_FunMonoBind tycon_loc inRange_RDR [TuplePatIn [a_Pat, b_Pat], c_Pat] [] (
590 untag_Expr tycon [(a_RDR, ah_RDR)] (
591 untag_Expr tycon [(b_RDR, bh_RDR)] (
592 untag_Expr tycon [(c_RDR, ch_RDR)] (
593 HsIf (genOpApp (HsVar ch_RDR) geH_RDR (HsVar ah_RDR)) (
594 (genOpApp (HsVar ch_RDR) leH_RDR (HsVar bh_RDR))
599 --------------------------------------------------------------
601 = single_con_range `AndMonoBinds`
602 single_con_index `AndMonoBinds`
606 = case maybeTyConSingleCon tycon of -- just checking...
607 Nothing -> panic "get_Ix_binds"
608 Just dc -> if (any isUnpointedType (dataConRawArgTys dc)) then
609 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
613 con_arity = argFieldCount data_con
614 data_con_RDR = qual_orig_name data_con
616 as_needed = take con_arity as_RDRs
617 bs_needed = take con_arity bs_RDRs
618 cs_needed = take con_arity cs_RDRs
620 con_pat xs = ConPatIn data_con_RDR (map VarPatIn xs)
621 con_expr = mk_easy_App data_con_RDR cs_needed
623 --------------------------------------------------------------
625 = mk_easy_FunMonoBind tycon_loc range_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed]] [] $
626 HsDo ListComp stmts tycon_loc
628 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
630 [ReturnStmt con_expr]
632 mk_qual a b c = BindStmt (VarPatIn c)
633 (HsApp (HsVar range_RDR) (ExplicitTuple [HsVar a, HsVar b]))
638 = mk_easy_FunMonoBind tycon_loc index_RDR [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed] [range_size] (
639 foldl mk_index (HsLit (HsInt 0)) (zip3 as_needed bs_needed cs_needed))
641 mk_index multiply_by (l, u, i)
643 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [HsVar l, HsVar u])) (HsVar i))
646 (HsApp (HsVar rangeSize_RDR) (ExplicitTuple [HsVar l, HsVar u]))
647 ) times_RDR multiply_by
651 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR [TuplePatIn [a_Pat, b_Pat]] [] (
653 (HsApp (HsApp (HsVar index_RDR) (ExplicitTuple [a_Expr, b_Expr])) b_Expr)
654 ) plus_RDR (HsLit (HsInt 1)))
658 = mk_easy_FunMonoBind tycon_loc inRange_RDR
659 [TuplePatIn [con_pat as_needed, con_pat bs_needed], con_pat cs_needed]
661 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
663 in_range a b c = HsApp (HsApp (HsVar inRange_RDR) (ExplicitTuple [HsVar a, HsVar b])) (HsVar c)
666 %************************************************************************
668 \subsubsection{Generating @Read@ instance declarations}
670 %************************************************************************
672 Ignoring all the infix-ery mumbo jumbo (ToDo)
675 gen_Read_binds :: TyCon -> RdrNameMonoBinds
678 = reads_prec `AndMonoBinds` read_list
680 tycon_loc = getSrcLoc tycon
681 -----------------------------------------------------------------------
682 read_list = mk_easy_FunMonoBind tycon_loc readList_RDR [] []
683 (HsApp (HsVar readList___RDR) (HsPar (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 0)))))
684 -----------------------------------------------------------------------
687 read_con_comprehensions
688 = map read_con (tyConDataCons tycon)
690 mk_easy_FunMonoBind tycon_loc readsPrec_RDR [a_Pat, b_Pat] [] (
691 foldr1 append_Expr read_con_comprehensions
694 read_con data_con -- note: "b" is the string being "read"
696 data_con_RDR = qual_orig_name data_con
697 data_con_str= occNameString (getOccName data_con)
698 con_arity = argFieldCount data_con
699 con_expr = mk_easy_App data_con_RDR as_needed
700 nullary_con = con_arity == 0
701 labels = dataConFieldLabels data_con
702 lab_fields = length labels
704 as_needed = take con_arity as_RDRs
706 | lab_fields == 0 = take con_arity bs_RDRs
707 | otherwise = take (4*lab_fields + 1) bs_RDRs
708 -- (label, '=' and field)*n, (n-1)*',' + '{' + '}'
711 (TuplePatIn [LitPatIn (HsString data_con_str), d_Pat])
712 (HsApp (HsVar lex_RDR) c_Expr)
715 str_qual str res draw_from
717 (TuplePatIn [LitPatIn (HsString str), VarPatIn res])
718 (HsApp (HsVar lex_RDR) draw_from)
722 = let nm = occNameString (getOccName (fieldLabelName f))
724 [str_qual nm, str_qual SLIT("=")]
725 -- There might be spaces between the label and '='
729 snd (mapAccumL mk_qual
731 (zipWithEqual "as_needed"
732 (\ con_field draw_from -> (mk_read_qual con_field,
734 as_needed bs_needed))
737 mapAccumL mk_qual d_Expr
738 (zipEqual "bs_needed"
739 ((str_qual (SLIT("{")):
741 intersperse ([str_qual (_CONS_ ',' _NIL_)]) $
744 (\ as b -> as ++ [b])
746 (map read_label labels)
748 (map mk_read_qual as_needed))) ++ [str_qual (SLIT("}"))])
751 mk_qual draw_from (f, str_left)
752 = (HsVar str_left, -- what to draw from down the line...
753 f str_left draw_from)
755 mk_read_qual con_field res draw_from =
757 (TuplePatIn [VarPatIn con_field, VarPatIn res])
758 (HsApp (HsApp (HsVar readsPrec_RDR) (HsLit (HsInt 10))) draw_from)
761 result_expr = ExplicitTuple [con_expr, if null bs_needed
763 else HsVar (last bs_needed)]
765 stmts = con_qual:field_quals ++ [ReturnStmt result_expr]
768 = if nullary_con then -- must be False (parens are surely optional)
770 else -- parens depend on precedence...
771 HsPar (genOpApp a_Expr gt_RDR (HsLit (HsInt 9)))
774 readParen_Expr read_paren_arg $ HsPar $
775 HsLam (mk_easy_Match tycon_loc [c_Pat] [] $
776 HsDo ListComp stmts tycon_loc)
781 %************************************************************************
783 \subsubsection{Generating @Show@ instance declarations}
785 %************************************************************************
787 Ignoring all the infix-ery mumbo jumbo (ToDo)
790 gen_Show_binds :: TyCon -> RdrNameMonoBinds
793 = shows_prec `AndMonoBinds` show_list
795 tycon_loc = getSrcLoc tycon
796 -----------------------------------------------------------------------
797 show_list = mk_easy_FunMonoBind tycon_loc showList_RDR [] []
798 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 0)))))
799 -----------------------------------------------------------------------
801 = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
805 data_con_RDR = qual_orig_name data_con
806 con_arity = argFieldCount data_con
807 bs_needed = take con_arity bs_RDRs
808 con_pat = ConPatIn data_con_RDR (map VarPatIn bs_needed)
809 nullary_con = con_arity == 0
810 labels = dataConFieldLabels data_con
811 lab_fields = length labels
814 = let nm = occNameString (getOccName data_con)
816 | nullary_con = _NIL_
817 | lab_fields == 0 = SLIT(" ")
818 | otherwise = SLIT("{")
821 mk_showString_app (nm _APPEND_ space_ocurly_maybe)
826 | lab_fields > 0 = [mk_showString_app (SLIT("}"))]
829 con:fs ++ ccurly_maybe
831 show_thingies = show_all show_con real_show_thingies_with_labs
834 = let nm = occNameString (getOccName (fieldLabelName l))
836 mk_showString_app (nm _APPEND_ SLIT("="))
838 mk_showString_app str = HsApp (HsVar showString_RDR)
839 (HsLit (HsString str))
842 [ HsApp (HsApp (HsVar showsPrec_RDR) (HsLit (HsInt 10))) (HsVar b)
845 real_show_thingies_with_labs
846 | lab_fields == 0 = intersperse (HsVar showSpace_RDR) real_show_thingies
847 | otherwise = --Assumption: no of fields == no of labelled fields
848 -- (and in same order)
850 intersperse ([mk_showString_app (_CONS_ ',' _NIL_ )]) $ -- Using SLIT() is not cool here.
851 zipWithEqual "gen_Show_binds"
853 (map show_label labels)
858 if nullary_con then -- skip the showParen junk...
859 ASSERT(null bs_needed)
860 ([a_Pat, con_pat], show_con)
863 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt 10))))
864 (HsPar (nested_compose_Expr show_thingies)))
867 %************************************************************************
869 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
871 %************************************************************************
876 con2tag_Foo :: Foo ... -> Int#
877 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
878 maxtag_Foo :: Int -- ditto (NB: not unboxed)
881 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
886 = GenCon2Tag | GenTag2Con | GenMaxTag
888 gen_tag_n_con_monobind
889 :: (RdrName, -- (proto)Name for the thing in question
890 TyCon, -- tycon in question
894 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
895 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon))
897 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
900 = ASSERT(isDataCon var)
901 ([pat], HsLit (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG))))
903 pat = ConPatIn var_RDR (nOfThem (argFieldCount var) WildPatIn)
904 var_RDR = qual_orig_name var
906 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
907 = mk_FunMonoBind (getSrcLoc tycon) rdr_name (map mk_stuff (tyConDataCons tycon) ++
908 [([WildPatIn], impossible_Expr)])
910 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
913 = ASSERT(isDataCon var)
914 ([lit_pat], HsVar var_RDR)
916 lit_pat = ConPatIn mkInt_RDR [LitPatIn (HsIntPrim (toInteger ((dataConTag var) - fIRST_TAG)))]
917 var_RDR = qual_orig_name var
919 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
920 = mk_easy_FunMonoBind (getSrcLoc tycon)
921 rdr_name [] [] (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
923 max_tag = case (tyConDataCons tycon) of
924 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
928 %************************************************************************
930 \subsection{Utility bits for generating bindings}
932 %************************************************************************
934 @mk_easy_FunMonoBind fun pats binds expr@ generates:
936 fun pat1 pat2 ... patN = expr where binds
939 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
940 multi-clause definitions; it generates:
942 fun p1a p1b ... p1N = e1
943 fun p2a p2b ... p2N = e2
945 fun pMa pMb ... pMN = eM
949 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
950 -> [RdrNameMonoBinds] -> RdrNameHsExpr
953 mk_easy_FunMonoBind loc fun pats binds expr
954 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
956 mk_easy_Match loc pats binds expr
957 = mk_match loc pats expr (mkbind binds)
959 mkbind [] = EmptyBinds
960 mkbind bs = MonoBind (foldr1 AndMonoBinds bs) [] Recursive
961 -- The renamer expects everything in its input to be a
962 -- "recursive" MonoBinds, and it is its job to sort things out
965 mk_FunMonoBind :: SrcLoc -> RdrName
966 -> [([RdrNamePat], RdrNameHsExpr)]
969 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
970 mk_FunMonoBind loc fun pats_and_exprs
971 = FunMonoBind fun False{-not infix-}
972 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
975 mk_match loc pats expr binds
977 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS expr loc) binds))
980 paren p@(VarPatIn _) = p
981 paren other_p = ParPatIn other_p
985 mk_easy_App f xs = foldl HsApp (HsVar f) (map HsVar xs)
988 ToDo: Better SrcLocs.
991 compare_Case, cmp_eq_Expr ::
992 RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
993 -> RdrNameHsExpr -> RdrNameHsExpr
997 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
998 -> RdrNameHsExpr -> RdrNameHsExpr
1000 careful_compare_Case :: -- checks for primitive types...
1002 -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1003 -> RdrNameHsExpr -> RdrNameHsExpr
1006 compare_Case = compare_gen_Case compare_RDR
1007 cmp_eq_Expr = compare_gen_Case cmp_eq_RDR
1009 compare_gen_Case fun lt eq gt a b
1010 = HsCase (HsPar (HsApp (HsApp (HsVar fun) a) b)) {-of-}
1011 [PatMatch (ConPatIn ltTag_RDR [])
1012 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS lt mkGeneratedSrcLoc) EmptyBinds)),
1014 PatMatch (ConPatIn eqTag_RDR [])
1015 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS eq mkGeneratedSrcLoc) EmptyBinds)),
1017 PatMatch (ConPatIn gtTag_RDR [])
1018 (GRHSMatch (GRHSsAndBindsIn (unguardedRHS gt mkGeneratedSrcLoc) EmptyBinds))]
1021 careful_compare_Case ty lt eq gt a b
1022 = if not (isUnboxedType ty) then
1023 compare_gen_Case compare_RDR lt eq gt a b
1025 else -- we have to do something special for primitive things...
1026 HsIf (genOpApp a relevant_eq_op b)
1028 (HsIf (genOpApp a relevant_lt_op b) lt gt mkGeneratedSrcLoc)
1031 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1032 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1034 assoc_ty_id tyids ty
1035 = if null res then panic "assoc_ty"
1038 res = [id | (ty',id) <- tyids, ty == ty']
1041 [(charPrimTy, eqH_Char_RDR)
1042 ,(intPrimTy, eqH_Int_RDR)
1043 ,(wordPrimTy, eqH_Word_RDR)
1044 ,(addrPrimTy, eqH_Addr_RDR)
1045 ,(floatPrimTy, eqH_Float_RDR)
1046 ,(doublePrimTy, eqH_Double_RDR)
1050 [(charPrimTy, ltH_Char_RDR)
1051 ,(intPrimTy, ltH_Int_RDR)
1052 ,(wordPrimTy, ltH_Word_RDR)
1053 ,(addrPrimTy, ltH_Addr_RDR)
1054 ,(floatPrimTy, ltH_Float_RDR)
1055 ,(doublePrimTy, ltH_Double_RDR)
1058 -----------------------------------------------------------------------
1060 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1062 and_Expr a b = genOpApp a and_RDR b
1063 append_Expr a b = genOpApp a append_RDR b
1065 -----------------------------------------------------------------------
1067 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1069 = if not (isUnboxedType ty) then
1071 else -- we have to do something special for primitive things...
1072 genOpApp a relevant_eq_op b
1074 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1078 argFieldCount :: Id -> Int -- Works on data and newtype constructors
1079 argFieldCount con = length (dataConRawArgTys con)
1083 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1084 untag_Expr tycon [] expr = expr
1085 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1086 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1087 [PatMatch (VarPatIn put_tag_here)
1088 (GRHSMatch (GRHSsAndBindsIn grhs EmptyBinds))]
1091 grhs = unguardedRHS (untag_Expr tycon more expr) mkGeneratedSrcLoc
1093 cmp_tags_Expr :: RdrName -- Comparison op
1094 -> RdrName -> RdrName -- Things to compare
1095 -> RdrNameHsExpr -- What to return if true
1096 -> RdrNameHsExpr -- What to return if false
1099 cmp_tags_Expr op a b true_case false_case
1100 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case mkGeneratedSrcLoc
1103 :: RdrNameHsExpr -> RdrNameHsExpr
1105 enum_from_then_to_Expr
1106 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1109 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1110 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1112 showParen_Expr, readParen_Expr
1113 :: RdrNameHsExpr -> RdrNameHsExpr
1116 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1117 readParen_Expr e1 e2 = HsApp (HsApp (HsVar readParen_RDR) e1) e2
1119 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1121 nested_compose_Expr [e] = parenify e
1122 nested_compose_Expr (e:es)
1123 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1125 -- impossible_Expr is used in case RHSs that should never happen.
1126 -- We generate these to keep the desugarer from complaining that they *might* happen!
1127 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (_PK_ "Urk! in TcGenDeriv")))
1129 parenify e@(HsVar _) = e
1130 parenify e = HsPar e
1132 -- genOpApp wraps brackets round the operator application, so that the
1133 -- renamer won't subsequently try to re-associate it.
1134 -- For some reason the renamer doesn't reassociate it right, and I can't
1135 -- be bothered to find out why just now.
1137 genOpApp e1 op e2 = mkOpApp e1 op e2
1141 qual_orig_name n = case modAndOcc n of { (m,n) -> Qual m n HiFile }
1143 a_RDR = varUnqual SLIT("a")
1144 b_RDR = varUnqual SLIT("b")
1145 c_RDR = varUnqual SLIT("c")
1146 d_RDR = varUnqual SLIT("d")
1147 ah_RDR = varUnqual SLIT("a#")
1148 bh_RDR = varUnqual SLIT("b#")
1149 ch_RDR = varUnqual SLIT("c#")
1150 dh_RDR = varUnqual SLIT("d#")
1151 cmp_eq_RDR = varUnqual SLIT("cmp_eq")
1152 rangeSize_RDR = varUnqual SLIT("rangeSize")
1154 as_RDRs = [ varUnqual (_PK_ ("a"++show i)) | i <- [(1::Int) .. ] ]
1155 bs_RDRs = [ varUnqual (_PK_ ("b"++show i)) | i <- [(1::Int) .. ] ]
1156 cs_RDRs = [ varUnqual (_PK_ ("c"++show i)) | i <- [(1::Int) .. ] ]
1158 a_Expr = HsVar a_RDR
1159 b_Expr = HsVar b_RDR
1160 c_Expr = HsVar c_RDR
1161 d_Expr = HsVar d_RDR
1162 ltTag_Expr = HsVar ltTag_RDR
1163 eqTag_Expr = HsVar eqTag_RDR
1164 gtTag_Expr = HsVar gtTag_RDR
1165 false_Expr = HsVar false_RDR
1166 true_Expr = HsVar true_RDR
1168 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1170 a_Pat = VarPatIn a_RDR
1171 b_Pat = VarPatIn b_RDR
1172 c_Pat = VarPatIn c_RDR
1173 d_Pat = VarPatIn d_RDR
1175 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1177 con2tag_RDR tycon = varUnqual (SLIT("con2tag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1178 tag2con_RDR tycon = varUnqual (SLIT("tag2con_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))
1179 maxtag_RDR tycon = varUnqual (SLIT("maxtag_") _APPEND_ occNameString (getOccName tycon) _APPEND_ SLIT("#"))