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, mkRdrUnqual, getRdrName, mkDerivedRdrName )
33 import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo )
34 import BasicTypes ( RecFlag(..), Fixity(..), maxPrecedence, Boxity(..) )
35 import FieldLabel ( fieldLabelName )
36 import DataCon ( isNullaryDataCon, dataConTag,
37 dataConOrigArgTys, dataConSourceArity, fIRST_TAG,
40 import Name ( getOccString, getOccName, getSrcLoc, occNameString,
43 isDataSymOcc, isSymOcc
46 import HscTypes ( FixityEnv, lookupFixity )
50 import MkId ( eRROR_ID )
51 import PrimOp ( PrimOp(..) )
52 import SrcLoc ( generatedSrcLoc, SrcLoc )
53 import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon,
54 maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName
56 import TcType ( isUnLiftedType, tcEqType, Type )
57 import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, floatPrimTy, doublePrimTy,
59 import TysWiredIn ( charDataCon, intDataCon, floatDataCon, doubleDataCon )
60 import Util ( zipWithEqual, isSingleton,
61 zipWith3Equal, nOfThem, zipEqual )
62 import Char ( isAlpha )
64 import List ( partition, intersperse )
70 %************************************************************************
72 \subsection{Generating code, by derivable class}
74 %************************************************************************
76 %************************************************************************
78 \subsubsection{Generating @Eq@ instance declarations}
80 %************************************************************************
82 Here are the heuristics for the code we generate for @Eq@:
85 Let's assume we have a data type with some (possibly zero) nullary
86 data constructors and some ordinary, non-nullary ones (the rest,
87 also possibly zero of them). Here's an example, with both \tr{N}ullary
88 and \tr{O}rdinary data cons.
90 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
94 For the ordinary constructors (if any), we emit clauses to do The
98 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
99 (==) (O2 a1) (O2 a2) = a1 == a2
100 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
103 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
104 \tr{a2} are \tr{Float#}s, then we have to generate
106 case (a1 `eqFloat#` a2) of
109 for that particular test.
112 If there are any nullary constructors, we emit a catch-all clause of
116 (==) a b = case (con2tag_Foo a) of { a# ->
117 case (con2tag_Foo b) of { b# ->
118 case (a# ==# b#) of {
123 If there aren't any nullary constructors, we emit a simpler
130 For the @(/=)@ method, we normally just use the default method.
132 If the type is an enumeration type, we could/may/should? generate
133 special code that calls @con2tag_Foo@, much like for @(==)@ shown
137 We thought about doing this: If we're also deriving @Ord@ for this
140 instance ... Eq (Foo ...) where
141 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
142 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
144 However, that requires that \tr{Ord <whatever>} was put in the context
145 for the instance decl, which it probably wasn't, so the decls
146 produced don't get through the typechecker.
151 gen_Eq_binds :: TyCon -> RdrNameMonoBinds
155 tycon_loc = getSrcLoc tycon
156 (nullary_cons, nonnullary_cons)
157 | isNewTyCon tycon = ([], tyConDataCons tycon)
158 | otherwise = partition isNullaryDataCon (tyConDataCons tycon)
161 = if (null nullary_cons) then
162 case maybeTyConSingleCon tycon of
164 Nothing -> -- if cons don't match, then False
165 [([wildPat, wildPat], false_Expr)]
166 else -- calc. and compare the tags
168 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
169 (genOpApp (HsVar ah_RDR) eqInt_RDR (HsVar bh_RDR)))]
171 mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest)
173 mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] (
174 HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR])))
176 ------------------------------------------------------------------
179 con1_pat = mkConPat data_con_RDR as_needed
180 con2_pat = mkConPat data_con_RDR bs_needed
182 data_con_RDR = getRdrName data_con
183 con_arity = length tys_needed
184 as_needed = take con_arity as_RDRs
185 bs_needed = take con_arity bs_RDRs
186 tys_needed = dataConOrigArgTys data_con
188 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
190 nested_eq_expr [] [] [] = true_Expr
191 nested_eq_expr tys as bs
192 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
194 nested_eq ty a b = HsPar (eq_Expr tycon ty (HsVar a) (HsVar b))
197 %************************************************************************
199 \subsubsection{Generating @Ord@ instance declarations}
201 %************************************************************************
203 For a derived @Ord@, we concentrate our attentions on @compare@
205 compare :: a -> a -> Ordering
206 data Ordering = LT | EQ | GT deriving ()
209 We will use the same example data type as above:
211 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
216 We do all the other @Ord@ methods with calls to @compare@:
218 instance ... (Ord <wurble> <wurble>) where
219 a < b = case (compare a b) of { LT -> True; EQ -> False; GT -> False }
220 a <= b = case (compare a b) of { LT -> True; EQ -> True; GT -> False }
221 a >= b = case (compare a b) of { LT -> False; EQ -> True; GT -> True }
222 a > b = case (compare a b) of { LT -> False; EQ -> False; GT -> True }
224 max a b = case (compare a b) of { LT -> b; EQ -> a; GT -> a }
225 min a b = case (compare a b) of { LT -> a; EQ -> b; GT -> b }
227 -- compare to come...
231 @compare@ always has two parts. First, we use the compared
232 data-constructors' tags to deal with the case of different
235 compare a b = case (con2tag_Foo a) of { a# ->
236 case (con2tag_Foo b) of { b# ->
237 case (a# ==# b#) of {
239 False -> case (a# <# b#) of
244 cmp_eq = ... to come ...
248 We are only left with the ``help'' function @cmp_eq@, to deal with
249 comparing data constructors with the same tag.
251 For the ordinary constructors (if any), we emit the sorta-obvious
252 compare-style stuff; for our example:
254 cmp_eq (O1 a1 b1) (O1 a2 b2)
255 = case (compare a1 a2) of { LT -> LT; EQ -> compare b1 b2; GT -> GT }
257 cmp_eq (O2 a1) (O2 a2)
260 cmp_eq (O3 a1 b1 c1) (O3 a2 b2 c2)
261 = case (compare a1 a2) of {
264 EQ -> case compare b1 b2 of {
272 Again, we must be careful about unlifted comparisons. For example,
273 if \tr{a1} and \tr{a2} were \tr{Int#}s in the 2nd example above, we'd need to
277 cmp_eq lt eq gt (O2 a1) (O2 a2)
279 -- or maybe the unfolded equivalent
283 For the remaining nullary constructors, we already know that the
290 If there is only one constructor in the Data Type we don't need the WildCard Pattern.
294 gen_Ord_binds :: TyCon -> RdrNameMonoBinds
297 = compare -- `AndMonoBinds` compare
298 -- The default declaration in PrelBase handles this
300 tycon_loc = getSrcLoc tycon
301 --------------------------------------------------------------------
302 compare = mk_easy_FunMonoBind tycon_loc compare_RDR
303 [a_Pat, b_Pat] [cmp_eq] compare_rhs
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 isNullaryDataCon tycon_data_cons
320 cmp_eq = mk_FunMonoBind 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 = [([wildPat,wildPat], 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 [([wildPat, wildPat], default_rhs)])
338 = ([con1_pat, con2_pat],
339 nested_compare_expr tys_needed as_needed bs_needed)
341 con1_pat = mkConPat data_con_RDR as_needed
342 con2_pat = mkConPat 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 (HsVar a) (HsVar 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 (HsVar a) (HsVar 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 -> RdrNameMonoBinds
408 = succ_enum `AndMonoBinds`
409 pred_enum `AndMonoBinds`
410 to_enum `AndMonoBinds`
411 enum_from `AndMonoBinds`
412 enum_from_then `AndMonoBinds`
415 tycon_loc = getSrcLoc tycon
416 occ_nm = getOccString tycon
419 = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $
420 untag_Expr tycon [(a_RDR, ah_RDR)] $
421 HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon),
422 mkHsVarApps intDataCon_RDR [ah_RDR]])
423 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
424 (HsApp (HsVar (tag2con_RDR tycon))
425 (mkHsApps plus_RDR [mkHsVarApps intDataCon_RDR [ah_RDR],
430 = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $
431 untag_Expr tycon [(a_RDR, ah_RDR)] $
432 HsIf (mkHsApps eq_RDR [mkHsIntLit 0,
433 mkHsVarApps intDataCon_RDR [ah_RDR]])
434 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
435 (HsApp (HsVar (tag2con_RDR tycon))
436 (mkHsApps plus_RDR [mkHsVarApps intDataCon_RDR [ah_RDR],
437 HsLit (HsInt (-1))]))
441 = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $
442 HsIf (mkHsApps and_RDR
443 [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0],
444 mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]])
445 (mkHsVarApps (tag2con_RDR tycon) [a_RDR])
446 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
450 = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $
451 untag_Expr tycon [(a_RDR, ah_RDR)] $
453 [HsVar (tag2con_RDR tycon),
454 HsPar (enum_from_to_Expr
455 (mkHsVarApps intDataCon_RDR [ah_RDR])
456 (HsVar (maxtag_RDR tycon)))]
459 = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $
460 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
461 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
462 HsPar (enum_from_then_to_Expr
463 (mkHsVarApps intDataCon_RDR [ah_RDR])
464 (mkHsVarApps intDataCon_RDR [bh_RDR])
465 (HsIf (mkHsApps gt_RDR [mkHsVarApps intDataCon_RDR [ah_RDR],
466 mkHsVarApps intDataCon_RDR [bh_RDR]])
468 (HsVar (maxtag_RDR tycon))
472 = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $
473 untag_Expr tycon [(a_RDR, ah_RDR)] $
474 (mkHsVarApps intDataCon_RDR [ah_RDR])
477 %************************************************************************
479 \subsubsection{Generating @Bounded@ instance declarations}
481 %************************************************************************
484 gen_Bounded_binds tycon
485 = if isEnumerationTyCon tycon then
486 min_bound_enum `AndMonoBinds` max_bound_enum
488 ASSERT(isSingleton data_cons)
489 min_bound_1con `AndMonoBinds` max_bound_1con
491 data_cons = tyConDataCons tycon
492 tycon_loc = getSrcLoc tycon
494 ----- enum-flavored: ---------------------------
495 min_bound_enum = mkVarMonoBind tycon_loc minBound_RDR (HsVar data_con_1_RDR)
496 max_bound_enum = mkVarMonoBind tycon_loc maxBound_RDR (HsVar 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 = mkVarMonoBind tycon_loc minBound_RDR $
507 mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
508 max_bound_1con = mkVarMonoBind tycon_loc maxBound_RDR $
509 mkHsVarApps 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#))
540 then case (con2tag_Foo d -# con2tag_Foo a) of
542 else error "Ix.Foo.index: out of range"
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 -> RdrNameMonoBinds
574 = if isEnumerationTyCon tycon
578 tycon_str = getOccString tycon
579 tycon_loc = getSrcLoc tycon
581 --------------------------------------------------------------
582 enum_ixes = enum_range `AndMonoBinds`
583 enum_index `AndMonoBinds` enum_inRange
586 = mk_easy_FunMonoBind tycon_loc range_RDR
587 [TuplePat [a_Pat, b_Pat] Boxed] [] $
588 untag_Expr tycon [(a_RDR, ah_RDR)] $
589 untag_Expr tycon [(b_RDR, bh_RDR)] $
590 HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $
591 HsPar (enum_from_to_Expr
592 (mkHsVarApps intDataCon_RDR [ah_RDR])
593 (mkHsVarApps intDataCon_RDR [bh_RDR]))
596 = mk_easy_FunMonoBind tycon_loc index_RDR
597 [AsPat c_RDR (TuplePat [a_Pat, wildPat] Boxed),
599 HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) (
600 untag_Expr tycon [(a_RDR, ah_RDR)] (
601 untag_Expr tycon [(d_RDR, dh_RDR)] (
603 rhs = mkHsVarApps intDataCon_RDR [c_RDR]
606 (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR))
607 [mkSimpleHsAlt (VarPat c_RDR) rhs]
611 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n"))))
616 = mk_easy_FunMonoBind tycon_loc inRange_RDR
617 [TuplePat [a_Pat, b_Pat] Boxed, c_Pat] [] (
618 untag_Expr tycon [(a_RDR, ah_RDR)] (
619 untag_Expr tycon [(b_RDR, bh_RDR)] (
620 untag_Expr tycon [(c_RDR, ch_RDR)] (
621 HsIf (genOpApp (HsVar ch_RDR) geInt_RDR (HsVar ah_RDR)) (
622 (genOpApp (HsVar ch_RDR) leInt_RDR (HsVar bh_RDR))
627 --------------------------------------------------------------
629 = single_con_range `AndMonoBinds`
630 single_con_index `AndMonoBinds`
634 = case maybeTyConSingleCon tycon of -- just checking...
635 Nothing -> panic "get_Ix_binds"
636 Just dc | any isUnLiftedType (dataConOrigArgTys dc)
637 -> pprPanic "Can't derive Ix for a single-constructor type with primitive argument types:" (ppr tycon)
640 con_arity = dataConSourceArity data_con
641 data_con_RDR = getRdrName data_con
643 as_needed = take con_arity as_RDRs
644 bs_needed = take con_arity bs_RDRs
645 cs_needed = take con_arity cs_RDRs
647 con_pat xs = mkConPat data_con_RDR xs
648 con_expr = mkHsVarApps data_con_RDR cs_needed
650 --------------------------------------------------------------
652 = mk_easy_FunMonoBind tycon_loc range_RDR
653 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed] [] $
654 mkHsDo ListComp stmts tycon_loc
656 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
658 [ResultStmt con_expr tycon_loc]
660 mk_qual a b c = BindStmt (VarPat c)
661 (HsApp (HsVar range_RDR)
662 (ExplicitTuple [HsVar a, HsVar b] Boxed))
667 = mk_easy_FunMonoBind tycon_loc index_RDR
668 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
669 con_pat cs_needed] [range_size] (
670 foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed))
672 mk_index multiply_by (l, u, i)
674 (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed,
678 (HsApp (HsVar rangeSize_RDR)
679 (ExplicitTuple [HsVar l, HsVar u] Boxed))
680 ) times_RDR multiply_by
684 = mk_easy_FunMonoBind tycon_loc rangeSize_RDR
685 [TuplePat [a_Pat, b_Pat] Boxed] [] (
687 (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed,
689 ) plus_RDR (mkHsIntLit 1))
693 = mk_easy_FunMonoBind tycon_loc inRange_RDR
694 [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
697 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed))
699 in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed,
703 %************************************************************************
705 \subsubsection{Generating @Read@ instance declarations}
707 %************************************************************************
717 instance Read T where
721 do x <- ReadP.step Read.readPrec
722 Symbol "%%" <- Lex.lex
723 y <- ReadP.step Read.readPrec
727 do Ident "T1" <- Lex.lex
729 Ident "f1" <- Lex.lex
731 x <- ReadP.reset Read.readPrec
733 return (T1 { f1 = x }))
736 do Ident "T2" <- Lex.lexP
737 x <- ReadP.step Read.readPrec
741 readListPrec = readListPrecDefault
742 readList = readListDefault
746 gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
748 gen_Read_binds get_fixity tycon
749 = read_prec `AndMonoBinds` default_binds
751 -----------------------------------------------------------------------
753 = mkVarMonoBind loc readList_RDR (HsVar readListDefault_RDR)
755 mkVarMonoBind loc readListPrec_RDR (HsVar readListPrecDefault_RDR)
756 -----------------------------------------------------------------------
758 loc = getSrcLoc tycon
759 data_cons = tyConDataCons tycon
760 (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons
762 read_prec = mkVarMonoBind loc readPrec_RDR
763 (HsApp (HsVar parens_RDR) read_cons)
765 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
766 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
769 = case nullary_cons of
771 [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)),
772 result_stmt con []] loc]
773 _ -> [HsApp (HsVar choose_RDR)
774 (ExplicitList placeHolderType (map mk_pair nullary_cons))]
776 mk_pair con = ExplicitTuple [HsLit (data_con_str con),
777 HsApp (HsVar returnM_RDR) (HsVar (getRdrName con))]
780 read_non_nullary_con data_con
781 = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc]
783 stmts | is_infix = infix_stmts
784 | length labels > 0 = lbl_stmts
785 | otherwise = prefix_stmts
787 prefix_stmts -- T a b c
788 = [bindLex (ident_pat (data_con_str data_con))]
790 ++ [result_stmt data_con as_needed]
792 infix_stmts -- a %% b
794 bindLex (symbol_pat (data_con_str data_con)),
796 result_stmt data_con [a1,a2]]
798 lbl_stmts -- T { f1 = a, f2 = b }
799 = [bindLex (ident_pat (data_con_str data_con)),
801 ++ concat (intersperse [read_punc ","] field_stmts)
802 ++ [read_punc "}", result_stmt data_con as_needed]
804 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
806 con_arity = dataConSourceArity data_con
807 labels = dataConFieldLabels data_con
808 dc_nm = getName data_con
809 is_infix = isDataSymOcc (getOccName dc_nm)
810 as_needed = take con_arity as_RDRs
811 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
812 (read_a1:read_a2:_) = read_args
813 (a1:a2:_) = as_needed
814 prec = getPrec is_infix get_fixity dc_nm
816 ------------------------------------------------------------------------
818 ------------------------------------------------------------------------
819 mk_alt e1 e2 = genOpApp e1 alt_RDR e2
820 bindLex pat = BindStmt pat (HsVar lexP_RDR) loc
821 result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc
822 con_app c as = mkHsVarApps (getRdrName c) as
824 punc_pat s = ConPatIn punc_RDR (PrefixCon [LitPat (mkHsString s)]) -- Punc 'c'
825 ident_pat s = ConPatIn ident_RDR (PrefixCon [LitPat s]) -- Ident "foo"
826 symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s]) -- Symbol ">>"
828 data_con_str con = mkHsString (occNameUserString (getOccName con))
830 read_punc c = bindLex (punc_pat c)
832 | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty)
833 | otherwise = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc
835 read_field lbl a = read_lbl lbl ++
837 BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc]
839 -- When reading field labels we might encounter
844 read_lbl lbl | is_id_start (head lbl_str)
845 = [bindLex (ident_pat lbl_lit)]
848 bindLex (symbol_pat lbl_lit),
851 lbl_str = occNameUserString (getOccName (fieldLabelName lbl))
852 lbl_lit = mkHsString lbl_str
853 is_id_start c = isAlpha c || c == '_'
857 %************************************************************************
859 \subsubsection{Generating @Show@ instance declarations}
861 %************************************************************************
867 data Tree a = Leaf a | Tree a :^: Tree a
869 instance (Show a) => Show (Tree a) where
871 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
873 showStr = showString "Leaf " . showsPrec (app_prec+1) m
875 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
877 showStr = showsPrec (up_prec+1) u .
879 showsPrec (up_prec+1) v
880 -- Note: right-associativity of :^: ignored
882 up_prec = 5 -- Precedence of :^:
883 app_prec = 10 -- Application has precedence one more than
884 -- the most tightly-binding operator
887 gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds
889 gen_Show_binds get_fixity tycon
890 = shows_prec `AndMonoBinds` show_list
892 tycon_loc = getSrcLoc tycon
893 -----------------------------------------------------------------------
894 show_list = mkVarMonoBind tycon_loc showList_RDR
895 (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0))))
896 -----------------------------------------------------------------------
897 shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
900 | nullary_con = -- skip the showParen junk...
901 ASSERT(null bs_needed)
902 ([wildPat, con_pat], mk_showString_app con_str)
905 showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one))))
906 (HsPar (nested_compose_Expr show_thingies)))
908 data_con_RDR = getRdrName data_con
909 con_arity = dataConSourceArity data_con
910 bs_needed = take con_arity bs_RDRs
911 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
912 con_pat = mkConPat data_con_RDR bs_needed
913 nullary_con = con_arity == 0
914 labels = dataConFieldLabels data_con
915 lab_fields = length labels
916 record_syntax = lab_fields > 0
918 dc_nm = getName data_con
919 dc_occ_nm = getOccName data_con
920 con_str = occNameUserString dc_occ_nm
923 | is_infix = [show_arg1, mk_showString_app (" " ++ con_str ++ " "), show_arg2]
924 | record_syntax = mk_showString_app (con_str ++ " {") :
925 show_record_args ++ [mk_showString_app "}"]
926 | otherwise = mk_showString_app (con_str ++ " ") : show_prefix_args
928 show_label l = mk_showString_app (the_name ++ " = ")
929 -- Note the spaces around the "=" sign. If we don't have them
930 -- then we get Foo { x=-1 } and the "=-" parses as a single
931 -- lexeme. Only the space after the '=' is necessary, but
932 -- it seems tidier to have them both sides.
934 occ_nm = getOccName (fieldLabelName l)
935 nm = occNameUserString occ_nm
936 is_op = isSymOcc occ_nm -- Legal, but rare.
937 the_name | is_op = '(':nm ++ ")"
940 show_args = zipWith show_arg bs_needed arg_tys
941 (show_arg1:show_arg2:_) = show_args
942 show_prefix_args = intersperse (HsVar showSpace_RDR) show_args
944 -- Assumption for record syntax: no of fields == no of labelled fields
945 -- (and in same order)
946 show_record_args = concat $
947 intersperse [mk_showString_app ", "] $
948 [ [show_label lbl, arg]
949 | (lbl,arg) <- zipEqual "gen_Show_binds"
952 -- Generates (showsPrec p x) for argument x, but it also boxes
953 -- the argument first if necessary. Note that this prints unboxed
954 -- things without any '#' decorations; could change that if need be
955 show_arg b arg_ty = mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec),
956 box_if_necy "Show" tycon (HsVar b) arg_ty]
959 is_infix = isDataSymOcc dc_occ_nm
960 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
961 arg_prec | record_syntax = 0 -- Record fields don't need parens
962 | otherwise = con_prec_plus_one
964 mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (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 (Typeable a, Typeable b) => Typeable (T a b) where
998 typeOf _ = mkTypeRep (mkTyConRep "T")
999 [typeOf (undefined::a),
1000 typeOf (undefined::b)]
1002 Notice the use of lexically scoped type variables.
1005 gen_Typeable_binds :: TyCon -> RdrNameMonoBinds
1006 gen_Typeable_binds tycon
1007 = mk_easy_FunMonoBind tycon_loc typeOf_RDR [wildPat] []
1008 (mkHsApps mkTypeRep_RDR [tycon_rep, arg_reps])
1010 tycon_loc = getSrcLoc tycon
1011 tyvars = tyConTyVars tycon
1012 tycon_rep = HsVar mkTyConRep_RDR `HsApp` HsLit (mkHsString (showSDoc (ppr tycon)))
1013 arg_reps = ExplicitList placeHolderType (map mk tyvars)
1014 mk tyvar = HsApp (HsVar typeOf_RDR)
1015 (ExprWithTySig (HsVar undefined_RDR)
1016 (HsTyVar (getRdrName tyvar)))
1021 %************************************************************************
1025 %************************************************************************
1029 data T a b = T1 a b | T2
1033 $cT1 = mkConstr 1 "T1" Prefix
1034 $cT2 = mkConstr 2 "T2" Prefix
1035 $dT = mkDataType [$con_T1, $con_T2]
1037 instance (Data a, Data b) => Data (T a b) where
1038 gfoldl k z (T1 a b) = z T `k` a `k` b
1039 gfoldl k z T2 = z T2
1040 -- ToDo: add gmapT,Q,M, gfoldr
1042 fromConstr c = case conIndex c of
1043 I# 1# -> T1 undefined undefined
1046 toConstr (T1 _ _) = $cT1
1052 gen_Data_binds :: FixityEnv
1054 -> (RdrNameMonoBinds, -- The method bindings
1055 RdrNameMonoBinds) -- Auxiliary bindings
1056 gen_Data_binds fix_env tycon
1057 = (andMonoBindList [gfoldl_bind, fromCon_bind, toCon_bind, dataTypeOf_bind],
1058 -- Auxiliary definitions: the data type and constructors
1059 datatype_bind `AndMonoBinds` andMonoBindList (map mk_con_bind data_cons))
1061 tycon_loc = getSrcLoc tycon
1062 tycon_name = tyConName tycon
1063 data_cons = tyConDataCons tycon
1066 gfoldl_bind = mk_FunMonoBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons)
1067 gfoldl_eqn con = ([VarPat k_RDR, VarPat z_RDR, mkConPat con_name as_needed],
1068 foldl mk_k_app (HsVar z_RDR `HsApp` HsVar con_name) as_needed)
1071 con_name = getRdrName con
1072 as_needed = take (dataConSourceArity con) as_RDRs
1073 mk_k_app e v = HsPar (mkHsOpApp e k_RDR (HsVar v))
1075 ------------ fromConstr
1076 fromCon_bind = mk_FunMonoBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)]
1077 from_con_rhs = HsCase (HsVar conIndex_RDR `HsApp` c_Expr)
1078 (map from_con_alt data_cons) tycon_loc
1079 from_con_alt dc = mkSimpleHsAlt (ConPatIn intDataCon_RDR (PrefixCon [LitPat (HsIntPrim (toInteger (dataConTag dc)))]))
1080 (mkHsVarApps (getRdrName dc)
1081 (replicate (dataConSourceArity dc) undefined_RDR))
1083 ------------ toConstr
1084 toCon_bind = mk_FunMonoBind tycon_loc toConstr_RDR (map to_con_eqn data_cons)
1085 to_con_eqn dc = ([mkWildConPat dc], HsVar (mk_constr_name dc))
1087 ------------ dataTypeOf
1088 dataTypeOf_bind = mk_easy_FunMonoBind tycon_loc dataTypeOf_RDR [wildPat]
1089 [] (HsVar data_type_name)
1092 data_type_name = mkDerivedRdrName tycon_name mkDataTOcc
1093 datatype_bind = mkVarMonoBind tycon_loc data_type_name
1094 (HsVar mkDataType_RDR `HsApp`
1095 ExplicitList placeHolderType constrs)
1096 constrs = [HsVar (mk_constr_name con) | con <- data_cons]
1099 ------------ $cT1 etc
1100 mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc
1101 mk_con_bind dc = mkVarMonoBind tycon_loc (mk_constr_name dc)
1102 (mkHsApps mkConstr_RDR (constr_args dc))
1103 constr_args dc = [mkHsIntLit (toInteger (dataConTag dc)), -- Tag
1104 HsLit (mkHsString (occNameUserString dc_occ)), -- String name
1105 HsVar fixity] -- Fixity
1107 dc_occ = getOccName dc
1108 is_infix = isDataSymOcc dc_occ
1109 fixity | is_infix = infix_RDR
1110 | otherwise = prefix_RDR
1112 gfoldl_RDR = varQual_RDR gENERICS_Name FSLIT("gfoldl")
1113 fromConstr_RDR = varQual_RDR gENERICS_Name FSLIT("fromConstr")
1114 toConstr_RDR = varQual_RDR gENERICS_Name FSLIT("toConstr")
1115 dataTypeOf_RDR = varQual_RDR gENERICS_Name FSLIT("dataTypeOf")
1116 mkConstr_RDR = varQual_RDR gENERICS_Name FSLIT("mkConstr")
1117 mkDataType_RDR = varQual_RDR gENERICS_Name FSLIT("mkDataType")
1118 conIndex_RDR = varQual_RDR gENERICS_Name FSLIT("conIndex")
1119 prefix_RDR = dataQual_RDR gENERICS_Name FSLIT("Prefix")
1120 infix_RDR = dataQual_RDR gENERICS_Name FSLIT("Infix")
1123 %************************************************************************
1125 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1127 %************************************************************************
1132 con2tag_Foo :: Foo ... -> Int#
1133 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1134 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1137 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1142 = GenCon2Tag | GenTag2Con | GenMaxTag
1144 gen_tag_n_con_monobind
1145 :: (RdrName, -- (proto)Name for the thing in question
1146 TyCon, -- tycon in question
1150 gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag)
1151 | lots_of_constructors
1152 = mk_FunMonoBind loc rdr_name [([], get_tag_rhs)]
1155 = mk_FunMonoBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1158 loc = getSrcLoc tycon
1160 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1161 -- We can't use gerRdrName because that makes an Exact RdrName
1162 -- and we can't put them in the LocalRdrEnv
1164 -- Give a signature to the bound variable, so
1165 -- that the case expression generated by getTag is
1166 -- monomorphic. In the push-enter model we get better code.
1167 get_tag_rhs = ExprWithTySig
1168 (HsLam (mkSimpleHsAlt (VarPat a_RDR)
1169 (HsApp (HsVar getTag_RDR) a_Expr)))
1170 (mkExplicitHsForAllTy (map UserTyVar tvs) [] con2tag_ty)
1172 con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon))
1175 HsTyVar (getRdrName intPrimTyCon)
1177 lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1179 mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr)
1180 mk_stuff con = ([mkWildConPat con],
1181 HsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1183 gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con)
1184 = mk_FunMonoBind (getSrcLoc tycon) rdr_name
1185 [([mkConPat intDataCon_RDR [a_RDR]],
1186 ExprWithTySig (HsApp (HsVar tagToEnum_RDR) a_Expr)
1187 (HsTyVar (getRdrName tycon)))]
1189 gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag)
1190 = mkVarMonoBind (getSrcLoc tycon) rdr_name
1191 (HsApp (HsVar intDataCon_RDR) (HsLit (HsIntPrim max_tag)))
1193 max_tag = case (tyConDataCons tycon) of
1194 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1198 %************************************************************************
1200 \subsection{Utility bits for generating bindings}
1202 %************************************************************************
1204 @mk_easy_FunMonoBind fun pats binds expr@ generates:
1206 fun pat1 pat2 ... patN = expr where binds
1209 @mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for
1210 multi-clause definitions; it generates:
1212 fun p1a p1b ... p1N = e1
1213 fun p2a p2b ... p2N = e2
1215 fun pMa pMb ... pMN = eM
1219 mkVarMonoBind :: SrcLoc -> RdrName -> RdrNameHsExpr -> RdrNameMonoBinds
1220 mkVarMonoBind loc var rhs = mk_easy_FunMonoBind loc var [] [] rhs
1222 mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat]
1223 -> [RdrNameMonoBinds] -> RdrNameHsExpr
1226 mk_easy_FunMonoBind loc fun pats binds expr
1227 = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc
1229 mk_easy_Match loc pats binds expr
1230 = mk_match loc pats expr (mkMonoBind Recursive (andMonoBindList binds))
1231 -- The renamer expects everything in its input to be a
1232 -- "recursive" MonoBinds, and it is its job to sort things out
1235 mk_FunMonoBind :: SrcLoc -> RdrName
1236 -> [([RdrNamePat], RdrNameHsExpr)]
1239 mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind"
1240 mk_FunMonoBind loc fun pats_and_exprs
1241 = FunMonoBind fun False{-not infix-}
1242 [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ]
1245 mk_match loc pats expr binds
1246 = Match (map paren pats) Nothing
1247 (GRHSs (unguardedRHS expr loc) binds placeHolderType)
1249 paren p@(VarPat _) = p
1250 paren other_p = ParPat other_p
1252 mkWildConPat :: DataCon -> Pat RdrName
1253 mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat))
1256 wildPat = WildPat placeHolderType -- Pre-typechecking
1259 ToDo: Better SrcLocs.
1263 RdrNameHsExpr -- What to do for equality
1264 -> RdrNameHsExpr -> RdrNameHsExpr
1266 careful_compare_Case :: -- checks for primitive types...
1267 TyCon -- The tycon we are deriving for
1269 -> RdrNameHsExpr -- What to do for equality
1270 -> RdrNameHsExpr -> RdrNameHsExpr
1273 cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b
1274 -- Was: compare_gen_Case cmp_eq_RDR
1276 compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR
1277 = HsApp (HsApp (HsVar compare_RDR) a) b -- Simple case
1278 compare_gen_Case eq a b -- General case
1279 = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-}
1280 [mkSimpleHsAlt (mkNullaryConPat ltTag_RDR) ltTag_Expr,
1281 mkSimpleHsAlt (mkNullaryConPat eqTag_RDR) eq,
1282 mkSimpleHsAlt (mkNullaryConPat gtTag_RDR) gtTag_Expr]
1285 careful_compare_Case tycon ty eq a b
1286 | not (isUnLiftedType ty)
1287 = compare_gen_Case eq a b
1288 | otherwise -- We have to do something special for primitive things...
1289 = HsIf (genOpApp a relevant_eq_op b)
1291 (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc)
1294 relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty)
1295 relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty)
1298 box_if_necy :: String -- The class involved
1299 -> TyCon -- The tycon involved
1300 -> RdrNameHsExpr -- The argument
1301 -> Type -- The argument type
1302 -> RdrNameHsExpr -- Boxed version of the arg
1303 box_if_necy cls_str tycon arg arg_ty
1304 | isUnLiftedType arg_ty = HsApp (HsVar box_con) arg
1307 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1309 assoc_ty_id :: String -- The class involved
1310 -> TyCon -- The tycon involved
1311 -> [(Type,a)] -- The table
1313 -> a -- The result of the lookup
1314 assoc_ty_id cls_str tycon tbl ty
1315 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1316 text "for primitive type" <+> ppr ty)
1317 | otherwise = head res
1319 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1321 eq_op_tbl :: [(Type, PrimOp)]
1323 [(charPrimTy, CharEqOp)
1324 ,(intPrimTy, IntEqOp)
1325 ,(wordPrimTy, WordEqOp)
1326 ,(addrPrimTy, AddrEqOp)
1327 ,(floatPrimTy, FloatEqOp)
1328 ,(doublePrimTy, DoubleEqOp)
1331 lt_op_tbl :: [(Type, PrimOp)]
1333 [(charPrimTy, CharLtOp)
1334 ,(intPrimTy, IntLtOp)
1335 ,(wordPrimTy, WordLtOp)
1336 ,(addrPrimTy, AddrLtOp)
1337 ,(floatPrimTy, FloatLtOp)
1338 ,(doublePrimTy, DoubleLtOp)
1342 [(charPrimTy, getRdrName charDataCon)
1343 ,(intPrimTy, getRdrName intDataCon)
1344 ,(wordPrimTy, wordDataCon_RDR)
1345 ,(addrPrimTy, addrDataCon_RDR)
1346 ,(floatPrimTy, getRdrName floatDataCon)
1347 ,(doublePrimTy, getRdrName doubleDataCon)
1350 -----------------------------------------------------------------------
1352 and_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1353 and_Expr a b = genOpApp a and_RDR b
1355 -----------------------------------------------------------------------
1357 eq_Expr :: TyCon -> Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1358 eq_Expr tycon ty a b = genOpApp a eq_op b
1361 | not (isUnLiftedType ty) = eq_RDR
1363 -- we have to do something special for primitive things...
1364 primOpRdrName (assoc_ty_id "Eq" tycon eq_op_tbl ty)
1368 untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr
1369 untag_Expr tycon [] expr = expr
1370 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1371 = HsCase (HsPar (mkHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1372 [mkSimpleHsAlt (VarPat put_tag_here) (untag_Expr tycon more expr)]
1375 cmp_tags_Expr :: RdrName -- Comparison op
1376 -> RdrName -> RdrName -- Things to compare
1377 -> RdrNameHsExpr -- What to return if true
1378 -> RdrNameHsExpr -- What to return if false
1381 cmp_tags_Expr op a b true_case false_case
1382 = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc
1385 :: RdrNameHsExpr -> RdrNameHsExpr
1387 enum_from_then_to_Expr
1388 :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr
1391 enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2
1392 enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2
1395 :: RdrNameHsExpr -> RdrNameHsExpr
1398 showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2
1400 nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr
1402 nested_compose_Expr [e] = parenify e
1403 nested_compose_Expr (e:es)
1404 = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1406 -- impossible_Expr is used in case RHSs that should never happen.
1407 -- We generate these to keep the desugarer from complaining that they *might* happen!
1408 impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv")))
1410 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1411 -- method. It is currently only used by Enum.{succ,pred}
1412 illegal_Expr meth tp msg =
1413 HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg))))
1415 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1416 -- to include the value of a_RDR in the error string.
1417 illegal_toEnum_tag tp maxtag =
1418 HsApp (HsVar error_RDR)
1419 (HsApp (HsApp (HsVar append_RDR)
1420 (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag (")))))
1421 (HsApp (HsApp (HsApp
1422 (HsVar showsPrec_RDR)
1427 (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,"))))
1428 (HsApp (HsApp (HsApp
1429 (HsVar showsPrec_RDR)
1432 (HsLit (HsString (mkFastString ")")))))))
1434 parenify e@(HsVar _) = e
1435 parenify e = HsPar e
1437 -- genOpApp wraps brackets round the operator application, so that the
1438 -- renamer won't subsequently try to re-associate it.
1439 genOpApp e1 op e2 = HsPar (mkHsOpApp e1 op e2)
1443 a_RDR = mkVarUnqual FSLIT("a")
1444 b_RDR = mkVarUnqual FSLIT("b")
1445 c_RDR = mkVarUnqual FSLIT("c")
1446 d_RDR = mkVarUnqual FSLIT("d")
1447 k_RDR = mkVarUnqual FSLIT("k")
1448 z_RDR = mkVarUnqual FSLIT("z")
1449 ah_RDR = mkVarUnqual FSLIT("a#")
1450 bh_RDR = mkVarUnqual FSLIT("b#")
1451 ch_RDR = mkVarUnqual FSLIT("c#")
1452 dh_RDR = mkVarUnqual FSLIT("d#")
1453 cmp_eq_RDR = mkVarUnqual FSLIT("cmp_eq")
1454 rangeSize_RDR = mkVarUnqual FSLIT("rangeSize")
1456 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1457 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1458 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1460 a_Expr = HsVar a_RDR
1461 b_Expr = HsVar b_RDR
1462 c_Expr = HsVar c_RDR
1463 ltTag_Expr = HsVar ltTag_RDR
1464 eqTag_Expr = HsVar eqTag_RDR
1465 gtTag_Expr = HsVar gtTag_RDR
1466 false_Expr = HsVar false_RDR
1467 true_Expr = HsVar true_RDR
1469 a_Pat = VarPat a_RDR
1470 b_Pat = VarPat b_RDR
1471 c_Pat = VarPat c_RDR
1472 d_Pat = VarPat d_RDR
1474 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1475 -- Generates Orig RdrNames, for the binding positions
1476 con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_"
1477 tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_"
1478 maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_"
1480 mk_tc_deriv_name tycon str
1481 = mkDerivedRdrName tc_name mk_occ
1483 tc_name = tyConName tycon
1484 mk_occ tc_occ = mkOccFS varName (mkFastString new_str)
1486 new_str = str ++ occNameString tc_occ ++ "#"
1489 RdrNames for PrimOps. Can't be done in PrelNames, because PrimOp imports
1490 PrelNames, so PrelNames can't import PrimOp.
1493 primOpRdrName op = getRdrName (primOpId op)
1495 minusInt_RDR = primOpRdrName IntSubOp
1496 eqInt_RDR = primOpRdrName IntEqOp
1497 ltInt_RDR = primOpRdrName IntLtOp
1498 geInt_RDR = primOpRdrName IntGeOp
1499 leInt_RDR = primOpRdrName IntLeOp
1500 tagToEnum_RDR = primOpRdrName TagToEnumOp
1502 error_RDR = getRdrName eRROR_ID