2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcGenDeriv]{Generating derived instance declarations}
6 This module is nominally ``subordinate'' to @TcDeriv@, which is the
7 ``official'' interface to deriving-related things.
9 This is where we do all the grimy bindings' generation.
22 gen_tag_n_con_monobind,
24 con2tag_RDR, tag2con_RDR, maxtag_RDR,
29 #include "HsVersions.h"
32 import RdrName ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual,
34 import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) )
35 import DataCon ( isNullarySrcDataCon, dataConTag,
36 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
37 DataCon, dataConName, dataConIsInfix,
39 import Name ( getOccString, getSrcLoc, Name, NamedThing(..) )
41 import HscTypes ( FixityEnv, lookupFixity )
44 import MkId ( eRROR_ID )
45 import PrimOp ( PrimOp(..) )
46 import SrcLoc ( Located(..), noLoc, srcLocSpan )
47 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, tyConArity,
48 maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName
50 import TcType ( isUnLiftedType, tcEqType, Type )
51 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
53 import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon,
54 intDataCon_RDR, true_RDR, false_RDR )
55 import Util ( zipWithEqual, isSingleton,
56 zipWith3Equal, nOfThem, zipEqual )
58 import List ( partition, intersperse )
65 %************************************************************************
67 \subsection{Generating code, by derivable class}
69 %************************************************************************
71 %************************************************************************
73 \subsubsection{Generating @Eq@ instance declarations}
75 %************************************************************************
77 Here are the heuristics for the code we generate for @Eq@:
80 Let's assume we have a data type with some (possibly zero) nullary
81 data constructors and some ordinary, non-nullary ones (the rest,
82 also possibly zero of them). Here's an example, with both \tr{N}ullary
83 and \tr{O}rdinary data cons.
85 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
89 For the ordinary constructors (if any), we emit clauses to do The
93 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
94 (==) (O2 a1) (O2 a2) = a1 == a2
95 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
98 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
99 \tr{a2} are \tr{Float#}s, then we have to generate
101 case (a1 `eqFloat#` a2) of
104 for that particular test.
107 If there are any nullary constructors, we emit a catch-all clause of
111 (==) a b = case (con2tag_Foo a) of { a# ->
112 case (con2tag_Foo b) of { b# ->
113 case (a# ==# b#) of {
118 If there aren't any nullary constructors, we emit a simpler
125 For the @(/=)@ method, we normally just use the default method.
127 If the type is an enumeration type, we could/may/should? generate
128 special code that calls @con2tag_Foo@, much like for @(==)@ shown
132 We thought about doing this: If we're also deriving @Ord@ for this
135 instance ... Eq (Foo ...) where
136 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
137 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
139 However, that requires that \tr{Ord <whatever>} was put in the context
140 for the instance decl, which it probably wasn't, so the decls
141 produced don't get through the typechecker.
146 gen_Eq_binds :: TyCon -> LHsBinds RdrName
150 tycon_loc = getSrcSpan tycon
152 (nullary_cons, nonnullary_cons)
153 | isNewTyCon tycon = ([], tyConDataCons tycon)
154 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
157 = if (null nullary_cons) then
158 case maybeTyConSingleCon tycon of
160 Nothing -> -- if cons don't match, then False
161 [([nlWildPat, nlWildPat], false_Expr)]
162 else -- calc. and compare the tags
164 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
165 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
168 mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
169 mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] (
170 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
173 ------------------------------------------------------------------
176 con1_pat = nlConVarPat data_con_RDR as_needed
177 con2_pat = nlConVarPat data_con_RDR bs_needed
179 data_con_RDR = getRdrName data_con
180 con_arity = length tys_needed
181 as_needed = take con_arity as_RDRs
182 bs_needed = take con_arity bs_RDRs
183 tys_needed = dataConOrigArgTys data_con
185 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
187 nested_eq_expr [] [] [] = true_Expr
188 nested_eq_expr tys as bs
189 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
191 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
194 %************************************************************************
196 \subsubsection{Generating @Ord@ instance declarations}
198 %************************************************************************
200 For a derived @Ord@, we concentrate our attentions on @compare@
202 compare :: a -> a -> Ordering
203 data Ordering = LT | EQ | GT deriving ()
206 We will use the same example data type as above:
208 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
213 We do all the other @Ord@ methods with calls to @compare@:
215 instance ... (Ord <wurble> <wurble>) where
216 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
217 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
218 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
219 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
221 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
222 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
224 -- compare to come...
228 @compare@ always has two parts. First, we use the compared
229 data-constructors' tags to deal with the case of different
232 compare a b = case (con2tag_Foo a) of { a# ->
233 case (con2tag_Foo b) of { b# ->
234 case (a# ==# b#) of {
236 False -> case (a# <# b#) of
241 cmp_eq = ... to come ...
245 We are only left with the ``help'' function @cmp_eq@, to deal with
246 comparing data constructors with the same tag.
248 For the ordinary constructors (if any), we emit the sorta-obvious
249 compare-style stuff; for our example:
251 cmp_eq (O1 a1 b1) (O1 a2 b2)
252 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
254 cmp_eq (O2 a1) (O2 a2)
257 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
258 = case (compare a1 a2) of {
261 EQ -> case compare b1 b2 of {
269 Again, we must be careful about unlifted comparisons. For example,
270 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
274 cmp_eq lt eq gt (O2 a1) (O2 a2)
276 -- or maybe the unfolded equivalent
280 For the remaining nullary constructors, we already know that the
287 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
291 gen_Ord_binds :: TyCon -> LHsBinds RdrName
294 = unitBag compare -- `AndMonoBinds` compare
295 -- The default declaration in PrelBase handles this
297 tycon_loc = getSrcSpan tycon
298 --------------------------------------------------------------------
300 compare = L tycon_loc (FunBind (L tycon_loc compare_RDR) False compare_matches placeHolderNames)
301 compare_matches = mkMatchGroup [mkMatch [a_Pat, b_Pat] compare_rhs cmp_eq_binds]
302 cmp_eq_binds = HsValBinds (ValBindsIn (unitBag cmp_eq) [])
305 | single_con_type = cmp_eq_Expr a_Expr b_Expr
307 = untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)]
308 (cmp_tags_Expr eqInt_RDR ah_RDR bh_RDR
309 (cmp_eq_Expr a_Expr b_Expr) -- True case
310 -- False case; they aren't equal
311 -- So we need to do a less-than comparison on the tags
312 (cmp_tags_Expr ltInt_RDR ah_RDR bh_RDR ltTag_Expr gtTag_Expr))
314 tycon_data_cons = tyConDataCons tycon
315 single_con_type = isSingleton tycon_data_cons
316 (nullary_cons, nonnullary_cons)
317 | isNewTyCon tycon = ([], tyConDataCons tycon)
318 | otherwise = partition isNullarySrcDataCon tycon_data_cons
320 cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match
322 | isEnumerationTyCon tycon
323 -- We know the tags are equal, so if it's an enumeration TyCon,
324 -- then there is nothing left to do
325 -- Catch this specially to avoid warnings
326 -- about overlapping patterns from the desugarer,
327 -- and to avoid unnecessary pattern-matching
328 = [([nlWildPat,nlWildPat], eqTag_Expr)]
330 = map pats_etc nonnullary_cons ++
331 (if single_con_type then -- Omit wildcards when there's just one
332 [] -- constructor, to silence desugarer
334 [([nlWildPat, nlWildPat], default_rhs)])
338 = ([con1_pat, con2_pat],
339 nested_compare_expr tys_needed as_needed bs_needed)
341 con1_pat = nlConVarPat data_con_RDR as_needed
342 con2_pat = nlConVarPat data_con_RDR bs_needed
344 data_con_RDR = getRdrName data_con
345 con_arity = length tys_needed
346 as_needed = take con_arity as_RDRs
347 bs_needed = take con_arity bs_RDRs
348 tys_needed = dataConOrigArgTys data_con
350 nested_compare_expr [ty] [a] [b]
351 = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b)
353 nested_compare_expr (ty:tys) (a:as) (b:bs)
354 = let eq_expr = nested_compare_expr tys as bs
355 in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b)
357 default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about
358 -- inexhaustive patterns
359 | otherwise = eqTag_Expr -- Some nullary constructors;
360 -- Tags are equal, no args => return EQ
363 %************************************************************************
365 \subsubsection{Generating @Enum@ instance declarations}
367 %************************************************************************
369 @Enum@ can only be derived for enumeration types. For a type
371 data Foo ... = N1 | N2 | ... | Nn
374 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
375 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
378 instance ... Enum (Foo ...) where
379 succ x = toEnum (1 + fromEnum x)
380 pred x = toEnum (fromEnum x - 1)
382 toEnum i = tag2con_Foo i
384 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
388 = case con2tag_Foo a of
389 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
392 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
396 = case con2tag_Foo a of { a# ->
397 case con2tag_Foo b of { b# ->
398 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
402 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
405 gen_Enum_binds :: TyCon -> LHsBinds RdrName
417 tycon_loc = getSrcSpan tycon
418 occ_nm = getOccString tycon
421 = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] $
422 untag_Expr tycon [(a_RDR, ah_RDR)] $
423 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
424 nlHsVarApps intDataCon_RDR [ah_RDR]])
425 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
426 (nlHsApp (nlHsVar (tag2con_RDR tycon))
427 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
431 = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] $
432 untag_Expr tycon [(a_RDR, ah_RDR)] $
433 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
434 nlHsVarApps intDataCon_RDR [ah_RDR]])
435 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
436 (nlHsApp (nlHsVar (tag2con_RDR tycon))
437 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
438 nlHsLit (HsInt (-1))]))
441 = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] $
442 nlHsIf (nlHsApps and_RDR
443 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
444 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
445 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
446 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
449 = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] $
450 untag_Expr tycon [(a_RDR, ah_RDR)] $
452 [nlHsVar (tag2con_RDR tycon),
453 nlHsPar (enum_from_to_Expr
454 (nlHsVarApps intDataCon_RDR [ah_RDR])
455 (nlHsVar (maxtag_RDR tycon)))]
458 = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] $
459 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
460 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
461 nlHsPar (enum_from_then_to_Expr
462 (nlHsVarApps intDataCon_RDR [ah_RDR])
463 (nlHsVarApps intDataCon_RDR [bh_RDR])
464 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
465 nlHsVarApps intDataCon_RDR [bh_RDR]])
467 (nlHsVar (maxtag_RDR tycon))
471 = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] $
472 untag_Expr tycon [(a_RDR, ah_RDR)] $
473 (nlHsVarApps intDataCon_RDR [ah_RDR])
476 %************************************************************************
478 \subsubsection{Generating @Bounded@ instance declarations}
480 %************************************************************************
483 gen_Bounded_binds tycon
484 = if isEnumerationTyCon tycon then
485 listToBag [ min_bound_enum, max_bound_enum ]
487 ASSERT(isSingleton data_cons)
488 listToBag [ min_bound_1con, max_bound_1con ]
490 data_cons = tyConDataCons tycon
491 tycon_loc = getSrcSpan tycon
493 ----- enum-flavored: ---------------------------
494 min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR)
495 max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR)
497 data_con_1 = head data_cons
498 data_con_N = last data_cons
499 data_con_1_RDR = getRdrName data_con_1
500 data_con_N_RDR = getRdrName data_con_N
502 ----- single-constructor-flavored: -------------
503 arity = dataConSourceArity data_con_1
505 min_bound_1con = mkVarBind tycon_loc minBound_RDR $
506 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
507 max_bound_1con = mkVarBind tycon_loc maxBound_RDR $
508 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
511 %************************************************************************
513 \subsubsection{Generating @Ix@ instance declarations}
515 %************************************************************************
517 Deriving @Ix@ is only possible for enumeration types and
518 single-constructor types. We deal with them in turn.
520 For an enumeration type, e.g.,
522 data Foo ... = N1 | N2 | ... | Nn
524 things go not too differently from @Enum@:
526 instance ... Ix (Foo ...) where
528 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
532 = case (con2tag_Foo a) of { a# ->
533 case (con2tag_Foo b) of { b# ->
534 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
537 -- Generate code for unsafeIndex, becuase using index leads
538 -- to lots of redundant range tests
539 unsafeIndex c@(a, b) d
540 = case (con2tag_Foo d -# con2tag_Foo a) of
545 p_tag = con2tag_Foo c
547 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
551 = case (con2tag_Foo a) of { a_tag ->
552 case (con2tag_Foo b) of { b_tag ->
553 case (con2tag_Foo c) of { c_tag ->
554 if (c_tag >=# a_tag) then
560 (modulo suitable case-ification to handle the unlifted tags)
562 For a single-constructor type (NB: this includes all tuples), e.g.,
564 data Foo ... = MkFoo a b Int Double c c
566 we follow the scheme given in Figure~19 of the Haskell~1.2 report
570 gen_Ix_binds :: TyCon -> LHsBinds RdrName
573 = if isEnumerationTyCon 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 [nlTuplePat [a_Pat, b_Pat] Boxed] $
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)),
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 [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
609 untag_Expr tycon [(a_RDR, ah_RDR)] (
610 untag_Expr tycon [(b_RDR, bh_RDR)] (
611 untag_Expr tycon [(c_RDR, ch_RDR)] (
612 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
613 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
618 --------------------------------------------------------------
620 = listToBag [single_con_range, single_con_index, single_con_inRange]
623 = case maybeTyConSingleCon tycon of -- just checking...
624 Nothing -> panic "get_Ix_binds"
625 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
626 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
629 con_arity = dataConSourceArity data_con
630 data_con_RDR = getRdrName data_con
632 as_needed = take con_arity as_RDRs
633 bs_needed = take con_arity bs_RDRs
634 cs_needed = take con_arity cs_RDRs
636 con_pat xs = nlConVarPat data_con_RDR xs
637 con_expr = nlHsVarApps data_con_RDR cs_needed
639 --------------------------------------------------------------
641 = mk_easy_FunBind tycon_loc range_RDR
642 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
643 nlHsDo ListComp stmts con_expr
645 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
647 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
648 (nlHsApp (nlHsVar range_RDR)
649 (nlTuple [nlHsVar a, nlHsVar b] Boxed))
653 = mk_easy_FunBind tycon_loc unsafeIndex_RDR
654 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
656 (mk_index (zip3 as_needed bs_needed cs_needed))
658 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
659 mk_index [] = nlHsIntLit 0
660 mk_index [(l,u,i)] = mk_one l u i
661 mk_index ((l,u,i) : rest)
666 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
667 (nlTuple [nlHsVar l, nlHsVar u] Boxed))
668 ) times_RDR (mk_index rest)
671 = nlHsApps unsafeIndex_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, nlHsVar i]
675 = mk_easy_FunBind tycon_loc inRange_RDR
676 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
678 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
680 in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed,
684 %************************************************************************
686 \subsubsection{Generating @Read@ instance declarations}
688 %************************************************************************
698 instance Read T where
702 do x <- ReadP.step Read.readPrec
703 Symbol "%%" <- Lex.lex
704 y <- ReadP.step Read.readPrec
708 do Ident "T1" <- Lex.lex
710 Ident "f1" <- Lex.lex
712 x <- ReadP.reset Read.readPrec
714 return (T1 { f1 = x }))
717 do Ident "T2" <- Lex.lexP
718 x <- ReadP.step Read.readPrec
722 readListPrec = readListPrecDefault
723 readList = readListDefault
727 gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
729 gen_Read_binds get_fixity tycon
730 = listToBag [read_prec, default_readlist, default_readlistprec]
732 -----------------------------------------------------------------------
734 = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
737 = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
738 -----------------------------------------------------------------------
740 loc = getSrcSpan tycon
741 data_cons = tyConDataCons tycon
742 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
744 read_prec = mkVarBind loc readPrec_RDR
745 (nlHsApp (nlHsVar parens_RDR) read_cons)
747 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
748 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
751 = case nullary_cons of
753 [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con))]
754 (result_expr con [])]
755 _ -> [nlHsApp (nlHsVar choose_RDR)
756 (nlList (map mk_pair nullary_cons))]
758 mk_pair con = nlTuple [nlHsLit (mkHsString (data_con_str con)),
759 nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))]
762 read_non_nullary_con data_con
763 = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts body]
765 stmts | is_infix = infix_stmts
766 | length labels > 0 = lbl_stmts
767 | otherwise = prefix_stmts
769 body = result_expr data_con as_needed
770 con_str = data_con_str data_con
772 prefix_stmts -- T a b c
773 = [bindLex (ident_pat (wrapOpParens con_str))]
776 infix_stmts -- a %% b, or a `T` b
779 then [bindLex (symbol_pat con_str)]
780 else [read_punc "`", bindLex (ident_pat con_str), read_punc "`"])
783 lbl_stmts -- T { f1 = a, f2 = b }
784 = [bindLex (ident_pat (wrapOpParens con_str)),
786 ++ concat (intersperse [read_punc ","] field_stmts)
789 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
791 con_arity = dataConSourceArity data_con
792 labels = dataConFieldLabels data_con
793 dc_nm = getName data_con
794 is_infix = dataConIsInfix data_con
795 as_needed = take con_arity as_RDRs
796 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
797 (read_a1:read_a2:_) = read_args
798 prec = getPrec is_infix get_fixity dc_nm
800 ------------------------------------------------------------------------
802 ------------------------------------------------------------------------
803 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
804 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR))
805 con_app c as = nlHsVarApps (getRdrName c) as
806 result_expr c as = nlHsApp (nlHsVar returnM_RDR) (con_app c as)
808 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
809 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
810 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
812 data_con_str con = occNameString (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 | isSym lbl_str
830 bindLex (symbol_pat lbl_str),
833 = [bindLex (ident_pat lbl_str)]
835 lbl_str = occNameString (getOccName lbl)
839 %************************************************************************
841 \subsubsection{Generating @Show@ instance declarations}
843 %************************************************************************
849 data Tree a = Leaf a | Tree a :^: Tree a
851 instance (Show a) => Show (Tree a) where
853 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
855 showStr = showString "Leaf " . showsPrec (app_prec+1) m
857 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
859 showStr = showsPrec (up_prec+1) u .
861 showsPrec (up_prec+1) v
862 -- Note: right-associativity of :^: ignored
864 up_prec = 5 -- Precedence of :^:
865 app_prec = 10 -- Application has precedence one more than
866 -- the most tightly-binding operator
869 gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName
871 gen_Show_binds get_fixity tycon
872 = listToBag [shows_prec, show_list]
874 tycon_loc = getSrcSpan tycon
875 -----------------------------------------------------------------------
876 show_list = mkVarBind tycon_loc showList_RDR
877 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
878 -----------------------------------------------------------------------
879 shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
882 | nullary_con = -- skip the showParen junk...
883 ASSERT(null bs_needed)
884 ([nlWildPat, con_pat], mk_showString_app con_str)
887 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
888 (nlHsPar (nested_compose_Expr show_thingies)))
890 data_con_RDR = getRdrName data_con
891 con_arity = dataConSourceArity data_con
892 bs_needed = take con_arity bs_RDRs
893 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
894 con_pat = nlConVarPat data_con_RDR bs_needed
895 nullary_con = con_arity == 0
896 labels = dataConFieldLabels data_con
897 lab_fields = length labels
898 record_syntax = lab_fields > 0
900 dc_nm = getName data_con
901 dc_occ_nm = getOccName data_con
902 con_str = occNameString dc_occ_nm
903 op_con_str = wrapOpParens con_str
904 backquote_str = wrapOpBackquotes con_str
907 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_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 = wrapOpParens (occNameString 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 wrapOpParens :: String -> String
946 wrapOpParens s | isSym s = '(' : s ++ ")"
949 wrapOpBackquotes :: String -> String
950 wrapOpBackquotes s | isSym s = s
951 | otherwise = '`' : s ++ "`"
953 isSym :: String -> Bool
955 isSym (c:cs) = startsVarSym c || startsConSym c
957 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
961 getPrec :: Bool -> FixityEnv -> Name -> Integer
962 getPrec is_infix get_fixity nm
963 | not is_infix = appPrecedence
964 | otherwise = getPrecedence get_fixity nm
966 appPrecedence :: Integer
967 appPrecedence = fromIntegral maxPrecedence + 1
968 -- One more than the precedence of the most
969 -- tightly-binding operator
971 getPrecedence :: FixityEnv -> Name -> Integer
972 getPrecedence get_fixity nm
973 = case lookupFixity get_fixity nm of
974 Fixity x _ -> fromIntegral x
978 %************************************************************************
980 \subsection{Typeable}
982 %************************************************************************
990 instance Typeable2 T where
991 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
993 We are passed the Typeable2 class as well as T
996 gen_Typeable_binds :: TyCon -> LHsBinds RdrName
997 gen_Typeable_binds tycon
999 mk_easy_FunBind tycon_loc
1000 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1002 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1004 tycon_loc = getSrcSpan tycon
1005 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1007 mk_typeOf_RDR :: TyCon -> RdrName
1008 -- Use the arity of the TyCon to make the right typeOfn function
1009 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1011 arity = tyConArity tycon
1012 suffix | arity == 0 = ""
1013 | otherwise = show arity
1018 %************************************************************************
1022 %************************************************************************
1026 data T a b = T1 a b | T2
1030 $cT1 = mkDataCon $dT "T1" Prefix
1031 $cT2 = mkDataCon $dT "T2" Prefix
1032 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1033 -- the [] is for field labels.
1035 instance (Data a, Data b) => Data (T a b) where
1036 gfoldl k z (T1 a b) = z T `k` a `k` b
1037 gfoldl k z T2 = z T2
1038 -- ToDo: add gmapT,Q,M, gfoldr
1040 gunfold k z c = case conIndex c of
1041 I# 1# -> k (k (z T1))
1044 toConstr (T1 _ _) = $cT1
1050 gen_Data_binds :: FixityEnv
1052 -> (LHsBinds RdrName, -- The method bindings
1053 LHsBinds RdrName) -- Auxiliary bindings
1054 gen_Data_binds fix_env tycon
1055 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind],
1056 -- Auxiliary definitions: the data type and constructors
1057 datatype_bind `consBag` listToBag (map mk_con_bind data_cons))
1059 tycon_loc = getSrcSpan tycon
1060 tycon_name = tyConName tycon
1061 data_cons = tyConDataCons tycon
1062 n_cons = length data_cons
1063 one_constr = n_cons == 1
1066 gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1067 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1068 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1071 con_name = getRdrName con
1072 as_needed = take (dataConSourceArity con) as_RDRs
1073 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1075 ------------ gunfold
1076 gunfold_bind = mk_FunBind tycon_loc
1078 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1082 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1083 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1084 (map gunfold_alt data_cons)
1086 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1087 mk_unfold_rhs dc = foldr nlHsApp
1088 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1089 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1091 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1092 -- redundant test, and annoying warning
1093 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1094 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1098 ------------ toConstr
1099 toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1100 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1102 ------------ dataTypeOf
1103 dataTypeOf_bind = mk_easy_FunBind
1107 (nlHsVar data_type_name)
1111 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1112 datatype_bind = mkVarBind
1115 ( nlHsVar mkDataType_RDR
1116 `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon)))
1117 `nlHsApp` nlList constrs
1119 constrs = [nlHsVar (mk_constr_name con) | con <- data_cons]
1122 ------------ $cT1 etc
1123 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1124 mk_con_bind dc = mkVarBind
1127 (nlHsApps mkConstr_RDR (constr_args dc))
1129 [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1130 nlHsVar data_type_name, -- DataType
1131 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1132 nlList labels, -- Field labels
1133 nlHsVar fixity] -- Fixity
1135 labels = map (nlHsLit . mkHsString . getOccString)
1136 (dataConFieldLabels dc)
1137 dc_occ = getOccName dc
1138 is_infix = isDataSymOcc dc_occ
1139 fixity | is_infix = infix_RDR
1140 | otherwise = prefix_RDR
1142 gfoldl_RDR = varQual_RDR gENERICS FSLIT("gfoldl")
1143 gunfold_RDR = varQual_RDR gENERICS FSLIT("gunfold")
1144 toConstr_RDR = varQual_RDR gENERICS FSLIT("toConstr")
1145 dataTypeOf_RDR = varQual_RDR gENERICS FSLIT("dataTypeOf")
1146 mkConstr_RDR = varQual_RDR gENERICS FSLIT("mkConstr")
1147 mkDataType_RDR = varQual_RDR gENERICS FSLIT("mkDataType")
1148 conIndex_RDR = varQual_RDR gENERICS FSLIT("constrIndex")
1149 prefix_RDR = dataQual_RDR gENERICS FSLIT("Prefix")
1150 infix_RDR = dataQual_RDR gENERICS FSLIT("Infix")
1153 %************************************************************************
1155 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1157 %************************************************************************
1162 con2tag_Foo :: Foo ... -> Int#
1163 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1164 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1167 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1172 = GenCon2Tag | GenTag2Con | GenMaxTag
1174 gen_tag_n_con_monobind
1175 :: ( RdrName, -- (proto)Name for the thing in question
1176 TyCon, -- tycon in question
1180 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1181 | lots_of_constructors
1182 = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)]
1185 = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon))
1188 tycon_loc = getSrcSpan tycon
1190 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1191 -- We can't use gerRdrName because that makes an Exact RdrName
1192 -- and we can't put them in the LocalRdrEnv
1194 -- Give a signature to the bound variable, so
1195 -- that the case expression generated by getTag is
1196 -- monomorphic. In the push-enter model we get better code.
1197 get_tag_rhs = noLoc $ ExprWithTySig
1198 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1199 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1200 (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty))
1202 con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon))
1205 nlHsTyVar (getRdrName intPrimTyCon)
1207 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1209 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1210 mk_stuff con = ([nlWildConPat con],
1211 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1213 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1214 = mk_FunBind (getSrcSpan tycon) rdr_name
1215 [([nlConVarPat intDataCon_RDR [a_RDR]],
1216 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1217 (nlHsTyVar (getRdrName tycon))))]
1219 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1220 = mkVarBind (getSrcSpan tycon) rdr_name
1221 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1223 max_tag = case (tyConDataCons tycon) of
1224 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1228 %************************************************************************
1230 \subsection{Utility bits for generating bindings}
1232 %************************************************************************
1235 ToDo: Better SrcLocs.
1239 LHsExpr RdrName -- What to do for equality
1240 -> LHsExpr RdrName -> LHsExpr RdrName
1242 careful_compare_Case :: -- checks for primitive types...
1243 TyCon -- The tycon we are deriving for
1245 -> LHsExpr RdrName -- What to do for equality
1246 -> LHsExpr RdrName -> LHsExpr RdrName
1249 cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b
1250 -- Was: compare_gen_Case cmp_eq_RDR
1252 compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR
1253 = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case
1254 compare_gen_Case eq a b -- General case
1255 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-}
1256 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr,
1257 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
1258 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr]
1260 careful_compare_Case tycon ty eq a b
1261 | not (isUnLiftedType ty)
1262 = compare_gen_Case eq a b
1263 | otherwise -- We have to do something special for primitive things...
1264 = nlHsIf (genOpApp a relevant_eq_op b)
1266 (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr)
1268 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1269 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1272 box_if_necy :: String -- The class involved
1273 -> TyCon -- The tycon involved
1274 -> LHsExpr RdrName -- The argument
1275 -> Type -- The argument type
1276 -> LHsExpr RdrName -- Boxed version of the arg
1277 box_if_necy cls_str tycon arg arg_ty
1278 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1281 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1283 assoc_ty_id :: String -- The class involved
1284 -> TyCon -- The tycon involved
1285 -> [(Type,a)] -- The table
1287 -> a -- The result of the lookup
1288 assoc_ty_id cls_str tycon tbl ty
1289 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1290 text "for primitive type" <+> ppr ty)
1291 | otherwise = head res
1293 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1295 eq_op_tbl :: [(Type, PrimOp)]
1297 [(charPrimTy, CharEqOp)
1298 ,(intPrimTy, IntEqOp)
1299 ,(wordPrimTy, WordEqOp)
1300 ,(addrPrimTy, AddrEqOp)
1301 ,(floatPrimTy, FloatEqOp)
1302 ,(doublePrimTy, DoubleEqOp)
1305 lt_op_tbl :: [(Type, PrimOp)]
1307 [(charPrimTy, CharLtOp)
1308 ,(intPrimTy, IntLtOp)
1309 ,(wordPrimTy, WordLtOp)
1310 ,(addrPrimTy, AddrLtOp)
1311 ,(floatPrimTy, FloatLtOp)
1312 ,(doublePrimTy, DoubleLtOp)
1316 [(charPrimTy, getRdrName charDataCon)
1317 ,(intPrimTy, getRdrName intDataCon)
1318 ,(wordPrimTy, wordDataCon_RDR)
1319 ,(addrPrimTy, addrDataCon_RDR)
1320 ,(floatPrimTy, getRdrName floatDataCon)
1321 ,(doublePrimTy, getRdrName doubleDataCon)
1324 -----------------------------------------------------------------------
1326 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1327 and_Expr a b = genOpApp a and_RDR b
1329 -----------------------------------------------------------------------
1331 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1332 eq_Expr tycon ty a b = genOpApp a eq_op b
1335 | not (isUnLiftedType ty) = eq_RDR
1336 | otherwise = primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1337 -- we have to do something special for primitive things...
1341 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1342 untag_Expr tycon [] expr = expr
1343 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1344 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1345 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1347 cmp_tags_Expr :: RdrName -- Comparison op
1348 -> RdrName -> RdrName -- Things to compare
1349 -> LHsExpr RdrName -- What to return if true
1350 -> LHsExpr RdrName -- What to return if false
1353 cmp_tags_Expr op a b true_case false_case
1354 = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case
1357 :: LHsExpr RdrName -> LHsExpr RdrName
1359 enum_from_then_to_Expr
1360 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1363 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1364 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1367 :: LHsExpr RdrName -> LHsExpr RdrName
1370 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1372 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1374 nested_compose_Expr [e] = parenify e
1375 nested_compose_Expr (e:es)
1376 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1378 -- impossible_Expr is used in case RHSs that should never happen.
1379 -- We generate these to keep the desugarer from complaining that they *might* happen!
1380 impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1382 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1383 -- method. It is currently only used by Enum.{succ,pred}
1384 illegal_Expr meth tp msg =
1385 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1387 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1388 -- to include the value of a_RDR in the error string.
1389 illegal_toEnum_tag tp maxtag =
1390 nlHsApp (nlHsVar error_RDR)
1391 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1392 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1393 (nlHsApp (nlHsApp (nlHsApp
1394 (nlHsVar showsPrec_RDR)
1398 (nlHsVar append_RDR)
1399 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1400 (nlHsApp (nlHsApp (nlHsApp
1401 (nlHsVar showsPrec_RDR)
1404 (nlHsLit (mkHsString ")"))))))
1406 parenify e@(L _ (HsVar _)) = e
1407 parenify e = mkHsPar e
1409 -- genOpApp wraps brackets round the operator application, so that the
1410 -- renamer won't subsequently try to re-associate it.
1411 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1415 getSrcSpan = srcLocSpan . getSrcLoc
1419 a_RDR = mkVarUnqual FSLIT("a")
1420 b_RDR = mkVarUnqual FSLIT("b")
1421 c_RDR = mkVarUnqual FSLIT("c")
1422 d_RDR = mkVarUnqual FSLIT("d")
1423 k_RDR = mkVarUnqual FSLIT("k")
1424 z_RDR = mkVarUnqual FSLIT("z")
1425 ah_RDR = mkVarUnqual FSLIT("a#")
1426 bh_RDR = mkVarUnqual FSLIT("b#")
1427 ch_RDR = mkVarUnqual FSLIT("c#")
1428 dh_RDR = mkVarUnqual FSLIT("d#")
1429 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1431 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1432 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1433 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1435 a_Expr = nlHsVar a_RDR
1436 b_Expr = nlHsVar b_RDR
1437 c_Expr = nlHsVar c_RDR
1438 ltTag_Expr = nlHsVar ltTag_RDR
1439 eqTag_Expr = nlHsVar eqTag_RDR
1440 gtTag_Expr = nlHsVar gtTag_RDR
1441 false_Expr = nlHsVar false_RDR
1442 true_Expr = nlHsVar true_RDR
1444 a_Pat = nlVarPat a_RDR
1445 b_Pat = nlVarPat b_RDR
1446 c_Pat = nlVarPat c_RDR
1447 d_Pat = nlVarPat d_RDR
1448 k_Pat = nlVarPat k_RDR
1449 z_Pat = nlVarPat z_RDR
1451 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1452 -- Generates Orig s RdrName, for the binding positions
1453 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1454 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1455 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1457 mk_tc_deriv_name tycon str
1458 = mkDerivedRdrName tc_name mk_occ
1460 tc_name = tyConName tycon
1461 mk_occ tc_occ = mkVarOccFS (mkFastString new_str)
1463 new_str = str ++ occNameString tc_occ ++ "#"
1466 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1467 PrelNames, so PrelNames can't import PrimOp.
1470 primOpRdrName op = getRdrName (primOpId op)
1472 minusInt_RDR = primOpRdrName IntSubOp
1473 eqInt_RDR = primOpRdrName IntEqOp
1474 ltInt_RDR = primOpRdrName IntLtOp
1475 geInt_RDR = primOpRdrName IntGeOp
1476 leInt_RDR = primOpRdrName IntLeOp
1477 tagToEnum_RDR = primOpRdrName TagToEnumOp
1479 error_RDR = getRdrName eRROR_ID