2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcGenDeriv]{Generating derived instance declarations}
6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
7 ``official'' interface to deriving-related things.
9 This is where we do all the grimy bindings' generation.
22 gen_tag_n_con_monobind,
24 con2tag_RDR, tag2con_RDR, maxtag_RDR,
29 #include "HsVersions.h"
31 import HsSyn ( Pat(..), HsConDetails(..), HsExpr(..), MonoBinds(..),
32 Match(..), GRHSs(..), Stmt(..), HsLit(..),
33 HsBinds(..), HsType(..), HsStmtContext(..),
34 unguardedRHS, mkSimpleMatch, mkMonoBind, andMonoBindList, placeHolderType
36 import RdrName ( RdrName, mkUnqual, nameRdrName, getRdrName )
37 import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
38 import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
42 import FieldLabel ( fieldLabelName )
43 import DataCon ( isNullaryDataCon, dataConTag,
44 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
47 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
48 occNameUserString, varName,
50 isDataSymOcc, isSymOcc
53 import HscTypes ( FixityEnv, lookupFixity )
54 import PrelNames -- Lots of Names
55 import PrimOp -- Lots of Names
56 import SrcLoc ( generatedSrcLoc, SrcLoc )
57 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
58 maybeTyConSingleCon, tyConFamilySize, tyConTyVars
60 import TcType ( isUnLiftedType, tcEqType, Type )
61 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy,
62 floatPrimTy, doublePrimTy
64 import Util ( zipWithEqual, isSingleton,
65 zipWith3Equal, nOfThem, zipEqual )
66 import Panic ( panic, assertPanic )
67 import Char ( ord, isAlpha )
69 import List ( partition, intersperse )
75 %************************************************************************
77 \subsection{Generating code, by derivable class}
79 %************************************************************************
81 %************************************************************************
83 \subsubsection{Generating @Eq@ instance declarations}
85 %************************************************************************
87 Here are the heuristics for the code we generate for @Eq@:
90 Let's assume we have a data type with some (possibly zero) nullary
91 data constructors and some ordinary, non-nullary ones (the rest,
92 also possibly zero of them). Here's an example, with both \tr{N}ullary
93 and \tr{O}rdinary data cons.
95 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
99 For the ordinary constructors (if any), we emit clauses to do The
103 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
104 (==) (O2 a1) (O2 a2) = a1 == a2
105 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
108 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
109 \tr{a2} are \tr{Float#}s, then we have to generate
111 case (a1 `eqFloat#` a2) of
114 for that particular test.
117 If there are any nullary constructors, we emit a catch-all clause of
121 (==) a b = case (con2tag_Foo a) of { a# ->
122 case (con2tag_Foo b) of { b# ->
123 case (a# ==# b#) of {
128 If there aren't any nullary constructors, we emit a simpler
135 For the @(/=)@ method, we normally just use the default method.
137 If the type is an enumeration type, we could/may/should? generate
138 special code that calls @con2tag_Foo@, much like for @(==)@ shown
142 We thought about doing this: If we're also deriving @Ord@ for this
145 instance ... Eq (Foo ...) where
146 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
147 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
149 However, that requires that \tr{Ord <whatever>} was put in the context
150 for the instance decl, which it probably wasn't, so the decls
151 produced don't get through the typechecker.
155 deriveEq :: RdrName -- Class
156 -> RdrName -- Type constructor
157 -> [ (RdrName, [RdrType]) ] -- Constructors
158 -> (RdrContext, -- Context for the inst decl
159 [RdrBind], -- Binds in the inst decl
160 [RdrBind]) -- Extra value bindings outside
162 deriveEq clas tycon constrs
163 = (context, [eq_bind, ne_bind], [])
165 context = [(clas, [ty]) | (_, tys) <- constrs, ty <- tys]
168 (nullary_cons, non_nullary_cons) = partition is_nullary constrs
169 is_nullary (_, args) = null args
172 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
176 tycon_loc = getSrcLoc tycon
177 (nullary_cons, nonnullary_cons)
178 | isNewTyCon tycon = ([], tyConDataCons tycon)
179 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
182 = if (null nullary_cons) then
183 case maybeTyConSingleCon tycon of
185 Nothing -> -- if cons don't match, then False
186 [([wildPat, wildPat], false_Expr)]
187 else -- calc. and compare the tags
189 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
190 (genOpApp (HsVar ah_RDR) eqInt_RDR (HsVar bh_RDR)))]
192 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
194 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
195 HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
197 ------------------------------------------------------------------
200 con1_pat = mkConPat data_con_RDR as_needed
201 con2_pat = mkConPat data_con_RDR bs_needed
203 data_con_RDR = getRdrName data_con
204 con_arity = length tys_needed
205 as_needed = take con_arity as_RDRs
206 bs_needed = take con_arity bs_RDRs
207 tys_needed = dataConOrigArgTys data_con
209 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
211 nested_eq_expr [] [] [] = true_Expr
212 nested_eq_expr tys as bs
213 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
215 nested_eq ty a b = HsPar (eq_Expr ty (HsVar a) (HsVar b))
218 %************************************************************************
220 \subsubsection{Generating @Ord@ instance declarations}
222 %************************************************************************
224 For a derived @Ord@, we concentrate our attentions on @compare@
226 compare :: a -> a -> Ordering
227 data Ordering = LT | EQ | GT deriving ()
230 We will use the same example data type as above:
232 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
237 We do all the other @Ord@ methods with calls to @compare@:
239 instance ... (Ord <wurble> <wurble>) where
240 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
241 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
242 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
243 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
245 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
246 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
248 -- compare to come...
252 @compare@ always has two parts. First, we use the compared
253 data-constructors' tags to deal with the case of different
256 compare a b = case (con2tag_Foo a) of { a# ->
257 case (con2tag_Foo b) of { b# ->
258 case (a# ==# b#) of {
260 False -> case (a# <# b#) of
265 cmp_eq = ... to come ...
269 We are only left with the ``help'' function @cmp_eq@, to deal with
270 comparing data constructors with the same tag.
272 For the ordinary constructors (if any), we emit the sorta-obvious
273 compare-style stuff; for our example:
275 cmp_eq (O1 a1 b1) (O1 a2 b2)
276 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
278 cmp_eq (O2 a1) (O2 a2)
281 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
282 = case (compare a1 a2) of {
285 EQ -> case compare b1 b2 of {
293 Again, we must be careful about unlifted comparisons. For example,
294 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
298 cmp_eq lt eq gt (O2 a1) (O2 a2)
300 -- or maybe the unfolded equivalent
304 For the remaining nullary constructors, we already know that the
311 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
315 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
318 = compare -- `AndMonoBinds` compare
319 -- The default declaration in PrelBase handles this
321 tycon_loc = getSrcLoc tycon
322 --------------------------------------------------------------------
323 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
324 [a_Pat, b_Pat] [cmp_eq] compare_rhs
326 | single_con_type = cmp_eq_Expr a_Expr b_Expr
328 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
329 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
330 (cmp_eq_Expr a_Expr b_Expr) -- True case
331 -- False case; they aren't equal
332 -- So we need to do a less-than comparison on the tags
333 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
335 tycon_data_cons = tyConDataCons tycon
336 single_con_type = isSingleton tycon_data_cons
337 (nullary_cons, nonnullary_cons)
338 | isNewTyCon tycon = ([], tyConDataCons tycon)
339 | otherwise = partition isNullaryDataCon tycon_data_cons
341 cmp_eq = mk_FunMonoBind tycon_loc cmp_eq_RDR cmp_eq_match
343 | isEnumerationTyCon tycon
344 -- We know the tags are equal, so if it's an enumeration TyCon,
345 -- then there is nothing left to do
346 -- Catch this specially to avoid warnings
347 -- about overlapping patterns from the desugarer,
348 -- and to avoid unnecessary pattern-matching
349 = [([wildPat,wildPat], eqTag_Expr)]
351 = map pats_etc nonnullary_cons ++
352 (if single_con_type then -- Omit wildcards when there's just one
353 [] -- constructor, to silence desugarer
355 [([wildPat, wildPat], default_rhs)])
359 = ([con1_pat, con2_pat],
360 nested_compare_expr tys_needed as_needed bs_needed)
362 con1_pat = mkConPat data_con_RDR as_needed
363 con2_pat = mkConPat data_con_RDR bs_needed
365 data_con_RDR = getRdrName data_con
366 con_arity = length tys_needed
367 as_needed = take con_arity as_RDRs
368 bs_needed = take con_arity bs_RDRs
369 tys_needed = dataConOrigArgTys data_con
371 nested_compare_expr [ty] [a] [b]
372 = careful_compare_Case ty eqTag_Expr (HsVar a) (HsVar b)
374 nested_compare_expr (ty:tys) (a:as) (b:bs)
375 = let eq_expr = nested_compare_expr tys as bs
376 in careful_compare_Case ty eq_expr (HsVar a) (HsVar b)
378 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
379 -- inexhaustive patterns
380 | otherwise = eqTag_Expr -- Some nullary constructors;
381 -- Tags are equal, no args => return EQ
384 %************************************************************************
386 \subsubsection{Generating @Enum@ instance declarations}
388 %************************************************************************
390 @Enum@ can only be derived for enumeration types. For a type
392 data Foo ... = N1 | N2 | ... | Nn
395 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
396 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
399 instance ... Enum (Foo ...) where
400 succ x = toEnum (1 + fromEnum x)
401 pred x = toEnum (fromEnum x - 1)
403 toEnum i = tag2con_Foo i
405 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
409 = case con2tag_Foo a of
410 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
413 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
417 = case con2tag_Foo a of { a# ->
418 case con2tag_Foo b of { b# ->
419 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
423 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
426 gen_Enum_binds :: TyCon -> RdrNameMonoBinds
429 = succ_enum `AndMonoBinds`
430 pred_enum `AndMonoBinds`
431 to_enum `AndMonoBinds`
432 enum_from `AndMonoBinds`
433 enum_from_then `AndMonoBinds`
436 tycon_loc = getSrcLoc tycon
437 occ_nm = getOccString tycon
440 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
441 untag_Expr tycon [(a_RDR, ah_RDR)] $
442 HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
443 mkHsVarApps mkInt_RDR [ah_RDR]])
444 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
445 (HsApp (HsVar (tag2con_RDR tycon))
446 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
451 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
452 untag_Expr tycon [(a_RDR, ah_RDR)] $
453 HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
454 mkHsVarApps mkInt_RDR [ah_RDR]])
455 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
456 (HsApp (HsVar (tag2con_RDR tycon))
457 (mkHsApps plus_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
458 HsLit (HsInt (-1))]))
462 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
463 HsIf (mkHsApps and_RDR
464 [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
465 mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
466 (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
467 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
471 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
472 untag_Expr tycon [(a_RDR, ah_RDR)] $
474 [HsVar (tag2con_RDR tycon),
475 HsPar (enum_from_to_Expr
476 (mkHsVarApps mkInt_RDR [ah_RDR])
477 (HsVar (maxtag_RDR tycon)))]
480 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
481 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
482 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
483 HsPar (enum_from_then_to_Expr
484 (mkHsVarApps mkInt_RDR [ah_RDR])
485 (mkHsVarApps mkInt_RDR [bh_RDR])
486 (HsIf (mkHsApps gt_RDR [mkHsVarApps mkInt_RDR [ah_RDR],
487 mkHsVarApps mkInt_RDR [bh_RDR]])
489 (HsVar (maxtag_RDR tycon))
493 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
494 untag_Expr tycon [(a_RDR, ah_RDR)] $
495 (mkHsVarApps mkInt_RDR [ah_RDR])
498 %************************************************************************
500 \subsubsection{Generating @Bounded@ instance declarations}
502 %************************************************************************
505 gen_Bounded_binds tycon
506 = if isEnumerationTyCon tycon then
507 min_bound_enum `AndMonoBinds` max_bound_enum
509 ASSERT(isSingleton data_cons)
510 min_bound_1con `AndMonoBinds` max_bound_1con
512 data_cons = tyConDataCons tycon
513 tycon_loc = getSrcLoc tycon
515 ----- enum-flavored: ---------------------------
516 min_bound_enum = mkVarMonoBind tycon_loc minBound_RDR (HsVar data_con_1_RDR)
517 max_bound_enum = mkVarMonoBind tycon_loc maxBound_RDR (HsVar data_con_N_RDR)
519 data_con_1 = head data_cons
520 data_con_N = last data_cons
521 data_con_1_RDR = getRdrName data_con_1
522 data_con_N_RDR = getRdrName data_con_N
524 ----- single-constructor-flavored: -------------
525 arity = dataConSourceArity data_con_1
527 min_bound_1con = mkVarMonoBind tycon_loc minBound_RDR $
528 mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
529 max_bound_1con = mkVarMonoBind tycon_loc maxBound_RDR $
530 mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
533 %************************************************************************
535 \subsubsection{Generating @Ix@ instance declarations}
537 %************************************************************************
539 Deriving @Ix@ is only possible for enumeration types and
540 single-constructor types. We deal with them in turn.
542 For an enumeration type, e.g.,
544 data Foo ... = N1 | N2 | ... | Nn
546 things go not too differently from @Enum@:
548 instance ... Ix (Foo ...) where
550 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
554 = case (con2tag_Foo a) of { a# ->
555 case (con2tag_Foo b) of { b# ->
556 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
561 then case (con2tag_Foo d -# con2tag_Foo a) of
563 else error "Ix.Foo.index: out of range"
567 p_tag = con2tag_Foo c
569 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
573 = case (con2tag_Foo a) of { a_tag ->
574 case (con2tag_Foo b) of { b_tag ->
575 case (con2tag_Foo c) of { c_tag ->
576 if (c_tag >=# a_tag) then
582 (modulo suitable case-ification to handle the unlifted tags)
584 For a single-constructor type (NB: this includes all tuples), e.g.,
586 data Foo ... = MkFoo a b Int Double c c
588 we follow the scheme given in Figure~19 of the Haskell~1.2 report
592 gen_Ix_binds :: TyCon -> RdrNameMonoBinds
595 = if isEnumerationTyCon tycon
599 tycon_str = getOccString tycon
600 tycon_loc = getSrcLoc tycon
602 --------------------------------------------------------------
603 enum_ixes = enum_range `AndMonoBinds`
604 enum_index `AndMonoBinds` enum_inRange
607 = mk_easy_FunMonoBind tycon_loc range_RDR
608 [TuplePat [a_Pat, b_Pat] Boxed] [] $
609 untag_Expr tycon [(a_RDR, ah_RDR)] $
610 untag_Expr tycon [(b_RDR, bh_RDR)] $
611 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
612 HsPar (enum_from_to_Expr
613 (mkHsVarApps mkInt_RDR [ah_RDR])
614 (mkHsVarApps mkInt_RDR [bh_RDR]))
617 = mk_easy_FunMonoBind tycon_loc index_RDR
618 [AsPat c_RDR (TuplePat [a_Pat, wildPat] Boxed),
620 HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
621 untag_Expr tycon [(a_RDR, ah_RDR)] (
622 untag_Expr tycon [(d_RDR, dh_RDR)] (
624 rhs = mkHsVarApps mkInt_RDR [c_RDR]
627 (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR))
628 [mkSimpleMatch [VarPat c_RDR] rhs placeHolderType tycon_loc]
632 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
637 = mk_easy_FunMonoBind tycon_loc inRange_RDR
638 [TuplePat [a_Pat, b_Pat] Boxed, c_Pat] [] (
639 untag_Expr tycon [(a_RDR, ah_RDR)] (
640 untag_Expr tycon [(b_RDR, bh_RDR)] (
641 untag_Expr tycon [(c_RDR, ch_RDR)] (
642 HsIf (genOpApp (HsVar ch_RDR) geInt_RDR (HsVar ah_RDR)) (
643 (genOpApp (HsVar ch_RDR) leInt_RDR (HsVar bh_RDR))
648 --------------------------------------------------------------
650 = single_con_range `AndMonoBinds`
651 single_con_index `AndMonoBinds`
655 = case maybeTyConSingleCon tycon of -- just checking...
656 Nothing -> panic "get_Ix_binds"
657 Just dc -> if (any isUnLiftedType (dataConOrigArgTys dc)) then
658 error ("ERROR: Can't derive Ix for a single-constructor type with primitive argument types: "++tycon_str)
662 con_arity = dataConSourceArity data_con
663 data_con_RDR = getRdrName data_con
665 as_needed = take con_arity as_RDRs
666 bs_needed = take con_arity bs_RDRs
667 cs_needed = take con_arity cs_RDRs
669 con_pat xs = mkConPat data_con_RDR xs
670 con_expr = mkHsVarApps data_con_RDR cs_needed
672 --------------------------------------------------------------
674 = mk_easy_FunMonoBind tycon_loc range_RDR
675 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed] [] $
676 mkHsDo ListComp stmts tycon_loc
678 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
680 [ResultStmt con_expr tycon_loc]
682 mk_qual a b c = BindStmt (VarPat c)
683 (HsApp (HsVar range_RDR)
684 (ExplicitTuple [HsVar a, HsVar b] Boxed))
689 = mk_easy_FunMonoBind tycon_loc index_RDR
690 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
691 con_pat cs_needed] [range_size] (
692 foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
694 mk_index multiply_by (l, u, i)
696 (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,
700 (HsApp (HsVar rangeSize_RDR)
701 (ExplicitTuple [HsVar l, HsVar u] Boxed))
702 ) times_RDR multiply_by
706 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
707 [TuplePat [a_Pat, b_Pat] Boxed] [] (
709 (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
711 ) plus_RDR (mkHsIntLit 1))
715 = mk_easy_FunMonoBind tycon_loc inRange_RDR
716 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
719 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
721 in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
725 %************************************************************************
727 \subsubsection{Generating @Read@ instance declarations}
729 %************************************************************************
739 instance Read T where
743 do x <- ReadP.step Read.readPrec
744 Symbol "%%" <- Lex.lex
745 y <- ReadP.step Read.readPrec
749 do Ident "T1" <- Lex.lex
751 Ident "f1" <- Lex.lex
753 x <- ReadP.reset Read.readPrec
755 return (T1 { f1 = x }))
758 do Ident "T2" <- Lex.lexP
759 x <- ReadP.step Read.readPrec
763 readListPrec = readListPrecDefault
764 readList = readListDefault
768 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
770 gen_Read_binds get_fixity tycon
771 = read_prec `AndMonoBinds` default_binds
773 -----------------------------------------------------------------------
775 = mkVarMonoBind loc readList_RDR (HsVar readListDefault_RDR)
777 mkVarMonoBind loc readListPrec_RDR (HsVar readListPrecDefault_RDR)
778 -----------------------------------------------------------------------
780 loc = getSrcLoc tycon
781 data_cons = tyConDataCons tycon
782 (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
784 read_prec = mkVarMonoBind loc readPrec_RDR
785 (HsApp (HsVar parens_RDR) read_cons)
787 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
788 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
791 = case nullary_cons of
793 [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
794 result_stmt con []] loc]
795 _ -> [HsApp (HsVar choose_RDR)
796 (ExplicitList placeHolderType (map mk_pair nullary_cons))]
798 mk_pair con = ExplicitTuple [HsLit (data_con_str con),
799 HsApp (HsVar returnM_RDR) (HsVar (getRdrName con))]
802 read_non_nullary_con data_con
803 = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
805 stmts | is_infix = infix_stmts
806 | length labels > 0 = lbl_stmts
807 | otherwise = prefix_stmts
809 prefix_stmts -- T a b c
810 = [bindLex (ident_pat (data_con_str data_con))]
811 ++ map read_arg as_needed
812 ++ [result_stmt data_con as_needed]
814 infix_stmts -- a %% b
816 bindLex (symbol_pat (data_con_str data_con)),
818 result_stmt data_con [a1,a2]]
820 lbl_stmts -- T { f1 = a, f2 = b }
821 = [bindLex (ident_pat (data_con_str data_con)),
823 ++ concat (intersperse [read_punc ","] field_stmts)
824 ++ [read_punc "}", result_stmt data_con as_needed]
826 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
828 con_arity = dataConSourceArity data_con
829 nullary_con = con_arity == 0
830 labels = dataConFieldLabels data_con
831 lab_fields = length labels
832 dc_nm = getName data_con
833 is_infix = isDataSymOcc (getOccName dc_nm)
834 as_needed = take con_arity as_RDRs
835 (a1:a2:_) = as_needed
836 prec = getPrec is_infix get_fixity dc_nm
838 ------------------------------------------------------------------------
840 ------------------------------------------------------------------------
841 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
842 bindLex pat = BindStmt pat (HsVar lexP_RDR) loc
843 result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
844 con_app c as = mkHsVarApps (getRdrName c) as
846 punc_pat s = ConPatIn punc_RDR (PrefixCon [LitPat (mkHsString s)]) -- Punc 'c'
847 ident_pat s = ConPatIn ident_RDR (PrefixCon [LitPat s]) -- Ident "foo"
848 symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s]) -- Symbol ">>"
850 data_con_str con = mkHsString (occNameUserString (getOccName con))
852 read_punc c = bindLex (punc_pat c)
853 read_arg a = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
855 read_field lbl a = read_lbl lbl ++
857 BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
859 -- When reading field labels we might encounter
864 read_lbl lbl | is_id_start (head lbl_str)
865 = [bindLex (ident_pat lbl_lit)]
868 bindLex (symbol_pat lbl_lit),
871 lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
872 lbl_lit = mkHsString lbl_str
873 is_id_start c = isAlpha c || c == '_'
877 %************************************************************************
879 \subsubsection{Generating @Show@ instance declarations}
881 %************************************************************************
887 data Tree a = Leaf a | Tree a :^: Tree a
889 instance (Show a) => Show (Tree a) where
891 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
893 showStr = showString "Leaf " . showsPrec (app_prec+1) m
895 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
897 showStr = showsPrec (up_prec+1) u .
899 showsPrec (up_prec+1) v
900 -- Note: right-associativity of :^: ignored
902 up_prec = 5 -- Precedence of :^:
903 app_prec = 10 -- Application has precedence one more than
904 -- the most tightly-binding operator
907 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
909 gen_Show_binds get_fixity tycon
910 = shows_prec `AndMonoBinds` show_list
912 tycon_loc = getSrcLoc tycon
913 -----------------------------------------------------------------------
914 show_list = mkVarMonoBind tycon_loc showList_RDR
915 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
916 -----------------------------------------------------------------------
917 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
920 | nullary_con = -- skip the showParen junk...
921 ASSERT(null bs_needed)
922 ([wildPat, con_pat], mk_showString_app con_str)
925 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
926 (HsPar (nested_compose_Expr show_thingies)))
928 data_con_RDR = getRdrName data_con
929 con_arity = dataConSourceArity data_con
930 bs_needed = take con_arity bs_RDRs
931 con_pat = mkConPat data_con_RDR bs_needed
932 nullary_con = con_arity == 0
933 labels = dataConFieldLabels data_con
934 lab_fields = length labels
935 record_syntax = lab_fields > 0
937 dc_nm = getName data_con
938 dc_occ_nm = getOccName data_con
939 con_str = occNameUserString dc_occ_nm
942 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
943 | record_syntax = mk_showString_app (con_str ++ " {") :
944 show_record_args ++ [mk_showString_app "}"]
945 | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
947 show_label l = mk_showString_app (the_name ++ " = ")
948 -- Note the spaces around the "=" sign. If we don't have them
949 -- then we get Foo { x=-1 } and the "=-" parses as a single
950 -- lexeme. Only the space after the '=' is necessary, but
951 -- it seems tidier to have them both sides.
953 occ_nm = getOccName (fieldLabelName l)
954 nm = occNameUserString occ_nm
956 is_op = isSymOcc occ_nm -- Legal, but rare.
958 | is_op = '(':nm ++ ")"
961 show_args = [ mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec), HsVar b]
963 (show_arg1:show_arg2:_) = show_args
964 show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
966 -- Assumption for record syntax: no of fields == no of labelled fields
967 -- (and in same order)
968 show_record_args = concat $
969 intersperse [mk_showString_app ", "] $
970 [ [show_label lbl, arg]
971 | (lbl,arg) <- zipEqual "gen_Show_binds"
975 is_infix = isDataSymOcc dc_occ_nm
976 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
977 arg_prec | record_syntax = 0 -- Record fields don't need parens
978 | otherwise = con_prec_plus_one
980 mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str))
984 getPrec :: Bool -> FixityEnv -> Name -> Integer
985 getPrec is_infix get_fixity nm
986 | not is_infix = appPrecedence
987 | otherwise = getPrecedence get_fixity nm
989 appPrecedence :: Integer
990 appPrecedence = fromIntegral maxPrecedence + 1
991 -- One more than the precedence of the most
992 -- tightly-binding operator
994 getPrecedence :: FixityEnv -> Name -> Integer
995 getPrecedence get_fixity nm
996 = case lookupFixity get_fixity nm of
997 Fixity x _ -> fromIntegral x
999 isLRAssoc :: FixityEnv -> Name -> (Bool, Bool)
1000 isLRAssoc get_fixity nm =
1001 case lookupFixity get_fixity nm of
1002 Fixity _ InfixN -> (False, False)
1003 Fixity _ InfixR -> (False, True)
1004 Fixity _ InfixL -> (True, False)
1008 %************************************************************************
1010 \subsection{Typeable}
1012 %************************************************************************
1020 instance (Typeable a, Typeable b) => Typeable (T a b) where
1021 typeOf _ = mkTypeRep (mkTyConRep "T")
1022 [typeOf (undefined::a),
1023 typeOf (undefined::b)]
1025 Notice the use of lexically scoped type variables.
1028 gen_Typeable_binds :: TyCon -> RdrNameMonoBinds
1029 gen_Typeable_binds tycon
1030 = mk_easy_FunMonoBind tycon_loc typeOf_RDR [wildPat] []
1031 (mkHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
1033 tycon_loc = getSrcLoc tycon
1034 tyvars = tyConTyVars tycon
1035 tycon_rep = HsVar mkTyConRep_RDR `HsApp` HsLit (mkHsString (showSDoc (ppr tycon)))
1036 arg_reps = ExplicitList placeHolderType (map mk tyvars)
1037 mk tyvar = HsApp (HsVar typeOf_RDR)
1038 (ExprWithTySig (HsVar undefined_RDR)
1039 (HsTyVar (getRdrName tyvar)))
1044 %************************************************************************
1048 %************************************************************************
1052 data T a b = T1 a b | T2
1056 instance (Data a, Data b) => Data (T a b) where
1057 gfoldl k z (T1 a b) = z T `k` a `k` b
1058 gfoldl k z T2 = z T2
1059 -- ToDo: add gmapT,Q,M, gfoldr
1061 gunfold k z _ (Constr "T1") = k (k (z T1))
1062 gunfold k z _ (Constr "T2") = z T2
1065 conOf (T1 _ _) = Constr "T1"
1066 conOf T2 = Constr "T2"
1068 consOf _ = [Constr "T1", Constr "T2"]
1070 ToDo: generate auxiliary bindings for the Constrs?
1073 gen_Data_binds :: TyCon -> RdrNameMonoBinds
1074 gen_Data_binds tycon
1075 = andMonoBindList [gfoldl_bind, gunfold_bind, conOf_bind, consOf_bind]
1077 tycon_loc = getSrcLoc tycon
1078 data_cons = tyConDataCons tycon
1081 gfoldl_bind = mk_FunMonoBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1082 gfoldl_eqn con = ([VarPat k_RDR, VarPat z_RDR, mkConPat con_name as_needed],
1083 foldl mk_k_app (HsVar z_RDR `HsApp` HsVar con_name) as_needed)
1086 con_name = getRdrName con
1087 as_needed = take (dataConSourceArity con) as_RDRs
1088 mk_k_app e v = HsPar (mkHsOpApp e k_RDR (HsVar v))
1090 ------------ gunfold
1091 gunfold_bind = mk_FunMonoBind tycon_loc gunfold_RDR (map gunfold_eqn data_cons ++ [catch_all])
1092 gunfold_eqn con = ([VarPat k_RDR, VarPat z_RDR, wildPat,
1093 ConPatIn constr_RDR (PrefixCon [LitPat (mk_constr_string con)])],
1094 apN (dataConSourceArity con)
1095 (\e -> HsVar k_RDR `HsApp` e)
1096 (z_Expr `HsApp` HsVar (getRdrName con)))
1097 catch_all = ([wildPat, wildPat, VarPat e_RDR, wildPat], HsVar e_RDR)
1098 mk_constr_string con = mkHsString (occNameUserString (getOccName con))
1101 conOf_bind = mk_FunMonoBind tycon_loc conOf_RDR (map conOf_eqn data_cons)
1102 conOf_eqn con = ([mkWildConPat con], mk_constr con)
1105 consOf_bind = mk_easy_FunMonoBind tycon_loc consOf_RDR [wildPat] []
1106 (ExplicitList placeHolderType (map mk_constr data_cons))
1107 mk_constr con = HsVar constr_RDR `HsApp` (HsLit (mk_constr_string con))
1110 apN :: Int -> (a -> a) -> a -> a
1112 apN n k z = apN (n-1) k (k z)
1115 %************************************************************************
1117 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1119 %************************************************************************
1124 con2tag_Foo :: Foo ... -> Int#
1125 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1126 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1129 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1134 = GenCon2Tag | GenTag2Con | GenMaxTag
1136 gen_tag_n_con_monobind
1137 :: (RdrName, -- (proto)Name for the thing in question
1138 TyCon, -- tycon in question
1142 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1143 | lots_of_constructors
1144 = mk_FunMonoBind loc rdr_name [([], get_tag_rhs)]
1147 = mk_FunMonoBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1150 loc = getSrcLoc tycon
1152 -- Give a signature to the bound variable, so
1153 -- that the case expression generated by getTag is
1154 -- monomorphic. In the push-enter model we get better code.
1155 get_tag_rhs = ExprWithTySig
1156 (HsLam (mk_match loc [VarPat a_RDR]
1157 (HsApp getTag_Expr a_Expr)
1159 (HsForAllTy Nothing [] con2tag_ty)
1160 -- Nothing => implicit quantification
1162 con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon))
1163 [HsTyVar (getRdrName tv) | tv <- tyConTyVars tycon]
1165 HsTyVar (getRdrName intPrimTyConName)
1167 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1169 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1170 mk_stuff con = ([mkWildConPat con],
1171 HsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1173 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1174 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1175 [([mkConPat mkInt_RDR [a_RDR]],
1176 ExprWithTySig (HsApp tagToEnum_Expr a_Expr)
1177 (HsTyVar (getRdrName tycon)))]
1179 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1180 = mkVarMonoBind (getSrcLoc tycon) rdr_name
1181 (HsApp (HsVar mkInt_RDR) (HsLit (HsIntPrim max_tag)))
1183 max_tag = case (tyConDataCons tycon) of
1184 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1188 %************************************************************************
1190 \subsection{Utility bits for generating bindings}
1192 %************************************************************************
1194 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1196 fun pat1 pat2 ... patN = expr where binds
1199 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1200 multi-clause definitions; it generates:
1202 fun p1a p1b ... p1N = e1
1203 fun p2a p2b ... p2N = e2
1205 fun pMa pMb ... pMN = eM
1209 mkVarMonoBind :: SrcLoc -> RdrName -> RdrNameHsExpr -> RdrNameMonoBinds
1210 mkVarMonoBind loc var rhs = mk_easy_FunMonoBind loc var [] [] rhs
1212 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1213 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1216 mk_easy_FunMonoBind loc fun pats binds expr
1217 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1219 mk_easy_Match loc pats binds expr
1220 = mk_match loc pats expr (mkMonoBind Recursive (andMonoBindList binds))
1221 -- The renamer expects everything in its input to be a
1222 -- "recursive" MonoBinds, and it is its job to sort things out
1225 mk_FunMonoBind :: SrcLoc -> RdrName
1226 -> [([RdrNamePat], RdrNameHsExpr)]
1229 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1230 mk_FunMonoBind loc fun pats_and_exprs
1231 = FunMonoBind fun False{-not infix-}
1232 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1235 mk_match loc pats expr binds
1236 = Match (map paren pats) Nothing
1237 (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1239 paren p@(VarPat _) = p
1240 paren other_p = ParPat other_p
1244 mkHsApps f xs = foldl HsApp (HsVar f) xs
1245 mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs)
1247 mkHsIntLit n = HsLit (HsInt n)
1248 mkHsString s = HsString (mkFastString s)
1249 mkHsChar c = HsChar (ord c)
1251 mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars))
1252 mkNullaryConPat con = ConPatIn con (PrefixCon [])
1253 mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat))
1256 ToDo: Better SrcLocs.
1260 RdrNameHsExpr -- What to do for equality
1261 -> RdrNameHsExpr -> RdrNameHsExpr
1263 careful_compare_Case :: -- checks for primitive types...
1265 -> RdrNameHsExpr -- What to do for equality
1266 -> RdrNameHsExpr -> RdrNameHsExpr
1269 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1270 -- Was: compare_gen_Case cmp_eq_RDR
1272 compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR
1273 = HsApp (HsApp (HsVar compare_RDR) a) b -- Simple case
1274 compare_gen_Case eq a b -- General case
1275 = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-}
1276 [mkSimpleMatch [mkNullaryConPat ltTag_RDR] ltTag_Expr placeHolderType generatedSrcLoc,
1277 mkSimpleMatch [mkNullaryConPat eqTag_RDR] eq placeHolderType generatedSrcLoc,
1278 mkSimpleMatch [mkNullaryConPat gtTag_RDR] gtTag_Expr placeHolderType generatedSrcLoc]
1281 careful_compare_Case ty eq a b
1282 | not (isUnLiftedType ty) =
1283 compare_gen_Case eq a b
1285 -- we have to do something special for primitive things...
1286 HsIf (genOpApp a relevant_eq_op b)
1288 (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc)
1291 relevant_eq_op = assoc_ty_id eq_op_tbl ty
1292 relevant_lt_op = assoc_ty_id lt_op_tbl ty
1294 assoc_ty_id tyids ty
1295 = if null res then panic "assoc_ty"
1298 res = [id | (ty',id) <- tyids, ty `tcEqType` ty']
1301 [(charPrimTy, eqChar_RDR)
1302 ,(intPrimTy, eqInt_RDR)
1303 ,(wordPrimTy, eqWord_RDR)
1304 ,(addrPrimTy, eqAddr_RDR)
1305 ,(floatPrimTy, eqFloat_RDR)
1306 ,(doublePrimTy, eqDouble_RDR)
1310 [(charPrimTy, ltChar_RDR)
1311 ,(intPrimTy, ltInt_RDR)
1312 ,(wordPrimTy, ltWord_RDR)
1313 ,(addrPrimTy, ltAddr_RDR)
1314 ,(floatPrimTy, ltFloat_RDR)
1315 ,(doublePrimTy, ltDouble_RDR)
1318 -----------------------------------------------------------------------
1320 and_Expr, append_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1322 and_Expr a b = genOpApp a and_RDR b
1323 append_Expr a b = genOpApp a append_RDR b
1325 -----------------------------------------------------------------------
1327 eq_Expr :: Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1328 eq_Expr ty a b = genOpApp a eq_op b
1331 | not (isUnLiftedType ty) = eq_RDR
1333 -- we have to do something special for primitive things...
1334 assoc_ty_id eq_op_tbl ty
1339 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1340 untag_Expr tycon [] expr = expr
1341 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1342 = HsCase (HsPar (HsApp (con2tag_Expr tycon) (HsVar untag_this))) {-of-}
1343 [mkSimpleMatch [VarPat put_tag_here] (untag_Expr tycon more expr) placeHolderType generatedSrcLoc]
1346 cmp_tags_Expr :: RdrName -- Comparison op
1347 -> RdrName -> RdrName -- Things to compare
1348 -> RdrNameHsExpr -- What to return if true
1349 -> RdrNameHsExpr -- What to return if false
1352 cmp_tags_Expr op a b true_case false_case
1353 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1356 :: RdrNameHsExpr -> RdrNameHsExpr
1358 enum_from_then_to_Expr
1359 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1362 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1363 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1366 :: RdrNameHsExpr -> RdrNameHsExpr
1369 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1371 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1373 nested_compose_Expr [e] = parenify e
1374 nested_compose_Expr (e:es)
1375 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1377 -- impossible_Expr is used in case RHSs that should never happen.
1378 -- We generate these to keep the desugarer from complaining that they *might* happen!
1379 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv")))
1381 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1382 -- method. It is currently only used by Enum.{succ,pred}
1383 illegal_Expr meth tp msg =
1384 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg))))
1386 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1387 -- to include the value of a_RDR in the error string.
1388 illegal_toEnum_tag tp maxtag =
1389 HsApp (HsVar error_RDR)
1390 (HsApp (HsApp (HsVar append_RDR)
1391 (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag (")))))
1392 (HsApp (HsApp (HsApp
1393 (HsVar showsPrec_RDR)
1398 (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,"))))
1399 (HsApp (HsApp (HsApp
1400 (HsVar showsPrec_RDR)
1403 (HsLit (HsString (mkFastString ")")))))))
1405 parenify e@(HsVar _) = e
1406 parenify e = HsPar e
1408 -- genOpApp wraps brackets round the operator application, so that the
1409 -- renamer won't subsequently try to re-associate it.
1410 -- For some reason the renamer doesn't reassociate it right, and I can't
1411 -- be bothered to find out why just now.
1413 genOpApp e1 op e2 = mkHsOpApp e1 op e2
1417 varUnqual n = mkUnqual OccName.varName n
1419 zz_a_RDR = varUnqual FSLIT("_a")
1420 a_RDR = varUnqual FSLIT("a")
1421 b_RDR = varUnqual FSLIT("b")
1422 c_RDR = varUnqual FSLIT("c")
1423 d_RDR = varUnqual FSLIT("d")
1424 e_RDR = varUnqual FSLIT("e")
1425 k_RDR = varUnqual FSLIT("k")
1426 z_RDR = varUnqual FSLIT("z") :: RdrName
1427 ah_RDR = varUnqual FSLIT("a#")
1428 bh_RDR = varUnqual FSLIT("b#")
1429 ch_RDR = varUnqual FSLIT("c#")
1430 dh_RDR = varUnqual FSLIT("d#")
1431 cmp_eq_RDR = varUnqual FSLIT("cmp_eq")
1432 rangeSize_RDR = varUnqual FSLIT("rangeSize")
1434 as_RDRs = [ varUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1435 bs_RDRs = [ varUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1436 cs_RDRs = [ varUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1438 zz_a_Expr = HsVar zz_a_RDR
1439 a_Expr = HsVar a_RDR
1440 b_Expr = HsVar b_RDR
1441 c_Expr = HsVar c_RDR
1442 d_Expr = HsVar d_RDR
1443 z_Expr = HsVar z_RDR
1444 ltTag_Expr = HsVar ltTag_RDR
1445 eqTag_Expr = HsVar eqTag_RDR
1446 gtTag_Expr = HsVar gtTag_RDR
1447 false_Expr = HsVar false_RDR
1448 true_Expr = HsVar true_RDR
1450 getTag_Expr = HsVar getTag_RDR
1451 tagToEnum_Expr = HsVar tagToEnum_RDR
1452 con2tag_Expr tycon = HsVar (con2tag_RDR tycon)
1454 wildPat = WildPat placeHolderType
1455 zz_a_Pat = VarPat zz_a_RDR
1456 a_Pat = VarPat a_RDR
1457 b_Pat = VarPat b_RDR
1458 c_Pat = VarPat c_RDR
1459 d_Pat = VarPat d_RDR
1461 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1463 con2tag_RDR tycon = varUnqual (mkFastString ("con2tag_" ++ occNameString (getOccName tycon) ++ "#"))
1464 tag2con_RDR tycon = varUnqual (mkFastString ("tag2con_" ++ occNameString (getOccName tycon) ++ "#"))
1465 maxtag_RDR tycon = varUnqual (mkFastString ("maxtag_" ++ occNameString (getOccName tycon) ++ "#"))
1468 RdrNames for PrimOps. Can't be done in PrelNames, because PrimOp imports
1469 PrelNames, so PrelNames can't import PrimOp.
1472 minusInt_RDR = nameRdrName minusIntName
1473 eqInt_RDR = nameRdrName eqIntName
1474 ltInt_RDR = nameRdrName ltIntName
1475 geInt_RDR = nameRdrName geIntName
1476 leInt_RDR = nameRdrName leIntName
1477 eqChar_RDR = nameRdrName eqCharName
1478 eqWord_RDR = nameRdrName eqWordName
1479 eqAddr_RDR = nameRdrName eqAddrName
1480 eqFloat_RDR = nameRdrName eqFloatName
1481 eqDouble_RDR = nameRdrName eqDoubleName
1482 ltChar_RDR = nameRdrName ltCharName
1483 ltWord_RDR = nameRdrName ltWordName
1484 ltAddr_RDR = nameRdrName ltAddrName
1485 ltFloat_RDR = nameRdrName ltFloatName
1486 ltDouble_RDR = nameRdrName ltDoubleName
1487 tagToEnum_RDR = nameRdrName tagToEnumName