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 )
62 import Data.List ( partition, intersperse )
66 type DerivAuxBinds = [DerivAuxBind]
68 data DerivAuxBind -- Please add these auxiliary top-level bindings
69 = GenCon2Tag TyCon -- The con2Tag for given TyCon
70 | GenTag2Con TyCon -- ...ditto tag2Con
71 | GenMaxTag TyCon -- ...and maxTag
72 -- All these generate ZERO-BASED tag operations
73 -- I.e first constructor has tag 0
75 -- Scrap your boilerplate
76 | MkDataCon DataCon -- For constructor C we get $cC :: Constr
77 | MkTyCon TyCon -- For tycon T we get $tT :: DataType
80 isDupAux :: DerivAuxBind -> DerivAuxBind -> Bool
81 isDupAux (GenCon2Tag tc1) (GenCon2Tag tc2) = tc1 == tc2
82 isDupAux (GenTag2Con tc1) (GenTag2Con tc2) = tc1 == tc2
83 isDupAux (GenMaxTag tc1) (GenMaxTag tc2) = tc1 == tc2
84 isDupAux (MkDataCon dc1) (MkDataCon dc2) = dc1 == dc2
85 isDupAux (MkTyCon tc1) (MkTyCon tc2) = tc1 == tc2
90 %************************************************************************
94 %************************************************************************
96 Here are the heuristics for the code we generate for @Eq@:
99 Let's assume we have a data type with some (possibly zero) nullary
100 data constructors and some ordinary, non-nullary ones (the rest,
101 also possibly zero of them). Here's an example, with both \tr{N}ullary
102 and \tr{O}rdinary data cons.
104 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
108 For the ordinary constructors (if any), we emit clauses to do The
112 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
113 (==) (O2 a1) (O2 a2) = a1 == a2
114 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
117 Note: if we're comparing unlifted things, e.g., if \tr{a1} and
118 \tr{a2} are \tr{Float#}s, then we have to generate
120 case (a1 `eqFloat#` a2) of
123 for that particular test.
126 If there are any nullary constructors, we emit a catch-all clause of
130 (==) a b = case (con2tag_Foo a) of { a# ->
131 case (con2tag_Foo b) of { b# ->
132 case (a# ==# b#) of {
137 If there aren't any nullary constructors, we emit a simpler
144 For the @(/=)@ method, we normally just use the default method.
146 If the type is an enumeration type, we could/may/should? generate
147 special code that calls @con2tag_Foo@, much like for @(==)@ shown
151 We thought about doing this: If we're also deriving @Ord@ for this
154 instance ... Eq (Foo ...) where
155 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
156 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
158 However, that requires that \tr{Ord <whatever>} was put in the context
159 for the instance decl, which it probably wasn't, so the decls
160 produced don't get through the typechecker.
165 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
166 gen_Eq_binds loc tycon
167 = (method_binds, aux_binds)
169 (nullary_cons, nonnullary_cons)
170 | isNewTyCon tycon = ([], tyConDataCons tycon)
171 | otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
173 no_nullary_cons = null nullary_cons
175 rest | no_nullary_cons
176 = case tyConSingleDataCon_maybe tycon of
178 Nothing -> -- if cons don't match, then False
179 [([nlWildPat, nlWildPat], false_Expr)]
180 | otherwise -- calc. and compare the tags
182 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
183 (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
185 aux_binds | no_nullary_cons = []
186 | otherwise = [GenCon2Tag tycon]
188 method_binds = listToBag [eq_bind, ne_bind]
189 eq_bind = mk_FunBind loc eq_RDR (map pats_etc nonnullary_cons ++ rest)
190 ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
191 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
193 ------------------------------------------------------------------
196 con1_pat = nlConVarPat data_con_RDR as_needed
197 con2_pat = nlConVarPat data_con_RDR bs_needed
199 data_con_RDR = getRdrName data_con
200 con_arity = length tys_needed
201 as_needed = take con_arity as_RDRs
202 bs_needed = take con_arity bs_RDRs
203 tys_needed = dataConOrigArgTys data_con
205 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
207 nested_eq_expr [] [] [] = true_Expr
208 nested_eq_expr tys as bs
209 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
211 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
214 %************************************************************************
218 %************************************************************************
220 Note [Generating Ord instances]
221 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
222 Suppose constructors are K1..Kn, and some are nullary.
223 The general form we generate is:
225 * Do case on first argument
234 If i = 1, 2, n-1, n, generate a single case.
237 K2 ... -> ...eq_rhs(K2)...
240 Otherwise do a tag compare against the bigger range
241 (because this is the one most likely to succeed)
242 rhs_3 case tag b of tb ->
245 K3 ... -> ...eq_rhs(K3)....
248 * To make eq_rhs(K), which knows that
251 we just want to compare (a1,b1) then (a2,b2) etc.
252 Take care on the last field to tail-call into comparing av,bv
254 * To make nullary_rhs generate this
255 case con2tag a of a# ->
259 Several special cases:
261 * Two or fewer nullary constructors: don't generate nullary_rhs
263 * Be careful about unlifted comparisons. When comparing unboxed
264 values we can't call the overloaded functions.
265 See function unliftedOrdOp
267 Note [Do not rely on compare]
268 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
269 It's a bad idea to define only 'compare', and build the other binary
270 comparisions on top of it; see Trac #2130, #4019. Reason: we don't
271 want to laboriously make a three-way comparison, only to extract a
272 binary result, something like this:
273 (>) (I# x) (I# y) = case <# x y of
275 False -> case ==# x y of
279 So for sufficiently small types (few constructors, or all nullary)
280 we generate all methods; for large ones we just use 'compare'.
283 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
286 ordMethRdr :: OrdOp -> RdrName
289 OrdCompare -> compare_RDR
296 ltResult :: OrdOp -> LHsExpr RdrName
297 -- Knowing a<b, what is the result for a `op` b?
298 ltResult OrdCompare = ltTag_Expr
299 ltResult OrdLT = true_Expr
300 ltResult OrdLE = true_Expr
301 ltResult OrdGE = false_Expr
302 ltResult OrdGT = false_Expr
305 eqResult :: OrdOp -> LHsExpr RdrName
306 -- Knowing a=b, what is the result for a `op` b?
307 eqResult OrdCompare = eqTag_Expr
308 eqResult OrdLT = false_Expr
309 eqResult OrdLE = true_Expr
310 eqResult OrdGE = true_Expr
311 eqResult OrdGT = false_Expr
314 gtResult :: OrdOp -> LHsExpr RdrName
315 -- Knowing a>b, what is the result for a `op` b?
316 gtResult OrdCompare = gtTag_Expr
317 gtResult OrdLT = false_Expr
318 gtResult OrdLE = false_Expr
319 gtResult OrdGE = true_Expr
320 gtResult OrdGT = true_Expr
323 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
324 gen_Ord_binds loc tycon
325 | null tycon_data_cons -- No data-cons => invoke bale-out case
326 = (unitBag $ mk_FunBind loc compare_RDR [], [])
328 = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
330 aux_binds | single_con_type = []
331 | otherwise = [GenCon2Tag tycon]
333 -- Note [Do not rely on compare]
334 other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
335 || null non_nullary_cons -- Or it's an enumeration
336 = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
340 get_tag con = dataConTag con - fIRST_TAG
341 -- We want *zero-based* tags, because that's what
342 -- con2Tag returns (generated by untag_Expr)!
344 tycon_data_cons = tyConDataCons tycon
345 single_con_type = isSingleton tycon_data_cons
346 (first_con : _) = tycon_data_cons
347 (last_con : _) = reverse tycon_data_cons
348 first_tag = get_tag first_con
349 last_tag = get_tag last_con
351 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
354 mkOrdOp :: OrdOp -> LHsBind RdrName
355 -- Returns a binding op a b = ... compares a and b according to op ....
356 mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
358 mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
359 mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
360 | length nullary_cons <= 2 -- Two nullary or fewer, so use cases
361 = nlHsCase (nlHsVar a_RDR) $
362 map (mkOrdOpAlt op) tycon_data_cons
363 -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
364 -- C2 x -> case b of C2 x -> ....comopare x.... }
366 | null non_nullary_cons -- All nullary, so go straight to comparing tags
369 | otherwise -- Mixed nullary and non-nullary
370 = nlHsCase (nlHsVar a_RDR) $
371 (map (mkOrdOpAlt op) non_nullary_cons
372 ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
375 mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName
376 -- Make the alternative (Ki a1 a2 .. av ->
377 mkOrdOpAlt op data_con
378 = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
380 as_needed = take (dataConSourceArity data_con) as_RDRs
381 data_con_RDR = getRdrName data_con
383 mkInnerRhs op data_con
385 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
388 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
389 , mkSimpleHsAlt nlWildPat (ltResult op) ]
391 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
392 , mkSimpleHsAlt nlWildPat (gtResult op) ]
394 | tag == first_tag + 1
395 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
396 , mkInnerEqAlt op data_con
397 , mkSimpleHsAlt nlWildPat (ltResult op) ]
398 | tag == last_tag - 1
399 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
400 , mkInnerEqAlt op data_con
401 , mkSimpleHsAlt nlWildPat (gtResult op) ]
403 | tag > last_tag `div` 2 -- lower range is larger
404 = untag_Expr tycon [(b_RDR, bh_RDR)] $
405 nlHsIf (genOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
406 (gtResult op) $ -- Definitely GT
407 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
408 , mkSimpleHsAlt nlWildPat (ltResult op) ]
410 | otherwise -- upper range is larger
411 = untag_Expr tycon [(b_RDR, bh_RDR)] $
412 nlHsIf (genOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
413 (ltResult op) $ -- Definitely LT
414 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
415 , mkSimpleHsAlt nlWildPat (gtResult op) ]
417 tag = get_tag data_con
418 tag_lit = noLoc (HsLit (HsIntPrim (toInteger tag)))
420 mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName
421 -- First argument 'a' known to be built with K
422 -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
423 mkInnerEqAlt op data_con
424 = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
425 mkCompareFields tycon op (dataConOrigArgTys data_con)
427 data_con_RDR = getRdrName data_con
428 bs_needed = take (dataConSourceArity data_con) bs_RDRs
430 mkTagCmp :: OrdOp -> LHsExpr RdrName
431 -- Both constructors known to be nullary
432 -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
433 mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
434 unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
436 mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
437 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
438 -- where the ai,bi have the given types
439 mkCompareFields tycon op tys
440 = go tys as_RDRs bs_RDRs
442 go [] _ _ = eqResult op
444 | isUnLiftedType ty = unliftedOrdOp tycon ty op a b
445 | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
446 go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
450 go _ _ _ = panic "mkCompareFields"
452 -- (mk_compare ty a b) generates
453 -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
454 -- but with suitable special cases for
455 mk_compare ty a b lt eq gt
457 = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
459 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
460 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
461 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
462 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
466 (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
468 unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
469 unliftedOrdOp tycon ty op a b
471 OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
472 ltTag_Expr eqTag_Expr gtTag_Expr
478 (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
479 wrap prim_op = genOpApp a_expr (primOpRdrName prim_op) b_expr
483 unliftedCompare :: PrimOp -> PrimOp
484 -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare
485 -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results
487 -- Return (if a < b then lt else if a == b then eq else gt)
488 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
489 = nlHsIf (genOpApp a_expr (primOpRdrName lt_op) b_expr) lt $
490 -- Test (<) first, not (==), becuase the latter
491 -- is true less often, so putting it first would
492 -- mean more tests (dynamically)
493 nlHsIf (genOpApp a_expr (primOpRdrName eq_op) b_expr) eq gt
495 nlConWildPat :: DataCon -> LPat RdrName
496 -- The pattern (K {})
497 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
498 (RecCon (HsRecFields { rec_flds = []
499 , rec_dotdot = Nothing })))
504 %************************************************************************
508 %************************************************************************
510 @Enum@ can only be derived for enumeration types. For a type
512 data Foo ... = N1 | N2 | ... | Nn
515 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
516 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
519 instance ... Enum (Foo ...) where
520 succ x = toEnum (1 + fromEnum x)
521 pred x = toEnum (fromEnum x - 1)
523 toEnum i = tag2con_Foo i
525 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
529 = case con2tag_Foo a of
530 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
533 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
537 = case con2tag_Foo a of { a# ->
538 case con2tag_Foo b of { b# ->
539 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
543 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
546 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
547 gen_Enum_binds loc tycon
548 = (method_binds, aux_binds)
550 method_binds = listToBag [
558 aux_binds = [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon]
560 occ_nm = getOccString tycon
563 = mk_easy_FunBind loc succ_RDR [a_Pat] $
564 untag_Expr tycon [(a_RDR, ah_RDR)] $
565 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
566 nlHsVarApps intDataCon_RDR [ah_RDR]])
567 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
568 (nlHsApp (nlHsVar (tag2con_RDR tycon))
569 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
573 = mk_easy_FunBind loc pred_RDR [a_Pat] $
574 untag_Expr tycon [(a_RDR, ah_RDR)] $
575 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
576 nlHsVarApps intDataCon_RDR [ah_RDR]])
577 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
578 (nlHsApp (nlHsVar (tag2con_RDR tycon))
579 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
580 nlHsLit (HsInt (-1))]))
583 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
584 nlHsIf (nlHsApps and_RDR
585 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
586 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
587 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
588 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
591 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
592 untag_Expr tycon [(a_RDR, ah_RDR)] $
594 [nlHsVar (tag2con_RDR tycon),
595 nlHsPar (enum_from_to_Expr
596 (nlHsVarApps intDataCon_RDR [ah_RDR])
597 (nlHsVar (maxtag_RDR tycon)))]
600 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
601 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
602 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
603 nlHsPar (enum_from_then_to_Expr
604 (nlHsVarApps intDataCon_RDR [ah_RDR])
605 (nlHsVarApps intDataCon_RDR [bh_RDR])
606 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
607 nlHsVarApps intDataCon_RDR [bh_RDR]])
609 (nlHsVar (maxtag_RDR tycon))
613 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
614 untag_Expr tycon [(a_RDR, ah_RDR)] $
615 (nlHsVarApps intDataCon_RDR [ah_RDR])
618 %************************************************************************
622 %************************************************************************
625 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
626 gen_Bounded_binds loc tycon
627 | isEnumerationTyCon tycon
628 = (listToBag [ min_bound_enum, max_bound_enum ], [])
630 = ASSERT(isSingleton data_cons)
631 (listToBag [ min_bound_1con, max_bound_1con ], [])
633 data_cons = tyConDataCons tycon
635 ----- enum-flavored: ---------------------------
636 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
637 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
639 data_con_1 = head data_cons
640 data_con_N = last data_cons
641 data_con_1_RDR = getRdrName data_con_1
642 data_con_N_RDR = getRdrName data_con_N
644 ----- single-constructor-flavored: -------------
645 arity = dataConSourceArity data_con_1
647 min_bound_1con = mkHsVarBind loc minBound_RDR $
648 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
649 max_bound_1con = mkHsVarBind loc maxBound_RDR $
650 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
653 %************************************************************************
657 %************************************************************************
659 Deriving @Ix@ is only possible for enumeration types and
660 single-constructor types. We deal with them in turn.
662 For an enumeration type, e.g.,
664 data Foo ... = N1 | N2 | ... | Nn
666 things go not too differently from @Enum@:
668 instance ... Ix (Foo ...) where
670 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
674 = case (con2tag_Foo a) of { a# ->
675 case (con2tag_Foo b) of { b# ->
676 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
679 -- Generate code for unsafeIndex, becuase using index leads
680 -- to lots of redundant range tests
681 unsafeIndex c@(a, b) d
682 = case (con2tag_Foo d -# con2tag_Foo a) of
687 p_tag = con2tag_Foo c
689 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
693 = case (con2tag_Foo a) of { a_tag ->
694 case (con2tag_Foo b) of { b_tag ->
695 case (con2tag_Foo c) of { c_tag ->
696 if (c_tag >=# a_tag) then
702 (modulo suitable case-ification to handle the unlifted tags)
704 For a single-constructor type (NB: this includes all tuples), e.g.,
706 data Foo ... = MkFoo a b Int Double c c
708 we follow the scheme given in Figure~19 of the Haskell~1.2 report
712 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
714 gen_Ix_binds loc tycon
715 | isEnumerationTyCon tycon
716 = (enum_ixes, [GenCon2Tag tycon, GenTag2Con tycon, GenMaxTag tycon])
718 = (single_con_ixes, [GenCon2Tag tycon])
720 --------------------------------------------------------------
721 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
724 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
725 untag_Expr tycon [(a_RDR, ah_RDR)] $
726 untag_Expr tycon [(b_RDR, bh_RDR)] $
727 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
728 nlHsPar (enum_from_to_Expr
729 (nlHsVarApps intDataCon_RDR [ah_RDR])
730 (nlHsVarApps intDataCon_RDR [bh_RDR]))
733 = mk_easy_FunBind loc unsafeIndex_RDR
734 [noLoc (AsPat (noLoc c_RDR)
735 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
737 untag_Expr tycon [(a_RDR, ah_RDR)] (
738 untag_Expr tycon [(d_RDR, dh_RDR)] (
740 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
743 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
744 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
749 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
750 untag_Expr tycon [(a_RDR, ah_RDR)] (
751 untag_Expr tycon [(b_RDR, bh_RDR)] (
752 untag_Expr tycon [(c_RDR, ch_RDR)] (
753 nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
754 (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
759 --------------------------------------------------------------
761 = listToBag [single_con_range, single_con_index, single_con_inRange]
764 = case tyConSingleDataCon_maybe tycon of -- just checking...
765 Nothing -> panic "get_Ix_binds"
768 con_arity = dataConSourceArity data_con
769 data_con_RDR = getRdrName data_con
771 as_needed = take con_arity as_RDRs
772 bs_needed = take con_arity bs_RDRs
773 cs_needed = take con_arity cs_RDRs
775 con_pat xs = nlConVarPat data_con_RDR xs
776 con_expr = nlHsVarApps data_con_RDR cs_needed
778 --------------------------------------------------------------
780 = mk_easy_FunBind loc range_RDR
781 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
782 noLoc (mkHsComp ListComp stmts con_expr)
784 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
786 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
787 (nlHsApp (nlHsVar range_RDR)
788 (mkLHsVarTuple [a,b]))
792 = mk_easy_FunBind loc unsafeIndex_RDR
793 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
795 -- We need to reverse the order we consider the components in
797 -- range (l,u) !! index (l,u) i == i -- when i is in range
798 -- (from http://haskell.org/onlinereport/ix.html) holds.
799 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
801 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
802 mk_index [] = nlHsIntLit 0
803 mk_index [(l,u,i)] = mk_one l u i
804 mk_index ((l,u,i) : rest)
809 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
810 (mkLHsVarTuple [l,u]))
811 ) times_RDR (mk_index rest)
814 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
818 = mk_easy_FunBind loc inRange_RDR
819 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
821 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
823 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
826 %************************************************************************
830 %************************************************************************
840 instance Read T where
844 do x <- ReadP.step Read.readPrec
845 Symbol "%%" <- Lex.lex
846 y <- ReadP.step Read.readPrec
850 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
851 -- Record construction binds even more tightly than application
852 do Ident "T1" <- Lex.lex
854 Ident "f1" <- Lex.lex
856 x <- ReadP.reset Read.readPrec
858 return (T1 { f1 = x }))
861 do Ident "T2" <- Lex.lexP
862 x <- ReadP.step Read.readPrec
866 readListPrec = readListPrecDefault
867 readList = readListDefault
871 gen_Read_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
873 gen_Read_binds get_fixity loc tycon
874 = (listToBag [read_prec, default_readlist, default_readlistprec], [])
876 -----------------------------------------------------------------------
878 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
881 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
882 -----------------------------------------------------------------------
884 data_cons = tyConDataCons tycon
885 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
887 read_prec = mkHsVarBind loc readPrec_RDR
888 (nlHsApp (nlHsVar parens_RDR) read_cons)
890 read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
891 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
894 = case nullary_cons of
896 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
897 _ -> [nlHsApp (nlHsVar choose_RDR)
898 (nlList (map mk_pair nullary_cons))]
899 -- NB For operators the parens around (:=:) are matched by the
900 -- enclosing "parens" call, so here we must match the naked
903 match_con con | isSym con_str = [symbol_pat con_str]
904 | otherwise = ident_h_pat con_str
906 con_str = data_con_str con
907 -- For nullary constructors we must match Ident s for normal constrs
908 -- and Symbol s for operators
910 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
913 read_non_nullary_con data_con
914 | is_infix = mk_parser infix_prec infix_stmts body
915 | is_record = mk_parser record_prec record_stmts body
916 -- Using these two lines instead allows the derived
917 -- read for infix and record bindings to read the prefix form
918 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
919 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
920 | otherwise = prefix_parser
922 body = result_expr data_con as_needed
923 con_str = data_con_str data_con
925 prefix_parser = mk_parser prefix_prec prefix_stmts body
928 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
929 | otherwise = ident_h_pat con_str
932 | isSym con_str = [symbol_pat con_str]
933 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
935 prefix_stmts -- T a b c
936 = read_prefix_con ++ read_args
938 infix_stmts -- a %% b, or a `T` b
943 record_stmts -- T { f1 = a, f2 = b }
946 ++ concat (intersperse [read_punc ","] field_stmts)
949 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
951 con_arity = dataConSourceArity data_con
952 labels = dataConFieldLabels data_con
953 dc_nm = getName data_con
954 is_infix = dataConIsInfix data_con
955 is_record = length labels > 0
956 as_needed = take con_arity as_RDRs
957 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
958 (read_a1:read_a2:_) = read_args
960 prefix_prec = appPrecedence
961 infix_prec = getPrecedence get_fixity dc_nm
962 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
963 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
965 ------------------------------------------------------------------------
967 ------------------------------------------------------------------------
968 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
969 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
970 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
971 bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP
972 con_app con as = nlHsVarApps (getRdrName con) as -- con as
973 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
975 punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c'
977 -- For constructors and field labels ending in '#', we hackily
978 -- let the lexer generate two tokens, and look for both in sequence
979 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
980 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
981 | otherwise = [ ident_pat s ]
983 ident_pat s = bindLex $ nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" <- lexP
984 symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" <- lexP
986 data_con_str con = occNameString (getOccName con)
988 read_punc c = bindLex (punc_pat c)
989 read_arg a ty = ASSERT( not (isUnLiftedType ty) )
990 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
992 read_field lbl a = read_lbl lbl ++
994 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
996 -- When reading field labels we might encounter
1001 read_lbl lbl | isSym lbl_str
1002 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1004 = ident_h_pat lbl_str
1006 lbl_str = occNameString (getOccName lbl)
1010 %************************************************************************
1014 %************************************************************************
1020 data Tree a = Leaf a | Tree a :^: Tree a
1022 instance (Show a) => Show (Tree a) where
1024 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1026 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1028 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1030 showStr = showsPrec (up_prec+1) u .
1031 showString " :^: " .
1032 showsPrec (up_prec+1) v
1033 -- Note: right-associativity of :^: ignored
1035 up_prec = 5 -- Precedence of :^:
1036 app_prec = 10 -- Application has precedence one more than
1037 -- the most tightly-binding operator
1040 gen_Show_binds :: FixityEnv -> SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1042 gen_Show_binds get_fixity loc tycon
1043 = (listToBag [shows_prec, show_list], [])
1045 -----------------------------------------------------------------------
1046 show_list = mkHsVarBind loc showList_RDR
1047 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1048 -----------------------------------------------------------------------
1049 data_cons = tyConDataCons tycon
1050 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
1053 | nullary_con = -- skip the showParen junk...
1054 ASSERT(null bs_needed)
1055 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1058 showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one))))
1059 (nlHsPar (nested_compose_Expr show_thingies)))
1061 data_con_RDR = getRdrName data_con
1062 con_arity = dataConSourceArity data_con
1063 bs_needed = take con_arity bs_RDRs
1064 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1065 con_pat = nlConVarPat data_con_RDR bs_needed
1066 nullary_con = con_arity == 0
1067 labels = dataConFieldLabels data_con
1068 lab_fields = length labels
1069 record_syntax = lab_fields > 0
1071 dc_nm = getName data_con
1072 dc_occ_nm = getOccName data_con
1073 con_str = occNameString dc_occ_nm
1074 op_con_str = wrapOpParens con_str
1075 backquote_str = wrapOpBackquotes con_str
1078 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1079 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1080 show_record_args ++ [mk_showString_app "}"]
1081 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1083 show_label l = mk_showString_app (nm ++ " = ")
1084 -- Note the spaces around the "=" sign. If we don't have them
1085 -- then we get Foo { x=-1 } and the "=-" parses as a single
1086 -- lexeme. Only the space after the '=' is necessary, but
1087 -- it seems tidier to have them both sides.
1089 occ_nm = getOccName l
1090 nm = wrapOpParens (occNameString occ_nm)
1092 show_args = zipWith show_arg bs_needed arg_tys
1093 (show_arg1:show_arg2:_) = show_args
1094 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1096 -- Assumption for record syntax: no of fields == no of labelled fields
1097 -- (and in same order)
1098 show_record_args = concat $
1099 intersperse [mk_showString_app ", "] $
1100 [ [show_label lbl, arg]
1101 | (lbl,arg) <- zipEqual "gen_Show_binds"
1104 -- Generates (showsPrec p x) for argument x, but it also boxes
1105 -- the argument first if necessary. Note that this prints unboxed
1106 -- things without any '#' decorations; could change that if need be
1107 show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec),
1108 box_if_necy "Show" tycon (nlHsVar b) arg_ty]
1111 is_infix = dataConIsInfix data_con
1112 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1113 arg_prec | record_syntax = 0 -- Record fields don't need parens
1114 | otherwise = con_prec_plus_one
1116 wrapOpParens :: String -> String
1117 wrapOpParens s | isSym s = '(' : s ++ ")"
1120 wrapOpBackquotes :: String -> String
1121 wrapOpBackquotes s | isSym s = s
1122 | otherwise = '`' : s ++ "`"
1124 isSym :: String -> Bool
1126 isSym (c : _) = startsVarSym c || startsConSym c
1128 mk_showString_app :: String -> LHsExpr RdrName
1129 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1133 getPrec :: Bool -> FixityEnv -> Name -> Integer
1134 getPrec is_infix get_fixity nm
1135 | not is_infix = appPrecedence
1136 | otherwise = getPrecedence get_fixity nm
1138 appPrecedence :: Integer
1139 appPrecedence = fromIntegral maxPrecedence + 1
1140 -- One more than the precedence of the most
1141 -- tightly-binding operator
1143 getPrecedence :: FixityEnv -> Name -> Integer
1144 getPrecedence get_fixity nm
1145 = case lookupFixity get_fixity nm of
1146 Fixity x _assoc -> fromIntegral x
1147 -- NB: the Report says that associativity is not taken
1148 -- into account for either Read or Show; hence we
1149 -- ignore associativity here
1153 %************************************************************************
1155 \subsection{Typeable}
1157 %************************************************************************
1165 instance Typeable2 T where
1166 typeOf2 _ = mkTyConApp (mkTyConRep "T") []
1168 We are passed the Typeable2 class as well as T
1171 gen_Typeable_binds :: SrcSpan -> TyCon -> LHsBinds RdrName
1172 gen_Typeable_binds loc tycon
1175 (mk_typeOf_RDR tycon) -- Name of appropriate type0f function
1177 (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []])
1179 tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1181 mk_typeOf_RDR :: TyCon -> RdrName
1182 -- Use the arity of the TyCon to make the right typeOfn function
1183 mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix))
1185 arity = tyConArity tycon
1186 suffix | arity == 0 = ""
1187 | otherwise = show arity
1192 %************************************************************************
1196 %************************************************************************
1200 data T a b = T1 a b | T2
1204 $cT1 = mkDataCon $dT "T1" Prefix
1205 $cT2 = mkDataCon $dT "T2" Prefix
1206 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1207 -- the [] is for field labels.
1209 instance (Data a, Data b) => Data (T a b) where
1210 gfoldl k z (T1 a b) = z T `k` a `k` b
1211 gfoldl k z T2 = z T2
1212 -- ToDo: add gmapT,Q,M, gfoldr
1214 gunfold k z c = case conIndex c of
1215 I# 1# -> k (k (z T1))
1218 toConstr (T1 _ _) = $cT1
1223 dataCast1 = gcast1 -- If T :: * -> *
1224 dataCast2 = gcast2 -- if T :: * -> * -> *
1228 gen_Data_binds :: SrcSpan
1230 -> (LHsBinds RdrName, -- The method bindings
1231 DerivAuxBinds) -- Auxiliary bindings
1232 gen_Data_binds loc tycon
1233 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1234 `unionBags` gcast_binds,
1235 -- Auxiliary definitions: the data type and constructors
1236 MkTyCon tycon : map MkDataCon data_cons)
1238 data_cons = tyConDataCons tycon
1239 n_cons = length data_cons
1240 one_constr = n_cons == 1
1243 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1246 = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1247 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1250 con_name = getRdrName con
1251 as_needed = take (dataConSourceArity con) as_RDRs
1252 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1254 ------------ gunfold
1255 gunfold_bind = mk_FunBind loc
1257 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1261 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1262 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1263 (map gunfold_alt data_cons)
1265 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1266 mk_unfold_rhs dc = foldr nlHsApp
1267 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1268 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1270 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1271 -- redundant test, and annoying warning
1272 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1273 | otherwise = nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger tag))]
1277 ------------ toConstr
1278 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1279 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1281 ------------ dataTypeOf
1282 dataTypeOf_bind = mk_easy_FunBind
1286 (nlHsVar (mk_data_type_name tycon))
1288 ------------ gcast1/2
1289 tycon_kind = tyConKind tycon
1290 gcast_binds | tycon_kind `eqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1291 | tycon_kind `eqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1292 | otherwise = emptyBag
1293 mk_gcast dataCast_RDR gcast_RDR
1294 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1295 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1298 kind1, kind2 :: Kind
1299 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1300 kind2 = liftedTypeKind `mkArrowKind` kind1
1302 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1303 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1304 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1305 constr_RDR, dataType_RDR :: RdrName
1306 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1307 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1308 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1309 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1310 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1311 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1312 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1313 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1314 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1315 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1316 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1317 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1318 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1319 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1320 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1325 %************************************************************************
1329 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1332 %************************************************************************
1336 data T a = T1 Int a | T2 (T a)
1338 We generate the instance:
1340 instance Functor T where
1341 fmap f (T1 b1 a) = T1 b1 (f a)
1342 fmap f (T2 ta) = T2 (fmap f ta)
1344 Notice that we don't simply apply 'fmap' to the constructor arguments.
1346 - Do nothing to an argument whose type doesn't mention 'a'
1347 - Apply 'f' to an argument of type 'a'
1348 - Apply 'fmap f' to other arguments
1349 That's why we have to recurse deeply into the constructor argument types,
1350 rather than just one level, as we typically do.
1352 What about types with more than one type parameter? In general, we only
1353 derive Functor for the last position:
1355 data S a b = S1 [b] | S2 (a, T a b)
1356 instance Functor (S a) where
1357 fmap f (S1 bs) = S1 (fmap f bs)
1358 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1360 However, we have special cases for
1364 More formally, we write the derivation of fmap code over type variable
1365 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1368 instance Functor T where
1369 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1370 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1372 $(fmap 'a 'b) x = x -- when b does not contain a
1373 $(fmap 'a 'a) x = f x
1374 $(fmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1375 $(fmap 'a '(T b1 b2)) x = fmap $(fmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1376 $(fmap 'a '(b -> c)) x = \b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1378 For functions, the type parameter 'a can occur in a contravariant position,
1379 which means we need to derive a function like:
1381 cofmap :: (a -> b) -> (f b -> f a)
1383 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1385 $(cofmap 'a 'b) x = x -- when b does not contain a
1386 $(cofmap 'a 'a) x = error "type variable in contravariant position"
1387 $(cofmap 'a '(b1,b2)) x = case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1388 $(cofmap 'a '[b]) x = map $(cofmap 'a 'b) x
1389 $(cofmap 'a '(T b1 b2)) x = fmap $(cofmap 'a 'b2) x -- when a only occurs in the last parameter, b2
1390 $(cofmap 'a '(b -> c)) x = \b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1393 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1394 gen_Functor_binds loc tycon
1395 = (unitBag fmap_bind, [])
1397 data_cons = tyConDataCons tycon
1398 fmap_bind = L loc $ mkRdrFunBind (L loc fmap_RDR) eqns
1400 fmap_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1402 parts = foldDataConArgs ft_fmap con
1404 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1405 (error_Expr "Void fmap")]
1406 | otherwise = map fmap_eqn data_cons
1408 ft_fmap :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1409 -- Tricky higher order type; I can't say I fully understand this code :-(
1410 ft_fmap = FT { ft_triv = \x -> return x -- fmap f x = x
1411 , ft_var = \x -> return (nlHsApp f_Expr x) -- fmap f x = f x
1412 , ft_fun = \g h x -> mkSimpleLam (\b -> h =<< (nlHsApp x `fmap` g b))
1413 -- fmap f x = \b -> h (x (g b))
1414 , ft_tup = mkSimpleTupleCase match_for_con -- fmap f x = case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1415 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- fmap f x = fmap g x
1416 return $ nlHsApps fmap_RDR [gg,x]
1417 , ft_forall = \_ g x -> g x
1418 , ft_bad_app = panic "in other argument"
1419 , ft_co_var = panic "contravariant" }
1421 match_for_con = mkSimpleConMatch $
1422 \con_name xsM -> do xs <- sequence xsM
1423 return (nlHsApps con_name xs) -- Con (g1 v1) (g2 v2) ..
1426 Utility functions related to Functor deriving.
1428 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1429 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1432 -- Generic traversal for Functor deriving
1433 data FFoldType a -- Describes how to fold over a Type in a functor like way
1434 = FT { ft_triv :: a -- Does not contain variable
1435 , ft_var :: a -- The variable itself
1436 , ft_co_var :: a -- The variable itself, contravariantly
1437 , ft_fun :: a -> a -> a -- Function type
1438 , ft_tup :: Boxity -> [a] -> a -- Tuple type
1439 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1440 , ft_bad_app :: a -- Type app, variable other than in last argument
1441 , ft_forall :: TcTyVar -> a -> a -- Forall type
1444 functorLikeTraverse :: TyVar -- ^ Variable to look for
1445 -> FFoldType a -- ^ How to fold
1446 -> Type -- ^ Type to process
1448 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1449 , ft_co_var = caseCoVar, ft_fun = caseFun
1450 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1451 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1454 where -- go returns (result of type a, does type contain var)
1455 go co ty | Just ty' <- coreView ty = go co ty'
1456 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1457 go co (FunTy (PredTy _) b) = go co b
1458 go co (FunTy x y) | xc || yc = (caseFun xr yr,True)
1459 where (xr,xc) = go (not co) x
1461 go co (AppTy x y) | xc = (caseWrongArg, True)
1462 | yc = (caseTyApp x yr, True)
1463 where (_, xc) = go co x
1465 go co ty@(TyConApp con args)
1466 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
1467 -- At this point we know that xrs, xcs is not empty,
1468 -- and at least one xr is True
1469 | isTupleTyCon con = (caseTuple (tupleTyConBoxity con) xrs, True)
1470 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
1471 | otherwise = -- T (..no var..) ty
1472 (caseTyApp (fst (splitAppTy ty)) (last xrs), True)
1473 where (xrs,xcs) = unzip (map (go co) args)
1474 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1475 where (xr,xc) = go co x
1476 go _ _ = (caseTrivial,False)
1478 -- Return all syntactic subterms of ty that contain var somewhere
1479 -- These are the things that should appear in instance constraints
1480 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1481 deepSubtypesContaining tv
1482 = functorLikeTraverse tv
1485 , ft_fun = (++), ft_tup = \_ xs -> concat xs
1487 , ft_bad_app = panic "in other argument"
1488 , ft_co_var = panic "contravariant"
1489 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1492 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1493 -- Fold over the arguments of the datacon
1494 foldDataConArgs ft con
1495 = map (functorLikeTraverse tv ft) (dataConOrigArgTys con)
1497 tv = last (dataConUnivTyVars con)
1498 -- Argument to derive for, 'a in the above description
1499 -- The validity checks have ensured that con is
1500 -- a vanilla data constructor
1502 -- Make a HsLam using a fresh variable from a State monad
1503 mkSimpleLam :: (LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1504 -- (mkSimpleLam fn) returns (\x. fn(x))
1505 mkSimpleLam lam = do
1508 body <- lam (nlHsVar n)
1509 return (mkHsLam [nlVarPat n] body)
1511 mkSimpleLam2 :: (LHsExpr id -> LHsExpr id -> State [id] (LHsExpr id)) -> State [id] (LHsExpr id)
1512 mkSimpleLam2 lam = do
1513 (n1:n2:names) <- get
1515 body <- lam (nlHsVar n1) (nlHsVar n2)
1516 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1518 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1519 mkSimpleConMatch :: Monad m => (RdrName -> [a] -> m (LHsExpr RdrName)) -> [LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName)
1520 mkSimpleConMatch fold extra_pats con insides = do
1521 let con_name = getRdrName con
1522 let vars_needed = takeList insides as_RDRs
1523 let pat = nlConVarPat con_name vars_needed
1524 rhs <- fold con_name (zipWith ($) insides (map nlHsVar vars_needed))
1525 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1527 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1528 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [LHsExpr RdrName -> a] -> m (LMatch RdrName))
1529 -> Boxity -> [LHsExpr RdrName -> a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1530 mkSimpleTupleCase match_for_con boxity insides x = do
1531 let con = tupleCon boxity (length insides)
1532 match <- match_for_con [] con insides
1533 return $ nlHsCase x [match]
1537 %************************************************************************
1541 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1544 %************************************************************************
1546 Deriving Foldable instances works the same way as Functor instances,
1547 only Foldable instances are not possible for function types at all.
1548 Here the derived instance for the type T above is:
1550 instance Foldable T where
1551 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1555 $(foldr 'a 'b) x z = z -- when b does not contain a
1556 $(foldr 'a 'a) x z = f x z
1557 $(foldr 'a '(b1,b2)) x z = case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1558 $(foldr 'a '(T b1 b2)) x z = foldr $(foldr 'a 'b2) x z -- when a only occurs in the last parameter, b2
1560 Note that the arguments to the real foldr function are the wrong way around,
1561 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1564 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1565 gen_Foldable_binds loc tycon
1566 = (unitBag foldr_bind, [])
1568 data_cons = tyConDataCons tycon
1570 foldr_bind = L loc $ mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1571 eqns = map foldr_eqn data_cons
1572 foldr_eqn con = evalState (match_for_con z_Expr [f_Pat,z_Pat] con parts) bs_RDRs
1574 parts = foldDataConArgs ft_foldr con
1576 ft_foldr :: FFoldType (LHsExpr RdrName -> LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1577 ft_foldr = FT { ft_triv = \_ z -> return z -- foldr f z x = z
1578 , ft_var = \x z -> return (nlHsApps f_RDR [x,z]) -- foldr f z x = f x z
1579 , ft_tup = \b gs x z -> mkSimpleTupleCase (match_for_con z) b gs x
1580 , ft_ty_app = \_ g x z -> do gg <- mkSimpleLam2 g -- foldr f z x = foldr (\xx zz -> g xx zz) z x
1581 return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1582 , ft_forall = \_ g x z -> g x z
1583 , ft_co_var = panic "covariant"
1584 , ft_fun = panic "function"
1585 , ft_bad_app = panic "in other argument" }
1587 match_for_con z = mkSimpleConMatch (\_con_name -> foldrM ($) z) -- g1 v1 (g2 v2 (.. z))
1591 %************************************************************************
1593 Traversable instances
1595 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1597 %************************************************************************
1599 Again, Traversable is much like Functor and Foldable.
1603 $(traverse 'a 'b) x = pure x -- when b does not contain a
1604 $(traverse 'a 'a) x = f x
1605 $(traverse 'a '(b1,b2)) x = case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1606 $(traverse 'a '(T b1 b2)) x = traverse $(traverse 'a 'b2) x -- when a only occurs in the last parameter, b2
1608 Note that the generated code is not as efficient as it could be. For instance:
1610 data T a = T Int a deriving Traversable
1612 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1613 instead of: traverse f (T x y) = T x <$> f y
1616 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds)
1617 gen_Traversable_binds loc tycon
1618 = (unitBag traverse_bind, [])
1620 data_cons = tyConDataCons tycon
1622 traverse_bind = L loc $ mkRdrFunBind (L loc traverse_RDR) eqns
1623 eqns = map traverse_eqn data_cons
1624 traverse_eqn con = evalState (match_for_con [f_Pat] con parts) bs_RDRs
1626 parts = foldDataConArgs ft_trav con
1629 ft_trav :: FFoldType (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1630 ft_trav = FT { ft_triv = \x -> return (nlHsApps pure_RDR [x]) -- traverse f x = pure x
1631 , ft_var = \x -> return (nlHsApps f_RDR [x]) -- travese f x = f x
1632 , ft_tup = mkSimpleTupleCase match_for_con -- travese f x z = case x of (a1,a2,..) ->
1633 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1634 , ft_ty_app = \_ g x -> do gg <- mkSimpleLam g -- travese f x = travese (\xx -> g xx) x
1635 return $ nlHsApps traverse_RDR [gg,x]
1636 , ft_forall = \_ g x -> g x
1637 , ft_co_var = panic "covariant"
1638 , ft_fun = panic "function"
1639 , ft_bad_app = panic "in other argument" }
1641 match_for_con = mkSimpleConMatch $
1642 \con_name xsM -> do xs <- sequence xsM
1643 return (mkApCon (nlHsVar con_name) xs)
1645 -- ((Con <$> x1) <*> x2) <*> ..
1646 mkApCon con [] = nlHsApps pure_RDR [con]
1647 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1648 where appAp x y = nlHsApps ap_RDR [x,y]
1653 %************************************************************************
1655 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
1657 %************************************************************************
1662 con2tag_Foo :: Foo ... -> Int#
1663 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
1664 maxtag_Foo :: Int -- ditto (NB: not unlifted)
1667 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
1671 genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName)
1672 genAuxBind loc (GenCon2Tag tycon)
1673 = (mk_FunBind loc rdr_name eqns,
1674 L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1676 rdr_name = con2tag_RDR tycon
1679 mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
1680 mkParentType tycon `mkFunTy` intPrimTy
1682 lots_of_constructors = tyConFamilySize tycon > 8
1683 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
1684 -- but we don't do vectored returns any more.
1686 eqns | lots_of_constructors = [get_tag_eqn]
1687 | otherwise = map mk_eqn (tyConDataCons tycon)
1689 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
1691 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
1692 mk_eqn con = ([nlWildConPat con],
1693 nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG))))
1695 genAuxBind loc (GenTag2Con tycon)
1696 = (mk_FunBind loc rdr_name
1697 [([nlConVarPat intDataCon_RDR [a_RDR]],
1698 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
1699 L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1701 sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
1702 intTy `mkFunTy` mkParentType tycon
1704 rdr_name = tag2con_RDR tycon
1706 genAuxBind loc (GenMaxTag tycon)
1707 = (mkHsVarBind loc rdr_name rhs,
1708 L loc (TypeSig (L loc rdr_name) (L loc sig_ty)))
1710 rdr_name = maxtag_RDR tycon
1711 sig_ty = HsCoreTy intTy
1712 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))
1713 max_tag = case (tyConDataCons tycon) of
1714 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
1716 genAuxBind loc (MkTyCon tycon) -- $dT
1717 = (mkHsVarBind loc rdr_name rhs,
1718 L loc (TypeSig (L loc rdr_name) sig_ty))
1720 rdr_name = mk_data_type_name tycon
1721 sig_ty = nlHsTyVar dataType_RDR
1722 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons tycon]
1723 rhs = nlHsVar mkDataType_RDR
1724 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon)))
1725 `nlHsApp` nlList constrs
1727 genAuxBind loc (MkDataCon dc) -- $cT1 etc
1728 = (mkHsVarBind loc rdr_name rhs,
1729 L loc (TypeSig (L loc rdr_name) sig_ty))
1731 rdr_name = mk_constr_name dc
1732 sig_ty = nlHsTyVar constr_RDR
1733 rhs = nlHsApps mkConstr_RDR constr_args
1736 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1737 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1738 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1739 nlList labels, -- Field labels
1740 nlHsVar fixity] -- Fixity
1742 labels = map (nlHsLit . mkHsString . getOccString)
1743 (dataConFieldLabels dc)
1744 dc_occ = getOccName dc
1745 is_infix = isDataSymOcc dc_occ
1746 fixity | is_infix = infix_RDR
1747 | otherwise = prefix_RDR
1749 mk_data_type_name :: TyCon -> RdrName -- "$tT"
1750 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
1752 mk_constr_name :: DataCon -> RdrName -- "$cC"
1753 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
1755 mkParentType :: TyCon -> Type
1756 -- Turn the representation tycon of a family into
1757 -- a use of its family constructor
1759 = case tyConFamInst_maybe tc of
1760 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
1761 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
1764 %************************************************************************
1766 \subsection{Utility bits for generating bindings}
1768 %************************************************************************
1772 mk_FunBind :: SrcSpan -> RdrName
1773 -> [([LPat RdrName], LHsExpr RdrName)]
1775 mk_FunBind loc fun pats_and_exprs
1776 = L loc $ mkRdrFunBind (L loc fun) matches
1778 matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
1780 mkRdrFunBind :: Located RdrName -> [LMatch RdrName] -> HsBind RdrName
1781 mkRdrFunBind fun@(L _ fun_rdr) matches
1782 | null matches = mkFunBind fun [mkMatch [] (error_Expr str) emptyLocalBinds]
1783 -- Catch-all eqn looks like
1784 -- fmap = error "Void fmap"
1785 -- It's needed if there no data cons at all,
1786 -- which can happen with -XEmptyDataDecls
1788 | otherwise = mkFunBind fun matches
1790 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
1794 box_if_necy :: String -- The class involved
1795 -> TyCon -- The tycon involved
1796 -> LHsExpr RdrName -- The argument
1797 -> Type -- The argument type
1798 -> LHsExpr RdrName -- Boxed version of the arg
1799 box_if_necy cls_str tycon arg arg_ty
1800 | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg
1803 box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty
1805 ---------------------
1806 primOrdOps :: String -- The class involved
1807 -> TyCon -- The tycon involved
1809 -> (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp) -- (lt,le,eq,ge,gt)
1810 primOrdOps str tycon ty = assoc_ty_id str tycon ord_op_tbl ty
1812 ord_op_tbl :: [(Type, (PrimOp, PrimOp, PrimOp, PrimOp, PrimOp))]
1814 = [(charPrimTy, (CharLtOp, CharLeOp, CharEqOp, CharGeOp, CharGtOp))
1815 ,(intPrimTy, (IntLtOp, IntLeOp, IntEqOp, IntGeOp, IntGtOp))
1816 ,(wordPrimTy, (WordLtOp, WordLeOp, WordEqOp, WordGeOp, WordGtOp))
1817 ,(addrPrimTy, (AddrLtOp, AddrLeOp, AddrEqOp, AddrGeOp, AddrGtOp))
1818 ,(floatPrimTy, (FloatLtOp, FloatLeOp, FloatEqOp, FloatGeOp, FloatGtOp))
1819 ,(doublePrimTy, (DoubleLtOp, DoubleLeOp, DoubleEqOp, DoubleGeOp, DoubleGtOp)) ]
1821 box_con_tbl :: [(Type, RdrName)]
1823 [(charPrimTy, getRdrName charDataCon)
1824 ,(intPrimTy, getRdrName intDataCon)
1825 ,(wordPrimTy, wordDataCon_RDR)
1826 ,(floatPrimTy, getRdrName floatDataCon)
1827 ,(doublePrimTy, getRdrName doubleDataCon)
1830 assoc_ty_id :: String -- The class involved
1831 -> TyCon -- The tycon involved
1832 -> [(Type,a)] -- The table
1834 -> a -- The result of the lookup
1835 assoc_ty_id cls_str _ tbl ty
1836 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
1837 text "for primitive type" <+> ppr ty)
1838 | otherwise = head res
1840 res = [id | (ty',id) <- tbl, ty `tcEqType` ty']
1842 -----------------------------------------------------------------------
1844 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1845 and_Expr a b = genOpApp a and_RDR b
1847 -----------------------------------------------------------------------
1849 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1850 eq_Expr tycon ty a b = genOpApp a eq_op b
1852 eq_op | not (isUnLiftedType ty) = eq_RDR
1853 | otherwise = primOpRdrName prim_eq
1854 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
1858 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
1859 untag_Expr _ [] expr = expr
1860 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
1861 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
1862 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
1865 :: LHsExpr RdrName -> LHsExpr RdrName
1867 enum_from_then_to_Expr
1868 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1871 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
1872 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
1875 :: LHsExpr RdrName -> LHsExpr RdrName
1878 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
1880 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
1882 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
1883 nested_compose_Expr [e] = parenify e
1884 nested_compose_Expr (e:es)
1885 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
1887 -- impossible_Expr is used in case RHSs that should never happen.
1888 -- We generate these to keep the desugarer from complaining that they *might* happen!
1889 error_Expr :: String -> LHsExpr RdrName
1890 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
1892 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
1893 -- method. It is currently only used by Enum.{succ,pred}
1894 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
1895 illegal_Expr meth tp msg =
1896 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
1898 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
1899 -- to include the value of a_RDR in the error string.
1900 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
1901 illegal_toEnum_tag tp maxtag =
1902 nlHsApp (nlHsVar error_RDR)
1903 (nlHsApp (nlHsApp (nlHsVar append_RDR)
1904 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
1905 (nlHsApp (nlHsApp (nlHsApp
1906 (nlHsVar showsPrec_RDR)
1910 (nlHsVar append_RDR)
1911 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
1912 (nlHsApp (nlHsApp (nlHsApp
1913 (nlHsVar showsPrec_RDR)
1916 (nlHsLit (mkHsString ")"))))))
1918 parenify :: LHsExpr RdrName -> LHsExpr RdrName
1919 parenify e@(L _ (HsVar _)) = e
1920 parenify e = mkHsPar e
1922 -- genOpApp wraps brackets round the operator application, so that the
1923 -- renamer won't subsequently try to re-associate it.
1924 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1925 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
1929 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
1931 a_RDR = mkVarUnqual (fsLit "a")
1932 b_RDR = mkVarUnqual (fsLit "b")
1933 c_RDR = mkVarUnqual (fsLit "c")
1934 d_RDR = mkVarUnqual (fsLit "d")
1935 f_RDR = mkVarUnqual (fsLit "f")
1936 k_RDR = mkVarUnqual (fsLit "k")
1937 z_RDR = mkVarUnqual (fsLit "z")
1938 ah_RDR = mkVarUnqual (fsLit "a#")
1939 bh_RDR = mkVarUnqual (fsLit "b#")
1940 ch_RDR = mkVarUnqual (fsLit "c#")
1941 dh_RDR = mkVarUnqual (fsLit "d#")
1943 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
1944 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
1945 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
1946 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
1948 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
1949 false_Expr, true_Expr :: LHsExpr RdrName
1950 a_Expr = nlHsVar a_RDR
1951 -- b_Expr = nlHsVar b_RDR
1952 c_Expr = nlHsVar c_RDR
1953 f_Expr = nlHsVar f_RDR
1954 z_Expr = nlHsVar z_RDR
1955 ltTag_Expr = nlHsVar ltTag_RDR
1956 eqTag_Expr = nlHsVar eqTag_RDR
1957 gtTag_Expr = nlHsVar gtTag_RDR
1958 false_Expr = nlHsVar false_RDR
1959 true_Expr = nlHsVar true_RDR
1961 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
1962 a_Pat = nlVarPat a_RDR
1963 b_Pat = nlVarPat b_RDR
1964 c_Pat = nlVarPat c_RDR
1965 d_Pat = nlVarPat d_RDR
1966 f_Pat = nlVarPat f_RDR
1967 k_Pat = nlVarPat k_RDR
1968 z_Pat = nlVarPat z_RDR
1970 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
1971 -- Generates Orig s RdrName, for the binding positions
1972 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
1973 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
1974 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
1976 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
1977 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
1979 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
1980 mkAuxBinderName parent occ_fun = mkRdrUnqual (occ_fun (nameOccName parent))
1981 -- Was: mkDerivedRdrName name occ_fun, which made an original name
1982 -- But: (a) that does not work well for standalone-deriving
1983 -- (b) an unqualified name is just fine, provided it can't clash with user code
1986 s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports
1987 PrelNames, so PrelNames can't import PrimOp.
1990 primOpRdrName :: PrimOp -> RdrName
1991 primOpRdrName op = getRdrName (primOpId op)
1993 minusInt_RDR, eqInt_RDR, ltInt_RDR, geInt_RDR, gtInt_RDR, leInt_RDR,
1994 tagToEnum_RDR :: RdrName
1995 minusInt_RDR = primOpRdrName IntSubOp
1996 eqInt_RDR = primOpRdrName IntEqOp
1997 ltInt_RDR = primOpRdrName IntLtOp
1998 geInt_RDR = primOpRdrName IntGeOp
1999 gtInt_RDR = primOpRdrName IntGtOp
2000 leInt_RDR = primOpRdrName IntLeOp
2001 tagToEnum_RDR = primOpRdrName TagToEnumOp
2003 error_RDR :: RdrName
2004 error_RDR = getRdrName eRROR_ID