2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
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.
22 gen_tag_n_con_monobind,
24 con2tag_RDR, tag2con_RDR, maxtag_RDR,
29 #include "HsVersions.h"
31 import HsSyn ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..),
32 Match(..), GRHSs(..), Stmt(..), HsLit(..),
33 HsBinds(..), HsType(..), HsStmtContext(..),
34 unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
36 import RdrName ( RdrName, mkUnqual, mkRdrUnqual, nameRdrName, getRdrName )
37 import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
38 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
42 import FieldLabel ( fieldLabelName )
43 import DataCon ( isNullaryDataCon, dataConTag,
44 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
47 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
48 occNameUserString, varName,
50 isDataSymOcc, isSymOcc
53 import HscTypes ( FixityEnv, lookupFixity )
54 import PrelNames -- Lots of Names
55 import PrimOp -- Lots of Names
56 import SrcLoc ( generatedSrcLoc, SrcLoc )
57 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
58 maybeTyConSingleCon, tyConFamilySize, tyConTyVars
60 import TcType ( isUnLiftedType, tcEqType, Type )
61 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy )
62 import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon, wordDataCon )
63 import Util ( zipWithEqual, isSingleton,
64 zipWith3Equal, nOfThem, zipEqual )
65 import Panic ( panic, assertPanic )
66 import Char ( ord, isAlpha )
68 import List ( partition, intersperse )
74 %************************************************************************
76 \subsection{Generating code, by derivable class}
78 %************************************************************************
80 %************************************************************************
82 \subsubsection{Generating @Eq@ instance declarations}
84 %************************************************************************
86 Here are the heuristics for the code we generate for @Eq@:
89 Let's assume we have a data type with some (possibly zero) nullary
90 data constructors and some ordinary, non-nullary ones (the rest,
91 also possibly zero of them). Here's an example, with both \tr{N}ullary
92 and \tr{O}rdinary data cons.
94 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
98 For the ordinary constructors (if any), we emit clauses to do The
102 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
103 (==) (O2 a1) (O2 a2) = a1 == a2
104 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
107 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
108 \tr{a2} are \tr{Float#}s, then we have to generate
110 case (a1 `eqFloat#` a2) of
113 for that particular test.
116 If there are any nullary constructors, we emit a catch-all clause of
120 (==) a b = case (con2tag_Foo a) of { a# ->
121 case (con2tag_Foo b) of { b# ->
122 case (a# ==# b#) of {
127 If there aren't any nullary constructors, we emit a simpler
134 For the @(/=)@ method, we normally just use the default method.
136 If the type is an enumeration type, we could/may/should? generate
137 special code that calls @con2tag_Foo@, much like for @(==)@ shown
141 We thought about doing this: If we're also deriving @Ord@ for this
144 instance ... Eq (Foo ...) where
145 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
146 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
148 However, that requires that \tr{Ord <whatever>} was put in the context
149 for the instance decl, which it probably wasn't, so the decls
150 produced don't get through the typechecker.
155 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
159 tycon_loc = getSrcLoc tycon
160 (nullary_cons, nonnullary_cons)
161 | isNewTyCon tycon = ([], tyConDataCons tycon)
162 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
165 = if (null nullary_cons) then
166 case maybeTyConSingleCon tycon of
168 Nothing -> -- if cons don't match, then False
169 [([wildPat, wildPat], false_Expr)]
170 else -- calc. and compare the tags
172 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
173 (genOpApp (HsVar ah_RDR) eqInt_RDR (HsVar bh_RDR)))]
175 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
177 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
178 HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
180 ------------------------------------------------------------------
183 con1_pat = mkConPat data_con_RDR as_needed
184 con2_pat = mkConPat data_con_RDR bs_needed
186 data_con_RDR = getRdrName data_con
187 con_arity = length tys_needed
188 as_needed = take con_arity as_RDRs
189 bs_needed = take con_arity bs_RDRs
190 tys_needed = dataConOrigArgTys data_con
192 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
194 nested_eq_expr [] [] [] = true_Expr
195 nested_eq_expr tys as bs
196 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
198 nested_eq ty a b = HsPar (eq_Expr tycon ty (HsVar a) (HsVar b))
201 %************************************************************************
203 \subsubsection{Generating @Ord@ instance declarations}
205 %************************************************************************
207 For a derived @Ord@, we concentrate our attentions on @compare@
209 compare :: a -> a -> Ordering
210 data Ordering = LT | EQ | GT deriving ()
213 We will use the same example data type as above:
215 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
220 We do all the other @Ord@ methods with calls to @compare@:
222 instance ... (Ord <wurble> <wurble>) where
223 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
224 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
225 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
226 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
228 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
229 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
231 -- compare to come...
235 @compare@ always has two parts. First, we use the compared
236 data-constructors' tags to deal with the case of different
239 compare a b = case (con2tag_Foo a) of { a# ->
240 case (con2tag_Foo b) of { b# ->
241 case (a# ==# b#) of {
243 False -> case (a# <# b#) of
248 cmp_eq = ... to come ...
252 We are only left with the ``help'' function @cmp_eq@, to deal with
253 comparing data constructors with the same tag.
255 For the ordinary constructors (if any), we emit the sorta-obvious
256 compare-style stuff; for our example:
258 cmp_eq (O1 a1 b1) (O1 a2 b2)
259 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
261 cmp_eq (O2 a1) (O2 a2)
264 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
265 = case (compare a1 a2) of {
268 EQ -> case compare b1 b2 of {
276 Again, we must be careful about unlifted comparisons. For example,
277 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
281 cmp_eq lt eq gt (O2 a1) (O2 a2)
283 -- or maybe the unfolded equivalent
287 For the remaining nullary constructors, we already know that the
294 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
298 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
301 = compare -- `AndMonoBinds` compare
302 -- The default declaration in PrelBase handles this
304 tycon_loc = getSrcLoc tycon
305 --------------------------------------------------------------------
306 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
307 [a_Pat, b_Pat] [cmp_eq] compare_rhs
309 | single_con_type = cmp_eq_Expr a_Expr b_Expr
311 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
312 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
313 (cmp_eq_Expr a_Expr b_Expr) -- True case
314 -- False case; they aren't equal
315 -- So we need to do a less-than comparison on the tags
316 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
318 tycon_data_cons = tyConDataCons tycon
319 single_con_type = isSingleton tycon_data_cons
320 (nullary_cons, nonnullary_cons)
321 | isNewTyCon tycon = ([], tyConDataCons tycon)
322 | otherwise = partition isNullaryDataCon tycon_data_cons
324 cmp_eq = mk_FunMonoBind tycon_loc cmp_eq_RDR cmp_eq_match
326 | isEnumerationTyCon tycon
327 -- We know the tags are equal, so if it's an enumeration TyCon,
328 -- then there is nothing left to do
329 -- Catch this specially to avoid warnings
330 -- about overlapping patterns from the desugarer,
331 -- and to avoid unnecessary pattern-matching
332 = [([wildPat,wildPat], eqTag_Expr)]
334 = map pats_etc nonnullary_cons ++
335 (if single_con_type then -- Omit wildcards when there's just one
336 [] -- constructor, to silence desugarer
338 [([wildPat, wildPat], default_rhs)])
342 = ([con1_pat, con2_pat],
343 nested_compare_expr tys_needed as_needed bs_needed)
345 con1_pat = mkConPat data_con_RDR as_needed
346 con2_pat = mkConPat data_con_RDR bs_needed
348 data_con_RDR = getRdrName data_con
349 con_arity = length tys_needed
350 as_needed = take con_arity as_RDRs
351 bs_needed = take con_arity bs_RDRs
352 tys_needed = dataConOrigArgTys data_con
354 nested_compare_expr [ty] [a] [b]
355 = careful_compare_Case tycon ty eqTag_Expr (HsVar a) (HsVar b)
357 nested_compare_expr (ty:tys) (a:as) (b:bs)
358 = let eq_expr = nested_compare_expr tys as bs
359 in careful_compare_Case tycon ty eq_expr (HsVar a) (HsVar b)
361 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
362 -- inexhaustive patterns
363 | otherwise = eqTag_Expr -- Some nullary constructors;
364 -- Tags are equal, no args => return EQ
367 %************************************************************************
369 \subsubsection{Generating @Enum@ instance declarations}
371 %************************************************************************
373 @Enum@ can only be derived for enumeration types. For a type
375 data Foo ... = N1 | N2 | ... | Nn
378 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
379 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
382 instance ... Enum (Foo ...) where
383 succ x = toEnum (1 + fromEnum x)
384 pred x = toEnum (fromEnum x - 1)
386 toEnum i = tag2con_Foo i
388 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
392 = case con2tag_Foo a of
393 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
396 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
400 = case con2tag_Foo a of { a# ->
401 case con2tag_Foo b of { b# ->
402 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
406 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
409 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
412 = succ_enum `AndMonoBinds`
413 pred_enum `AndMonoBinds`
414 to_enum `AndMonoBinds`
415 enum_from `AndMonoBinds`
416 enum_from_then `AndMonoBinds`
419 tycon_loc = getSrcLoc tycon
420 occ_nm = getOccString tycon
423 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
424 untag_Expr tycon [(a_RDR, ah_RDR)] $
425 HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
426 mkHsVarApps mkInt_RDR [ah_RDR]])
427 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
428 (HsApp (HsVar (tag2con_RDR tycon))
429 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
434 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
435 untag_Expr tycon [(a_RDR, ah_RDR)] $
436 HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
437 mkHsVarApps mkInt_RDR [ah_RDR]])
438 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
439 (HsApp (HsVar (tag2con_RDR tycon))
440 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
441 HsLit (HsInt (-1))]))
445 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
446 HsIf (mkHsApps and_RDR
447 [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
448 mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
449 (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
450 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
454 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
455 untag_Expr tycon [(a_RDR, ah_RDR)] $
457 [HsVar (tag2con_RDR tycon),
458 HsPar (enum_from_to_Expr
459 (mkHsVarApps mkInt_RDR [ah_RDR])
460 (HsVar (maxtag_RDR tycon)))]
463 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
464 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
465 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
466 HsPar (enum_from_then_to_Expr
467 (mkHsVarApps mkInt_RDR [ah_RDR])
468 (mkHsVarApps mkInt_RDR [bh_RDR])
469 (HsIf (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
470 mkHsVarApps mkInt_RDR [bh_RDR]])
472 (HsVar (maxtag_RDR tycon))
476 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
477 untag_Expr tycon [(a_RDR, ah_RDR)] $
478 (mkHsVarApps mkInt_RDR [ah_RDR])
481 %************************************************************************
483 \subsubsection{Generating @Bounded@ instance declarations}
485 %************************************************************************
488 gen_Bounded_binds tycon
489 = if isEnumerationTyCon tycon then
490 min_bound_enum `AndMonoBinds` max_bound_enum
492 ASSERT(isSingleton data_cons)
493 min_bound_1con `AndMonoBinds` max_bound_1con
495 data_cons = tyConDataCons tycon
496 tycon_loc = getSrcLoc tycon
498 ----- enum-flavored: ---------------------------
499 min_bound_enum = mkVarMonoBind tycon_loc minBound_RDR (HsVar data_con_1_RDR)
500 max_bound_enum = mkVarMonoBind tycon_loc maxBound_RDR (HsVar data_con_N_RDR)
502 data_con_1 = head data_cons
503 data_con_N = last data_cons
504 data_con_1_RDR = getRdrName data_con_1
505 data_con_N_RDR = getRdrName data_con_N
507 ----- single-constructor-flavored: -------------
508 arity = dataConSourceArity data_con_1
510 min_bound_1con = mkVarMonoBind tycon_loc minBound_RDR $
511 mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
512 max_bound_1con = mkVarMonoBind tycon_loc maxBound_RDR $
513 mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
516 %************************************************************************
518 \subsubsection{Generating @Ix@ instance declarations}
520 %************************************************************************
522 Deriving @Ix@ is only possible for enumeration types and
523 single-constructor types. We deal with them in turn.
525 For an enumeration type, e.g.,
527 data Foo ... = N1 | N2 | ... | Nn
529 things go not too differently from @Enum@:
531 instance ... Ix (Foo ...) where
533 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
537 = case (con2tag_Foo a) of { a# ->
538 case (con2tag_Foo b) of { b# ->
539 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
544 then case (con2tag_Foo d -# con2tag_Foo a) of
546 else error "Ix.Foo.index: out of range"
550 p_tag = con2tag_Foo c
552 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
556 = case (con2tag_Foo a) of { a_tag ->
557 case (con2tag_Foo b) of { b_tag ->
558 case (con2tag_Foo c) of { c_tag ->
559 if (c_tag >=# a_tag) then
565 (modulo suitable case-ification to handle the unlifted tags)
567 For a single-constructor type (NB: this includes all tuples), e.g.,
569 data Foo ... = MkFoo a b Int Double c c
571 we follow the scheme given in Figure~19 of the Haskell~1.2 report
575 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
578 = if isEnumerationTyCon tycon
582 tycon_str = getOccString tycon
583 tycon_loc = getSrcLoc tycon
585 --------------------------------------------------------------
586 enum_ixes = enum_range `AndMonoBinds`
587 enum_index `AndMonoBinds` enum_inRange
590 = mk_easy_FunMonoBind tycon_loc range_RDR
591 [TuplePat [a_Pat, b_Pat] Boxed] [] $
592 untag_Expr tycon [(a_RDR, ah_RDR)] $
593 untag_Expr tycon [(b_RDR, bh_RDR)] $
594 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
595 HsPar (enum_from_to_Expr
596 (mkHsVarApps mkInt_RDR [ah_RDR])
597 (mkHsVarApps mkInt_RDR [bh_RDR]))
600 = mk_easy_FunMonoBind tycon_loc index_RDR
601 [AsPat c_RDR (TuplePat [a_Pat, wildPat] Boxed),
603 HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
604 untag_Expr tycon [(a_RDR, ah_RDR)] (
605 untag_Expr tycon [(d_RDR, dh_RDR)] (
607 rhs = mkHsVarApps mkInt_RDR [c_RDR]
610 (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR))
611 [mk_triv_Match (VarPat c_RDR) rhs]
615 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
620 = mk_easy_FunMonoBind tycon_loc inRange_RDR
621 [TuplePat [a_Pat, b_Pat] Boxed, c_Pat] [] (
622 untag_Expr tycon [(a_RDR, ah_RDR)] (
623 untag_Expr tycon [(b_RDR, bh_RDR)] (
624 untag_Expr tycon [(c_RDR, ch_RDR)] (
625 HsIf (genOpApp (HsVar ch_RDR) geInt_RDR (HsVar ah_RDR)) (
626 (genOpApp (HsVar ch_RDR) leInt_RDR (HsVar bh_RDR))
631 --------------------------------------------------------------
633 = single_con_range `AndMonoBinds`
634 single_con_index `AndMonoBinds`
638 = case maybeTyConSingleCon tycon of -- just checking...
639 Nothing -> panic "get_Ix_binds"
640 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
641 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
644 con_arity = dataConSourceArity data_con
645 data_con_RDR = getRdrName data_con
647 as_needed = take con_arity as_RDRs
648 bs_needed = take con_arity bs_RDRs
649 cs_needed = take con_arity cs_RDRs
651 con_pat xs = mkConPat data_con_RDR xs
652 con_expr = mkHsVarApps data_con_RDR cs_needed
654 --------------------------------------------------------------
656 = mk_easy_FunMonoBind tycon_loc range_RDR
657 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed] [] $
658 mkHsDo ListComp stmts tycon_loc
660 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
662 [ResultStmt con_expr tycon_loc]
664 mk_qual a b c = BindStmt (VarPat c)
665 (HsApp (HsVar range_RDR)
666 (ExplicitTuple [HsVar a, HsVar b] Boxed))
671 = mk_easy_FunMonoBind tycon_loc index_RDR
672 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
673 con_pat cs_needed] [range_size] (
674 foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
676 mk_index multiply_by (l, u, i)
678 (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,
682 (HsApp (HsVar rangeSize_RDR)
683 (ExplicitTuple [HsVar l, HsVar u] Boxed))
684 ) times_RDR multiply_by
688 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
689 [TuplePat [a_Pat, b_Pat] Boxed] [] (
691 (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
693 ) plus_RDR (mkHsIntLit 1))
697 = mk_easy_FunMonoBind tycon_loc inRange_RDR
698 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
701 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
703 in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
707 %************************************************************************
709 \subsubsection{Generating @Read@ instance declarations}
711 %************************************************************************
721 instance Read T where
725 do x <- ReadP.step Read.readPrec
726 Symbol "%%" <- Lex.lex
727 y <- ReadP.step Read.readPrec
731 do Ident "T1" <- Lex.lex
733 Ident "f1" <- Lex.lex
735 x <- ReadP.reset Read.readPrec
737 return (T1 { f1 = x }))
740 do Ident "T2" <- Lex.lexP
741 x <- ReadP.step Read.readPrec
745 readListPrec = readListPrecDefault
746 readList = readListDefault
750 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
752 gen_Read_binds get_fixity tycon
753 = read_prec `AndMonoBinds` default_binds
755 -----------------------------------------------------------------------
757 = mkVarMonoBind loc readList_RDR (HsVar readListDefault_RDR)
759 mkVarMonoBind loc readListPrec_RDR (HsVar readListPrecDefault_RDR)
760 -----------------------------------------------------------------------
762 loc = getSrcLoc tycon
763 data_cons = tyConDataCons tycon
764 (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
766 read_prec = mkVarMonoBind loc readPrec_RDR
767 (HsApp (HsVar parens_RDR) read_cons)
769 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
770 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
773 = case nullary_cons of
775 [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
776 result_stmt con []] loc]
777 _ -> [HsApp (HsVar choose_RDR)
778 (ExplicitList placeHolderType (map mk_pair nullary_cons))]
780 mk_pair con = ExplicitTuple [HsLit (data_con_str con),
781 HsApp (HsVar returnM_RDR) (HsVar (getRdrName con))]
784 read_non_nullary_con data_con
785 = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
787 stmts | is_infix = infix_stmts
788 | length labels > 0 = lbl_stmts
789 | otherwise = prefix_stmts
791 prefix_stmts -- T a b c
792 = [bindLex (ident_pat (data_con_str data_con))]
794 ++ [result_stmt data_con as_needed]
796 infix_stmts -- a %% b
798 bindLex (symbol_pat (data_con_str data_con)),
800 result_stmt data_con [a1,a2]]
802 lbl_stmts -- T { f1 = a, f2 = b }
803 = [bindLex (ident_pat (data_con_str data_con)),
805 ++ concat (intersperse [read_punc ","] field_stmts)
806 ++ [read_punc "}", result_stmt data_con as_needed]
808 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
810 con_arity = dataConSourceArity data_con
811 nullary_con = con_arity == 0
812 labels = dataConFieldLabels data_con
813 lab_fields = length labels
814 dc_nm = getName data_con
815 is_infix = isDataSymOcc (getOccName dc_nm)
816 as_needed = take con_arity as_RDRs
817 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
818 (read_a1:read_a2:_) = read_args
819 (a1:a2:_) = as_needed
820 prec = getPrec is_infix get_fixity dc_nm
822 ------------------------------------------------------------------------
824 ------------------------------------------------------------------------
825 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
826 bindLex pat = BindStmt pat (HsVar lexP_RDR) loc
827 result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
828 con_app c as = mkHsVarApps (getRdrName c) as
830 punc_pat s = ConPatIn punc_RDR (PrefixCon [LitPat (mkHsString s)]) -- Punc 'c'
831 ident_pat s = ConPatIn ident_RDR (PrefixCon [LitPat s]) -- Ident "foo"
832 symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s]) -- Symbol ">>"
834 data_con_str con = mkHsString (occNameUserString (getOccName con))
836 read_punc c = bindLex (punc_pat c)
838 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
839 | otherwise = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
841 read_field lbl a = read_lbl lbl ++
843 BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
845 -- When reading field labels we might encounter
850 read_lbl lbl | is_id_start (head lbl_str)
851 = [bindLex (ident_pat lbl_lit)]
854 bindLex (symbol_pat lbl_lit),
857 lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
858 lbl_lit = mkHsString lbl_str
859 is_id_start c = isAlpha c || c == '_'
863 %************************************************************************
865 \subsubsection{Generating @Show@ instance declarations}
867 %************************************************************************
873 data Tree a = Leaf a | Tree a :^: Tree a
875 instance (Show a) => Show (Tree a) where
877 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
879 showStr = showString "Leaf " . showsPrec (app_prec+1) m
881 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
883 showStr = showsPrec (up_prec+1) u .
885 showsPrec (up_prec+1) v
886 -- Note: right-associativity of :^: ignored
888 up_prec = 5 -- Precedence of :^:
889 app_prec = 10 -- Application has precedence one more than
890 -- the most tightly-binding operator
893 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
895 gen_Show_binds get_fixity tycon
896 = shows_prec `AndMonoBinds` show_list
898 tycon_loc = getSrcLoc tycon
899 -----------------------------------------------------------------------
900 show_list = mkVarMonoBind tycon_loc showList_RDR
901 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
902 -----------------------------------------------------------------------
903 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
906 | nullary_con = -- skip the showParen junk...
907 ASSERT(null bs_needed)
908 ([wildPat, con_pat], mk_showString_app con_str)
911 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
912 (HsPar (nested_compose_Expr show_thingies)))
914 data_con_RDR = getRdrName data_con
915 con_arity = dataConSourceArity data_con
916 bs_needed = take con_arity bs_RDRs
917 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
918 con_pat = mkConPat data_con_RDR bs_needed
919 nullary_con = con_arity == 0
920 labels = dataConFieldLabels data_con
921 lab_fields = length labels
922 record_syntax = lab_fields > 0
924 dc_nm = getName data_con
925 dc_occ_nm = getOccName data_con
926 con_str = occNameUserString dc_occ_nm
929 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
930 | record_syntax = mk_showString_app (con_str ++ " {") :
931 show_record_args ++ [mk_showString_app "}"]
932 | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
934 show_label l = mk_showString_app (the_name ++ " = ")
935 -- Note the spaces around the "=" sign. If we don't have them
936 -- then we get Foo { x=-1 } and the "=-" parses as a single
937 -- lexeme. Only the space after the '=' is necessary, but
938 -- it seems tidier to have them both sides.
940 occ_nm = getOccName (fieldLabelName l)
941 nm = occNameUserString occ_nm
942 is_op = isSymOcc occ_nm -- Legal, but rare.
943 the_name | is_op = '(':nm ++ ")"
946 show_args = zipWith show_arg bs_needed arg_tys
947 (show_arg1:show_arg2:_) = show_args
948 show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
950 -- Assumption for record syntax: no of fields == no of labelled fields
951 -- (and in same order)
952 show_record_args = concat $
953 intersperse [mk_showString_app ", "] $
954 [ [show_label lbl, arg]
955 | (lbl,arg) <- zipEqual "gen_Show_binds"
958 -- Generates (showsPrec p x) for argument x, but it also boxes
959 -- the argument first if necessary. Note that this prints unboxed
960 -- things without any '#' decorations; could change that if need be
961 show_arg b arg_ty = mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec),
962 box_if_necy "Show" tycon (HsVar b) arg_ty]
965 is_infix = isDataSymOcc dc_occ_nm
966 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
967 arg_prec | record_syntax = 0 -- Record fields don't need parens
968 | otherwise = con_prec_plus_one
970 mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str))
974 getPrec :: Bool -> FixityEnv -> Name -> Integer
975 getPrec is_infix get_fixity nm
976 | not is_infix = appPrecedence
977 | otherwise = getPrecedence get_fixity nm
979 appPrecedence :: Integer
980 appPrecedence = fromIntegral maxPrecedence + 1
981 -- One more than the precedence of the most
982 -- tightly-binding operator
984 getPrecedence :: FixityEnv -> Name -> Integer
985 getPrecedence get_fixity nm
986 = case lookupFixity get_fixity nm of
987 Fixity x _ -> fromIntegral x
989 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
990 isLRAssoc get_fixity nm =
991 case lookupFixity get_fixity nm of
992 Fixity _ InfixN -> (False, False)
993 Fixity _ InfixR -> (False, True)
994 Fixity _ InfixL -> (True, False)
998 %************************************************************************
1000 \subsection{Typeable}
1002 %************************************************************************
1010 instance (Typeable a, Typeable b) => Typeable (T a b) where
1011 typeOf _ = mkTypeRep (mkTyConRep "T")
1012 [typeOf (undefined::a),
1013 typeOf (undefined::b)]
1015 Notice the use of lexically scoped type variables.
1018 gen_Typeable_binds :: TyCon -> RdrNameMonoBinds
1019 gen_Typeable_binds tycon
1020 = mk_easy_FunMonoBind tycon_loc typeOf_RDR [wildPat] []
1021 (mkHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
1023 tycon_loc = getSrcLoc tycon
1024 tyvars = tyConTyVars tycon
1025 tycon_rep = HsVar mkTyConRep_RDR `HsApp` HsLit (mkHsString (showSDoc (ppr tycon)))
1026 arg_reps = ExplicitList placeHolderType (map mk tyvars)
1027 mk tyvar = HsApp (HsVar typeOf_RDR)
1028 (ExprWithTySig (HsVar undefined_RDR)
1029 (HsTyVar (getRdrName tyvar)))
1034 %************************************************************************
1038 %************************************************************************
1042 data T a b = T1 a b | T2
1046 $cT1 = mkConstr 1 "T1" Prefix
1047 $cT2 = mkConstr 2 "T2" Prefix
1048 $dT = mkDataType [$con_T1, $con_T2]
1050 instance (Data a, Data b) => Data (T a b) where
1051 gfoldl k z (T1 a b) = z T `k` a `k` b
1052 gfoldl k z T2 = z T2
1053 -- ToDo: add gmapT,Q,M, gfoldr
1055 fromConstr c = case conIndex c of
1056 I# 1# -> T1 undefined undefined
1059 toConstr (T1 _ _) = $cT1
1065 gen_Data_binds :: FixityEnv
1067 -> (RdrNameMonoBinds, -- The method bindings
1068 RdrNameMonoBinds) -- Auxiliary bindings
1069 gen_Data_binds fix_env tycon
1070 = (andMonoBindList [gfoldl_bind, fromCon_bind, toCon_bind, dataTypeOf_bind],
1071 -- Auxiliary definitions: the data type and constructors
1072 datatype_bind `AndMonoBinds` andMonoBindList (map mk_con_bind data_cons))
1074 tycon_loc = getSrcLoc tycon
1075 data_cons = tyConDataCons tycon
1078 gfoldl_bind = mk_FunMonoBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1079 gfoldl_eqn con = ([VarPat k_RDR, VarPat z_RDR, mkConPat con_name as_needed],
1080 foldl mk_k_app (HsVar z_RDR `HsApp` HsVar con_name) as_needed)
1083 con_name = getRdrName con
1084 as_needed = take (dataConSourceArity con) as_RDRs
1085 mk_k_app e v = HsPar (mkHsOpApp e k_RDR (HsVar v))
1087 ------------ fromConstr
1088 fromCon_bind = mk_FunMonoBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)]
1089 from_con_rhs = HsCase (HsVar conIndex_RDR `HsApp` c_Expr)
1090 (map from_con_alt data_cons) tycon_loc
1091 from_con_alt dc = mk_triv_Match (ConPatIn mkInt_RDR (PrefixCon [LitPat (HsIntPrim (toInteger (dataConTag dc)))]))
1092 (mkHsVarApps (getRdrName dc)
1093 (replicate (dataConSourceArity dc) undefined_RDR))
1095 ------------ toConstr
1096 toCon_bind = mk_FunMonoBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1097 to_con_eqn dc = ([mkWildConPat dc], HsVar (mkConstrName dc))
1099 ------------ dataTypeOf
1100 dataTypeOf_bind = mk_easy_FunMonoBind tycon_loc dataTypeOf_RDR [wildPat]
1101 [] (HsVar data_type_name)
1104 data_type_name = mkDataTypeName tycon
1105 datatype_bind = mkVarMonoBind tycon_loc data_type_name
1106 (HsVar mkDataType_RDR `HsApp`
1107 ExplicitList placeHolderType constrs)
1108 constrs = [HsVar (mkConstrName con) | con <- data_cons]
1110 ------------ $cT1 etc
1111 mk_con_bind dc = mkVarMonoBind tycon_loc (mkConstrName dc)
1112 (mkHsApps mkConstr_RDR (constr_args dc))
1113 constr_args dc = [mkHsIntLit (toInteger (dataConTag dc)), -- Tag
1114 HsLit (mkHsString (occNameUserString dc_occ)), -- String name
1115 HsVar fixity] -- Fixity
1117 dc_occ = getOccName dc
1118 is_infix = isDataSymOcc dc_occ
1119 fixity | is_infix = infix_RDR
1120 | otherwise = prefix_RDR
1122 gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl")
1123 fromConstr_RDR = varQual_RDR gENERICS_Name FSLIT("fromConstr")
1124 toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr")
1125 dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
1126 mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr")
1127 mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
1128 conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("conIndex")
1129 prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix")
1130 infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix")
1132 mkDataTypeName :: TyCon -> RdrName -- $tT
1133 mkDataTypeName tc = mkRdrUnqual (mkDataTOcc (getOccName tc))
1135 mkConstrName :: DataCon -> RdrName -- $cT1
1136 mkConstrName con = mkRdrUnqual (mkDataCOcc (getOccName con))
1139 apN :: Int -> (a -> a) -> a -> a
1141 apN n k z = apN (n-1) k (k z)
1144 %************************************************************************
1146 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1148 %************************************************************************
1153 con2tag_Foo :: Foo ... -> Int#
1154 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1155 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1158 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1163 = GenCon2Tag | GenTag2Con | GenMaxTag
1165 gen_tag_n_con_monobind
1166 :: (RdrName, -- (proto)Name for the thing in question
1167 TyCon, -- tycon in question
1171 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1172 | lots_of_constructors
1173 = mk_FunMonoBind loc rdr_name [([], get_tag_rhs)]
1176 = mk_FunMonoBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1179 loc = getSrcLoc tycon
1181 -- Give a signature to the bound variable, so
1182 -- that the case expression generated by getTag is
1183 -- monomorphic. In the push-enter model we get better code.
1184 get_tag_rhs = ExprWithTySig
1185 (HsLam (mk_match loc [VarPat a_RDR]
1186 (HsApp getTag_Expr a_Expr)
1188 (HsForAllTy Nothing [] con2tag_ty)
1189 -- Nothing => implicit quantification
1191 con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon))
1192 [HsTyVar (getRdrName tv) | tv <- tyConTyVars tycon]
1194 HsTyVar (getRdrName intPrimTyConName)
1196 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1198 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1199 mk_stuff con = ([mkWildConPat con],
1200 HsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1202 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1203 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1204 [([mkConPat mkInt_RDR [a_RDR]],
1205 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1206 (HsTyVar (getRdrName tycon)))]
1208 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1209 = mkVarMonoBind (getSrcLoc tycon) rdr_name
1210 (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1212 max_tag = case (tyConDataCons tycon) of
1213 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1217 %************************************************************************
1219 \subsection{Utility bits for generating bindings}
1221 %************************************************************************
1223 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1225 fun pat1 pat2 ... patN = expr where binds
1228 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1229 multi-clause definitions; it generates:
1231 fun p1a p1b ... p1N = e1
1232 fun p2a p2b ... p2N = e2
1234 fun pMa pMb ... pMN = eM
1238 mkVarMonoBind :: SrcLoc -> RdrName -> RdrNameHsExpr -> RdrNameMonoBinds
1239 mkVarMonoBind loc var rhs = mk_easy_FunMonoBind loc var [] [] rhs
1241 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1242 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1245 mk_easy_FunMonoBind loc fun pats binds expr
1246 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1248 mk_easy_Match loc pats binds expr
1249 = mk_match loc pats expr (mkMonoBind Recursive (andMonoBindList binds))
1250 -- The renamer expects everything in its input to be a
1251 -- "recursive" MonoBinds, and it is its job to sort things out
1254 mk_triv_Match pat expr = mkSimpleMatch [pat] expr placeHolderType generatedSrcLoc
1256 mk_FunMonoBind :: SrcLoc -> RdrName
1257 -> [([RdrNamePat], RdrNameHsExpr)]
1260 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1261 mk_FunMonoBind loc fun pats_and_exprs
1262 = FunMonoBind fun False{-not infix-}
1263 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1266 mk_match loc pats expr binds
1267 = Match (map paren pats) Nothing
1268 (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1270 paren p@(VarPat _) = p
1271 paren other_p = ParPat other_p
1275 mkHsApps f xs = foldl HsApp (HsVar f) xs
1276 mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
1278 mkHsIntLit n = HsLit (HsInt n)
1279 mkHsString s = HsString (mkFastString s)
1280 mkHsChar c = HsChar (ord c)
1282 mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars))
1283 mkNullaryConPat con = ConPatIn con (PrefixCon [])
1284 mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat))
1287 ToDo: Better SrcLocs.
1291 RdrNameHsExpr -- What to do for equality
1292 -> RdrNameHsExpr -> RdrNameHsExpr
1294 careful_compare_Case :: -- checks for primitive types...
1295 TyCon -- The tycon we are deriving for
1297 -> RdrNameHsExpr -- What to do for equality
1298 -> RdrNameHsExpr -> RdrNameHsExpr
1301 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1302 -- Was: compare_gen_Case cmp_eq_RDR
1304 compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR
1305 = HsApp (HsApp (HsVar compare_RDR) a) b -- Simple case
1306 compare_gen_Case eq a b -- General case
1307 = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-}
1308 [mk_triv_Match (mkNullaryConPat ltTag_RDR) ltTag_Expr,
1309 mk_triv_Match (mkNullaryConPat eqTag_RDR) eq,
1310 mk_triv_Match (mkNullaryConPat gtTag_RDR) gtTag_Expr]
1313 careful_compare_Case tycon ty eq a b
1314 | not (isUnLiftedType ty)
1315 = compare_gen_Case eq a b
1316 | otherwise -- We have to do something special for primitive things...
1317 = HsIf (genOpApp a relevant_eq_op b)
1319 (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc)
1322 relevant_eq_op = assoc_ty_id "Ord" tycon eq_op_tbl ty
1323 relevant_lt_op = assoc_ty_id "Ord" tycon lt_op_tbl ty
1326 box_if_necy :: String -- The class involved
1327 -> TyCon -- The tycon involved
1328 -> RdrNameHsExpr -- The argument
1329 -> Type -- The argument type
1330 -> RdrNameHsExpr -- Boxed version of the arg
1331 box_if_necy cls_str tycon arg arg_ty
1332 | isUnLiftedType arg_ty = HsApp (HsVar box_con) arg
1335 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1337 assoc_ty_id :: String -- The class involved
1338 -> TyCon -- The tycon involved
1339 -> [(Type,a)] -- The table
1341 -> a -- The result of the lookup
1342 assoc_ty_id cls_str tycon tbl ty
1343 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1344 text "for primitive type" <+> ppr ty)
1345 | otherwise = head res
1347 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1350 [(charPrimTy, eqChar_RDR)
1351 ,(intPrimTy, eqInt_RDR)
1352 ,(wordPrimTy, eqWord_RDR)
1353 ,(addrPrimTy, eqAddr_RDR)
1354 ,(floatPrimTy, eqFloat_RDR)
1355 ,(doublePrimTy, eqDouble_RDR)
1359 [(charPrimTy, ltChar_RDR)
1360 ,(intPrimTy, ltInt_RDR)
1361 ,(wordPrimTy, ltWord_RDR)
1362 ,(addrPrimTy, ltAddr_RDR)
1363 ,(floatPrimTy, ltFloat_RDR)
1364 ,(doublePrimTy, ltDouble_RDR)
1368 [(charPrimTy, getRdrName charDataCon)
1369 ,(intPrimTy, getRdrName intDataCon)
1370 ,(wordPrimTy, getRdrName wordDataCon)
1371 ,(addrPrimTy, addrDataCon_RDR)
1372 ,(floatPrimTy, getRdrName floatDataCon)
1373 ,(doublePrimTy, getRdrName doubleDataCon)
1376 -----------------------------------------------------------------------
1378 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1380 and_Expr a b = genOpApp a and_RDR b
1381 append_Expr a b = genOpApp a append_RDR b
1383 -----------------------------------------------------------------------
1385 eq_Expr :: TyCon -> Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1386 eq_Expr tycon ty a b = genOpApp a eq_op b
1389 | not (isUnLiftedType ty) = eq_RDR
1391 -- we have to do something special for primitive things...
1392 assoc_ty_id "Eq" tycon eq_op_tbl ty
1397 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1398 untag_Expr tycon [] expr = expr
1399 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1400 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1401 [mk_triv_Match (VarPat put_tag_here) (untag_Expr tycon more expr)]
1404 cmp_tags_Expr :: RdrName -- Comparison op
1405 -> RdrName -> RdrName -- Things to compare
1406 -> RdrNameHsExpr -- What to return if true
1407 -> RdrNameHsExpr -- What to return if false
1410 cmp_tags_Expr op a b true_case false_case
1411 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1414 :: RdrNameHsExpr -> RdrNameHsExpr
1416 enum_from_then_to_Expr
1417 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1420 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1421 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1424 :: RdrNameHsExpr -> RdrNameHsExpr
1427 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1429 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1431 nested_compose_Expr [e] = parenify e
1432 nested_compose_Expr (e:es)
1433 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1435 -- impossible_Expr is used in case RHSs that should never happen.
1436 -- We generate these to keep the desugarer from complaining that they *might* happen!
1437 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv")))
1439 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1440 -- method. It is currently only used by Enum.{succ,pred}
1441 illegal_Expr meth tp msg =
1442 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg))))
1444 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1445 -- to include the value of a_RDR in the error string.
1446 illegal_toEnum_tag tp maxtag =
1447 HsApp (HsVar error_RDR)
1448 (HsApp (HsApp (HsVar append_RDR)
1449 (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag (")))))
1450 (HsApp (HsApp (HsApp
1451 (HsVar showsPrec_RDR)
1456 (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,"))))
1457 (HsApp (HsApp (HsApp
1458 (HsVar showsPrec_RDR)
1461 (HsLit (HsString (mkFastString ")")))))))
1463 parenify e@(HsVar _) = e
1464 parenify e = HsPar e
1466 -- genOpApp wraps brackets round the operator application, so that the
1467 -- renamer won't subsequently try to re-associate it.
1468 -- For some reason the renamer doesn't reassociate it right, and I can't
1469 -- be bothered to find out why just now.
1471 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1475 varUnqual n = mkUnqual OccName.varName n
1477 zz_a_RDR = varUnqual FSLIT("_a")
1478 a_RDR = varUnqual FSLIT("a")
1479 b_RDR = varUnqual FSLIT("b")
1480 c_RDR = varUnqual FSLIT("c")
1481 d_RDR = varUnqual FSLIT("d")
1482 e_RDR = varUnqual FSLIT("e")
1483 k_RDR = varUnqual FSLIT("k")
1484 z_RDR = varUnqual FSLIT("z") :: RdrName
1485 ah_RDR = varUnqual FSLIT("a#")
1486 bh_RDR = varUnqual FSLIT("b#")
1487 ch_RDR = varUnqual FSLIT("c#")
1488 dh_RDR = varUnqual FSLIT("d#")
1489 cmp_eq_RDR = varUnqual FSLIT("cmp_eq")
1490 rangeSize_RDR = varUnqual FSLIT("rangeSize")
1492 as_RDRs = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1493 bs_RDRs = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1494 cs_RDRs = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1496 zz_a_Expr = HsVar zz_a_RDR
1497 a_Expr = HsVar a_RDR
1498 b_Expr = HsVar b_RDR
1499 c_Expr = HsVar c_RDR
1500 d_Expr = HsVar d_RDR
1501 z_Expr = HsVar z_RDR
1502 ltTag_Expr = HsVar ltTag_RDR
1503 eqTag_Expr = HsVar eqTag_RDR
1504 gtTag_Expr = HsVar gtTag_RDR
1505 false_Expr = HsVar false_RDR
1506 true_Expr = HsVar true_RDR
1508 getTag_Expr = HsVar getTag_RDR
1509 tagToEnum_Expr = HsVar tagToEnum_RDR
1510 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1512 wildPat = WildPat placeHolderType
1513 zz_a_Pat = VarPat zz_a_RDR
1514 a_Pat = VarPat a_RDR
1515 b_Pat = VarPat b_RDR
1516 c_Pat = VarPat c_RDR
1517 d_Pat = VarPat d_RDR
1519 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1521 con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1522 tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1523 maxtag_RDR tycon = varUnqual (mkFastString ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))
1526 RdrNames for PrimOps. Can't be done in PrelNames, because PrimOp imports
1527 PrelNames, so PrelNames can't import PrimOp.
1530 minusInt_RDR = nameRdrName minusIntName
1531 eqInt_RDR = nameRdrName eqIntName
1532 ltInt_RDR = nameRdrName ltIntName
1533 geInt_RDR = nameRdrName geIntName
1534 leInt_RDR = nameRdrName leIntName
1535 eqChar_RDR = nameRdrName eqCharName
1536 eqWord_RDR = nameRdrName eqWordName
1537 eqAddr_RDR = nameRdrName eqAddrName
1538 eqFloat_RDR = nameRdrName eqFloatName
1539 eqDouble_RDR = nameRdrName eqDoubleName
1540 ltChar_RDR = nameRdrName ltCharName
1541 ltWord_RDR = nameRdrName ltWordName
1542 ltAddr_RDR = nameRdrName ltAddrName
1543 ltFloat_RDR = nameRdrName ltFloatName
1544 ltDouble_RDR = nameRdrName ltDoubleName
1545 tagToEnum_RDR = nameRdrName tagToEnumName