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] emptyLHsBinds (
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 = mk_easy_FunBind tycon_loc compare_RDR
302 [a_Pat, b_Pat] (unitBag cmp_eq) compare_rhs
304 | single_con_type = cmp_eq_Expr a_Expr b_Expr
306 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
307 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
308 (cmp_eq_Expr a_Expr b_Expr) -- True case
309 -- False case; they aren't equal
310 -- So we need to do a less-than comparison on the tags
311 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
313 tycon_data_cons = tyConDataCons tycon
314 single_con_type = isSingleton tycon_data_cons
315 (nullary_cons, nonnullary_cons)
316 | isNewTyCon tycon = ([], tyConDataCons tycon)
317 | otherwise = partition isNullarySrcDataCon tycon_data_cons
319 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
321 | isEnumerationTyCon tycon
322 -- We know the tags are equal, so if it's an enumeration TyCon,
323 -- then there is nothing left to do
324 -- Catch this specially to avoid warnings
325 -- about overlapping patterns from the desugarer,
326 -- and to avoid unnecessary pattern-matching
327 = [([nlWildPat,nlWildPat], eqTag_Expr)]
329 = map pats_etc nonnullary_cons ++
330 (if single_con_type then -- Omit wildcards when there's just one
331 [] -- constructor, to silence desugarer
333 [([nlWildPat, nlWildPat], default_rhs)])
337 = ([con1_pat, con2_pat],
338 nested_compare_expr tys_needed as_needed bs_needed)
340 con1_pat = nlConVarPat data_con_RDR as_needed
341 con2_pat = nlConVarPat data_con_RDR bs_needed
343 data_con_RDR = getRdrName data_con
344 con_arity = length tys_needed
345 as_needed = take con_arity as_RDRs
346 bs_needed = take con_arity bs_RDRs
347 tys_needed = dataConOrigArgTys data_con
349 nested_compare_expr [ty] [a] [b]
350 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
352 nested_compare_expr (ty:tys) (a:as) (b:bs)
353 = let eq_expr = nested_compare_expr tys as bs
354 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
356 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
357 -- inexhaustive patterns
358 | otherwise = eqTag_Expr -- Some nullary constructors;
359 -- Tags are equal, no args => return EQ
362 %************************************************************************
364 \subsubsection{Generating @Enum@ instance declarations}
366 %************************************************************************
368 @Enum@ can only be derived for enumeration types. For a type
370 data Foo ... = N1 | N2 | ... | Nn
373 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
374 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
377 instance ... Enum (Foo ...) where
378 succ x = toEnum (1 + fromEnum x)
379 pred x = toEnum (fromEnum x - 1)
381 toEnum i = tag2con_Foo i
383 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
387 = case con2tag_Foo a of
388 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
391 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
395 = case con2tag_Foo a of { a# ->
396 case con2tag_Foo b of { b# ->
397 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
401 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
404 gen_Enum_binds :: TyCon -> LHsBinds RdrName
416 tycon_loc = getSrcSpan tycon
417 occ_nm = getOccString tycon
420 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyLHsBinds $
421 untag_Expr tycon [(a_RDR, ah_RDR)] $
422 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
423 nlHsVarApps intDataCon_RDR [ah_RDR]])
424 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
425 (nlHsApp (nlHsVar (tag2con_RDR tycon))
426 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
430 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyLHsBinds $
431 untag_Expr tycon [(a_RDR, ah_RDR)] $
432 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
433 nlHsVarApps intDataCon_RDR [ah_RDR]])
434 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
435 (nlHsApp (nlHsVar (tag2con_RDR tycon))
436 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
437 nlHsLit (HsInt (-1))]))
440 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyLHsBinds $
441 nlHsIf (nlHsApps and_RDR
442 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
443 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
444 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
445 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
448 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyLHsBinds $
449 untag_Expr tycon [(a_RDR, ah_RDR)] $
451 [nlHsVar (tag2con_RDR tycon),
452 nlHsPar (enum_from_to_Expr
453 (nlHsVarApps intDataCon_RDR [ah_RDR])
454 (nlHsVar (maxtag_RDR tycon)))]
457 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyLHsBinds $
458 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
459 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
460 nlHsPar (enum_from_then_to_Expr
461 (nlHsVarApps intDataCon_RDR [ah_RDR])
462 (nlHsVarApps intDataCon_RDR [bh_RDR])
463 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
464 nlHsVarApps intDataCon_RDR [bh_RDR]])
466 (nlHsVar (maxtag_RDR tycon))
470 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyLHsBinds $
471 untag_Expr tycon [(a_RDR, ah_RDR)] $
472 (nlHsVarApps intDataCon_RDR [ah_RDR])
475 %************************************************************************
477 \subsubsection{Generating @Bounded@ instance declarations}
479 %************************************************************************
482 gen_Bounded_binds tycon
483 = if isEnumerationTyCon tycon then
484 listToBag [ min_bound_enum, max_bound_enum ]
486 ASSERT(isSingleton data_cons)
487 listToBag [ min_bound_1con, max_bound_1con ]
489 data_cons = tyConDataCons tycon
490 tycon_loc = getSrcSpan tycon
492 ----- enum-flavored: ---------------------------
493 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
494 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
496 data_con_1 = head data_cons
497 data_con_N = last data_cons
498 data_con_1_RDR = getRdrName data_con_1
499 data_con_N_RDR = getRdrName data_con_N
501 ----- single-constructor-flavored: -------------
502 arity = dataConSourceArity data_con_1
504 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
505 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
506 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
507 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
510 %************************************************************************
512 \subsubsection{Generating @Ix@ instance declarations}
514 %************************************************************************
516 Deriving @Ix@ is only possible for enumeration types and
517 single-constructor types. We deal with them in turn.
519 For an enumeration type, e.g.,
521 data Foo ... = N1 | N2 | ... | Nn
523 things go not too differently from @Enum@:
525 instance ... Ix (Foo ...) where
527 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
531 = case (con2tag_Foo a) of { a# ->
532 case (con2tag_Foo b) of { b# ->
533 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
536 -- Generate code for unsafeIndex, becuase using index leads
537 -- to lots of redundant range tests
538 unsafeIndex c@(a, b) d
539 = case (con2tag_Foo d -# con2tag_Foo a) of
544 p_tag = con2tag_Foo c
546 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
550 = case (con2tag_Foo a) of { a_tag ->
551 case (con2tag_Foo b) of { b_tag ->
552 case (con2tag_Foo c) of { c_tag ->
553 if (c_tag >=# a_tag) then
559 (modulo suitable case-ification to handle the unlifted tags)
561 For a single-constructor type (NB: this includes all tuples), e.g.,
563 data Foo ... = MkFoo a b Int Double c c
565 we follow the scheme given in Figure~19 of the Haskell~1.2 report
569 gen_Ix_binds :: TyCon -> LHsBinds RdrName
572 = if isEnumerationTyCon tycon
576 tycon_loc = getSrcSpan tycon
578 --------------------------------------------------------------
579 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
582 = mk_easy_FunBind tycon_loc range_RDR
583 [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $
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)),
595 d_Pat] emptyLHsBinds (
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
609 [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds (
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] emptyLHsBinds $
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,
656 con_pat cs_needed] emptyBag
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,
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 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 (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 | length labels > 0 = lbl_stmts
769 | otherwise = prefix_stmts
771 body = result_expr data_con as_needed
773 prefix_stmts -- T a b c
774 = [bindLex (ident_pat (data_con_str_w_parens data_con))]
777 infix_stmts -- a %% b
779 bindLex (symbol_pat (data_con_str data_con)),
782 lbl_stmts -- T { f1 = a, f2 = b }
783 = [bindLex (ident_pat (data_con_str_w_parens data_con)),
785 ++ concat (intersperse [read_punc ","] field_stmts)
788 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
790 con_arity = dataConSourceArity data_con
791 labels = dataConFieldLabels data_con
792 dc_nm = getName data_con
793 is_infix = dataConIsInfix data_con
794 as_needed = take con_arity as_RDRs
795 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
796 (read_a1:read_a2:_) = read_args
797 prec = getPrec is_infix get_fixity dc_nm
799 ------------------------------------------------------------------------
801 ------------------------------------------------------------------------
802 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
803 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))
804 con_app c as = nlHsVarApps (getRdrName c) as
805 result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as)
807 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
808 ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo"
809 symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>"
811 data_con_str con = mkHsString (occNameUserString (getOccName con))
812 data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
814 read_punc c = bindLex (punc_pat c)
816 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
817 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
819 read_field lbl a = read_lbl lbl ++
821 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
823 -- When reading field labels we might encounter
828 read_lbl lbl | is_id_start (head lbl_str)
829 = [bindLex (ident_pat lbl_lit)]
832 bindLex (symbol_pat lbl_lit),
835 lbl_str = occNameUserString (getOccName lbl)
836 lbl_lit = mkHsString lbl_str
837 is_id_start c = isAlpha c || c == '_'
841 %************************************************************************
843 \subsubsection{Generating @Show@ instance declarations}
845 %************************************************************************
851 data Tree a = Leaf a | Tree a :^: Tree a
853 instance (Show a) => Show (Tree a) where
855 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
857 showStr = showString "Leaf " . showsPrec (app_prec+1) m
859 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
861 showStr = showsPrec (up_prec+1) u .
863 showsPrec (up_prec+1) v
864 -- Note: right-associativity of :^: ignored
866 up_prec = 5 -- Precedence of :^:
867 app_prec = 10 -- Application has precedence one more than
868 -- the most tightly-binding operator
871 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
873 gen_Show_binds get_fixity tycon
874 = listToBag [shows_prec, show_list]
876 tycon_loc = getSrcSpan tycon
877 -----------------------------------------------------------------------
878 show_list = mkVarBind tycon_loc showList_RDR
879 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
880 -----------------------------------------------------------------------
881 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
884 | nullary_con = -- skip the showParen junk...
885 ASSERT(null bs_needed)
886 ([nlWildPat, con_pat], mk_showString_app con_str)
889 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
890 (nlHsPar (nested_compose_Expr show_thingies)))
892 data_con_RDR = getRdrName data_con
893 con_arity = dataConSourceArity data_con
894 bs_needed = take con_arity bs_RDRs
895 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
896 con_pat = nlConVarPat data_con_RDR bs_needed
897 nullary_con = con_arity == 0
898 labels = dataConFieldLabels data_con
899 lab_fields = length labels
900 record_syntax = lab_fields > 0
902 dc_nm = getName data_con
903 dc_occ_nm = getOccName data_con
904 con_str = occNameUserString dc_occ_nm
905 op_con_str = occNameUserString_with_parens dc_occ_nm
908 | is_infix = [show_arg1, mk_showString_app (" " ++ con_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 = occNameUserString_with_parens 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 occNameUserString_with_parens :: OccName -> String
947 occNameUserString_with_parens occ
948 | isSymOcc occ = '(':nm ++ ")"
951 nm = occNameUserString occ
953 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
957 getPrec :: Bool -> FixityEnv -> Name -> Integer
958 getPrec is_infix get_fixity nm
959 | not is_infix = appPrecedence
960 | otherwise = getPrecedence get_fixity nm
962 appPrecedence :: Integer
963 appPrecedence = fromIntegral maxPrecedence + 1
964 -- One more than the precedence of the most
965 -- tightly-binding operator
967 getPrecedence :: FixityEnv -> Name -> Integer
968 getPrecedence get_fixity nm
969 = case lookupFixity get_fixity nm of
970 Fixity x _ -> fromIntegral x
974 %************************************************************************
976 \subsection{Typeable}
978 %************************************************************************
986 instance Typeable2 T where
987 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
989 We are passed the Typeable2 class as well as T
992 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
993 gen_Typeable_binds tycon
995 mk_easy_FunBind tycon_loc
996 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
997 [nlWildPat] emptyLHsBinds
998 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1000 tycon_loc = getSrcSpan tycon
1001 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1003 mk_typeOf_RDR :: TyCon -> RdrName
1004 -- Use the arity of the TyCon to make the right typeOfn function
1005 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1007 arity = tyConArity tycon
1008 suffix | arity == 0 = ""
1009 | otherwise = show arity
1014 %************************************************************************
1018 %************************************************************************
1022 data T a b = T1 a b | T2
1026 $cT1 = mkDataCon $dT "T1" Prefix
1027 $cT2 = mkDataCon $dT "T2" Prefix
1028 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1029 -- the [] is for field labels.
1031 instance (Data a, Data b) => Data (T a b) where
1032 gfoldl k z (T1 a b) = z T `k` a `k` b
1033 gfoldl k z T2 = z T2
1034 -- ToDo: add gmapT,Q,M, gfoldr
1036 gunfold k z c = case conIndex c of
1037 I# 1# -> k (k (z T1))
1040 toConstr (T1 _ _) = $cT1
1046 gen_Data_binds :: FixityEnv
1048 -> (LHsBinds RdrName, -- The method bindings
1049 LHsBinds RdrName) -- Auxiliary bindings
1050 gen_Data_binds fix_env tycon
1051 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1052 -- Auxiliary definitions: the data type and constructors
1053 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1055 tycon_loc = getSrcSpan tycon
1056 tycon_name = tyConName tycon
1057 data_cons = tyConDataCons tycon
1058 n_cons = length data_cons
1059 one_constr = n_cons == 1
1062 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1063 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1064 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1067 con_name = getRdrName con
1068 as_needed = take (dataConSourceArity con) as_RDRs
1069 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1071 ------------ gunfold
1072 gunfold_bind = mk_FunBind tycon_loc
1074 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1078 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1079 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1080 (map gunfold_alt data_cons)
1082 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1083 mk_unfold_rhs dc = foldr nlHsApp
1084 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1085 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1087 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1088 -- redundant test, and annoying warning
1089 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1090 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1094 ------------ toConstr
1095 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1096 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1098 ------------ dataTypeOf
1099 dataTypeOf_bind = mk_easy_FunBind
1104 (nlHsVar data_type_name)
1108 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1109 datatype_bind = mkVarBind
1112 ( nlHsVar mkDataType_RDR
1113 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1114 `nlHsApp` nlList constrs
1116 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1119 ------------ $cT1 etc
1120 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1121 mk_con_bind dc = mkVarBind
1124 (nlHsApps mkConstr_RDR (constr_args dc))
1126 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1127 nlHsVar data_type_name, -- DataType
1128 nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name
1129 nlList labels, -- Field labels
1130 nlHsVar fixity] -- Fixity
1132 labels = map (nlHsLit . mkHsString . getOccString)
1133 (dataConFieldLabels dc)
1134 dc_occ = getOccName dc
1135 is_infix = isDataSymOcc dc_occ
1136 fixity | is_infix = infix_RDR
1137 | otherwise = prefix_RDR
1139 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1140 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1141 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1142 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1143 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1144 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1145 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1146 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1147 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1150 %************************************************************************
1152 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1154 %************************************************************************
1159 con2tag_Foo :: Foo ... -> Int#
1160 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1161 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1164 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1169 = GenCon2Tag | GenTag2Con | GenMaxTag
1171 gen_tag_n_con_monobind
1172 :: ( RdrName, -- (proto)Name for the thing in question
1173 TyCon, -- tycon in question
1177 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1178 | lots_of_constructors
1179 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1182 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1185 tycon_loc = getSrcSpan tycon
1187 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1188 -- We can't use gerRdrName because that makes an Exact RdrName
1189 -- and we can't put them in the LocalRdrEnv
1191 -- Give a signature to the bound variable, so
1192 -- that the case expression generated by getTag is
1193 -- monomorphic. In the push-enter model we get better code.
1194 get_tag_rhs = noLoc $ ExprWithTySig
1195 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1196 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1197 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1199 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1202 nlHsTyVar (getRdrName intPrimTyCon)
1204 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1206 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1207 mk_stuff con = ([nlWildConPat con],
1208 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1210 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1211 = mk_FunBind (getSrcSpan tycon) rdr_name
1212 [([nlConVarPat intDataCon_RDR [a_RDR]],
1213 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1214 (nlHsTyVar (getRdrName tycon))))]
1216 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1217 = mkVarBind (getSrcSpan tycon) rdr_name
1218 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1220 max_tag = case (tyConDataCons tycon) of
1221 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1225 %************************************************************************
1227 \subsection{Utility bits for generating bindings}
1229 %************************************************************************
1232 ToDo: Better SrcLocs.
1236 LHsExpr RdrName -- What to do for equality
1237 -> LHsExpr RdrName -> LHsExpr RdrName
1239 careful_compare_Case :: -- checks for primitive types...
1240 TyCon -- The tycon we are deriving for
1242 -> LHsExpr RdrName -- What to do for equality
1243 -> LHsExpr RdrName -> LHsExpr RdrName
1246 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1247 -- Was: compare_gen_Case cmp_eq_RDR
1249 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1250 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1251 compare_gen_Case eq a b -- General case
1252 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1253 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1254 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1255 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1257 careful_compare_Case tycon ty eq a b
1258 | not (isUnLiftedType ty)
1259 = compare_gen_Case eq a b
1260 | otherwise -- We have to do something special for primitive things...
1261 = nlHsIf (genOpApp a relevant_eq_op b)
1263 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1265 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1266 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1269 box_if_necy :: String -- The class involved
1270 -> TyCon -- The tycon involved
1271 -> LHsExpr RdrName -- The argument
1272 -> Type -- The argument type
1273 -> LHsExpr RdrName -- Boxed version of the arg
1274 box_if_necy cls_str tycon arg arg_ty
1275 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1278 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1280 assoc_ty_id :: String -- The class involved
1281 -> TyCon -- The tycon involved
1282 -> [(Type,a)] -- The table
1284 -> a -- The result of the lookup
1285 assoc_ty_id cls_str tycon tbl ty
1286 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1287 text "for primitive type" <+> ppr ty)
1288 | otherwise = head res
1290 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1292 eq_op_tbl :: [(Type, PrimOp)]
1294 [(charPrimTy, CharEqOp)
1295 ,(intPrimTy, IntEqOp)
1296 ,(wordPrimTy, WordEqOp)
1297 ,(addrPrimTy, AddrEqOp)
1298 ,(floatPrimTy, FloatEqOp)
1299 ,(doublePrimTy, DoubleEqOp)
1302 lt_op_tbl :: [(Type, PrimOp)]
1304 [(charPrimTy, CharLtOp)
1305 ,(intPrimTy, IntLtOp)
1306 ,(wordPrimTy, WordLtOp)
1307 ,(addrPrimTy, AddrLtOp)
1308 ,(floatPrimTy, FloatLtOp)
1309 ,(doublePrimTy, DoubleLtOp)
1313 [(charPrimTy, getRdrName charDataCon)
1314 ,(intPrimTy, getRdrName intDataCon)
1315 ,(wordPrimTy, wordDataCon_RDR)
1316 ,(addrPrimTy, addrDataCon_RDR)
1317 ,(floatPrimTy, getRdrName floatDataCon)
1318 ,(doublePrimTy, getRdrName doubleDataCon)
1321 -----------------------------------------------------------------------
1323 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1324 and_Expr a b = genOpApp a and_RDR b
1326 -----------------------------------------------------------------------
1328 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1329 eq_Expr tycon ty a b = genOpApp a eq_op b
1332 | not (isUnLiftedType ty) = eq_RDR
1333 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1334 -- we have to do something special for primitive things...
1338 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1339 untag_Expr tycon [] expr = expr
1340 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1341 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1342 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1344 cmp_tags_Expr :: RdrName -- Comparison op
1345 -> RdrName -> RdrName -- Things to compare
1346 -> LHsExpr RdrName -- What to return if true
1347 -> LHsExpr RdrName -- What to return if false
1350 cmp_tags_Expr op a b true_case false_case
1351 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1354 :: LHsExpr RdrName -> LHsExpr RdrName
1356 enum_from_then_to_Expr
1357 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1360 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1361 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1364 :: LHsExpr RdrName -> LHsExpr RdrName
1367 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1369 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1371 nested_compose_Expr [e] = parenify e
1372 nested_compose_Expr (e:es)
1373 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1375 -- impossible_Expr is used in case RHSs that should never happen.
1376 -- We generate these to keep the desugarer from complaining that they *might* happen!
1377 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1379 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1380 -- method. It is currently only used by Enum.{succ,pred}
1381 illegal_Expr meth tp msg =
1382 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1384 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1385 -- to include the value of a_RDR in the error string.
1386 illegal_toEnum_tag tp maxtag =
1387 nlHsApp (nlHsVar error_RDR)
1388 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1389 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1390 (nlHsApp (nlHsApp (nlHsApp
1391 (nlHsVar showsPrec_RDR)
1395 (nlHsVar append_RDR)
1396 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1397 (nlHsApp (nlHsApp (nlHsApp
1398 (nlHsVar showsPrec_RDR)
1401 (nlHsLit (mkHsString ")"))))))
1403 parenify e@(L _ (HsVar _)) = e
1404 parenify e = mkHsPar e
1406 -- genOpApp wraps brackets round the operator application, so that the
1407 -- renamer won't subsequently try to re-associate it.
1408 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1412 getSrcSpan = srcLocSpan . getSrcLoc
1416 a_RDR = mkVarUnqual FSLIT("a")
1417 b_RDR = mkVarUnqual FSLIT("b")
1418 c_RDR = mkVarUnqual FSLIT("c")
1419 d_RDR = mkVarUnqual FSLIT("d")
1420 k_RDR = mkVarUnqual FSLIT("k")
1421 z_RDR = mkVarUnqual FSLIT("z")
1422 ah_RDR = mkVarUnqual FSLIT("a#")
1423 bh_RDR = mkVarUnqual FSLIT("b#")
1424 ch_RDR = mkVarUnqual FSLIT("c#")
1425 dh_RDR = mkVarUnqual FSLIT("d#")
1426 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1428 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1429 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1430 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1432 a_Expr = nlHsVar a_RDR
1433 b_Expr = nlHsVar b_RDR
1434 c_Expr = nlHsVar c_RDR
1435 ltTag_Expr = nlHsVar ltTag_RDR
1436 eqTag_Expr = nlHsVar eqTag_RDR
1437 gtTag_Expr = nlHsVar gtTag_RDR
1438 false_Expr = nlHsVar false_RDR
1439 true_Expr = nlHsVar true_RDR
1441 a_Pat = nlVarPat a_RDR
1442 b_Pat = nlVarPat b_RDR
1443 c_Pat = nlVarPat c_RDR
1444 d_Pat = nlVarPat d_RDR
1445 k_Pat = nlVarPat k_RDR
1446 z_Pat = nlVarPat z_RDR
1448 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1449 -- Generates Orig s RdrName, for the binding positions
1450 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1451 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1452 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1454 mk_tc_deriv_name tycon str
1455 = mkDerivedRdrName tc_name mk_occ
1457 tc_name = tyConName tycon
1458 mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1460 new_str = str ++ occNameString tc_occ ++ "#"
1463 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1464 PrelNames, so PrelNames can't import PrimOp.
1467 primOpRdrName op = getRdrName (primOpId op)
1469 minusInt_RDR = primOpRdrName IntSubOp
1470 eqInt_RDR = primOpRdrName IntEqOp
1471 ltInt_RDR = primOpRdrName IntLtOp
1472 geInt_RDR = primOpRdrName IntGeOp
1473 leInt_RDR = primOpRdrName IntLeOp
1474 tagToEnum_RDR = primOpRdrName TagToEnumOp
1476 error_RDR = getRdrName eRROR_ID