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 DataCon ( isNullarySrcDataCon, dataConTag,
36 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
37 DataCon, dataConName, dataConIsInfix,
39 import Name ( getOccString, getSrcLoc, Name, NamedThing(..) )
41 import HscTypes ( FixityEnv, lookupFixity )
44 import MkId ( eRROR_ID )
45 import PrimOp ( PrimOp(..) )
46 import SrcLoc ( Located(..), noLoc, srcLocSpan )
47 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity,
48 maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName
50 import TcType ( isUnLiftedType, tcEqType, Type )
51 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
53 import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon,
54 intDataCon_RDR, true_RDR, false_RDR )
55 import Util ( zipWithEqual, isSingleton,
56 zipWith3Equal, nOfThem, zipEqual )
58 import List ( partition, intersperse )
65 %************************************************************************
67 \subsection{Generating code, by derivable class}
69 %************************************************************************
71 %************************************************************************
73 \subsubsection{Generating @Eq@ instance declarations}
75 %************************************************************************
77 Here are the heuristics for the code we generate for @Eq@:
80 Let's assume we have a data type with some (possibly zero) nullary
81 data constructors and some ordinary, non-nullary ones (the rest,
82 also possibly zero of them). Here's an example, with both \tr{N}ullary
83 and \tr{O}rdinary data cons.
85 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
89 For the ordinary constructors (if any), we emit clauses to do The
93 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
94 (==) (O2 a1) (O2 a2) = a1 == a2
95 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
98 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
99 \tr{a2} are \tr{Float#}s, then we have to generate
101 case (a1 `eqFloat#` a2) of
104 for that particular test.
107 If there are any nullary constructors, we emit a catch-all clause of
111 (==) a b = case (con2tag_Foo a) of { a# ->
112 case (con2tag_Foo b) of { b# ->
113 case (a# ==# b#) of {
118 If there aren't any nullary constructors, we emit a simpler
125 For the @(/=)@ method, we normally just use the default method.
127 If the type is an enumeration type, we could/may/should? generate
128 special code that calls @con2tag_Foo@, much like for @(==)@ shown
132 We thought about doing this: If we're also deriving @Ord@ for this
135 instance ... Eq (Foo ...) where
136 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
137 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
139 However, that requires that \tr{Ord <whatever>} was put in the context
140 for the instance decl, which it probably wasn't, so the decls
141 produced don't get through the typechecker.
146 gen_Eq_binds :: TyCon -> LHsBinds RdrName
150 tycon_loc = getSrcSpan tycon
152 (nullary_cons, nonnullary_cons)
153 | isNewTyCon tycon = ([], tyConDataCons tycon)
154 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
157 = if (null nullary_cons) then
158 case maybeTyConSingleCon tycon of
160 Nothing -> -- if cons don't match, then False
161 [([nlWildPat, nlWildPat], false_Expr)]
162 else -- calc. and compare the tags
164 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
165 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
168 mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
169 mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
170 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
173 ------------------------------------------------------------------
176 con1_pat = nlConVarPat data_con_RDR as_needed
177 con2_pat = nlConVarPat data_con_RDR bs_needed
179 data_con_RDR = getRdrName data_con
180 con_arity = length tys_needed
181 as_needed = take con_arity as_RDRs
182 bs_needed = take con_arity bs_RDRs
183 tys_needed = dataConOrigArgTys data_con
185 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
187 nested_eq_expr [] [] [] = true_Expr
188 nested_eq_expr tys as bs
189 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
191 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
194 %************************************************************************
196 \subsubsection{Generating @Ord@ instance declarations}
198 %************************************************************************
200 For a derived @Ord@, we concentrate our attentions on @compare@
202 compare :: a -> a -> Ordering
203 data Ordering = LT | EQ | GT deriving ()
206 We will use the same example data type as above:
208 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
213 We do all the other @Ord@ methods with calls to @compare@:
215 instance ... (Ord <wurble> <wurble>) where
216 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
217 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
218 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
219 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
221 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
222 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
224 -- compare to come...
228 @compare@ always has two parts. First, we use the compared
229 data-constructors' tags to deal with the case of different
232 compare a b = case (con2tag_Foo a) of { a# ->
233 case (con2tag_Foo b) of { b# ->
234 case (a# ==# b#) of {
236 False -> case (a# <# b#) of
241 cmp_eq = ... to come ...
245 We are only left with the ``help'' function @cmp_eq@, to deal with
246 comparing data constructors with the same tag.
248 For the ordinary constructors (if any), we emit the sorta-obvious
249 compare-style stuff; for our example:
251 cmp_eq (O1 a1 b1) (O1 a2 b2)
252 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
254 cmp_eq (O2 a1) (O2 a2)
257 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
258 = case (compare a1 a2) of {
261 EQ -> case compare b1 b2 of {
269 Again, we must be careful about unlifted comparisons. For example,
270 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
274 cmp_eq lt eq gt (O2 a1) (O2 a2)
276 -- or maybe the unfolded equivalent
280 For the remaining nullary constructors, we already know that the
287 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
291 gen_Ord_binds :: TyCon -> LHsBinds RdrName
294 = unitBag compare -- `AndMonoBinds` compare
295 -- The default declaration in PrelBase handles this
297 tycon_loc = getSrcSpan tycon
298 --------------------------------------------------------------------
300 compare = L tycon_loc (mkFunBind (L tycon_loc compare_RDR) compare_matches)
301 compare_matches = [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
302 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
305 | single_con_type = cmp_eq_Expr a_Expr b_Expr
307 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
308 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
309 (cmp_eq_Expr a_Expr b_Expr) -- True case
310 -- False case; they aren't equal
311 -- So we need to do a less-than comparison on the tags
312 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
314 tycon_data_cons = tyConDataCons tycon
315 single_con_type = isSingleton tycon_data_cons
316 (nullary_cons, nonnullary_cons)
317 | isNewTyCon tycon = ([], tyConDataCons tycon)
318 | otherwise = partition isNullarySrcDataCon tycon_data_cons
320 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
322 | isEnumerationTyCon tycon
323 -- We know the tags are equal, so if it's an enumeration TyCon,
324 -- then there is nothing left to do
325 -- Catch this specially to avoid warnings
326 -- about overlapping patterns from the desugarer,
327 -- and to avoid unnecessary pattern-matching
328 = [([nlWildPat,nlWildPat], eqTag_Expr)]
330 = map pats_etc nonnullary_cons ++
331 (if single_con_type then -- Omit wildcards when there's just one
332 [] -- constructor, to silence desugarer
334 [([nlWildPat, nlWildPat], default_rhs)])
338 = ([con1_pat, con2_pat],
339 nested_compare_expr tys_needed as_needed bs_needed)
341 con1_pat = nlConVarPat data_con_RDR as_needed
342 con2_pat = nlConVarPat data_con_RDR bs_needed
344 data_con_RDR = getRdrName data_con
345 con_arity = length tys_needed
346 as_needed = take con_arity as_RDRs
347 bs_needed = take con_arity bs_RDRs
348 tys_needed = dataConOrigArgTys data_con
350 nested_compare_expr [ty] [a] [b]
351 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
353 nested_compare_expr (ty:tys) (a:as) (b:bs)
354 = let eq_expr = nested_compare_expr tys as bs
355 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
357 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
358 -- inexhaustive patterns
359 | otherwise = eqTag_Expr -- Some nullary constructors;
360 -- Tags are equal, no args => return EQ
363 %************************************************************************
365 \subsubsection{Generating @Enum@ instance declarations}
367 %************************************************************************
369 @Enum@ can only be derived for enumeration types. For a type
371 data Foo ... = N1 | N2 | ... | Nn
374 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
375 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
378 instance ... Enum (Foo ...) where
379 succ x = toEnum (1 + fromEnum x)
380 pred x = toEnum (fromEnum x - 1)
382 toEnum i = tag2con_Foo i
384 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
388 = case con2tag_Foo a of
389 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
392 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
396 = case con2tag_Foo a of { a# ->
397 case con2tag_Foo b of { b# ->
398 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
402 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
405 gen_Enum_binds :: TyCon -> LHsBinds RdrName
417 tycon_loc = getSrcSpan tycon
418 occ_nm = getOccString tycon
421 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
422 untag_Expr tycon [(a_RDR, ah_RDR)] $
423 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
424 nlHsVarApps intDataCon_RDR [ah_RDR]])
425 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
426 (nlHsApp (nlHsVar (tag2con_RDR tycon))
427 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
431 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
432 untag_Expr tycon [(a_RDR, ah_RDR)] $
433 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
434 nlHsVarApps intDataCon_RDR [ah_RDR]])
435 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
436 (nlHsApp (nlHsVar (tag2con_RDR tycon))
437 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
438 nlHsLit (HsInt (-1))]))
441 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
442 nlHsIf (nlHsApps and_RDR
443 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
444 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
445 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
446 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
449 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
450 untag_Expr tycon [(a_RDR, ah_RDR)] $
452 [nlHsVar (tag2con_RDR tycon),
453 nlHsPar (enum_from_to_Expr
454 (nlHsVarApps intDataCon_RDR [ah_RDR])
455 (nlHsVar (maxtag_RDR tycon)))]
458 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
459 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
460 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
461 nlHsPar (enum_from_then_to_Expr
462 (nlHsVarApps intDataCon_RDR [ah_RDR])
463 (nlHsVarApps intDataCon_RDR [bh_RDR])
464 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
465 nlHsVarApps intDataCon_RDR [bh_RDR]])
467 (nlHsVar (maxtag_RDR tycon))
471 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
472 untag_Expr tycon [(a_RDR, ah_RDR)] $
473 (nlHsVarApps intDataCon_RDR [ah_RDR])
476 %************************************************************************
478 \subsubsection{Generating @Bounded@ instance declarations}
480 %************************************************************************
483 gen_Bounded_binds tycon
484 = if isEnumerationTyCon tycon then
485 listToBag [ min_bound_enum, max_bound_enum ]
487 ASSERT(isSingleton data_cons)
488 listToBag [ min_bound_1con, max_bound_1con ]
490 data_cons = tyConDataCons tycon
491 tycon_loc = getSrcSpan tycon
493 ----- enum-flavored: ---------------------------
494 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
495 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
497 data_con_1 = head data_cons
498 data_con_N = last data_cons
499 data_con_1_RDR = getRdrName data_con_1
500 data_con_N_RDR = getRdrName data_con_N
502 ----- single-constructor-flavored: -------------
503 arity = dataConSourceArity data_con_1
505 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
506 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
507 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
508 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
511 %************************************************************************
513 \subsubsection{Generating @Ix@ instance declarations}
515 %************************************************************************
517 Deriving @Ix@ is only possible for enumeration types and
518 single-constructor types. We deal with them in turn.
520 For an enumeration type, e.g.,
522 data Foo ... = N1 | N2 | ... | Nn
524 things go not too differently from @Enum@:
526 instance ... Ix (Foo ...) where
528 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
532 = case (con2tag_Foo a) of { a# ->
533 case (con2tag_Foo b) of { b# ->
534 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
537 -- Generate code for unsafeIndex, becuase using index leads
538 -- to lots of redundant range tests
539 unsafeIndex c@(a, b) d
540 = case (con2tag_Foo d -# con2tag_Foo a) of
545 p_tag = con2tag_Foo c
547 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
551 = case (con2tag_Foo a) of { a_tag ->
552 case (con2tag_Foo b) of { b_tag ->
553 case (con2tag_Foo c) of { c_tag ->
554 if (c_tag >=# a_tag) then
560 (modulo suitable case-ification to handle the unlifted tags)
562 For a single-constructor type (NB: this includes all tuples), e.g.,
564 data Foo ... = MkFoo a b Int Double c c
566 we follow the scheme given in Figure~19 of the Haskell~1.2 report
570 gen_Ix_binds :: TyCon -> LHsBinds RdrName
573 = if isEnumerationTyCon tycon
577 tycon_loc = getSrcSpan tycon
579 --------------------------------------------------------------
580 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
583 = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
584 untag_Expr tycon [(a_RDR, ah_RDR)] $
585 untag_Expr tycon [(b_RDR, bh_RDR)] $
586 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
587 nlHsPar (enum_from_to_Expr
588 (nlHsVarApps intDataCon_RDR [ah_RDR])
589 (nlHsVarApps intDataCon_RDR [bh_RDR]))
592 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
593 [noLoc (AsPat (noLoc c_RDR)
594 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
596 untag_Expr tycon [(a_RDR, ah_RDR)] (
597 untag_Expr tycon [(d_RDR, dh_RDR)] (
599 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
602 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
603 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
608 = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
609 untag_Expr tycon [(a_RDR, ah_RDR)] (
610 untag_Expr tycon [(b_RDR, bh_RDR)] (
611 untag_Expr tycon [(c_RDR, ch_RDR)] (
612 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
613 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
618 --------------------------------------------------------------
620 = listToBag [single_con_range, single_con_index, single_con_inRange]
623 = case maybeTyConSingleCon tycon of -- just checking...
624 Nothing -> panic "get_Ix_binds"
625 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
626 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
629 con_arity = dataConSourceArity data_con
630 data_con_RDR = getRdrName data_con
632 as_needed = take con_arity as_RDRs
633 bs_needed = take con_arity bs_RDRs
634 cs_needed = take con_arity cs_RDRs
636 con_pat xs = nlConVarPat data_con_RDR xs
637 con_expr = nlHsVarApps data_con_RDR cs_needed
639 --------------------------------------------------------------
641 = mk_easy_FunBind tycon_loc range_RDR
642 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
643 nlHsDo ListComp stmts con_expr
645 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
647 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
648 (nlHsApp (nlHsVar range_RDR)
649 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
653 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
654 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
656 (mk_index (zip3 as_needed bs_needed cs_needed))
658 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
659 mk_index [] = nlHsIntLit 0
660 mk_index [(l,u,i)] = mk_one l u i
661 mk_index ((l,u,i) : rest)
666 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
667 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
668 ) times_RDR (mk_index rest)
671 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
675 = mk_easy_FunBind tycon_loc inRange_RDR
676 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
678 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
680 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
684 %************************************************************************
686 \subsubsection{Generating @Read@ instance declarations}
688 %************************************************************************
698 instance Read T where
702 do x <- ReadP.step Read.readPrec
703 Symbol "%%" <- Lex.lex
704 y <- ReadP.step Read.readPrec
708 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
709 -- Record construction binds even more tightly than application
710 do Ident "T1" <- Lex.lex
712 Ident "f1" <- Lex.lex
714 x <- ReadP.reset Read.readPrec
716 return (T1 { f1 = x }))
719 do Ident "T2" <- Lex.lexP
720 x <- ReadP.step Read.readPrec
724 readListPrec = readListPrecDefault
725 readList = readListDefault
729 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
731 gen_Read_binds get_fixity tycon
732 = listToBag [read_prec, default_readlist, default_readlistprec]
734 -----------------------------------------------------------------------
736 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
739 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
740 -----------------------------------------------------------------------
742 loc = getSrcSpan tycon
743 data_cons = tyConDataCons tycon
744 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
746 read_prec = mkVarBind loc readPrec_RDR
747 (nlHsApp (nlHsVar parens_RDR) read_cons)
749 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
750 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
753 = case nullary_cons of
755 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
756 (result_expr con [])]
757 _ -> [nlHsApp (nlHsVar choose_RDR)
758 (nlList (map mk_pair nullary_cons))]
760 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
761 nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
764 read_non_nullary_con data_con
765 = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body]
767 stmts | is_infix = infix_stmts
768 | is_record = lbl_stmts
769 | otherwise = prefix_stmts
771 body = result_expr data_con as_needed
772 con_str = data_con_str data_con
774 prefix_stmts -- T a b c
775 = [bindLex (ident_pat (wrapOpParens con_str))]
778 infix_stmts -- a %% b, or a `T` b
781 then [bindLex (symbol_pat con_str)]
782 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
785 lbl_stmts -- T { f1 = a, f2 = b }
786 = [bindLex (ident_pat (wrapOpParens con_str)),
788 ++ concat (intersperse [read_punc ","] field_stmts)
791 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
793 con_arity = dataConSourceArity data_con
794 labels = dataConFieldLabels data_con
795 dc_nm = getName data_con
796 is_infix = dataConIsInfix data_con
797 is_record = length labels > 0
798 as_needed = take con_arity as_RDRs
799 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
800 (read_a1:read_a2:_) = read_args
801 prec | is_infix = getPrecedence get_fixity dc_nm
802 | is_record = appPrecedence + 1 -- Record construction binds even more tightly
803 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
804 | otherwise = appPrecedence
806 ------------------------------------------------------------------------
808 ------------------------------------------------------------------------
809 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
810 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))
811 con_app c as = nlHsVarApps (getRdrName c) as
812 result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as)
814 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
815 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
816 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
818 data_con_str con = occNameString (getOccName con)
820 read_punc c = bindLex (punc_pat c)
822 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
823 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
825 read_field lbl a = read_lbl lbl ++
827 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
829 -- When reading field labels we might encounter
834 read_lbl lbl | isSym lbl_str
836 bindLex (symbol_pat lbl_str),
839 = [bindLex (ident_pat lbl_str)]
841 lbl_str = occNameString (getOccName lbl)
845 %************************************************************************
847 \subsubsection{Generating @Show@ instance declarations}
849 %************************************************************************
855 data Tree a = Leaf a | Tree a :^: Tree a
857 instance (Show a) => Show (Tree a) where
859 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
861 showStr = showString "Leaf " . showsPrec (app_prec+1) m
863 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
865 showStr = showsPrec (up_prec+1) u .
867 showsPrec (up_prec+1) v
868 -- Note: right-associativity of :^: ignored
870 up_prec = 5 -- Precedence of :^:
871 app_prec = 10 -- Application has precedence one more than
872 -- the most tightly-binding operator
875 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
877 gen_Show_binds get_fixity tycon
878 = listToBag [shows_prec, show_list]
880 tycon_loc = getSrcSpan tycon
881 -----------------------------------------------------------------------
882 show_list = mkVarBind tycon_loc showList_RDR
883 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
884 -----------------------------------------------------------------------
885 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
888 | nullary_con = -- skip the showParen junk...
889 ASSERT(null bs_needed)
890 ([nlWildPat, con_pat], mk_showString_app con_str)
893 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
894 (nlHsPar (nested_compose_Expr show_thingies)))
896 data_con_RDR = getRdrName data_con
897 con_arity = dataConSourceArity data_con
898 bs_needed = take con_arity bs_RDRs
899 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
900 con_pat = nlConVarPat data_con_RDR bs_needed
901 nullary_con = con_arity == 0
902 labels = dataConFieldLabels data_con
903 lab_fields = length labels
904 record_syntax = lab_fields > 0
906 dc_nm = getName data_con
907 dc_occ_nm = getOccName data_con
908 con_str = occNameString dc_occ_nm
909 op_con_str = wrapOpParens con_str
910 backquote_str = wrapOpBackquotes con_str
913 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
914 | record_syntax = mk_showString_app (op_con_str ++ " {") :
915 show_record_args ++ [mk_showString_app "}"]
916 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
918 show_label l = mk_showString_app (nm ++ " = ")
919 -- Note the spaces around the "=" sign. If we don't have them
920 -- then we get Foo { x=-1 } and the "=-" parses as a single
921 -- lexeme. Only the space after the '=' is necessary, but
922 -- it seems tidier to have them both sides.
924 occ_nm = getOccName l
925 nm = wrapOpParens (occNameString occ_nm)
927 show_args = zipWith show_arg bs_needed arg_tys
928 (show_arg1:show_arg2:_) = show_args
929 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
931 -- Assumption for record syntax: no of fields == no of labelled fields
932 -- (and in same order)
933 show_record_args = concat $
934 intersperse [mk_showString_app ", "] $
935 [ [show_label lbl, arg]
936 | (lbl,arg) <- zipEqual "gen_Show_binds"
939 -- Generates (showsPrec p x) for argument x, but it also boxes
940 -- the argument first if necessary. Note that this prints unboxed
941 -- things without any '#' decorations; could change that if need be
942 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
943 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
946 is_infix = dataConIsInfix data_con
947 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
948 arg_prec | record_syntax = 0 -- Record fields don't need parens
949 | otherwise = con_prec_plus_one
951 wrapOpParens :: String -> String
952 wrapOpParens s | isSym s = '(' : s ++ ")"
955 wrapOpBackquotes :: String -> String
956 wrapOpBackquotes s | isSym s = s
957 | otherwise = '`' : s ++ "`"
959 isSym :: String -> Bool
961 isSym (c:cs) = startsVarSym c || startsConSym c
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 (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 gunfold k z c = case conIndex c of
1047 I# 1# -> k (k (z T1))
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, gunfold_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
1068 n_cons = length data_cons
1069 one_constr = n_cons == 1
1072 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1073 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1074 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1077 con_name = getRdrName con
1078 as_needed = take (dataConSourceArity con) as_RDRs
1079 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1081 ------------ gunfold
1082 gunfold_bind = mk_FunBind tycon_loc
1084 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1088 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1089 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1090 (map gunfold_alt data_cons)
1092 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1093 mk_unfold_rhs dc = foldr nlHsApp
1094 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1095 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1097 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1098 -- redundant test, and annoying warning
1099 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1100 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1104 ------------ toConstr
1105 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1106 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1108 ------------ dataTypeOf
1109 dataTypeOf_bind = mk_easy_FunBind
1113 (nlHsVar data_type_name)
1117 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1118 datatype_bind = mkVarBind
1121 ( nlHsVar mkDataType_RDR
1122 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1123 `nlHsApp` nlList constrs
1125 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1128 ------------ $cT1 etc
1129 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1130 mk_con_bind dc = mkVarBind
1133 (nlHsApps mkConstr_RDR (constr_args dc))
1135 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1136 nlHsVar data_type_name, -- DataType
1137 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1138 nlList labels, -- Field labels
1139 nlHsVar fixity] -- Fixity
1141 labels = map (nlHsLit . mkHsString . getOccString)
1142 (dataConFieldLabels dc)
1143 dc_occ = getOccName dc
1144 is_infix = isDataSymOcc dc_occ
1145 fixity | is_infix = infix_RDR
1146 | otherwise = prefix_RDR
1148 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1149 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1150 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1151 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1152 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1153 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1154 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1155 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1156 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1159 %************************************************************************
1161 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1163 %************************************************************************
1168 con2tag_Foo :: Foo ... -> Int#
1169 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1170 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1173 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1178 = GenCon2Tag | GenTag2Con | GenMaxTag
1180 gen_tag_n_con_monobind
1181 :: ( RdrName, -- (proto)Name for the thing in question
1182 TyCon, -- tycon in question
1186 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1187 | lots_of_constructors
1188 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1191 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1194 tycon_loc = getSrcSpan tycon
1196 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1197 -- We can't use gerRdrName because that makes an Exact RdrName
1198 -- and we can't put them in the LocalRdrEnv
1200 -- Give a signature to the bound variable, so
1201 -- that the case expression generated by getTag is
1202 -- monomorphic. In the push-enter model we get better code.
1203 get_tag_rhs = noLoc $ ExprWithTySig
1204 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1205 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1206 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1208 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1211 nlHsTyVar (getRdrName intPrimTyCon)
1213 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1215 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1216 mk_stuff con = ([nlWildConPat con],
1217 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1219 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1220 = mk_FunBind (getSrcSpan tycon) rdr_name
1221 [([nlConVarPat intDataCon_RDR [a_RDR]],
1222 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1223 (nlHsTyVar (getRdrName tycon))))]
1225 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1226 = mkVarBind (getSrcSpan tycon) rdr_name
1227 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1229 max_tag = case (tyConDataCons tycon) of
1230 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1234 %************************************************************************
1236 \subsection{Utility bits for generating bindings}
1238 %************************************************************************
1241 ToDo: Better SrcLocs.
1245 LHsExpr RdrName -- What to do for equality
1246 -> LHsExpr RdrName -> LHsExpr RdrName
1248 careful_compare_Case :: -- checks for primitive types...
1249 TyCon -- The tycon we are deriving for
1251 -> LHsExpr RdrName -- What to do for equality
1252 -> LHsExpr RdrName -> LHsExpr RdrName
1255 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1256 -- Was: compare_gen_Case cmp_eq_RDR
1258 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1259 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1260 compare_gen_Case eq a b -- General case
1261 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1262 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1263 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1264 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1266 careful_compare_Case tycon ty eq a b
1267 | not (isUnLiftedType ty)
1268 = compare_gen_Case eq a b
1269 | otherwise -- We have to do something special for primitive things...
1270 = nlHsIf (genOpApp a relevant_eq_op b)
1272 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1274 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1275 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1278 box_if_necy :: String -- The class involved
1279 -> TyCon -- The tycon involved
1280 -> LHsExpr RdrName -- The argument
1281 -> Type -- The argument type
1282 -> LHsExpr RdrName -- Boxed version of the arg
1283 box_if_necy cls_str tycon arg arg_ty
1284 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1287 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1289 assoc_ty_id :: String -- The class involved
1290 -> TyCon -- The tycon involved
1291 -> [(Type,a)] -- The table
1293 -> a -- The result of the lookup
1294 assoc_ty_id cls_str tycon tbl ty
1295 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1296 text "for primitive type" <+> ppr ty)
1297 | otherwise = head res
1299 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1301 eq_op_tbl :: [(Type, PrimOp)]
1303 [(charPrimTy, CharEqOp)
1304 ,(intPrimTy, IntEqOp)
1305 ,(wordPrimTy, WordEqOp)
1306 ,(addrPrimTy, AddrEqOp)
1307 ,(floatPrimTy, FloatEqOp)
1308 ,(doublePrimTy, DoubleEqOp)
1311 lt_op_tbl :: [(Type, PrimOp)]
1313 [(charPrimTy, CharLtOp)
1314 ,(intPrimTy, IntLtOp)
1315 ,(wordPrimTy, WordLtOp)
1316 ,(addrPrimTy, AddrLtOp)
1317 ,(floatPrimTy, FloatLtOp)
1318 ,(doublePrimTy, DoubleLtOp)
1322 [(charPrimTy, getRdrName charDataCon)
1323 ,(intPrimTy, getRdrName intDataCon)
1324 ,(wordPrimTy, wordDataCon_RDR)
1325 ,(floatPrimTy, getRdrName floatDataCon)
1326 ,(doublePrimTy, getRdrName doubleDataCon)
1329 -----------------------------------------------------------------------
1331 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1332 and_Expr a b = genOpApp a and_RDR b
1334 -----------------------------------------------------------------------
1336 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1337 eq_Expr tycon ty a b = genOpApp a eq_op b
1340 | not (isUnLiftedType ty) = eq_RDR
1341 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1342 -- we have to do something special for primitive things...
1346 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1347 untag_Expr tycon [] expr = expr
1348 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1349 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1350 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1352 cmp_tags_Expr :: RdrName -- Comparison op
1353 -> RdrName -> RdrName -- Things to compare
1354 -> LHsExpr RdrName -- What to return if true
1355 -> LHsExpr RdrName -- What to return if false
1358 cmp_tags_Expr op a b true_case false_case
1359 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1362 :: LHsExpr RdrName -> LHsExpr RdrName
1364 enum_from_then_to_Expr
1365 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1368 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1369 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1372 :: LHsExpr RdrName -> LHsExpr RdrName
1375 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1377 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1379 nested_compose_Expr [e] = parenify e
1380 nested_compose_Expr (e:es)
1381 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1383 -- impossible_Expr is used in case RHSs that should never happen.
1384 -- We generate these to keep the desugarer from complaining that they *might* happen!
1385 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1387 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1388 -- method. It is currently only used by Enum.{succ,pred}
1389 illegal_Expr meth tp msg =
1390 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1392 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1393 -- to include the value of a_RDR in the error string.
1394 illegal_toEnum_tag tp maxtag =
1395 nlHsApp (nlHsVar error_RDR)
1396 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1397 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1398 (nlHsApp (nlHsApp (nlHsApp
1399 (nlHsVar showsPrec_RDR)
1403 (nlHsVar append_RDR)
1404 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1405 (nlHsApp (nlHsApp (nlHsApp
1406 (nlHsVar showsPrec_RDR)
1409 (nlHsLit (mkHsString ")"))))))
1411 parenify e@(L _ (HsVar _)) = e
1412 parenify e = mkHsPar e
1414 -- genOpApp wraps brackets round the operator application, so that the
1415 -- renamer won't subsequently try to re-associate it.
1416 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1420 getSrcSpan = srcLocSpan . getSrcLoc
1424 a_RDR = mkVarUnqual FSLIT("a")
1425 b_RDR = mkVarUnqual FSLIT("b")
1426 c_RDR = mkVarUnqual FSLIT("c")
1427 d_RDR = mkVarUnqual FSLIT("d")
1428 k_RDR = mkVarUnqual FSLIT("k")
1429 z_RDR = mkVarUnqual FSLIT("z")
1430 ah_RDR = mkVarUnqual FSLIT("a#")
1431 bh_RDR = mkVarUnqual FSLIT("b#")
1432 ch_RDR = mkVarUnqual FSLIT("c#")
1433 dh_RDR = mkVarUnqual FSLIT("d#")
1434 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1436 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1437 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1438 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1440 a_Expr = nlHsVar a_RDR
1441 b_Expr = nlHsVar b_RDR
1442 c_Expr = nlHsVar c_RDR
1443 ltTag_Expr = nlHsVar ltTag_RDR
1444 eqTag_Expr = nlHsVar eqTag_RDR
1445 gtTag_Expr = nlHsVar gtTag_RDR
1446 false_Expr = nlHsVar false_RDR
1447 true_Expr = nlHsVar true_RDR
1449 a_Pat = nlVarPat a_RDR
1450 b_Pat = nlVarPat b_RDR
1451 c_Pat = nlVarPat c_RDR
1452 d_Pat = nlVarPat d_RDR
1453 k_Pat = nlVarPat k_RDR
1454 z_Pat = nlVarPat z_RDR
1456 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1457 -- Generates Orig s RdrName, for the binding positions
1458 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1459 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1460 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1462 mk_tc_deriv_name tycon str
1463 = mkDerivedRdrName tc_name mk_occ
1465 tc_name = tyConName tycon
1466 mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1468 new_str = str ++ occNameString tc_occ ++ "#"
1471 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1472 PrelNames, so PrelNames can't import PrimOp.
1475 primOpRdrName op = getRdrName (primOpId op)
1477 minusInt_RDR = primOpRdrName IntSubOp
1478 eqInt_RDR = primOpRdrName IntEqOp
1479 ltInt_RDR = primOpRdrName IntLtOp
1480 geInt_RDR = primOpRdrName IntGeOp
1481 leInt_RDR = primOpRdrName IntLeOp
1482 tagToEnum_RDR = primOpRdrName TagToEnumOp
1484 error_RDR = getRdrName eRROR_ID