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, getOccName, getSrcLoc, occNameString,
43 isDataSymOcc, isSymOcc
46 import HscTypes ( FixityEnv, lookupFixity )
50 import MkId ( eRROR_ID )
51 import PrimOp ( PrimOp(..) )
52 import SrcLoc ( Located(..), noLoc, srcLocSpan )
53 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
54 maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName
56 import TcType ( isUnLiftedType, tcEqType, Type )
57 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
59 import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon )
60 import Util ( zipWithEqual, isSingleton,
61 zipWith3Equal, nOfThem, zipEqual )
62 import Char ( isAlpha )
64 import List ( partition, intersperse )
71 %************************************************************************
73 \subsection{Generating code, by derivable class}
75 %************************************************************************
77 %************************************************************************
79 \subsubsection{Generating @Eq@ instance declarations}
81 %************************************************************************
83 Here are the heuristics for the code we generate for @Eq@:
86 Let's assume we have a data type with some (possibly zero) nullary
87 data constructors and some ordinary, non-nullary ones (the rest,
88 also possibly zero of them). Here's an example, with both \tr{N}ullary
89 and \tr{O}rdinary data cons.
91 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
95 For the ordinary constructors (if any), we emit clauses to do The
99 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
100 (==) (O2 a1) (O2 a2) = a1 == a2
101 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
104 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
105 \tr{a2} are \tr{Float#}s, then we have to generate
107 case (a1 `eqFloat#` a2) of
110 for that particular test.
113 If there are any nullary constructors, we emit a catch-all clause of
117 (==) a b = case (con2tag_Foo a) of { a# ->
118 case (con2tag_Foo b) of { b# ->
119 case (a# ==# b#) of {
124 If there aren't any nullary constructors, we emit a simpler
131 For the @(/=)@ method, we normally just use the default method.
133 If the type is an enumeration type, we could/may/should? generate
134 special code that calls @con2tag_Foo@, much like for @(==)@ shown
138 We thought about doing this: If we're also deriving @Ord@ for this
141 instance ... Eq (Foo ...) where
142 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
143 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
145 However, that requires that \tr{Ord <whatever>} was put in the context
146 for the instance decl, which it probably wasn't, so the decls
147 produced don't get through the typechecker.
152 gen_Eq_binds :: TyCon -> LHsBinds RdrName
156 tycon_loc = getSrcSpan tycon
158 (nullary_cons, nonnullary_cons)
159 | isNewTyCon tycon = ([], tyConDataCons tycon)
160 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
163 = if (null nullary_cons) then
164 case maybeTyConSingleCon tycon of
166 Nothing -> -- if cons don't match, then False
167 [([wildPat, wildPat], false_Expr)]
168 else -- calc. and compare the tags
170 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
171 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
174 mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
175 mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyBag (
176 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
179 ------------------------------------------------------------------
182 con1_pat = nlConVarPat data_con_RDR as_needed
183 con2_pat = nlConVarPat data_con_RDR bs_needed
185 data_con_RDR = getRdrName data_con
186 con_arity = length tys_needed
187 as_needed = take con_arity as_RDRs
188 bs_needed = take con_arity bs_RDRs
189 tys_needed = dataConOrigArgTys data_con
191 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
193 nested_eq_expr [] [] [] = true_Expr
194 nested_eq_expr tys as bs
195 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
197 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
200 %************************************************************************
202 \subsubsection{Generating @Ord@ instance declarations}
204 %************************************************************************
206 For a derived @Ord@, we concentrate our attentions on @compare@
208 compare :: a -> a -> Ordering
209 data Ordering = LT | EQ | GT deriving ()
212 We will use the same example data type as above:
214 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
219 We do all the other @Ord@ methods with calls to @compare@:
221 instance ... (Ord <wurble> <wurble>) where
222 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
223 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
224 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
225 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
227 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
228 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
230 -- compare to come...
234 @compare@ always has two parts. First, we use the compared
235 data-constructors' tags to deal with the case of different
238 compare a b = case (con2tag_Foo a) of { a# ->
239 case (con2tag_Foo b) of { b# ->
240 case (a# ==# b#) of {
242 False -> case (a# <# b#) of
247 cmp_eq = ... to come ...
251 We are only left with the ``help'' function @cmp_eq@, to deal with
252 comparing data constructors with the same tag.
254 For the ordinary constructors (if any), we emit the sorta-obvious
255 compare-style stuff; for our example:
257 cmp_eq (O1 a1 b1) (O1 a2 b2)
258 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
260 cmp_eq (O2 a1) (O2 a2)
263 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
264 = case (compare a1 a2) of {
267 EQ -> case compare b1 b2 of {
275 Again, we must be careful about unlifted comparisons. For example,
276 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
280 cmp_eq lt eq gt (O2 a1) (O2 a2)
282 -- or maybe the unfolded equivalent
286 For the remaining nullary constructors, we already know that the
293 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
297 gen_Ord_binds :: TyCon -> LHsBinds RdrName
300 = unitBag compare -- `AndMonoBinds` compare
301 -- The default declaration in PrelBase handles this
303 tycon_loc = getSrcSpan tycon
304 --------------------------------------------------------------------
306 compare = mk_easy_FunBind tycon_loc compare_RDR
307 [a_Pat, b_Pat] (unitBag cmp_eq) compare_rhs
309 | single_con_type = cmp_eq_Expr a_Expr b_Expr
311 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
312 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
313 (cmp_eq_Expr a_Expr b_Expr) -- True case
314 -- False case; they aren't equal
315 -- So we need to do a less-than comparison on the tags
316 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
318 tycon_data_cons = tyConDataCons tycon
319 single_con_type = isSingleton tycon_data_cons
320 (nullary_cons, nonnullary_cons)
321 | isNewTyCon tycon = ([], tyConDataCons tycon)
322 | otherwise = partition isNullaryDataCon tycon_data_cons
324 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
326 | isEnumerationTyCon tycon
327 -- We know the tags are equal, so if it's an enumeration TyCon,
328 -- then there is nothing left to do
329 -- Catch this specially to avoid warnings
330 -- about overlapping patterns from the desugarer,
331 -- and to avoid unnecessary pattern-matching
332 = [([wildPat,wildPat], eqTag_Expr)]
334 = map pats_etc nonnullary_cons ++
335 (if single_con_type then -- Omit wildcards when there's just one
336 [] -- constructor, to silence desugarer
338 [([wildPat, wildPat], default_rhs)])
342 = ([con1_pat, con2_pat],
343 nested_compare_expr tys_needed as_needed bs_needed)
345 con1_pat = nlConVarPat data_con_RDR as_needed
346 con2_pat = nlConVarPat data_con_RDR bs_needed
348 data_con_RDR = getRdrName data_con
349 con_arity = length tys_needed
350 as_needed = take con_arity as_RDRs
351 bs_needed = take con_arity bs_RDRs
352 tys_needed = dataConOrigArgTys data_con
354 nested_compare_expr [ty] [a] [b]
355 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
357 nested_compare_expr (ty:tys) (a:as) (b:bs)
358 = let eq_expr = nested_compare_expr tys as bs
359 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
361 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
362 -- inexhaustive patterns
363 | otherwise = eqTag_Expr -- Some nullary constructors;
364 -- Tags are equal, no args => return EQ
367 %************************************************************************
369 \subsubsection{Generating @Enum@ instance declarations}
371 %************************************************************************
373 @Enum@ can only be derived for enumeration types. For a type
375 data Foo ... = N1 | N2 | ... | Nn
378 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
379 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
382 instance ... Enum (Foo ...) where
383 succ x = toEnum (1 + fromEnum x)
384 pred x = toEnum (fromEnum x - 1)
386 toEnum i = tag2con_Foo i
388 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
392 = case con2tag_Foo a of
393 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
396 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
400 = case con2tag_Foo a of { a# ->
401 case con2tag_Foo b of { b# ->
402 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
406 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
409 gen_Enum_binds :: TyCon -> LHsBinds RdrName
421 tycon_loc = getSrcSpan tycon
422 occ_nm = getOccString tycon
425 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyBag $
426 untag_Expr tycon [(a_RDR, ah_RDR)] $
427 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
428 nlHsVarApps intDataCon_RDR [ah_RDR]])
429 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
430 (nlHsApp (nlHsVar (tag2con_RDR tycon))
431 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
435 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyBag $
436 untag_Expr tycon [(a_RDR, ah_RDR)] $
437 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
438 nlHsVarApps intDataCon_RDR [ah_RDR]])
439 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
440 (nlHsApp (nlHsVar (tag2con_RDR tycon))
441 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
442 nlHsLit (HsInt (-1))]))
445 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyBag $
446 nlHsIf (nlHsApps and_RDR
447 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
448 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
449 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
450 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
453 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyBag $
454 untag_Expr tycon [(a_RDR, ah_RDR)] $
456 [nlHsVar (tag2con_RDR tycon),
457 nlHsPar (enum_from_to_Expr
458 (nlHsVarApps intDataCon_RDR [ah_RDR])
459 (nlHsVar (maxtag_RDR tycon)))]
462 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyBag $
463 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
464 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
465 nlHsPar (enum_from_then_to_Expr
466 (nlHsVarApps intDataCon_RDR [ah_RDR])
467 (nlHsVarApps intDataCon_RDR [bh_RDR])
468 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
469 nlHsVarApps intDataCon_RDR [bh_RDR]])
471 (nlHsVar (maxtag_RDR tycon))
475 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyBag $
476 untag_Expr tycon [(a_RDR, ah_RDR)] $
477 (nlHsVarApps intDataCon_RDR [ah_RDR])
480 %************************************************************************
482 \subsubsection{Generating @Bounded@ instance declarations}
484 %************************************************************************
487 gen_Bounded_binds tycon
488 = if isEnumerationTyCon tycon then
489 listToBag [ min_bound_enum, max_bound_enum ]
491 ASSERT(isSingleton data_cons)
492 listToBag [ min_bound_1con, max_bound_1con ]
494 data_cons = tyConDataCons tycon
495 tycon_loc = getSrcSpan tycon
497 ----- enum-flavored: ---------------------------
498 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
499 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
501 data_con_1 = head data_cons
502 data_con_N = last data_cons
503 data_con_1_RDR = getRdrName data_con_1
504 data_con_N_RDR = getRdrName data_con_N
506 ----- single-constructor-flavored: -------------
507 arity = dataConSourceArity data_con_1
509 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
510 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
511 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
512 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
515 %************************************************************************
517 \subsubsection{Generating @Ix@ instance declarations}
519 %************************************************************************
521 Deriving @Ix@ is only possible for enumeration types and
522 single-constructor types. We deal with them in turn.
524 For an enumeration type, e.g.,
526 data Foo ... = N1 | N2 | ... | Nn
528 things go not too differently from @Enum@:
530 instance ... Ix (Foo ...) where
532 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
536 = case (con2tag_Foo a) of { a# ->
537 case (con2tag_Foo b) of { b# ->
538 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
543 then case (con2tag_Foo d -# con2tag_Foo a) of
545 else error "Ix.Foo.index: out of range"
549 p_tag = con2tag_Foo c
551 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
555 = case (con2tag_Foo a) of { a_tag ->
556 case (con2tag_Foo b) of { b_tag ->
557 case (con2tag_Foo c) of { c_tag ->
558 if (c_tag >=# a_tag) then
564 (modulo suitable case-ification to handle the unlifted tags)
566 For a single-constructor type (NB: this includes all tuples), e.g.,
568 data Foo ... = MkFoo a b Int Double c c
570 we follow the scheme given in Figure~19 of the Haskell~1.2 report
574 gen_Ix_binds :: TyCon -> LHsBinds RdrName
577 = if isEnumerationTyCon tycon
581 tycon_str = getOccString tycon
582 tycon_loc = getSrcSpan tycon
584 --------------------------------------------------------------
585 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
588 = mk_easy_FunBind tycon_loc range_RDR
589 [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $
590 untag_Expr tycon [(a_RDR, ah_RDR)] $
591 untag_Expr tycon [(b_RDR, bh_RDR)] $
592 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
593 nlHsPar (enum_from_to_Expr
594 (nlHsVarApps intDataCon_RDR [ah_RDR])
595 (nlHsVarApps intDataCon_RDR [bh_RDR]))
598 = mk_easy_FunBind tycon_loc index_RDR
599 [noLoc (AsPat (noLoc c_RDR)
600 (nlTuplePat [a_Pat, wildPat] Boxed)),
602 nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
603 untag_Expr tycon [(a_RDR, ah_RDR)] (
604 untag_Expr tycon [(d_RDR, dh_RDR)] (
606 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
609 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
610 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
613 nlHsApp (nlHsVar error_RDR) (nlHsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
617 = mk_easy_FunBind tycon_loc inRange_RDR
618 [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag (
619 untag_Expr tycon [(a_RDR, ah_RDR)] (
620 untag_Expr tycon [(b_RDR, bh_RDR)] (
621 untag_Expr tycon [(c_RDR, ch_RDR)] (
622 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
623 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
628 --------------------------------------------------------------
630 = listToBag [single_con_range, single_con_index, single_con_inRange]
633 = case maybeTyConSingleCon tycon of -- just checking...
634 Nothing -> panic "get_Ix_binds"
635 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
636 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
639 con_arity = dataConSourceArity data_con
640 data_con_RDR = getRdrName data_con
642 as_needed = take con_arity as_RDRs
643 bs_needed = take con_arity bs_RDRs
644 cs_needed = take con_arity cs_RDRs
646 con_pat xs = nlConVarPat data_con_RDR xs
647 con_expr = nlHsVarApps data_con_RDR cs_needed
649 --------------------------------------------------------------
651 = mk_easy_FunBind tycon_loc range_RDR
652 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyBag $
653 nlHsDo ListComp stmts
655 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
657 [nlResultStmt con_expr]
659 mk_qual a b c = nlBindStmt (nlVarPat c)
660 (nlHsApp (nlHsVar range_RDR)
661 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
665 = mk_easy_FunBind tycon_loc index_RDR
666 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
667 con_pat cs_needed] (unitBag range_size) (
668 foldl mk_index (nlHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
670 mk_index multiply_by (l, u, i)
672 (nlHsApps index_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed,
676 (nlHsApp (nlHsVar rangeSize_RDR)
677 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
678 ) times_RDR multiply_by
682 = mk_easy_FunBind tycon_loc rangeSize_RDR
683 [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag (
685 (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed,
687 ) plus_RDR (nlHsIntLit 1))
691 = mk_easy_FunBind tycon_loc inRange_RDR
692 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
695 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
697 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
701 %************************************************************************
703 \subsubsection{Generating @Read@ instance declarations}
705 %************************************************************************
715 instance Read T where
719 do x <- ReadP.step Read.readPrec
720 Symbol "%%" <- Lex.lex
721 y <- ReadP.step Read.readPrec
725 do Ident "T1" <- Lex.lex
727 Ident "f1" <- Lex.lex
729 x <- ReadP.reset Read.readPrec
731 return (T1 { f1 = x }))
734 do Ident "T2" <- Lex.lexP
735 x <- ReadP.step Read.readPrec
739 readListPrec = readListPrecDefault
740 readList = readListDefault
744 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
746 gen_Read_binds get_fixity tycon
747 = listToBag [read_prec, default_readlist, default_readlistprec]
749 -----------------------------------------------------------------------
751 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
754 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
755 -----------------------------------------------------------------------
757 loc = getSrcSpan tycon
758 data_cons = tyConDataCons tycon
759 (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
761 read_prec = mkVarBind loc readPrec_RDR
762 (nlHsApp (nlHsVar parens_RDR) read_cons)
764 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
765 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
768 = case nullary_cons of
770 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
772 _ -> [nlHsApp (nlHsVar choose_RDR)
773 (nlList (map mk_pair nullary_cons))]
775 mk_pair con = nlTuple [nlHsLit (data_con_str con),
776 nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
779 read_non_nullary_con data_con
780 = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts]
782 stmts | is_infix = infix_stmts
783 | length labels > 0 = lbl_stmts
784 | otherwise = prefix_stmts
786 prefix_stmts -- T a b c
787 = [bindLex (ident_pat (data_con_str data_con))]
789 ++ [result_stmt data_con as_needed]
791 infix_stmts -- a %% b
793 bindLex (symbol_pat (data_con_str data_con)),
795 result_stmt data_con [a1,a2]]
797 lbl_stmts -- T { f1 = a, f2 = b }
798 = [bindLex (ident_pat (data_con_str data_con)),
800 ++ concat (intersperse [read_punc ","] field_stmts)
801 ++ [read_punc "}", result_stmt data_con as_needed]
803 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
805 con_arity = dataConSourceArity data_con
806 labels = dataConFieldLabels data_con
807 dc_nm = getName data_con
808 is_infix = isDataSymOcc (getOccName dc_nm)
809 as_needed = take con_arity as_RDRs
810 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
811 (read_a1:read_a2:_) = read_args
812 (a1:a2:_) = as_needed
813 prec = getPrec is_infix get_fixity dc_nm
815 ------------------------------------------------------------------------
817 ------------------------------------------------------------------------
818 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
819 bindLex pat = nlBindStmt pat (nlHsVar lexP_RDR)
820 result_stmt c as = nlResultStmt (nlHsApp (nlHsVar returnM_RDR) (con_app c as))
821 con_app c as = nlHsVarApps (getRdrName c) as
823 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
824 ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo"
825 symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>"
827 data_con_str con = mkHsString (occNameUserString (getOccName con))
829 read_punc c = bindLex (punc_pat c)
831 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
832 | otherwise = nlBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])
834 read_field lbl a = read_lbl lbl ++
836 nlBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR])]
838 -- When reading field labels we might encounter
843 read_lbl lbl | is_id_start (head lbl_str)
844 = [bindLex (ident_pat lbl_lit)]
847 bindLex (symbol_pat lbl_lit),
850 lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
851 lbl_lit = mkHsString lbl_str
852 is_id_start c = isAlpha c || c == '_'
856 %************************************************************************
858 \subsubsection{Generating @Show@ instance declarations}
860 %************************************************************************
866 data Tree a = Leaf a | Tree a :^: Tree a
868 instance (Show a) => Show (Tree a) where
870 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
872 showStr = showString "Leaf " . showsPrec (app_prec+1) m
874 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
876 showStr = showsPrec (up_prec+1) u .
878 showsPrec (up_prec+1) v
879 -- Note: right-associativity of :^: ignored
881 up_prec = 5 -- Precedence of :^:
882 app_prec = 10 -- Application has precedence one more than
883 -- the most tightly-binding operator
886 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
888 gen_Show_binds get_fixity tycon
889 = listToBag [shows_prec, show_list]
891 tycon_loc = getSrcSpan tycon
892 -----------------------------------------------------------------------
893 show_list = mkVarBind tycon_loc showList_RDR
894 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
895 -----------------------------------------------------------------------
896 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
899 | nullary_con = -- skip the showParen junk...
900 ASSERT(null bs_needed)
901 ([wildPat, con_pat], mk_showString_app con_str)
904 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
905 (nlHsPar (nested_compose_Expr show_thingies)))
907 data_con_RDR = getRdrName data_con
908 con_arity = dataConSourceArity data_con
909 bs_needed = take con_arity bs_RDRs
910 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
911 con_pat = nlConVarPat data_con_RDR bs_needed
912 nullary_con = con_arity == 0
913 labels = dataConFieldLabels data_con
914 lab_fields = length labels
915 record_syntax = lab_fields > 0
917 dc_nm = getName data_con
918 dc_occ_nm = getOccName data_con
919 con_str = occNameUserString dc_occ_nm
922 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
923 | record_syntax = mk_showString_app (con_str ++ " {") :
924 show_record_args ++ [mk_showString_app "}"]
925 | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
927 show_label l = mk_showString_app (the_name ++ " = ")
928 -- Note the spaces around the "=" sign. If we don't have them
929 -- then we get Foo { x=-1 } and the "=-" parses as a single
930 -- lexeme. Only the space after the '=' is necessary, but
931 -- it seems tidier to have them both sides.
933 occ_nm = getOccName (fieldLabelName l)
934 nm = occNameUserString occ_nm
935 is_op = isSymOcc occ_nm -- Legal, but rare.
936 the_name | is_op = '(':nm ++ ")"
939 show_args = zipWith show_arg bs_needed arg_tys
940 (show_arg1:show_arg2:_) = show_args
941 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
943 -- Assumption for record syntax: no of fields == no of labelled fields
944 -- (and in same order)
945 show_record_args = concat $
946 intersperse [mk_showString_app ", "] $
947 [ [show_label lbl, arg]
948 | (lbl,arg) <- zipEqual "gen_Show_binds"
951 -- Generates (showsPrec p x) for argument x, but it also boxes
952 -- the argument first if necessary. Note that this prints unboxed
953 -- things without any '#' decorations; could change that if need be
954 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
955 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
958 is_infix = isDataSymOcc dc_occ_nm
959 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
960 arg_prec | record_syntax = 0 -- Record fields don't need parens
961 | otherwise = con_prec_plus_one
963 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
967 getPrec :: Bool -> FixityEnv -> Name -> Integer
968 getPrec is_infix get_fixity nm
969 | not is_infix = appPrecedence
970 | otherwise = getPrecedence get_fixity nm
972 appPrecedence :: Integer
973 appPrecedence = fromIntegral maxPrecedence + 1
974 -- One more than the precedence of the most
975 -- tightly-binding operator
977 getPrecedence :: FixityEnv -> Name -> Integer
978 getPrecedence get_fixity nm
979 = case lookupFixity get_fixity nm of
980 Fixity x _ -> fromIntegral x
984 %************************************************************************
986 \subsection{Typeable}
988 %************************************************************************
996 instance (Typeable a, Typeable b) => Typeable (T a b) where
997 typeOf _ = mkTypeRep (mkTyConRep "T")
998 [typeOf (undefined::a),
999 typeOf (undefined::b)]
1001 Notice the use of lexically scoped type variables.
1004 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1005 gen_Typeable_binds tycon
1007 mk_easy_FunBind tycon_loc typeOf_RDR [wildPat] emptyBag
1008 (nlHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
1010 tycon_loc = getSrcSpan tycon
1011 tyvars = tyConTyVars tycon
1012 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1013 arg_reps = nlList (map mk tyvars)
1014 mk tyvar = nlHsApp (nlHsVar typeOf_RDR)
1015 (noLoc (ExprWithTySig (nlHsVar undefined_RDR)
1016 (nlHsTyVar (getRdrName tyvar))))
1021 %************************************************************************
1025 %************************************************************************
1029 data T a b = T1 a b | T2
1033 $cT1 = mkConstr 1 "T1" Prefix
1034 $cT2 = mkConstr 2 "T2" Prefix
1035 $dT = mkDataType [$con_T1, $con_T2]
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 fromConstr c = case conIndex c of
1043 I# 1# -> T1 undefined undefined
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, fromCon_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
1066 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1067 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1068 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1071 con_name = getRdrName con
1072 as_needed = take (dataConSourceArity con) as_RDRs
1073 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1075 ------------ fromConstr
1076 fromCon_bind = mk_FunBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)]
1077 from_con_rhs = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1078 (map from_con_alt data_cons)
1079 from_con_alt dc = mkSimpleHsAlt (nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger (dataConTag dc)))])
1080 (nlHsVarApps (getRdrName dc)
1081 (replicate (dataConSourceArity dc) undefined_RDR))
1083 ------------ toConstr
1084 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1085 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1087 ------------ dataTypeOf
1088 dataTypeOf_bind = mk_easy_FunBind tycon_loc dataTypeOf_RDR [wildPat]
1089 emptyBag (nlHsVar data_type_name)
1092 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1093 datatype_bind = mkVarBind tycon_loc data_type_name
1094 (nlHsVar mkDataType_RDR `nlHsApp`
1096 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1099 ------------ $cT1 etc
1100 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1101 mk_con_bind dc = mkVarBind tycon_loc (mk_constr_name dc)
1102 (nlHsApps mkConstr_RDR (constr_args dc))
1103 constr_args dc = [nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1104 nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name
1105 nlHsVar fixity] -- Fixity
1107 dc_occ = getOccName dc
1108 is_infix = isDataSymOcc dc_occ
1109 fixity | is_infix = infix_RDR
1110 | otherwise = prefix_RDR
1112 gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl")
1113 fromConstr_RDR = varQual_RDR gENERICS_Name FSLIT("fromConstr")
1114 toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr")
1115 dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
1116 mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr")
1117 mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
1118 conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("conIndex")
1119 prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix")
1120 infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix")
1123 %************************************************************************
1125 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1127 %************************************************************************
1132 con2tag_Foo :: Foo ... -> Int#
1133 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1134 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1137 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1142 = GenCon2Tag | GenTag2Con | GenMaxTag
1144 gen_tag_n_con_monobind
1145 :: ( RdrName, -- (proto)Name for the thing in question
1146 TyCon, -- tycon in question
1150 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1151 | lots_of_constructors
1152 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1155 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1158 tycon_loc = getSrcSpan tycon
1160 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1161 -- We can't use gerRdrName because that makes an Exact RdrName
1162 -- and we can't put them in the LocalRdrEnv
1164 -- Give a signature to the bound variable, so
1165 -- that the case expression generated by getTag is
1166 -- monomorphic. In the push-enter model we get better code.
1167 get_tag_rhs = noLoc $ ExprWithTySig
1168 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1169 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1170 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1172 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1175 nlHsTyVar (getRdrName intPrimTyCon)
1177 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1179 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1180 mk_stuff con = ([nlWildConPat con],
1181 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1183 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1184 = mk_FunBind (getSrcSpan tycon) rdr_name
1185 [([nlConVarPat intDataCon_RDR [a_RDR]],
1186 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1187 (nlHsTyVar (getRdrName tycon))))]
1189 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1190 = mkVarBind (getSrcSpan tycon) rdr_name
1191 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1193 max_tag = case (tyConDataCons tycon) of
1194 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1198 %************************************************************************
1200 \subsection{Utility bits for generating bindings}
1202 %************************************************************************
1205 ToDo: Better SrcLocs.
1209 LHsExpr RdrName -- What to do for equality
1210 -> LHsExpr RdrName -> LHsExpr RdrName
1212 careful_compare_Case :: -- checks for primitive types...
1213 TyCon -- The tycon we are deriving for
1215 -> LHsExpr RdrName -- What to do for equality
1216 -> LHsExpr RdrName -> LHsExpr RdrName
1219 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1220 -- Was: compare_gen_Case cmp_eq_RDR
1222 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1223 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1224 compare_gen_Case eq a b -- General case
1225 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1226 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1227 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1228 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1230 careful_compare_Case tycon ty eq a b
1231 | not (isUnLiftedType ty)
1232 = compare_gen_Case eq a b
1233 | otherwise -- We have to do something special for primitive things...
1234 = nlHsIf (genOpApp a relevant_eq_op b)
1236 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1238 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1239 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1242 box_if_necy :: String -- The class involved
1243 -> TyCon -- The tycon involved
1244 -> LHsExpr RdrName -- The argument
1245 -> Type -- The argument type
1246 -> LHsExpr RdrName -- Boxed version of the arg
1247 box_if_necy cls_str tycon arg arg_ty
1248 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1251 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1253 assoc_ty_id :: String -- The class involved
1254 -> TyCon -- The tycon involved
1255 -> [(Type,a)] -- The table
1257 -> a -- The result of the lookup
1258 assoc_ty_id cls_str tycon tbl ty
1259 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1260 text "for primitive type" <+> ppr ty)
1261 | otherwise = head res
1263 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1265 eq_op_tbl :: [(Type, PrimOp)]
1267 [(charPrimTy, CharEqOp)
1268 ,(intPrimTy, IntEqOp)
1269 ,(wordPrimTy, WordEqOp)
1270 ,(addrPrimTy, AddrEqOp)
1271 ,(floatPrimTy, FloatEqOp)
1272 ,(doublePrimTy, DoubleEqOp)
1275 lt_op_tbl :: [(Type, PrimOp)]
1277 [(charPrimTy, CharLtOp)
1278 ,(intPrimTy, IntLtOp)
1279 ,(wordPrimTy, WordLtOp)
1280 ,(addrPrimTy, AddrLtOp)
1281 ,(floatPrimTy, FloatLtOp)
1282 ,(doublePrimTy, DoubleLtOp)
1286 [(charPrimTy, getRdrName charDataCon)
1287 ,(intPrimTy, getRdrName intDataCon)
1288 ,(wordPrimTy, wordDataCon_RDR)
1289 ,(addrPrimTy, addrDataCon_RDR)
1290 ,(floatPrimTy, getRdrName floatDataCon)
1291 ,(doublePrimTy, getRdrName doubleDataCon)
1294 -----------------------------------------------------------------------
1296 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1297 and_Expr a b = genOpApp a and_RDR b
1299 -----------------------------------------------------------------------
1301 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1302 eq_Expr tycon ty a b = genOpApp a eq_op b
1305 | not (isUnLiftedType ty) = eq_RDR
1307 -- we have to do something special for primitive things...
1308 primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1312 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1313 untag_Expr tycon [] expr = expr
1314 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1315 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1316 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1318 cmp_tags_Expr :: RdrName -- Comparison op
1319 -> RdrName -> RdrName -- Things to compare
1320 -> LHsExpr RdrName -- What to return if true
1321 -> LHsExpr RdrName -- What to return if false
1324 cmp_tags_Expr op a b true_case false_case
1325 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1328 :: LHsExpr RdrName -> LHsExpr RdrName
1330 enum_from_then_to_Expr
1331 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1334 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1335 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1338 :: LHsExpr RdrName -> LHsExpr RdrName
1341 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1343 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1345 nested_compose_Expr [e] = parenify e
1346 nested_compose_Expr (e:es)
1347 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1349 -- impossible_Expr is used in case RHSs that should never happen.
1350 -- We generate these to keep the desugarer from complaining that they *might* happen!
1351 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1353 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1354 -- method. It is currently only used by Enum.{succ,pred}
1355 illegal_Expr meth tp msg =
1356 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1358 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1359 -- to include the value of a_RDR in the error string.
1360 illegal_toEnum_tag tp maxtag =
1361 nlHsApp (nlHsVar error_RDR)
1362 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1363 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1364 (nlHsApp (nlHsApp (nlHsApp
1365 (nlHsVar showsPrec_RDR)
1369 (nlHsVar append_RDR)
1370 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1371 (nlHsApp (nlHsApp (nlHsApp
1372 (nlHsVar showsPrec_RDR)
1375 (nlHsLit (mkHsString ")"))))))
1377 parenify e@(L _ (HsVar _)) = e
1378 parenify e = mkHsPar e
1380 -- genOpApp wraps brackets round the operator application, so that the
1381 -- renamer won't subsequently try to re-associate it.
1382 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1386 getSrcSpan = srcLocSpan . getSrcLoc
1390 a_RDR = mkVarUnqual FSLIT("a")
1391 b_RDR = mkVarUnqual FSLIT("b")
1392 c_RDR = mkVarUnqual FSLIT("c")
1393 d_RDR = mkVarUnqual FSLIT("d")
1394 k_RDR = mkVarUnqual FSLIT("k")
1395 z_RDR = mkVarUnqual FSLIT("z")
1396 ah_RDR = mkVarUnqual FSLIT("a#")
1397 bh_RDR = mkVarUnqual FSLIT("b#")
1398 ch_RDR = mkVarUnqual FSLIT("c#")
1399 dh_RDR = mkVarUnqual FSLIT("d#")
1400 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1401 rangeSize_RDR = mkVarUnqual FSLIT("rangeSize")
1403 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1404 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1405 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1407 a_Expr = nlHsVar a_RDR
1408 b_Expr = nlHsVar b_RDR
1409 c_Expr = nlHsVar c_RDR
1410 ltTag_Expr = nlHsVar ltTag_RDR
1411 eqTag_Expr = nlHsVar eqTag_RDR
1412 gtTag_Expr = nlHsVar gtTag_RDR
1413 false_Expr = nlHsVar false_RDR
1414 true_Expr = nlHsVar true_RDR
1416 a_Pat = nlVarPat a_RDR
1417 b_Pat = nlVarPat b_RDR
1418 c_Pat = nlVarPat c_RDR
1419 d_Pat = nlVarPat d_RDR
1421 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1422 -- Generates Orig s RdrName, for the binding positions
1423 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1424 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1425 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1427 mk_tc_deriv_name tycon str
1428 = mkDerivedRdrName tc_name mk_occ
1430 tc_name = tyConName tycon
1431 mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1433 new_str = str ++ occNameString tc_occ ++ "#"
1436 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1437 PrelNames, so PrelNames can't import PrimOp.
1440 primOpRdrName op = getRdrName (primOpId op)
1442 minusInt_RDR = primOpRdrName IntSubOp
1443 eqInt_RDR = primOpRdrName IntEqOp
1444 ltInt_RDR = primOpRdrName IntLtOp
1445 geInt_RDR = primOpRdrName IntGeOp
1446 leInt_RDR = primOpRdrName IntLeOp
1447 tagToEnum_RDR = primOpRdrName TagToEnumOp
1449 error_RDR = getRdrName eRROR_ID