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 nested_compare_expr _ _ _ = panic "nested_compare_expr" -- Args always equal length
359 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
360 -- inexhaustive patterns
361 | otherwise = eqTag_Expr -- Some nullary constructors;
362 -- Tags are equal, no args => return EQ
365 %************************************************************************
367 \subsubsection{Generating @Enum@ instance declarations}
369 %************************************************************************
371 @Enum@ can only be derived for enumeration types. For a type
373 data Foo ... = N1 | N2 | ... | Nn
376 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
377 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
380 instance ... Enum (Foo ...) where
381 succ x = toEnum (1 + fromEnum x)
382 pred x = toEnum (fromEnum x - 1)
384 toEnum i = tag2con_Foo i
386 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
390 = case con2tag_Foo a of
391 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
394 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
398 = case con2tag_Foo a of { a# ->
399 case con2tag_Foo b of { b# ->
400 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
404 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
407 gen_Enum_binds :: TyCon -> LHsBinds RdrName
419 tycon_loc = getSrcSpan tycon
420 occ_nm = getOccString tycon
423 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
424 untag_Expr tycon [(a_RDR, ah_RDR)] $
425 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
426 nlHsVarApps intDataCon_RDR [ah_RDR]])
427 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
428 (nlHsApp (nlHsVar (tag2con_RDR tycon))
429 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
433 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
434 untag_Expr tycon [(a_RDR, ah_RDR)] $
435 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
436 nlHsVarApps intDataCon_RDR [ah_RDR]])
437 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
438 (nlHsApp (nlHsVar (tag2con_RDR tycon))
439 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
440 nlHsLit (HsInt (-1))]))
443 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
444 nlHsIf (nlHsApps and_RDR
445 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
446 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
447 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
448 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
451 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
452 untag_Expr tycon [(a_RDR, ah_RDR)] $
454 [nlHsVar (tag2con_RDR tycon),
455 nlHsPar (enum_from_to_Expr
456 (nlHsVarApps intDataCon_RDR [ah_RDR])
457 (nlHsVar (maxtag_RDR tycon)))]
460 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
461 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
462 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
463 nlHsPar (enum_from_then_to_Expr
464 (nlHsVarApps intDataCon_RDR [ah_RDR])
465 (nlHsVarApps intDataCon_RDR [bh_RDR])
466 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
467 nlHsVarApps intDataCon_RDR [bh_RDR]])
469 (nlHsVar (maxtag_RDR tycon))
473 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
474 untag_Expr tycon [(a_RDR, ah_RDR)] $
475 (nlHsVarApps intDataCon_RDR [ah_RDR])
478 %************************************************************************
480 \subsubsection{Generating @Bounded@ instance declarations}
482 %************************************************************************
485 gen_Bounded_binds tycon
486 = if isEnumerationTyCon tycon then
487 listToBag [ min_bound_enum, max_bound_enum ]
489 ASSERT(isSingleton data_cons)
490 listToBag [ min_bound_1con, max_bound_1con ]
492 data_cons = tyConDataCons tycon
493 tycon_loc = getSrcSpan tycon
495 ----- enum-flavored: ---------------------------
496 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
497 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
499 data_con_1 = head data_cons
500 data_con_N = last data_cons
501 data_con_1_RDR = getRdrName data_con_1
502 data_con_N_RDR = getRdrName data_con_N
504 ----- single-constructor-flavored: -------------
505 arity = dataConSourceArity data_con_1
507 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
508 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
509 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
510 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
513 %************************************************************************
515 \subsubsection{Generating @Ix@ instance declarations}
517 %************************************************************************
519 Deriving @Ix@ is only possible for enumeration types and
520 single-constructor types. We deal with them in turn.
522 For an enumeration type, e.g.,
524 data Foo ... = N1 | N2 | ... | Nn
526 things go not too differently from @Enum@:
528 instance ... Ix (Foo ...) where
530 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
534 = case (con2tag_Foo a) of { a# ->
535 case (con2tag_Foo b) of { b# ->
536 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
539 -- Generate code for unsafeIndex, becuase using index leads
540 -- to lots of redundant range tests
541 unsafeIndex c@(a, b) d
542 = case (con2tag_Foo d -# con2tag_Foo a) of
547 p_tag = con2tag_Foo c
549 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
553 = case (con2tag_Foo a) of { a_tag ->
554 case (con2tag_Foo b) of { b_tag ->
555 case (con2tag_Foo c) of { c_tag ->
556 if (c_tag >=# a_tag) then
562 (modulo suitable case-ification to handle the unlifted tags)
564 For a single-constructor type (NB: this includes all tuples), e.g.,
566 data Foo ... = MkFoo a b Int Double c c
568 we follow the scheme given in Figure~19 of the Haskell~1.2 report
572 gen_Ix_binds :: TyCon -> LHsBinds RdrName
575 = if isEnumerationTyCon tycon
579 tycon_loc = getSrcSpan tycon
581 --------------------------------------------------------------
582 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
585 = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
586 untag_Expr tycon [(a_RDR, ah_RDR)] $
587 untag_Expr tycon [(b_RDR, bh_RDR)] $
588 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
589 nlHsPar (enum_from_to_Expr
590 (nlHsVarApps intDataCon_RDR [ah_RDR])
591 (nlHsVarApps intDataCon_RDR [bh_RDR]))
594 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
595 [noLoc (AsPat (noLoc c_RDR)
596 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
598 untag_Expr tycon [(a_RDR, ah_RDR)] (
599 untag_Expr tycon [(d_RDR, dh_RDR)] (
601 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
604 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
605 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
610 = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
611 untag_Expr tycon [(a_RDR, ah_RDR)] (
612 untag_Expr tycon [(b_RDR, bh_RDR)] (
613 untag_Expr tycon [(c_RDR, ch_RDR)] (
614 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
615 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
620 --------------------------------------------------------------
622 = listToBag [single_con_range, single_con_index, single_con_inRange]
625 = case maybeTyConSingleCon tycon of -- just checking...
626 Nothing -> panic "get_Ix_binds"
627 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
628 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
631 con_arity = dataConSourceArity data_con
632 data_con_RDR = getRdrName data_con
634 as_needed = take con_arity as_RDRs
635 bs_needed = take con_arity bs_RDRs
636 cs_needed = take con_arity cs_RDRs
638 con_pat xs = nlConVarPat data_con_RDR xs
639 con_expr = nlHsVarApps data_con_RDR cs_needed
641 --------------------------------------------------------------
643 = mk_easy_FunBind tycon_loc range_RDR
644 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
645 nlHsDo ListComp stmts con_expr
647 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
649 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
650 (nlHsApp (nlHsVar range_RDR)
651 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
655 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
656 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
658 (mk_index (zip3 as_needed bs_needed cs_needed))
660 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
661 mk_index [] = nlHsIntLit 0
662 mk_index [(l,u,i)] = mk_one l u i
663 mk_index ((l,u,i) : rest)
668 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
669 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
670 ) times_RDR (mk_index rest)
673 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
677 = mk_easy_FunBind tycon_loc inRange_RDR
678 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
680 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
682 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
686 %************************************************************************
688 \subsubsection{Generating @Read@ instance declarations}
690 %************************************************************************
700 instance Read T where
704 do x <- ReadP.step Read.readPrec
705 Symbol "%%" <- Lex.lex
706 y <- ReadP.step Read.readPrec
710 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
711 -- Record construction binds even more tightly than application
712 do Ident "T1" <- Lex.lex
714 Ident "f1" <- Lex.lex
716 x <- ReadP.reset Read.readPrec
718 return (T1 { f1 = x }))
721 do Ident "T2" <- Lex.lexP
722 x <- ReadP.step Read.readPrec
726 readListPrec = readListPrecDefault
727 readList = readListDefault
731 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
733 gen_Read_binds get_fixity tycon
734 = listToBag [read_prec, default_readlist, default_readlistprec]
736 -----------------------------------------------------------------------
738 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
741 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
742 -----------------------------------------------------------------------
744 loc = getSrcSpan tycon
745 data_cons = tyConDataCons tycon
746 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
748 read_prec = mkVarBind loc readPrec_RDR
749 (nlHsApp (nlHsVar parens_RDR) read_cons)
751 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
752 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
755 = case nullary_cons of
757 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
758 (result_expr con [])]
759 _ -> [nlHsApp (nlHsVar choose_RDR)
760 (nlList (map mk_pair nullary_cons))]
762 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
766 read_non_nullary_con data_con
767 | is_infix = mk_parser infix_prec infix_stmts body
768 | is_record = mk_parser record_prec record_stmts body
769 -- Using these two lines instead allows the derived
770 -- read for infix and record bindings to read the prefix form
771 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
772 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
773 | otherwise = prefix_parser
775 body = result_expr data_con as_needed
776 con_str = data_con_str data_con
778 prefix_parser = mk_parser prefix_prec prefix_stmts body
779 prefix_stmts -- T a b c
780 = (if not (isSym con_str) then
781 [bindLex (ident_pat con_str)]
782 else [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"])
785 infix_stmts -- a %% b, or a `T` b
788 then [bindLex (symbol_pat con_str)]
789 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
792 record_stmts -- T { f1 = a, f2 = b }
793 = [bindLex (ident_pat (wrapOpParens con_str)),
795 ++ concat (intersperse [read_punc ","] field_stmts)
798 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
800 con_arity = dataConSourceArity data_con
801 labels = dataConFieldLabels data_con
802 dc_nm = getName data_con
803 is_infix = dataConIsInfix data_con
804 is_record = length labels > 0
805 as_needed = take con_arity as_RDRs
806 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
807 (read_a1:read_a2:_) = read_args
809 prefix_prec = appPrecedence
810 infix_prec = getPrecedence get_fixity dc_nm
811 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
812 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
814 ------------------------------------------------------------------------
816 ------------------------------------------------------------------------
817 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
818 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
819 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
820 con_app con as = nlHsVarApps (getRdrName con) as -- con as
821 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
823 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
824 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
825 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
827 data_con_str con = occNameString (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 = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
834 read_field lbl a = read_lbl lbl ++
836 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
838 -- When reading field labels we might encounter
843 read_lbl lbl | isSym lbl_str
845 bindLex (symbol_pat lbl_str),
848 = [bindLex (ident_pat lbl_str)]
850 lbl_str = occNameString (getOccName lbl)
854 %************************************************************************
856 \subsubsection{Generating @Show@ instance declarations}
858 %************************************************************************
864 data Tree a = Leaf a | Tree a :^: Tree a
866 instance (Show a) => Show (Tree a) where
868 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
870 showStr = showString "Leaf " . showsPrec (app_prec+1) m
872 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
874 showStr = showsPrec (up_prec+1) u .
876 showsPrec (up_prec+1) v
877 -- Note: right-associativity of :^: ignored
879 up_prec = 5 -- Precedence of :^:
880 app_prec = 10 -- Application has precedence one more than
881 -- the most tightly-binding operator
884 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
886 gen_Show_binds get_fixity tycon
887 = listToBag [shows_prec, show_list]
889 tycon_loc = getSrcSpan tycon
890 -----------------------------------------------------------------------
891 show_list = mkVarBind tycon_loc showList_RDR
892 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
893 -----------------------------------------------------------------------
894 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
897 | nullary_con = -- skip the showParen junk...
898 ASSERT(null bs_needed)
899 ([nlWildPat, con_pat], mk_showString_app con_str)
902 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
903 (nlHsPar (nested_compose_Expr show_thingies)))
905 data_con_RDR = getRdrName data_con
906 con_arity = dataConSourceArity data_con
907 bs_needed = take con_arity bs_RDRs
908 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
909 con_pat = nlConVarPat data_con_RDR bs_needed
910 nullary_con = con_arity == 0
911 labels = dataConFieldLabels data_con
912 lab_fields = length labels
913 record_syntax = lab_fields > 0
915 dc_nm = getName data_con
916 dc_occ_nm = getOccName data_con
917 con_str = occNameString dc_occ_nm
918 op_con_str = wrapOpParens con_str
919 backquote_str = wrapOpBackquotes con_str
922 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
923 | record_syntax = mk_showString_app (op_con_str ++ " {") :
924 show_record_args ++ [mk_showString_app "}"]
925 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
927 show_label l = mk_showString_app (nm ++ " = ")
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 l
934 nm = wrapOpParens (occNameString occ_nm)
936 show_args = zipWith show_arg bs_needed arg_tys
937 (show_arg1:show_arg2:_) = show_args
938 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
940 -- Assumption for record syntax: no of fields == no of labelled fields
941 -- (and in same order)
942 show_record_args = concat $
943 intersperse [mk_showString_app ", "] $
944 [ [show_label lbl, arg]
945 | (lbl,arg) <- zipEqual "gen_Show_binds"
948 -- Generates (showsPrec p x) for argument x, but it also boxes
949 -- the argument first if necessary. Note that this prints unboxed
950 -- things without any '#' decorations; could change that if need be
951 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
952 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
955 is_infix = dataConIsInfix data_con
956 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
957 arg_prec | record_syntax = 0 -- Record fields don't need parens
958 | otherwise = con_prec_plus_one
960 wrapOpParens :: String -> String
961 wrapOpParens s | isSym s = '(' : s ++ ")"
964 wrapOpBackquotes :: String -> String
965 wrapOpBackquotes s | isSym s = s
966 | otherwise = '`' : s ++ "`"
968 isSym :: String -> Bool
970 isSym (c:cs) = startsVarSym c || startsConSym c
972 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
976 getPrec :: Bool -> FixityEnv -> Name -> Integer
977 getPrec is_infix get_fixity nm
978 | not is_infix = appPrecedence
979 | otherwise = getPrecedence get_fixity nm
981 appPrecedence :: Integer
982 appPrecedence = fromIntegral maxPrecedence + 1
983 -- One more than the precedence of the most
984 -- tightly-binding operator
986 getPrecedence :: FixityEnv -> Name -> Integer
987 getPrecedence get_fixity nm
988 = case lookupFixity get_fixity nm of
989 Fixity x _ -> fromIntegral x
993 %************************************************************************
995 \subsection{Typeable}
997 %************************************************************************
1005 instance Typeable2 T where
1006 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1008 We are passed the Typeable2 class as well as T
1011 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1012 gen_Typeable_binds tycon
1014 mk_easy_FunBind tycon_loc
1015 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1017 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1019 tycon_loc = getSrcSpan tycon
1020 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1022 mk_typeOf_RDR :: TyCon -> RdrName
1023 -- Use the arity of the TyCon to make the right typeOfn function
1024 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1026 arity = tyConArity tycon
1027 suffix | arity == 0 = ""
1028 | otherwise = show arity
1033 %************************************************************************
1037 %************************************************************************
1041 data T a b = T1 a b | T2
1045 $cT1 = mkDataCon $dT "T1" Prefix
1046 $cT2 = mkDataCon $dT "T2" Prefix
1047 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1048 -- the [] is for field labels.
1050 instance (Data a, Data b) => Data (T a b) where
1051 gfoldl k z (T1 a b) = z T `k` a `k` b
1052 gfoldl k z T2 = z T2
1053 -- ToDo: add gmapT,Q,M, gfoldr
1055 gunfold k z c = case conIndex c of
1056 I# 1# -> k (k (z T1))
1059 toConstr (T1 _ _) = $cT1
1065 gen_Data_binds :: FixityEnv
1067 -> (LHsBinds RdrName, -- The method bindings
1068 LHsBinds RdrName) -- Auxiliary bindings
1069 gen_Data_binds fix_env tycon
1070 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1071 -- Auxiliary definitions: the data type and constructors
1072 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1074 tycon_loc = getSrcSpan tycon
1075 tycon_name = tyConName tycon
1076 data_cons = tyConDataCons tycon
1077 n_cons = length data_cons
1078 one_constr = n_cons == 1
1081 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1082 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1083 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1086 con_name = getRdrName con
1087 as_needed = take (dataConSourceArity con) as_RDRs
1088 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1090 ------------ gunfold
1091 gunfold_bind = mk_FunBind tycon_loc
1093 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1097 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1098 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1099 (map gunfold_alt data_cons)
1101 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1102 mk_unfold_rhs dc = foldr nlHsApp
1103 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1104 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1106 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1107 -- redundant test, and annoying warning
1108 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1109 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1113 ------------ toConstr
1114 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1115 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1117 ------------ dataTypeOf
1118 dataTypeOf_bind = mk_easy_FunBind
1122 (nlHsVar data_type_name)
1126 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1127 datatype_bind = mkVarBind
1130 ( nlHsVar mkDataType_RDR
1131 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1132 `nlHsApp` nlList constrs
1134 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1137 ------------ $cT1 etc
1138 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1139 mk_con_bind dc = mkVarBind
1142 (nlHsApps mkConstr_RDR (constr_args dc))
1144 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1145 nlHsVar data_type_name, -- DataType
1146 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1147 nlList labels, -- Field labels
1148 nlHsVar fixity] -- Fixity
1150 labels = map (nlHsLit . mkHsString . getOccString)
1151 (dataConFieldLabels dc)
1152 dc_occ = getOccName dc
1153 is_infix = isDataSymOcc dc_occ
1154 fixity | is_infix = infix_RDR
1155 | otherwise = prefix_RDR
1157 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1158 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1159 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1160 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1161 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1162 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1163 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1164 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1165 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1168 %************************************************************************
1170 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1172 %************************************************************************
1177 con2tag_Foo :: Foo ... -> Int#
1178 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1179 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1182 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1187 = GenCon2Tag | GenTag2Con | GenMaxTag
1189 gen_tag_n_con_monobind
1190 :: ( RdrName, -- (proto)Name for the thing in question
1191 TyCon, -- tycon in question
1195 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1196 | lots_of_constructors
1197 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1200 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1203 tycon_loc = getSrcSpan tycon
1205 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1206 -- We can't use gerRdrName because that makes an Exact RdrName
1207 -- and we can't put them in the LocalRdrEnv
1209 -- Give a signature to the bound variable, so
1210 -- that the case expression generated by getTag is
1211 -- monomorphic. In the push-enter model we get better code.
1212 get_tag_rhs = noLoc $ ExprWithTySig
1213 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1214 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1215 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1217 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1220 nlHsTyVar (getRdrName intPrimTyCon)
1222 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1224 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1225 mk_stuff con = ([nlWildConPat con],
1226 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1228 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1229 = mk_FunBind (getSrcSpan tycon) rdr_name
1230 [([nlConVarPat intDataCon_RDR [a_RDR]],
1231 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1232 (nlHsTyVar (getRdrName tycon))))]
1234 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1235 = mkVarBind (getSrcSpan tycon) rdr_name
1236 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1238 max_tag = case (tyConDataCons tycon) of
1239 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1243 %************************************************************************
1245 \subsection{Utility bits for generating bindings}
1247 %************************************************************************
1250 ToDo: Better SrcLocs.
1254 LHsExpr RdrName -- What to do for equality
1255 -> LHsExpr RdrName -> LHsExpr RdrName
1257 careful_compare_Case :: -- checks for primitive types...
1258 TyCon -- The tycon we are deriving for
1260 -> LHsExpr RdrName -- What to do for equality
1261 -> LHsExpr RdrName -> LHsExpr RdrName
1264 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1265 -- Was: compare_gen_Case cmp_eq_RDR
1267 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1268 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1269 compare_gen_Case eq a b -- General case
1270 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1271 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1272 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1273 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1275 careful_compare_Case tycon ty eq a b
1276 | not (isUnLiftedType ty)
1277 = compare_gen_Case eq a b
1278 | otherwise -- We have to do something special for primitive things...
1279 = nlHsIf (genOpApp a relevant_eq_op b)
1281 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1283 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1284 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1287 box_if_necy :: String -- The class involved
1288 -> TyCon -- The tycon involved
1289 -> LHsExpr RdrName -- The argument
1290 -> Type -- The argument type
1291 -> LHsExpr RdrName -- Boxed version of the arg
1292 box_if_necy cls_str tycon arg arg_ty
1293 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1296 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1298 assoc_ty_id :: String -- The class involved
1299 -> TyCon -- The tycon involved
1300 -> [(Type,a)] -- The table
1302 -> a -- The result of the lookup
1303 assoc_ty_id cls_str tycon tbl ty
1304 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1305 text "for primitive type" <+> ppr ty)
1306 | otherwise = head res
1308 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1310 eq_op_tbl :: [(Type, PrimOp)]
1312 [(charPrimTy, CharEqOp)
1313 ,(intPrimTy, IntEqOp)
1314 ,(wordPrimTy, WordEqOp)
1315 ,(addrPrimTy, AddrEqOp)
1316 ,(floatPrimTy, FloatEqOp)
1317 ,(doublePrimTy, DoubleEqOp)
1320 lt_op_tbl :: [(Type, PrimOp)]
1322 [(charPrimTy, CharLtOp)
1323 ,(intPrimTy, IntLtOp)
1324 ,(wordPrimTy, WordLtOp)
1325 ,(addrPrimTy, AddrLtOp)
1326 ,(floatPrimTy, FloatLtOp)
1327 ,(doublePrimTy, DoubleLtOp)
1331 [(charPrimTy, getRdrName charDataCon)
1332 ,(intPrimTy, getRdrName intDataCon)
1333 ,(wordPrimTy, wordDataCon_RDR)
1334 ,(floatPrimTy, getRdrName floatDataCon)
1335 ,(doublePrimTy, getRdrName doubleDataCon)
1338 -----------------------------------------------------------------------
1340 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1341 and_Expr a b = genOpApp a and_RDR b
1343 -----------------------------------------------------------------------
1345 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1346 eq_Expr tycon ty a b = genOpApp a eq_op b
1349 | not (isUnLiftedType ty) = eq_RDR
1350 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1351 -- we have to do something special for primitive things...
1355 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1356 untag_Expr tycon [] expr = expr
1357 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1358 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1359 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1361 cmp_tags_Expr :: RdrName -- Comparison op
1362 -> RdrName -> RdrName -- Things to compare
1363 -> LHsExpr RdrName -- What to return if true
1364 -> LHsExpr RdrName -- What to return if false
1367 cmp_tags_Expr op a b true_case false_case
1368 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1371 :: LHsExpr RdrName -> LHsExpr RdrName
1373 enum_from_then_to_Expr
1374 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1377 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1378 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1381 :: LHsExpr RdrName -> LHsExpr RdrName
1384 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1386 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1388 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1389 nested_compose_Expr [e] = parenify e
1390 nested_compose_Expr (e:es)
1391 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1393 -- impossible_Expr is used in case RHSs that should never happen.
1394 -- We generate these to keep the desugarer from complaining that they *might* happen!
1395 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1397 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1398 -- method. It is currently only used by Enum.{succ,pred}
1399 illegal_Expr meth tp msg =
1400 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1402 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1403 -- to include the value of a_RDR in the error string.
1404 illegal_toEnum_tag tp maxtag =
1405 nlHsApp (nlHsVar error_RDR)
1406 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1407 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1408 (nlHsApp (nlHsApp (nlHsApp
1409 (nlHsVar showsPrec_RDR)
1413 (nlHsVar append_RDR)
1414 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1415 (nlHsApp (nlHsApp (nlHsApp
1416 (nlHsVar showsPrec_RDR)
1419 (nlHsLit (mkHsString ")"))))))
1421 parenify e@(L _ (HsVar _)) = e
1422 parenify e = mkHsPar e
1424 -- genOpApp wraps brackets round the operator application, so that the
1425 -- renamer won't subsequently try to re-associate it.
1426 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1430 getSrcSpan = srcLocSpan . getSrcLoc
1434 a_RDR = mkVarUnqual FSLIT("a")
1435 b_RDR = mkVarUnqual FSLIT("b")
1436 c_RDR = mkVarUnqual FSLIT("c")
1437 d_RDR = mkVarUnqual FSLIT("d")
1438 k_RDR = mkVarUnqual FSLIT("k")
1439 z_RDR = mkVarUnqual FSLIT("z")
1440 ah_RDR = mkVarUnqual FSLIT("a#")
1441 bh_RDR = mkVarUnqual FSLIT("b#")
1442 ch_RDR = mkVarUnqual FSLIT("c#")
1443 dh_RDR = mkVarUnqual FSLIT("d#")
1444 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1446 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1447 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1448 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1450 a_Expr = nlHsVar a_RDR
1451 b_Expr = nlHsVar b_RDR
1452 c_Expr = nlHsVar c_RDR
1453 ltTag_Expr = nlHsVar ltTag_RDR
1454 eqTag_Expr = nlHsVar eqTag_RDR
1455 gtTag_Expr = nlHsVar gtTag_RDR
1456 false_Expr = nlHsVar false_RDR
1457 true_Expr = nlHsVar true_RDR
1459 a_Pat = nlVarPat a_RDR
1460 b_Pat = nlVarPat b_RDR
1461 c_Pat = nlVarPat c_RDR
1462 d_Pat = nlVarPat d_RDR
1463 k_Pat = nlVarPat k_RDR
1464 z_Pat = nlVarPat z_RDR
1466 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1467 -- Generates Orig s RdrName, for the binding positions
1468 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1469 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1470 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1472 mk_tc_deriv_name tycon str
1473 = mkDerivedRdrName tc_name mk_occ
1475 tc_name = tyConName tycon
1476 mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1478 new_str = str ++ occNameString tc_occ ++ "#"
1481 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1482 PrelNames, so PrelNames can't import PrimOp.
1485 primOpRdrName op = getRdrName (primOpId op)
1487 minusInt_RDR = primOpRdrName IntSubOp
1488 eqInt_RDR = primOpRdrName IntEqOp
1489 ltInt_RDR = primOpRdrName IntLtOp
1490 geInt_RDR = primOpRdrName IntGeOp
1491 leInt_RDR = primOpRdrName IntLeOp
1492 tagToEnum_RDR = primOpRdrName TagToEnumOp
1494 error_RDR = getRdrName eRROR_ID