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, tyConArity,
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 Typeable2 T where
997 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
999 We are passed the Typeable2 class as well as T
1002 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1003 gen_Typeable_binds tycon
1005 mk_easy_FunBind tycon_loc
1006 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1008 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1010 tycon_loc = getSrcSpan tycon
1011 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1013 mk_typeOf_RDR :: TyCon -> RdrName
1014 -- Use the arity of the TyCon to make the right typeOfn function
1015 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_Name (mkFastString ("typeOf" ++ suffix))
1017 arity = tyConArity tycon
1018 suffix | arity == 0 = ""
1019 | otherwise = show arity
1024 %************************************************************************
1028 %************************************************************************
1032 data T a b = T1 a b | T2
1036 $cT1 = mkDataCon $dT "T1" Prefix
1037 $cT2 = mkDataCon $dT "T2" Prefix
1038 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1039 -- the [] is for field labels.
1041 instance (Data a, Data b) => Data (T a b) where
1042 gfoldl k z (T1 a b) = z T `k` a `k` b
1043 gfoldl k z T2 = z T2
1044 -- ToDo: add gmapT,Q,M, gfoldr
1046 fromConstr c = case conIndex c of
1047 I# 1# -> T1 undefined undefined
1050 toConstr (T1 _ _) = $cT1
1056 gen_Data_binds :: FixityEnv
1058 -> (LHsBinds RdrName, -- The method bindings
1059 LHsBinds RdrName) -- Auxiliary bindings
1060 gen_Data_binds fix_env tycon
1061 = (listToBag [gfoldl_bind, fromCon_bind, toCon_bind, dataTypeOf_bind],
1062 -- Auxiliary definitions: the data type and constructors
1063 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1065 tycon_loc = getSrcSpan tycon
1066 tycon_name = tyConName tycon
1067 data_cons = tyConDataCons tycon
1070 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1071 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1072 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1075 con_name = getRdrName con
1076 as_needed = take (dataConSourceArity con) as_RDRs
1077 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1079 ------------ fromConstr
1080 fromCon_bind = mk_FunBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)]
1081 from_con_rhs = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1082 (map from_con_alt data_cons)
1083 from_con_alt dc = mkSimpleHsAlt (nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger (dataConTag dc)))])
1084 (nlHsVarApps (getRdrName dc)
1085 (replicate (dataConSourceArity dc) undefined_RDR))
1087 ------------ toConstr
1088 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1089 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1091 ------------ dataTypeOf
1092 dataTypeOf_bind = mk_easy_FunBind
1097 (nlHsVar data_type_name)
1101 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1102 datatype_bind = mkVarBind
1105 ( nlHsVar mkDataType_RDR
1106 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1107 `nlHsApp` nlList constrs
1109 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1112 ------------ $cT1 etc
1113 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1114 mk_con_bind dc = mkVarBind
1117 (nlHsApps mkConstr_RDR (constr_args dc))
1119 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1120 nlHsVar data_type_name, -- DataType
1121 nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name
1122 nlList labels, -- Field labels
1123 nlHsVar fixity] -- Fixity
1125 labels = map (nlHsLit . mkHsString . getOccString . fieldLabelName)
1126 (dataConFieldLabels dc)
1127 dc_occ = getOccName dc
1128 is_infix = isDataSymOcc dc_occ
1129 fixity | is_infix = infix_RDR
1130 | otherwise = prefix_RDR
1132 gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl")
1133 fromConstr_RDR = varQual_RDR gENERICS_Name FSLIT("fromConstr")
1134 toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr")
1135 dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
1136 mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr")
1137 mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
1138 conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("constrIndex")
1139 prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix")
1140 infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix")
1143 %************************************************************************
1145 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1147 %************************************************************************
1152 con2tag_Foo :: Foo ... -> Int#
1153 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1154 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1157 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1162 = GenCon2Tag | GenTag2Con | GenMaxTag
1164 gen_tag_n_con_monobind
1165 :: ( RdrName, -- (proto)Name for the thing in question
1166 TyCon, -- tycon in question
1170 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1171 | lots_of_constructors
1172 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1175 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1178 tycon_loc = getSrcSpan tycon
1180 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1181 -- We can't use gerRdrName because that makes an Exact RdrName
1182 -- and we can't put them in the LocalRdrEnv
1184 -- Give a signature to the bound variable, so
1185 -- that the case expression generated by getTag is
1186 -- monomorphic. In the push-enter model we get better code.
1187 get_tag_rhs = noLoc $ ExprWithTySig
1188 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1189 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1190 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1192 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1195 nlHsTyVar (getRdrName intPrimTyCon)
1197 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1199 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1200 mk_stuff con = ([nlWildConPat con],
1201 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1203 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1204 = mk_FunBind (getSrcSpan tycon) rdr_name
1205 [([nlConVarPat intDataCon_RDR [a_RDR]],
1206 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1207 (nlHsTyVar (getRdrName tycon))))]
1209 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1210 = mkVarBind (getSrcSpan tycon) rdr_name
1211 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1213 max_tag = case (tyConDataCons tycon) of
1214 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1218 %************************************************************************
1220 \subsection{Utility bits for generating bindings}
1222 %************************************************************************
1225 ToDo: Better SrcLocs.
1229 LHsExpr RdrName -- What to do for equality
1230 -> LHsExpr RdrName -> LHsExpr RdrName
1232 careful_compare_Case :: -- checks for primitive types...
1233 TyCon -- The tycon we are deriving for
1235 -> LHsExpr RdrName -- What to do for equality
1236 -> LHsExpr RdrName -> LHsExpr RdrName
1239 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1240 -- Was: compare_gen_Case cmp_eq_RDR
1242 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1243 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1244 compare_gen_Case eq a b -- General case
1245 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1246 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1247 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1248 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1250 careful_compare_Case tycon ty eq a b
1251 | not (isUnLiftedType ty)
1252 = compare_gen_Case eq a b
1253 | otherwise -- We have to do something special for primitive things...
1254 = nlHsIf (genOpApp a relevant_eq_op b)
1256 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1258 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1259 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1262 box_if_necy :: String -- The class involved
1263 -> TyCon -- The tycon involved
1264 -> LHsExpr RdrName -- The argument
1265 -> Type -- The argument type
1266 -> LHsExpr RdrName -- Boxed version of the arg
1267 box_if_necy cls_str tycon arg arg_ty
1268 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1271 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1273 assoc_ty_id :: String -- The class involved
1274 -> TyCon -- The tycon involved
1275 -> [(Type,a)] -- The table
1277 -> a -- The result of the lookup
1278 assoc_ty_id cls_str tycon tbl ty
1279 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1280 text "for primitive type" <+> ppr ty)
1281 | otherwise = head res
1283 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1285 eq_op_tbl :: [(Type, PrimOp)]
1287 [(charPrimTy, CharEqOp)
1288 ,(intPrimTy, IntEqOp)
1289 ,(wordPrimTy, WordEqOp)
1290 ,(addrPrimTy, AddrEqOp)
1291 ,(floatPrimTy, FloatEqOp)
1292 ,(doublePrimTy, DoubleEqOp)
1295 lt_op_tbl :: [(Type, PrimOp)]
1297 [(charPrimTy, CharLtOp)
1298 ,(intPrimTy, IntLtOp)
1299 ,(wordPrimTy, WordLtOp)
1300 ,(addrPrimTy, AddrLtOp)
1301 ,(floatPrimTy, FloatLtOp)
1302 ,(doublePrimTy, DoubleLtOp)
1306 [(charPrimTy, getRdrName charDataCon)
1307 ,(intPrimTy, getRdrName intDataCon)
1308 ,(wordPrimTy, wordDataCon_RDR)
1309 ,(addrPrimTy, addrDataCon_RDR)
1310 ,(floatPrimTy, getRdrName floatDataCon)
1311 ,(doublePrimTy, getRdrName doubleDataCon)
1314 -----------------------------------------------------------------------
1316 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1317 and_Expr a b = genOpApp a and_RDR b
1319 -----------------------------------------------------------------------
1321 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1322 eq_Expr tycon ty a b = genOpApp a eq_op b
1325 | not (isUnLiftedType ty) = eq_RDR
1327 -- we have to do something special for primitive things...
1328 primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1332 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1333 untag_Expr tycon [] expr = expr
1334 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1335 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1336 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1338 cmp_tags_Expr :: RdrName -- Comparison op
1339 -> RdrName -> RdrName -- Things to compare
1340 -> LHsExpr RdrName -- What to return if true
1341 -> LHsExpr RdrName -- What to return if false
1344 cmp_tags_Expr op a b true_case false_case
1345 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1348 :: LHsExpr RdrName -> LHsExpr RdrName
1350 enum_from_then_to_Expr
1351 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1354 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1355 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1358 :: LHsExpr RdrName -> LHsExpr RdrName
1361 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1363 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1365 nested_compose_Expr [e] = parenify e
1366 nested_compose_Expr (e:es)
1367 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1369 -- impossible_Expr is used in case RHSs that should never happen.
1370 -- We generate these to keep the desugarer from complaining that they *might* happen!
1371 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1373 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1374 -- method. It is currently only used by Enum.{succ,pred}
1375 illegal_Expr meth tp msg =
1376 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1378 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1379 -- to include the value of a_RDR in the error string.
1380 illegal_toEnum_tag tp maxtag =
1381 nlHsApp (nlHsVar error_RDR)
1382 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1383 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1384 (nlHsApp (nlHsApp (nlHsApp
1385 (nlHsVar showsPrec_RDR)
1389 (nlHsVar append_RDR)
1390 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1391 (nlHsApp (nlHsApp (nlHsApp
1392 (nlHsVar showsPrec_RDR)
1395 (nlHsLit (mkHsString ")"))))))
1397 parenify e@(L _ (HsVar _)) = e
1398 parenify e = mkHsPar e
1400 -- genOpApp wraps brackets round the operator application, so that the
1401 -- renamer won't subsequently try to re-associate it.
1402 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1406 getSrcSpan = srcLocSpan . getSrcLoc
1410 a_RDR = mkVarUnqual FSLIT("a")
1411 b_RDR = mkVarUnqual FSLIT("b")
1412 c_RDR = mkVarUnqual FSLIT("c")
1413 d_RDR = mkVarUnqual FSLIT("d")
1414 k_RDR = mkVarUnqual FSLIT("k")
1415 z_RDR = mkVarUnqual FSLIT("z")
1416 ah_RDR = mkVarUnqual FSLIT("a#")
1417 bh_RDR = mkVarUnqual FSLIT("b#")
1418 ch_RDR = mkVarUnqual FSLIT("c#")
1419 dh_RDR = mkVarUnqual FSLIT("d#")
1420 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1421 rangeSize_RDR = mkVarUnqual FSLIT("rangeSize")
1423 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1424 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1425 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1427 a_Expr = nlHsVar a_RDR
1428 b_Expr = nlHsVar b_RDR
1429 c_Expr = nlHsVar c_RDR
1430 ltTag_Expr = nlHsVar ltTag_RDR
1431 eqTag_Expr = nlHsVar eqTag_RDR
1432 gtTag_Expr = nlHsVar gtTag_RDR
1433 false_Expr = nlHsVar false_RDR
1434 true_Expr = nlHsVar true_RDR
1436 a_Pat = nlVarPat a_RDR
1437 b_Pat = nlVarPat b_RDR
1438 c_Pat = nlVarPat c_RDR
1439 d_Pat = nlVarPat d_RDR
1441 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1442 -- Generates Orig s RdrName, for the binding positions
1443 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1444 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1445 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1447 mk_tc_deriv_name tycon str
1448 = mkDerivedRdrName tc_name mk_occ
1450 tc_name = tyConName tycon
1451 mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1453 new_str = str ++ occNameString tc_occ ++ "#"
1456 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1457 PrelNames, so PrelNames can't import PrimOp.
1460 primOpRdrName op = getRdrName (primOpId op)
1462 minusInt_RDR = primOpRdrName IntSubOp
1463 eqInt_RDR = primOpRdrName IntEqOp
1464 ltInt_RDR = primOpRdrName IntLtOp
1465 geInt_RDR = primOpRdrName IntGeOp
1466 leInt_RDR = primOpRdrName IntLeOp
1467 tagToEnum_RDR = primOpRdrName TagToEnumOp
1469 error_RDR = getRdrName eRROR_ID