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, 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, addrDataCon, 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.
154 deriveEq :: RdrName -- Class
155 -> RdrName -- Type constructor
156 -> [ (RdrName, [RdrType]) ] -- Constructors
157 -> (RdrContext, -- Context for the inst decl
158 [RdrBind], -- Binds in the inst decl
159 [RdrBind]) -- Extra value bindings outside
161 deriveEq clas tycon constrs
162 = (context, [eq_bind, ne_bind], [])
164 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
167 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
168 is_nullary (_, args) = null args
171 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
175 tycon_loc = getSrcLoc tycon
176 (nullary_cons, nonnullary_cons)
177 | isNewTyCon tycon = ([], tyConDataCons tycon)
178 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
181 = if (null nullary_cons) then
182 case maybeTyConSingleCon tycon of
184 Nothing -> -- if cons don't match, then False
185 [([wildPat, wildPat], false_Expr)]
186 else -- calc. and compare the tags
188 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
189 (genOpApp (HsVar ah_RDR) eqInt_RDR (HsVar bh_RDR)))]
191 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
193 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
194 HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
196 ------------------------------------------------------------------
199 con1_pat = mkConPat data_con_RDR as_needed
200 con2_pat = mkConPat data_con_RDR bs_needed
202 data_con_RDR = getRdrName data_con
203 con_arity = length tys_needed
204 as_needed = take con_arity as_RDRs
205 bs_needed = take con_arity bs_RDRs
206 tys_needed = dataConOrigArgTys data_con
208 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
210 nested_eq_expr [] [] [] = true_Expr
211 nested_eq_expr tys as bs
212 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
214 nested_eq ty a b = HsPar (eq_Expr tycon ty (HsVar a) (HsVar b))
217 %************************************************************************
219 \subsubsection{Generating @Ord@ instance declarations}
221 %************************************************************************
223 For a derived @Ord@, we concentrate our attentions on @compare@
225 compare :: a -> a -> Ordering
226 data Ordering = LT | EQ | GT deriving ()
229 We will use the same example data type as above:
231 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
236 We do all the other @Ord@ methods with calls to @compare@:
238 instance ... (Ord <wurble> <wurble>) where
239 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
240 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
241 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
242 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
244 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
245 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
247 -- compare to come...
251 @compare@ always has two parts. First, we use the compared
252 data-constructors' tags to deal with the case of different
255 compare a b = case (con2tag_Foo a) of { a# ->
256 case (con2tag_Foo b) of { b# ->
257 case (a# ==# b#) of {
259 False -> case (a# <# b#) of
264 cmp_eq = ... to come ...
268 We are only left with the ``help'' function @cmp_eq@, to deal with
269 comparing data constructors with the same tag.
271 For the ordinary constructors (if any), we emit the sorta-obvious
272 compare-style stuff; for our example:
274 cmp_eq (O1 a1 b1) (O1 a2 b2)
275 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
277 cmp_eq (O2 a1) (O2 a2)
280 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
281 = case (compare a1 a2) of {
284 EQ -> case compare b1 b2 of {
292 Again, we must be careful about unlifted comparisons. For example,
293 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
297 cmp_eq lt eq gt (O2 a1) (O2 a2)
299 -- or maybe the unfolded equivalent
303 For the remaining nullary constructors, we already know that the
310 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
314 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
317 = compare -- `AndMonoBinds` compare
318 -- The default declaration in PrelBase handles this
320 tycon_loc = getSrcLoc tycon
321 --------------------------------------------------------------------
322 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
323 [a_Pat, b_Pat] [cmp_eq] compare_rhs
325 | single_con_type = cmp_eq_Expr a_Expr b_Expr
327 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
328 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
329 (cmp_eq_Expr a_Expr b_Expr) -- True case
330 -- False case; they aren't equal
331 -- So we need to do a less-than comparison on the tags
332 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
334 tycon_data_cons = tyConDataCons tycon
335 single_con_type = isSingleton tycon_data_cons
336 (nullary_cons, nonnullary_cons)
337 | isNewTyCon tycon = ([], tyConDataCons tycon)
338 | otherwise = partition isNullaryDataCon tycon_data_cons
340 cmp_eq = mk_FunMonoBind tycon_loc cmp_eq_RDR cmp_eq_match
342 | isEnumerationTyCon tycon
343 -- We know the tags are equal, so if it's an enumeration TyCon,
344 -- then there is nothing left to do
345 -- Catch this specially to avoid warnings
346 -- about overlapping patterns from the desugarer,
347 -- and to avoid unnecessary pattern-matching
348 = [([wildPat,wildPat], eqTag_Expr)]
350 = map pats_etc nonnullary_cons ++
351 (if single_con_type then -- Omit wildcards when there's just one
352 [] -- constructor, to silence desugarer
354 [([wildPat, wildPat], default_rhs)])
358 = ([con1_pat, con2_pat],
359 nested_compare_expr tys_needed as_needed bs_needed)
361 con1_pat = mkConPat data_con_RDR as_needed
362 con2_pat = mkConPat data_con_RDR bs_needed
364 data_con_RDR = getRdrName data_con
365 con_arity = length tys_needed
366 as_needed = take con_arity as_RDRs
367 bs_needed = take con_arity bs_RDRs
368 tys_needed = dataConOrigArgTys data_con
370 nested_compare_expr [ty] [a] [b]
371 = careful_compare_Case tycon ty eqTag_Expr (HsVar a) (HsVar b)
373 nested_compare_expr (ty:tys) (a:as) (b:bs)
374 = let eq_expr = nested_compare_expr tys as bs
375 in careful_compare_Case tycon ty eq_expr (HsVar a) (HsVar b)
377 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
378 -- inexhaustive patterns
379 | otherwise = eqTag_Expr -- Some nullary constructors;
380 -- Tags are equal, no args => return EQ
383 %************************************************************************
385 \subsubsection{Generating @Enum@ instance declarations}
387 %************************************************************************
389 @Enum@ can only be derived for enumeration types. For a type
391 data Foo ... = N1 | N2 | ... | Nn
394 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
395 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
398 instance ... Enum (Foo ...) where
399 succ x = toEnum (1 + fromEnum x)
400 pred x = toEnum (fromEnum x - 1)
402 toEnum i = tag2con_Foo i
404 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
408 = case con2tag_Foo a of
409 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
412 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
416 = case con2tag_Foo a of { a# ->
417 case con2tag_Foo b of { b# ->
418 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
422 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
425 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
428 = succ_enum `AndMonoBinds`
429 pred_enum `AndMonoBinds`
430 to_enum `AndMonoBinds`
431 enum_from `AndMonoBinds`
432 enum_from_then `AndMonoBinds`
435 tycon_loc = getSrcLoc tycon
436 occ_nm = getOccString tycon
439 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
440 untag_Expr tycon [(a_RDR, ah_RDR)] $
441 HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
442 mkHsVarApps mkInt_RDR [ah_RDR]])
443 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
444 (HsApp (HsVar (tag2con_RDR tycon))
445 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
450 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
451 untag_Expr tycon [(a_RDR, ah_RDR)] $
452 HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
453 mkHsVarApps mkInt_RDR [ah_RDR]])
454 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
455 (HsApp (HsVar (tag2con_RDR tycon))
456 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
457 HsLit (HsInt (-1))]))
461 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
462 HsIf (mkHsApps and_RDR
463 [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
464 mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
465 (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
466 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
470 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
471 untag_Expr tycon [(a_RDR, ah_RDR)] $
473 [HsVar (tag2con_RDR tycon),
474 HsPar (enum_from_to_Expr
475 (mkHsVarApps mkInt_RDR [ah_RDR])
476 (HsVar (maxtag_RDR tycon)))]
479 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
480 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
481 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
482 HsPar (enum_from_then_to_Expr
483 (mkHsVarApps mkInt_RDR [ah_RDR])
484 (mkHsVarApps mkInt_RDR [bh_RDR])
485 (HsIf (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
486 mkHsVarApps mkInt_RDR [bh_RDR]])
488 (HsVar (maxtag_RDR tycon))
492 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
493 untag_Expr tycon [(a_RDR, ah_RDR)] $
494 (mkHsVarApps mkInt_RDR [ah_RDR])
497 %************************************************************************
499 \subsubsection{Generating @Bounded@ instance declarations}
501 %************************************************************************
504 gen_Bounded_binds tycon
505 = if isEnumerationTyCon tycon then
506 min_bound_enum `AndMonoBinds` max_bound_enum
508 ASSERT(isSingleton data_cons)
509 min_bound_1con `AndMonoBinds` max_bound_1con
511 data_cons = tyConDataCons tycon
512 tycon_loc = getSrcLoc tycon
514 ----- enum-flavored: ---------------------------
515 min_bound_enum = mkVarMonoBind tycon_loc minBound_RDR (HsVar data_con_1_RDR)
516 max_bound_enum = mkVarMonoBind tycon_loc maxBound_RDR (HsVar data_con_N_RDR)
518 data_con_1 = head data_cons
519 data_con_N = last data_cons
520 data_con_1_RDR = getRdrName data_con_1
521 data_con_N_RDR = getRdrName data_con_N
523 ----- single-constructor-flavored: -------------
524 arity = dataConSourceArity data_con_1
526 min_bound_1con = mkVarMonoBind tycon_loc minBound_RDR $
527 mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
528 max_bound_1con = mkVarMonoBind tycon_loc maxBound_RDR $
529 mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
532 %************************************************************************
534 \subsubsection{Generating @Ix@ instance declarations}
536 %************************************************************************
538 Deriving @Ix@ is only possible for enumeration types and
539 single-constructor types. We deal with them in turn.
541 For an enumeration type, e.g.,
543 data Foo ... = N1 | N2 | ... | Nn
545 things go not too differently from @Enum@:
547 instance ... Ix (Foo ...) where
549 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
553 = case (con2tag_Foo a) of { a# ->
554 case (con2tag_Foo b) of { b# ->
555 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
560 then case (con2tag_Foo d -# con2tag_Foo a) of
562 else error "Ix.Foo.index: out of range"
566 p_tag = con2tag_Foo c
568 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
572 = case (con2tag_Foo a) of { a_tag ->
573 case (con2tag_Foo b) of { b_tag ->
574 case (con2tag_Foo c) of { c_tag ->
575 if (c_tag >=# a_tag) then
581 (modulo suitable case-ification to handle the unlifted tags)
583 For a single-constructor type (NB: this includes all tuples), e.g.,
585 data Foo ... = MkFoo a b Int Double c c
587 we follow the scheme given in Figure~19 of the Haskell~1.2 report
591 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
594 = if isEnumerationTyCon tycon
598 tycon_str = getOccString tycon
599 tycon_loc = getSrcLoc tycon
601 --------------------------------------------------------------
602 enum_ixes = enum_range `AndMonoBinds`
603 enum_index `AndMonoBinds` enum_inRange
606 = mk_easy_FunMonoBind tycon_loc range_RDR
607 [TuplePat [a_Pat, b_Pat] Boxed] [] $
608 untag_Expr tycon [(a_RDR, ah_RDR)] $
609 untag_Expr tycon [(b_RDR, bh_RDR)] $
610 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
611 HsPar (enum_from_to_Expr
612 (mkHsVarApps mkInt_RDR [ah_RDR])
613 (mkHsVarApps mkInt_RDR [bh_RDR]))
616 = mk_easy_FunMonoBind tycon_loc index_RDR
617 [AsPat c_RDR (TuplePat [a_Pat, wildPat] Boxed),
619 HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
620 untag_Expr tycon [(a_RDR, ah_RDR)] (
621 untag_Expr tycon [(d_RDR, dh_RDR)] (
623 rhs = mkHsVarApps mkInt_RDR [c_RDR]
626 (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR))
627 [mkSimpleMatch [VarPat c_RDR] rhs placeHolderType tycon_loc]
631 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
636 = mk_easy_FunMonoBind tycon_loc inRange_RDR
637 [TuplePat [a_Pat, b_Pat] Boxed, c_Pat] [] (
638 untag_Expr tycon [(a_RDR, ah_RDR)] (
639 untag_Expr tycon [(b_RDR, bh_RDR)] (
640 untag_Expr tycon [(c_RDR, ch_RDR)] (
641 HsIf (genOpApp (HsVar ch_RDR) geInt_RDR (HsVar ah_RDR)) (
642 (genOpApp (HsVar ch_RDR) leInt_RDR (HsVar bh_RDR))
647 --------------------------------------------------------------
649 = single_con_range `AndMonoBinds`
650 single_con_index `AndMonoBinds`
654 = case maybeTyConSingleCon tycon of -- just checking...
655 Nothing -> panic "get_Ix_binds"
656 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
657 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
660 con_arity = dataConSourceArity data_con
661 data_con_RDR = getRdrName data_con
663 as_needed = take con_arity as_RDRs
664 bs_needed = take con_arity bs_RDRs
665 cs_needed = take con_arity cs_RDRs
667 con_pat xs = mkConPat data_con_RDR xs
668 con_expr = mkHsVarApps data_con_RDR cs_needed
670 --------------------------------------------------------------
672 = mk_easy_FunMonoBind tycon_loc range_RDR
673 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed] [] $
674 mkHsDo ListComp stmts tycon_loc
676 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
678 [ResultStmt con_expr tycon_loc]
680 mk_qual a b c = BindStmt (VarPat c)
681 (HsApp (HsVar range_RDR)
682 (ExplicitTuple [HsVar a, HsVar b] Boxed))
687 = mk_easy_FunMonoBind tycon_loc index_RDR
688 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
689 con_pat cs_needed] [range_size] (
690 foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
692 mk_index multiply_by (l, u, i)
694 (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,
698 (HsApp (HsVar rangeSize_RDR)
699 (ExplicitTuple [HsVar l, HsVar u] Boxed))
700 ) times_RDR multiply_by
704 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
705 [TuplePat [a_Pat, b_Pat] Boxed] [] (
707 (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
709 ) plus_RDR (mkHsIntLit 1))
713 = mk_easy_FunMonoBind tycon_loc inRange_RDR
714 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
717 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
719 in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
723 %************************************************************************
725 \subsubsection{Generating @Read@ instance declarations}
727 %************************************************************************
737 instance Read T where
741 do x <- ReadP.step Read.readPrec
742 Symbol "%%" <- Lex.lex
743 y <- ReadP.step Read.readPrec
747 do Ident "T1" <- Lex.lex
749 Ident "f1" <- Lex.lex
751 x <- ReadP.reset Read.readPrec
753 return (T1 { f1 = x }))
756 do Ident "T2" <- Lex.lexP
757 x <- ReadP.step Read.readPrec
761 readListPrec = readListPrecDefault
762 readList = readListDefault
766 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
768 gen_Read_binds get_fixity tycon
769 = read_prec `AndMonoBinds` default_binds
771 -----------------------------------------------------------------------
773 = mkVarMonoBind loc readList_RDR (HsVar readListDefault_RDR)
775 mkVarMonoBind loc readListPrec_RDR (HsVar readListPrecDefault_RDR)
776 -----------------------------------------------------------------------
778 loc = getSrcLoc tycon
779 data_cons = tyConDataCons tycon
780 (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
782 read_prec = mkVarMonoBind loc readPrec_RDR
783 (HsApp (HsVar parens_RDR) read_cons)
785 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
786 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
789 = case nullary_cons of
791 [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
792 result_stmt con []] loc]
793 _ -> [HsApp (HsVar choose_RDR)
794 (ExplicitList placeHolderType (map mk_pair nullary_cons))]
796 mk_pair con = ExplicitTuple [HsLit (data_con_str con),
797 HsApp (HsVar returnM_RDR) (HsVar (getRdrName con))]
800 read_non_nullary_con data_con
801 = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
803 stmts | is_infix = infix_stmts
804 | length labels > 0 = lbl_stmts
805 | otherwise = prefix_stmts
807 prefix_stmts -- T a b c
808 = [bindLex (ident_pat (data_con_str data_con))]
810 ++ [result_stmt data_con as_needed]
812 infix_stmts -- a %% b
814 bindLex (symbol_pat (data_con_str data_con)),
816 result_stmt data_con [a1,a2]]
818 lbl_stmts -- T { f1 = a, f2 = b }
819 = [bindLex (ident_pat (data_con_str data_con)),
821 ++ concat (intersperse [read_punc ","] field_stmts)
822 ++ [read_punc "}", result_stmt data_con as_needed]
824 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
826 con_arity = dataConSourceArity data_con
827 nullary_con = con_arity == 0
828 labels = dataConFieldLabels data_con
829 lab_fields = length labels
830 dc_nm = getName data_con
831 is_infix = isDataSymOcc (getOccName dc_nm)
832 as_needed = take con_arity as_RDRs
833 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
834 (read_a1:read_a2:_) = read_args
835 (a1:a2:_) = as_needed
836 prec = getPrec is_infix get_fixity dc_nm
838 ------------------------------------------------------------------------
840 ------------------------------------------------------------------------
841 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
842 bindLex pat = BindStmt pat (HsVar lexP_RDR) loc
843 result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
844 con_app c as = mkHsVarApps (getRdrName c) as
846 punc_pat s = ConPatIn punc_RDR (PrefixCon [LitPat (mkHsString s)]) -- Punc 'c'
847 ident_pat s = ConPatIn ident_RDR (PrefixCon [LitPat s]) -- Ident "foo"
848 symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s]) -- Symbol ">>"
850 data_con_str con = mkHsString (occNameUserString (getOccName con))
852 read_punc c = bindLex (punc_pat c)
854 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
855 | otherwise = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
857 read_field lbl a = read_lbl lbl ++
859 BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
861 -- When reading field labels we might encounter
866 read_lbl lbl | is_id_start (head lbl_str)
867 = [bindLex (ident_pat lbl_lit)]
870 bindLex (symbol_pat lbl_lit),
873 lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
874 lbl_lit = mkHsString lbl_str
875 is_id_start c = isAlpha c || c == '_'
879 %************************************************************************
881 \subsubsection{Generating @Show@ instance declarations}
883 %************************************************************************
889 data Tree a = Leaf a | Tree a :^: Tree a
891 instance (Show a) => Show (Tree a) where
893 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
895 showStr = showString "Leaf " . showsPrec (app_prec+1) m
897 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
899 showStr = showsPrec (up_prec+1) u .
901 showsPrec (up_prec+1) v
902 -- Note: right-associativity of :^: ignored
904 up_prec = 5 -- Precedence of :^:
905 app_prec = 10 -- Application has precedence one more than
906 -- the most tightly-binding operator
909 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
911 gen_Show_binds get_fixity tycon
912 = shows_prec `AndMonoBinds` show_list
914 tycon_loc = getSrcLoc tycon
915 -----------------------------------------------------------------------
916 show_list = mkVarMonoBind tycon_loc showList_RDR
917 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
918 -----------------------------------------------------------------------
919 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
922 | nullary_con = -- skip the showParen junk...
923 ASSERT(null bs_needed)
924 ([wildPat, con_pat], mk_showString_app con_str)
927 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
928 (HsPar (nested_compose_Expr show_thingies)))
930 data_con_RDR = getRdrName data_con
931 con_arity = dataConSourceArity data_con
932 bs_needed = take con_arity bs_RDRs
933 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
934 con_pat = mkConPat data_con_RDR bs_needed
935 nullary_con = con_arity == 0
936 labels = dataConFieldLabels data_con
937 lab_fields = length labels
938 record_syntax = lab_fields > 0
940 dc_nm = getName data_con
941 dc_occ_nm = getOccName data_con
942 con_str = occNameUserString dc_occ_nm
945 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
946 | record_syntax = mk_showString_app (con_str ++ " {") :
947 show_record_args ++ [mk_showString_app "}"]
948 | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
950 show_label l = mk_showString_app (the_name ++ " = ")
951 -- Note the spaces around the "=" sign. If we don't have them
952 -- then we get Foo { x=-1 } and the "=-" parses as a single
953 -- lexeme. Only the space after the '=' is necessary, but
954 -- it seems tidier to have them both sides.
956 occ_nm = getOccName (fieldLabelName l)
957 nm = occNameUserString occ_nm
958 is_op = isSymOcc occ_nm -- Legal, but rare.
959 the_name | is_op = '(':nm ++ ")"
962 show_args = zipWith show_arg bs_needed arg_tys
963 (show_arg1:show_arg2:_) = show_args
964 show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
966 -- Assumption for record syntax: no of fields == no of labelled fields
967 -- (and in same order)
968 show_record_args = concat $
969 intersperse [mk_showString_app ", "] $
970 [ [show_label lbl, arg]
971 | (lbl,arg) <- zipEqual "gen_Show_binds"
974 -- Generates (showsPrec p x) for argument x, but it also boxes
975 -- the argument first if necessary. Note that this prints unboxed
976 -- things without any '#' decorations; could change that if need be
977 show_arg b arg_ty = mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec),
978 box_if_necy "Show" tycon (HsVar b) arg_ty]
981 is_infix = isDataSymOcc dc_occ_nm
982 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
983 arg_prec | record_syntax = 0 -- Record fields don't need parens
984 | otherwise = con_prec_plus_one
986 mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str))
990 getPrec :: Bool -> FixityEnv -> Name -> Integer
991 getPrec is_infix get_fixity nm
992 | not is_infix = appPrecedence
993 | otherwise = getPrecedence get_fixity nm
995 appPrecedence :: Integer
996 appPrecedence = fromIntegral maxPrecedence + 1
997 -- One more than the precedence of the most
998 -- tightly-binding operator
1000 getPrecedence :: FixityEnv -> Name -> Integer
1001 getPrecedence get_fixity nm
1002 = case lookupFixity get_fixity nm of
1003 Fixity x _ -> fromIntegral x
1005 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
1006 isLRAssoc get_fixity nm =
1007 case lookupFixity get_fixity nm of
1008 Fixity _ InfixN -> (False, False)
1009 Fixity _ InfixR -> (False, True)
1010 Fixity _ InfixL -> (True, False)
1014 %************************************************************************
1016 \subsection{Typeable}
1018 %************************************************************************
1026 instance (Typeable a, Typeable b) => Typeable (T a b) where
1027 typeOf _ = mkTypeRep (mkTyConRep "T")
1028 [typeOf (undefined::a),
1029 typeOf (undefined::b)]
1031 Notice the use of lexically scoped type variables.
1034 gen_Typeable_binds :: TyCon -> RdrNameMonoBinds
1035 gen_Typeable_binds tycon
1036 = mk_easy_FunMonoBind tycon_loc typeOf_RDR [wildPat] []
1037 (mkHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
1039 tycon_loc = getSrcLoc tycon
1040 tyvars = tyConTyVars tycon
1041 tycon_rep = HsVar mkTyConRep_RDR `HsApp` HsLit (mkHsString (showSDoc (ppr tycon)))
1042 arg_reps = ExplicitList placeHolderType (map mk tyvars)
1043 mk tyvar = HsApp (HsVar typeOf_RDR)
1044 (ExprWithTySig (HsVar undefined_RDR)
1045 (HsTyVar (getRdrName tyvar)))
1050 %************************************************************************
1054 %************************************************************************
1058 data T a b = T1 a b | T2
1062 instance (Data a, Data b) => Data (T a b) where
1063 gfoldl k z (T1 a b) = z T `k` a `k` b
1064 gfoldl k z T2 = z T2
1065 -- ToDo: add gmapT,Q,M, gfoldr
1067 gunfold k z (Constr "T1") = k (k (z T1))
1068 gunfold k z (Constr "T2") = z T2
1070 conOf (T1 _ _) = Constr "T1"
1071 conOf T2 = Constr "T2"
1073 consOf _ = [Constr "T1", Constr "T2"]
1075 ToDo: generate auxiliary bindings for the Constrs?
1078 gen_Data_binds :: TyCon -> RdrNameMonoBinds
1079 gen_Data_binds tycon
1080 = andMonoBindList [gfoldl_bind, gunfold_bind, conOf_bind, consOf_bind]
1082 tycon_loc = getSrcLoc tycon
1083 data_cons = tyConDataCons tycon
1086 gfoldl_bind = mk_FunMonoBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1087 gfoldl_eqn con = ([VarPat k_RDR, VarPat z_RDR, mkConPat con_name as_needed],
1088 foldl mk_k_app (HsVar z_RDR `HsApp` HsVar con_name) as_needed)
1091 con_name = getRdrName con
1092 as_needed = take (dataConSourceArity con) as_RDRs
1093 mk_k_app e v = HsPar (mkHsOpApp e k_RDR (HsVar v))
1095 ------------ gunfold
1096 gunfold_bind = mk_FunMonoBind tycon_loc gunfold_RDR (map gunfold_eqn data_cons)
1097 gunfold_eqn con = ([VarPat k_RDR, VarPat z_RDR,
1098 ConPatIn constr_RDR (PrefixCon [LitPat (mk_constr_string con)])],
1099 apN (dataConSourceArity con)
1100 (\e -> HsVar k_RDR `HsApp` e)
1101 (z_Expr `HsApp` HsVar (getRdrName con)))
1102 mk_constr_string con = mkHsString (occNameUserString (getOccName con))
1105 conOf_bind = mk_FunMonoBind tycon_loc conOf_RDR (map conOf_eqn data_cons)
1106 conOf_eqn con = ([mkWildConPat con], mk_constr con)
1109 consOf_bind = mk_easy_FunMonoBind tycon_loc consOf_RDR [wildPat] []
1110 (ExplicitList placeHolderType (map mk_constr data_cons))
1111 mk_constr con = HsVar constr_RDR `HsApp` (HsLit (mk_constr_string con))
1114 apN :: Int -> (a -> a) -> a -> a
1116 apN n k z = apN (n-1) k (k z)
1119 %************************************************************************
1121 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1123 %************************************************************************
1128 con2tag_Foo :: Foo ... -> Int#
1129 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1130 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1133 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1138 = GenCon2Tag | GenTag2Con | GenMaxTag
1140 gen_tag_n_con_monobind
1141 :: (RdrName, -- (proto)Name for the thing in question
1142 TyCon, -- tycon in question
1146 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1147 | lots_of_constructors
1148 = mk_FunMonoBind loc rdr_name [([], get_tag_rhs)]
1151 = mk_FunMonoBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1154 loc = getSrcLoc tycon
1156 -- Give a signature to the bound variable, so
1157 -- that the case expression generated by getTag is
1158 -- monomorphic. In the push-enter model we get better code.
1159 get_tag_rhs = ExprWithTySig
1160 (HsLam (mk_match loc [VarPat a_RDR]
1161 (HsApp getTag_Expr a_Expr)
1163 (HsForAllTy Nothing [] con2tag_ty)
1164 -- Nothing => implicit quantification
1166 con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon))
1167 [HsTyVar (getRdrName tv) | tv <- tyConTyVars tycon]
1169 HsTyVar (getRdrName intPrimTyConName)
1171 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1173 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1174 mk_stuff con = ([mkWildConPat con],
1175 HsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1177 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1178 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1179 [([mkConPat mkInt_RDR [a_RDR]],
1180 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1181 (HsTyVar (getRdrName tycon)))]
1183 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1184 = mkVarMonoBind (getSrcLoc tycon) rdr_name
1185 (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1187 max_tag = case (tyConDataCons tycon) of
1188 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1192 %************************************************************************
1194 \subsection{Utility bits for generating bindings}
1196 %************************************************************************
1198 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1200 fun pat1 pat2 ... patN = expr where binds
1203 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1204 multi-clause definitions; it generates:
1206 fun p1a p1b ... p1N = e1
1207 fun p2a p2b ... p2N = e2
1209 fun pMa pMb ... pMN = eM
1213 mkVarMonoBind :: SrcLoc -> RdrName -> RdrNameHsExpr -> RdrNameMonoBinds
1214 mkVarMonoBind loc var rhs = mk_easy_FunMonoBind loc var [] [] rhs
1216 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1217 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1220 mk_easy_FunMonoBind loc fun pats binds expr
1221 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1223 mk_easy_Match loc pats binds expr
1224 = mk_match loc pats expr (mkMonoBind Recursive (andMonoBindList binds))
1225 -- The renamer expects everything in its input to be a
1226 -- "recursive" MonoBinds, and it is its job to sort things out
1229 mk_FunMonoBind :: SrcLoc -> RdrName
1230 -> [([RdrNamePat], RdrNameHsExpr)]
1233 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1234 mk_FunMonoBind loc fun pats_and_exprs
1235 = FunMonoBind fun False{-not infix-}
1236 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1239 mk_match loc pats expr binds
1240 = Match (map paren pats) Nothing
1241 (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1243 paren p@(VarPat _) = p
1244 paren other_p = ParPat other_p
1248 mkHsApps f xs = foldl HsApp (HsVar f) xs
1249 mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
1251 mkHsIntLit n = HsLit (HsInt n)
1252 mkHsString s = HsString (mkFastString s)
1253 mkHsChar c = HsChar (ord c)
1255 mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars))
1256 mkNullaryConPat con = ConPatIn con (PrefixCon [])
1257 mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat))
1260 ToDo: Better SrcLocs.
1264 RdrNameHsExpr -- What to do for equality
1265 -> RdrNameHsExpr -> RdrNameHsExpr
1267 careful_compare_Case :: -- checks for primitive types...
1268 TyCon -- The tycon we are deriving for
1270 -> RdrNameHsExpr -- What to do for equality
1271 -> RdrNameHsExpr -> RdrNameHsExpr
1274 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1275 -- Was: compare_gen_Case cmp_eq_RDR
1277 compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR
1278 = HsApp (HsApp (HsVar compare_RDR) a) b -- Simple case
1279 compare_gen_Case eq a b -- General case
1280 = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-}
1281 [mkSimpleMatch [mkNullaryConPat ltTag_RDR] ltTag_Expr placeHolderType generatedSrcLoc,
1282 mkSimpleMatch [mkNullaryConPat eqTag_RDR] eq placeHolderType generatedSrcLoc,
1283 mkSimpleMatch [mkNullaryConPat gtTag_RDR] gtTag_Expr placeHolderType generatedSrcLoc]
1286 careful_compare_Case tycon ty eq a b
1287 | not (isUnLiftedType ty)
1288 = compare_gen_Case eq a b
1289 | otherwise -- We have to do something special for primitive things...
1290 = HsIf (genOpApp a relevant_eq_op b)
1292 (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc)
1295 relevant_eq_op = assoc_ty_id "Ord" tycon eq_op_tbl ty
1296 relevant_lt_op = assoc_ty_id "Ord" tycon lt_op_tbl ty
1299 box_if_necy :: String -- The class involved
1300 -> TyCon -- The tycon involved
1301 -> RdrNameHsExpr -- The argument
1302 -> Type -- The argument type
1303 -> RdrNameHsExpr -- Boxed version of the arg
1304 box_if_necy cls_str tycon arg arg_ty
1305 | isUnLiftedType arg_ty = HsApp (HsVar box_con) arg
1308 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1310 assoc_ty_id :: String -- The class involved
1311 -> TyCon -- The tycon involved
1312 -> [(Type,a)] -- The table
1314 -> a -- The result of the lookup
1315 assoc_ty_id cls_str tycon tbl ty
1316 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1317 text "for primitive type" <+> ppr ty)
1318 | otherwise = head res
1320 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1323 [(charPrimTy, eqChar_RDR)
1324 ,(intPrimTy, eqInt_RDR)
1325 ,(wordPrimTy, eqWord_RDR)
1326 ,(addrPrimTy, eqAddr_RDR)
1327 ,(floatPrimTy, eqFloat_RDR)
1328 ,(doublePrimTy, eqDouble_RDR)
1332 [(charPrimTy, ltChar_RDR)
1333 ,(intPrimTy, ltInt_RDR)
1334 ,(wordPrimTy, ltWord_RDR)
1335 ,(addrPrimTy, ltAddr_RDR)
1336 ,(floatPrimTy, ltFloat_RDR)
1337 ,(doublePrimTy, ltDouble_RDR)
1341 [(charPrimTy, getRdrName charDataCon)
1342 ,(intPrimTy, getRdrName intDataCon)
1343 ,(wordPrimTy, getRdrName wordDataCon)
1344 ,(addrPrimTy, getRdrName addrDataCon)
1345 ,(floatPrimTy, getRdrName floatDataCon)
1346 ,(doublePrimTy, getRdrName doubleDataCon)
1349 -----------------------------------------------------------------------
1351 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1353 and_Expr a b = genOpApp a and_RDR b
1354 append_Expr a b = genOpApp a append_RDR b
1356 -----------------------------------------------------------------------
1358 eq_Expr :: TyCon -> Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1359 eq_Expr tycon ty a b = genOpApp a eq_op b
1362 | not (isUnLiftedType ty) = eq_RDR
1364 -- we have to do something special for primitive things...
1365 assoc_ty_id "Eq" tycon eq_op_tbl ty
1370 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1371 untag_Expr tycon [] expr = expr
1372 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1373 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1374 [mkSimpleMatch [VarPat put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1377 cmp_tags_Expr :: RdrName -- Comparison op
1378 -> RdrName -> RdrName -- Things to compare
1379 -> RdrNameHsExpr -- What to return if true
1380 -> RdrNameHsExpr -- What to return if false
1383 cmp_tags_Expr op a b true_case false_case
1384 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1387 :: RdrNameHsExpr -> RdrNameHsExpr
1389 enum_from_then_to_Expr
1390 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1393 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1394 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1397 :: RdrNameHsExpr -> RdrNameHsExpr
1400 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1402 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1404 nested_compose_Expr [e] = parenify e
1405 nested_compose_Expr (e:es)
1406 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1408 -- impossible_Expr is used in case RHSs that should never happen.
1409 -- We generate these to keep the desugarer from complaining that they *might* happen!
1410 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv")))
1412 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1413 -- method. It is currently only used by Enum.{succ,pred}
1414 illegal_Expr meth tp msg =
1415 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg))))
1417 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1418 -- to include the value of a_RDR in the error string.
1419 illegal_toEnum_tag tp maxtag =
1420 HsApp (HsVar error_RDR)
1421 (HsApp (HsApp (HsVar append_RDR)
1422 (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag (")))))
1423 (HsApp (HsApp (HsApp
1424 (HsVar showsPrec_RDR)
1429 (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,"))))
1430 (HsApp (HsApp (HsApp
1431 (HsVar showsPrec_RDR)
1434 (HsLit (HsString (mkFastString ")")))))))
1436 parenify e@(HsVar _) = e
1437 parenify e = HsPar e
1439 -- genOpApp wraps brackets round the operator application, so that the
1440 -- renamer won't subsequently try to re-associate it.
1441 -- For some reason the renamer doesn't reassociate it right, and I can't
1442 -- be bothered to find out why just now.
1444 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1448 varUnqual n = mkUnqual OccName.varName n
1450 zz_a_RDR = varUnqual FSLIT("_a")
1451 a_RDR = varUnqual FSLIT("a")
1452 b_RDR = varUnqual FSLIT("b")
1453 c_RDR = varUnqual FSLIT("c")
1454 d_RDR = varUnqual FSLIT("d")
1455 e_RDR = varUnqual FSLIT("e")
1456 k_RDR = varUnqual FSLIT("k")
1457 z_RDR = varUnqual FSLIT("z") :: RdrName
1458 ah_RDR = varUnqual FSLIT("a#")
1459 bh_RDR = varUnqual FSLIT("b#")
1460 ch_RDR = varUnqual FSLIT("c#")
1461 dh_RDR = varUnqual FSLIT("d#")
1462 cmp_eq_RDR = varUnqual FSLIT("cmp_eq")
1463 rangeSize_RDR = varUnqual FSLIT("rangeSize")
1465 as_RDRs = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1466 bs_RDRs = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1467 cs_RDRs = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1469 zz_a_Expr = HsVar zz_a_RDR
1470 a_Expr = HsVar a_RDR
1471 b_Expr = HsVar b_RDR
1472 c_Expr = HsVar c_RDR
1473 d_Expr = HsVar d_RDR
1474 z_Expr = HsVar z_RDR
1475 ltTag_Expr = HsVar ltTag_RDR
1476 eqTag_Expr = HsVar eqTag_RDR
1477 gtTag_Expr = HsVar gtTag_RDR
1478 false_Expr = HsVar false_RDR
1479 true_Expr = HsVar true_RDR
1481 getTag_Expr = HsVar getTag_RDR
1482 tagToEnum_Expr = HsVar tagToEnum_RDR
1483 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1485 wildPat = WildPat placeHolderType
1486 zz_a_Pat = VarPat zz_a_RDR
1487 a_Pat = VarPat a_RDR
1488 b_Pat = VarPat b_RDR
1489 c_Pat = VarPat c_RDR
1490 d_Pat = VarPat d_RDR
1492 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1494 con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1495 tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1496 maxtag_RDR tycon = varUnqual (mkFastString ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))
1499 RdrNames for PrimOps. Can't be done in PrelNames, because PrimOp imports
1500 PrelNames, so PrelNames can't import PrimOp.
1503 minusInt_RDR = nameRdrName minusIntName
1504 eqInt_RDR = nameRdrName eqIntName
1505 ltInt_RDR = nameRdrName ltIntName
1506 geInt_RDR = nameRdrName geIntName
1507 leInt_RDR = nameRdrName leIntName
1508 eqChar_RDR = nameRdrName eqCharName
1509 eqWord_RDR = nameRdrName eqWordName
1510 eqAddr_RDR = nameRdrName eqAddrName
1511 eqFloat_RDR = nameRdrName eqFloatName
1512 eqDouble_RDR = nameRdrName eqDoubleName
1513 ltChar_RDR = nameRdrName ltCharName
1514 ltWord_RDR = nameRdrName ltWordName
1515 ltAddr_RDR = nameRdrName ltAddrName
1516 ltFloat_RDR = nameRdrName ltFloatName
1517 ltDouble_RDR = nameRdrName ltDoubleName
1518 tagToEnum_RDR = nameRdrName tagToEnumName