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 (ident_pat (data_con_str con))]
893 (result_expr con [])]
894 _ -> [nlHsApp (nlHsVar choose_RDR)
895 (nlList (map mk_pair nullary_cons))]
897 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
900 read_non_nullary_con data_con
901 | is_infix = mk_parser infix_prec infix_stmts body
902 | is_record = mk_parser record_prec record_stmts body
903 -- Using these two lines instead allows the derived
904 -- read for infix and record bindings to read the prefix form
905 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
906 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
907 | otherwise = prefix_parser
909 body = result_expr data_con as_needed
910 con_str = data_con_str data_con
912 prefix_parser = mk_parser prefix_prec prefix_stmts body
915 | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"]
916 | otherwise = [bindLex (ident_pat con_str)]
919 | isSym con_str = [bindLex (symbol_pat con_str)]
920 | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"]
922 prefix_stmts -- T a b c
923 = read_prefix_con ++ read_args
925 infix_stmts -- a %% b, or a `T` b
930 record_stmts -- T { f1 = a, f2 = b }
933 ++ concat (intersperse [read_punc ","] field_stmts)
936 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
938 con_arity = dataConSourceArity data_con
939 labels = dataConFieldLabels data_con
940 dc_nm = getName data_con
941 is_infix = dataConIsInfix data_con
942 is_record = length labels > 0
943 as_needed = take con_arity as_RDRs
944 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
945 (read_a1:read_a2:_) = read_args
947 prefix_prec = appPrecedence
948 infix_prec = getPrecedence get_fixity dc_nm
949 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
950 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
952 ------------------------------------------------------------------------
954 ------------------------------------------------------------------------
955 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
956 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
957 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
958 con_app con as = nlHsVarApps (getRdrName con) as -- con as
959 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
961 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
962 ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo"
963 symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>"
965 data_con_str con = occNameString (getOccName con)
967 read_punc c = bindLex (punc_pat c)
968 read_arg a ty = ASSERT( not (isUnLiftedType ty) )
969 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
971 read_field lbl a = read_lbl lbl ++
973 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
975 -- When reading field labels we might encounter
980 read_lbl lbl | isSym lbl_str
982 bindLex (symbol_pat lbl_str),
985 = [bindLex (ident_pat lbl_str)]
987 lbl_str = occNameString (getOccName lbl)
991 %************************************************************************
995 %************************************************************************
1001 data Tree a = Leaf a | Tree a :^: Tree a
1003 instance (Show a) => Show (Tree a) where
1005 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1007 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1009 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1011 showStr = showsPrec (up_prec+1) u .
1012 showString " :^: " .
1013 showsPrec (up_prec+1) v
1014 -- Note: right-associativity of :^: ignored
1016 up_prec = 5 -- Precedence of :^:
1017 app_prec = 10 -- Application has precedence one more than
1018 -- the most tightly-binding operator
1021 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1023 gen_Show_binds get_fixity loc tycon
1024 = (listToBag [shows_prec, show_list], [])
1026 -----------------------------------------------------------------------
1027 show_list = mkHsVarBind loc showList_RDR
1028 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1029 -----------------------------------------------------------------------
1030 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc (tyConDataCons tycon))
1033 | nullary_con = -- skip the showParen junk...
1034 ASSERT(null bs_needed)
1035 ([nlWildPat, con_pat], mk_showString_app con_str)
1038 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
1039 (nlHsPar (nested_compose_Expr show_thingies)))
1041 data_con_RDR = getRdrName data_con
1042 con_arity = dataConSourceArity data_con
1043 bs_needed = take con_arity bs_RDRs
1044 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1045 con_pat = nlConVarPat data_con_RDR bs_needed
1046 nullary_con = con_arity == 0
1047 labels = dataConFieldLabels data_con
1048 lab_fields = length labels
1049 record_syntax = lab_fields > 0
1051 dc_nm = getName data_con
1052 dc_occ_nm = getOccName data_con
1053 con_str = occNameString dc_occ_nm
1054 op_con_str = wrapOpParens con_str
1055 backquote_str = wrapOpBackquotes con_str
1058 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1059 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1060 show_record_args ++ [mk_showString_app "}"]
1061 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1063 show_label l = mk_showString_app (nm ++ " = ")
1064 -- Note the spaces around the "=" sign. If we don't have them
1065 -- then we get Foo { x=-1 } and the "=-" parses as a single
1066 -- lexeme. Only the space after the '=' is necessary, but
1067 -- it seems tidier to have them both sides.
1069 occ_nm = getOccName l
1070 nm = wrapOpParens (occNameString occ_nm)
1072 show_args = zipWith show_arg bs_needed arg_tys
1073 (show_arg1:show_arg2:_) = show_args
1074 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1076 -- Assumption for record syntax: no of fields == no of labelled fields
1077 -- (and in same order)
1078 show_record_args = concat $
1079 intersperse [mk_showString_app ", "] $
1080 [ [show_label lbl, arg]
1081 | (lbl,arg) <- zipEqual "gen_Show_binds"
1084 -- Generates (showsPrec p x) for argument x, but it also boxes
1085 -- the argument first if necessary. Note that this prints unboxed
1086 -- things without any '#' decorations; could change that if need be
1087 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1088 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1091 is_infix = dataConIsInfix data_con
1092 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1093 arg_prec | record_syntax = 0 -- Record fields don't need parens
1094 | otherwise = con_prec_plus_one
1096 wrapOpParens :: String -> String
1097 wrapOpParens s | isSym s = '(' : s ++ ")"
1100 wrapOpBackquotes :: String -> String
1101 wrapOpBackquotes s | isSym s = s
1102 | otherwise = '`' : s ++ "`"
1104 isSym :: String -> Bool
1106 isSym (c : _) = startsVarSym c || startsConSym c
1108 mk_showString_app :: String -> LHsExpr RdrName
1109 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1113 getPrec :: Bool -> FixityEnv -> Name -> Integer
1114 getPrec is_infix get_fixity nm
1115 | not is_infix = appPrecedence
1116 | otherwise = getPrecedence get_fixity nm
1118 appPrecedence :: Integer
1119 appPrecedence = fromIntegral maxPrecedence + 1
1120 -- One more than the precedence of the most
1121 -- tightly-binding operator
1123 getPrecedence :: FixityEnv -> Name -> Integer
1124 getPrecedence get_fixity nm
1125 = case lookupFixity get_fixity nm of
1126 Fixity x _assoc -> fromIntegral x
1127 -- NB: the Report says that associativity is not taken
1128 -- into account for either Read or Show; hence we
1129 -- ignore associativity here
1133 %************************************************************************
1135 \subsection{Typeable}
1137 %************************************************************************
1145 instance Typeable2 T where
1146 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1148 We are passed the Typeable2 class as well as T
1151 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1152 gen_Typeable_binds loc tycon
1155 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1157 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1159 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1161 mk_typeOf_RDR :: TyCon -> RdrName
1162 -- Use the arity of the TyCon to make the right typeOfn function
1163 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1165 arity = tyConArity tycon
1166 suffix | arity == 0 = ""
1167 | otherwise = show arity
1172 %************************************************************************
1176 %************************************************************************
1180 data T a b = T1 a b | T2
1184 $cT1 = mkDataCon $dT "T1" Prefix
1185 $cT2 = mkDataCon $dT "T2" Prefix
1186 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1187 -- the [] is for field labels.
1189 instance (Data a, Data b) => Data (T a b) where
1190 gfoldl k z (T1 a b) = z T `k` a `k` b
1191 gfoldl k z T2 = z T2
1192 -- ToDo: add gmapT,Q,M, gfoldr
1194 gunfold k z c = case conIndex c of
1195 I# 1# -> k (k (z T1))
1198 toConstr (T1 _ _) = $cT1
1203 dataCast1 = gcast1 -- If T :: * -> *
1204 dataCast2 = gcast2 -- if T :: * -> * -> *
1208 gen_Data_binds :: SrcSpan
1210 -> (LHsBinds RdrName, -- The method bindings
1211 DerivAuxBinds) -- Auxiliary bindings
1212 gen_Data_binds loc tycon
1213 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1214 `unionBags` gcast_binds,
1215 -- Auxiliary definitions: the data type and constructors
1216 MkTyCon tycon : map MkDataCon data_cons)
1218 data_cons = tyConDataCons tycon
1219 n_cons = length data_cons
1220 one_constr = n_cons == 1
1223 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1224 gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1225 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1228 con_name = getRdrName con
1229 as_needed = take (dataConSourceArity con) as_RDRs
1230 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1232 ------------ gunfold
1233 gunfold_bind = mk_FunBind loc
1235 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1239 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1240 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1241 (map gunfold_alt data_cons)
1243 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1244 mk_unfold_rhs dc = foldr nlHsApp
1245 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1246 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1248 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1249 -- redundant test, and annoying warning
1250 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1251 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1255 ------------ toConstr
1256 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1257 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1259 ------------ dataTypeOf
1260 dataTypeOf_bind = mk_easy_FunBind
1264 (nlHsVar (mk_data_type_name tycon))
1266 ------------ gcast1/2
1267 tycon_kind = tyConKind tycon
1268 gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1269 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1270 | otherwise = emptyBag
1271 mk_gcast dataCast_RDR gcast_RDR
1272 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1273 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1276 kind1, kind2 :: Kind
1277 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1278 kind2 = liftedTypeKind `mkArrowKind` kind1
1280 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1281 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1282 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR :: RdrName
1283 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1284 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1285 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1286 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1287 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1288 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1289 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1290 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1291 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1292 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1293 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1294 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1295 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1300 %************************************************************************
1304 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1307 %************************************************************************
1311 data T a = T1 Int a | T2 (T a)
1313 We generate the instance:
1315 instance Functor T where
1316 fmap f (T1 b1 a) = T1 b1 (f a)
1317 fmap f (T2 ta) = T2 (fmap f ta)
1319 Notice that we don't simply apply 'fmap' to the constructor arguments.
1321 - Do nothing to an argument whose type doesn't mention 'a'
1322 - Apply 'f' to an argument of type 'a'
1323 - Apply 'fmap f' to other arguments
1324 That's why we have to recurse deeply into the constructor argument types,
1325 rather than just one level, as we typically do.
1327 What about types with more than one type parameter? In general, we only
1328 derive Functor for the last position:
1330 data S a b = S1 [b] | S2 (a, T a b)
1331 instance Functor (S a) where
1332 fmap f (S1 bs) = S1 (fmap f bs)
1333 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1335 However, we have special cases for
1339 More formally, we write the derivation of fmap code over type variable
1340 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1343 instance Functor T where
1344 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1345 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1347 $(fmap 'a 'b) x = x -- when b does not contain a
1348 $(fmap 'a 'a) x = f x
1349 $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1350 $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1351 $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1353 For functions, the type parameter 'a can occur in a contravariant position,
1354 which means we need to derive a function like:
1356 cofmap :: (a -> b) -> (f b -> f a)
1358 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1360 $(cofmap 'a 'b) x = x -- when b does not contain a
1361 $(cofmap 'a 'a) x = error "type variable in contravariant position"
1362 $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1363 $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
1364 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1365 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1368 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1369 gen_Functor_binds loc tycon
1370 = (unitBag fmap_bind, [])
1372 data_cons = tyConDataCons tycon
1374 fmap_bind = L loc $ mkFunBind (L loc fmap_RDR) (map fmap_eqn data_cons)
1375 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1377 parts = foldDataConArgs ft_fmap con
1379 ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1380 -- Tricky higher order type; I can't say I fully understand this code :-(
1381 ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
1382 , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x
1383 , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1384 -- fmap f x = \b -> h (x (g b))
1385 , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1386 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x
1387 return $ nlHsApps fmap_RDR [gg,x]
1388 , ft_forall = \_ g x -> g x
1389 , ft_bad_app = panic "in other argument"
1390 , ft_co_var = panic "contravariant" }
1392 match_for_con = mkSimpleConMatch $
1393 \con_name xsM -> do xs <- sequence xsM
1394 return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) ..
1397 Utility functions related to Functor deriving.
1399 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1400 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1403 -- Generic traversal for Functor deriving
1404 data FFoldType a -- Describes how to fold over a Type in a functor like way
1405 = FT { ft_triv :: a -- Does not contain variable
1406 , ft_var :: a -- The variable itself
1407 , ft_co_var :: a -- The variable itself, contravariantly
1408 , ft_fun :: a -> a -> a -- Function type
1409 , ft_tup :: Boxity -> [a] -> a -- Tuple type
1410 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1411 , ft_bad_app :: a -- Type app, variable other than in last argument
1412 , ft_forall :: TcTyVar -> a -> a -- Forall type
1415 functorLikeTraverse :: TyVar -- ^ Variable to look for
1416 -> FFoldType a -- ^ How to fold
1417 -> Type -- ^ Type to process
1419 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1420 , ft_co_var = caseCoVar, ft_fun = caseFun
1421 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1422 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1425 where -- go returns (result of type a, does type contain var)
1426 go co ty | Just ty' <- coreView ty = go co ty'
1427 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1428 go co (FunTy (PredTy _) b) = go co b
1429 go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
1430 where (xr,xc) = go (not co) x
1432 go co (AppTy x y) | xc = (caseWrongArg, True)
1433 | yc = (caseTyApp x yr, True)
1434 where (_, xc) = go co x
1436 go co ty@(TyConApp con args)
1437 | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs,True)
1438 | null args = (caseTrivial,False) -- T
1439 | or (init xcs) = (caseWrongArg,True) -- T (..var..) ty
1440 | last xcs = -- T (..no var..) ty
1441 (caseTyApp (fst (splitAppTy ty)) (last xrs),True)
1442 where (xrs,xcs) = unzip (map (go co) args)
1443 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1444 where (xr,xc) = go co x
1445 go _ _ = (caseTrivial,False)
1447 -- Return all syntactic subterms of ty that contain var somewhere
1448 -- These are the things that should appear in instance constraints
1449 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1450 deepSubtypesContaining tv
1451 = functorLikeTraverse tv
1454 , ft_fun = (++), ft_tup = \_ xs -> concat xs
1456 , ft_bad_app = panic "in other argument"
1457 , ft_co_var = panic "contravariant"
1458 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1461 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1462 -- Fold over the arguments of the datacon
1463 foldDataConArgs ft con
1464 = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1466 tv = last (dataConUnivTyVars con)
1467 -- Argument to derive for, 'a in the above description
1468 -- The validity checks have ensured that con is
1469 -- a vanilla data constructor
1471 -- Make a HsLam using a fresh variable from a State monad
1472 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1473 -- (mkSimpleLam fn) returns (\x. fn(x))
1474 mkSimpleLam lam = do
1477 body <- lam (nlHsVar n)
1478 return (mkHsLam [nlVarPat n] body)
1480 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1481 mkSimpleLam2 lam = do
1482 (n1:n2:names) <- get
1484 body <- lam (nlHsVar n1) (nlHsVar n2)
1485 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1487 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1488 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1489 mkSimpleConMatch fold extra_pats con insides = do
1490 let con_name = getRdrName con
1491 let vars_needed = takeList insides as_RDRs
1492 let pat = nlConVarPat con_name vars_needed
1493 rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1494 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1496 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1497 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1498 -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1499 mkSimpleTupleCase match_for_con boxity insides x = do
1500 let con = tupleCon boxity (length insides)
1501 match <- match_for_con [] con insides
1502 return $ nlHsCase x [match]
1506 %************************************************************************
1510 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1513 %************************************************************************
1515 Deriving Foldable instances works the same way as Functor instances,
1516 only Foldable instances are not possible for function types at all.
1517 Here the derived instance for the type T above is:
1519 instance Foldable T where
1520 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1524 $(foldr 'a 'b) x z = z -- when b does not contain a
1525 $(foldr 'a 'a) x z = f x z
1526 $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1527 $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
1529 Note that the arguments to the real foldr function are the wrong way around,
1530 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1533 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1534 gen_Foldable_binds loc tycon
1535 = (unitBag foldr_bind, [])
1537 data_cons = tyConDataCons tycon
1539 foldr_bind = L loc $ mkFunBind (L loc foldable_foldr_RDR) (map foldr_eqn data_cons)
1540 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1542 parts = foldDataConArgs ft_foldr con
1544 ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1545 ft_foldr = FT { ft_triv = \_ z -> return z -- foldr f z x = z
1546 , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f x z
1547 , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1548 , ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1549 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1550 , ft_forall = \_ g x z -> g x z
1551 , ft_co_var = panic "covariant"
1552 , ft_fun = panic "function"
1553 , ft_bad_app = panic "in other argument" }
1555 match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1559 %************************************************************************
1561 Traversable instances
1563 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1565 %************************************************************************
1567 Again, Traversable is much like Functor and Foldable.
1571 $(traverse 'a 'b) x = pure x -- when b does not contain a
1572 $(traverse 'a 'a) x = f x
1573 $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1574 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
1576 Note that the generated code is not as efficient as it could be. For instance:
1578 data T a = T Int a deriving Traversable
1580 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1581 instead of: traverse f (T x y) = T x <$> f y
1584 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1585 gen_Traversable_binds loc tycon
1586 = (unitBag traverse_bind, [])
1588 data_cons = tyConDataCons tycon
1590 traverse_bind = L loc $ mkFunBind (L loc traverse_RDR) (map traverse_eqn data_cons)
1591 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1593 parts = foldDataConArgs ft_trav con
1596 ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1597 ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x]) -- traverse f x = pure x
1598 , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x
1599 , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) ->
1600 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1601 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
1602 return $ nlHsApps traverse_RDR [gg,x]
1603 , ft_forall = \_ g x -> g x
1604 , ft_co_var = panic "covariant"
1605 , ft_fun = panic "function"
1606 , ft_bad_app = panic "in other argument" }
1608 match_for_con = mkSimpleConMatch $
1609 \con_name xsM -> do xs <- sequence xsM
1610 return (mkApCon (nlHsVar con_name) xs)
1612 -- ((Con <$> x1) <*> x2) <*> ..
1613 mkApCon con [] = nlHsApps pure_RDR [con]
1614 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1615 where appAp x y = nlHsApps ap_RDR [x,y]
1620 %************************************************************************
1622 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1624 %************************************************************************
1629 con2tag_Foo :: Foo ... -> Int#
1630 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1631 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1634 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1638 genAuxBind :: SrcSpan -> DerivAuxBind -> LHsBind RdrName
1639 genAuxBind loc (GenCon2Tag tycon)
1640 | lots_of_constructors
1641 = mk_FunBind loc rdr_name [([], get_tag_rhs)]
1644 = mk_FunBind loc rdr_name (map mk_stuff (tyConDataCons tycon))
1647 rdr_name = con2tag_RDR tycon
1649 tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon)
1650 -- We can't use gerRdrName because that makes an Exact RdrName
1651 -- and we can't put them in the LocalRdrEnv
1653 -- Give a signature to the bound variable, so
1654 -- that the case expression generated by getTag is
1655 -- monomorphic. In the push-enter model we get better code.
1656 get_tag_rhs = L loc $ ExprWithTySig
1657 (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR)
1658 (nlHsApp (nlHsVar getTag_RDR) a_Expr)))
1659 (noLoc (mkExplicitHsForAllTy (userHsTyVarBndrs (map noLoc tvs))
1660 (noLoc []) con2tag_ty))
1662 con2tag_ty = nlHsTyConApp (getRdrName tycon) (map nlHsTyVar tvs)
1664 nlHsTyVar (getRdrName intPrimTyCon)
1666 lots_of_constructors = tyConFamilySize tycon > 8
1667 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1668 -- but we don't do vectored returns any more.
1670 mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1671 mk_stuff con = ([nlWildConPat con],
1672 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1674 genAuxBind loc (GenTag2Con tycon)
1675 = mk_FunBind loc rdr_name
1676 [([nlConVarPat intDataCon_RDR [a_RDR]],
1677 noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)
1678 (nlHsTyVar (getRdrName tycon))))]
1680 rdr_name = tag2con_RDR tycon
1682 genAuxBind loc (GenMaxTag tycon)
1683 = mkHsVarBind loc rdr_name
1684 (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag)))
1686 rdr_name = maxtag_RDR tycon
1687 max_tag = case (tyConDataCons tycon) of
1688 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1690 genAuxBind loc (MkTyCon tycon) -- $dT
1691 = mkHsVarBind loc (mk_data_type_name tycon)
1692 ( nlHsVar mkDataType_RDR
1693 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1694 `nlHsApp` nlList constrs )
1696 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1698 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1699 = mkHsVarBind loc (mk_constr_name dc)
1700 (nlHsApps mkConstr_RDR constr_args)
1703 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1704 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1705 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1706 nlList labels, -- Field labels
1707 nlHsVar fixity] -- Fixity
1709 labels = map (nlHsLit . mkHsString . getOccString)
1710 (dataConFieldLabels dc)
1711 dc_occ = getOccName dc
1712 is_infix = isDataSymOcc dc_occ
1713 fixity | is_infix = infix_RDR
1714 | otherwise = prefix_RDR
1716 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1717 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1719 mk_constr_name :: DataCon -> RdrName -- "$cC"
1720 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1723 %************************************************************************
1725 \subsection{Utility bits for generating bindings}
1727 %************************************************************************
1730 ToDo: Better SrcLocs.
1733 box_if_necy :: String -- The class involved
1734 -> TyCon -- The tycon involved
1735 -> LHsExpr RdrName -- The argument
1736 -> Type -- The argument type
1737 -> LHsExpr RdrName -- Boxed version of the arg
1738 box_if_necy cls_str tycon arg arg_ty
1739 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1742 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1744 ---------------------
1745 primOrdOps :: String -- The class involved
1746 -> TyCon -- The tycon involved
1748 -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp) -- (lt,le,eq,ge,gt)
1749 primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
1751 ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
1753 = [(charPrimTy, (CharLtOp, CharLeOp, CharEqOp, CharGeOp, CharGtOp))
1754 ,(intPrimTy, (IntLtOp, IntLeOp, IntEqOp, IntGeOp, IntGtOp))
1755 ,(wordPrimTy, (WordLtOp, WordLeOp, WordEqOp, WordGeOp, WordGtOp))
1756 ,(addrPrimTy, (AddrLtOp, AddrLeOp, AddrEqOp, AddrGeOp, AddrGtOp))
1757 ,(floatPrimTy, (FloatLtOp, FloatLeOp, FloatEqOp, FloatGeOp, FloatGtOp))
1758 ,(doublePrimTy, (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
1760 box_con_tbl :: [(Type, RdrName)]
1762 [(charPrimTy, getRdrName charDataCon)
1763 ,(intPrimTy, getRdrName intDataCon)
1764 ,(wordPrimTy, wordDataCon_RDR)
1765 ,(floatPrimTy, getRdrName floatDataCon)
1766 ,(doublePrimTy, getRdrName doubleDataCon)
1769 assoc_ty_id :: String -- The class involved
1770 -> TyCon -- The tycon involved
1771 -> [(Type,a)] -- The table
1773 -> a -- The result of the lookup
1774 assoc_ty_id cls_str _ tbl ty
1775 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1776 text "for primitive type" <+> ppr ty)
1777 | otherwise = head res
1779 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1781 -----------------------------------------------------------------------
1783 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1784 and_Expr a b = genOpApp a and_RDR b
1786 -----------------------------------------------------------------------
1788 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1789 eq_Expr tycon ty a b = genOpApp a eq_op b
1791 eq_op | not (isUnLiftedType ty) = eq_RDR
1792 | otherwise = primOpRdrName prim_eq
1793 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1797 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1798 untag_Expr _ [] expr = expr
1799 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1800 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1801 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1804 :: LHsExpr RdrName -> LHsExpr RdrName
1806 enum_from_then_to_Expr
1807 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1810 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1811 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1814 :: LHsExpr RdrName -> LHsExpr RdrName
1817 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1819 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1821 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1822 nested_compose_Expr [e] = parenify e
1823 nested_compose_Expr (e:es)
1824 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1826 -- impossible_Expr is used in case RHSs that should never happen.
1827 -- We generate these to keep the desugarer from complaining that they *might* happen!
1828 -- impossible_Expr :: LHsExpr RdrName
1829 -- impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv"))
1831 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1832 -- method. It is currently only used by Enum.{succ,pred}
1833 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1834 illegal_Expr meth tp msg =
1835 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1837 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1838 -- to include the value of a_RDR in the error string.
1839 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1840 illegal_toEnum_tag tp maxtag =
1841 nlHsApp (nlHsVar error_RDR)
1842 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1843 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1844 (nlHsApp (nlHsApp (nlHsApp
1845 (nlHsVar showsPrec_RDR)
1849 (nlHsVar append_RDR)
1850 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1851 (nlHsApp (nlHsApp (nlHsApp
1852 (nlHsVar showsPrec_RDR)
1855 (nlHsLit (mkHsString ")"))))))
1857 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1858 parenify e@(L _ (HsVar _)) = e
1859 parenify e = mkHsPar e
1861 -- genOpApp wraps brackets round the operator application, so that the
1862 -- renamer won't subsequently try to re-associate it.
1863 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1864 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1868 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
1870 a_RDR = mkVarUnqual (fsLit "a")
1871 b_RDR = mkVarUnqual (fsLit "b")
1872 c_RDR = mkVarUnqual (fsLit "c")
1873 d_RDR = mkVarUnqual (fsLit "d")
1874 f_RDR = mkVarUnqual (fsLit "f")
1875 k_RDR = mkVarUnqual (fsLit "k")
1876 z_RDR = mkVarUnqual (fsLit "z")
1877 ah_RDR = mkVarUnqual (fsLit "a#")
1878 bh_RDR = mkVarUnqual (fsLit "b#")
1879 ch_RDR = mkVarUnqual (fsLit "c#")
1880 dh_RDR = mkVarUnqual (fsLit "d#")
1882 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1883 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1884 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1885 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1887 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1888 false_Expr, true_Expr :: LHsExpr RdrName
1889 a_Expr = nlHsVar a_RDR
1890 -- b_Expr = nlHsVar b_RDR
1891 c_Expr = nlHsVar c_RDR
1892 f_Expr = nlHsVar f_RDR
1893 z_Expr = nlHsVar z_RDR
1894 ltTag_Expr = nlHsVar ltTag_RDR
1895 eqTag_Expr = nlHsVar eqTag_RDR
1896 gtTag_Expr = nlHsVar gtTag_RDR
1897 false_Expr = nlHsVar false_RDR
1898 true_Expr = nlHsVar true_RDR
1900 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1901 a_Pat = nlVarPat a_RDR
1902 b_Pat = nlVarPat b_RDR
1903 c_Pat = nlVarPat c_RDR
1904 d_Pat = nlVarPat d_RDR
1905 f_Pat = nlVarPat f_RDR
1906 k_Pat = nlVarPat k_RDR
1907 z_Pat = nlVarPat z_RDR
1909 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1910 -- Generates Orig s RdrName, for the binding positions
1911 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1912 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1913 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1915 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1916 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1918 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1919 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1920 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1921 -- But: (a) that does not work well for standalone-deriving
1922 -- (b) an unqualified name is just fine, provided it can't clash with user code
1925 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1926 PrelNames, so PrelNames can't import PrimOp.
1929 primOpRdrName :: PrimOp -> RdrName
1930 primOpRdrName op = getRdrName (primOpId op)
1932 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
1933 tagToEnum_RDR :: RdrName
1934 minusInt_RDR = primOpRdrName IntSubOp
1935 eqInt_RDR = primOpRdrName IntEqOp
1936 ltInt_RDR = primOpRdrName IntLtOp
1937 geInt_RDR = primOpRdrName IntGeOp
1938 gtInt_RDR = primOpRdrName IntGtOp
1939 leInt_RDR = primOpRdrName IntLeOp
1940 tagToEnum_RDR = primOpRdrName TagToEnumOp
1942 error_RDR :: RdrName
1943 error_RDR = getRdrName eRROR_ID