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"
32 import RdrName ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual,
34 import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) )
35 import FieldLabel ( fieldLabelName )
36 import DataCon ( isNullaryDataCon, dataConTag,
37 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
38 DataCon, dataConName, dataConIsInfix,
40 import Name ( getOccString, getSrcLoc, Name, NamedThing(..) )
42 import HscTypes ( FixityEnv, lookupFixity )
45 import MkId ( eRROR_ID )
46 import PrimOp ( PrimOp(..) )
47 import SrcLoc ( Located(..), noLoc, srcLocSpan )
48 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity,
49 maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName
51 import TcType ( isUnLiftedType, tcEqType, Type )
52 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
54 import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon,
55 intDataCon_RDR, true_RDR, false_RDR )
56 import Util ( zipWithEqual, isSingleton,
57 zipWith3Equal, nOfThem, zipEqual )
58 import Char ( isAlpha )
60 import List ( partition, intersperse )
67 %************************************************************************
69 \subsection{Generating code, by derivable class}
71 %************************************************************************
73 %************************************************************************
75 \subsubsection{Generating @Eq@ instance declarations}
77 %************************************************************************
79 Here are the heuristics for the code we generate for @Eq@:
82 Let's assume we have a data type with some (possibly zero) nullary
83 data constructors and some ordinary, non-nullary ones (the rest,
84 also possibly zero of them). Here's an example, with both \tr{N}ullary
85 and \tr{O}rdinary data cons.
87 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
91 For the ordinary constructors (if any), we emit clauses to do The
95 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
96 (==) (O2 a1) (O2 a2) = a1 == a2
97 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
100 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
101 \tr{a2} are \tr{Float#}s, then we have to generate
103 case (a1 `eqFloat#` a2) of
106 for that particular test.
109 If there are any nullary constructors, we emit a catch-all clause of
113 (==) a b = case (con2tag_Foo a) of { a# ->
114 case (con2tag_Foo b) of { b# ->
115 case (a# ==# b#) of {
120 If there aren't any nullary constructors, we emit a simpler
127 For the @(/=)@ method, we normally just use the default method.
129 If the type is an enumeration type, we could/may/should? generate
130 special code that calls @con2tag_Foo@, much like for @(==)@ shown
134 We thought about doing this: If we're also deriving @Ord@ for this
137 instance ... Eq (Foo ...) where
138 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
139 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
141 However, that requires that \tr{Ord <whatever>} was put in the context
142 for the instance decl, which it probably wasn't, so the decls
143 produced don't get through the typechecker.
148 gen_Eq_binds :: TyCon -> LHsBinds RdrName
152 tycon_loc = getSrcSpan tycon
154 (nullary_cons, nonnullary_cons)
155 | isNewTyCon tycon = ([], tyConDataCons tycon)
156 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
159 = if (null nullary_cons) then
160 case maybeTyConSingleCon tycon of
162 Nothing -> -- if cons don't match, then False
163 [([nlWildPat, nlWildPat], false_Expr)]
164 else -- calc. and compare the tags
166 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
167 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
170 mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
171 mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyBag (
172 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
175 ------------------------------------------------------------------
178 con1_pat = nlConVarPat data_con_RDR as_needed
179 con2_pat = nlConVarPat data_con_RDR bs_needed
181 data_con_RDR = getRdrName data_con
182 con_arity = length tys_needed
183 as_needed = take con_arity as_RDRs
184 bs_needed = take con_arity bs_RDRs
185 tys_needed = dataConOrigArgTys data_con
187 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
189 nested_eq_expr [] [] [] = true_Expr
190 nested_eq_expr tys as bs
191 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
193 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
196 %************************************************************************
198 \subsubsection{Generating @Ord@ instance declarations}
200 %************************************************************************
202 For a derived @Ord@, we concentrate our attentions on @compare@
204 compare :: a -> a -> Ordering
205 data Ordering = LT | EQ | GT deriving ()
208 We will use the same example data type as above:
210 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
215 We do all the other @Ord@ methods with calls to @compare@:
217 instance ... (Ord <wurble> <wurble>) where
218 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
219 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
220 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
221 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
223 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
224 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
226 -- compare to come...
230 @compare@ always has two parts. First, we use the compared
231 data-constructors' tags to deal with the case of different
234 compare a b = case (con2tag_Foo a) of { a# ->
235 case (con2tag_Foo b) of { b# ->
236 case (a# ==# b#) of {
238 False -> case (a# <# b#) of
243 cmp_eq = ... to come ...
247 We are only left with the ``help'' function @cmp_eq@, to deal with
248 comparing data constructors with the same tag.
250 For the ordinary constructors (if any), we emit the sorta-obvious
251 compare-style stuff; for our example:
253 cmp_eq (O1 a1 b1) (O1 a2 b2)
254 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
256 cmp_eq (O2 a1) (O2 a2)
259 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
260 = case (compare a1 a2) of {
263 EQ -> case compare b1 b2 of {
271 Again, we must be careful about unlifted comparisons. For example,
272 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
276 cmp_eq lt eq gt (O2 a1) (O2 a2)
278 -- or maybe the unfolded equivalent
282 For the remaining nullary constructors, we already know that the
289 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
293 gen_Ord_binds :: TyCon -> LHsBinds RdrName
296 = unitBag compare -- `AndMonoBinds` compare
297 -- The default declaration in PrelBase handles this
299 tycon_loc = getSrcSpan tycon
300 --------------------------------------------------------------------
302 compare = mk_easy_FunBind tycon_loc compare_RDR
303 [a_Pat, b_Pat] (unitBag cmp_eq) compare_rhs
305 | single_con_type = cmp_eq_Expr a_Expr b_Expr
307 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
308 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
309 (cmp_eq_Expr a_Expr b_Expr) -- True case
310 -- False case; they aren't equal
311 -- So we need to do a less-than comparison on the tags
312 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
314 tycon_data_cons = tyConDataCons tycon
315 single_con_type = isSingleton tycon_data_cons
316 (nullary_cons, nonnullary_cons)
317 | isNewTyCon tycon = ([], tyConDataCons tycon)
318 | otherwise = partition isNullaryDataCon tycon_data_cons
320 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
322 | isEnumerationTyCon tycon
323 -- We know the tags are equal, so if it's an enumeration TyCon,
324 -- then there is nothing left to do
325 -- Catch this specially to avoid warnings
326 -- about overlapping patterns from the desugarer,
327 -- and to avoid unnecessary pattern-matching
328 = [([nlWildPat,nlWildPat], eqTag_Expr)]
330 = map pats_etc nonnullary_cons ++
331 (if single_con_type then -- Omit wildcards when there's just one
332 [] -- constructor, to silence desugarer
334 [([nlWildPat, nlWildPat], default_rhs)])
338 = ([con1_pat, con2_pat],
339 nested_compare_expr tys_needed as_needed bs_needed)
341 con1_pat = nlConVarPat data_con_RDR as_needed
342 con2_pat = nlConVarPat data_con_RDR bs_needed
344 data_con_RDR = getRdrName data_con
345 con_arity = length tys_needed
346 as_needed = take con_arity as_RDRs
347 bs_needed = take con_arity bs_RDRs
348 tys_needed = dataConOrigArgTys data_con
350 nested_compare_expr [ty] [a] [b]
351 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
353 nested_compare_expr (ty:tys) (a:as) (b:bs)
354 = let eq_expr = nested_compare_expr tys as bs
355 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
357 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
358 -- inexhaustive patterns
359 | otherwise = eqTag_Expr -- Some nullary constructors;
360 -- Tags are equal, no args => return EQ
363 %************************************************************************
365 \subsubsection{Generating @Enum@ instance declarations}
367 %************************************************************************
369 @Enum@ can only be derived for enumeration types. For a type
371 data Foo ... = N1 | N2 | ... | Nn
374 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
375 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
378 instance ... Enum (Foo ...) where
379 succ x = toEnum (1 + fromEnum x)
380 pred x = toEnum (fromEnum x - 1)
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 -> LHsBinds RdrName
417 tycon_loc = getSrcSpan tycon
418 occ_nm = getOccString tycon
421 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyBag $
422 untag_Expr tycon [(a_RDR, ah_RDR)] $
423 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
424 nlHsVarApps intDataCon_RDR [ah_RDR]])
425 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
426 (nlHsApp (nlHsVar (tag2con_RDR tycon))
427 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
431 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyBag $
432 untag_Expr tycon [(a_RDR, ah_RDR)] $
433 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
434 nlHsVarApps intDataCon_RDR [ah_RDR]])
435 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
436 (nlHsApp (nlHsVar (tag2con_RDR tycon))
437 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
438 nlHsLit (HsInt (-1))]))
441 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyBag $
442 nlHsIf (nlHsApps and_RDR
443 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
444 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
445 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
446 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
449 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyBag $
450 untag_Expr tycon [(a_RDR, ah_RDR)] $
452 [nlHsVar (tag2con_RDR tycon),
453 nlHsPar (enum_from_to_Expr
454 (nlHsVarApps intDataCon_RDR [ah_RDR])
455 (nlHsVar (maxtag_RDR tycon)))]
458 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyBag $
459 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
460 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
461 nlHsPar (enum_from_then_to_Expr
462 (nlHsVarApps intDataCon_RDR [ah_RDR])
463 (nlHsVarApps intDataCon_RDR [bh_RDR])
464 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
465 nlHsVarApps intDataCon_RDR [bh_RDR]])
467 (nlHsVar (maxtag_RDR tycon))
471 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyBag $
472 untag_Expr tycon [(a_RDR, ah_RDR)] $
473 (nlHsVarApps intDataCon_RDR [ah_RDR])
476 %************************************************************************
478 \subsubsection{Generating @Bounded@ instance declarations}
480 %************************************************************************
483 gen_Bounded_binds tycon
484 = if isEnumerationTyCon tycon then
485 listToBag [ min_bound_enum, max_bound_enum ]
487 ASSERT(isSingleton data_cons)
488 listToBag [ min_bound_1con, max_bound_1con ]
490 data_cons = tyConDataCons tycon
491 tycon_loc = getSrcSpan tycon
493 ----- enum-flavored: ---------------------------
494 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
495 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
497 data_con_1 = head data_cons
498 data_con_N = last data_cons
499 data_con_1_RDR = getRdrName data_con_1
500 data_con_N_RDR = getRdrName data_con_N
502 ----- single-constructor-flavored: -------------
503 arity = dataConSourceArity data_con_1
505 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
506 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
507 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
508 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
511 %************************************************************************
513 \subsubsection{Generating @Ix@ instance declarations}
515 %************************************************************************
517 Deriving @Ix@ is only possible for enumeration types and
518 single-constructor types. We deal with them in turn.
520 For an enumeration type, e.g.,
522 data Foo ... = N1 | N2 | ... | Nn
524 things go not too differently from @Enum@:
526 instance ... Ix (Foo ...) where
528 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
532 = case (con2tag_Foo a) of { a# ->
533 case (con2tag_Foo b) of { b# ->
534 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
539 then case (con2tag_Foo d -# con2tag_Foo a) of
541 else error "Ix.Foo.index: out of range"
545 p_tag = con2tag_Foo c
547 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
551 = case (con2tag_Foo a) of { a_tag ->
552 case (con2tag_Foo b) of { b_tag ->
553 case (con2tag_Foo c) of { c_tag ->
554 if (c_tag >=# a_tag) then
560 (modulo suitable case-ification to handle the unlifted tags)
562 For a single-constructor type (NB: this includes all tuples), e.g.,
564 data Foo ... = MkFoo a b Int Double c c
566 we follow the scheme given in Figure~19 of the Haskell~1.2 report
570 gen_Ix_binds :: TyCon -> LHsBinds RdrName
573 = if isEnumerationTyCon tycon
577 tycon_str = getOccString tycon
578 tycon_loc = getSrcSpan tycon
580 --------------------------------------------------------------
581 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
584 = mk_easy_FunBind tycon_loc range_RDR
585 [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $
586 untag_Expr tycon [(a_RDR, ah_RDR)] $
587 untag_Expr tycon [(b_RDR, bh_RDR)] $
588 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
589 nlHsPar (enum_from_to_Expr
590 (nlHsVarApps intDataCon_RDR [ah_RDR])
591 (nlHsVarApps intDataCon_RDR [bh_RDR]))
594 = mk_easy_FunBind tycon_loc index_RDR
595 [noLoc (AsPat (noLoc c_RDR)
596 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
598 nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
599 untag_Expr tycon [(a_RDR, ah_RDR)] (
600 untag_Expr tycon [(d_RDR, dh_RDR)] (
602 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
605 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
606 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
609 nlHsApp (nlHsVar error_RDR) (nlHsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
613 = mk_easy_FunBind tycon_loc inRange_RDR
614 [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag (
615 untag_Expr tycon [(a_RDR, ah_RDR)] (
616 untag_Expr tycon [(b_RDR, bh_RDR)] (
617 untag_Expr tycon [(c_RDR, ch_RDR)] (
618 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
619 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
624 --------------------------------------------------------------
626 = listToBag [single_con_range, single_con_index, single_con_inRange]
629 = case maybeTyConSingleCon tycon of -- just checking...
630 Nothing -> panic "get_Ix_binds"
631 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
632 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
635 con_arity = dataConSourceArity data_con
636 data_con_RDR = getRdrName data_con
638 as_needed = take con_arity as_RDRs
639 bs_needed = take con_arity bs_RDRs
640 cs_needed = take con_arity cs_RDRs
642 con_pat xs = nlConVarPat data_con_RDR xs
643 con_expr = nlHsVarApps data_con_RDR cs_needed
645 --------------------------------------------------------------
647 = mk_easy_FunBind tycon_loc range_RDR
648 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyBag $
649 nlHsDo ListComp stmts
651 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
653 [nlResultStmt con_expr]
655 mk_qual a b c = nlBindStmt (nlVarPat c)
656 (nlHsApp (nlHsVar range_RDR)
657 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
661 = mk_easy_FunBind tycon_loc index_RDR
662 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
663 con_pat cs_needed] (unitBag range_size) (
664 foldl mk_index (nlHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
666 mk_index multiply_by (l, u, i)
668 (nlHsApps index_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed,
672 (nlHsApp (nlHsVar rangeSize_RDR)
673 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
674 ) times_RDR multiply_by
678 = mk_easy_FunBind tycon_loc rangeSize_RDR
679 [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag (
681 (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed,
683 ) plus_RDR (nlHsIntLit 1))
687 = mk_easy_FunBind tycon_loc inRange_RDR
688 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
691 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
693 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
697 %************************************************************************
699 \subsubsection{Generating @Read@ instance declarations}
701 %************************************************************************
711 instance Read T where
715 do x <- ReadP.step Read.readPrec
716 Symbol "%%" <- Lex.lex
717 y <- ReadP.step Read.readPrec
721 do Ident "T1" <- Lex.lex
723 Ident "f1" <- Lex.lex
725 x <- ReadP.reset Read.readPrec
727 return (T1 { f1 = x }))
730 do Ident "T2" <- Lex.lexP
731 x <- ReadP.step Read.readPrec
735 readListPrec = readListPrecDefault
736 readList = readListDefault
740 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
742 gen_Read_binds get_fixity tycon
743 = listToBag [read_prec, default_readlist, default_readlistprec]
745 -----------------------------------------------------------------------
747 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
750 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
751 -----------------------------------------------------------------------
753 loc = getSrcSpan tycon
754 data_cons = tyConDataCons tycon
755 (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
757 read_prec = mkVarBind loc readPrec_RDR
758 (nlHsApp (nlHsVar parens_RDR) read_cons)
760 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
761 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
764 = case nullary_cons of
766 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
768 _ -> [nlHsApp (nlHsVar choose_RDR)
769 (nlList (map mk_pair nullary_cons))]
771 mk_pair con = nlTuple [nlHsLit (data_con_str con),
772 nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
775 read_non_nullary_con data_con
776 = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts]
778 stmts | is_infix = infix_stmts
779 | length labels > 0 = lbl_stmts
780 | otherwise = prefix_stmts
782 prefix_stmts -- T a b c
783 = [bindLex (ident_pat (data_con_str_w_parens data_con))]
785 ++ [result_stmt data_con as_needed]
787 infix_stmts -- a %% b
789 bindLex (symbol_pat (data_con_str data_con)),
791 result_stmt data_con [a1,a2]]
793 lbl_stmts -- T { f1 = a, f2 = b }
794 = [bindLex (ident_pat (data_con_str_w_parens data_con)),
796 ++ concat (intersperse [read_punc ","] field_stmts)
797 ++ [read_punc "}", result_stmt data_con as_needed]
799 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
801 con_arity = dataConSourceArity data_con
802 labels = dataConFieldLabels data_con
803 dc_nm = getName data_con
804 is_infix = dataConIsInfix data_con
805 as_needed = take con_arity as_RDRs
806 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
807 (read_a1:read_a2:_) = read_args
808 (a1:a2:_) = as_needed
809 prec = getPrec is_infix get_fixity dc_nm
811 ------------------------------------------------------------------------
813 ------------------------------------------------------------------------
814 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
815 bindLex pat = nlBindStmt pat (nlHsVar lexP_RDR)
816 result_stmt c as = nlResultStmt (nlHsApp (nlHsVar returnM_RDR) (con_app c as))
817 con_app c as = nlHsVarApps (getRdrName c) as
819 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
820 ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo"
821 symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>"
823 data_con_str con = mkHsString (occNameUserString (getOccName con))
824 data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
826 read_punc c = bindLex (punc_pat c)
828 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
829 | otherwise = nlBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])
831 read_field lbl a = read_lbl lbl ++
833 nlBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR])]
835 -- When reading field labels we might encounter
840 read_lbl lbl | is_id_start (head lbl_str)
841 = [bindLex (ident_pat lbl_lit)]
844 bindLex (symbol_pat lbl_lit),
847 lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
848 lbl_lit = mkHsString lbl_str
849 is_id_start c = isAlpha c || c == '_'
853 %************************************************************************
855 \subsubsection{Generating @Show@ instance declarations}
857 %************************************************************************
863 data Tree a = Leaf a | Tree a :^: Tree a
865 instance (Show a) => Show (Tree a) where
867 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
869 showStr = showString "Leaf " . showsPrec (app_prec+1) m
871 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
873 showStr = showsPrec (up_prec+1) u .
875 showsPrec (up_prec+1) v
876 -- Note: right-associativity of :^: ignored
878 up_prec = 5 -- Precedence of :^:
879 app_prec = 10 -- Application has precedence one more than
880 -- the most tightly-binding operator
883 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
885 gen_Show_binds get_fixity tycon
886 = listToBag [shows_prec, show_list]
888 tycon_loc = getSrcSpan tycon
889 -----------------------------------------------------------------------
890 show_list = mkVarBind tycon_loc showList_RDR
891 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
892 -----------------------------------------------------------------------
893 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
896 | nullary_con = -- skip the showParen junk...
897 ASSERT(null bs_needed)
898 ([nlWildPat, con_pat], mk_showString_app con_str)
901 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
902 (nlHsPar (nested_compose_Expr show_thingies)))
904 data_con_RDR = getRdrName data_con
905 con_arity = dataConSourceArity data_con
906 bs_needed = take con_arity bs_RDRs
907 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
908 con_pat = nlConVarPat data_con_RDR bs_needed
909 nullary_con = con_arity == 0
910 labels = dataConFieldLabels data_con
911 lab_fields = length labels
912 record_syntax = lab_fields > 0
914 dc_nm = getName data_con
915 dc_occ_nm = getOccName data_con
916 con_str = occNameUserString dc_occ_nm
917 op_con_str = occNameUserString_with_parens dc_occ_nm
920 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
921 | record_syntax = mk_showString_app (op_con_str ++ " {") :
922 show_record_args ++ [mk_showString_app "}"]
923 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
925 show_label l = mk_showString_app (nm ++ " = ")
926 -- Note the spaces around the "=" sign. If we don't have them
927 -- then we get Foo { x=-1 } and the "=-" parses as a single
928 -- lexeme. Only the space after the '=' is necessary, but
929 -- it seems tidier to have them both sides.
931 occ_nm = getOccName (fieldLabelName l)
932 nm = occNameUserString_with_parens occ_nm
934 show_args = zipWith show_arg bs_needed arg_tys
935 (show_arg1:show_arg2:_) = show_args
936 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
938 -- Assumption for record syntax: no of fields == no of labelled fields
939 -- (and in same order)
940 show_record_args = concat $
941 intersperse [mk_showString_app ", "] $
942 [ [show_label lbl, arg]
943 | (lbl,arg) <- zipEqual "gen_Show_binds"
946 -- Generates (showsPrec p x) for argument x, but it also boxes
947 -- the argument first if necessary. Note that this prints unboxed
948 -- things without any '#' decorations; could change that if need be
949 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
950 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
953 is_infix = dataConIsInfix data_con
954 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
955 arg_prec | record_syntax = 0 -- Record fields don't need parens
956 | otherwise = con_prec_plus_one
958 occNameUserString_with_parens :: OccName -> String
959 occNameUserString_with_parens occ
960 | isSymOcc occ = '(':nm ++ ")"
963 nm = occNameUserString occ
965 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
969 getPrec :: Bool -> FixityEnv -> Name -> Integer
970 getPrec is_infix get_fixity nm
971 | not is_infix = appPrecedence
972 | otherwise = getPrecedence get_fixity nm
974 appPrecedence :: Integer
975 appPrecedence = fromIntegral maxPrecedence + 1
976 -- One more than the precedence of the most
977 -- tightly-binding operator
979 getPrecedence :: FixityEnv -> Name -> Integer
980 getPrecedence get_fixity nm
981 = case lookupFixity get_fixity nm of
982 Fixity x _ -> fromIntegral x
986 %************************************************************************
988 \subsection{Typeable}
990 %************************************************************************
998 instance Typeable2 T where
999 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1001 We are passed the Typeable2 class as well as T
1004 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1005 gen_Typeable_binds tycon
1007 mk_easy_FunBind tycon_loc
1008 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1009 [nlWildPat] emptyBag
1010 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1012 tycon_loc = getSrcSpan tycon
1013 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1015 mk_typeOf_RDR :: TyCon -> RdrName
1016 -- Use the arity of the TyCon to make the right typeOfn function
1017 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_Name (mkFastString ("typeOf" ++ suffix))
1019 arity = tyConArity tycon
1020 suffix | arity == 0 = ""
1021 | otherwise = show arity
1026 %************************************************************************
1030 %************************************************************************
1034 data T a b = T1 a b | T2
1038 $cT1 = mkDataCon $dT "T1" Prefix
1039 $cT2 = mkDataCon $dT "T2" Prefix
1040 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1041 -- the [] is for field labels.
1043 instance (Data a, Data b) => Data (T a b) where
1044 gfoldl k z (T1 a b) = z T `k` a `k` b
1045 gfoldl k z T2 = z T2
1046 -- ToDo: add gmapT,Q,M, gfoldr
1048 gunfold k z c = case conIndex c of
1049 I# 1# -> k (k (z T1))
1052 toConstr (T1 _ _) = $cT1
1058 gen_Data_binds :: FixityEnv
1060 -> (LHsBinds RdrName, -- The method bindings
1061 LHsBinds RdrName) -- Auxiliary bindings
1062 gen_Data_binds fix_env tycon
1063 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1064 -- Auxiliary definitions: the data type and constructors
1065 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1067 tycon_loc = getSrcSpan tycon
1068 tycon_name = tyConName tycon
1069 data_cons = tyConDataCons tycon
1070 n_cons = length data_cons
1071 one_constr = n_cons == 1
1074 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1075 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1076 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1079 con_name = getRdrName con
1080 as_needed = take (dataConSourceArity con) as_RDRs
1081 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1083 ------------ gunfold
1084 gunfold_bind = mk_FunBind tycon_loc
1086 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1090 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1091 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1092 (map gunfold_alt data_cons)
1094 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1095 mk_unfold_rhs dc = foldr nlHsApp
1096 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1097 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1099 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1100 -- redundant test, and annoying warning
1101 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1102 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1106 ------------ toConstr
1107 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1108 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1110 ------------ dataTypeOf
1111 dataTypeOf_bind = mk_easy_FunBind
1116 (nlHsVar data_type_name)
1120 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1121 datatype_bind = mkVarBind
1124 ( nlHsVar mkDataType_RDR
1125 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1126 `nlHsApp` nlList constrs
1128 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1131 ------------ $cT1 etc
1132 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1133 mk_con_bind dc = mkVarBind
1136 (nlHsApps mkConstr_RDR (constr_args dc))
1138 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1139 nlHsVar data_type_name, -- DataType
1140 nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name
1141 nlList labels, -- Field labels
1142 nlHsVar fixity] -- Fixity
1144 labels = map (nlHsLit . mkHsString . getOccString . fieldLabelName)
1145 (dataConFieldLabels dc)
1146 dc_occ = getOccName dc
1147 is_infix = isDataSymOcc dc_occ
1148 fixity | is_infix = infix_RDR
1149 | otherwise = prefix_RDR
1151 gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl")
1152 gunfold_RDR = varQual_RDR gENERICS_Name FSLIT("gunfold")
1153 toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr")
1154 dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
1155 mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr")
1156 mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
1157 conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("constrIndex")
1158 prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix")
1159 infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix")
1162 %************************************************************************
1164 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1166 %************************************************************************
1171 con2tag_Foo :: Foo ... -> Int#
1172 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1173 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1176 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1181 = GenCon2Tag | GenTag2Con | GenMaxTag
1183 gen_tag_n_con_monobind
1184 :: ( RdrName, -- (proto)Name for the thing in question
1185 TyCon, -- tycon in question
1189 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1190 | lots_of_constructors
1191 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1194 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1197 tycon_loc = getSrcSpan tycon
1199 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1200 -- We can't use gerRdrName because that makes an Exact RdrName
1201 -- and we can't put them in the LocalRdrEnv
1203 -- Give a signature to the bound variable, so
1204 -- that the case expression generated by getTag is
1205 -- monomorphic. In the push-enter model we get better code.
1206 get_tag_rhs = noLoc $ ExprWithTySig
1207 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1208 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1209 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1211 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1214 nlHsTyVar (getRdrName intPrimTyCon)
1216 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1218 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1219 mk_stuff con = ([nlWildConPat con],
1220 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1222 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1223 = mk_FunBind (getSrcSpan tycon) rdr_name
1224 [([nlConVarPat intDataCon_RDR [a_RDR]],
1225 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1226 (nlHsTyVar (getRdrName tycon))))]
1228 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1229 = mkVarBind (getSrcSpan tycon) rdr_name
1230 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1232 max_tag = case (tyConDataCons tycon) of
1233 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1237 %************************************************************************
1239 \subsection{Utility bits for generating bindings}
1241 %************************************************************************
1244 ToDo: Better SrcLocs.
1248 LHsExpr RdrName -- What to do for equality
1249 -> LHsExpr RdrName -> LHsExpr RdrName
1251 careful_compare_Case :: -- checks for primitive types...
1252 TyCon -- The tycon we are deriving for
1254 -> LHsExpr RdrName -- What to do for equality
1255 -> LHsExpr RdrName -> LHsExpr RdrName
1258 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1259 -- Was: compare_gen_Case cmp_eq_RDR
1261 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1262 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1263 compare_gen_Case eq a b -- General case
1264 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1265 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1266 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1267 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1269 careful_compare_Case tycon ty eq a b
1270 | not (isUnLiftedType ty)
1271 = compare_gen_Case eq a b
1272 | otherwise -- We have to do something special for primitive things...
1273 = nlHsIf (genOpApp a relevant_eq_op b)
1275 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1277 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1278 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1281 box_if_necy :: String -- The class involved
1282 -> TyCon -- The tycon involved
1283 -> LHsExpr RdrName -- The argument
1284 -> Type -- The argument type
1285 -> LHsExpr RdrName -- Boxed version of the arg
1286 box_if_necy cls_str tycon arg arg_ty
1287 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1290 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1292 assoc_ty_id :: String -- The class involved
1293 -> TyCon -- The tycon involved
1294 -> [(Type,a)] -- The table
1296 -> a -- The result of the lookup
1297 assoc_ty_id cls_str tycon tbl ty
1298 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1299 text "for primitive type" <+> ppr ty)
1300 | otherwise = head res
1302 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1304 eq_op_tbl :: [(Type, PrimOp)]
1306 [(charPrimTy, CharEqOp)
1307 ,(intPrimTy, IntEqOp)
1308 ,(wordPrimTy, WordEqOp)
1309 ,(addrPrimTy, AddrEqOp)
1310 ,(floatPrimTy, FloatEqOp)
1311 ,(doublePrimTy, DoubleEqOp)
1314 lt_op_tbl :: [(Type, PrimOp)]
1316 [(charPrimTy, CharLtOp)
1317 ,(intPrimTy, IntLtOp)
1318 ,(wordPrimTy, WordLtOp)
1319 ,(addrPrimTy, AddrLtOp)
1320 ,(floatPrimTy, FloatLtOp)
1321 ,(doublePrimTy, DoubleLtOp)
1325 [(charPrimTy, getRdrName charDataCon)
1326 ,(intPrimTy, getRdrName intDataCon)
1327 ,(wordPrimTy, wordDataCon_RDR)
1328 ,(addrPrimTy, addrDataCon_RDR)
1329 ,(floatPrimTy, getRdrName floatDataCon)
1330 ,(doublePrimTy, getRdrName doubleDataCon)
1333 -----------------------------------------------------------------------
1335 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1336 and_Expr a b = genOpApp a and_RDR b
1338 -----------------------------------------------------------------------
1340 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1341 eq_Expr tycon ty a b = genOpApp a eq_op b
1344 | not (isUnLiftedType ty) = eq_RDR
1346 -- we have to do something special for primitive things...
1347 primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1351 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1352 untag_Expr tycon [] expr = expr
1353 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1354 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1355 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1357 cmp_tags_Expr :: RdrName -- Comparison op
1358 -> RdrName -> RdrName -- Things to compare
1359 -> LHsExpr RdrName -- What to return if true
1360 -> LHsExpr RdrName -- What to return if false
1363 cmp_tags_Expr op a b true_case false_case
1364 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1367 :: LHsExpr RdrName -> LHsExpr RdrName
1369 enum_from_then_to_Expr
1370 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1373 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1374 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1377 :: LHsExpr RdrName -> LHsExpr RdrName
1380 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1382 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1384 nested_compose_Expr [e] = parenify e
1385 nested_compose_Expr (e:es)
1386 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1388 -- impossible_Expr is used in case RHSs that should never happen.
1389 -- We generate these to keep the desugarer from complaining that they *might* happen!
1390 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1392 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1393 -- method. It is currently only used by Enum.{succ,pred}
1394 illegal_Expr meth tp msg =
1395 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1397 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1398 -- to include the value of a_RDR in the error string.
1399 illegal_toEnum_tag tp maxtag =
1400 nlHsApp (nlHsVar error_RDR)
1401 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1402 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1403 (nlHsApp (nlHsApp (nlHsApp
1404 (nlHsVar showsPrec_RDR)
1408 (nlHsVar append_RDR)
1409 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1410 (nlHsApp (nlHsApp (nlHsApp
1411 (nlHsVar showsPrec_RDR)
1414 (nlHsLit (mkHsString ")"))))))
1416 parenify e@(L _ (HsVar _)) = e
1417 parenify e = mkHsPar e
1419 -- genOpApp wraps brackets round the operator application, so that the
1420 -- renamer won't subsequently try to re-associate it.
1421 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1425 getSrcSpan = srcLocSpan . getSrcLoc
1429 a_RDR = mkVarUnqual FSLIT("a")
1430 b_RDR = mkVarUnqual FSLIT("b")
1431 c_RDR = mkVarUnqual FSLIT("c")
1432 d_RDR = mkVarUnqual FSLIT("d")
1433 k_RDR = mkVarUnqual FSLIT("k")
1434 z_RDR = mkVarUnqual FSLIT("z")
1435 ah_RDR = mkVarUnqual FSLIT("a#")
1436 bh_RDR = mkVarUnqual FSLIT("b#")
1437 ch_RDR = mkVarUnqual FSLIT("c#")
1438 dh_RDR = mkVarUnqual FSLIT("d#")
1439 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1440 rangeSize_RDR = mkVarUnqual FSLIT("rangeSize")
1442 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1443 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1444 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1446 a_Expr = nlHsVar a_RDR
1447 b_Expr = nlHsVar b_RDR
1448 c_Expr = nlHsVar c_RDR
1449 ltTag_Expr = nlHsVar ltTag_RDR
1450 eqTag_Expr = nlHsVar eqTag_RDR
1451 gtTag_Expr = nlHsVar gtTag_RDR
1452 false_Expr = nlHsVar false_RDR
1453 true_Expr = nlHsVar true_RDR
1455 a_Pat = nlVarPat a_RDR
1456 b_Pat = nlVarPat b_RDR
1457 c_Pat = nlVarPat c_RDR
1458 d_Pat = nlVarPat d_RDR
1459 k_Pat = nlVarPat k_RDR
1460 z_Pat = nlVarPat z_RDR
1462 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1463 -- Generates Orig s RdrName, for the binding positions
1464 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1465 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1466 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1468 mk_tc_deriv_name tycon str
1469 = mkDerivedRdrName tc_name mk_occ
1471 tc_name = tyConName tycon
1472 mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1474 new_str = str ++ occNameString tc_occ ++ "#"
1477 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1478 PrelNames, so PrelNames can't import PrimOp.
1481 primOpRdrName op = getRdrName (primOpId op)
1483 minusInt_RDR = primOpRdrName IntSubOp
1484 eqInt_RDR = primOpRdrName IntEqOp
1485 ltInt_RDR = primOpRdrName IntLtOp
1486 geInt_RDR = primOpRdrName IntGeOp
1487 leInt_RDR = primOpRdrName IntLeOp
1488 tagToEnum_RDR = primOpRdrName TagToEnumOp
1490 error_RDR = getRdrName eRROR_ID