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#))
538 then case (con2tag_Foo d -# con2tag_Foo a) of
540 else error "Ix.Foo.index: out of range"
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_str = getOccString tycon
577 tycon_loc = getSrcSpan tycon
579 --------------------------------------------------------------
580 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
583 = mk_easy_FunBind tycon_loc range_RDR
584 [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds $
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 index_RDR
594 [noLoc (AsPat (noLoc c_RDR)
595 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
596 d_Pat] emptyLHsBinds (
597 nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) (
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]
608 nlHsApp (nlHsVar error_RDR) (nlHsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
612 = mk_easy_FunBind tycon_loc inRange_RDR
613 [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyLHsBinds (
614 untag_Expr tycon [(a_RDR, ah_RDR)] (
615 untag_Expr tycon [(b_RDR, bh_RDR)] (
616 untag_Expr tycon [(c_RDR, ch_RDR)] (
617 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
618 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
623 --------------------------------------------------------------
625 = listToBag [single_con_range, single_con_index, single_con_inRange]
628 = case maybeTyConSingleCon tycon of -- just checking...
629 Nothing -> panic "get_Ix_binds"
630 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
631 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
634 con_arity = dataConSourceArity data_con
635 data_con_RDR = getRdrName data_con
637 as_needed = take con_arity as_RDRs
638 bs_needed = take con_arity bs_RDRs
639 cs_needed = take con_arity cs_RDRs
641 con_pat xs = nlConVarPat data_con_RDR xs
642 con_expr = nlHsVarApps data_con_RDR cs_needed
644 --------------------------------------------------------------
646 = mk_easy_FunBind tycon_loc range_RDR
647 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyLHsBinds $
648 nlHsDo ListComp stmts
650 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
652 [nlResultStmt con_expr]
654 mk_qual a b c = nlBindStmt (nlVarPat c)
655 (nlHsApp (nlHsVar range_RDR)
656 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
660 = mk_easy_FunBind tycon_loc index_RDR
661 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
662 con_pat cs_needed] (unitBag range_size) (
663 foldl mk_index (nlHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
665 mk_index multiply_by (l, u, i)
667 (nlHsApps index_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed,
671 (nlHsApp (nlHsVar rangeSize_RDR)
672 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
673 ) times_RDR multiply_by
677 = mk_easy_FunBind tycon_loc rangeSize_RDR
678 [nlTuplePat [a_Pat, b_Pat] Boxed] emptyLHsBinds (
680 (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed,
682 ) plus_RDR (nlHsIntLit 1))
686 = mk_easy_FunBind tycon_loc inRange_RDR
687 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
690 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
692 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
696 %************************************************************************
698 \subsubsection{Generating @Read@ instance declarations}
700 %************************************************************************
710 instance Read T where
714 do x <- ReadP.step Read.readPrec
715 Symbol "%%" <- Lex.lex
716 y <- ReadP.step Read.readPrec
720 do Ident "T1" <- Lex.lex
722 Ident "f1" <- Lex.lex
724 x <- ReadP.reset Read.readPrec
726 return (T1 { f1 = x }))
729 do Ident "T2" <- Lex.lexP
730 x <- ReadP.step Read.readPrec
734 readListPrec = readListPrecDefault
735 readList = readListDefault
739 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
741 gen_Read_binds get_fixity tycon
742 = listToBag [read_prec, default_readlist, default_readlistprec]
744 -----------------------------------------------------------------------
746 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
749 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
750 -----------------------------------------------------------------------
752 loc = getSrcSpan tycon
753 data_cons = tyConDataCons tycon
754 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
756 read_prec = mkVarBind loc readPrec_RDR
757 (nlHsApp (nlHsVar parens_RDR) read_cons)
759 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
760 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
763 = case nullary_cons of
765 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
767 _ -> [nlHsApp (nlHsVar choose_RDR)
768 (nlList (map mk_pair nullary_cons))]
770 mk_pair con = nlTuple [nlHsLit (data_con_str con),
771 nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
774 read_non_nullary_con data_con
775 = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts]
777 stmts | is_infix = infix_stmts
778 | length labels > 0 = lbl_stmts
779 | otherwise = prefix_stmts
781 prefix_stmts -- T a b c
782 = [bindLex (ident_pat (data_con_str_w_parens data_con))]
784 ++ [result_stmt data_con as_needed]
786 infix_stmts -- a %% b
788 bindLex (symbol_pat (data_con_str data_con)),
790 result_stmt data_con [a1,a2]]
792 lbl_stmts -- T { f1 = a, f2 = b }
793 = [bindLex (ident_pat (data_con_str_w_parens data_con)),
795 ++ concat (intersperse [read_punc ","] field_stmts)
796 ++ [read_punc "}", result_stmt data_con as_needed]
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 as_needed = take con_arity as_RDRs
805 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
806 (read_a1:read_a2:_) = read_args
807 (a1:a2:_) = as_needed
808 prec = getPrec is_infix get_fixity dc_nm
810 ------------------------------------------------------------------------
812 ------------------------------------------------------------------------
813 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
814 bindLex pat = nlBindStmt pat (nlHsVar lexP_RDR)
815 result_stmt c as = nlResultStmt (nlHsApp (nlHsVar returnM_RDR) (con_app c as))
816 con_app c as = nlHsVarApps (getRdrName c) as
818 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
819 ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo"
820 symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>"
822 data_con_str con = mkHsString (occNameUserString (getOccName con))
823 data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
825 read_punc c = bindLex (punc_pat c)
827 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
828 | otherwise = nlBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR])
830 read_field lbl a = read_lbl lbl ++
832 nlBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR])]
834 -- When reading field labels we might encounter
839 read_lbl lbl | is_id_start (head lbl_str)
840 = [bindLex (ident_pat lbl_lit)]
843 bindLex (symbol_pat lbl_lit),
846 lbl_str = occNameUserString (getOccName lbl)
847 lbl_lit = mkHsString lbl_str
848 is_id_start c = isAlpha c || c == '_'
852 %************************************************************************
854 \subsubsection{Generating @Show@ instance declarations}
856 %************************************************************************
862 data Tree a = Leaf a | Tree a :^: Tree a
864 instance (Show a) => Show (Tree a) where
866 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
868 showStr = showString "Leaf " . showsPrec (app_prec+1) m
870 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
872 showStr = showsPrec (up_prec+1) u .
874 showsPrec (up_prec+1) v
875 -- Note: right-associativity of :^: ignored
877 up_prec = 5 -- Precedence of :^:
878 app_prec = 10 -- Application has precedence one more than
879 -- the most tightly-binding operator
882 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
884 gen_Show_binds get_fixity tycon
885 = listToBag [shows_prec, show_list]
887 tycon_loc = getSrcSpan tycon
888 -----------------------------------------------------------------------
889 show_list = mkVarBind tycon_loc showList_RDR
890 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
891 -----------------------------------------------------------------------
892 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
895 | nullary_con = -- skip the showParen junk...
896 ASSERT(null bs_needed)
897 ([nlWildPat, con_pat], mk_showString_app con_str)
900 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
901 (nlHsPar (nested_compose_Expr show_thingies)))
903 data_con_RDR = getRdrName data_con
904 con_arity = dataConSourceArity data_con
905 bs_needed = take con_arity bs_RDRs
906 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
907 con_pat = nlConVarPat data_con_RDR bs_needed
908 nullary_con = con_arity == 0
909 labels = dataConFieldLabels data_con
910 lab_fields = length labels
911 record_syntax = lab_fields > 0
913 dc_nm = getName data_con
914 dc_occ_nm = getOccName data_con
915 con_str = occNameUserString dc_occ_nm
916 op_con_str = occNameUserString_with_parens dc_occ_nm
919 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
920 | record_syntax = mk_showString_app (op_con_str ++ " {") :
921 show_record_args ++ [mk_showString_app "}"]
922 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
924 show_label l = mk_showString_app (nm ++ " = ")
925 -- Note the spaces around the "=" sign. If we don't have them
926 -- then we get Foo { x=-1 } and the "=-" parses as a single
927 -- lexeme. Only the space after the '=' is necessary, but
928 -- it seems tidier to have them both sides.
930 occ_nm = getOccName l
931 nm = occNameUserString_with_parens occ_nm
933 show_args = zipWith show_arg bs_needed arg_tys
934 (show_arg1:show_arg2:_) = show_args
935 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
937 -- Assumption for record syntax: no of fields == no of labelled fields
938 -- (and in same order)
939 show_record_args = concat $
940 intersperse [mk_showString_app ", "] $
941 [ [show_label lbl, arg]
942 | (lbl,arg) <- zipEqual "gen_Show_binds"
945 -- Generates (showsPrec p x) for argument x, but it also boxes
946 -- the argument first if necessary. Note that this prints unboxed
947 -- things without any '#' decorations; could change that if need be
948 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
949 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
952 is_infix = dataConIsInfix data_con
953 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
954 arg_prec | record_syntax = 0 -- Record fields don't need parens
955 | otherwise = con_prec_plus_one
957 occNameUserString_with_parens :: OccName -> String
958 occNameUserString_with_parens occ
959 | isSymOcc occ = '(':nm ++ ")"
962 nm = occNameUserString occ
964 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
968 getPrec :: Bool -> FixityEnv -> Name -> Integer
969 getPrec is_infix get_fixity nm
970 | not is_infix = appPrecedence
971 | otherwise = getPrecedence get_fixity nm
973 appPrecedence :: Integer
974 appPrecedence = fromIntegral maxPrecedence + 1
975 -- One more than the precedence of the most
976 -- tightly-binding operator
978 getPrecedence :: FixityEnv -> Name -> Integer
979 getPrecedence get_fixity nm
980 = case lookupFixity get_fixity nm of
981 Fixity x _ -> fromIntegral x
985 %************************************************************************
987 \subsection{Typeable}
989 %************************************************************************
997 instance Typeable2 T where
998 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1000 We are passed the Typeable2 class as well as T
1003 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
1004 gen_Typeable_binds tycon
1006 mk_easy_FunBind tycon_loc
1007 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1008 [nlWildPat] emptyLHsBinds
1009 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1011 tycon_loc = getSrcSpan tycon
1012 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1014 mk_typeOf_RDR :: TyCon -> RdrName
1015 -- Use the arity of the TyCon to make the right typeOfn function
1016 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_Name (mkFastString ("typeOf" ++ suffix))
1018 arity = tyConArity tycon
1019 suffix | arity == 0 = ""
1020 | otherwise = show arity
1025 %************************************************************************
1029 %************************************************************************
1033 data T a b = T1 a b | T2
1037 $cT1 = mkDataCon $dT "T1" Prefix
1038 $cT2 = mkDataCon $dT "T2" Prefix
1039 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1040 -- the [] is for field labels.
1042 instance (Data a, Data b) => Data (T a b) where
1043 gfoldl k z (T1 a b) = z T `k` a `k` b
1044 gfoldl k z T2 = z T2
1045 -- ToDo: add gmapT,Q,M, gfoldr
1047 gunfold k z c = case conIndex c of
1048 I# 1# -> k (k (z T1))
1051 toConstr (T1 _ _) = $cT1
1057 gen_Data_binds :: FixityEnv
1059 -> (LHsBinds RdrName, -- The method bindings
1060 LHsBinds RdrName) -- Auxiliary bindings
1061 gen_Data_binds fix_env tycon
1062 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1063 -- Auxiliary definitions: the data type and constructors
1064 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1066 tycon_loc = getSrcSpan tycon
1067 tycon_name = tyConName tycon
1068 data_cons = tyConDataCons tycon
1069 n_cons = length data_cons
1070 one_constr = n_cons == 1
1073 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1074 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1075 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1078 con_name = getRdrName con
1079 as_needed = take (dataConSourceArity con) as_RDRs
1080 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1082 ------------ gunfold
1083 gunfold_bind = mk_FunBind tycon_loc
1085 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1089 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1090 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1091 (map gunfold_alt data_cons)
1093 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1094 mk_unfold_rhs dc = foldr nlHsApp
1095 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1096 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1098 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1099 -- redundant test, and annoying warning
1100 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1101 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1105 ------------ toConstr
1106 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1107 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1109 ------------ dataTypeOf
1110 dataTypeOf_bind = mk_easy_FunBind
1115 (nlHsVar data_type_name)
1119 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1120 datatype_bind = mkVarBind
1123 ( nlHsVar mkDataType_RDR
1124 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1125 `nlHsApp` nlList constrs
1127 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1130 ------------ $cT1 etc
1131 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1132 mk_con_bind dc = mkVarBind
1135 (nlHsApps mkConstr_RDR (constr_args dc))
1137 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1138 nlHsVar data_type_name, -- DataType
1139 nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name
1140 nlList labels, -- Field labels
1141 nlHsVar fixity] -- Fixity
1143 labels = map (nlHsLit . mkHsString . getOccString)
1144 (dataConFieldLabels dc)
1145 dc_occ = getOccName dc
1146 is_infix = isDataSymOcc dc_occ
1147 fixity | is_infix = infix_RDR
1148 | otherwise = prefix_RDR
1150 gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl")
1151 gunfold_RDR = varQual_RDR gENERICS_Name FSLIT("gunfold")
1152 toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr")
1153 dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
1154 mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr")
1155 mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
1156 conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("constrIndex")
1157 prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix")
1158 infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix")
1161 %************************************************************************
1163 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1165 %************************************************************************
1170 con2tag_Foo :: Foo ... -> Int#
1171 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1172 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1175 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1180 = GenCon2Tag | GenTag2Con | GenMaxTag
1182 gen_tag_n_con_monobind
1183 :: ( RdrName, -- (proto)Name for the thing in question
1184 TyCon, -- tycon in question
1188 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1189 | lots_of_constructors
1190 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1193 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1196 tycon_loc = getSrcSpan tycon
1198 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1199 -- We can't use gerRdrName because that makes an Exact RdrName
1200 -- and we can't put them in the LocalRdrEnv
1202 -- Give a signature to the bound variable, so
1203 -- that the case expression generated by getTag is
1204 -- monomorphic. In the push-enter model we get better code.
1205 get_tag_rhs = noLoc $ ExprWithTySig
1206 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1207 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1208 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1210 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1213 nlHsTyVar (getRdrName intPrimTyCon)
1215 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1217 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1218 mk_stuff con = ([nlWildConPat con],
1219 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1221 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1222 = mk_FunBind (getSrcSpan tycon) rdr_name
1223 [([nlConVarPat intDataCon_RDR [a_RDR]],
1224 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1225 (nlHsTyVar (getRdrName tycon))))]
1227 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1228 = mkVarBind (getSrcSpan tycon) rdr_name
1229 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1231 max_tag = case (tyConDataCons tycon) of
1232 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1236 %************************************************************************
1238 \subsection{Utility bits for generating bindings}
1240 %************************************************************************
1243 ToDo: Better SrcLocs.
1247 LHsExpr RdrName -- What to do for equality
1248 -> LHsExpr RdrName -> LHsExpr RdrName
1250 careful_compare_Case :: -- checks for primitive types...
1251 TyCon -- The tycon we are deriving for
1253 -> LHsExpr RdrName -- What to do for equality
1254 -> LHsExpr RdrName -> LHsExpr RdrName
1257 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1258 -- Was: compare_gen_Case cmp_eq_RDR
1260 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1261 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1262 compare_gen_Case eq a b -- General case
1263 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1264 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1265 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1266 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1268 careful_compare_Case tycon ty eq a b
1269 | not (isUnLiftedType ty)
1270 = compare_gen_Case eq a b
1271 | otherwise -- We have to do something special for primitive things...
1272 = nlHsIf (genOpApp a relevant_eq_op b)
1274 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1276 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1277 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1280 box_if_necy :: String -- The class involved
1281 -> TyCon -- The tycon involved
1282 -> LHsExpr RdrName -- The argument
1283 -> Type -- The argument type
1284 -> LHsExpr RdrName -- Boxed version of the arg
1285 box_if_necy cls_str tycon arg arg_ty
1286 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1289 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1291 assoc_ty_id :: String -- The class involved
1292 -> TyCon -- The tycon involved
1293 -> [(Type,a)] -- The table
1295 -> a -- The result of the lookup
1296 assoc_ty_id cls_str tycon tbl ty
1297 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1298 text "for primitive type" <+> ppr ty)
1299 | otherwise = head res
1301 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1303 eq_op_tbl :: [(Type, PrimOp)]
1305 [(charPrimTy, CharEqOp)
1306 ,(intPrimTy, IntEqOp)
1307 ,(wordPrimTy, WordEqOp)
1308 ,(addrPrimTy, AddrEqOp)
1309 ,(floatPrimTy, FloatEqOp)
1310 ,(doublePrimTy, DoubleEqOp)
1313 lt_op_tbl :: [(Type, PrimOp)]
1315 [(charPrimTy, CharLtOp)
1316 ,(intPrimTy, IntLtOp)
1317 ,(wordPrimTy, WordLtOp)
1318 ,(addrPrimTy, AddrLtOp)
1319 ,(floatPrimTy, FloatLtOp)
1320 ,(doublePrimTy, DoubleLtOp)
1324 [(charPrimTy, getRdrName charDataCon)
1325 ,(intPrimTy, getRdrName intDataCon)
1326 ,(wordPrimTy, wordDataCon_RDR)
1327 ,(addrPrimTy, addrDataCon_RDR)
1328 ,(floatPrimTy, getRdrName floatDataCon)
1329 ,(doublePrimTy, getRdrName doubleDataCon)
1332 -----------------------------------------------------------------------
1334 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1335 and_Expr a b = genOpApp a and_RDR b
1337 -----------------------------------------------------------------------
1339 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1340 eq_Expr tycon ty a b = genOpApp a eq_op b
1343 | not (isUnLiftedType ty) = eq_RDR
1344 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1345 -- we have to do something special for primitive things...
1349 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1350 untag_Expr tycon [] expr = expr
1351 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1352 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1353 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1355 cmp_tags_Expr :: RdrName -- Comparison op
1356 -> RdrName -> RdrName -- Things to compare
1357 -> LHsExpr RdrName -- What to return if true
1358 -> LHsExpr RdrName -- What to return if false
1361 cmp_tags_Expr op a b true_case false_case
1362 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1365 :: LHsExpr RdrName -> LHsExpr RdrName
1367 enum_from_then_to_Expr
1368 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1371 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1372 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1375 :: LHsExpr RdrName -> LHsExpr RdrName
1378 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1380 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1382 nested_compose_Expr [e] = parenify e
1383 nested_compose_Expr (e:es)
1384 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1386 -- impossible_Expr is used in case RHSs that should never happen.
1387 -- We generate these to keep the desugarer from complaining that they *might* happen!
1388 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1390 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1391 -- method. It is currently only used by Enum.{succ,pred}
1392 illegal_Expr meth tp msg =
1393 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1395 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1396 -- to include the value of a_RDR in the error string.
1397 illegal_toEnum_tag tp maxtag =
1398 nlHsApp (nlHsVar error_RDR)
1399 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1400 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1401 (nlHsApp (nlHsApp (nlHsApp
1402 (nlHsVar showsPrec_RDR)
1406 (nlHsVar append_RDR)
1407 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1408 (nlHsApp (nlHsApp (nlHsApp
1409 (nlHsVar showsPrec_RDR)
1412 (nlHsLit (mkHsString ")"))))))
1414 parenify e@(L _ (HsVar _)) = e
1415 parenify e = mkHsPar e
1417 -- genOpApp wraps brackets round the operator application, so that the
1418 -- renamer won't subsequently try to re-associate it.
1419 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1423 getSrcSpan = srcLocSpan . getSrcLoc
1427 a_RDR = mkVarUnqual FSLIT("a")
1428 b_RDR = mkVarUnqual FSLIT("b")
1429 c_RDR = mkVarUnqual FSLIT("c")
1430 d_RDR = mkVarUnqual FSLIT("d")
1431 k_RDR = mkVarUnqual FSLIT("k")
1432 z_RDR = mkVarUnqual FSLIT("z")
1433 ah_RDR = mkVarUnqual FSLIT("a#")
1434 bh_RDR = mkVarUnqual FSLIT("b#")
1435 ch_RDR = mkVarUnqual FSLIT("c#")
1436 dh_RDR = mkVarUnqual FSLIT("d#")
1437 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1438 rangeSize_RDR = mkVarUnqual FSLIT("rangeSize")
1440 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1441 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1442 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1444 a_Expr = nlHsVar a_RDR
1445 b_Expr = nlHsVar b_RDR
1446 c_Expr = nlHsVar c_RDR
1447 ltTag_Expr = nlHsVar ltTag_RDR
1448 eqTag_Expr = nlHsVar eqTag_RDR
1449 gtTag_Expr = nlHsVar gtTag_RDR
1450 false_Expr = nlHsVar false_RDR
1451 true_Expr = nlHsVar true_RDR
1453 a_Pat = nlVarPat a_RDR
1454 b_Pat = nlVarPat b_RDR
1455 c_Pat = nlVarPat c_RDR
1456 d_Pat = nlVarPat d_RDR
1457 k_Pat = nlVarPat k_RDR
1458 z_Pat = nlVarPat z_RDR
1460 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1461 -- Generates Orig s RdrName, for the binding positions
1462 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1463 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1464 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1466 mk_tc_deriv_name tycon str
1467 = mkDerivedRdrName tc_name mk_occ
1469 tc_name = tyConName tycon
1470 mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1472 new_str = str ++ occNameString tc_occ ++ "#"
1475 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1476 PrelNames, so PrelNames can't import PrimOp.
1479 primOpRdrName op = getRdrName (primOpId op)
1481 minusInt_RDR = primOpRdrName IntSubOp
1482 eqInt_RDR = primOpRdrName IntEqOp
1483 ltInt_RDR = primOpRdrName IntLtOp
1484 geInt_RDR = primOpRdrName IntGeOp
1485 leInt_RDR = primOpRdrName IntLeOp
1486 tagToEnum_RDR = primOpRdrName TagToEnumOp
1488 error_RDR = getRdrName eRROR_ID