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 (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
772 prefix_stmts -- T a b c
773 = [bindLex (ident_pat (data_con_str_w_parens data_con))]
776 infix_stmts -- a %% b
778 bindLex (symbol_pat (data_con_str data_con)),
781 lbl_stmts -- T { f1 = a, f2 = b }
782 = [bindLex (ident_pat (data_con_str_w_parens data_con)),
784 ++ concat (intersperse [read_punc ","] field_stmts)
787 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
789 con_arity = dataConSourceArity data_con
790 labels = dataConFieldLabels data_con
791 dc_nm = getName data_con
792 is_infix = dataConIsInfix data_con
793 as_needed = take con_arity as_RDRs
794 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
795 (read_a1:read_a2:_) = read_args
796 prec = getPrec is_infix get_fixity dc_nm
798 ------------------------------------------------------------------------
800 ------------------------------------------------------------------------
801 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
802 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))
803 con_app c as = nlHsVarApps (getRdrName c) as
804 result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as)
806 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
807 ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo"
808 symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>"
810 data_con_str con = mkHsString (occNameUserString (getOccName con))
811 data_con_str_w_parens con = mkHsString (occNameUserString_with_parens (getOccName con))
813 read_punc c = bindLex (punc_pat c)
815 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
816 | otherwise = noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
818 read_field lbl a = read_lbl lbl ++
820 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
822 -- When reading field labels we might encounter
827 read_lbl lbl | is_id_start (head lbl_str)
828 = [bindLex (ident_pat lbl_lit)]
831 bindLex (symbol_pat lbl_lit),
834 lbl_str = occNameUserString (getOccName lbl)
835 lbl_lit = mkHsString lbl_str
836 is_id_start c = isAlpha c || c == '_'
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 = occNameUserString_with_parens dc_occ_nm
907 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
908 | record_syntax = mk_showString_app (op_con_str ++ " {") :
909 show_record_args ++ [mk_showString_app "}"]
910 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
912 show_label l = mk_showString_app (nm ++ " = ")
913 -- Note the spaces around the "=" sign. If we don't have them
914 -- then we get Foo { x=-1 } and the "=-" parses as a single
915 -- lexeme. Only the space after the '=' is necessary, but
916 -- it seems tidier to have them both sides.
918 occ_nm = getOccName l
919 nm = occNameUserString_with_parens occ_nm
921 show_args = zipWith show_arg bs_needed arg_tys
922 (show_arg1:show_arg2:_) = show_args
923 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
925 -- Assumption for record syntax: no of fields == no of labelled fields
926 -- (and in same order)
927 show_record_args = concat $
928 intersperse [mk_showString_app ", "] $
929 [ [show_label lbl, arg]
930 | (lbl,arg) <- zipEqual "gen_Show_binds"
933 -- Generates (showsPrec p x) for argument x, but it also boxes
934 -- the argument first if necessary. Note that this prints unboxed
935 -- things without any '#' decorations; could change that if need be
936 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
937 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
940 is_infix = dataConIsInfix data_con
941 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
942 arg_prec | record_syntax = 0 -- Record fields don't need parens
943 | otherwise = con_prec_plus_one
945 occNameUserString_with_parens :: OccName -> String
946 occNameUserString_with_parens occ
947 | isSymOcc occ = '(':nm ++ ")"
950 nm = occNameUserString occ
952 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
956 getPrec :: Bool -> FixityEnv -> Name -> Integer
957 getPrec is_infix get_fixity nm
958 | not is_infix = appPrecedence
959 | otherwise = getPrecedence get_fixity nm
961 appPrecedence :: Integer
962 appPrecedence = fromIntegral maxPrecedence + 1
963 -- One more than the precedence of the most
964 -- tightly-binding operator
966 getPrecedence :: FixityEnv -> Name -> Integer
967 getPrecedence get_fixity nm
968 = case lookupFixity get_fixity nm of
969 Fixity x _ -> fromIntegral x
973 %************************************************************************
975 \subsection{Typeable}
977 %************************************************************************
985 instance Typeable2 T where
986 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
988 We are passed the Typeable2 class as well as T
991 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
992 gen_Typeable_binds tycon
994 mk_easy_FunBind tycon_loc
995 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
997 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
999 tycon_loc = getSrcSpan tycon
1000 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1002 mk_typeOf_RDR :: TyCon -> RdrName
1003 -- Use the arity of the TyCon to make the right typeOfn function
1004 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1006 arity = tyConArity tycon
1007 suffix | arity == 0 = ""
1008 | otherwise = show arity
1013 %************************************************************************
1017 %************************************************************************
1021 data T a b = T1 a b | T2
1025 $cT1 = mkDataCon $dT "T1" Prefix
1026 $cT2 = mkDataCon $dT "T2" Prefix
1027 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1028 -- the [] is for field labels.
1030 instance (Data a, Data b) => Data (T a b) where
1031 gfoldl k z (T1 a b) = z T `k` a `k` b
1032 gfoldl k z T2 = z T2
1033 -- ToDo: add gmapT,Q,M, gfoldr
1035 gunfold k z c = case conIndex c of
1036 I# 1# -> k (k (z T1))
1039 toConstr (T1 _ _) = $cT1
1045 gen_Data_binds :: FixityEnv
1047 -> (LHsBinds RdrName, -- The method bindings
1048 LHsBinds RdrName) -- Auxiliary bindings
1049 gen_Data_binds fix_env tycon
1050 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1051 -- Auxiliary definitions: the data type and constructors
1052 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1054 tycon_loc = getSrcSpan tycon
1055 tycon_name = tyConName tycon
1056 data_cons = tyConDataCons tycon
1057 n_cons = length data_cons
1058 one_constr = n_cons == 1
1061 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1062 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1063 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1066 con_name = getRdrName con
1067 as_needed = take (dataConSourceArity con) as_RDRs
1068 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1070 ------------ gunfold
1071 gunfold_bind = mk_FunBind tycon_loc
1073 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1077 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1078 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1079 (map gunfold_alt data_cons)
1081 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1082 mk_unfold_rhs dc = foldr nlHsApp
1083 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1084 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1086 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1087 -- redundant test, and annoying warning
1088 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1089 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1093 ------------ toConstr
1094 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1095 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1097 ------------ dataTypeOf
1098 dataTypeOf_bind = mk_easy_FunBind
1102 (nlHsVar data_type_name)
1106 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1107 datatype_bind = mkVarBind
1110 ( nlHsVar mkDataType_RDR
1111 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1112 `nlHsApp` nlList constrs
1114 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1117 ------------ $cT1 etc
1118 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1119 mk_con_bind dc = mkVarBind
1122 (nlHsApps mkConstr_RDR (constr_args dc))
1124 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1125 nlHsVar data_type_name, -- DataType
1126 nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name
1127 nlList labels, -- Field labels
1128 nlHsVar fixity] -- Fixity
1130 labels = map (nlHsLit . mkHsString . getOccString)
1131 (dataConFieldLabels dc)
1132 dc_occ = getOccName dc
1133 is_infix = isDataSymOcc dc_occ
1134 fixity | is_infix = infix_RDR
1135 | otherwise = prefix_RDR
1137 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1138 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1139 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1140 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1141 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1142 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1143 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1144 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1145 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1148 %************************************************************************
1150 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1152 %************************************************************************
1157 con2tag_Foo :: Foo ... -> Int#
1158 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1159 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1162 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1167 = GenCon2Tag | GenTag2Con | GenMaxTag
1169 gen_tag_n_con_monobind
1170 :: ( RdrName, -- (proto)Name for the thing in question
1171 TyCon, -- tycon in question
1175 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1176 | lots_of_constructors
1177 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1180 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1183 tycon_loc = getSrcSpan tycon
1185 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1186 -- We can't use gerRdrName because that makes an Exact RdrName
1187 -- and we can't put them in the LocalRdrEnv
1189 -- Give a signature to the bound variable, so
1190 -- that the case expression generated by getTag is
1191 -- monomorphic. In the push-enter model we get better code.
1192 get_tag_rhs = noLoc $ ExprWithTySig
1193 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1194 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1195 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1197 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1200 nlHsTyVar (getRdrName intPrimTyCon)
1202 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1204 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1205 mk_stuff con = ([nlWildConPat con],
1206 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1208 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1209 = mk_FunBind (getSrcSpan tycon) rdr_name
1210 [([nlConVarPat intDataCon_RDR [a_RDR]],
1211 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1212 (nlHsTyVar (getRdrName tycon))))]
1214 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1215 = mkVarBind (getSrcSpan tycon) rdr_name
1216 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1218 max_tag = case (tyConDataCons tycon) of
1219 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1223 %************************************************************************
1225 \subsection{Utility bits for generating bindings}
1227 %************************************************************************
1230 ToDo: Better SrcLocs.
1234 LHsExpr RdrName -- What to do for equality
1235 -> LHsExpr RdrName -> LHsExpr RdrName
1237 careful_compare_Case :: -- checks for primitive types...
1238 TyCon -- The tycon we are deriving for
1240 -> LHsExpr RdrName -- What to do for equality
1241 -> LHsExpr RdrName -> LHsExpr RdrName
1244 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1245 -- Was: compare_gen_Case cmp_eq_RDR
1247 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1248 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1249 compare_gen_Case eq a b -- General case
1250 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1251 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1252 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1253 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1255 careful_compare_Case tycon ty eq a b
1256 | not (isUnLiftedType ty)
1257 = compare_gen_Case eq a b
1258 | otherwise -- We have to do something special for primitive things...
1259 = nlHsIf (genOpApp a relevant_eq_op b)
1261 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1263 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1264 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1267 box_if_necy :: String -- The class involved
1268 -> TyCon -- The tycon involved
1269 -> LHsExpr RdrName -- The argument
1270 -> Type -- The argument type
1271 -> LHsExpr RdrName -- Boxed version of the arg
1272 box_if_necy cls_str tycon arg arg_ty
1273 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1276 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1278 assoc_ty_id :: String -- The class involved
1279 -> TyCon -- The tycon involved
1280 -> [(Type,a)] -- The table
1282 -> a -- The result of the lookup
1283 assoc_ty_id cls_str tycon tbl ty
1284 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1285 text "for primitive type" <+> ppr ty)
1286 | otherwise = head res
1288 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1290 eq_op_tbl :: [(Type, PrimOp)]
1292 [(charPrimTy, CharEqOp)
1293 ,(intPrimTy, IntEqOp)
1294 ,(wordPrimTy, WordEqOp)
1295 ,(addrPrimTy, AddrEqOp)
1296 ,(floatPrimTy, FloatEqOp)
1297 ,(doublePrimTy, DoubleEqOp)
1300 lt_op_tbl :: [(Type, PrimOp)]
1302 [(charPrimTy, CharLtOp)
1303 ,(intPrimTy, IntLtOp)
1304 ,(wordPrimTy, WordLtOp)
1305 ,(addrPrimTy, AddrLtOp)
1306 ,(floatPrimTy, FloatLtOp)
1307 ,(doublePrimTy, DoubleLtOp)
1311 [(charPrimTy, getRdrName charDataCon)
1312 ,(intPrimTy, getRdrName intDataCon)
1313 ,(wordPrimTy, wordDataCon_RDR)
1314 ,(addrPrimTy, addrDataCon_RDR)
1315 ,(floatPrimTy, getRdrName floatDataCon)
1316 ,(doublePrimTy, getRdrName doubleDataCon)
1319 -----------------------------------------------------------------------
1321 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1322 and_Expr a b = genOpApp a and_RDR b
1324 -----------------------------------------------------------------------
1326 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1327 eq_Expr tycon ty a b = genOpApp a eq_op b
1330 | not (isUnLiftedType ty) = eq_RDR
1331 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1332 -- we have to do something special for primitive things...
1336 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1337 untag_Expr tycon [] expr = expr
1338 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1339 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1340 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1342 cmp_tags_Expr :: RdrName -- Comparison op
1343 -> RdrName -> RdrName -- Things to compare
1344 -> LHsExpr RdrName -- What to return if true
1345 -> LHsExpr RdrName -- What to return if false
1348 cmp_tags_Expr op a b true_case false_case
1349 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1352 :: LHsExpr RdrName -> LHsExpr RdrName
1354 enum_from_then_to_Expr
1355 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1358 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1359 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1362 :: LHsExpr RdrName -> LHsExpr RdrName
1365 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1367 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1369 nested_compose_Expr [e] = parenify e
1370 nested_compose_Expr (e:es)
1371 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1373 -- impossible_Expr is used in case RHSs that should never happen.
1374 -- We generate these to keep the desugarer from complaining that they *might* happen!
1375 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1377 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1378 -- method. It is currently only used by Enum.{succ,pred}
1379 illegal_Expr meth tp msg =
1380 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1382 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1383 -- to include the value of a_RDR in the error string.
1384 illegal_toEnum_tag tp maxtag =
1385 nlHsApp (nlHsVar error_RDR)
1386 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1387 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1388 (nlHsApp (nlHsApp (nlHsApp
1389 (nlHsVar showsPrec_RDR)
1393 (nlHsVar append_RDR)
1394 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1395 (nlHsApp (nlHsApp (nlHsApp
1396 (nlHsVar showsPrec_RDR)
1399 (nlHsLit (mkHsString ")"))))))
1401 parenify e@(L _ (HsVar _)) = e
1402 parenify e = mkHsPar e
1404 -- genOpApp wraps brackets round the operator application, so that the
1405 -- renamer won't subsequently try to re-associate it.
1406 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1410 getSrcSpan = srcLocSpan . getSrcLoc
1414 a_RDR = mkVarUnqual FSLIT("a")
1415 b_RDR = mkVarUnqual FSLIT("b")
1416 c_RDR = mkVarUnqual FSLIT("c")
1417 d_RDR = mkVarUnqual FSLIT("d")
1418 k_RDR = mkVarUnqual FSLIT("k")
1419 z_RDR = mkVarUnqual FSLIT("z")
1420 ah_RDR = mkVarUnqual FSLIT("a#")
1421 bh_RDR = mkVarUnqual FSLIT("b#")
1422 ch_RDR = mkVarUnqual FSLIT("c#")
1423 dh_RDR = mkVarUnqual FSLIT("d#")
1424 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1426 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1427 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1428 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1430 a_Expr = nlHsVar a_RDR
1431 b_Expr = nlHsVar b_RDR
1432 c_Expr = nlHsVar c_RDR
1433 ltTag_Expr = nlHsVar ltTag_RDR
1434 eqTag_Expr = nlHsVar eqTag_RDR
1435 gtTag_Expr = nlHsVar gtTag_RDR
1436 false_Expr = nlHsVar false_RDR
1437 true_Expr = nlHsVar true_RDR
1439 a_Pat = nlVarPat a_RDR
1440 b_Pat = nlVarPat b_RDR
1441 c_Pat = nlVarPat c_RDR
1442 d_Pat = nlVarPat d_RDR
1443 k_Pat = nlVarPat k_RDR
1444 z_Pat = nlVarPat z_RDR
1446 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1447 -- Generates Orig s RdrName, for the binding positions
1448 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1449 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1450 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1452 mk_tc_deriv_name tycon str
1453 = mkDerivedRdrName tc_name mk_occ
1455 tc_name = tyConName tycon
1456 mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1458 new_str = str ++ occNameString tc_occ ++ "#"
1461 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1462 PrelNames, so PrelNames can't import PrimOp.
1465 primOpRdrName op = getRdrName (primOpId op)
1467 minusInt_RDR = primOpRdrName IntSubOp
1468 eqInt_RDR = primOpRdrName IntEqOp
1469 ltInt_RDR = primOpRdrName IntLtOp
1470 geInt_RDR = primOpRdrName IntGeOp
1471 leInt_RDR = primOpRdrName IntLeOp
1472 tagToEnum_RDR = primOpRdrName TagToEnumOp
1474 error_RDR = getRdrName eRROR_ID