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"
44 import MkCore ( eRROR_ID )
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 [eq_bind, ne_bind]
188 eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
189 ne_bind = 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 | null tycon_data_cons -- No data-cons => invoke bale-out case
325 = (unitBag $ mk_FunBind loc compare_RDR [], [])
327 = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
329 aux_binds | single_con_type = []
330 | otherwise = [GenCon2Tag tycon]
332 -- Note [Do not rely on compare]
333 other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
334 || null non_nullary_cons -- Or it's an enumeration
335 = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
339 get_tag con = dataConTag con - fIRST_TAG
340 -- We want *zero-based* tags, because that's what
341 -- con2Tag returns (generated by untag_Expr)!
343 tycon_data_cons = tyConDataCons tycon
344 single_con_type = isSingleton tycon_data_cons
345 (first_con : _) = tycon_data_cons
346 (last_con : _) = reverse tycon_data_cons
347 first_tag = get_tag first_con
348 last_tag = get_tag last_con
350 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
353 mkOrdOp :: OrdOp -> LHsBind RdrName
354 -- Returns a binding op a b = ... compares a and b according to op ....
355 mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
357 mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
358 mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
359 | length nullary_cons <= 2 -- Two nullary or fewer, so use cases
360 = nlHsCase (nlHsVar a_RDR) $
361 map (mkOrdOpAlt op) tycon_data_cons
362 -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
363 -- C2 x -> case b of C2 x -> ....comopare x.... }
365 | null non_nullary_cons -- All nullary, so go straight to comparing tags
368 | otherwise -- Mixed nullary and non-nullary
369 = nlHsCase (nlHsVar a_RDR) $
370 (map (mkOrdOpAlt op) non_nullary_cons
371 ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
374 mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName
375 -- Make the alternative (Ki a1 a2 .. av ->
376 mkOrdOpAlt op data_con
377 = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
379 as_needed = take (dataConSourceArity data_con) as_RDRs
380 data_con_RDR = getRdrName data_con
382 mkInnerRhs op data_con
384 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
387 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
388 , mkSimpleHsAlt nlWildPat (ltResult op) ]
390 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
391 , mkSimpleHsAlt nlWildPat (gtResult op) ]
393 | tag == first_tag + 1
394 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
395 , mkInnerEqAlt op data_con
396 , mkSimpleHsAlt nlWildPat (ltResult op) ]
397 | tag == last_tag - 1
398 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
399 , mkInnerEqAlt op data_con
400 , mkSimpleHsAlt nlWildPat (gtResult op) ]
402 | tag > last_tag `div` 2 -- lower range is larger
403 = untag_Expr tycon [(b_RDR, bh_RDR)] $
404 nlHsIf (genOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
405 (gtResult op) $ -- Definitely GT
406 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
407 , mkSimpleHsAlt nlWildPat (ltResult op) ]
409 | otherwise -- upper range is larger
410 = untag_Expr tycon [(b_RDR, bh_RDR)] $
411 nlHsIf (genOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
412 (ltResult op) $ -- Definitely LT
413 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
414 , mkSimpleHsAlt nlWildPat (gtResult op) ]
416 tag = get_tag data_con
417 tag_lit = noLoc (HsLit (HsIntPrim (toInteger tag)))
419 mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName
420 -- First argument 'a' known to be built with K
421 -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
422 mkInnerEqAlt op data_con
423 = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
424 mkCompareFields tycon op (dataConOrigArgTys data_con)
426 data_con_RDR = getRdrName data_con
427 bs_needed = take (dataConSourceArity data_con) bs_RDRs
429 mkTagCmp :: OrdOp -> LHsExpr RdrName
430 -- Both constructors known to be nullary
431 -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
432 mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
433 unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
435 mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
436 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
437 -- where the ai,bi have the given types
438 mkCompareFields tycon op tys
439 = go tys as_RDRs bs_RDRs
441 go [] _ _ = eqResult op
443 | isUnLiftedType ty = unliftedOrdOp tycon ty op a b
444 | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
445 go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
449 go _ _ _ = panic "mkCompareFields"
451 -- (mk_compare ty a b) generates
452 -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
453 -- but with suitable special cases for
454 mk_compare ty a b lt eq gt
456 = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
458 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
459 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
460 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
461 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
465 (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
467 unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
468 unliftedOrdOp tycon ty op a b
470 OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
471 ltTag_Expr eqTag_Expr gtTag_Expr
477 (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
478 wrap prim_op = genOpApp a_expr (primOpRdrName prim_op) b_expr
482 unliftedCompare :: PrimOp -> PrimOp
483 -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare
484 -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results
486 -- Return (if a < b then lt else if a == b then eq else gt)
487 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
488 = nlHsIf (genOpApp a_expr (primOpRdrName lt_op) b_expr) lt $
489 -- Test (<) first, not (==), becuase the latter
490 -- is true less often, so putting it first would
491 -- mean more tests (dynamically)
492 nlHsIf (genOpApp a_expr (primOpRdrName eq_op) b_expr) eq gt
494 nlConWildPat :: DataCon -> LPat RdrName
495 -- The pattern (K {})
496 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
497 (RecCon (HsRecFields { rec_flds = []
498 , rec_dotdot = Nothing })))
503 %************************************************************************
507 %************************************************************************
509 @Enum@ can only be derived for enumeration types. For a type
511 data Foo ... = N1 | N2 | ... | Nn
514 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
515 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
518 instance ... Enum (Foo ...) where
519 succ x = toEnum (1 + fromEnum x)
520 pred x = toEnum (fromEnum x - 1)
522 toEnum i = tag2con_Foo i
524 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
528 = case con2tag_Foo a of
529 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
532 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
536 = case con2tag_Foo a of { a# ->
537 case con2tag_Foo b of { b# ->
538 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
542 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
545 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
546 gen_Enum_binds loc tycon
547 = (method_binds, aux_binds)
549 method_binds = listToBag [
557 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
559 occ_nm = getOccString tycon
562 = mk_easy_FunBind loc succ_RDR [a_Pat] $
563 untag_Expr tycon [(a_RDR, ah_RDR)] $
564 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
565 nlHsVarApps intDataCon_RDR [ah_RDR]])
566 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
567 (nlHsApp (nlHsVar (tag2con_RDR tycon))
568 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
572 = mk_easy_FunBind loc pred_RDR [a_Pat] $
573 untag_Expr tycon [(a_RDR, ah_RDR)] $
574 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
575 nlHsVarApps intDataCon_RDR [ah_RDR]])
576 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
577 (nlHsApp (nlHsVar (tag2con_RDR tycon))
578 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
579 nlHsLit (HsInt (-1))]))
582 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
583 nlHsIf (nlHsApps and_RDR
584 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
585 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
586 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
587 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
590 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
591 untag_Expr tycon [(a_RDR, ah_RDR)] $
593 [nlHsVar (tag2con_RDR tycon),
594 nlHsPar (enum_from_to_Expr
595 (nlHsVarApps intDataCon_RDR [ah_RDR])
596 (nlHsVar (maxtag_RDR tycon)))]
599 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
600 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
601 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
602 nlHsPar (enum_from_then_to_Expr
603 (nlHsVarApps intDataCon_RDR [ah_RDR])
604 (nlHsVarApps intDataCon_RDR [bh_RDR])
605 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
606 nlHsVarApps intDataCon_RDR [bh_RDR]])
608 (nlHsVar (maxtag_RDR tycon))
612 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
613 untag_Expr tycon [(a_RDR, ah_RDR)] $
614 (nlHsVarApps intDataCon_RDR [ah_RDR])
617 %************************************************************************
621 %************************************************************************
624 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
625 gen_Bounded_binds loc tycon
626 | isEnumerationTyCon tycon
627 = (listToBag [ min_bound_enum, max_bound_enum ], [])
629 = ASSERT(isSingleton data_cons)
630 (listToBag [ min_bound_1con, max_bound_1con ], [])
632 data_cons = tyConDataCons tycon
634 ----- enum-flavored: ---------------------------
635 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
636 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
638 data_con_1 = head data_cons
639 data_con_N = last data_cons
640 data_con_1_RDR = getRdrName data_con_1
641 data_con_N_RDR = getRdrName data_con_N
643 ----- single-constructor-flavored: -------------
644 arity = dataConSourceArity data_con_1
646 min_bound_1con = mkHsVarBind loc minBound_RDR $
647 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
648 max_bound_1con = mkHsVarBind loc maxBound_RDR $
649 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
652 %************************************************************************
656 %************************************************************************
658 Deriving @Ix@ is only possible for enumeration types and
659 single-constructor types. We deal with them in turn.
661 For an enumeration type, e.g.,
663 data Foo ... = N1 | N2 | ... | Nn
665 things go not too differently from @Enum@:
667 instance ... Ix (Foo ...) where
669 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
673 = case (con2tag_Foo a) of { a# ->
674 case (con2tag_Foo b) of { b# ->
675 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
678 -- Generate code for unsafeIndex, becuase using index leads
679 -- to lots of redundant range tests
680 unsafeIndex c@(a, b) d
681 = case (con2tag_Foo d -# con2tag_Foo a) of
686 p_tag = con2tag_Foo c
688 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
692 = case (con2tag_Foo a) of { a_tag ->
693 case (con2tag_Foo b) of { b_tag ->
694 case (con2tag_Foo c) of { c_tag ->
695 if (c_tag >=# a_tag) then
701 (modulo suitable case-ification to handle the unlifted tags)
703 For a single-constructor type (NB: this includes all tuples), e.g.,
705 data Foo ... = MkFoo a b Int Double c c
707 we follow the scheme given in Figure~19 of the Haskell~1.2 report
711 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
713 gen_Ix_binds loc tycon
714 | isEnumerationTyCon tycon
715 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
717 = (single_con_ixes, [GenCon2Tag tycon])
719 --------------------------------------------------------------
720 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
723 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
724 untag_Expr tycon [(a_RDR, ah_RDR)] $
725 untag_Expr tycon [(b_RDR, bh_RDR)] $
726 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
727 nlHsPar (enum_from_to_Expr
728 (nlHsVarApps intDataCon_RDR [ah_RDR])
729 (nlHsVarApps intDataCon_RDR [bh_RDR]))
732 = mk_easy_FunBind loc unsafeIndex_RDR
733 [noLoc (AsPat (noLoc c_RDR)
734 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
736 untag_Expr tycon [(a_RDR, ah_RDR)] (
737 untag_Expr tycon [(d_RDR, dh_RDR)] (
739 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
742 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
743 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
748 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
749 untag_Expr tycon [(a_RDR, ah_RDR)] (
750 untag_Expr tycon [(b_RDR, bh_RDR)] (
751 untag_Expr tycon [(c_RDR, ch_RDR)] (
752 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
753 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
758 --------------------------------------------------------------
760 = listToBag [single_con_range, single_con_index, single_con_inRange]
763 = case tyConSingleDataCon_maybe tycon of -- just checking...
764 Nothing -> panic "get_Ix_binds"
767 con_arity = dataConSourceArity data_con
768 data_con_RDR = getRdrName data_con
770 as_needed = take con_arity as_RDRs
771 bs_needed = take con_arity bs_RDRs
772 cs_needed = take con_arity cs_RDRs
774 con_pat xs = nlConVarPat data_con_RDR xs
775 con_expr = nlHsVarApps data_con_RDR cs_needed
777 --------------------------------------------------------------
779 = mk_easy_FunBind loc range_RDR
780 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
781 nlHsDo ListComp stmts con_expr
783 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
785 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
786 (nlHsApp (nlHsVar range_RDR)
787 (mkLHsVarTuple [a,b]))
791 = mk_easy_FunBind loc unsafeIndex_RDR
792 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
794 -- We need to reverse the order we consider the components in
796 -- range (l,u) !! index (l,u) i == i -- when i is in range
797 -- (from http://haskell.org/onlinereport/ix.html) holds.
798 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
800 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
801 mk_index [] = nlHsIntLit 0
802 mk_index [(l,u,i)] = mk_one l u i
803 mk_index ((l,u,i) : rest)
808 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
809 (mkLHsVarTuple [l,u]))
810 ) times_RDR (mk_index rest)
813 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
817 = mk_easy_FunBind loc inRange_RDR
818 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
820 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
822 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
825 %************************************************************************
829 %************************************************************************
839 instance Read T where
843 do x <- ReadP.step Read.readPrec
844 Symbol "%%" <- Lex.lex
845 y <- ReadP.step Read.readPrec
849 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
850 -- Record construction binds even more tightly than application
851 do Ident "T1" <- Lex.lex
853 Ident "f1" <- Lex.lex
855 x <- ReadP.reset Read.readPrec
857 return (T1 { f1 = x }))
860 do Ident "T2" <- Lex.lexP
861 x <- ReadP.step Read.readPrec
865 readListPrec = readListPrecDefault
866 readList = readListDefault
870 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
872 gen_Read_binds get_fixity loc tycon
873 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
875 -----------------------------------------------------------------------
877 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
880 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
881 -----------------------------------------------------------------------
883 data_cons = tyConDataCons tycon
884 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
886 read_prec = mkHsVarBind loc readPrec_RDR
887 (nlHsApp (nlHsVar parens_RDR) read_cons)
889 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
890 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
893 = case nullary_cons of
895 [con] -> [nlHsDo DoExpr (match_con con) (result_expr con [])]
896 _ -> [nlHsApp (nlHsVar choose_RDR)
897 (nlList (map mk_pair nullary_cons))]
898 -- NB For operators the parens around (:=:) are matched by the
899 -- enclosing "parens" call, so here we must match the naked
902 match_con con | isSym con_str = [symbol_pat con_str]
903 | otherwise = ident_h_pat con_str
905 con_str = data_con_str con
906 -- For nullary constructors we must match Ident s for normal constrs
907 -- and Symbol s for operators
909 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
912 read_non_nullary_con data_con
913 | is_infix = mk_parser infix_prec infix_stmts body
914 | is_record = mk_parser record_prec record_stmts body
915 -- Using these two lines instead allows the derived
916 -- read for infix and record bindings to read the prefix form
917 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
918 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
919 | otherwise = prefix_parser
921 body = result_expr data_con as_needed
922 con_str = data_con_str data_con
924 prefix_parser = mk_parser prefix_prec prefix_stmts body
927 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
928 | otherwise = ident_h_pat con_str
931 | isSym con_str = [symbol_pat con_str]
932 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
934 prefix_stmts -- T a b c
935 = read_prefix_con ++ read_args
937 infix_stmts -- a %% b, or a `T` b
942 record_stmts -- T { f1 = a, f2 = b }
945 ++ concat (intersperse [read_punc ","] field_stmts)
948 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
950 con_arity = dataConSourceArity data_con
951 labels = dataConFieldLabels data_con
952 dc_nm = getName data_con
953 is_infix = dataConIsInfix data_con
954 is_record = length labels > 0
955 as_needed = take con_arity as_RDRs
956 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
957 (read_a1:read_a2:_) = read_args
959 prefix_prec = appPrecedence
960 infix_prec = getPrecedence get_fixity dc_nm
961 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
962 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
964 ------------------------------------------------------------------------
966 ------------------------------------------------------------------------
967 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
968 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b })
969 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
970 con_app con as = nlHsVarApps (getRdrName con) as -- con as
971 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
973 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
975 -- For constructors and field labels ending in '#', we hackily
976 -- let the lexer generate two tokens, and look for both in sequence
977 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
978 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
979 | otherwise = [ ident_pat s ]
981 ident_pat s = bindLex $ nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" <- lexP
982 symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" <- lexP
984 data_con_str con = occNameString (getOccName con)
986 read_punc c = bindLex (punc_pat c)
987 read_arg a ty = ASSERT( not (isUnLiftedType ty) )
988 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
990 read_field lbl a = read_lbl lbl ++
992 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
994 -- When reading field labels we might encounter
999 read_lbl lbl | isSym lbl_str
1000 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1002 = ident_h_pat lbl_str
1004 lbl_str = occNameString (getOccName lbl)
1008 %************************************************************************
1012 %************************************************************************
1018 data Tree a = Leaf a | Tree a :^: Tree a
1020 instance (Show a) => Show (Tree a) where
1022 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1024 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1026 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1028 showStr = showsPrec (up_prec+1) u .
1029 showString " :^: " .
1030 showsPrec (up_prec+1) v
1031 -- Note: right-associativity of :^: ignored
1033 up_prec = 5 -- Precedence of :^:
1034 app_prec = 10 -- Application has precedence one more than
1035 -- the most tightly-binding operator
1038 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1040 gen_Show_binds get_fixity loc tycon
1041 = (listToBag [shows_prec, show_list], [])
1043 -----------------------------------------------------------------------
1044 show_list = mkHsVarBind loc showList_RDR
1045 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1046 -----------------------------------------------------------------------
1047 data_cons = tyConDataCons tycon
1048 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
1051 | nullary_con = -- skip the showParen junk...
1052 ASSERT(null bs_needed)
1053 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1056 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
1057 (nlHsPar (nested_compose_Expr show_thingies)))
1059 data_con_RDR = getRdrName data_con
1060 con_arity = dataConSourceArity data_con
1061 bs_needed = take con_arity bs_RDRs
1062 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1063 con_pat = nlConVarPat data_con_RDR bs_needed
1064 nullary_con = con_arity == 0
1065 labels = dataConFieldLabels data_con
1066 lab_fields = length labels
1067 record_syntax = lab_fields > 0
1069 dc_nm = getName data_con
1070 dc_occ_nm = getOccName data_con
1071 con_str = occNameString dc_occ_nm
1072 op_con_str = wrapOpParens con_str
1073 backquote_str = wrapOpBackquotes con_str
1076 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1077 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1078 show_record_args ++ [mk_showString_app "}"]
1079 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1081 show_label l = mk_showString_app (nm ++ " = ")
1082 -- Note the spaces around the "=" sign. If we don't have them
1083 -- then we get Foo { x=-1 } and the "=-" parses as a single
1084 -- lexeme. Only the space after the '=' is necessary, but
1085 -- it seems tidier to have them both sides.
1087 occ_nm = getOccName l
1088 nm = wrapOpParens (occNameString occ_nm)
1090 show_args = zipWith show_arg bs_needed arg_tys
1091 (show_arg1:show_arg2:_) = show_args
1092 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1094 -- Assumption for record syntax: no of fields == no of labelled fields
1095 -- (and in same order)
1096 show_record_args = concat $
1097 intersperse [mk_showString_app ", "] $
1098 [ [show_label lbl, arg]
1099 | (lbl,arg) <- zipEqual "gen_Show_binds"
1102 -- Generates (showsPrec p x) for argument x, but it also boxes
1103 -- the argument first if necessary. Note that this prints unboxed
1104 -- things without any '#' decorations; could change that if need be
1105 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1106 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1109 is_infix = dataConIsInfix data_con
1110 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1111 arg_prec | record_syntax = 0 -- Record fields don't need parens
1112 | otherwise = con_prec_plus_one
1114 wrapOpParens :: String -> String
1115 wrapOpParens s | isSym s = '(' : s ++ ")"
1118 wrapOpBackquotes :: String -> String
1119 wrapOpBackquotes s | isSym s = s
1120 | otherwise = '`' : s ++ "`"
1122 isSym :: String -> Bool
1124 isSym (c : _) = startsVarSym c || startsConSym c
1126 mk_showString_app :: String -> LHsExpr RdrName
1127 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1131 getPrec :: Bool -> FixityEnv -> Name -> Integer
1132 getPrec is_infix get_fixity nm
1133 | not is_infix = appPrecedence
1134 | otherwise = getPrecedence get_fixity nm
1136 appPrecedence :: Integer
1137 appPrecedence = fromIntegral maxPrecedence + 1
1138 -- One more than the precedence of the most
1139 -- tightly-binding operator
1141 getPrecedence :: FixityEnv -> Name -> Integer
1142 getPrecedence get_fixity nm
1143 = case lookupFixity get_fixity nm of
1144 Fixity x _assoc -> fromIntegral x
1145 -- NB: the Report says that associativity is not taken
1146 -- into account for either Read or Show; hence we
1147 -- ignore associativity here
1151 %************************************************************************
1153 \subsection{Typeable}
1155 %************************************************************************
1163 instance Typeable2 T where
1164 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1166 We are passed the Typeable2 class as well as T
1169 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1170 gen_Typeable_binds loc tycon
1173 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1175 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1177 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1179 mk_typeOf_RDR :: TyCon -> RdrName
1180 -- Use the arity of the TyCon to make the right typeOfn function
1181 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1183 arity = tyConArity tycon
1184 suffix | arity == 0 = ""
1185 | otherwise = show arity
1190 %************************************************************************
1194 %************************************************************************
1198 data T a b = T1 a b | T2
1202 $cT1 = mkDataCon $dT "T1" Prefix
1203 $cT2 = mkDataCon $dT "T2" Prefix
1204 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1205 -- the [] is for field labels.
1207 instance (Data a, Data b) => Data (T a b) where
1208 gfoldl k z (T1 a b) = z T `k` a `k` b
1209 gfoldl k z T2 = z T2
1210 -- ToDo: add gmapT,Q,M, gfoldr
1212 gunfold k z c = case conIndex c of
1213 I# 1# -> k (k (z T1))
1216 toConstr (T1 _ _) = $cT1
1221 dataCast1 = gcast1 -- If T :: * -> *
1222 dataCast2 = gcast2 -- if T :: * -> * -> *
1226 gen_Data_binds :: SrcSpan
1228 -> (LHsBinds RdrName, -- The method bindings
1229 DerivAuxBinds) -- Auxiliary bindings
1230 gen_Data_binds loc tycon
1231 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1232 `unionBags` gcast_binds,
1233 -- Auxiliary definitions: the data type and constructors
1234 MkTyCon tycon : map MkDataCon data_cons)
1236 data_cons = tyConDataCons tycon
1237 n_cons = length data_cons
1238 one_constr = n_cons == 1
1241 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1244 = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1245 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1248 con_name = getRdrName con
1249 as_needed = take (dataConSourceArity con) as_RDRs
1250 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1252 ------------ gunfold
1253 gunfold_bind = mk_FunBind loc
1255 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1259 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1260 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1261 (map gunfold_alt data_cons)
1263 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1264 mk_unfold_rhs dc = foldr nlHsApp
1265 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1266 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1268 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1269 -- redundant test, and annoying warning
1270 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1271 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1275 ------------ toConstr
1276 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1277 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1279 ------------ dataTypeOf
1280 dataTypeOf_bind = mk_easy_FunBind
1284 (nlHsVar (mk_data_type_name tycon))
1286 ------------ gcast1/2
1287 tycon_kind = tyConKind tycon
1288 gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1289 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1290 | otherwise = emptyBag
1291 mk_gcast dataCast_RDR gcast_RDR
1292 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1293 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1296 kind1, kind2 :: Kind
1297 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1298 kind2 = liftedTypeKind `mkArrowKind` kind1
1300 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1301 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1302 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1303 constr_RDR, dataType_RDR :: RdrName
1304 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1305 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1306 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1307 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1308 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1309 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1310 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1311 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1312 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1313 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1314 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1315 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1316 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1317 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1318 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1323 %************************************************************************
1327 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1330 %************************************************************************
1334 data T a = T1 Int a | T2 (T a)
1336 We generate the instance:
1338 instance Functor T where
1339 fmap f (T1 b1 a) = T1 b1 (f a)
1340 fmap f (T2 ta) = T2 (fmap f ta)
1342 Notice that we don't simply apply 'fmap' to the constructor arguments.
1344 - Do nothing to an argument whose type doesn't mention 'a'
1345 - Apply 'f' to an argument of type 'a'
1346 - Apply 'fmap f' to other arguments
1347 That's why we have to recurse deeply into the constructor argument types,
1348 rather than just one level, as we typically do.
1350 What about types with more than one type parameter? In general, we only
1351 derive Functor for the last position:
1353 data S a b = S1 [b] | S2 (a, T a b)
1354 instance Functor (S a) where
1355 fmap f (S1 bs) = S1 (fmap f bs)
1356 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1358 However, we have special cases for
1362 More formally, we write the derivation of fmap code over type variable
1363 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1366 instance Functor T where
1367 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1368 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1370 $(fmap 'a 'b) x = x -- when b does not contain a
1371 $(fmap 'a 'a) x = f x
1372 $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1373 $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1374 $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1376 For functions, the type parameter 'a can occur in a contravariant position,
1377 which means we need to derive a function like:
1379 cofmap :: (a -> b) -> (f b -> f a)
1381 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1383 $(cofmap 'a 'b) x = x -- when b does not contain a
1384 $(cofmap 'a 'a) x = error "type variable in contravariant position"
1385 $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1386 $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
1387 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1388 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1391 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1392 gen_Functor_binds loc tycon
1393 = (unitBag fmap_bind, [])
1395 data_cons = tyConDataCons tycon
1396 fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
1398 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1400 parts = foldDataConArgs ft_fmap con
1402 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1403 (error_Expr "Void fmap")]
1404 | otherwise = map fmap_eqn data_cons
1406 ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1407 -- Tricky higher order type; I can't say I fully understand this code :-(
1408 ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
1409 , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x
1410 , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1411 -- fmap f x = \b -> h (x (g b))
1412 , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1413 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x
1414 return $ nlHsApps fmap_RDR [gg,x]
1415 , ft_forall = \_ g x -> g x
1416 , ft_bad_app = panic "in other argument"
1417 , ft_co_var = panic "contravariant" }
1419 match_for_con = mkSimpleConMatch $
1420 \con_name xsM -> do xs <- sequence xsM
1421 return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) ..
1424 Utility functions related to Functor deriving.
1426 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1427 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1430 -- Generic traversal for Functor deriving
1431 data FFoldType a -- Describes how to fold over a Type in a functor like way
1432 = FT { ft_triv :: a -- Does not contain variable
1433 , ft_var :: a -- The variable itself
1434 , ft_co_var :: a -- The variable itself, contravariantly
1435 , ft_fun :: a -> a -> a -- Function type
1436 , ft_tup :: Boxity -> [a] -> a -- Tuple type
1437 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1438 , ft_bad_app :: a -- Type app, variable other than in last argument
1439 , ft_forall :: TcTyVar -> a -> a -- Forall type
1442 functorLikeTraverse :: TyVar -- ^ Variable to look for
1443 -> FFoldType a -- ^ How to fold
1444 -> Type -- ^ Type to process
1446 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1447 , ft_co_var = caseCoVar, ft_fun = caseFun
1448 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1449 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1452 where -- go returns (result of type a, does type contain var)
1453 go co ty | Just ty' <- coreView ty = go co ty'
1454 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1455 go co (FunTy (PredTy _) b) = go co b
1456 go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
1457 where (xr,xc) = go (not co) x
1459 go co (AppTy x y) | xc = (caseWrongArg, True)
1460 | yc = (caseTyApp x yr, True)
1461 where (_, xc) = go co x
1463 go co ty@(TyConApp con args)
1464 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
1465 -- At this point we know that xrs, xcs is not empty,
1466 -- and at least one xr is True
1467 | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs, True)
1468 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
1469 | otherwise = -- T (..no var..) ty
1470 (caseTyApp (fst (splitAppTy ty)) (last xrs), True)
1471 where (xrs,xcs) = unzip (map (go co) args)
1472 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1473 where (xr,xc) = go co x
1474 go _ _ = (caseTrivial,False)
1476 -- Return all syntactic subterms of ty that contain var somewhere
1477 -- These are the things that should appear in instance constraints
1478 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1479 deepSubtypesContaining tv
1480 = functorLikeTraverse tv
1483 , ft_fun = (++), ft_tup = \_ xs -> concat xs
1485 , ft_bad_app = panic "in other argument"
1486 , ft_co_var = panic "contravariant"
1487 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1490 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1491 -- Fold over the arguments of the datacon
1492 foldDataConArgs ft con
1493 = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1495 tv = last (dataConUnivTyVars con)
1496 -- Argument to derive for, 'a in the above description
1497 -- The validity checks have ensured that con is
1498 -- a vanilla data constructor
1500 -- Make a HsLam using a fresh variable from a State monad
1501 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1502 -- (mkSimpleLam fn) returns (\x. fn(x))
1503 mkSimpleLam lam = do
1506 body <- lam (nlHsVar n)
1507 return (mkHsLam [nlVarPat n] body)
1509 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1510 mkSimpleLam2 lam = do
1511 (n1:n2:names) <- get
1513 body <- lam (nlHsVar n1) (nlHsVar n2)
1514 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1516 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1517 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1518 mkSimpleConMatch fold extra_pats con insides = do
1519 let con_name = getRdrName con
1520 let vars_needed = takeList insides as_RDRs
1521 let pat = nlConVarPat con_name vars_needed
1522 rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1523 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1525 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1526 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1527 -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1528 mkSimpleTupleCase match_for_con boxity insides x = do
1529 let con = tupleCon boxity (length insides)
1530 match <- match_for_con [] con insides
1531 return $ nlHsCase x [match]
1535 %************************************************************************
1539 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1542 %************************************************************************
1544 Deriving Foldable instances works the same way as Functor instances,
1545 only Foldable instances are not possible for function types at all.
1546 Here the derived instance for the type T above is:
1548 instance Foldable T where
1549 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1553 $(foldr 'a 'b) x z = z -- when b does not contain a
1554 $(foldr 'a 'a) x z = f x z
1555 $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1556 $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
1558 Note that the arguments to the real foldr function are the wrong way around,
1559 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1562 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1563 gen_Foldable_binds loc tycon
1564 = (unitBag foldr_bind, [])
1566 data_cons = tyConDataCons tycon
1568 foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1569 eqns = map foldr_eqn data_cons
1570 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1572 parts = foldDataConArgs ft_foldr con
1574 ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1575 ft_foldr = FT { ft_triv = \_ z -> return z -- foldr f z x = z
1576 , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f x z
1577 , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1578 , ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1579 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1580 , ft_forall = \_ g x z -> g x z
1581 , ft_co_var = panic "covariant"
1582 , ft_fun = panic "function"
1583 , ft_bad_app = panic "in other argument" }
1585 match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1589 %************************************************************************
1591 Traversable instances
1593 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1595 %************************************************************************
1597 Again, Traversable is much like Functor and Foldable.
1601 $(traverse 'a 'b) x = pure x -- when b does not contain a
1602 $(traverse 'a 'a) x = f x
1603 $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1604 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
1606 Note that the generated code is not as efficient as it could be. For instance:
1608 data T a = T Int a deriving Traversable
1610 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1611 instead of: traverse f (T x y) = T x <$> f y
1614 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1615 gen_Traversable_binds loc tycon
1616 = (unitBag traverse_bind, [])
1618 data_cons = tyConDataCons tycon
1620 traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
1621 eqns = map traverse_eqn data_cons
1622 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1624 parts = foldDataConArgs ft_trav con
1627 ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1628 ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x]) -- traverse f x = pure x
1629 , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x
1630 , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) ->
1631 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1632 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
1633 return $ nlHsApps traverse_RDR [gg,x]
1634 , ft_forall = \_ g x -> g x
1635 , ft_co_var = panic "covariant"
1636 , ft_fun = panic "function"
1637 , ft_bad_app = panic "in other argument" }
1639 match_for_con = mkSimpleConMatch $
1640 \con_name xsM -> do xs <- sequence xsM
1641 return (mkApCon (nlHsVar con_name) xs)
1643 -- ((Con <$> x1) <*> x2) <*> ..
1644 mkApCon con [] = nlHsApps pure_RDR [con]
1645 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1646 where appAp x y = nlHsApps ap_RDR [x,y]
1651 %************************************************************************
1653 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1655 %************************************************************************
1660 con2tag_Foo :: Foo ... -> Int#
1661 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1662 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1665 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1669 genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
1670 genAuxBind loc (GenCon2Tag tycon)
1671 = (mk_FunBind loc rdr_name eqns,
1672 L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1674 rdr_name = con2tag_RDR tycon
1677 mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
1678 mkParentType tycon `mkFunTy` intPrimTy
1680 lots_of_constructors = tyConFamilySize tycon > 8
1681 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1682 -- but we don't do vectored returns any more.
1684 eqns | lots_of_constructors = [get_tag_eqn]
1685 | otherwise = map mk_eqn (tyConDataCons tycon)
1687 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1689 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1690 mk_eqn con = ([nlWildConPat con],
1691 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1693 genAuxBind loc (GenTag2Con tycon)
1694 = (mk_FunBind loc rdr_name
1695 [([nlConVarPat intDataCon_RDR [a_RDR]],
1696 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1697 L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1699 sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
1700 intTy `mkFunTy` mkParentType tycon
1702 rdr_name = tag2con_RDR tycon
1704 genAuxBind loc (GenMaxTag tycon)
1705 = (mkHsVarBind loc rdr_name rhs,
1706 L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1708 rdr_name = maxtag_RDR tycon
1709 sig_ty = HsCoreTy intTy
1710 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
1711 max_tag = case (tyConDataCons tycon) of
1712 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1714 genAuxBind loc (MkTyCon tycon) -- $dT
1715 = (mkHsVarBind loc rdr_name rhs,
1716 L loc (TypeSig (L loc rdr_name) sig_ty))
1718 rdr_name = mk_data_type_name tycon
1719 sig_ty = nlHsTyVar dataType_RDR
1720 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1721 rhs = nlHsVar mkDataType_RDR
1722 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1723 `nlHsApp` nlList constrs
1725 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1726 = (mkHsVarBind loc rdr_name rhs,
1727 L loc (TypeSig (L loc rdr_name) sig_ty))
1729 rdr_name = mk_constr_name dc
1730 sig_ty = nlHsTyVar constr_RDR
1731 rhs = nlHsApps mkConstr_RDR constr_args
1734 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1735 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1736 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1737 nlList labels, -- Field labels
1738 nlHsVar fixity] -- Fixity
1740 labels = map (nlHsLit . mkHsString . getOccString)
1741 (dataConFieldLabels dc)
1742 dc_occ = getOccName dc
1743 is_infix = isDataSymOcc dc_occ
1744 fixity | is_infix = infix_RDR
1745 | otherwise = prefix_RDR
1747 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1748 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1750 mk_constr_name :: DataCon -> RdrName -- "$cC"
1751 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1753 mkParentType :: TyCon -> Type
1754 -- Turn the representation tycon of a family into
1755 -- a use of its family constructor
1757 = case tyConFamInst_maybe tc of
1758 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
1759 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
1762 %************************************************************************
1764 \subsection{Utility bits for generating bindings}
1766 %************************************************************************
1770 mk_FunBind :: SrcSpan -> RdrName
1771 -> [([LPat RdrName], LHsExpr RdrName)]
1773 mk_FunBind loc fun pats_and_exprs
1774 = L loc $ mkRdrFunBind (L loc fun) matches
1776 matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
1778 mkRdrFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName
1779 mkRdrFunBind fun@(L _ fun_rdr) matches
1780 | null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds]
1781 -- Catch-all eqn looks like
1782 -- fmap = error "Void fmap"
1783 -- It's needed if there no data cons at all,
1784 -- which can happen with -XEmptyDataDecls
1786 | otherwise = mkFunBind fun matches
1788 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
1792 box_if_necy :: String -- The class involved
1793 -> TyCon -- The tycon involved
1794 -> LHsExpr RdrName -- The argument
1795 -> Type -- The argument type
1796 -> LHsExpr RdrName -- Boxed version of the arg
1797 box_if_necy cls_str tycon arg arg_ty
1798 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1801 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1803 ---------------------
1804 primOrdOps :: String -- The class involved
1805 -> TyCon -- The tycon involved
1807 -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp) -- (lt,le,eq,ge,gt)
1808 primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
1810 ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
1812 = [(charPrimTy, (CharLtOp, CharLeOp, CharEqOp, CharGeOp, CharGtOp))
1813 ,(intPrimTy, (IntLtOp, IntLeOp, IntEqOp, IntGeOp, IntGtOp))
1814 ,(wordPrimTy, (WordLtOp, WordLeOp, WordEqOp, WordGeOp, WordGtOp))
1815 ,(addrPrimTy, (AddrLtOp, AddrLeOp, AddrEqOp, AddrGeOp, AddrGtOp))
1816 ,(floatPrimTy, (FloatLtOp, FloatLeOp, FloatEqOp, FloatGeOp, FloatGtOp))
1817 ,(doublePrimTy, (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
1819 box_con_tbl :: [(Type, RdrName)]
1821 [(charPrimTy, getRdrName charDataCon)
1822 ,(intPrimTy, getRdrName intDataCon)
1823 ,(wordPrimTy, wordDataCon_RDR)
1824 ,(floatPrimTy, getRdrName floatDataCon)
1825 ,(doublePrimTy, getRdrName doubleDataCon)
1828 assoc_ty_id :: String -- The class involved
1829 -> TyCon -- The tycon involved
1830 -> [(Type,a)] -- The table
1832 -> a -- The result of the lookup
1833 assoc_ty_id cls_str _ tbl ty
1834 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1835 text "for primitive type" <+> ppr ty)
1836 | otherwise = head res
1838 res = [id | (ty',id) <- tbl, ty `eqType` ty']
1840 -----------------------------------------------------------------------
1842 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1843 and_Expr a b = genOpApp a and_RDR b
1845 -----------------------------------------------------------------------
1847 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1848 eq_Expr tycon ty a b = genOpApp a eq_op b
1850 eq_op | not (isUnLiftedType ty) = eq_RDR
1851 | otherwise = primOpRdrName prim_eq
1852 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1856 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1857 untag_Expr _ [] expr = expr
1858 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1859 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1860 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1863 :: LHsExpr RdrName -> LHsExpr RdrName
1865 enum_from_then_to_Expr
1866 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1869 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1870 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1873 :: LHsExpr RdrName -> LHsExpr RdrName
1876 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1878 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1880 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1881 nested_compose_Expr [e] = parenify e
1882 nested_compose_Expr (e:es)
1883 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1885 -- impossible_Expr is used in case RHSs that should never happen.
1886 -- We generate these to keep the desugarer from complaining that they *might* happen!
1887 error_Expr :: String -> LHsExpr RdrName
1888 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
1890 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1891 -- method. It is currently only used by Enum.{succ,pred}
1892 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1893 illegal_Expr meth tp msg =
1894 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1896 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1897 -- to include the value of a_RDR in the error string.
1898 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1899 illegal_toEnum_tag tp maxtag =
1900 nlHsApp (nlHsVar error_RDR)
1901 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1902 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1903 (nlHsApp (nlHsApp (nlHsApp
1904 (nlHsVar showsPrec_RDR)
1908 (nlHsVar append_RDR)
1909 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1910 (nlHsApp (nlHsApp (nlHsApp
1911 (nlHsVar showsPrec_RDR)
1914 (nlHsLit (mkHsString ")"))))))
1916 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1917 parenify e@(L _ (HsVar _)) = e
1918 parenify e = mkHsPar e
1920 -- genOpApp wraps brackets round the operator application, so that the
1921 -- renamer won't subsequently try to re-associate it.
1922 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1923 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1927 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
1929 a_RDR = mkVarUnqual (fsLit "a")
1930 b_RDR = mkVarUnqual (fsLit "b")
1931 c_RDR = mkVarUnqual (fsLit "c")
1932 d_RDR = mkVarUnqual (fsLit "d")
1933 f_RDR = mkVarUnqual (fsLit "f")
1934 k_RDR = mkVarUnqual (fsLit "k")
1935 z_RDR = mkVarUnqual (fsLit "z")
1936 ah_RDR = mkVarUnqual (fsLit "a#")
1937 bh_RDR = mkVarUnqual (fsLit "b#")
1938 ch_RDR = mkVarUnqual (fsLit "c#")
1939 dh_RDR = mkVarUnqual (fsLit "d#")
1941 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1942 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1943 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1944 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1946 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1947 false_Expr, true_Expr :: LHsExpr RdrName
1948 a_Expr = nlHsVar a_RDR
1949 -- b_Expr = nlHsVar b_RDR
1950 c_Expr = nlHsVar c_RDR
1951 f_Expr = nlHsVar f_RDR
1952 z_Expr = nlHsVar z_RDR
1953 ltTag_Expr = nlHsVar ltTag_RDR
1954 eqTag_Expr = nlHsVar eqTag_RDR
1955 gtTag_Expr = nlHsVar gtTag_RDR
1956 false_Expr = nlHsVar false_RDR
1957 true_Expr = nlHsVar true_RDR
1959 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1960 a_Pat = nlVarPat a_RDR
1961 b_Pat = nlVarPat b_RDR
1962 c_Pat = nlVarPat c_RDR
1963 d_Pat = nlVarPat d_RDR
1964 f_Pat = nlVarPat f_RDR
1965 k_Pat = nlVarPat k_RDR
1966 z_Pat = nlVarPat z_RDR
1968 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1969 -- Generates Orig s RdrName, for the binding positions
1970 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1971 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1972 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1974 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1975 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1977 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1978 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1979 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1980 -- But: (a) that does not work well for standalone-deriving
1981 -- (b) an unqualified name is just fine, provided it can't clash with user code
1984 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1985 PrelNames, so PrelNames can't import PrimOp.
1988 primOpRdrName :: PrimOp -> RdrName
1989 primOpRdrName op = getRdrName (primOpId op)
1991 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
1992 tagToEnum_RDR :: RdrName
1993 minusInt_RDR = primOpRdrName IntSubOp
1994 eqInt_RDR = primOpRdrName IntEqOp
1995 ltInt_RDR = primOpRdrName IntLtOp
1996 geInt_RDR = primOpRdrName IntGeOp
1997 gtInt_RDR = primOpRdrName IntGtOp
1998 leInt_RDR = primOpRdrName IntLeOp
1999 tagToEnum_RDR = primOpRdrName TagToEnumOp
2001 error_RDR :: RdrName
2002 error_RDR = getRdrName eRROR_ID