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,
1292 constr_RDR, dataType_RDR :: RdrName
1293 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1294 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1295 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1296 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1297 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1298 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1299 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1300 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1301 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1302 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1303 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1304 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1305 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1306 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1307 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1312 %************************************************************************
1316 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1319 %************************************************************************
1323 data T a = T1 Int a | T2 (T a)
1325 We generate the instance:
1327 instance Functor T where
1328 fmap f (T1 b1 a) = T1 b1 (f a)
1329 fmap f (T2 ta) = T2 (fmap f ta)
1331 Notice that we don't simply apply 'fmap' to the constructor arguments.
1333 - Do nothing to an argument whose type doesn't mention 'a'
1334 - Apply 'f' to an argument of type 'a'
1335 - Apply 'fmap f' to other arguments
1336 That's why we have to recurse deeply into the constructor argument types,
1337 rather than just one level, as we typically do.
1339 What about types with more than one type parameter? In general, we only
1340 derive Functor for the last position:
1342 data S a b = S1 [b] | S2 (a, T a b)
1343 instance Functor (S a) where
1344 fmap f (S1 bs) = S1 (fmap f bs)
1345 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1347 However, we have special cases for
1351 More formally, we write the derivation of fmap code over type variable
1352 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1355 instance Functor T where
1356 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1357 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1359 $(fmap 'a 'b) x = x -- when b does not contain a
1360 $(fmap 'a 'a) x = f x
1361 $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1362 $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1363 $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1365 For functions, the type parameter 'a can occur in a contravariant position,
1366 which means we need to derive a function like:
1368 cofmap :: (a -> b) -> (f b -> f a)
1370 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1372 $(cofmap 'a 'b) x = x -- when b does not contain a
1373 $(cofmap 'a 'a) x = error "type variable in contravariant position"
1374 $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1375 $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
1376 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1377 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1380 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1381 gen_Functor_binds loc tycon
1382 = (unitBag fmap_bind, [])
1384 data_cons = tyConDataCons tycon
1385 fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) eqns
1387 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1389 parts = foldDataConArgs ft_fmap con
1391 -- Catch-all eqn looks like fmap _ _ = error "impossible"
1392 -- It's needed if there no data cons at all
1393 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1394 (error_Expr "Void fmap")]
1395 | otherwise = map fmap_eqn data_cons
1397 ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1398 -- Tricky higher order type; I can't say I fully understand this code :-(
1399 ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
1400 , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x
1401 , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1402 -- fmap f x = \b -> h (x (g b))
1403 , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1404 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x
1405 return $ nlHsApps fmap_RDR [gg,x]
1406 , ft_forall = \_ g x -> g x
1407 , ft_bad_app = panic "in other argument"
1408 , ft_co_var = panic "contravariant" }
1410 match_for_con = mkSimpleConMatch $
1411 \con_name xsM -> do xs <- sequence xsM
1412 return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) ..
1415 Utility functions related to Functor deriving.
1417 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1418 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1421 -- Generic traversal for Functor deriving
1422 data FFoldType a -- Describes how to fold over a Type in a functor like way
1423 = FT { ft_triv :: a -- Does not contain variable
1424 , ft_var :: a -- The variable itself
1425 , ft_co_var :: a -- The variable itself, contravariantly
1426 , ft_fun :: a -> a -> a -- Function type
1427 , ft_tup :: Boxity -> [a] -> a -- Tuple type
1428 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1429 , ft_bad_app :: a -- Type app, variable other than in last argument
1430 , ft_forall :: TcTyVar -> a -> a -- Forall type
1433 functorLikeTraverse :: TyVar -- ^ Variable to look for
1434 -> FFoldType a -- ^ How to fold
1435 -> Type -- ^ Type to process
1437 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1438 , ft_co_var = caseCoVar, ft_fun = caseFun
1439 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1440 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1443 where -- go returns (result of type a, does type contain var)
1444 go co ty | Just ty' <- coreView ty = go co ty'
1445 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1446 go co (FunTy (PredTy _) b) = go co b
1447 go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
1448 where (xr,xc) = go (not co) x
1450 go co (AppTy x y) | xc = (caseWrongArg, True)
1451 | yc = (caseTyApp x yr, True)
1452 where (_, xc) = go co x
1454 go co ty@(TyConApp con args)
1455 | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1456 | null args = (caseTrivial,False) -- T
1457 | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty
1458 | last xcs = -- T (..no var..) ty
1459 (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1460 where (xrs,xcs) = unzip (map (go co) args)
1461 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1462 where (xr,xc) = go co x
1463 go _ _ = (caseTrivial,False)
1465 -- Return all syntactic subterms of ty that contain var somewhere
1466 -- These are the things that should appear in instance constraints
1467 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1468 deepSubtypesContaining tv
1469 = functorLikeTraverse tv
1472 , ft_fun = (++), ft_tup = \_ xs -> concat xs
1474 , ft_bad_app = panic "in other argument"
1475 , ft_co_var = panic "contravariant"
1476 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1479 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1480 -- Fold over the arguments of the datacon
1481 foldDataConArgs ft con
1482 = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1484 tv = last (dataConUnivTyVars con)
1485 -- Argument to derive for, 'a in the above description
1486 -- The validity checks have ensured that con is
1487 -- a vanilla data constructor
1489 -- Make a HsLam using a fresh variable from a State monad
1490 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1491 -- (mkSimpleLam fn) returns (\x. fn(x))
1492 mkSimpleLam lam = do
1495 body <- lam (nlHsVar n)
1496 return (mkHsLam [nlVarPat n] body)
1498 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1499 mkSimpleLam2 lam = do
1500 (n1:n2:names) <- get
1502 body <- lam (nlHsVar n1) (nlHsVar n2)
1503 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1505 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1506 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1507 mkSimpleConMatch fold extra_pats con insides = do
1508 let con_name = getRdrName con
1509 let vars_needed = takeList insides as_RDRs
1510 let pat = nlConVarPat con_name vars_needed
1511 rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1512 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1514 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1515 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1516 -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1517 mkSimpleTupleCase match_for_con boxity insides x = do
1518 let con = tupleCon boxity (length insides)
1519 match <- match_for_con [] con insides
1520 return $ nlHsCase x [match]
1524 %************************************************************************
1528 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1531 %************************************************************************
1533 Deriving Foldable instances works the same way as Functor instances,
1534 only Foldable instances are not possible for function types at all.
1535 Here the derived instance for the type T above is:
1537 instance Foldable T where
1538 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1542 $(foldr 'a 'b) x z = z -- when b does not contain a
1543 $(foldr 'a 'a) x z = f x z
1544 $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1545 $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
1547 Note that the arguments to the real foldr function are the wrong way around,
1548 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1551 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1552 gen_Foldable_binds loc tycon
1553 = (unitBag foldr_bind, [])
1555 data_cons = tyConDataCons tycon
1557 foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) eqns
1558 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat, nlWildPat]
1559 (error_Expr "Void foldr")]
1560 | otherwise = map foldr_eqn data_cons
1561 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1563 parts = foldDataConArgs ft_foldr con
1565 ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1566 ft_foldr = FT { ft_triv = \_ z -> return z -- foldr f z x = z
1567 , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f x z
1568 , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1569 , ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1570 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1571 , ft_forall = \_ g x z -> g x z
1572 , ft_co_var = panic "covariant"
1573 , ft_fun = panic "function"
1574 , ft_bad_app = panic "in other argument" }
1576 match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1580 %************************************************************************
1582 Traversable instances
1584 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1586 %************************************************************************
1588 Again, Traversable is much like Functor and Foldable.
1592 $(traverse 'a 'b) x = pure x -- when b does not contain a
1593 $(traverse 'a 'a) x = f x
1594 $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1595 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
1597 Note that the generated code is not as efficient as it could be. For instance:
1599 data T a = T Int a deriving Traversable
1601 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1602 instead of: traverse f (T x y) = T x <$> f y
1605 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1606 gen_Traversable_binds loc tycon
1607 = (unitBag traverse_bind, [])
1609 data_cons = tyConDataCons tycon
1611 traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) eqns
1612 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1613 (error_Expr "Void traverse")]
1614 | otherwise = map traverse_eqn data_cons
1615 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1617 parts = foldDataConArgs ft_trav con
1620 ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1621 ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x]) -- traverse f x = pure x
1622 , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x
1623 , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) ->
1624 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1625 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
1626 return $ nlHsApps traverse_RDR [gg,x]
1627 , ft_forall = \_ g x -> g x
1628 , ft_co_var = panic "covariant"
1629 , ft_fun = panic "function"
1630 , ft_bad_app = panic "in other argument" }
1632 match_for_con = mkSimpleConMatch $
1633 \con_name xsM -> do xs <- sequence xsM
1634 return (mkApCon (nlHsVar con_name) xs)
1636 -- ((Con <$> x1) <*> x2) <*> ..
1637 mkApCon con [] = nlHsApps pure_RDR [con]
1638 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1639 where appAp x y = nlHsApps ap_RDR [x,y]
1644 %************************************************************************
1646 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1648 %************************************************************************
1653 con2tag_Foo :: Foo ... -> Int#
1654 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1655 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1658 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1662 genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
1663 genAuxBind loc (GenCon2Tag tycon)
1664 = (mk_FunBind loc rdr_name eqns,
1665 L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1667 rdr_name = con2tag_RDR tycon
1670 mkForAllTys (tyConTyVars tycon) $
1671 mkParentType tycon `mkFunTy` intPrimTy
1673 lots_of_constructors = tyConFamilySize tycon > 8
1674 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1675 -- but we don't do vectored returns any more.
1677 eqns | lots_of_constructors = [get_tag_eqn]
1678 | otherwise = map mk_eqn (tyConDataCons tycon)
1680 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1682 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1683 mk_eqn con = ([nlWildConPat con],
1684 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1686 genAuxBind loc (GenTag2Con tycon)
1687 = (mk_FunBind loc rdr_name
1688 [([nlConVarPat intDataCon_RDR [a_RDR]],
1689 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1690 L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1692 sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
1693 intTy `mkFunTy` mkParentType tycon
1695 rdr_name = tag2con_RDR tycon
1697 genAuxBind loc (GenMaxTag tycon)
1698 = (mkHsVarBind loc rdr_name rhs,
1699 L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1701 rdr_name = maxtag_RDR tycon
1702 sig_ty = HsCoreTy intTy
1703 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
1704 max_tag = case (tyConDataCons tycon) of
1705 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1707 genAuxBind loc (MkTyCon tycon) -- $dT
1708 = (mkHsVarBind loc rdr_name rhs,
1709 L loc (TypeSig (L loc rdr_name) sig_ty))
1711 rdr_name = mk_data_type_name tycon
1712 sig_ty = nlHsTyVar dataType_RDR
1713 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1714 rhs = nlHsVar mkDataType_RDR
1715 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1716 `nlHsApp` nlList constrs
1718 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1719 = (mkHsVarBind loc rdr_name rhs,
1720 L loc (TypeSig (L loc rdr_name) sig_ty))
1722 rdr_name = mk_constr_name dc
1723 sig_ty = nlHsTyVar constr_RDR
1724 rhs = nlHsApps mkConstr_RDR constr_args
1727 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1728 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1729 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1730 nlList labels, -- Field labels
1731 nlHsVar fixity] -- Fixity
1733 labels = map (nlHsLit . mkHsString . getOccString)
1734 (dataConFieldLabels dc)
1735 dc_occ = getOccName dc
1736 is_infix = isDataSymOcc dc_occ
1737 fixity | is_infix = infix_RDR
1738 | otherwise = prefix_RDR
1740 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1741 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1743 mk_constr_name :: DataCon -> RdrName -- "$cC"
1744 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1746 mkParentType :: TyCon -> Type
1747 -- Turn the representation tycon of a family into
1748 -- a use of its family constructor
1750 = case tyConFamInst_maybe tc of
1751 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
1752 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
1755 %************************************************************************
1757 \subsection{Utility bits for generating bindings}
1759 %************************************************************************
1762 ToDo: Better SrcLocs.
1765 box_if_necy :: String -- The class involved
1766 -> TyCon -- The tycon involved
1767 -> LHsExpr RdrName -- The argument
1768 -> Type -- The argument type
1769 -> LHsExpr RdrName -- Boxed version of the arg
1770 box_if_necy cls_str tycon arg arg_ty
1771 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1774 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1776 ---------------------
1777 primOrdOps :: String -- The class involved
1778 -> TyCon -- The tycon involved
1780 -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp) -- (lt,le,eq,ge,gt)
1781 primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
1783 ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
1785 = [(charPrimTy, (CharLtOp, CharLeOp, CharEqOp, CharGeOp, CharGtOp))
1786 ,(intPrimTy, (IntLtOp, IntLeOp, IntEqOp, IntGeOp, IntGtOp))
1787 ,(wordPrimTy, (WordLtOp, WordLeOp, WordEqOp, WordGeOp, WordGtOp))
1788 ,(addrPrimTy, (AddrLtOp, AddrLeOp, AddrEqOp, AddrGeOp, AddrGtOp))
1789 ,(floatPrimTy, (FloatLtOp, FloatLeOp, FloatEqOp, FloatGeOp, FloatGtOp))
1790 ,(doublePrimTy, (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
1792 box_con_tbl :: [(Type, RdrName)]
1794 [(charPrimTy, getRdrName charDataCon)
1795 ,(intPrimTy, getRdrName intDataCon)
1796 ,(wordPrimTy, wordDataCon_RDR)
1797 ,(floatPrimTy, getRdrName floatDataCon)
1798 ,(doublePrimTy, getRdrName doubleDataCon)
1801 assoc_ty_id :: String -- The class involved
1802 -> TyCon -- The tycon involved
1803 -> [(Type,a)] -- The table
1805 -> a -- The result of the lookup
1806 assoc_ty_id cls_str _ tbl ty
1807 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1808 text "for primitive type" <+> ppr ty)
1809 | otherwise = head res
1811 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1813 -----------------------------------------------------------------------
1815 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1816 and_Expr a b = genOpApp a and_RDR b
1818 -----------------------------------------------------------------------
1820 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1821 eq_Expr tycon ty a b = genOpApp a eq_op b
1823 eq_op | not (isUnLiftedType ty) = eq_RDR
1824 | otherwise = primOpRdrName prim_eq
1825 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1829 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1830 untag_Expr _ [] expr = expr
1831 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1832 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1833 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1836 :: LHsExpr RdrName -> LHsExpr RdrName
1838 enum_from_then_to_Expr
1839 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1842 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1843 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1846 :: LHsExpr RdrName -> LHsExpr RdrName
1849 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1851 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1853 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1854 nested_compose_Expr [e] = parenify e
1855 nested_compose_Expr (e:es)
1856 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1858 -- impossible_Expr is used in case RHSs that should never happen.
1859 -- We generate these to keep the desugarer from complaining that they *might* happen!
1860 error_Expr :: String -> LHsExpr RdrName
1861 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
1863 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1864 -- method. It is currently only used by Enum.{succ,pred}
1865 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1866 illegal_Expr meth tp msg =
1867 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1869 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1870 -- to include the value of a_RDR in the error string.
1871 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1872 illegal_toEnum_tag tp maxtag =
1873 nlHsApp (nlHsVar error_RDR)
1874 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1875 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1876 (nlHsApp (nlHsApp (nlHsApp
1877 (nlHsVar showsPrec_RDR)
1881 (nlHsVar append_RDR)
1882 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1883 (nlHsApp (nlHsApp (nlHsApp
1884 (nlHsVar showsPrec_RDR)
1887 (nlHsLit (mkHsString ")"))))))
1889 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1890 parenify e@(L _ (HsVar _)) = e
1891 parenify e = mkHsPar e
1893 -- genOpApp wraps brackets round the operator application, so that the
1894 -- renamer won't subsequently try to re-associate it.
1895 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1896 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1900 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
1902 a_RDR = mkVarUnqual (fsLit "a")
1903 b_RDR = mkVarUnqual (fsLit "b")
1904 c_RDR = mkVarUnqual (fsLit "c")
1905 d_RDR = mkVarUnqual (fsLit "d")
1906 f_RDR = mkVarUnqual (fsLit "f")
1907 k_RDR = mkVarUnqual (fsLit "k")
1908 z_RDR = mkVarUnqual (fsLit "z")
1909 ah_RDR = mkVarUnqual (fsLit "a#")
1910 bh_RDR = mkVarUnqual (fsLit "b#")
1911 ch_RDR = mkVarUnqual (fsLit "c#")
1912 dh_RDR = mkVarUnqual (fsLit "d#")
1914 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1915 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1916 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1917 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1919 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1920 false_Expr, true_Expr :: LHsExpr RdrName
1921 a_Expr = nlHsVar a_RDR
1922 -- b_Expr = nlHsVar b_RDR
1923 c_Expr = nlHsVar c_RDR
1924 f_Expr = nlHsVar f_RDR
1925 z_Expr = nlHsVar z_RDR
1926 ltTag_Expr = nlHsVar ltTag_RDR
1927 eqTag_Expr = nlHsVar eqTag_RDR
1928 gtTag_Expr = nlHsVar gtTag_RDR
1929 false_Expr = nlHsVar false_RDR
1930 true_Expr = nlHsVar true_RDR
1932 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1933 a_Pat = nlVarPat a_RDR
1934 b_Pat = nlVarPat b_RDR
1935 c_Pat = nlVarPat c_RDR
1936 d_Pat = nlVarPat d_RDR
1937 f_Pat = nlVarPat f_RDR
1938 k_Pat = nlVarPat k_RDR
1939 z_Pat = nlVarPat z_RDR
1941 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1942 -- Generates Orig s RdrName, for the binding positions
1943 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1944 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1945 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1947 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1948 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1950 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1951 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1952 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1953 -- But: (a) that does not work well for standalone-deriving
1954 -- (b) an unqualified name is just fine, provided it can't clash with user code
1957 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1958 PrelNames, so PrelNames can't import PrimOp.
1961 primOpRdrName :: PrimOp -> RdrName
1962 primOpRdrName op = getRdrName (primOpId op)
1964 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
1965 tagToEnum_RDR :: RdrName
1966 minusInt_RDR = primOpRdrName IntSubOp
1967 eqInt_RDR = primOpRdrName IntEqOp
1968 ltInt_RDR = primOpRdrName IntLtOp
1969 geInt_RDR = primOpRdrName IntGeOp
1970 gtInt_RDR = primOpRdrName IntGtOp
1971 leInt_RDR = primOpRdrName IntLeOp
1972 tagToEnum_RDR = primOpRdrName TagToEnumOp
1974 error_RDR :: RdrName
1975 error_RDR = getRdrName eRROR_ID