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 )
57 import Char ( isAlpha )
59 import List ( partition, intersperse )
66 %************************************************************************
68 \subsection{Generating code, by derivable class}
70 %************************************************************************
72 %************************************************************************
74 \subsubsection{Generating @Eq@ instance declarations}
76 %************************************************************************
78 Here are the heuristics for the code we generate for @Eq@:
81 Let's assume we have a data type with some (possibly zero) nullary
82 data constructors and some ordinary, non-nullary ones (the rest,
83 also possibly zero of them). Here's an example, with both \tr{N}ullary
84 and \tr{O}rdinary data cons.
86 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
90 For the ordinary constructors (if any), we emit clauses to do The
94 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
95 (==) (O2 a1) (O2 a2) = a1 == a2
96 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
99 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
100 \tr{a2} are \tr{Float#}s, then we have to generate
102 case (a1 `eqFloat#` a2) of
105 for that particular test.
108 If there are any nullary constructors, we emit a catch-all clause of
112 (==) a b = case (con2tag_Foo a) of { a# ->
113 case (con2tag_Foo b) of { b# ->
114 case (a# ==# b#) of {
119 If there aren't any nullary constructors, we emit a simpler
126 For the @(/=)@ method, we normally just use the default method.
128 If the type is an enumeration type, we could/may/should? generate
129 special code that calls @con2tag_Foo@, much like for @(==)@ shown
133 We thought about doing this: If we're also deriving @Ord@ for this
136 instance ... Eq (Foo ...) where
137 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
138 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
140 However, that requires that \tr{Ord <whatever>} was put in the context
141 for the instance decl, which it probably wasn't, so the decls
142 produced don't get through the typechecker.
147 gen_Eq_binds :: TyCon -> LHsBinds RdrName
151 tycon_loc = getSrcSpan tycon
153 (nullary_cons, nonnullary_cons)
154 | isNewTyCon tycon = ([], tyConDataCons tycon)
155 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
158 = if (null nullary_cons) then
159 case maybeTyConSingleCon tycon of
161 Nothing -> -- if cons don't match, then False
162 [([nlWildPat, nlWildPat], false_Expr)]
163 else -- calc. and compare the tags
165 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
166 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
169 mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
170 mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
171 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
174 ------------------------------------------------------------------
177 con1_pat = nlConVarPat data_con_RDR as_needed
178 con2_pat = nlConVarPat data_con_RDR bs_needed
180 data_con_RDR = getRdrName data_con
181 con_arity = length tys_needed
182 as_needed = take con_arity as_RDRs
183 bs_needed = take con_arity bs_RDRs
184 tys_needed = dataConOrigArgTys data_con
186 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
188 nested_eq_expr [] [] [] = true_Expr
189 nested_eq_expr tys as bs
190 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
192 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
195 %************************************************************************
197 \subsubsection{Generating @Ord@ instance declarations}
199 %************************************************************************
201 For a derived @Ord@, we concentrate our attentions on @compare@
203 compare :: a -> a -> Ordering
204 data Ordering = LT | EQ | GT deriving ()
207 We will use the same example data type as above:
209 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
214 We do all the other @Ord@ methods with calls to @compare@:
216 instance ... (Ord <wurble> <wurble>) where
217 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
218 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
219 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
220 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
222 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
223 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
225 -- compare to come...
229 @compare@ always has two parts. First, we use the compared
230 data-constructors' tags to deal with the case of different
233 compare a b = case (con2tag_Foo a) of { a# ->
234 case (con2tag_Foo b) of { b# ->
235 case (a# ==# b#) of {
237 False -> case (a# <# b#) of
242 cmp_eq = ... to come ...
246 We are only left with the ``help'' function @cmp_eq@, to deal with
247 comparing data constructors with the same tag.
249 For the ordinary constructors (if any), we emit the sorta-obvious
250 compare-style stuff; for our example:
252 cmp_eq (O1 a1 b1) (O1 a2 b2)
253 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
255 cmp_eq (O2 a1) (O2 a2)
258 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
259 = case (compare a1 a2) of {
262 EQ -> case compare b1 b2 of {
270 Again, we must be careful about unlifted comparisons. For example,
271 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
275 cmp_eq lt eq gt (O2 a1) (O2 a2)
277 -- or maybe the unfolded equivalent
281 For the remaining nullary constructors, we already know that the
288 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
292 gen_Ord_binds :: TyCon -> LHsBinds RdrName
295 = unitBag compare -- `AndMonoBinds` compare
296 -- The default declaration in PrelBase handles this
298 tycon_loc = getSrcSpan tycon
299 --------------------------------------------------------------------
301 compare = L tycon_loc (FunBind (L tycon_loc compare_RDR) False compare_matches placeHolderNames)
302 compare_matches = mkMatchGroup [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
303 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
306 | single_con_type = cmp_eq_Expr a_Expr b_Expr
308 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
309 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
310 (cmp_eq_Expr a_Expr b_Expr) -- True case
311 -- False case; they aren't equal
312 -- So we need to do a less-than comparison on the tags
313 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
315 tycon_data_cons = tyConDataCons tycon
316 single_con_type = isSingleton tycon_data_cons
317 (nullary_cons, nonnullary_cons)
318 | isNewTyCon tycon = ([], tyConDataCons tycon)
319 | otherwise = partition isNullarySrcDataCon tycon_data_cons
321 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
323 | isEnumerationTyCon tycon
324 -- We know the tags are equal, so if it's an enumeration TyCon,
325 -- then there is nothing left to do
326 -- Catch this specially to avoid warnings
327 -- about overlapping patterns from the desugarer,
328 -- and to avoid unnecessary pattern-matching
329 = [([nlWildPat,nlWildPat], eqTag_Expr)]
331 = map pats_etc nonnullary_cons ++
332 (if single_con_type then -- Omit wildcards when there's just one
333 [] -- constructor, to silence desugarer
335 [([nlWildPat, nlWildPat], default_rhs)])
339 = ([con1_pat, con2_pat],
340 nested_compare_expr tys_needed as_needed bs_needed)
342 con1_pat = nlConVarPat data_con_RDR as_needed
343 con2_pat = nlConVarPat data_con_RDR bs_needed
345 data_con_RDR = getRdrName data_con
346 con_arity = length tys_needed
347 as_needed = take con_arity as_RDRs
348 bs_needed = take con_arity bs_RDRs
349 tys_needed = dataConOrigArgTys data_con
351 nested_compare_expr [ty] [a] [b]
352 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
354 nested_compare_expr (ty:tys) (a:as) (b:bs)
355 = let eq_expr = nested_compare_expr tys as bs
356 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
358 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
359 -- inexhaustive patterns
360 | otherwise = eqTag_Expr -- Some nullary constructors;
361 -- Tags are equal, no args => return EQ
364 %************************************************************************
366 \subsubsection{Generating @Enum@ instance declarations}
368 %************************************************************************
370 @Enum@ can only be derived for enumeration types. For a type
372 data Foo ... = N1 | N2 | ... | Nn
375 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
376 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
379 instance ... Enum (Foo ...) where
380 succ x = toEnum (1 + fromEnum x)
381 pred x = toEnum (fromEnum x - 1)
383 toEnum i = tag2con_Foo i
385 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
389 = case con2tag_Foo a of
390 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
393 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
397 = case con2tag_Foo a of { a# ->
398 case con2tag_Foo b of { b# ->
399 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
403 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
406 gen_Enum_binds :: TyCon -> LHsBinds RdrName
418 tycon_loc = getSrcSpan tycon
419 occ_nm = getOccString tycon
422 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
423 untag_Expr tycon [(a_RDR, ah_RDR)] $
424 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
425 nlHsVarApps intDataCon_RDR [ah_RDR]])
426 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
427 (nlHsApp (nlHsVar (tag2con_RDR tycon))
428 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
432 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
433 untag_Expr tycon [(a_RDR, ah_RDR)] $
434 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
435 nlHsVarApps intDataCon_RDR [ah_RDR]])
436 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
437 (nlHsApp (nlHsVar (tag2con_RDR tycon))
438 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
439 nlHsLit (HsInt (-1))]))
442 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
443 nlHsIf (nlHsApps and_RDR
444 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
445 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
446 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
447 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
450 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
451 untag_Expr tycon [(a_RDR, ah_RDR)] $
453 [nlHsVar (tag2con_RDR tycon),
454 nlHsPar (enum_from_to_Expr
455 (nlHsVarApps intDataCon_RDR [ah_RDR])
456 (nlHsVar (maxtag_RDR tycon)))]
459 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
460 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
461 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
462 nlHsPar (enum_from_then_to_Expr
463 (nlHsVarApps intDataCon_RDR [ah_RDR])
464 (nlHsVarApps intDataCon_RDR [bh_RDR])
465 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
466 nlHsVarApps intDataCon_RDR [bh_RDR]])
468 (nlHsVar (maxtag_RDR tycon))
472 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
473 untag_Expr tycon [(a_RDR, ah_RDR)] $
474 (nlHsVarApps intDataCon_RDR [ah_RDR])
477 %************************************************************************
479 \subsubsection{Generating @Bounded@ instance declarations}
481 %************************************************************************
484 gen_Bounded_binds tycon
485 = if isEnumerationTyCon tycon then
486 listToBag [ min_bound_enum, max_bound_enum ]
488 ASSERT(isSingleton data_cons)
489 listToBag [ min_bound_1con, max_bound_1con ]
491 data_cons = tyConDataCons tycon
492 tycon_loc = getSrcSpan tycon
494 ----- enum-flavored: ---------------------------
495 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
496 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
498 data_con_1 = head data_cons
499 data_con_N = last data_cons
500 data_con_1_RDR = getRdrName data_con_1
501 data_con_N_RDR = getRdrName data_con_N
503 ----- single-constructor-flavored: -------------
504 arity = dataConSourceArity data_con_1
506 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
507 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
508 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
509 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
512 %************************************************************************
514 \subsubsection{Generating @Ix@ instance declarations}
516 %************************************************************************
518 Deriving @Ix@ is only possible for enumeration types and
519 single-constructor types. We deal with them in turn.
521 For an enumeration type, e.g.,
523 data Foo ... = N1 | N2 | ... | Nn
525 things go not too differently from @Enum@:
527 instance ... Ix (Foo ...) where
529 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
533 = case (con2tag_Foo a) of { a# ->
534 case (con2tag_Foo b) of { b# ->
535 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
538 -- Generate code for unsafeIndex, becuase using index leads
539 -- to lots of redundant range tests
540 unsafeIndex c@(a, b) d
541 = case (con2tag_Foo d -# con2tag_Foo a) of
546 p_tag = con2tag_Foo c
548 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
552 = case (con2tag_Foo a) of { a_tag ->
553 case (con2tag_Foo b) of { b_tag ->
554 case (con2tag_Foo c) of { c_tag ->
555 if (c_tag >=# a_tag) then
561 (modulo suitable case-ification to handle the unlifted tags)
563 For a single-constructor type (NB: this includes all tuples), e.g.,
565 data Foo ... = MkFoo a b Int Double c c
567 we follow the scheme given in Figure~19 of the Haskell~1.2 report
571 gen_Ix_binds :: TyCon -> LHsBinds RdrName
574 = if isEnumerationTyCon tycon
578 tycon_loc = getSrcSpan tycon
580 --------------------------------------------------------------
581 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
584 = mk_easy_FunBind tycon_loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
585 untag_Expr tycon [(a_RDR, ah_RDR)] $
586 untag_Expr tycon [(b_RDR, bh_RDR)] $
587 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
588 nlHsPar (enum_from_to_Expr
589 (nlHsVarApps intDataCon_RDR [ah_RDR])
590 (nlHsVarApps intDataCon_RDR [bh_RDR]))
593 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
594 [noLoc (AsPat (noLoc c_RDR)
595 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
597 untag_Expr tycon [(a_RDR, ah_RDR)] (
598 untag_Expr tycon [(d_RDR, dh_RDR)] (
600 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
603 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
604 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
609 = mk_easy_FunBind tycon_loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
610 untag_Expr tycon [(a_RDR, ah_RDR)] (
611 untag_Expr tycon [(b_RDR, bh_RDR)] (
612 untag_Expr tycon [(c_RDR, ch_RDR)] (
613 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
614 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
619 --------------------------------------------------------------
621 = listToBag [single_con_range, single_con_index, single_con_inRange]
624 = case maybeTyConSingleCon tycon of -- just checking...
625 Nothing -> panic "get_Ix_binds"
626 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
627 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
630 con_arity = dataConSourceArity data_con
631 data_con_RDR = getRdrName data_con
633 as_needed = take con_arity as_RDRs
634 bs_needed = take con_arity bs_RDRs
635 cs_needed = take con_arity cs_RDRs
637 con_pat xs = nlConVarPat data_con_RDR xs
638 con_expr = nlHsVarApps data_con_RDR cs_needed
640 --------------------------------------------------------------
642 = mk_easy_FunBind tycon_loc range_RDR
643 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
644 nlHsDo ListComp stmts con_expr
646 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
648 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
649 (nlHsApp (nlHsVar range_RDR)
650 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
654 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
655 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
657 (mk_index (zip3 as_needed bs_needed cs_needed))
659 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
660 mk_index [] = nlHsIntLit 0
661 mk_index [(l,u,i)] = mk_one l u i
662 mk_index ((l,u,i) : rest)
667 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
668 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
669 ) times_RDR (mk_index rest)
672 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
676 = mk_easy_FunBind tycon_loc inRange_RDR
677 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
679 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
681 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
685 %************************************************************************
687 \subsubsection{Generating @Read@ instance declarations}
689 %************************************************************************
699 instance Read T where
703 do x <- ReadP.step Read.readPrec
704 Symbol "%%" <- Lex.lex
705 y <- ReadP.step Read.readPrec
709 do Ident "T1" <- Lex.lex
711 Ident "f1" <- Lex.lex
713 x <- ReadP.reset Read.readPrec
715 return (T1 { f1 = x }))
718 do Ident "T2" <- Lex.lexP
719 x <- ReadP.step Read.readPrec
723 readListPrec = readListPrecDefault
724 readList = readListDefault
728 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
730 gen_Read_binds get_fixity tycon
731 = listToBag [read_prec, default_readlist, default_readlistprec]
733 -----------------------------------------------------------------------
735 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
738 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
739 -----------------------------------------------------------------------
741 loc = getSrcSpan tycon
742 data_cons = tyConDataCons tycon
743 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
745 read_prec = mkVarBind loc readPrec_RDR
746 (nlHsApp (nlHsVar parens_RDR) read_cons)
748 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
749 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
752 = case nullary_cons of
754 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
755 (result_expr con [])]
756 _ -> [nlHsApp (nlHsVar choose_RDR)
757 (nlList (map mk_pair nullary_cons))]
759 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
760 nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
763 read_non_nullary_con data_con
764 = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body]
766 stmts | is_infix = infix_stmts
767 | length labels > 0 = lbl_stmts
768 | otherwise = prefix_stmts
770 body = result_expr data_con as_needed
771 con_str = data_con_str data_con
773 prefix_stmts -- T a b c
774 = [bindLex (ident_pat (wrapOpParens con_str))]
777 infix_stmts -- a %% b, or a `T` b
780 then [bindLex (symbol_pat con_str)]
781 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
784 lbl_stmts -- T { f1 = a, f2 = b }
785 = [bindLex (ident_pat (wrapOpParens con_str)),
787 ++ concat (intersperse [read_punc ","] field_stmts)
790 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
792 con_arity = dataConSourceArity data_con
793 labels = dataConFieldLabels data_con
794 dc_nm = getName data_con
795 is_infix = dataConIsInfix data_con
796 as_needed = take con_arity as_RDRs
797 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
798 (read_a1:read_a2:_) = read_args
799 prec = getPrec is_infix get_fixity dc_nm
801 ------------------------------------------------------------------------
803 ------------------------------------------------------------------------
804 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
805 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))
806 con_app c as = nlHsVarApps (getRdrName c) as
807 result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as)
809 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
810 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
811 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
813 data_con_str con = occNameUserString (getOccName con)
815 read_punc c = bindLex (punc_pat c)
817 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
818 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
820 read_field lbl a = read_lbl lbl ++
822 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
824 -- When reading field labels we might encounter
829 read_lbl lbl | isSym lbl_str
831 bindLex (symbol_pat lbl_str),
834 = [bindLex (ident_pat lbl_str)]
836 lbl_str = occNameUserString (getOccName lbl)
840 %************************************************************************
842 \subsubsection{Generating @Show@ instance declarations}
844 %************************************************************************
850 data Tree a = Leaf a | Tree a :^: Tree a
852 instance (Show a) => Show (Tree a) where
854 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
856 showStr = showString "Leaf " . showsPrec (app_prec+1) m
858 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
860 showStr = showsPrec (up_prec+1) u .
862 showsPrec (up_prec+1) v
863 -- Note: right-associativity of :^: ignored
865 up_prec = 5 -- Precedence of :^:
866 app_prec = 10 -- Application has precedence one more than
867 -- the most tightly-binding operator
870 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
872 gen_Show_binds get_fixity tycon
873 = listToBag [shows_prec, show_list]
875 tycon_loc = getSrcSpan tycon
876 -----------------------------------------------------------------------
877 show_list = mkVarBind tycon_loc showList_RDR
878 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
879 -----------------------------------------------------------------------
880 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
883 | nullary_con = -- skip the showParen junk...
884 ASSERT(null bs_needed)
885 ([nlWildPat, con_pat], mk_showString_app con_str)
888 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
889 (nlHsPar (nested_compose_Expr show_thingies)))
891 data_con_RDR = getRdrName data_con
892 con_arity = dataConSourceArity data_con
893 bs_needed = take con_arity bs_RDRs
894 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
895 con_pat = nlConVarPat data_con_RDR bs_needed
896 nullary_con = con_arity == 0
897 labels = dataConFieldLabels data_con
898 lab_fields = length labels
899 record_syntax = lab_fields > 0
901 dc_nm = getName data_con
902 dc_occ_nm = getOccName data_con
903 con_str = occNameUserString dc_occ_nm
904 op_con_str = wrapOpParens con_str
905 backquote_str = wrapOpBackquotes con_str
908 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
909 | record_syntax = mk_showString_app (op_con_str ++ " {") :
910 show_record_args ++ [mk_showString_app "}"]
911 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
913 show_label l = mk_showString_app (nm ++ " = ")
914 -- Note the spaces around the "=" sign. If we don't have them
915 -- then we get Foo { x=-1 } and the "=-" parses as a single
916 -- lexeme. Only the space after the '=' is necessary, but
917 -- it seems tidier to have them both sides.
919 occ_nm = getOccName l
920 nm = wrapOpParens (occNameUserString occ_nm)
922 show_args = zipWith show_arg bs_needed arg_tys
923 (show_arg1:show_arg2:_) = show_args
924 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
926 -- Assumption for record syntax: no of fields == no of labelled fields
927 -- (and in same order)
928 show_record_args = concat $
929 intersperse [mk_showString_app ", "] $
930 [ [show_label lbl, arg]
931 | (lbl,arg) <- zipEqual "gen_Show_binds"
934 -- Generates (showsPrec p x) for argument x, but it also boxes
935 -- the argument first if necessary. Note that this prints unboxed
936 -- things without any '#' decorations; could change that if need be
937 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
938 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
941 is_infix = dataConIsInfix data_con
942 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
943 arg_prec | record_syntax = 0 -- Record fields don't need parens
944 | otherwise = con_prec_plus_one
946 wrapOpParens :: String -> String
947 wrapOpParens s | isSym s = '(' : s ++ ")"
950 wrapOpBackquotes :: String -> String
951 wrapOpBackquotes s | isSym s = s
952 | otherwise = '`' : s ++ "`"
954 isSym :: String -> Bool
956 isSym (c:cs) = startsVarSym c || startsConSym c
958 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
962 getPrec :: Bool -> FixityEnv -> Name -> Integer
963 getPrec is_infix get_fixity nm
964 | not is_infix = appPrecedence
965 | otherwise = getPrecedence get_fixity nm
967 appPrecedence :: Integer
968 appPrecedence = fromIntegral maxPrecedence + 1
969 -- One more than the precedence of the most
970 -- tightly-binding operator
972 getPrecedence :: FixityEnv -> Name -> Integer
973 getPrecedence get_fixity nm
974 = case lookupFixity get_fixity nm of
975 Fixity x _ -> fromIntegral x
979 %************************************************************************
981 \subsection{Typeable}
983 %************************************************************************
991 instance Typeable2 T where
992 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
994 We are passed the Typeable2 class as well as T
997 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
998 gen_Typeable_binds tycon
1000 mk_easy_FunBind tycon_loc
1001 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1003 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1005 tycon_loc = getSrcSpan tycon
1006 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1008 mk_typeOf_RDR :: TyCon -> RdrName
1009 -- Use the arity of the TyCon to make the right typeOfn function
1010 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1012 arity = tyConArity tycon
1013 suffix | arity == 0 = ""
1014 | otherwise = show arity
1019 %************************************************************************
1023 %************************************************************************
1027 data T a b = T1 a b | T2
1031 $cT1 = mkDataCon $dT "T1" Prefix
1032 $cT2 = mkDataCon $dT "T2" Prefix
1033 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1034 -- the [] is for field labels.
1036 instance (Data a, Data b) => Data (T a b) where
1037 gfoldl k z (T1 a b) = z T `k` a `k` b
1038 gfoldl k z T2 = z T2
1039 -- ToDo: add gmapT,Q,M, gfoldr
1041 gunfold k z c = case conIndex c of
1042 I# 1# -> k (k (z T1))
1045 toConstr (T1 _ _) = $cT1
1051 gen_Data_binds :: FixityEnv
1053 -> (LHsBinds RdrName, -- The method bindings
1054 LHsBinds RdrName) -- Auxiliary bindings
1055 gen_Data_binds fix_env tycon
1056 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1057 -- Auxiliary definitions: the data type and constructors
1058 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1060 tycon_loc = getSrcSpan tycon
1061 tycon_name = tyConName tycon
1062 data_cons = tyConDataCons tycon
1063 n_cons = length data_cons
1064 one_constr = n_cons == 1
1067 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1068 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1069 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1072 con_name = getRdrName con
1073 as_needed = take (dataConSourceArity con) as_RDRs
1074 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1076 ------------ gunfold
1077 gunfold_bind = mk_FunBind tycon_loc
1079 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1083 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1084 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1085 (map gunfold_alt data_cons)
1087 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1088 mk_unfold_rhs dc = foldr nlHsApp
1089 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1090 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1092 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1093 -- redundant test, and annoying warning
1094 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1095 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1099 ------------ toConstr
1100 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1101 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1103 ------------ dataTypeOf
1104 dataTypeOf_bind = mk_easy_FunBind
1108 (nlHsVar data_type_name)
1112 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1113 datatype_bind = mkVarBind
1116 ( nlHsVar mkDataType_RDR
1117 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1118 `nlHsApp` nlList constrs
1120 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1123 ------------ $cT1 etc
1124 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1125 mk_con_bind dc = mkVarBind
1128 (nlHsApps mkConstr_RDR (constr_args dc))
1130 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1131 nlHsVar data_type_name, -- DataType
1132 nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name
1133 nlList labels, -- Field labels
1134 nlHsVar fixity] -- Fixity
1136 labels = map (nlHsLit . mkHsString . getOccString)
1137 (dataConFieldLabels dc)
1138 dc_occ = getOccName dc
1139 is_infix = isDataSymOcc dc_occ
1140 fixity | is_infix = infix_RDR
1141 | otherwise = prefix_RDR
1143 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1144 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1145 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1146 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1147 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1148 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1149 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1150 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1151 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1154 %************************************************************************
1156 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1158 %************************************************************************
1163 con2tag_Foo :: Foo ... -> Int#
1164 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1165 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1168 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1173 = GenCon2Tag | GenTag2Con | GenMaxTag
1175 gen_tag_n_con_monobind
1176 :: ( RdrName, -- (proto)Name for the thing in question
1177 TyCon, -- tycon in question
1181 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1182 | lots_of_constructors
1183 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1186 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1189 tycon_loc = getSrcSpan tycon
1191 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1192 -- We can't use gerRdrName because that makes an Exact RdrName
1193 -- and we can't put them in the LocalRdrEnv
1195 -- Give a signature to the bound variable, so
1196 -- that the case expression generated by getTag is
1197 -- monomorphic. In the push-enter model we get better code.
1198 get_tag_rhs = noLoc $ ExprWithTySig
1199 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1200 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1201 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1203 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1206 nlHsTyVar (getRdrName intPrimTyCon)
1208 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1210 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1211 mk_stuff con = ([nlWildConPat con],
1212 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1214 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1215 = mk_FunBind (getSrcSpan tycon) rdr_name
1216 [([nlConVarPat intDataCon_RDR [a_RDR]],
1217 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1218 (nlHsTyVar (getRdrName tycon))))]
1220 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1221 = mkVarBind (getSrcSpan tycon) rdr_name
1222 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1224 max_tag = case (tyConDataCons tycon) of
1225 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1229 %************************************************************************
1231 \subsection{Utility bits for generating bindings}
1233 %************************************************************************
1236 ToDo: Better SrcLocs.
1240 LHsExpr RdrName -- What to do for equality
1241 -> LHsExpr RdrName -> LHsExpr RdrName
1243 careful_compare_Case :: -- checks for primitive types...
1244 TyCon -- The tycon we are deriving for
1246 -> LHsExpr RdrName -- What to do for equality
1247 -> LHsExpr RdrName -> LHsExpr RdrName
1250 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1251 -- Was: compare_gen_Case cmp_eq_RDR
1253 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1254 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1255 compare_gen_Case eq a b -- General case
1256 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1257 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1258 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1259 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1261 careful_compare_Case tycon ty eq a b
1262 | not (isUnLiftedType ty)
1263 = compare_gen_Case eq a b
1264 | otherwise -- We have to do something special for primitive things...
1265 = nlHsIf (genOpApp a relevant_eq_op b)
1267 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1269 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1270 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1273 box_if_necy :: String -- The class involved
1274 -> TyCon -- The tycon involved
1275 -> LHsExpr RdrName -- The argument
1276 -> Type -- The argument type
1277 -> LHsExpr RdrName -- Boxed version of the arg
1278 box_if_necy cls_str tycon arg arg_ty
1279 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1282 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1284 assoc_ty_id :: String -- The class involved
1285 -> TyCon -- The tycon involved
1286 -> [(Type,a)] -- The table
1288 -> a -- The result of the lookup
1289 assoc_ty_id cls_str tycon tbl ty
1290 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1291 text "for primitive type" <+> ppr ty)
1292 | otherwise = head res
1294 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1296 eq_op_tbl :: [(Type, PrimOp)]
1298 [(charPrimTy, CharEqOp)
1299 ,(intPrimTy, IntEqOp)
1300 ,(wordPrimTy, WordEqOp)
1301 ,(addrPrimTy, AddrEqOp)
1302 ,(floatPrimTy, FloatEqOp)
1303 ,(doublePrimTy, DoubleEqOp)
1306 lt_op_tbl :: [(Type, PrimOp)]
1308 [(charPrimTy, CharLtOp)
1309 ,(intPrimTy, IntLtOp)
1310 ,(wordPrimTy, WordLtOp)
1311 ,(addrPrimTy, AddrLtOp)
1312 ,(floatPrimTy, FloatLtOp)
1313 ,(doublePrimTy, DoubleLtOp)
1317 [(charPrimTy, getRdrName charDataCon)
1318 ,(intPrimTy, getRdrName intDataCon)
1319 ,(wordPrimTy, wordDataCon_RDR)
1320 ,(addrPrimTy, addrDataCon_RDR)
1321 ,(floatPrimTy, getRdrName floatDataCon)
1322 ,(doublePrimTy, getRdrName doubleDataCon)
1325 -----------------------------------------------------------------------
1327 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1328 and_Expr a b = genOpApp a and_RDR b
1330 -----------------------------------------------------------------------
1332 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1333 eq_Expr tycon ty a b = genOpApp a eq_op b
1336 | not (isUnLiftedType ty) = eq_RDR
1337 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1338 -- we have to do something special for primitive things...
1342 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1343 untag_Expr tycon [] expr = expr
1344 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1345 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1346 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1348 cmp_tags_Expr :: RdrName -- Comparison op
1349 -> RdrName -> RdrName -- Things to compare
1350 -> LHsExpr RdrName -- What to return if true
1351 -> LHsExpr RdrName -- What to return if false
1354 cmp_tags_Expr op a b true_case false_case
1355 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1358 :: LHsExpr RdrName -> LHsExpr RdrName
1360 enum_from_then_to_Expr
1361 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1364 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1365 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1368 :: LHsExpr RdrName -> LHsExpr RdrName
1371 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1373 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1375 nested_compose_Expr [e] = parenify e
1376 nested_compose_Expr (e:es)
1377 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1379 -- impossible_Expr is used in case RHSs that should never happen.
1380 -- We generate these to keep the desugarer from complaining that they *might* happen!
1381 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1383 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1384 -- method. It is currently only used by Enum.{succ,pred}
1385 illegal_Expr meth tp msg =
1386 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1388 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1389 -- to include the value of a_RDR in the error string.
1390 illegal_toEnum_tag tp maxtag =
1391 nlHsApp (nlHsVar error_RDR)
1392 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1393 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1394 (nlHsApp (nlHsApp (nlHsApp
1395 (nlHsVar showsPrec_RDR)
1399 (nlHsVar append_RDR)
1400 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1401 (nlHsApp (nlHsApp (nlHsApp
1402 (nlHsVar showsPrec_RDR)
1405 (nlHsLit (mkHsString ")"))))))
1407 parenify e@(L _ (HsVar _)) = e
1408 parenify e = mkHsPar e
1410 -- genOpApp wraps brackets round the operator application, so that the
1411 -- renamer won't subsequently try to re-associate it.
1412 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1416 getSrcSpan = srcLocSpan . getSrcLoc
1420 a_RDR = mkVarUnqual FSLIT("a")
1421 b_RDR = mkVarUnqual FSLIT("b")
1422 c_RDR = mkVarUnqual FSLIT("c")
1423 d_RDR = mkVarUnqual FSLIT("d")
1424 k_RDR = mkVarUnqual FSLIT("k")
1425 z_RDR = mkVarUnqual FSLIT("z")
1426 ah_RDR = mkVarUnqual FSLIT("a#")
1427 bh_RDR = mkVarUnqual FSLIT("b#")
1428 ch_RDR = mkVarUnqual FSLIT("c#")
1429 dh_RDR = mkVarUnqual FSLIT("d#")
1430 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1432 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1433 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1434 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1436 a_Expr = nlHsVar a_RDR
1437 b_Expr = nlHsVar b_RDR
1438 c_Expr = nlHsVar c_RDR
1439 ltTag_Expr = nlHsVar ltTag_RDR
1440 eqTag_Expr = nlHsVar eqTag_RDR
1441 gtTag_Expr = nlHsVar gtTag_RDR
1442 false_Expr = nlHsVar false_RDR
1443 true_Expr = nlHsVar true_RDR
1445 a_Pat = nlVarPat a_RDR
1446 b_Pat = nlVarPat b_RDR
1447 c_Pat = nlVarPat c_RDR
1448 d_Pat = nlVarPat d_RDR
1449 k_Pat = nlVarPat k_RDR
1450 z_Pat = nlVarPat z_RDR
1452 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1453 -- Generates Orig s RdrName, for the binding positions
1454 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1455 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1456 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1458 mk_tc_deriv_name tycon str
1459 = mkDerivedRdrName tc_name mk_occ
1461 tc_name = tyConName tycon
1462 mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1464 new_str = str ++ occNameString tc_occ ++ "#"
1467 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1468 PrelNames, so PrelNames can't import PrimOp.
1471 primOpRdrName op = getRdrName (primOpId op)
1473 minusInt_RDR = primOpRdrName IntSubOp
1474 eqInt_RDR = primOpRdrName IntEqOp
1475 ltInt_RDR = primOpRdrName IntLtOp
1476 geInt_RDR = primOpRdrName IntGeOp
1477 leInt_RDR = primOpRdrName IntLeOp
1478 tagToEnum_RDR = primOpRdrName TagToEnumOp
1480 error_RDR = getRdrName eRROR_ID