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,
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 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 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 = isDataSymOcc (getOccName dc_nm)
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))
825 read_punc c = bindLex (punc_pat c)
827 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
828 | otherwise = nlBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])
830 read_field lbl a = read_lbl lbl ++
832 nlBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR])]
834 -- When reading field labels we might encounter
839 read_lbl lbl | is_id_start (head lbl_str)
840 = [bindLex (ident_pat lbl_lit)]
843 bindLex (symbol_pat lbl_lit),
846 lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
847 lbl_lit = mkHsString lbl_str
848 is_id_start c = isAlpha c || c == '_'
852 %************************************************************************
854 \subsubsection{Generating @Show@ instance declarations}
856 %************************************************************************
862 data Tree a = Leaf a | Tree a :^: Tree a
864 instance (Show a) => Show (Tree a) where
866 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
868 showStr = showString "Leaf " . showsPrec (app_prec+1) m
870 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
872 showStr = showsPrec (up_prec+1) u .
874 showsPrec (up_prec+1) v
875 -- Note: right-associativity of :^: ignored
877 up_prec = 5 -- Precedence of :^:
878 app_prec = 10 -- Application has precedence one more than
879 -- the most tightly-binding operator
882 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
884 gen_Show_binds get_fixity tycon
885 = listToBag [shows_prec, show_list]
887 tycon_loc = getSrcSpan tycon
888 -----------------------------------------------------------------------
889 show_list = mkVarBind tycon_loc showList_RDR
890 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
891 -----------------------------------------------------------------------
892 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
895 | nullary_con = -- skip the showParen junk...
896 ASSERT(null bs_needed)
897 ([nlWildPat, con_pat], mk_showString_app con_str)
900 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
901 (nlHsPar (nested_compose_Expr show_thingies)))
903 data_con_RDR = getRdrName data_con
904 con_arity = dataConSourceArity data_con
905 bs_needed = take con_arity bs_RDRs
906 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
907 con_pat = nlConVarPat data_con_RDR bs_needed
908 nullary_con = con_arity == 0
909 labels = dataConFieldLabels data_con
910 lab_fields = length labels
911 record_syntax = lab_fields > 0
913 dc_nm = getName data_con
914 dc_occ_nm = getOccName data_con
915 con_str = occNameUserString dc_occ_nm
918 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
919 | record_syntax = mk_showString_app (con_str ++ " {") :
920 show_record_args ++ [mk_showString_app "}"]
921 | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
923 show_label l = mk_showString_app (the_name ++ " = ")
924 -- Note the spaces around the "=" sign. If we don't have them
925 -- then we get Foo { x=-1 } and the "=-" parses as a single
926 -- lexeme. Only the space after the '=' is necessary, but
927 -- it seems tidier to have them both sides.
929 occ_nm = getOccName (fieldLabelName l)
930 nm = occNameUserString occ_nm
931 is_op = isSymOcc occ_nm -- Legal, but rare.
932 the_name | is_op = '(':nm ++ ")"
935 show_args = zipWith show_arg bs_needed arg_tys
936 (show_arg1:show_arg2:_) = show_args
937 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
939 -- Assumption for record syntax: no of fields == no of labelled fields
940 -- (and in same order)
941 show_record_args = concat $
942 intersperse [mk_showString_app ", "] $
943 [ [show_label lbl, arg]
944 | (lbl,arg) <- zipEqual "gen_Show_binds"
947 -- Generates (showsPrec p x) for argument x, but it also boxes
948 -- the argument first if necessary. Note that this prints unboxed
949 -- things without any '#' decorations; could change that if need be
950 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
951 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
954 is_infix = isDataSymOcc dc_occ_nm
955 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
956 arg_prec | record_syntax = 0 -- Record fields don't need parens
957 | otherwise = con_prec_plus_one
959 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
963 getPrec :: Bool -> FixityEnv -> Name -> Integer
964 getPrec is_infix get_fixity nm
965 | not is_infix = appPrecedence
966 | otherwise = getPrecedence get_fixity nm
968 appPrecedence :: Integer
969 appPrecedence = fromIntegral maxPrecedence + 1
970 -- One more than the precedence of the most
971 -- tightly-binding operator
973 getPrecedence :: FixityEnv -> Name -> Integer
974 getPrecedence get_fixity nm
975 = case lookupFixity get_fixity nm of
976 Fixity x _ -> fromIntegral x
980 %************************************************************************
982 \subsection{Typeable}
984 %************************************************************************
992 instance Typeable2 T where
993 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
995 We are passed the Typeable2 class as well as T
998 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
999 gen_Typeable_binds tycon
1001 mk_easy_FunBind tycon_loc
1002 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1003 [nlWildPat] emptyBag
1004 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1006 tycon_loc = getSrcSpan tycon
1007 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1009 mk_typeOf_RDR :: TyCon -> RdrName
1010 -- Use the arity of the TyCon to make the right typeOfn function
1011 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_Name (mkFastString ("typeOf" ++ suffix))
1013 arity = tyConArity tycon
1014 suffix | arity == 0 = ""
1015 | otherwise = show arity
1020 %************************************************************************
1024 %************************************************************************
1028 data T a b = T1 a b | T2
1032 $cT1 = mkDataCon $dT "T1" Prefix
1033 $cT2 = mkDataCon $dT "T2" Prefix
1034 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1035 -- the [] is for field labels.
1037 instance (Data a, Data b) => Data (T a b) where
1038 gfoldl k z (T1 a b) = z T `k` a `k` b
1039 gfoldl k z T2 = z T2
1040 -- ToDo: add gmapT,Q,M, gfoldr
1042 gunfold k z c = case conIndex c of
1043 I# 1# -> k (k (z T1))
1046 toConstr (T1 _ _) = $cT1
1052 gen_Data_binds :: FixityEnv
1054 -> (LHsBinds RdrName, -- The method bindings
1055 LHsBinds RdrName) -- Auxiliary bindings
1056 gen_Data_binds fix_env tycon
1057 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1058 -- Auxiliary definitions: the data type and constructors
1059 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1061 tycon_loc = getSrcSpan tycon
1062 tycon_name = tyConName tycon
1063 data_cons = tyConDataCons tycon
1064 n_cons = length data_cons
1065 one_constr = n_cons == 1
1068 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1069 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1070 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1073 con_name = getRdrName con
1074 as_needed = take (dataConSourceArity con) as_RDRs
1075 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1077 ------------ gunfold
1078 gunfold_bind = mk_FunBind tycon_loc
1080 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1084 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1085 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1086 (map gunfold_alt data_cons)
1088 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1089 mk_unfold_rhs dc = foldr nlHsApp
1090 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1091 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1093 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1094 -- redundant test, and annoying warning
1095 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1096 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1100 ------------ toConstr
1101 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1102 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1104 ------------ dataTypeOf
1105 dataTypeOf_bind = mk_easy_FunBind
1110 (nlHsVar data_type_name)
1114 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1115 datatype_bind = mkVarBind
1118 ( nlHsVar mkDataType_RDR
1119 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1120 `nlHsApp` nlList constrs
1122 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1125 ------------ $cT1 etc
1126 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1127 mk_con_bind dc = mkVarBind
1130 (nlHsApps mkConstr_RDR (constr_args dc))
1132 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1133 nlHsVar data_type_name, -- DataType
1134 nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name
1135 nlList labels, -- Field labels
1136 nlHsVar fixity] -- Fixity
1138 labels = map (nlHsLit . mkHsString . getOccString . fieldLabelName)
1139 (dataConFieldLabels dc)
1140 dc_occ = getOccName dc
1141 is_infix = isDataSymOcc dc_occ
1142 fixity | is_infix = infix_RDR
1143 | otherwise = prefix_RDR
1145 gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl")
1146 gunfold_RDR = varQual_RDR gENERICS_Name FSLIT("gunfold")
1147 toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr")
1148 dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
1149 mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr")
1150 mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
1151 conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("constrIndex")
1152 prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix")
1153 infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix")
1156 %************************************************************************
1158 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1160 %************************************************************************
1165 con2tag_Foo :: Foo ... -> Int#
1166 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1167 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1170 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1175 = GenCon2Tag | GenTag2Con | GenMaxTag
1177 gen_tag_n_con_monobind
1178 :: ( RdrName, -- (proto)Name for the thing in question
1179 TyCon, -- tycon in question
1183 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1184 | lots_of_constructors
1185 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1188 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1191 tycon_loc = getSrcSpan tycon
1193 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1194 -- We can't use gerRdrName because that makes an Exact RdrName
1195 -- and we can't put them in the LocalRdrEnv
1197 -- Give a signature to the bound variable, so
1198 -- that the case expression generated by getTag is
1199 -- monomorphic. In the push-enter model we get better code.
1200 get_tag_rhs = noLoc $ ExprWithTySig
1201 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1202 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1203 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1205 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1208 nlHsTyVar (getRdrName intPrimTyCon)
1210 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1212 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1213 mk_stuff con = ([nlWildConPat con],
1214 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1216 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1217 = mk_FunBind (getSrcSpan tycon) rdr_name
1218 [([nlConVarPat intDataCon_RDR [a_RDR]],
1219 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1220 (nlHsTyVar (getRdrName tycon))))]
1222 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1223 = mkVarBind (getSrcSpan tycon) rdr_name
1224 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1226 max_tag = case (tyConDataCons tycon) of
1227 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1231 %************************************************************************
1233 \subsection{Utility bits for generating bindings}
1235 %************************************************************************
1238 ToDo: Better SrcLocs.
1242 LHsExpr RdrName -- What to do for equality
1243 -> LHsExpr RdrName -> LHsExpr RdrName
1245 careful_compare_Case :: -- checks for primitive types...
1246 TyCon -- The tycon we are deriving for
1248 -> LHsExpr RdrName -- What to do for equality
1249 -> LHsExpr RdrName -> LHsExpr RdrName
1252 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1253 -- Was: compare_gen_Case cmp_eq_RDR
1255 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1256 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1257 compare_gen_Case eq a b -- General case
1258 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1259 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1260 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1261 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1263 careful_compare_Case tycon ty eq a b
1264 | not (isUnLiftedType ty)
1265 = compare_gen_Case eq a b
1266 | otherwise -- We have to do something special for primitive things...
1267 = nlHsIf (genOpApp a relevant_eq_op b)
1269 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1271 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1272 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1275 box_if_necy :: String -- The class involved
1276 -> TyCon -- The tycon involved
1277 -> LHsExpr RdrName -- The argument
1278 -> Type -- The argument type
1279 -> LHsExpr RdrName -- Boxed version of the arg
1280 box_if_necy cls_str tycon arg arg_ty
1281 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1284 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1286 assoc_ty_id :: String -- The class involved
1287 -> TyCon -- The tycon involved
1288 -> [(Type,a)] -- The table
1290 -> a -- The result of the lookup
1291 assoc_ty_id cls_str tycon tbl ty
1292 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1293 text "for primitive type" <+> ppr ty)
1294 | otherwise = head res
1296 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1298 eq_op_tbl :: [(Type, PrimOp)]
1300 [(charPrimTy, CharEqOp)
1301 ,(intPrimTy, IntEqOp)
1302 ,(wordPrimTy, WordEqOp)
1303 ,(addrPrimTy, AddrEqOp)
1304 ,(floatPrimTy, FloatEqOp)
1305 ,(doublePrimTy, DoubleEqOp)
1308 lt_op_tbl :: [(Type, PrimOp)]
1310 [(charPrimTy, CharLtOp)
1311 ,(intPrimTy, IntLtOp)
1312 ,(wordPrimTy, WordLtOp)
1313 ,(addrPrimTy, AddrLtOp)
1314 ,(floatPrimTy, FloatLtOp)
1315 ,(doublePrimTy, DoubleLtOp)
1319 [(charPrimTy, getRdrName charDataCon)
1320 ,(intPrimTy, getRdrName intDataCon)
1321 ,(wordPrimTy, wordDataCon_RDR)
1322 ,(addrPrimTy, addrDataCon_RDR)
1323 ,(floatPrimTy, getRdrName floatDataCon)
1324 ,(doublePrimTy, getRdrName doubleDataCon)
1327 -----------------------------------------------------------------------
1329 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1330 and_Expr a b = genOpApp a and_RDR b
1332 -----------------------------------------------------------------------
1334 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1335 eq_Expr tycon ty a b = genOpApp a eq_op b
1338 | not (isUnLiftedType ty) = eq_RDR
1340 -- we have to do something special for primitive things...
1341 primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1345 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1346 untag_Expr tycon [] expr = expr
1347 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1348 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1349 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1351 cmp_tags_Expr :: RdrName -- Comparison op
1352 -> RdrName -> RdrName -- Things to compare
1353 -> LHsExpr RdrName -- What to return if true
1354 -> LHsExpr RdrName -- What to return if false
1357 cmp_tags_Expr op a b true_case false_case
1358 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1361 :: LHsExpr RdrName -> LHsExpr RdrName
1363 enum_from_then_to_Expr
1364 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1367 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1368 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1371 :: LHsExpr RdrName -> LHsExpr RdrName
1374 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1376 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1378 nested_compose_Expr [e] = parenify e
1379 nested_compose_Expr (e:es)
1380 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1382 -- impossible_Expr is used in case RHSs that should never happen.
1383 -- We generate these to keep the desugarer from complaining that they *might* happen!
1384 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1386 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1387 -- method. It is currently only used by Enum.{succ,pred}
1388 illegal_Expr meth tp msg =
1389 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1391 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1392 -- to include the value of a_RDR in the error string.
1393 illegal_toEnum_tag tp maxtag =
1394 nlHsApp (nlHsVar error_RDR)
1395 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1396 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1397 (nlHsApp (nlHsApp (nlHsApp
1398 (nlHsVar showsPrec_RDR)
1402 (nlHsVar append_RDR)
1403 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1404 (nlHsApp (nlHsApp (nlHsApp
1405 (nlHsVar showsPrec_RDR)
1408 (nlHsLit (mkHsString ")"))))))
1410 parenify e@(L _ (HsVar _)) = e
1411 parenify e = mkHsPar e
1413 -- genOpApp wraps brackets round the operator application, so that the
1414 -- renamer won't subsequently try to re-associate it.
1415 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1419 getSrcSpan = srcLocSpan . getSrcLoc
1423 a_RDR = mkVarUnqual FSLIT("a")
1424 b_RDR = mkVarUnqual FSLIT("b")
1425 c_RDR = mkVarUnqual FSLIT("c")
1426 d_RDR = mkVarUnqual FSLIT("d")
1427 k_RDR = mkVarUnqual FSLIT("k")
1428 z_RDR = mkVarUnqual FSLIT("z")
1429 ah_RDR = mkVarUnqual FSLIT("a#")
1430 bh_RDR = mkVarUnqual FSLIT("b#")
1431 ch_RDR = mkVarUnqual FSLIT("c#")
1432 dh_RDR = mkVarUnqual FSLIT("d#")
1433 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1434 rangeSize_RDR = mkVarUnqual FSLIT("rangeSize")
1436 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1437 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1438 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1440 a_Expr = nlHsVar a_RDR
1441 b_Expr = nlHsVar b_RDR
1442 c_Expr = nlHsVar c_RDR
1443 ltTag_Expr = nlHsVar ltTag_RDR
1444 eqTag_Expr = nlHsVar eqTag_RDR
1445 gtTag_Expr = nlHsVar gtTag_RDR
1446 false_Expr = nlHsVar false_RDR
1447 true_Expr = nlHsVar true_RDR
1449 a_Pat = nlVarPat a_RDR
1450 b_Pat = nlVarPat b_RDR
1451 c_Pat = nlVarPat c_RDR
1452 d_Pat = nlVarPat d_RDR
1453 k_Pat = nlVarPat k_RDR
1454 z_Pat = nlVarPat z_RDR
1456 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1457 -- Generates Orig s RdrName, for the binding positions
1458 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1459 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1460 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1462 mk_tc_deriv_name tycon str
1463 = mkDerivedRdrName tc_name mk_occ
1465 tc_name = tyConName tycon
1466 mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1468 new_str = str ++ occNameString tc_occ ++ "#"
1471 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1472 PrelNames, so PrelNames can't import PrimOp.
1475 primOpRdrName op = getRdrName (primOpId op)
1477 minusInt_RDR = primOpRdrName IntSubOp
1478 eqInt_RDR = primOpRdrName IntEqOp
1479 ltInt_RDR = primOpRdrName IntLtOp
1480 geInt_RDR = primOpRdrName IntGeOp
1481 leInt_RDR = primOpRdrName IntLeOp
1482 tagToEnum_RDR = primOpRdrName TagToEnumOp
1484 error_RDR = getRdrName eRROR_ID