2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcGenDeriv: Generating derived instance declarations
8 This module is nominally ``subordinate'' to @TcDeriv@, which is the
9 ``official'' interface to deriving-related things.
11 This is where we do all the grimy bindings' generation.
15 DerivAuxBinds, isDupAux,
27 FFoldType(..), functorLikeTraverse,
28 deepSubtypesContaining, foldDataConArgs,
30 gen_Traversable_binds,
34 #include "HsVersions.h"
61 import Data.List ( partition, intersperse )
65 type DerivAuxBinds = [DerivAuxBind]
67 data DerivAuxBind -- Please add these auxiliary top-level bindings
68 = GenCon2Tag TyCon -- The con2Tag for given TyCon
69 | GenTag2Con TyCon -- ...ditto tag2Con
70 | GenMaxTag TyCon -- ...and maxTag
71 -- All these generate ZERO-BASED tag operations
72 -- I.e first constructor has tag 0
74 -- Scrap your boilerplate
75 | MkDataCon DataCon -- For constructor C we get $cC :: Constr
76 | MkTyCon TyCon -- For tycon T we get $tT :: DataType
79 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
80 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
81 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
82 isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2
83 isDupAux (MkDataCon dc1) (MkDataCon dc2) = dc1 == dc2
84 isDupAux (MkTyCon tc1) (MkTyCon tc2) = tc1 == tc2
89 %************************************************************************
93 %************************************************************************
95 Here are the heuristics for the code we generate for @Eq@:
98 Let's assume we have a data type with some (possibly zero) nullary
99 data constructors and some ordinary, non-nullary ones (the rest,
100 also possibly zero of them). Here's an example, with both \tr{N}ullary
101 and \tr{O}rdinary data cons.
103 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
107 For the ordinary constructors (if any), we emit clauses to do The
111 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
112 (==) (O2 a1) (O2 a2) = a1 == a2
113 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
116 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
117 \tr{a2} are \tr{Float#}s, then we have to generate
119 case (a1 `eqFloat#` a2) of
122 for that particular test.
125 If there are any nullary constructors, we emit a catch-all clause of
129 (==) a b = case (con2tag_Foo a) of { a# ->
130 case (con2tag_Foo b) of { b# ->
131 case (a# ==# b#) of {
136 If there aren't any nullary constructors, we emit a simpler
143 For the @(/=)@ method, we normally just use the default method.
145 If the type is an enumeration type, we could/may/should? generate
146 special code that calls @con2tag_Foo@, much like for @(==)@ shown
150 We thought about doing this: If we're also deriving @Ord@ for this
153 instance ... Eq (Foo ...) where
154 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
155 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
157 However, that requires that \tr{Ord <whatever>} was put in the context
158 for the instance decl, which it probably wasn't, so the decls
159 produced don't get through the typechecker.
164 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
165 gen_Eq_binds loc tycon
166 = (method_binds, aux_binds)
168 (nullary_cons, nonnullary_cons)
169 | isNewTyCon tycon = ([], tyConDataCons tycon)
170 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
172 no_nullary_cons = null nullary_cons
174 rest | no_nullary_cons
175 = case tyConSingleDataCon_maybe tycon of
177 Nothing -> -- if cons don't match, then False
178 [([nlWildPat, nlWildPat], false_Expr)]
179 | otherwise -- calc. and compare the tags
181 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
182 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
184 aux_binds | no_nullary_cons = []
185 | otherwise = [GenCon2Tag tycon]
187 method_binds = listToBag [
188 mk_FunBind loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest),
189 mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
190 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))]
192 ------------------------------------------------------------------
195 con1_pat = nlConVarPat data_con_RDR as_needed
196 con2_pat = nlConVarPat data_con_RDR bs_needed
198 data_con_RDR = getRdrName data_con
199 con_arity = length tys_needed
200 as_needed = take con_arity as_RDRs
201 bs_needed = take con_arity bs_RDRs
202 tys_needed = dataConOrigArgTys data_con
204 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
206 nested_eq_expr [] [] [] = true_Expr
207 nested_eq_expr tys as bs
208 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
210 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
213 %************************************************************************
217 %************************************************************************
219 Note [Generating Ord instances]
220 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
221 Suppose constructors are K1..Kn, and some are nullary.
222 The general form we generate is:
224 * Do case on first argument
233 If i = 1, 2, n-1, n, generate a single case.
236 K2 ... -> ...eq_rhs(K2)...
239 Otherwise do a tag compare against the bigger range
240 (because this is the one most likely to succeed)
241 rhs_3 case tag b of tb ->
244 K3 ... -> ...eq_rhs(K3)....
247 * To make eq_rhs(K), which knows that
250 we just want to compare (a1,b1) then (a2,b2) etc.
251 Take care on the last field to tail-call into comparing av,bv
253 * To make nullary_rhs generate this
254 case con2tag a of a# ->
258 Several special cases:
260 * Two or fewer nullary constructors: don't generate nullary_rhs
262 * Be careful about unlifted comparisons. When comparing unboxed
263 values we can't call the overloaded functions.
264 See function unliftedOrdOp
266 Note [Do not rely on compare]
267 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
268 It's a bad idea to define only 'compare', and build the other binary
269 comparisions on top of it; see Trac #2130, #4019. Reason: we don't
270 want to laboriously make a three-way comparison, only to extract a
271 binary result, something like this:
272 (>) (I# x) (I# y) = case <# x y of
274 False -> case ==# x y of
278 So for sufficiently small types (few constructors, or all nullary)
279 we generate all methods; for large ones we just use 'compare'.
282 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
285 ordMethRdr :: OrdOp -> RdrName
288 OrdCompare -> compare_RDR
295 ltResult :: OrdOp -> LHsExpr RdrName
296 -- Knowing a<b, what is the result for a `op` b?
297 ltResult OrdCompare = ltTag_Expr
298 ltResult OrdLT = true_Expr
299 ltResult OrdLE = true_Expr
300 ltResult OrdGE = false_Expr
301 ltResult OrdGT = false_Expr
304 eqResult :: OrdOp -> LHsExpr RdrName
305 -- Knowing a=b, what is the result for a `op` b?
306 eqResult OrdCompare = eqTag_Expr
307 eqResult OrdLT = false_Expr
308 eqResult OrdLE = true_Expr
309 eqResult OrdGE = true_Expr
310 eqResult OrdGT = false_Expr
313 gtResult :: OrdOp -> LHsExpr RdrName
314 -- Knowing a>b, what is the result for a `op` b?
315 gtResult OrdCompare = gtTag_Expr
316 gtResult OrdLT = false_Expr
317 gtResult OrdLE = false_Expr
318 gtResult OrdGE = true_Expr
319 gtResult OrdGT = true_Expr
322 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
323 gen_Ord_binds loc tycon
324 = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
326 aux_binds | single_con_type = []
327 | otherwise = [GenCon2Tag tycon]
329 -- Note [Do not rely on compare]
330 other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
331 || null non_nullary_cons -- Or it's an enumeration
332 = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
336 get_tag con = dataConTag con - fIRST_TAG
337 -- We want *zero-based* tags, because that's what
338 -- con2Tag returns (generated by untag_Expr)!
340 tycon_data_cons = tyConDataCons tycon
341 single_con_type = isSingleton tycon_data_cons
342 (first_con : _) = tycon_data_cons
343 (last_con : _) = reverse tycon_data_cons
344 first_tag = get_tag first_con
345 last_tag = get_tag last_con
347 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
350 mkOrdOp :: OrdOp -> LHsBind RdrName
351 -- Returns a binding op a b = ... compares a and b according to op ....
352 mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
354 mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
355 mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
356 | length nullary_cons <= 2 -- Two nullary or fewer, so use cases
357 = nlHsCase (nlHsVar a_RDR) $
358 map (mkOrdOpAlt op) tycon_data_cons
359 -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
360 -- C2 x -> case b of C2 x -> ....comopare x.... }
362 | null non_nullary_cons -- All nullary, so go straight to comparing tags
365 | otherwise -- Mixed nullary and non-nullary
366 = nlHsCase (nlHsVar a_RDR) $
367 (map (mkOrdOpAlt op) non_nullary_cons
368 ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
371 mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName
372 -- Make the alternative (Ki a1 a2 .. av ->
373 mkOrdOpAlt op data_con
374 = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
376 as_needed = take (dataConSourceArity data_con) as_RDRs
377 data_con_RDR = getRdrName data_con
379 mkInnerRhs op data_con
381 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
384 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
385 , mkSimpleHsAlt nlWildPat (ltResult op) ]
387 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
388 , mkSimpleHsAlt nlWildPat (gtResult op) ]
390 | tag == first_tag + 1
391 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
392 , mkInnerEqAlt op data_con
393 , mkSimpleHsAlt nlWildPat (ltResult op) ]
394 | tag == last_tag - 1
395 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
396 , mkInnerEqAlt op data_con
397 , mkSimpleHsAlt nlWildPat (gtResult op) ]
399 | tag > last_tag `div` 2 -- lower range is larger
400 = untag_Expr tycon [(b_RDR, bh_RDR)] $
401 nlHsIf (genOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
402 (gtResult op) $ -- Definitely GT
403 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
404 , mkSimpleHsAlt nlWildPat (ltResult op) ]
406 | otherwise -- upper range is larger
407 = untag_Expr tycon [(b_RDR, bh_RDR)] $
408 nlHsIf (genOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
409 (ltResult op) $ -- Definitely LT
410 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
411 , mkSimpleHsAlt nlWildPat (gtResult op) ]
413 tag = get_tag data_con
414 tag_lit = noLoc (HsLit (HsIntPrim (toInteger tag)))
416 mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName
417 -- First argument 'a' known to be built with K
418 -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
419 mkInnerEqAlt op data_con
420 = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
421 mkCompareFields tycon op (dataConOrigArgTys data_con)
423 data_con_RDR = getRdrName data_con
424 bs_needed = take (dataConSourceArity data_con) bs_RDRs
426 mkTagCmp :: OrdOp -> LHsExpr RdrName
427 -- Both constructors known to be nullary
428 -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
429 mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
430 unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
432 mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
433 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
434 -- where the ai,bi have the given types
435 mkCompareFields tycon op tys
436 = go tys as_RDRs bs_RDRs
438 go [] _ _ = eqResult op
440 | isUnLiftedType ty = unliftedOrdOp tycon ty op a b
441 | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
442 go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
446 go _ _ _ = panic "mkCompareFields"
448 -- (mk_compare ty a b) generates
449 -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
450 -- but with suitable special cases for
451 mk_compare ty a b lt eq gt
453 = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
455 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
456 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
457 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
458 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
462 (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
464 unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
465 unliftedOrdOp tycon ty op a b
467 OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
468 ltTag_Expr eqTag_Expr gtTag_Expr
474 (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
475 wrap prim_op = genOpApp a_expr (primOpRdrName prim_op) b_expr
479 unliftedCompare :: PrimOp -> PrimOp
480 -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare
481 -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results
483 -- Return (if a < b then lt else if a == b then eq else gt)
484 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
485 = nlHsIf (genOpApp a_expr (primOpRdrName lt_op) b_expr) lt $
486 -- Test (<) first, not (==), becuase the latter
487 -- is true less often, so putting it first would
488 -- mean more tests (dynamically)
489 nlHsIf (genOpApp a_expr (primOpRdrName eq_op) b_expr) eq gt
491 nlConWildPat :: DataCon -> LPat RdrName
492 -- The pattern (K {})
493 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
494 (RecCon (HsRecFields { rec_flds = []
495 , rec_dotdot = Nothing })))
500 %************************************************************************
504 %************************************************************************
506 @Enum@ can only be derived for enumeration types. For a type
508 data Foo ... = N1 | N2 | ... | Nn
511 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
512 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
515 instance ... Enum (Foo ...) where
516 succ x = toEnum (1 + fromEnum x)
517 pred x = toEnum (fromEnum x - 1)
519 toEnum i = tag2con_Foo i
521 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
525 = case con2tag_Foo a of
526 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
529 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
533 = case con2tag_Foo a of { a# ->
534 case con2tag_Foo b of { b# ->
535 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
539 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
542 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
543 gen_Enum_binds loc tycon
544 = (method_binds, aux_binds)
546 method_binds = listToBag [
554 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
556 occ_nm = getOccString tycon
559 = mk_easy_FunBind loc succ_RDR [a_Pat] $
560 untag_Expr tycon [(a_RDR, ah_RDR)] $
561 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
562 nlHsVarApps intDataCon_RDR [ah_RDR]])
563 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
564 (nlHsApp (nlHsVar (tag2con_RDR tycon))
565 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
569 = mk_easy_FunBind loc pred_RDR [a_Pat] $
570 untag_Expr tycon [(a_RDR, ah_RDR)] $
571 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
572 nlHsVarApps intDataCon_RDR [ah_RDR]])
573 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
574 (nlHsApp (nlHsVar (tag2con_RDR tycon))
575 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
576 nlHsLit (HsInt (-1))]))
579 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
580 nlHsIf (nlHsApps and_RDR
581 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
582 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
583 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
584 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
587 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
588 untag_Expr tycon [(a_RDR, ah_RDR)] $
590 [nlHsVar (tag2con_RDR tycon),
591 nlHsPar (enum_from_to_Expr
592 (nlHsVarApps intDataCon_RDR [ah_RDR])
593 (nlHsVar (maxtag_RDR tycon)))]
596 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
597 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
598 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
599 nlHsPar (enum_from_then_to_Expr
600 (nlHsVarApps intDataCon_RDR [ah_RDR])
601 (nlHsVarApps intDataCon_RDR [bh_RDR])
602 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
603 nlHsVarApps intDataCon_RDR [bh_RDR]])
605 (nlHsVar (maxtag_RDR tycon))
609 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
610 untag_Expr tycon [(a_RDR, ah_RDR)] $
611 (nlHsVarApps intDataCon_RDR [ah_RDR])
614 %************************************************************************
618 %************************************************************************
621 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
622 gen_Bounded_binds loc tycon
623 | isEnumerationTyCon tycon
624 = (listToBag [ min_bound_enum, max_bound_enum ], [])
626 = ASSERT(isSingleton data_cons)
627 (listToBag [ min_bound_1con, max_bound_1con ], [])
629 data_cons = tyConDataCons tycon
631 ----- enum-flavored: ---------------------------
632 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
633 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
635 data_con_1 = head data_cons
636 data_con_N = last data_cons
637 data_con_1_RDR = getRdrName data_con_1
638 data_con_N_RDR = getRdrName data_con_N
640 ----- single-constructor-flavored: -------------
641 arity = dataConSourceArity data_con_1
643 min_bound_1con = mkHsVarBind loc minBound_RDR $
644 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
645 max_bound_1con = mkHsVarBind loc maxBound_RDR $
646 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
649 %************************************************************************
653 %************************************************************************
655 Deriving @Ix@ is only possible for enumeration types and
656 single-constructor types. We deal with them in turn.
658 For an enumeration type, e.g.,
660 data Foo ... = N1 | N2 | ... | Nn
662 things go not too differently from @Enum@:
664 instance ... Ix (Foo ...) where
666 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
670 = case (con2tag_Foo a) of { a# ->
671 case (con2tag_Foo b) of { b# ->
672 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
675 -- Generate code for unsafeIndex, becuase using index leads
676 -- to lots of redundant range tests
677 unsafeIndex c@(a, b) d
678 = case (con2tag_Foo d -# con2tag_Foo a) of
683 p_tag = con2tag_Foo c
685 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
689 = case (con2tag_Foo a) of { a_tag ->
690 case (con2tag_Foo b) of { b_tag ->
691 case (con2tag_Foo c) of { c_tag ->
692 if (c_tag >=# a_tag) then
698 (modulo suitable case-ification to handle the unlifted tags)
700 For a single-constructor type (NB: this includes all tuples), e.g.,
702 data Foo ... = MkFoo a b Int Double c c
704 we follow the scheme given in Figure~19 of the Haskell~1.2 report
708 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
710 gen_Ix_binds loc tycon
711 | isEnumerationTyCon tycon
712 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
714 = (single_con_ixes, [GenCon2Tag tycon])
716 --------------------------------------------------------------
717 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
720 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
721 untag_Expr tycon [(a_RDR, ah_RDR)] $
722 untag_Expr tycon [(b_RDR, bh_RDR)] $
723 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
724 nlHsPar (enum_from_to_Expr
725 (nlHsVarApps intDataCon_RDR [ah_RDR])
726 (nlHsVarApps intDataCon_RDR [bh_RDR]))
729 = mk_easy_FunBind loc unsafeIndex_RDR
730 [noLoc (AsPat (noLoc c_RDR)
731 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
733 untag_Expr tycon [(a_RDR, ah_RDR)] (
734 untag_Expr tycon [(d_RDR, dh_RDR)] (
736 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
739 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
740 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
745 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
746 untag_Expr tycon [(a_RDR, ah_RDR)] (
747 untag_Expr tycon [(b_RDR, bh_RDR)] (
748 untag_Expr tycon [(c_RDR, ch_RDR)] (
749 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
750 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
755 --------------------------------------------------------------
757 = listToBag [single_con_range, single_con_index, single_con_inRange]
760 = case tyConSingleDataCon_maybe tycon of -- just checking...
761 Nothing -> panic "get_Ix_binds"
764 con_arity = dataConSourceArity data_con
765 data_con_RDR = getRdrName data_con
767 as_needed = take con_arity as_RDRs
768 bs_needed = take con_arity bs_RDRs
769 cs_needed = take con_arity cs_RDRs
771 con_pat xs = nlConVarPat data_con_RDR xs
772 con_expr = nlHsVarApps data_con_RDR cs_needed
774 --------------------------------------------------------------
776 = mk_easy_FunBind loc range_RDR
777 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
778 nlHsDo ListComp stmts con_expr
780 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
782 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
783 (nlHsApp (nlHsVar range_RDR)
784 (mkLHsVarTuple [a,b]))
788 = mk_easy_FunBind loc unsafeIndex_RDR
789 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
791 -- We need to reverse the order we consider the components in
793 -- range (l,u) !! index (l,u) i == i -- when i is in range
794 -- (from http://haskell.org/onlinereport/ix.html) holds.
795 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
797 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
798 mk_index [] = nlHsIntLit 0
799 mk_index [(l,u,i)] = mk_one l u i
800 mk_index ((l,u,i) : rest)
805 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
806 (mkLHsVarTuple [l,u]))
807 ) times_RDR (mk_index rest)
810 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
814 = mk_easy_FunBind loc inRange_RDR
815 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
817 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
819 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
822 %************************************************************************
826 %************************************************************************
836 instance Read T where
840 do x <- ReadP.step Read.readPrec
841 Symbol "%%" <- Lex.lex
842 y <- ReadP.step Read.readPrec
846 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
847 -- Record construction binds even more tightly than application
848 do Ident "T1" <- Lex.lex
850 Ident "f1" <- Lex.lex
852 x <- ReadP.reset Read.readPrec
854 return (T1 { f1 = x }))
857 do Ident "T2" <- Lex.lexP
858 x <- ReadP.step Read.readPrec
862 readListPrec = readListPrecDefault
863 readList = readListDefault
867 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
869 gen_Read_binds get_fixity loc tycon
870 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
872 -----------------------------------------------------------------------
874 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
877 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
878 -----------------------------------------------------------------------
880 data_cons = tyConDataCons tycon
881 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
883 read_prec = mkHsVarBind loc readPrec_RDR
884 (nlHsApp (nlHsVar parens_RDR) read_cons)
886 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
887 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
890 = case nullary_cons of
892 [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])]
893 _ -> [nlHsApp (nlHsVar choose_RDR)
894 (nlList (map mk_pair nullary_cons))]
895 -- NB For operators the parens around (:=:) are matched by the
896 -- enclosing "parens" call, so here we must match the naked
899 match_con con | isSym con_str = symbol_pat con_str
900 | otherwise = ident_pat con_str
902 con_str = data_con_str con
903 -- For nullary constructors we must match Ident s for normal constrs
904 -- and Symbol s for operators
906 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
909 read_non_nullary_con data_con
910 | is_infix = mk_parser infix_prec infix_stmts body
911 | is_record = mk_parser record_prec record_stmts body
912 -- Using these two lines instead allows the derived
913 -- read for infix and record bindings to read the prefix form
914 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
915 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
916 | otherwise = prefix_parser
918 body = result_expr data_con as_needed
919 con_str = data_con_str data_con
921 prefix_parser = mk_parser prefix_prec prefix_stmts body
924 | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
925 | otherwise = [bindLex (ident_pat con_str)]
928 | isSym con_str = [bindLex (symbol_pat con_str)]
929 | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
931 prefix_stmts -- T a b c
932 = read_prefix_con ++ read_args
934 infix_stmts -- a %% b, or a `T` b
939 record_stmts -- T { f1 = a, f2 = b }
942 ++ concat (intersperse [read_punc ","] field_stmts)
945 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
947 con_arity = dataConSourceArity data_con
948 labels = dataConFieldLabels data_con
949 dc_nm = getName data_con
950 is_infix = dataConIsInfix data_con
951 is_record = length labels > 0
952 as_needed = take con_arity as_RDRs
953 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
954 (read_a1:read_a2:_) = read_args
956 prefix_prec = appPrecedence
957 infix_prec = getPrecedence get_fixity dc_nm
958 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
959 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
961 ------------------------------------------------------------------------
963 ------------------------------------------------------------------------
964 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
965 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
966 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
967 con_app con as = nlHsVarApps (getRdrName con) as -- con as
968 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
970 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
971 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
972 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
974 data_con_str con = occNameString (getOccName con)
976 read_punc c = bindLex (punc_pat c)
977 read_arg a ty = ASSERT( not (isUnLiftedType ty) )
978 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
980 read_field lbl a = read_lbl lbl ++
982 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
984 -- When reading field labels we might encounter
989 read_lbl lbl | isSym lbl_str
991 bindLex (symbol_pat lbl_str),
994 = [bindLex (ident_pat lbl_str)]
996 lbl_str = occNameString (getOccName lbl)
1000 %************************************************************************
1004 %************************************************************************
1010 data Tree a = Leaf a | Tree a :^: Tree a
1012 instance (Show a) => Show (Tree a) where
1014 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1016 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1018 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1020 showStr = showsPrec (up_prec+1) u .
1021 showString " :^: " .
1022 showsPrec (up_prec+1) v
1023 -- Note: right-associativity of :^: ignored
1025 up_prec = 5 -- Precedence of :^:
1026 app_prec = 10 -- Application has precedence one more than
1027 -- the most tightly-binding operator
1030 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1032 gen_Show_binds get_fixity loc tycon
1033 = (listToBag [shows_prec, show_list], [])
1035 -----------------------------------------------------------------------
1036 show_list = mkHsVarBind loc showList_RDR
1037 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1038 -----------------------------------------------------------------------
1039 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
1042 | nullary_con = -- skip the showParen junk...
1043 ASSERT(null bs_needed)
1044 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1047 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
1048 (nlHsPar (nested_compose_Expr show_thingies)))
1050 data_con_RDR = getRdrName data_con
1051 con_arity = dataConSourceArity data_con
1052 bs_needed = take con_arity bs_RDRs
1053 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1054 con_pat = nlConVarPat data_con_RDR bs_needed
1055 nullary_con = con_arity == 0
1056 labels = dataConFieldLabels data_con
1057 lab_fields = length labels
1058 record_syntax = lab_fields > 0
1060 dc_nm = getName data_con
1061 dc_occ_nm = getOccName data_con
1062 con_str = occNameString dc_occ_nm
1063 op_con_str = wrapOpParens con_str
1064 backquote_str = wrapOpBackquotes con_str
1067 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1068 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1069 show_record_args ++ [mk_showString_app "}"]
1070 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1072 show_label l = mk_showString_app (nm ++ " = ")
1073 -- Note the spaces around the "=" sign. If we don't have them
1074 -- then we get Foo { x=-1 } and the "=-" parses as a single
1075 -- lexeme. Only the space after the '=' is necessary, but
1076 -- it seems tidier to have them both sides.
1078 occ_nm = getOccName l
1079 nm = wrapOpParens (occNameString occ_nm)
1081 show_args = zipWith show_arg bs_needed arg_tys
1082 (show_arg1:show_arg2:_) = show_args
1083 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1085 -- Assumption for record syntax: no of fields == no of labelled fields
1086 -- (and in same order)
1087 show_record_args = concat $
1088 intersperse [mk_showString_app ", "] $
1089 [ [show_label lbl, arg]
1090 | (lbl,arg) <- zipEqual "gen_Show_binds"
1093 -- Generates (showsPrec p x) for argument x, but it also boxes
1094 -- the argument first if necessary. Note that this prints unboxed
1095 -- things without any '#' decorations; could change that if need be
1096 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1097 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1100 is_infix = dataConIsInfix data_con
1101 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1102 arg_prec | record_syntax = 0 -- Record fields don't need parens
1103 | otherwise = con_prec_plus_one
1105 wrapOpParens :: String -> String
1106 wrapOpParens s | isSym s = '(' : s ++ ")"
1109 wrapOpBackquotes :: String -> String
1110 wrapOpBackquotes s | isSym s = s
1111 | otherwise = '`' : s ++ "`"
1113 isSym :: String -> Bool
1115 isSym (c : _) = startsVarSym c || startsConSym c
1117 mk_showString_app :: String -> LHsExpr RdrName
1118 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1122 getPrec :: Bool -> FixityEnv -> Name -> Integer
1123 getPrec is_infix get_fixity nm
1124 | not is_infix = appPrecedence
1125 | otherwise = getPrecedence get_fixity nm
1127 appPrecedence :: Integer
1128 appPrecedence = fromIntegral maxPrecedence + 1
1129 -- One more than the precedence of the most
1130 -- tightly-binding operator
1132 getPrecedence :: FixityEnv -> Name -> Integer
1133 getPrecedence get_fixity nm
1134 = case lookupFixity get_fixity nm of
1135 Fixity x _assoc -> fromIntegral x
1136 -- NB: the Report says that associativity is not taken
1137 -- into account for either Read or Show; hence we
1138 -- ignore associativity here
1142 %************************************************************************
1144 \subsection{Typeable}
1146 %************************************************************************
1154 instance Typeable2 T where
1155 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1157 We are passed the Typeable2 class as well as T
1160 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1161 gen_Typeable_binds loc tycon
1164 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1166 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1168 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1170 mk_typeOf_RDR :: TyCon -> RdrName
1171 -- Use the arity of the TyCon to make the right typeOfn function
1172 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1174 arity = tyConArity tycon
1175 suffix | arity == 0 = ""
1176 | otherwise = show arity
1181 %************************************************************************
1185 %************************************************************************
1189 data T a b = T1 a b | T2
1193 $cT1 = mkDataCon $dT "T1" Prefix
1194 $cT2 = mkDataCon $dT "T2" Prefix
1195 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1196 -- the [] is for field labels.
1198 instance (Data a, Data b) => Data (T a b) where
1199 gfoldl k z (T1 a b) = z T `k` a `k` b
1200 gfoldl k z T2 = z T2
1201 -- ToDo: add gmapT,Q,M, gfoldr
1203 gunfold k z c = case conIndex c of
1204 I# 1# -> k (k (z T1))
1207 toConstr (T1 _ _) = $cT1
1212 dataCast1 = gcast1 -- If T :: * -> *
1213 dataCast2 = gcast2 -- if T :: * -> * -> *
1217 gen_Data_binds :: SrcSpan
1219 -> (LHsBinds RdrName, -- The method bindings
1220 DerivAuxBinds) -- Auxiliary bindings
1221 gen_Data_binds loc tycon
1222 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1223 `unionBags` gcast_binds,
1224 -- Auxiliary definitions: the data type and constructors
1225 MkTyCon tycon : map MkDataCon data_cons)
1227 data_cons = tyConDataCons tycon
1228 n_cons = length data_cons
1229 one_constr = n_cons == 1
1232 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1233 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1234 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1237 con_name = getRdrName con
1238 as_needed = take (dataConSourceArity con) as_RDRs
1239 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1241 ------------ gunfold
1242 gunfold_bind = mk_FunBind loc
1244 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1248 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1249 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1250 (map gunfold_alt data_cons)
1252 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1253 mk_unfold_rhs dc = foldr nlHsApp
1254 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1255 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1257 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1258 -- redundant test, and annoying warning
1259 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1260 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1264 ------------ toConstr
1265 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1266 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1268 ------------ dataTypeOf
1269 dataTypeOf_bind = mk_easy_FunBind
1273 (nlHsVar (mk_data_type_name tycon))
1275 ------------ gcast1/2
1276 tycon_kind = tyConKind tycon
1277 gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1278 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1279 | otherwise = emptyBag
1280 mk_gcast dataCast_RDR gcast_RDR
1281 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1282 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1285 kind1, kind2 :: Kind
1286 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1287 kind2 = liftedTypeKind `mkArrowKind` kind1
1289 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1290 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1291 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
1292 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1293 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1294 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1295 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1296 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1297 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1298 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1299 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1300 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1301 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1302 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1303 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1304 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1309 %************************************************************************
1313 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1316 %************************************************************************
1320 data T a = T1 Int a | T2 (T a)
1322 We generate the instance:
1324 instance Functor T where
1325 fmap f (T1 b1 a) = T1 b1 (f a)
1326 fmap f (T2 ta) = T2 (fmap f ta)
1328 Notice that we don't simply apply 'fmap' to the constructor arguments.
1330 - Do nothing to an argument whose type doesn't mention 'a'
1331 - Apply 'f' to an argument of type 'a'
1332 - Apply 'fmap f' to other arguments
1333 That's why we have to recurse deeply into the constructor argument types,
1334 rather than just one level, as we typically do.
1336 What about types with more than one type parameter? In general, we only
1337 derive Functor for the last position:
1339 data S a b = S1 [b] | S2 (a, T a b)
1340 instance Functor (S a) where
1341 fmap f (S1 bs) = S1 (fmap f bs)
1342 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1344 However, we have special cases for
1348 More formally, we write the derivation of fmap code over type variable
1349 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1352 instance Functor T where
1353 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1354 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1356 $(fmap 'a 'b) x = x -- when b does not contain a
1357 $(fmap 'a 'a) x = f x
1358 $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1359 $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1360 $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1362 For functions, the type parameter 'a can occur in a contravariant position,
1363 which means we need to derive a function like:
1365 cofmap :: (a -> b) -> (f b -> f a)
1367 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1369 $(cofmap 'a 'b) x = x -- when b does not contain a
1370 $(cofmap 'a 'a) x = error "type variable in contravariant position"
1371 $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1372 $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
1373 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1374 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1377 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1378 gen_Functor_binds loc tycon
1379 = (unitBag fmap_bind, [])
1381 data_cons = tyConDataCons tycon
1383 fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
1384 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1386 parts = foldDataConArgs ft_fmap con
1388 ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1389 -- Tricky higher order type; I can't say I fully understand this code :-(
1390 ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
1391 , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x
1392 , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1393 -- fmap f x = \b -> h (x (g b))
1394 , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1395 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x
1396 return $ nlHsApps fmap_RDR [gg,x]
1397 , ft_forall = \_ g x -> g x
1398 , ft_bad_app = panic "in other argument"
1399 , ft_co_var = panic "contravariant" }
1401 match_for_con = mkSimpleConMatch $
1402 \con_name xsM -> do xs <- sequence xsM
1403 return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) ..
1406 Utility functions related to Functor deriving.
1408 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1409 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1412 -- Generic traversal for Functor deriving
1413 data FFoldType a -- Describes how to fold over a Type in a functor like way
1414 = FT { ft_triv :: a -- Does not contain variable
1415 , ft_var :: a -- The variable itself
1416 , ft_co_var :: a -- The variable itself, contravariantly
1417 , ft_fun :: a -> a -> a -- Function type
1418 , ft_tup :: Boxity -> [a] -> a -- Tuple type
1419 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1420 , ft_bad_app :: a -- Type app, variable other than in last argument
1421 , ft_forall :: TcTyVar -> a -> a -- Forall type
1424 functorLikeTraverse :: TyVar -- ^ Variable to look for
1425 -> FFoldType a -- ^ How to fold
1426 -> Type -- ^ Type to process
1428 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1429 , ft_co_var = caseCoVar, ft_fun = caseFun
1430 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1431 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1434 where -- go returns (result of type a, does type contain var)
1435 go co ty | Just ty' <- coreView ty = go co ty'
1436 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1437 go co (FunTy (PredTy _) b) = go co b
1438 go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
1439 where (xr,xc) = go (not co) x
1441 go co (AppTy x y) | xc = (caseWrongArg, True)
1442 | yc = (caseTyApp x yr, True)
1443 where (_, xc) = go co x
1445 go co ty@(TyConApp con args)
1446 | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1447 | null args = (caseTrivial,False) -- T
1448 | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty
1449 | last xcs = -- T (..no var..) ty
1450 (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1451 where (xrs,xcs) = unzip (map (go co) args)
1452 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1453 where (xr,xc) = go co x
1454 go _ _ = (caseTrivial,False)
1456 -- Return all syntactic subterms of ty that contain var somewhere
1457 -- These are the things that should appear in instance constraints
1458 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1459 deepSubtypesContaining tv
1460 = functorLikeTraverse tv
1463 , ft_fun = (++), ft_tup = \_ xs -> concat xs
1465 , ft_bad_app = panic "in other argument"
1466 , ft_co_var = panic "contravariant"
1467 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1470 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1471 -- Fold over the arguments of the datacon
1472 foldDataConArgs ft con
1473 = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1475 tv = last (dataConUnivTyVars con)
1476 -- Argument to derive for, 'a in the above description
1477 -- The validity checks have ensured that con is
1478 -- a vanilla data constructor
1480 -- Make a HsLam using a fresh variable from a State monad
1481 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1482 -- (mkSimpleLam fn) returns (\x. fn(x))
1483 mkSimpleLam lam = do
1486 body <- lam (nlHsVar n)
1487 return (mkHsLam [nlVarPat n] body)
1489 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1490 mkSimpleLam2 lam = do
1491 (n1:n2:names) <- get
1493 body <- lam (nlHsVar n1) (nlHsVar n2)
1494 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1496 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1497 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1498 mkSimpleConMatch fold extra_pats con insides = do
1499 let con_name = getRdrName con
1500 let vars_needed = takeList insides as_RDRs
1501 let pat = nlConVarPat con_name vars_needed
1502 rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1503 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1505 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1506 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1507 -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1508 mkSimpleTupleCase match_for_con boxity insides x = do
1509 let con = tupleCon boxity (length insides)
1510 match <- match_for_con [] con insides
1511 return $ nlHsCase x [match]
1515 %************************************************************************
1519 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1522 %************************************************************************
1524 Deriving Foldable instances works the same way as Functor instances,
1525 only Foldable instances are not possible for function types at all.
1526 Here the derived instance for the type T above is:
1528 instance Foldable T where
1529 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1533 $(foldr 'a 'b) x z = z -- when b does not contain a
1534 $(foldr 'a 'a) x z = f x z
1535 $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1536 $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
1538 Note that the arguments to the real foldr function are the wrong way around,
1539 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1542 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1543 gen_Foldable_binds loc tycon
1544 = (unitBag foldr_bind, [])
1546 data_cons = tyConDataCons tycon
1548 foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
1549 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1551 parts = foldDataConArgs ft_foldr con
1553 ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1554 ft_foldr = FT { ft_triv = \_ z -> return z -- foldr f z x = z
1555 , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f x z
1556 , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1557 , ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1558 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1559 , ft_forall = \_ g x z -> g x z
1560 , ft_co_var = panic "covariant"
1561 , ft_fun = panic "function"
1562 , ft_bad_app = panic "in other argument" }
1564 match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1568 %************************************************************************
1570 Traversable instances
1572 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1574 %************************************************************************
1576 Again, Traversable is much like Functor and Foldable.
1580 $(traverse 'a 'b) x = pure x -- when b does not contain a
1581 $(traverse 'a 'a) x = f x
1582 $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1583 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
1585 Note that the generated code is not as efficient as it could be. For instance:
1587 data T a = T Int a deriving Traversable
1589 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1590 instead of: traverse f (T x y) = T x <$> f y
1593 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1594 gen_Traversable_binds loc tycon
1595 = (unitBag traverse_bind, [])
1597 data_cons = tyConDataCons tycon
1599 traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
1600 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1602 parts = foldDataConArgs ft_trav con
1605 ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1606 ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x]) -- traverse f x = pure x
1607 , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x
1608 , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) ->
1609 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1610 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
1611 return $ nlHsApps traverse_RDR [gg,x]
1612 , ft_forall = \_ g x -> g x
1613 , ft_co_var = panic "covariant"
1614 , ft_fun = panic "function"
1615 , ft_bad_app = panic "in other argument" }
1617 match_for_con = mkSimpleConMatch $
1618 \con_name xsM -> do xs <- sequence xsM
1619 return (mkApCon (nlHsVar con_name) xs)
1621 -- ((Con <$> x1) <*> x2) <*> ..
1622 mkApCon con [] = nlHsApps pure_RDR [con]
1623 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1624 where appAp x y = nlHsApps ap_RDR [x,y]
1629 %************************************************************************
1631 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1633 %************************************************************************
1638 con2tag_Foo :: Foo ... -> Int#
1639 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1640 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1643 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1647 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1648 genAuxBind loc (GenCon2Tag tycon)
1649 | lots_of_constructors
1650 = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1653 = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1656 rdr_name = con2tag_RDR tycon
1658 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1659 -- We can't use gerRdrName because that makes an Exact RdrName
1660 -- and we can't put them in the LocalRdrEnv
1662 -- Give a signature to the bound variable, so
1663 -- that the case expression generated by getTag is
1664 -- monomorphic. In the push-enter model we get better code.
1665 get_tag_rhs = L loc $ ExprWithTySig
1666 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1667 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1668 (noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs))
1669 (noLoc []) con2tag_ty))
1671 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1673 nlHsTyVar (getRdrName intPrimTyCon)
1675 lots_of_constructors = tyConFamilySize tycon > 8
1676 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1677 -- but we don't do vectored returns any more.
1679 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1680 mk_stuff con = ([nlWildConPat con],
1681 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1683 genAuxBind loc (GenTag2Con tycon)
1684 = mk_FunBind loc rdr_name
1685 [([nlConVarPat intDataCon_RDR [a_RDR]],
1686 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1687 (nlHsTyVar (getRdrName tycon))))]
1689 rdr_name = tag2con_RDR tycon
1691 genAuxBind loc (GenMaxTag tycon)
1692 = mkHsVarBind loc rdr_name
1693 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1695 rdr_name = maxtag_RDR tycon
1696 max_tag = case (tyConDataCons tycon) of
1697 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1699 genAuxBind loc (MkTyCon tycon) -- $dT
1700 = mkHsVarBind loc (mk_data_type_name tycon)
1701 ( nlHsVar mkDataType_RDR
1702 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1703 `nlHsApp` nlList constrs )
1705 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1707 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1708 = mkHsVarBind loc (mk_constr_name dc)
1709 (nlHsApps mkConstr_RDR constr_args)
1712 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1713 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1714 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1715 nlList labels, -- Field labels
1716 nlHsVar fixity] -- Fixity
1718 labels = map (nlHsLit . mkHsString . getOccString)
1719 (dataConFieldLabels dc)
1720 dc_occ = getOccName dc
1721 is_infix = isDataSymOcc dc_occ
1722 fixity | is_infix = infix_RDR
1723 | otherwise = prefix_RDR
1725 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1726 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1728 mk_constr_name :: DataCon -> RdrName -- "$cC"
1729 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1732 %************************************************************************
1734 \subsection{Utility bits for generating bindings}
1736 %************************************************************************
1739 ToDo: Better SrcLocs.
1742 box_if_necy :: String -- The class involved
1743 -> TyCon -- The tycon involved
1744 -> LHsExpr RdrName -- The argument
1745 -> Type -- The argument type
1746 -> LHsExpr RdrName -- Boxed version of the arg
1747 box_if_necy cls_str tycon arg arg_ty
1748 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1751 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1753 ---------------------
1754 primOrdOps :: String -- The class involved
1755 -> TyCon -- The tycon involved
1757 -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp) -- (lt,le,eq,ge,gt)
1758 primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
1760 ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
1762 = [(charPrimTy, (CharLtOp, CharLeOp, CharEqOp, CharGeOp, CharGtOp))
1763 ,(intPrimTy, (IntLtOp, IntLeOp, IntEqOp, IntGeOp, IntGtOp))
1764 ,(wordPrimTy, (WordLtOp, WordLeOp, WordEqOp, WordGeOp, WordGtOp))
1765 ,(addrPrimTy, (AddrLtOp, AddrLeOp, AddrEqOp, AddrGeOp, AddrGtOp))
1766 ,(floatPrimTy, (FloatLtOp, FloatLeOp, FloatEqOp, FloatGeOp, FloatGtOp))
1767 ,(doublePrimTy, (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
1769 box_con_tbl :: [(Type, RdrName)]
1771 [(charPrimTy, getRdrName charDataCon)
1772 ,(intPrimTy, getRdrName intDataCon)
1773 ,(wordPrimTy, wordDataCon_RDR)
1774 ,(floatPrimTy, getRdrName floatDataCon)
1775 ,(doublePrimTy, getRdrName doubleDataCon)
1778 assoc_ty_id :: String -- The class involved
1779 -> TyCon -- The tycon involved
1780 -> [(Type,a)] -- The table
1782 -> a -- The result of the lookup
1783 assoc_ty_id cls_str _ tbl ty
1784 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1785 text "for primitive type" <+> ppr ty)
1786 | otherwise = head res
1788 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1790 -----------------------------------------------------------------------
1792 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1793 and_Expr a b = genOpApp a and_RDR b
1795 -----------------------------------------------------------------------
1797 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1798 eq_Expr tycon ty a b = genOpApp a eq_op b
1800 eq_op | not (isUnLiftedType ty) = eq_RDR
1801 | otherwise = primOpRdrName prim_eq
1802 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1806 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1807 untag_Expr _ [] expr = expr
1808 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1809 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1810 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1813 :: LHsExpr RdrName -> LHsExpr RdrName
1815 enum_from_then_to_Expr
1816 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1819 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1820 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1823 :: LHsExpr RdrName -> LHsExpr RdrName
1826 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1828 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1830 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1831 nested_compose_Expr [e] = parenify e
1832 nested_compose_Expr (e:es)
1833 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1835 -- impossible_Expr is used in case RHSs that should never happen.
1836 -- We generate these to keep the desugarer from complaining that they *might* happen!
1837 -- impossible_Expr :: LHsExpr RdrName
1838 -- impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1840 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1841 -- method. It is currently only used by Enum.{succ,pred}
1842 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1843 illegal_Expr meth tp msg =
1844 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1846 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1847 -- to include the value of a_RDR in the error string.
1848 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1849 illegal_toEnum_tag tp maxtag =
1850 nlHsApp (nlHsVar error_RDR)
1851 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1852 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1853 (nlHsApp (nlHsApp (nlHsApp
1854 (nlHsVar showsPrec_RDR)
1858 (nlHsVar append_RDR)
1859 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1860 (nlHsApp (nlHsApp (nlHsApp
1861 (nlHsVar showsPrec_RDR)
1864 (nlHsLit (mkHsString ")"))))))
1866 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1867 parenify e@(L _ (HsVar _)) = e
1868 parenify e = mkHsPar e
1870 -- genOpApp wraps brackets round the operator application, so that the
1871 -- renamer won't subsequently try to re-associate it.
1872 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1873 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1877 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
1879 a_RDR = mkVarUnqual (fsLit "a")
1880 b_RDR = mkVarUnqual (fsLit "b")
1881 c_RDR = mkVarUnqual (fsLit "c")
1882 d_RDR = mkVarUnqual (fsLit "d")
1883 f_RDR = mkVarUnqual (fsLit "f")
1884 k_RDR = mkVarUnqual (fsLit "k")
1885 z_RDR = mkVarUnqual (fsLit "z")
1886 ah_RDR = mkVarUnqual (fsLit "a#")
1887 bh_RDR = mkVarUnqual (fsLit "b#")
1888 ch_RDR = mkVarUnqual (fsLit "c#")
1889 dh_RDR = mkVarUnqual (fsLit "d#")
1891 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1892 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1893 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1894 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1896 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1897 false_Expr, true_Expr :: LHsExpr RdrName
1898 a_Expr = nlHsVar a_RDR
1899 -- b_Expr = nlHsVar b_RDR
1900 c_Expr = nlHsVar c_RDR
1901 f_Expr = nlHsVar f_RDR
1902 z_Expr = nlHsVar z_RDR
1903 ltTag_Expr = nlHsVar ltTag_RDR
1904 eqTag_Expr = nlHsVar eqTag_RDR
1905 gtTag_Expr = nlHsVar gtTag_RDR
1906 false_Expr = nlHsVar false_RDR
1907 true_Expr = nlHsVar true_RDR
1909 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1910 a_Pat = nlVarPat a_RDR
1911 b_Pat = nlVarPat b_RDR
1912 c_Pat = nlVarPat c_RDR
1913 d_Pat = nlVarPat d_RDR
1914 f_Pat = nlVarPat f_RDR
1915 k_Pat = nlVarPat k_RDR
1916 z_Pat = nlVarPat z_RDR
1918 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1919 -- Generates Orig s RdrName, for the binding positions
1920 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1921 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1922 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1924 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1925 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1927 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1928 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1929 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1930 -- But: (a) that does not work well for standalone-deriving
1931 -- (b) an unqualified name is just fine, provided it can't clash with user code
1934 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1935 PrelNames, so PrelNames can't import PrimOp.
1938 primOpRdrName :: PrimOp -> RdrName
1939 primOpRdrName op = getRdrName (primOpId op)
1941 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
1942 tagToEnum_RDR :: RdrName
1943 minusInt_RDR = primOpRdrName IntSubOp
1944 eqInt_RDR = primOpRdrName IntEqOp
1945 ltInt_RDR = primOpRdrName IntLtOp
1946 geInt_RDR = primOpRdrName IntGeOp
1947 gtInt_RDR = primOpRdrName IntGtOp
1948 leInt_RDR = primOpRdrName IntLeOp
1949 tagToEnum_RDR = primOpRdrName TagToEnumOp
1951 error_RDR :: RdrName
1952 error_RDR = getRdrName eRROR_ID