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 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1302 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1303 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1304 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1305 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1306 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1311 %************************************************************************
1315 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1318 %************************************************************************
1322 data T a = T1 Int a | T2 (T a)
1324 We generate the instance:
1326 instance Functor T where
1327 fmap f (T1 b1 a) = T1 b1 (f a)
1328 fmap f (T2 ta) = T2 (fmap f ta)
1330 Notice that we don't simply apply 'fmap' to the constructor arguments.
1332 - Do nothing to an argument whose type doesn't mention 'a'
1333 - Apply 'f' to an argument of type 'a'
1334 - Apply 'fmap f' to other arguments
1335 That's why we have to recurse deeply into the constructor argument types,
1336 rather than just one level, as we typically do.
1338 What about types with more than one type parameter? In general, we only
1339 derive Functor for the last position:
1341 data S a b = S1 [b] | S2 (a, T a b)
1342 instance Functor (S a) where
1343 fmap f (S1 bs) = S1 (fmap f bs)
1344 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1346 However, we have special cases for
1350 More formally, we write the derivation of fmap code over type variable
1351 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1354 instance Functor T where
1355 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1356 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1358 $(fmap 'a 'b) x = x -- when b does not contain a
1359 $(fmap 'a 'a) x = f x
1360 $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1361 $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1362 $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1364 For functions, the type parameter 'a can occur in a contravariant position,
1365 which means we need to derive a function like:
1367 cofmap :: (a -> b) -> (f b -> f a)
1369 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1371 $(cofmap 'a 'b) x = x -- when b does not contain a
1372 $(cofmap 'a 'a) x = error "type variable in contravariant position"
1373 $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1374 $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
1375 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1376 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1379 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1380 gen_Functor_binds loc tycon
1381 = (unitBag fmap_bind, [])
1383 data_cons = tyConDataCons tycon
1384 fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) eqns
1386 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1388 parts = foldDataConArgs ft_fmap con
1390 -- Catch-all eqn looks like fmap _ _ = error "impossible"
1391 -- It's needed if there no data cons at all
1392 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1393 (error_Expr "Void fmap")]
1394 | otherwise = map fmap_eqn data_cons
1396 ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1397 -- Tricky higher order type; I can't say I fully understand this code :-(
1398 ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
1399 , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x
1400 , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1401 -- fmap f x = \b -> h (x (g b))
1402 , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1403 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x
1404 return $ nlHsApps fmap_RDR [gg,x]
1405 , ft_forall = \_ g x -> g x
1406 , ft_bad_app = panic "in other argument"
1407 , ft_co_var = panic "contravariant" }
1409 match_for_con = mkSimpleConMatch $
1410 \con_name xsM -> do xs <- sequence xsM
1411 return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) ..
1414 Utility functions related to Functor deriving.
1416 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1417 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1420 -- Generic traversal for Functor deriving
1421 data FFoldType a -- Describes how to fold over a Type in a functor like way
1422 = FT { ft_triv :: a -- Does not contain variable
1423 , ft_var :: a -- The variable itself
1424 , ft_co_var :: a -- The variable itself, contravariantly
1425 , ft_fun :: a -> a -> a -- Function type
1426 , ft_tup :: Boxity -> [a] -> a -- Tuple type
1427 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1428 , ft_bad_app :: a -- Type app, variable other than in last argument
1429 , ft_forall :: TcTyVar -> a -> a -- Forall type
1432 functorLikeTraverse :: TyVar -- ^ Variable to look for
1433 -> FFoldType a -- ^ How to fold
1434 -> Type -- ^ Type to process
1436 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1437 , ft_co_var = caseCoVar, ft_fun = caseFun
1438 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1439 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1442 where -- go returns (result of type a, does type contain var)
1443 go co ty | Just ty' <- coreView ty = go co ty'
1444 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1445 go co (FunTy (PredTy _) b) = go co b
1446 go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
1447 where (xr,xc) = go (not co) x
1449 go co (AppTy x y) | xc = (caseWrongArg, True)
1450 | yc = (caseTyApp x yr, True)
1451 where (_, xc) = go co x
1453 go co ty@(TyConApp con args)
1454 | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1455 | null args = (caseTrivial,False) -- T
1456 | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty
1457 | last xcs = -- T (..no var..) ty
1458 (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1459 where (xrs,xcs) = unzip (map (go co) args)
1460 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1461 where (xr,xc) = go co x
1462 go _ _ = (caseTrivial,False)
1464 -- Return all syntactic subterms of ty that contain var somewhere
1465 -- These are the things that should appear in instance constraints
1466 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1467 deepSubtypesContaining tv
1468 = functorLikeTraverse tv
1471 , ft_fun = (++), ft_tup = \_ xs -> concat xs
1473 , ft_bad_app = panic "in other argument"
1474 , ft_co_var = panic "contravariant"
1475 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1478 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1479 -- Fold over the arguments of the datacon
1480 foldDataConArgs ft con
1481 = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1483 tv = last (dataConUnivTyVars con)
1484 -- Argument to derive for, 'a in the above description
1485 -- The validity checks have ensured that con is
1486 -- a vanilla data constructor
1488 -- Make a HsLam using a fresh variable from a State monad
1489 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1490 -- (mkSimpleLam fn) returns (\x. fn(x))
1491 mkSimpleLam lam = do
1494 body <- lam (nlHsVar n)
1495 return (mkHsLam [nlVarPat n] body)
1497 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1498 mkSimpleLam2 lam = do
1499 (n1:n2:names) <- get
1501 body <- lam (nlHsVar n1) (nlHsVar n2)
1502 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1504 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1505 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1506 mkSimpleConMatch fold extra_pats con insides = do
1507 let con_name = getRdrName con
1508 let vars_needed = takeList insides as_RDRs
1509 let pat = nlConVarPat con_name vars_needed
1510 rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1511 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1513 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1514 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1515 -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1516 mkSimpleTupleCase match_for_con boxity insides x = do
1517 let con = tupleCon boxity (length insides)
1518 match <- match_for_con [] con insides
1519 return $ nlHsCase x [match]
1523 %************************************************************************
1527 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1530 %************************************************************************
1532 Deriving Foldable instances works the same way as Functor instances,
1533 only Foldable instances are not possible for function types at all.
1534 Here the derived instance for the type T above is:
1536 instance Foldable T where
1537 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1541 $(foldr 'a 'b) x z = z -- when b does not contain a
1542 $(foldr 'a 'a) x z = f x z
1543 $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1544 $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
1546 Note that the arguments to the real foldr function are the wrong way around,
1547 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1550 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1551 gen_Foldable_binds loc tycon
1552 = (unitBag foldr_bind, [])
1554 data_cons = tyConDataCons tycon
1556 foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) eqns
1557 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat, nlWildPat]
1558 (error_Expr "Void foldr")]
1559 | otherwise = map foldr_eqn data_cons
1560 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1562 parts = foldDataConArgs ft_foldr con
1564 ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1565 ft_foldr = FT { ft_triv = \_ z -> return z -- foldr f z x = z
1566 , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f x z
1567 , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1568 , ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1569 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1570 , ft_forall = \_ g x z -> g x z
1571 , ft_co_var = panic "covariant"
1572 , ft_fun = panic "function"
1573 , ft_bad_app = panic "in other argument" }
1575 match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1579 %************************************************************************
1581 Traversable instances
1583 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1585 %************************************************************************
1587 Again, Traversable is much like Functor and Foldable.
1591 $(traverse 'a 'b) x = pure x -- when b does not contain a
1592 $(traverse 'a 'a) x = f x
1593 $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1594 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
1596 Note that the generated code is not as efficient as it could be. For instance:
1598 data T a = T Int a deriving Traversable
1600 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1601 instead of: traverse f (T x y) = T x <$> f y
1604 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1605 gen_Traversable_binds loc tycon
1606 = (unitBag traverse_bind, [])
1608 data_cons = tyConDataCons tycon
1610 traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) eqns
1611 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1612 (error_Expr "Void traverse")]
1613 | otherwise = map traverse_eqn data_cons
1614 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1616 parts = foldDataConArgs ft_trav con
1619 ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1620 ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x]) -- traverse f x = pure x
1621 , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x
1622 , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) ->
1623 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1624 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
1625 return $ nlHsApps traverse_RDR [gg,x]
1626 , ft_forall = \_ g x -> g x
1627 , ft_co_var = panic "covariant"
1628 , ft_fun = panic "function"
1629 , ft_bad_app = panic "in other argument" }
1631 match_for_con = mkSimpleConMatch $
1632 \con_name xsM -> do xs <- sequence xsM
1633 return (mkApCon (nlHsVar con_name) xs)
1635 -- ((Con <$> x1) <*> x2) <*> ..
1636 mkApCon con [] = nlHsApps pure_RDR [con]
1637 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1638 where appAp x y = nlHsApps ap_RDR [x,y]
1643 %************************************************************************
1645 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1647 %************************************************************************
1652 con2tag_Foo :: Foo ... -> Int#
1653 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1654 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1657 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1661 genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
1662 genAuxBind loc (GenCon2Tag tycon)
1663 = (mk_FunBind loc rdr_name eqns,
1664 L loc (TypeSig (L loc rdr_name) sig_ty))
1666 rdr_name = con2tag_RDR tycon
1668 sig_ty = genForAllTy loc tycon $ \hs_tc_app ->
1669 hs_tc_app `nlHsFunTy` nlHsTyVar (getRdrName intPrimTyCon)
1671 lots_of_constructors = tyConFamilySize tycon > 8
1672 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1673 -- but we don't do vectored returns any more.
1675 eqns | lots_of_constructors = [get_tag_eqn]
1676 | otherwise = map mk_eqn (tyConDataCons tycon)
1678 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1680 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1681 mk_eqn con = ([nlWildConPat con],
1682 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1684 genAuxBind loc (GenTag2Con tycon)
1685 = ASSERT( null (tyConTyVars tycon) )
1686 (mk_FunBind loc rdr_name
1687 [([nlConVarPat intDataCon_RDR [a_RDR]],
1688 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1689 L loc (TypeSig (L loc rdr_name) sig_ty))
1691 sig_ty = nlHsTyVar (getRdrName intPrimTyCon)
1692 `nlHsFunTy` (nlHsTyVar (getRdrName tycon))
1694 rdr_name = tag2con_RDR tycon
1696 genAuxBind loc (GenMaxTag tycon)
1697 = (mkHsVarBind loc rdr_name rhs,
1698 L loc (TypeSig (L loc rdr_name) sig_ty))
1700 rdr_name = maxtag_RDR tycon
1701 sig_ty = nlHsTyVar (getRdrName intPrimTyCon)
1702 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
1703 max_tag = case (tyConDataCons tycon) of
1704 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1706 genAuxBind loc (MkTyCon tycon) -- $dT
1707 = (mkHsVarBind loc rdr_name rhs,
1708 L loc (TypeSig (L loc rdr_name) sig_ty))
1710 rdr_name = mk_data_type_name tycon
1711 sig_ty = nlHsTyVar dataType_RDR
1712 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1713 rhs = nlHsVar mkDataType_RDR
1714 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1715 `nlHsApp` nlList constrs
1717 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1718 = (mkHsVarBind loc rdr_name rhs,
1719 L loc (TypeSig (L loc rdr_name) sig_ty))
1721 rdr_name = mk_constr_name dc
1722 sig_ty = nlHsTyVar constr_RDR
1723 rhs = nlHsApps mkConstr_RDR constr_args
1726 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1727 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1728 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1729 nlList labels, -- Field labels
1730 nlHsVar fixity] -- Fixity
1732 labels = map (nlHsLit . mkHsString . getOccString)
1733 (dataConFieldLabels dc)
1734 dc_occ = getOccName dc
1735 is_infix = isDataSymOcc dc_occ
1736 fixity | is_infix = infix_RDR
1737 | otherwise = prefix_RDR
1739 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1740 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1742 mk_constr_name :: DataCon -> RdrName -- "$cC"
1743 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1745 genForAllTy :: SrcSpan -> TyCon
1746 -> (LHsType RdrName -> LHsType RdrName)
1748 -- Wrap a forall type for the variables of the TyCOn
1749 genForAllTy loc tc thing_inside
1750 = L loc $ mkExplicitHsForAllTy (userHsTyVarBndrs (map (L loc) tvs)) (L loc []) $
1751 thing_inside (nlHsTyConApp (getRdrName tc) (map nlHsTyVar tvs))
1753 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tc)
1754 -- We can't use getRdrName because that makes an Exact RdrName
1755 -- and we can't put them in the LocalRdrEnv
1758 %************************************************************************
1760 \subsection{Utility bits for generating bindings}
1762 %************************************************************************
1765 ToDo: Better SrcLocs.
1768 box_if_necy :: String -- The class involved
1769 -> TyCon -- The tycon involved
1770 -> LHsExpr RdrName -- The argument
1771 -> Type -- The argument type
1772 -> LHsExpr RdrName -- Boxed version of the arg
1773 box_if_necy cls_str tycon arg arg_ty
1774 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1777 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1779 ---------------------
1780 primOrdOps :: String -- The class involved
1781 -> TyCon -- The tycon involved
1783 -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp) -- (lt,le,eq,ge,gt)
1784 primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
1786 ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
1788 = [(charPrimTy, (CharLtOp, CharLeOp, CharEqOp, CharGeOp, CharGtOp))
1789 ,(intPrimTy, (IntLtOp, IntLeOp, IntEqOp, IntGeOp, IntGtOp))
1790 ,(wordPrimTy, (WordLtOp, WordLeOp, WordEqOp, WordGeOp, WordGtOp))
1791 ,(addrPrimTy, (AddrLtOp, AddrLeOp, AddrEqOp, AddrGeOp, AddrGtOp))
1792 ,(floatPrimTy, (FloatLtOp, FloatLeOp, FloatEqOp, FloatGeOp, FloatGtOp))
1793 ,(doublePrimTy, (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
1795 box_con_tbl :: [(Type, RdrName)]
1797 [(charPrimTy, getRdrName charDataCon)
1798 ,(intPrimTy, getRdrName intDataCon)
1799 ,(wordPrimTy, wordDataCon_RDR)
1800 ,(floatPrimTy, getRdrName floatDataCon)
1801 ,(doublePrimTy, getRdrName doubleDataCon)
1804 assoc_ty_id :: String -- The class involved
1805 -> TyCon -- The tycon involved
1806 -> [(Type,a)] -- The table
1808 -> a -- The result of the lookup
1809 assoc_ty_id cls_str _ tbl ty
1810 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1811 text "for primitive type" <+> ppr ty)
1812 | otherwise = head res
1814 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1816 -----------------------------------------------------------------------
1818 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1819 and_Expr a b = genOpApp a and_RDR b
1821 -----------------------------------------------------------------------
1823 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1824 eq_Expr tycon ty a b = genOpApp a eq_op b
1826 eq_op | not (isUnLiftedType ty) = eq_RDR
1827 | otherwise = primOpRdrName prim_eq
1828 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1832 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1833 untag_Expr _ [] expr = expr
1834 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1835 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1836 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1839 :: LHsExpr RdrName -> LHsExpr RdrName
1841 enum_from_then_to_Expr
1842 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1845 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1846 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1849 :: LHsExpr RdrName -> LHsExpr RdrName
1852 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1854 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1856 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1857 nested_compose_Expr [e] = parenify e
1858 nested_compose_Expr (e:es)
1859 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1861 -- impossible_Expr is used in case RHSs that should never happen.
1862 -- We generate these to keep the desugarer from complaining that they *might* happen!
1863 error_Expr :: String -> LHsExpr RdrName
1864 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
1866 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1867 -- method. It is currently only used by Enum.{succ,pred}
1868 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1869 illegal_Expr meth tp msg =
1870 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1872 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1873 -- to include the value of a_RDR in the error string.
1874 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1875 illegal_toEnum_tag tp maxtag =
1876 nlHsApp (nlHsVar error_RDR)
1877 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1878 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1879 (nlHsApp (nlHsApp (nlHsApp
1880 (nlHsVar showsPrec_RDR)
1884 (nlHsVar append_RDR)
1885 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1886 (nlHsApp (nlHsApp (nlHsApp
1887 (nlHsVar showsPrec_RDR)
1890 (nlHsLit (mkHsString ")"))))))
1892 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1893 parenify e@(L _ (HsVar _)) = e
1894 parenify e = mkHsPar e
1896 -- genOpApp wraps brackets round the operator application, so that the
1897 -- renamer won't subsequently try to re-associate it.
1898 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1899 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1903 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
1905 a_RDR = mkVarUnqual (fsLit "a")
1906 b_RDR = mkVarUnqual (fsLit "b")
1907 c_RDR = mkVarUnqual (fsLit "c")
1908 d_RDR = mkVarUnqual (fsLit "d")
1909 f_RDR = mkVarUnqual (fsLit "f")
1910 k_RDR = mkVarUnqual (fsLit "k")
1911 z_RDR = mkVarUnqual (fsLit "z")
1912 ah_RDR = mkVarUnqual (fsLit "a#")
1913 bh_RDR = mkVarUnqual (fsLit "b#")
1914 ch_RDR = mkVarUnqual (fsLit "c#")
1915 dh_RDR = mkVarUnqual (fsLit "d#")
1917 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1918 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1919 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1920 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1922 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1923 false_Expr, true_Expr :: LHsExpr RdrName
1924 a_Expr = nlHsVar a_RDR
1925 -- b_Expr = nlHsVar b_RDR
1926 c_Expr = nlHsVar c_RDR
1927 f_Expr = nlHsVar f_RDR
1928 z_Expr = nlHsVar z_RDR
1929 ltTag_Expr = nlHsVar ltTag_RDR
1930 eqTag_Expr = nlHsVar eqTag_RDR
1931 gtTag_Expr = nlHsVar gtTag_RDR
1932 false_Expr = nlHsVar false_RDR
1933 true_Expr = nlHsVar true_RDR
1935 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1936 a_Pat = nlVarPat a_RDR
1937 b_Pat = nlVarPat b_RDR
1938 c_Pat = nlVarPat c_RDR
1939 d_Pat = nlVarPat d_RDR
1940 f_Pat = nlVarPat f_RDR
1941 k_Pat = nlVarPat k_RDR
1942 z_Pat = nlVarPat z_RDR
1944 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1945 -- Generates Orig s RdrName, for the binding positions
1946 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1947 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1948 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1950 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1951 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1953 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1954 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1955 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1956 -- But: (a) that does not work well for standalone-deriving
1957 -- (b) an unqualified name is just fine, provided it can't clash with user code
1960 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1961 PrelNames, so PrelNames can't import PrimOp.
1964 primOpRdrName :: PrimOp -> RdrName
1965 primOpRdrName op = getRdrName (primOpId op)
1967 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
1968 tagToEnum_RDR :: RdrName
1969 minusInt_RDR = primOpRdrName IntSubOp
1970 eqInt_RDR = primOpRdrName IntEqOp
1971 ltInt_RDR = primOpRdrName IntLtOp
1972 geInt_RDR = primOpRdrName IntGeOp
1973 gtInt_RDR = primOpRdrName IntGtOp
1974 leInt_RDR = primOpRdrName IntLeOp
1975 tagToEnum_RDR = primOpRdrName TagToEnumOp
1977 error_RDR :: RdrName
1978 error_RDR = getRdrName eRROR_ID