e01586c300e4b4a9e79e363ab78924a17400ee63
[ghc.git] / compiler / typecheck / TcGenDeriv.hs
1 {-
2 %
3 (c) The University of Glasgow 2006
4 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5
6
7 TcGenDeriv: Generating derived instance declarations
8
9 This module is nominally ``subordinate'' to @TcDeriv@, which is the
10 ``official'' interface to deriving-related things.
11
12 This is where we do all the grimy bindings' generation.
13 -}
14
15 {-# LANGUAGE CPP, ScopedTypeVariables #-}
16 {-# LANGUAGE FlexibleContexts #-}
17
18 module TcGenDeriv (
19 BagDerivStuff, DerivStuff(..),
20
21 hasBuiltinDeriving,
22 FFoldType(..), functorLikeTraverse,
23 deepSubtypesContaining, foldDataConArgs,
24 mkCoerceClassMethEqn,
25 gen_Newtype_binds,
26 genAuxBinds,
27 ordOpTbl, boxConTbl, litConTbl,
28 mkRdrFunBind
29 ) where
30
31 #include "HsVersions.h"
32
33 import HsSyn
34 import RdrName
35 import BasicTypes
36 import DataCon
37 import Name
38 import Fingerprint
39 import Encoding
40
41 import DynFlags
42 import PrelInfo
43 import FamInstEnv( FamInst )
44 import PrelNames
45 import THNames
46 import Module ( moduleName, moduleNameString
47 , moduleUnitId, unitIdString )
48 import MkId ( coerceId )
49 import PrimOp
50 import SrcLoc
51 import TyCon
52 import TcType
53 import TysPrim
54 import TysWiredIn
55 import Type
56 import Class
57 import TyCoRep
58 import VarSet
59 import VarEnv
60 import State
61 import Util
62 import Var
63 import Outputable
64 import Lexeme
65 import FastString
66 import Pair
67 import Bag
68 import TcEnv (InstInfo)
69 import StaticFlags( opt_PprStyle_Debug )
70
71 import ListSetOps ( assocMaybe )
72 import Data.List ( partition, intersperse )
73 import Data.Maybe ( catMaybes, isJust )
74
75 type BagDerivStuff = Bag DerivStuff
76
77 data AuxBindSpec
78 = DerivCon2Tag TyCon -- The con2Tag for given TyCon
79 | DerivTag2Con TyCon -- ...ditto tag2Con
80 | DerivMaxTag TyCon -- ...and maxTag
81 deriving( Eq )
82 -- All these generate ZERO-BASED tag operations
83 -- I.e first constructor has tag 0
84
85 data DerivStuff -- Please add this auxiliary stuff
86 = DerivAuxBind AuxBindSpec
87
88 -- Generics
89 | DerivFamInst FamInst -- New type family instances
90
91 -- New top-level auxiliary bindings
92 | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
93 | DerivInst (InstInfo RdrName) -- New, auxiliary instances
94
95 {-
96 ************************************************************************
97 * *
98 Class deriving diagnostics
99 * *
100 ************************************************************************
101
102 Only certain blessed classes can be used in a deriving clause. These classes
103 are listed below in the definition of hasBuiltinDeriving (with the exception
104 of Generic and Generic1, which are handled separately in TcGenGenerics).
105
106 A class might be able to be used in a deriving clause if it -XDeriveAnyClass
107 is willing to support it. The canDeriveAnyClass function checks if this is
108 the case.
109 -}
110
111 hasBuiltinDeriving :: DynFlags
112 -> (Name -> Fixity)
113 -> Class
114 -> Maybe (SrcSpan
115 -> TyCon
116 -> (LHsBinds RdrName, BagDerivStuff))
117 hasBuiltinDeriving dflags fix_env clas = assocMaybe gen_list (getUnique clas)
118 where
119 gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
120 gen_list = [ (eqClassKey, gen_Eq_binds)
121 , (ordClassKey, gen_Ord_binds)
122 , (enumClassKey, gen_Enum_binds)
123 , (boundedClassKey, gen_Bounded_binds)
124 , (ixClassKey, gen_Ix_binds)
125 , (showClassKey, gen_Show_binds fix_env)
126 , (readClassKey, gen_Read_binds fix_env)
127 , (dataClassKey, gen_Data_binds dflags)
128 , (functorClassKey, gen_Functor_binds)
129 , (foldableClassKey, gen_Foldable_binds)
130 , (traversableClassKey, gen_Traversable_binds)
131 , (liftClassKey, gen_Lift_binds) ]
132
133 {-
134 ************************************************************************
135 * *
136 Eq instances
137 * *
138 ************************************************************************
139
140 Here are the heuristics for the code we generate for @Eq@. Let's
141 assume we have a data type with some (possibly zero) nullary data
142 constructors and some ordinary, non-nullary ones (the rest, also
143 possibly zero of them). Here's an example, with both \tr{N}ullary and
144 \tr{O}rdinary data cons.
145
146 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
147
148 * For the ordinary constructors (if any), we emit clauses to do The
149 Usual Thing, e.g.,:
150
151 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
152 (==) (O2 a1) (O2 a2) = a1 == a2
153 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
154
155 Note: if we're comparing unlifted things, e.g., if 'a1' and
156 'a2' are Float#s, then we have to generate
157 case (a1 `eqFloat#` a2) of r -> r
158 for that particular test.
159
160 * If there are a lot of (more than en) nullary constructors, we emit a
161 catch-all clause of the form:
162
163 (==) a b = case (con2tag_Foo a) of { a# ->
164 case (con2tag_Foo b) of { b# ->
165 case (a# ==# b#) of {
166 r -> r }}}
167
168 If con2tag gets inlined this leads to join point stuff, so
169 it's better to use regular pattern matching if there aren't too
170 many nullary constructors. "Ten" is arbitrary, of course
171
172 * If there aren't any nullary constructors, we emit a simpler
173 catch-all:
174
175 (==) a b = False
176
177 * For the @(/=)@ method, we normally just use the default method.
178 If the type is an enumeration type, we could/may/should? generate
179 special code that calls @con2tag_Foo@, much like for @(==)@ shown
180 above.
181
182 We thought about doing this: If we're also deriving 'Ord' for this
183 tycon, we generate:
184 instance ... Eq (Foo ...) where
185 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
186 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
187 However, that requires that (Ord <whatever>) was put in the context
188 for the instance decl, which it probably wasn't, so the decls
189 produced don't get through the typechecker.
190 -}
191
192 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
193 gen_Eq_binds loc tycon
194 = (method_binds, aux_binds)
195 where
196 all_cons = tyConDataCons tycon
197 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
198
199 -- If there are ten or more (arbitrary number) nullary constructors,
200 -- use the con2tag stuff. For small types it's better to use
201 -- ordinary pattern matching.
202 (tag_match_cons, pat_match_cons)
203 | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
204 | otherwise = ([], all_cons)
205
206 no_tag_match_cons = null tag_match_cons
207
208 fall_through_eqn
209 | no_tag_match_cons -- All constructors have arguments
210 = case pat_match_cons of
211 [] -> [] -- No constructors; no fall-though case
212 [_] -> [] -- One constructor; no fall-though case
213 _ -> -- Two or more constructors; add fall-through of
214 -- (==) _ _ = False
215 [([nlWildPat, nlWildPat], false_Expr)]
216
217 | otherwise -- One or more tag_match cons; add fall-through of
218 -- extract tags compare for equality
219 = [([a_Pat, b_Pat],
220 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
221 (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
222
223 aux_binds | no_tag_match_cons = emptyBag
224 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
225
226 method_binds = listToBag [eq_bind, ne_bind]
227 eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
228 ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
229 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
230
231 ------------------------------------------------------------------
232 pats_etc data_con
233 = let
234 con1_pat = nlConVarPat data_con_RDR as_needed
235 con2_pat = nlConVarPat data_con_RDR bs_needed
236
237 data_con_RDR = getRdrName data_con
238 con_arity = length tys_needed
239 as_needed = take con_arity as_RDRs
240 bs_needed = take con_arity bs_RDRs
241 tys_needed = dataConOrigArgTys data_con
242 in
243 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
244 where
245 nested_eq_expr [] [] [] = true_Expr
246 nested_eq_expr tys as bs
247 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
248 where
249 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
250
251 {-
252 ************************************************************************
253 * *
254 Ord instances
255 * *
256 ************************************************************************
257
258 Note [Generating Ord instances]
259 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
260 Suppose constructors are K1..Kn, and some are nullary.
261 The general form we generate is:
262
263 * Do case on first argument
264 case a of
265 K1 ... -> rhs_1
266 K2 ... -> rhs_2
267 ...
268 Kn ... -> rhs_n
269 _ -> nullary_rhs
270
271 * To make rhs_i
272 If i = 1, 2, n-1, n, generate a single case.
273 rhs_2 case b of
274 K1 {} -> LT
275 K2 ... -> ...eq_rhs(K2)...
276 _ -> GT
277
278 Otherwise do a tag compare against the bigger range
279 (because this is the one most likely to succeed)
280 rhs_3 case tag b of tb ->
281 if 3 <# tg then GT
282 else case b of
283 K3 ... -> ...eq_rhs(K3)....
284 _ -> LT
285
286 * To make eq_rhs(K), which knows that
287 a = K a1 .. av
288 b = K b1 .. bv
289 we just want to compare (a1,b1) then (a2,b2) etc.
290 Take care on the last field to tail-call into comparing av,bv
291
292 * To make nullary_rhs generate this
293 case con2tag a of a# ->
294 case con2tag b of ->
295 a# `compare` b#
296
297 Several special cases:
298
299 * Two or fewer nullary constructors: don't generate nullary_rhs
300
301 * Be careful about unlifted comparisons. When comparing unboxed
302 values we can't call the overloaded functions.
303 See function unliftedOrdOp
304
305 Note [Do not rely on compare]
306 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
307 It's a bad idea to define only 'compare', and build the other binary
308 comparisons on top of it; see Trac #2130, #4019. Reason: we don't
309 want to laboriously make a three-way comparison, only to extract a
310 binary result, something like this:
311 (>) (I# x) (I# y) = case <# x y of
312 True -> False
313 False -> case ==# x y of
314 True -> False
315 False -> True
316
317 So for sufficiently small types (few constructors, or all nullary)
318 we generate all methods; for large ones we just use 'compare'.
319 -}
320
321 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
322
323 ------------
324 ordMethRdr :: OrdOp -> RdrName
325 ordMethRdr op
326 = case op of
327 OrdCompare -> compare_RDR
328 OrdLT -> lt_RDR
329 OrdLE -> le_RDR
330 OrdGE -> ge_RDR
331 OrdGT -> gt_RDR
332
333 ------------
334 ltResult :: OrdOp -> LHsExpr RdrName
335 -- Knowing a<b, what is the result for a `op` b?
336 ltResult OrdCompare = ltTag_Expr
337 ltResult OrdLT = true_Expr
338 ltResult OrdLE = true_Expr
339 ltResult OrdGE = false_Expr
340 ltResult OrdGT = false_Expr
341
342 ------------
343 eqResult :: OrdOp -> LHsExpr RdrName
344 -- Knowing a=b, what is the result for a `op` b?
345 eqResult OrdCompare = eqTag_Expr
346 eqResult OrdLT = false_Expr
347 eqResult OrdLE = true_Expr
348 eqResult OrdGE = true_Expr
349 eqResult OrdGT = false_Expr
350
351 ------------
352 gtResult :: OrdOp -> LHsExpr RdrName
353 -- Knowing a>b, what is the result for a `op` b?
354 gtResult OrdCompare = gtTag_Expr
355 gtResult OrdLT = false_Expr
356 gtResult OrdLE = false_Expr
357 gtResult OrdGE = true_Expr
358 gtResult OrdGT = true_Expr
359
360 ------------
361 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
362 gen_Ord_binds loc tycon
363 | null tycon_data_cons -- No data-cons => invoke bale-out case
364 = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
365 | otherwise
366 = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
367 where
368 aux_binds | single_con_type = emptyBag
369 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
370
371 -- Note [Do not rely on compare]
372 other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
373 || null non_nullary_cons -- Or it's an enumeration
374 = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
375 | otherwise
376 = emptyBag
377
378 get_tag con = dataConTag con - fIRST_TAG
379 -- We want *zero-based* tags, because that's what
380 -- con2Tag returns (generated by untag_Expr)!
381
382 tycon_data_cons = tyConDataCons tycon
383 single_con_type = isSingleton tycon_data_cons
384 (first_con : _) = tycon_data_cons
385 (last_con : _) = reverse tycon_data_cons
386 first_tag = get_tag first_con
387 last_tag = get_tag last_con
388
389 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
390
391
392 mkOrdOp :: OrdOp -> LHsBind RdrName
393 -- Returns a binding op a b = ... compares a and b according to op ....
394 mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
395
396 mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
397 mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
398 | length nullary_cons <= 2 -- Two nullary or fewer, so use cases
399 = nlHsCase (nlHsVar a_RDR) $
400 map (mkOrdOpAlt op) tycon_data_cons
401 -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
402 -- C2 x -> case b of C2 x -> ....comopare x.... }
403
404 | null non_nullary_cons -- All nullary, so go straight to comparing tags
405 = mkTagCmp op
406
407 | otherwise -- Mixed nullary and non-nullary
408 = nlHsCase (nlHsVar a_RDR) $
409 (map (mkOrdOpAlt op) non_nullary_cons
410 ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])
411
412
413 mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
414 -- Make the alternative (Ki a1 a2 .. av ->
415 mkOrdOpAlt op data_con
416 = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
417 (mkInnerRhs op data_con)
418 where
419 as_needed = take (dataConSourceArity data_con) as_RDRs
420 data_con_RDR = getRdrName data_con
421
422 mkInnerRhs op data_con
423 | single_con_type
424 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
425
426 | tag == first_tag
427 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
428 , mkHsCaseAlt nlWildPat (ltResult op) ]
429 | tag == last_tag
430 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
431 , mkHsCaseAlt nlWildPat (gtResult op) ]
432
433 | tag == first_tag + 1
434 = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
435 (gtResult op)
436 , mkInnerEqAlt op data_con
437 , mkHsCaseAlt nlWildPat (ltResult op) ]
438 | tag == last_tag - 1
439 = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
440 (ltResult op)
441 , mkInnerEqAlt op data_con
442 , mkHsCaseAlt nlWildPat (gtResult op) ]
443
444 | tag > last_tag `div` 2 -- lower range is larger
445 = untag_Expr tycon [(b_RDR, bh_RDR)] $
446 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
447 (gtResult op) $ -- Definitely GT
448 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
449 , mkHsCaseAlt nlWildPat (ltResult op) ]
450
451 | otherwise -- upper range is larger
452 = untag_Expr tycon [(b_RDR, bh_RDR)] $
453 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
454 (ltResult op) $ -- Definitely LT
455 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
456 , mkHsCaseAlt nlWildPat (gtResult op) ]
457 where
458 tag = get_tag data_con
459 tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
460
461 mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
462 -- First argument 'a' known to be built with K
463 -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
464 mkInnerEqAlt op data_con
465 = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
466 mkCompareFields tycon op (dataConOrigArgTys data_con)
467 where
468 data_con_RDR = getRdrName data_con
469 bs_needed = take (dataConSourceArity data_con) bs_RDRs
470
471 mkTagCmp :: OrdOp -> LHsExpr RdrName
472 -- Both constructors known to be nullary
473 -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
474 mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
475 unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
476
477 mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
478 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
479 -- where the ai,bi have the given types
480 mkCompareFields tycon op tys
481 = go tys as_RDRs bs_RDRs
482 where
483 go [] _ _ = eqResult op
484 go [ty] (a:_) (b:_)
485 | isUnliftedType ty = unliftedOrdOp tycon ty op a b
486 | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
487 go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
488 (ltResult op)
489 (go tys as bs)
490 (gtResult op)
491 go _ _ _ = panic "mkCompareFields"
492
493 -- (mk_compare ty a b) generates
494 -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
495 -- but with suitable special cases for
496 mk_compare ty a b lt eq gt
497 | isUnliftedType ty
498 = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
499 | otherwise
500 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
501 [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
502 mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
503 mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
504 where
505 a_expr = nlHsVar a
506 b_expr = nlHsVar b
507 (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
508
509 unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
510 unliftedOrdOp tycon ty op a b
511 = case op of
512 OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
513 ltTag_Expr eqTag_Expr gtTag_Expr
514 OrdLT -> wrap lt_op
515 OrdLE -> wrap le_op
516 OrdGE -> wrap ge_op
517 OrdGT -> wrap gt_op
518 where
519 (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
520 wrap prim_op = genPrimOpApp a_expr prim_op b_expr
521 a_expr = nlHsVar a
522 b_expr = nlHsVar b
523
524 unliftedCompare :: RdrName -> RdrName
525 -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare
526 -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results
527 -> LHsExpr RdrName
528 -- Return (if a < b then lt else if a == b then eq else gt)
529 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
530 = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
531 -- Test (<) first, not (==), because the latter
532 -- is true less often, so putting it first would
533 -- mean more tests (dynamically)
534 nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
535 where
536 ascribeBool e = nlExprWithTySig e (toLHsSigWcType boolTy)
537
538 nlConWildPat :: DataCon -> LPat RdrName
539 -- The pattern (K {})
540 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
541 (RecCon (HsRecFields { rec_flds = []
542 , rec_dotdot = Nothing })))
543
544 {-
545 ************************************************************************
546 * *
547 Enum instances
548 * *
549 ************************************************************************
550
551 @Enum@ can only be derived for enumeration types. For a type
552 \begin{verbatim}
553 data Foo ... = N1 | N2 | ... | Nn
554 \end{verbatim}
555
556 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
557 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
558
559 \begin{verbatim}
560 instance ... Enum (Foo ...) where
561 succ x = toEnum (1 + fromEnum x)
562 pred x = toEnum (fromEnum x - 1)
563
564 toEnum i = tag2con_Foo i
565
566 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
567
568 -- or, really...
569 enumFrom a
570 = case con2tag_Foo a of
571 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
572
573 enumFromThen a b
574 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
575
576 -- or, really...
577 enumFromThen a b
578 = case con2tag_Foo a of { a# ->
579 case con2tag_Foo b of { b# ->
580 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
581 }}
582 \end{verbatim}
583
584 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
585 -}
586
587 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
588 gen_Enum_binds loc tycon
589 = (method_binds, aux_binds)
590 where
591 method_binds = listToBag [
592 succ_enum,
593 pred_enum,
594 to_enum,
595 enum_from,
596 enum_from_then,
597 from_enum
598 ]
599 aux_binds = listToBag $ map DerivAuxBind
600 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
601
602 occ_nm = getOccString tycon
603
604 succ_enum
605 = mk_easy_FunBind loc succ_RDR [a_Pat] $
606 untag_Expr tycon [(a_RDR, ah_RDR)] $
607 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
608 nlHsVarApps intDataCon_RDR [ah_RDR]])
609 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
610 (nlHsApp (nlHsVar (tag2con_RDR tycon))
611 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
612 nlHsIntLit 1]))
613
614 pred_enum
615 = mk_easy_FunBind loc pred_RDR [a_Pat] $
616 untag_Expr tycon [(a_RDR, ah_RDR)] $
617 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
618 nlHsVarApps intDataCon_RDR [ah_RDR]])
619 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
620 (nlHsApp (nlHsVar (tag2con_RDR tycon))
621 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
622 nlHsLit (HsInt "-1" (-1))]))
623
624 to_enum
625 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
626 nlHsIf (nlHsApps and_RDR
627 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
628 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
629 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
630 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
631
632 enum_from
633 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
634 untag_Expr tycon [(a_RDR, ah_RDR)] $
635 nlHsApps map_RDR
636 [nlHsVar (tag2con_RDR tycon),
637 nlHsPar (enum_from_to_Expr
638 (nlHsVarApps intDataCon_RDR [ah_RDR])
639 (nlHsVar (maxtag_RDR tycon)))]
640
641 enum_from_then
642 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
643 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
644 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
645 nlHsPar (enum_from_then_to_Expr
646 (nlHsVarApps intDataCon_RDR [ah_RDR])
647 (nlHsVarApps intDataCon_RDR [bh_RDR])
648 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
649 nlHsVarApps intDataCon_RDR [bh_RDR]])
650 (nlHsIntLit 0)
651 (nlHsVar (maxtag_RDR tycon))
652 ))
653
654 from_enum
655 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
656 untag_Expr tycon [(a_RDR, ah_RDR)] $
657 (nlHsVarApps intDataCon_RDR [ah_RDR])
658
659 {-
660 ************************************************************************
661 * *
662 Bounded instances
663 * *
664 ************************************************************************
665 -}
666
667 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
668 gen_Bounded_binds loc tycon
669 | isEnumerationTyCon tycon
670 = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
671 | otherwise
672 = ASSERT(isSingleton data_cons)
673 (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
674 where
675 data_cons = tyConDataCons tycon
676
677 ----- enum-flavored: ---------------------------
678 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
679 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
680
681 data_con_1 = head data_cons
682 data_con_N = last data_cons
683 data_con_1_RDR = getRdrName data_con_1
684 data_con_N_RDR = getRdrName data_con_N
685
686 ----- single-constructor-flavored: -------------
687 arity = dataConSourceArity data_con_1
688
689 min_bound_1con = mkHsVarBind loc minBound_RDR $
690 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
691 max_bound_1con = mkHsVarBind loc maxBound_RDR $
692 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
693
694 {-
695 ************************************************************************
696 * *
697 Ix instances
698 * *
699 ************************************************************************
700
701 Deriving @Ix@ is only possible for enumeration types and
702 single-constructor types. We deal with them in turn.
703
704 For an enumeration type, e.g.,
705 \begin{verbatim}
706 data Foo ... = N1 | N2 | ... | Nn
707 \end{verbatim}
708 things go not too differently from @Enum@:
709 \begin{verbatim}
710 instance ... Ix (Foo ...) where
711 range (a, b)
712 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
713
714 -- or, really...
715 range (a, b)
716 = case (con2tag_Foo a) of { a# ->
717 case (con2tag_Foo b) of { b# ->
718 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
719 }}
720
721 -- Generate code for unsafeIndex, because using index leads
722 -- to lots of redundant range tests
723 unsafeIndex c@(a, b) d
724 = case (con2tag_Foo d -# con2tag_Foo a) of
725 r# -> I# r#
726
727 inRange (a, b) c
728 = let
729 p_tag = con2tag_Foo c
730 in
731 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
732
733 -- or, really...
734 inRange (a, b) c
735 = case (con2tag_Foo a) of { a_tag ->
736 case (con2tag_Foo b) of { b_tag ->
737 case (con2tag_Foo c) of { c_tag ->
738 if (c_tag >=# a_tag) then
739 c_tag <=# b_tag
740 else
741 False
742 }}}
743 \end{verbatim}
744 (modulo suitable case-ification to handle the unlifted tags)
745
746 For a single-constructor type (NB: this includes all tuples), e.g.,
747 \begin{verbatim}
748 data Foo ... = MkFoo a b Int Double c c
749 \end{verbatim}
750 we follow the scheme given in Figure~19 of the Haskell~1.2 report
751 (p.~147).
752 -}
753
754 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
755
756 gen_Ix_binds loc tycon
757 | isEnumerationTyCon tycon
758 = ( enum_ixes
759 , listToBag $ map DerivAuxBind
760 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
761 | otherwise
762 = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
763 where
764 --------------------------------------------------------------
765 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
766
767 enum_range
768 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
769 untag_Expr tycon [(a_RDR, ah_RDR)] $
770 untag_Expr tycon [(b_RDR, bh_RDR)] $
771 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
772 nlHsPar (enum_from_to_Expr
773 (nlHsVarApps intDataCon_RDR [ah_RDR])
774 (nlHsVarApps intDataCon_RDR [bh_RDR]))
775
776 enum_index
777 = mk_easy_FunBind loc unsafeIndex_RDR
778 [noLoc (AsPat (noLoc c_RDR)
779 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
780 d_Pat] (
781 untag_Expr tycon [(a_RDR, ah_RDR)] (
782 untag_Expr tycon [(d_RDR, dh_RDR)] (
783 let
784 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
785 in
786 nlHsCase
787 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
788 [mkHsCaseAlt (nlVarPat c_RDR) rhs]
789 ))
790 )
791
792 -- This produces something like `(ch >= ah) && (ch <= bh)`
793 enum_inRange
794 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
795 untag_Expr tycon [(a_RDR, ah_RDR)] (
796 untag_Expr tycon [(b_RDR, bh_RDR)] (
797 untag_Expr tycon [(c_RDR, ch_RDR)] (
798 -- This used to use `if`, which interacts badly with RebindableSyntax.
799 -- See #11396.
800 nlHsApps and_RDR
801 [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
802 , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
803 ]
804 )))
805
806 --------------------------------------------------------------
807 single_con_ixes
808 = listToBag [single_con_range, single_con_index, single_con_inRange]
809
810 data_con
811 = case tyConSingleDataCon_maybe tycon of -- just checking...
812 Nothing -> panic "get_Ix_binds"
813 Just dc -> dc
814
815 con_arity = dataConSourceArity data_con
816 data_con_RDR = getRdrName data_con
817
818 as_needed = take con_arity as_RDRs
819 bs_needed = take con_arity bs_RDRs
820 cs_needed = take con_arity cs_RDRs
821
822 con_pat xs = nlConVarPat data_con_RDR xs
823 con_expr = nlHsVarApps data_con_RDR cs_needed
824
825 --------------------------------------------------------------
826 single_con_range
827 = mk_easy_FunBind loc range_RDR
828 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
829 noLoc (mkHsComp ListComp stmts con_expr)
830 where
831 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
832
833 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
834 (nlHsApp (nlHsVar range_RDR)
835 (mkLHsVarTuple [a,b]))
836
837 ----------------
838 single_con_index
839 = mk_easy_FunBind loc unsafeIndex_RDR
840 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
841 con_pat cs_needed]
842 -- We need to reverse the order we consider the components in
843 -- so that
844 -- range (l,u) !! index (l,u) i == i -- when i is in range
845 -- (from http://haskell.org/onlinereport/ix.html) holds.
846 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
847 where
848 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
849 mk_index [] = nlHsIntLit 0
850 mk_index [(l,u,i)] = mk_one l u i
851 mk_index ((l,u,i) : rest)
852 = genOpApp (
853 mk_one l u i
854 ) plus_RDR (
855 genOpApp (
856 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
857 (mkLHsVarTuple [l,u]))
858 ) times_RDR (mk_index rest)
859 )
860 mk_one l u i
861 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
862
863 ------------------
864 single_con_inRange
865 = mk_easy_FunBind loc inRange_RDR
866 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
867 con_pat cs_needed] $
868 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
869 where
870 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
871
872 {-
873 ************************************************************************
874 * *
875 Read instances
876 * *
877 ************************************************************************
878
879 Example
880
881 infix 4 %%
882 data T = Int %% Int
883 | T1 { f1 :: Int }
884 | T2 T
885
886 instance Read T where
887 readPrec =
888 parens
889 ( prec 4 (
890 do x <- ReadP.step Read.readPrec
891 expectP (Symbol "%%")
892 y <- ReadP.step Read.readPrec
893 return (x %% y))
894 +++
895 prec (appPrec+1) (
896 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
897 -- Record construction binds even more tightly than application
898 do expectP (Ident "T1")
899 expectP (Punc '{')
900 expectP (Ident "f1")
901 expectP (Punc '=')
902 x <- ReadP.reset Read.readPrec
903 expectP (Punc '}')
904 return (T1 { f1 = x }))
905 +++
906 prec appPrec (
907 do expectP (Ident "T2")
908 x <- ReadP.step Read.readPrec
909 return (T2 x))
910 )
911
912 readListPrec = readListPrecDefault
913 readList = readListDefault
914
915
916 Note [Use expectP]
917 ~~~~~~~~~~~~~~~~~~
918 Note that we use
919 expectP (Ident "T1")
920 rather than
921 Ident "T1" <- lexP
922 The latter desugares to inline code for matching the Ident and the
923 string, and this can be very voluminous. The former is much more
924 compact. Cf Trac #7258, although that also concerned non-linearity in
925 the occurrence analyser, a separate issue.
926
927 Note [Read for empty data types]
928 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
929 What should we get for this? (Trac #7931)
930 data Emp deriving( Read ) -- No data constructors
931
932 Here we want
933 read "[]" :: [Emp] to succeed, returning []
934 So we do NOT want
935 instance Read Emp where
936 readPrec = error "urk"
937 Rather we want
938 instance Read Emp where
939 readPred = pfail -- Same as choose []
940
941 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
942 These instances are also useful for Read (Either Int Emp), where
943 we want to be able to parse (Left 3) just fine.
944 -}
945
946 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
947
948 gen_Read_binds get_fixity loc tycon
949 = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
950 where
951 -----------------------------------------------------------------------
952 default_readlist
953 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
954
955 default_readlistprec
956 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
957 -----------------------------------------------------------------------
958
959 data_cons = tyConDataCons tycon
960 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
961
962 read_prec = mkHsVarBind loc readPrec_RDR
963 (nlHsApp (nlHsVar parens_RDR) read_cons)
964
965 read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types]
966 | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
967 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
968
969 read_nullary_cons
970 = case nullary_cons of
971 [] -> []
972 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
973 _ -> [nlHsApp (nlHsVar choose_RDR)
974 (nlList (map mk_pair nullary_cons))]
975 -- NB For operators the parens around (:=:) are matched by the
976 -- enclosing "parens" call, so here we must match the naked
977 -- data_con_str con
978
979 match_con con | isSym con_str = [symbol_pat con_str]
980 | otherwise = ident_h_pat con_str
981 where
982 con_str = data_con_str con
983 -- For nullary constructors we must match Ident s for normal constrs
984 -- and Symbol s for operators
985
986 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
987 result_expr con []]
988
989 read_non_nullary_con data_con
990 | is_infix = mk_parser infix_prec infix_stmts body
991 | is_record = mk_parser record_prec record_stmts body
992 -- Using these two lines instead allows the derived
993 -- read for infix and record bindings to read the prefix form
994 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
995 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
996 | otherwise = prefix_parser
997 where
998 body = result_expr data_con as_needed
999 con_str = data_con_str data_con
1000
1001 prefix_parser = mk_parser prefix_prec prefix_stmts body
1002
1003 read_prefix_con
1004 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
1005 | otherwise = ident_h_pat con_str
1006
1007 read_infix_con
1008 | isSym con_str = [symbol_pat con_str]
1009 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
1010
1011 prefix_stmts -- T a b c
1012 = read_prefix_con ++ read_args
1013
1014 infix_stmts -- a %% b, or a `T` b
1015 = [read_a1]
1016 ++ read_infix_con
1017 ++ [read_a2]
1018
1019 record_stmts -- T { f1 = a, f2 = b }
1020 = read_prefix_con
1021 ++ [read_punc "{"]
1022 ++ concat (intersperse [read_punc ","] field_stmts)
1023 ++ [read_punc "}"]
1024
1025 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
1026
1027 con_arity = dataConSourceArity data_con
1028 labels = map flLabel $ dataConFieldLabels data_con
1029 dc_nm = getName data_con
1030 is_infix = dataConIsInfix data_con
1031 is_record = length labels > 0
1032 as_needed = take con_arity as_RDRs
1033 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
1034 (read_a1:read_a2:_) = read_args
1035
1036 prefix_prec = appPrecedence
1037 infix_prec = getPrecedence get_fixity dc_nm
1038 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
1039 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
1040
1041 ------------------------------------------------------------------------
1042 -- Helpers
1043 ------------------------------------------------------------------------
1044 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
1045 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
1046 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
1047 con_app con as = nlHsVarApps (getRdrName con) as -- con as
1048 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1049
1050 -- For constructors and field labels ending in '#', we hackily
1051 -- let the lexer generate two tokens, and look for both in sequence
1052 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
1053 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
1054 | otherwise = [ ident_pat s ]
1055
1056 bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
1057 -- See Note [Use expectP]
1058 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo")
1059 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>")
1060 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<")
1061
1062 data_con_str con = occNameString (getOccName con)
1063
1064 read_arg a ty = ASSERT( not (isUnliftedType ty) )
1065 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
1066
1067 read_field lbl a = read_lbl lbl ++
1068 [read_punc "=",
1069 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
1070
1071 -- When reading field labels we might encounter
1072 -- a = 3
1073 -- _a = 3
1074 -- or (#) = 4
1075 -- Note the parens!
1076 read_lbl lbl | isSym lbl_str
1077 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1078 | otherwise
1079 = ident_h_pat lbl_str
1080 where
1081 lbl_str = unpackFS lbl
1082
1083 {-
1084 ************************************************************************
1085 * *
1086 Show instances
1087 * *
1088 ************************************************************************
1089
1090 Example
1091
1092 infixr 5 :^:
1093
1094 data Tree a = Leaf a | Tree a :^: Tree a
1095
1096 instance (Show a) => Show (Tree a) where
1097
1098 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1099 where
1100 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1101
1102 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1103 where
1104 showStr = showsPrec (up_prec+1) u .
1105 showString " :^: " .
1106 showsPrec (up_prec+1) v
1107 -- Note: right-associativity of :^: ignored
1108
1109 up_prec = 5 -- Precedence of :^:
1110 app_prec = 10 -- Application has precedence one more than
1111 -- the most tightly-binding operator
1112 -}
1113
1114 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1115
1116 gen_Show_binds get_fixity loc tycon
1117 = (listToBag [shows_prec, show_list], emptyBag)
1118 where
1119 -----------------------------------------------------------------------
1120 show_list = mkHsVarBind loc showList_RDR
1121 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1122 -----------------------------------------------------------------------
1123 data_cons = tyConDataCons tycon
1124 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
1125
1126 pats_etc data_con
1127 | nullary_con = -- skip the showParen junk...
1128 ASSERT(null bs_needed)
1129 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1130 | otherwise =
1131 ([a_Pat, con_pat],
1132 showParen_Expr (genOpApp a_Expr ge_RDR
1133 (nlHsLit (HsInt "" con_prec_plus_one)))
1134 (nlHsPar (nested_compose_Expr show_thingies)))
1135 where
1136 data_con_RDR = getRdrName data_con
1137 con_arity = dataConSourceArity data_con
1138 bs_needed = take con_arity bs_RDRs
1139 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1140 con_pat = nlConVarPat data_con_RDR bs_needed
1141 nullary_con = con_arity == 0
1142 labels = map flLabel $ dataConFieldLabels data_con
1143 lab_fields = length labels
1144 record_syntax = lab_fields > 0
1145
1146 dc_nm = getName data_con
1147 dc_occ_nm = getOccName data_con
1148 con_str = occNameString dc_occ_nm
1149 op_con_str = wrapOpParens con_str
1150 backquote_str = wrapOpBackquotes con_str
1151
1152 show_thingies
1153 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1154 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1155 show_record_args ++ [mk_showString_app "}"]
1156 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1157
1158 show_label l = mk_showString_app (nm ++ " = ")
1159 -- Note the spaces around the "=" sign. If we
1160 -- don't have them then we get Foo { x=-1 } and
1161 -- the "=-" parses as a single lexeme. Only the
1162 -- space after the '=' is necessary, but it
1163 -- seems tidier to have them both sides.
1164 where
1165 nm = wrapOpParens (unpackFS l)
1166
1167 show_args = zipWith show_arg bs_needed arg_tys
1168 (show_arg1:show_arg2:_) = show_args
1169 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1170
1171 -- Assumption for record syntax: no of fields == no of
1172 -- labelled fields (and in same order)
1173 show_record_args = concat $
1174 intersperse [mk_showString_app ", "] $
1175 [ [show_label lbl, arg]
1176 | (lbl,arg) <- zipEqual "gen_Show_binds"
1177 labels show_args ]
1178
1179 show_arg :: RdrName -> Type -> LHsExpr RdrName
1180 show_arg b arg_ty
1181 | isUnliftedType arg_ty
1182 -- See Note [Deriving and unboxed types] in TcDeriv
1183 = nlHsApps compose_RDR [mk_shows_app boxed_arg,
1184 mk_showString_app postfixMod]
1185 | otherwise
1186 = mk_showsPrec_app arg_prec arg
1187 where
1188 arg = nlHsVar b
1189 boxed_arg = box "Show" tycon arg arg_ty
1190 postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
1191
1192 -- Fixity stuff
1193 is_infix = dataConIsInfix data_con
1194 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1195 arg_prec | record_syntax = 0 -- Record fields don't need parens
1196 | otherwise = con_prec_plus_one
1197
1198 wrapOpParens :: String -> String
1199 wrapOpParens s | isSym s = '(' : s ++ ")"
1200 | otherwise = s
1201
1202 wrapOpBackquotes :: String -> String
1203 wrapOpBackquotes s | isSym s = s
1204 | otherwise = '`' : s ++ "`"
1205
1206 isSym :: String -> Bool
1207 isSym "" = False
1208 isSym (c : _) = startsVarSym c || startsConSym c
1209
1210 -- | showString :: String -> ShowS
1211 mk_showString_app :: String -> LHsExpr RdrName
1212 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1213
1214 -- | showsPrec :: Show a => Int -> a -> ShowS
1215 mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
1216 mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x]
1217
1218 -- | shows :: Show a => a -> ShowS
1219 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
1220 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1221
1222 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1223 getPrec is_infix get_fixity nm
1224 | not is_infix = appPrecedence
1225 | otherwise = getPrecedence get_fixity nm
1226
1227 appPrecedence :: Integer
1228 appPrecedence = fromIntegral maxPrecedence + 1
1229 -- One more than the precedence of the most
1230 -- tightly-binding operator
1231
1232 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1233 getPrecedence get_fixity nm
1234 = case get_fixity nm of
1235 Fixity _ x _assoc -> fromIntegral x
1236 -- NB: the Report says that associativity is not taken
1237 -- into account for either Read or Show; hence we
1238 -- ignore associativity here
1239
1240 {-
1241 ************************************************************************
1242 * *
1243 Data instances
1244 * *
1245 ************************************************************************
1246
1247 From the data type
1248
1249 data T a b = T1 a b | T2
1250
1251 we generate
1252
1253 $cT1 = mkDataCon $dT "T1" Prefix
1254 $cT2 = mkDataCon $dT "T2" Prefix
1255 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1256 -- the [] is for field labels.
1257
1258 instance (Data a, Data b) => Data (T a b) where
1259 gfoldl k z (T1 a b) = z T `k` a `k` b
1260 gfoldl k z T2 = z T2
1261 -- ToDo: add gmapT,Q,M, gfoldr
1262
1263 gunfold k z c = case conIndex c of
1264 I# 1# -> k (k (z T1))
1265 I# 2# -> z T2
1266
1267 toConstr (T1 _ _) = $cT1
1268 toConstr T2 = $cT2
1269
1270 dataTypeOf _ = $dT
1271
1272 dataCast1 = gcast1 -- If T :: * -> *
1273 dataCast2 = gcast2 -- if T :: * -> * -> *
1274 -}
1275
1276 gen_Data_binds :: DynFlags
1277 -> SrcSpan
1278 -> TyCon -- For data families, this is the
1279 -- *representation* TyCon
1280 -> (LHsBinds RdrName, -- The method bindings
1281 BagDerivStuff) -- Auxiliary bindings
1282 gen_Data_binds dflags loc rep_tc
1283 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1284 `unionBags` gcast_binds,
1285 -- Auxiliary definitions: the data type and constructors
1286 listToBag ( DerivHsBind (genDataTyCon)
1287 : map (DerivHsBind . genDataDataCon) data_cons))
1288 where
1289 data_cons = tyConDataCons rep_tc
1290 n_cons = length data_cons
1291 one_constr = n_cons == 1
1292
1293 genDataTyCon :: (LHsBind RdrName, LSig RdrName)
1294 genDataTyCon -- $dT
1295 = (mkHsVarBind loc rdr_name rhs,
1296 L loc (TypeSig [L loc rdr_name] sig_ty))
1297 where
1298 rdr_name = mk_data_type_name rep_tc
1299 sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
1300 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
1301 rhs = nlHsVar mkDataType_RDR
1302 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
1303 `nlHsApp` nlList constrs
1304
1305 genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
1306 genDataDataCon dc -- $cT1 etc
1307 = (mkHsVarBind loc rdr_name rhs,
1308 L loc (TypeSig [L loc rdr_name] sig_ty))
1309 where
1310 rdr_name = mk_constr_name dc
1311 sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
1312 rhs = nlHsApps mkConstr_RDR constr_args
1313
1314 constr_args
1315 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1316 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1317 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1318 nlList labels, -- Field labels
1319 nlHsVar fixity] -- Fixity
1320
1321 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
1322 (dataConFieldLabels dc)
1323 dc_occ = getOccName dc
1324 is_infix = isDataSymOcc dc_occ
1325 fixity | is_infix = infix_RDR
1326 | otherwise = prefix_RDR
1327
1328 ------------ gfoldl
1329 gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons)
1330
1331 gfoldl_eqn con
1332 = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1333 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1334 where
1335 con_name :: RdrName
1336 con_name = getRdrName con
1337 as_needed = take (dataConSourceArity con) as_RDRs
1338 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1339
1340 ------------ gunfold
1341 gunfold_bind = mk_HRFunBind 2 loc
1342 gunfold_RDR
1343 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1344 gunfold_rhs)]
1345
1346 gunfold_rhs
1347 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1348 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1349 (map gunfold_alt data_cons)
1350
1351 gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1352 mk_unfold_rhs dc = foldr nlHsApp
1353 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1354 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1355
1356 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1357 -- redundant test, and annoying warning
1358 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1359 | otherwise = nlConPat intDataCon_RDR
1360 [nlLitPat (HsIntPrim "" (toInteger tag))]
1361 where
1362 tag = dataConTag dc
1363
1364 ------------ toConstr
1365 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1366 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1367
1368 ------------ dataTypeOf
1369 dataTypeOf_bind = mk_easy_FunBind
1370 loc
1371 dataTypeOf_RDR
1372 [nlWildPat]
1373 (nlHsVar (mk_data_type_name rep_tc))
1374
1375 ------------ gcast1/2
1376 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1377 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1378 -- (or nothing if T has neither of these two types)
1379
1380 -- But care is needed for data families:
1381 -- If we have data family D a
1382 -- data instance D (a,b,c) = A | B deriving( Data )
1383 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1384 -- then we need dataCast1 x = gcast1 x
1385 -- because D :: * -> *
1386 -- even though rep_tc has kind * -> * -> * -> *
1387 -- Hence looking for the kind of fam_tc not rep_tc
1388 -- See Trac #4896
1389 tycon_kind = case tyConFamInst_maybe rep_tc of
1390 Just (fam_tc, _) -> tyConKind fam_tc
1391 Nothing -> tyConKind rep_tc
1392 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1393 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1394 | otherwise = emptyBag
1395 mk_gcast dataCast_RDR gcast_RDR
1396 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1397 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1398
1399
1400 kind1, kind2 :: Kind
1401 kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
1402 kind2 = liftedTypeKind `mkFunTy` kind1
1403
1404 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1405 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1406 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1407 constr_RDR, dataType_RDR,
1408 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1409 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1410 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1411 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1412 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1413 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1414 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1415 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1416 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1417 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1418 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1419 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1420 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1421 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1422 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1423 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1424 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1425 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1426 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1427 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1428 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1429
1430 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1431 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1432 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1433 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1434 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1435
1436 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1437 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1438 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1439 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1440 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1441
1442 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1443 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1444 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1445 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1446 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1447
1448 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1449 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1450 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1451 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1452 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1453
1454 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1455 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1456 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1457 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1458 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1459
1460 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1461 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1462 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1463 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1464 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1465
1466 {-
1467 ************************************************************************
1468 * *
1469 Functor instances
1470
1471 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1472
1473 * *
1474 ************************************************************************
1475
1476 For the data type:
1477
1478 data T a = T1 Int a | T2 (T a)
1479
1480 We generate the instance:
1481
1482 instance Functor T where
1483 fmap f (T1 b1 a) = T1 b1 (f a)
1484 fmap f (T2 ta) = T2 (fmap f ta)
1485
1486 Notice that we don't simply apply 'fmap' to the constructor arguments.
1487 Rather
1488 - Do nothing to an argument whose type doesn't mention 'a'
1489 - Apply 'f' to an argument of type 'a'
1490 - Apply 'fmap f' to other arguments
1491 That's why we have to recurse deeply into the constructor argument types,
1492 rather than just one level, as we typically do.
1493
1494 What about types with more than one type parameter? In general, we only
1495 derive Functor for the last position:
1496
1497 data S a b = S1 [b] | S2 (a, T a b)
1498 instance Functor (S a) where
1499 fmap f (S1 bs) = S1 (fmap f bs)
1500 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1501
1502 However, we have special cases for
1503 - tuples
1504 - functions
1505
1506 More formally, we write the derivation of fmap code over type variable
1507 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1508 instance for T is:
1509
1510 instance Functor T where
1511 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1512 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1513
1514 $(fmap 'a 'b) = \x -> x -- when b does not contain a
1515 $(fmap 'a 'a) = f
1516 $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1517 $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2
1518 $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1519
1520 For functions, the type parameter 'a can occur in a contravariant position,
1521 which means we need to derive a function like:
1522
1523 cofmap :: (a -> b) -> (f b -> f a)
1524
1525 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1526
1527 $(cofmap 'a 'b) = \x -> x -- when b does not contain a
1528 $(cofmap 'a 'a) = error "type variable in contravariant position"
1529 $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1530 $(cofmap 'a '[b]) = map $(cofmap 'a 'b)
1531 $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2
1532 $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1533
1534 Note that the code produced by $(fmap _ _) is always a higher order function,
1535 with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
1536 matching on the type, this means create a lambda function (see the (,) case above).
1537 The resulting code for fmap can look a bit weird, for example:
1538
1539 data X a = X (a,Int)
1540 -- generated instance
1541 instance Functor X where
1542 fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
1543
1544 The optimizer should be able to simplify this code by simple inlining.
1545
1546 An older version of the deriving code tried to avoid these applied
1547 lambda functions by producing a meta level function. But the function to
1548 be mapped, `f`, is a function on the code level, not on the meta level,
1549 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
1550 It is better to produce too many lambdas than to eta expand, see ticket #7436.
1551 -}
1552
1553 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1554 gen_Functor_binds loc tycon
1555 = (unitBag fmap_bind, emptyBag)
1556 where
1557 data_cons = tyConDataCons tycon
1558 fun_name = L loc fmap_RDR
1559 fmap_bind = mkRdrFunBind fun_name eqns
1560
1561 fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1562 where
1563 parts = sequence $ foldDataConArgs ft_fmap con
1564
1565 eqns | null data_cons = [mkSimpleMatch (FunRhs fun_name Prefix)
1566 [nlWildPat, nlWildPat]
1567 (error_Expr "Void fmap")]
1568 | otherwise = map fmap_eqn data_cons
1569
1570 ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1571 ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
1572 -- fmap f = \x -> x
1573 , ft_var = return f_Expr
1574 -- fmap f = f
1575 , ft_fun = \g h -> do
1576 gg <- g
1577 hh <- h
1578 mkSimpleLam2 $ \x b -> return $
1579 nlHsApp hh (nlHsApp x (nlHsApp gg b))
1580 -- fmap f = \x b -> h (x (g b))
1581 , ft_tup = \t gs -> do
1582 gg <- sequence gs
1583 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1584 -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1585 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
1586 -- fmap f = fmap g
1587 , ft_forall = \_ g -> g
1588 , ft_bad_app = panic "in other argument"
1589 , ft_co_var = panic "contravariant" }
1590
1591 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
1592 match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
1593 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1594 match_for_con = mkSimpleConMatch CaseAlt $
1595 \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 ..
1596
1597 {-
1598 Utility functions related to Functor deriving.
1599
1600 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1601 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1602 -}
1603
1604 -- Generic traversal for Functor deriving
1605 -- See Note [FFoldType and functorLikeTraverse]
1606 data FFoldType a -- Describes how to fold over a Type in a functor like way
1607 = FT { ft_triv :: a
1608 -- ^ Does not contain variable
1609 , ft_var :: a
1610 -- ^ The variable itself
1611 , ft_co_var :: a
1612 -- ^ The variable itself, contravariantly
1613 , ft_fun :: a -> a -> a
1614 -- ^ Function type
1615 , ft_tup :: TyCon -> [a] -> a
1616 -- ^ Tuple type
1617 , ft_ty_app :: Type -> a -> a
1618 -- ^ Type app, variable only in last argument
1619 , ft_bad_app :: a
1620 -- ^ Type app, variable other than in last argument
1621 , ft_forall :: TcTyVar -> a -> a
1622 -- ^ Forall type
1623 }
1624
1625 functorLikeTraverse :: forall a.
1626 TyVar -- ^ Variable to look for
1627 -> FFoldType a -- ^ How to fold
1628 -> Type -- ^ Type to process
1629 -> a
1630 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1631 , ft_co_var = caseCoVar, ft_fun = caseFun
1632 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1633 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1634 ty
1635 = fst (go False ty)
1636 where
1637 go :: Bool -- Covariant or contravariant context
1638 -> Type
1639 -> (a, Bool) -- (result of type a, does type contain var)
1640
1641 go co ty | Just ty' <- coreView ty = go co ty'
1642 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1643 go co (ForAllTy (Anon x) y) | isPredTy x = go co y
1644 | xc || yc = (caseFun xr yr,True)
1645 where (xr,xc) = go (not co) x
1646 (yr,yc) = go co y
1647 go co (AppTy x y) | xc = (caseWrongArg, True)
1648 | yc = (caseTyApp x yr, True)
1649 where (_, xc) = go co x
1650 (yr,yc) = go co y
1651 go co ty@(TyConApp con args)
1652 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
1653 -- At this point we know that xrs, xcs is not empty,
1654 -- and at least one xr is True
1655 | isTupleTyCon con = (caseTuple con xrs, True)
1656 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
1657 | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty
1658 = (caseTyApp fun_ty (last xrs), True)
1659 | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
1660 where
1661 (xrs,xcs) = unzip (map (go co) args)
1662 go _ (ForAllTy (Named _ Visible) _) = panic "unexpected visible binder"
1663 go co (ForAllTy (Named v _) x) | v /= var && xc = (caseForAll v xr,True)
1664 where (xr,xc) = go co x
1665
1666 go _ _ = (caseTrivial,False)
1667
1668 -- Return all syntactic subterms of ty that contain var somewhere
1669 -- These are the things that should appear in instance constraints
1670 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1671 deepSubtypesContaining tv
1672 = functorLikeTraverse tv
1673 (FT { ft_triv = []
1674 , ft_var = []
1675 , ft_fun = (++)
1676 , ft_tup = \_ xs -> concat xs
1677 , ft_ty_app = (:)
1678 , ft_bad_app = panic "in other argument"
1679 , ft_co_var = panic "contravariant"
1680 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
1681
1682
1683 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1684 -- Fold over the arguments of the datacon
1685 foldDataConArgs ft con
1686 = map foldArg (dataConOrigArgTys con)
1687 where
1688 foldArg
1689 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
1690 Just tv -> functorLikeTraverse tv ft
1691 Nothing -> const (ft_triv ft)
1692 -- If we are deriving Foldable for a GADT, there is a chance that the last
1693 -- type variable in the data type isn't actually a type variable at all.
1694 -- (for example, this can happen if the last type variable is refined to
1695 -- be a concrete type such as Int). If the last type variable is refined
1696 -- to be a specific type, then getTyVar_maybe will return Nothing.
1697 -- See Note [DeriveFoldable with ExistentialQuantification]
1698 --
1699 -- The kind checks have ensured the last type parameter is of kind *.
1700
1701 -- Make a HsLam using a fresh variable from a State monad
1702 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1703 -> State [RdrName] (LHsExpr RdrName)
1704 -- (mkSimpleLam fn) returns (\x. fn(x))
1705 mkSimpleLam lam = do
1706 (n:names) <- get
1707 put names
1708 body <- lam (nlHsVar n)
1709 return (mkHsLam [nlVarPat n] body)
1710
1711 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
1712 -> State [RdrName] (LHsExpr RdrName))
1713 -> State [RdrName] (LHsExpr RdrName)
1714 mkSimpleLam2 lam = do
1715 (n1:n2:names) <- get
1716 put names
1717 body <- lam (nlHsVar n1) (nlHsVar n2)
1718 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1719
1720 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1721 --
1722 -- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
1723 -- which the LHS pattern-matches on @extra_pats@, followed by a match on the
1724 -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
1725 -- and its arguments, applying an expression (from @insides@) to each of the
1726 -- respective arguments of @con@.
1727 mkSimpleConMatch :: Monad m => HsMatchContext RdrName
1728 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1729 -> [LPat RdrName]
1730 -> DataCon
1731 -> [LHsExpr RdrName]
1732 -> m (LMatch RdrName (LHsExpr RdrName))
1733 mkSimpleConMatch ctxt fold extra_pats con insides = do
1734 let con_name = getRdrName con
1735 let vars_needed = takeList insides as_RDRs
1736 let pat = nlConVarPat con_name vars_needed
1737 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1738 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
1739 (noLoc emptyLocalBinds)
1740
1741 -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
1742 --
1743 -- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
1744 -- 'mkSimpleConMatch', with two key differences:
1745 --
1746 -- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
1747 -- @[LHsExpr RdrName]@. This is because it filters out the expressions
1748 -- corresponding to arguments whose types do not mention the last type
1749 -- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
1750 -- 'Nothing' elements of @insides@).
1751 --
1752 -- 2. @fold@ takes an expression as its first argument instead of a
1753 -- constructor name. This is because it uses a specialized
1754 -- constructor function expression that only takes as many parameters as
1755 -- there are argument types that mention the last type variable.
1756 --
1757 -- See Note [Generated code for DeriveFoldable and DeriveTraversable]
1758 mkSimpleConMatch2 :: Monad m
1759 => HsMatchContext RdrName
1760 -> (LHsExpr RdrName -> [LHsExpr RdrName]
1761 -> m (LHsExpr RdrName))
1762 -> [LPat RdrName]
1763 -> DataCon
1764 -> [Maybe (LHsExpr RdrName)]
1765 -> m (LMatch RdrName (LHsExpr RdrName))
1766 mkSimpleConMatch2 ctxt fold extra_pats con insides = do
1767 let con_name = getRdrName con
1768 vars_needed = takeList insides as_RDRs
1769 pat = nlConVarPat con_name vars_needed
1770 -- Make sure to zip BEFORE invoking catMaybes. We want the variable
1771 -- indicies in each expression to match up with the argument indices
1772 -- in con_expr (defined below).
1773 exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i)
1774 insides (map nlHsVar vars_needed)
1775 -- An element of argTysTyVarInfo is True if the constructor argument
1776 -- with the same index has a type which mentions the last type
1777 -- variable.
1778 argTysTyVarInfo = map isJust insides
1779 (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs
1780
1781 con_expr
1782 | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar
1783 | otherwise =
1784 let bs = filterByList argTysTyVarInfo bs_RDRs
1785 vars = filterByLists argTysTyVarInfo
1786 (map nlHsVar bs_RDRs)
1787 (map nlHsVar as_RDRs)
1788 in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
1789
1790 rhs <- fold con_expr exps
1791 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
1792 (noLoc emptyLocalBinds)
1793
1794 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1795 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1796 -> m (LMatch RdrName (LHsExpr RdrName)))
1797 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1798 mkSimpleTupleCase match_for_con tc insides x
1799 = do { let data_con = tyConSingleDataCon tc
1800 ; match <- match_for_con [] data_con insides
1801 ; return $ nlHsCase x [match] }
1802
1803 {-
1804 ************************************************************************
1805 * *
1806 Foldable instances
1807
1808 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1809
1810 * *
1811 ************************************************************************
1812
1813 Deriving Foldable instances works the same way as Functor instances,
1814 only Foldable instances are not possible for function types at all.
1815 Given (data T a = T a a (T a) deriving Foldable), we get:
1816
1817 instance Foldable T where
1818 foldr f z (T x1 x2 x3) =
1819 $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
1820
1821 -XDeriveFoldable is different from -XDeriveFunctor in that it filters out
1822 arguments to the constructor that would produce useless code in a Foldable
1823 instance. For example, the following datatype:
1824
1825 data Foo a = Foo Int a Int deriving Foldable
1826
1827 would have the following generated Foldable instance:
1828
1829 instance Foldable Foo where
1830 foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
1831
1832 since neither of the two Int arguments are folded over.
1833
1834 The cases are:
1835
1836 $(foldr 'a 'a) = f
1837 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1838 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
1839
1840 Note that the arguments to the real foldr function are the wrong way around,
1841 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1842
1843 One can envision a case for types that don't contain the last type variable:
1844
1845 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
1846
1847 But this case will never materialize, since the aforementioned filtering
1848 removes all such types from consideration.
1849 See Note [Generated code for DeriveFoldable and DeriveTraversable].
1850
1851 Foldable instances differ from Functor and Traversable instances in that
1852 Foldable instances can be derived for data types in which the last type
1853 variable is existentially quantified. In particular, if the last type variable
1854 is refined to a more specific type in a GADT:
1855
1856 data GADT a where
1857 G :: a ~ Int => a -> G Int
1858
1859 then the deriving machinery does not attempt to check that the type a contains
1860 Int, since it is not syntactically equal to a type variable. That is, the
1861 derived Foldable instance for GADT is:
1862
1863 instance Foldable GADT where
1864 foldr _ z (GADT _) = z
1865
1866 See Note [DeriveFoldable with ExistentialQuantification].
1867
1868 -}
1869
1870 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1871 gen_Foldable_binds loc tycon
1872 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1873 where
1874 data_cons = tyConDataCons tycon
1875
1876 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1877 eqns = map foldr_eqn data_cons
1878 foldr_eqn con
1879 = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1880 where
1881 parts = sequence $ foldDataConArgs ft_foldr con
1882
1883 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1884 foldMap_eqn con
1885 = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1886 where
1887 parts = sequence $ foldDataConArgs ft_foldMap con
1888
1889 -- Yields 'Just' an expression if we're folding over a type that mentions
1890 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
1891 -- See Note [FFoldType and functorLikeTraverse]
1892 ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
1893 ft_foldr
1894 = FT { ft_triv = return Nothing
1895 -- foldr f = \x z -> z
1896 , ft_var = return $ Just f_Expr
1897 -- foldr f = f
1898 , ft_tup = \t g -> do
1899 gg <- sequence g
1900 lam <- mkSimpleLam2 $ \x z ->
1901 mkSimpleTupleCase (match_foldr z) t gg x
1902 return (Just lam)
1903 -- foldr f = (\x z -> case x of ...)
1904 , ft_ty_app = \_ g -> do
1905 gg <- g
1906 mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
1907 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
1908 -- foldr f = (\x z -> foldr g z x)
1909 , ft_forall = \_ g -> g
1910 , ft_co_var = panic "contravariant"
1911 , ft_fun = panic "function"
1912 , ft_bad_app = panic "in other argument" }
1913
1914 match_foldr :: LHsExpr RdrName
1915 -> [LPat RdrName]
1916 -> DataCon
1917 -> [Maybe (LHsExpr RdrName)]
1918 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1919 match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
1920 where
1921 -- g1 v1 (g2 v2 (.. z))
1922 mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName
1923 mkFoldr = foldr nlHsApp z
1924
1925 -- See Note [FFoldType and functorLikeTraverse]
1926 ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
1927 ft_foldMap
1928 = FT { ft_triv = return Nothing
1929 -- foldMap f = \x -> mempty
1930 , ft_var = return (Just f_Expr)
1931 -- foldMap f = f
1932 , ft_tup = \t g -> do
1933 gg <- sequence g
1934 lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
1935 return (Just lam)
1936 -- foldMap f = \x -> case x of (..,)
1937 , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
1938 -- foldMap f = foldMap g
1939 , ft_forall = \_ g -> g
1940 , ft_co_var = panic "contravariant"
1941 , ft_fun = panic "function"
1942 , ft_bad_app = panic "in other argument" }
1943
1944 match_foldMap :: [LPat RdrName]
1945 -> DataCon
1946 -> [Maybe (LHsExpr RdrName)]
1947 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1948 match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
1949 where
1950 -- mappend v1 (mappend v2 ..)
1951 mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName
1952 mkFoldMap [] = mempty_Expr
1953 mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
1954
1955 {-
1956 ************************************************************************
1957 * *
1958 Traversable instances
1959
1960 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1961 * *
1962 ************************************************************************
1963
1964 Again, Traversable is much like Functor and Foldable.
1965
1966 The cases are:
1967
1968 $(traverse 'a 'a) = f
1969 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1970 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
1971
1972 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
1973 do not mention the last type parameter. Therefore, the following datatype:
1974
1975 data Foo a = Foo Int a Int
1976
1977 would have the following derived Traversable instance:
1978
1979 instance Traversable Foo where
1980 traverse f (Foo x1 x2 x3) =
1981 fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
1982
1983 since the two Int arguments do not produce any effects in a traversal.
1984
1985 One can envision a case for types that do not mention the last type parameter:
1986
1987 $(traverse 'a 'b) = pure -- when b does not contain a
1988
1989 But this case will never materialize, since the aforementioned filtering
1990 removes all such types from consideration.
1991 See Note [Generated code for DeriveFoldable and DeriveTraversable].
1992 -}
1993
1994 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1995 gen_Traversable_binds loc tycon
1996 = (unitBag traverse_bind, emptyBag)
1997 where
1998 data_cons = tyConDataCons tycon
1999
2000 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
2001 eqns = map traverse_eqn data_cons
2002 traverse_eqn con
2003 = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
2004 where
2005 parts = sequence $ foldDataConArgs ft_trav con
2006
2007 -- Yields 'Just' an expression if we're folding over a type that mentions
2008 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
2009 -- See Note [FFoldType and functorLikeTraverse]
2010 ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
2011 ft_trav
2012 = FT { ft_triv = return Nothing
2013 -- traverse f = pure x
2014 , ft_var = return (Just f_Expr)
2015 -- traverse f = f x
2016 , ft_tup = \t gs -> do
2017 gg <- sequence gs
2018 lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
2019 return (Just lam)
2020 -- traverse f = \x -> case x of (a1,a2,..) ->
2021 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
2022 , ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
2023 -- traverse f = traverse g
2024 , ft_forall = \_ g -> g
2025 , ft_co_var = panic "contravariant"
2026 , ft_fun = panic "function"
2027 , ft_bad_app = panic "in other argument" }
2028
2029 -- Con a1 a2 ... -> fmap (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
2030 -- <*> g2 a2 <*> ...
2031 match_for_con :: [LPat RdrName]
2032 -> DataCon
2033 -> [Maybe (LHsExpr RdrName)]
2034 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
2035 match_for_con = mkSimpleConMatch2 CaseAlt $
2036 \con xs -> return (mkApCon con xs)
2037 where
2038 -- fmap (\b1 b2 ... -> Con b1 b2 ...) x1 <*> x2 <*> ..
2039 mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
2040 mkApCon con [] = nlHsApps pure_RDR [con]
2041 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
2042 where appAp x y = nlHsApps ap_RDR [x,y]
2043
2044 {-
2045 ************************************************************************
2046 * *
2047 Lift instances
2048 * *
2049 ************************************************************************
2050
2051 Example:
2052
2053 data Foo a = Foo a | a :^: a deriving Lift
2054
2055 ==>
2056
2057 instance (Lift a) => Lift (Foo a) where
2058 lift (Foo a)
2059 = appE
2060 (conE
2061 (mkNameG_d "package-name" "ModuleName" "Foo"))
2062 (lift a)
2063 lift (u :^: v)
2064 = infixApp
2065 (lift u)
2066 (conE
2067 (mkNameG_d "package-name" "ModuleName" ":^:"))
2068 (lift v)
2069
2070 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
2071 'Foo would be when using the -XTemplateHaskell extension. To make sure that
2072 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
2073 makeG_d.
2074 -}
2075
2076 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
2077 gen_Lift_binds loc tycon
2078 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
2079 [mkMatch (FunRhs (L loc lift_RDR) Prefix)
2080 [nlWildPat] errorMsg_Expr
2081 (noLoc emptyLocalBinds)])
2082 , emptyBag)
2083 | otherwise = (unitBag lift_bind, emptyBag)
2084 where
2085 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
2086 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
2087
2088 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
2089 data_cons = tyConDataCons tycon
2090 tycon_str = occNameString . nameOccName . tyConName $ tycon
2091
2092 pats_etc data_con
2093 = ([con_pat], lift_Expr)
2094 where
2095 con_pat = nlConVarPat data_con_RDR as_needed
2096 data_con_RDR = getRdrName data_con
2097 con_arity = dataConSourceArity data_con
2098 as_needed = take con_arity as_RDRs
2099 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
2100 tys_needed as_needed
2101 tycon_name = tyConName tycon
2102 is_infix = dataConIsInfix data_con
2103 tys_needed = dataConOrigArgTys data_con
2104
2105 mk_lift_app ty a
2106 | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
2107 (nlHsVar a)
2108 | otherwise = nlHsApp (nlHsVar litE_RDR)
2109 (primLitOp (mkBoxExp (nlHsVar a)))
2110 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
2111
2112 pkg_name = unitIdString . moduleUnitId
2113 . nameModule $ tycon_name
2114 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
2115 con_name = occNameString . nameOccName . dataConName $ data_con
2116
2117 conE_Expr = nlHsApp (nlHsVar conE_RDR)
2118 (nlHsApps mkNameG_dRDR
2119 (map (nlHsLit . mkHsString)
2120 [pkg_name, mod_name, con_name]))
2121
2122 lift_Expr
2123 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
2124 | otherwise = foldl mk_appE_app conE_Expr lifted_as
2125 (a1:a2:_) = lifted_as
2126
2127 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2128 mk_appE_app a b = nlHsApps appE_RDR [a, b]
2129
2130 {-
2131 ************************************************************************
2132 * *
2133 Newtype-deriving instances
2134 * *
2135 ************************************************************************
2136
2137 Note [Newtype-deriving instances]
2138 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2139 We take every method in the original instance and `coerce` it to fit
2140 into the derived instance. We need a type annotation on the argument
2141 to `coerce` to make it obvious what instantiation of the method we're
2142 coercing from. So from, say,
2143 class C a b where
2144 op :: a -> [b] -> Int
2145
2146 newtype T x = MkT <rep-ty>
2147
2148 instance C a <rep-ty> => C a (T x) where
2149 op = (coerce
2150 (op :: a -> [<rep-ty>] -> Int)
2151 ) :: a -> [T x] -> Int
2152
2153 Notice that we give the 'coerce' call two type signatures: one to
2154 fix the of the inner call, and one for the expected type. The outer
2155 type signature ought to be redundant, but may improve error messages.
2156 The inner one is essential to fix the type at which 'op' is called.
2157
2158 See #8503 for more discussion.
2159
2160 Here's a wrinkle. Supppose 'op' is locally overloaded:
2161
2162 class C2 b where
2163 op2 :: forall a. Eq a => a -> [b] -> Int
2164
2165 Then we could do exactly as above, but it's a bit redundant to
2166 instantiate op, then re-generalise with the inner signature.
2167 (The inner sig is only there to fix the type at which 'op' is
2168 called.) So we just instantiate the signature, and add
2169
2170 instance C2 <rep-ty> => C2 (T x) where
2171 op2 = (coerce
2172 (op2 :: a -> [<rep-ty>] -> Int)
2173 ) :: forall a. Eq a => a -> [T x] -> Int
2174 -}
2175
2176 gen_Newtype_binds :: SrcSpan
2177 -> Class -- the class being derived
2178 -> [TyVar] -- the tvs in the instance head
2179 -> [Type] -- instance head parameters (incl. newtype)
2180 -> Type -- the representation type (already eta-reduced)
2181 -> LHsBinds RdrName
2182 -- See Note [Newtype-deriving instances]
2183 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
2184 = listToBag $ map mk_bind (classMethods cls)
2185 where
2186 coerce_RDR = getRdrName coerceId
2187
2188 mk_bind :: Id -> LHsBind RdrName
2189 mk_bind meth_id
2190 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
2191 (FunRhs (L loc meth_RDR) Prefix)
2192 [] rhs_expr]
2193 where
2194 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty meth_id
2195
2196 -- See "wrinkle" in Note [Newtype-deriving instances]
2197 (_, _, from_ty') = tcSplitSigmaTy from_ty
2198
2199 meth_RDR = getRdrName meth_id
2200
2201 rhs_expr = ( nlHsVar coerce_RDR
2202 `nlHsApp`
2203 (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType from_ty'))
2204 `nlExprWithTySig` toLHsSigWcType to_ty
2205
2206
2207 nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
2208 nlExprWithTySig e s = noLoc (ExprWithTySig e s)
2209
2210 mkCoerceClassMethEqn :: Class -- the class being derived
2211 -> [TyVar] -- the tvs in the instance head
2212 -> [Type] -- instance head parameters (incl. newtype)
2213 -> Type -- the representation type (already eta-reduced)
2214 -> Id -- the method to look at
2215 -> Pair Type
2216 -- See Note [Newtype-deriving instances]
2217 -- The pair is the (from_type, to_type), where to_type is
2218 -- the type of the method we are tyrying to get
2219 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
2220 = Pair (substTy rhs_subst user_meth_ty)
2221 (substTy lhs_subst user_meth_ty)
2222 where
2223 cls_tvs = classTyVars cls
2224 in_scope = mkInScopeSet $ mkVarSet inst_tvs
2225 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
2226 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
2227 (_class_tvs, _class_constraint, user_meth_ty)
2228 = tcSplitMethodTy (varType id)
2229
2230 changeLast :: [a] -> a -> [a]
2231 changeLast [] _ = panic "changeLast"
2232 changeLast [_] x = [x]
2233 changeLast (x:xs) x' = x : changeLast xs x'
2234
2235 {-
2236 ************************************************************************
2237 * *
2238 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
2239 * *
2240 ************************************************************************
2241
2242 \begin{verbatim}
2243 data Foo ... = ...
2244
2245 con2tag_Foo :: Foo ... -> Int#
2246 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2247 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2248 \end{verbatim}
2249
2250 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2251 fiddling around.
2252 -}
2253
2254 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
2255 genAuxBindSpec loc (DerivCon2Tag tycon)
2256 = (mk_FunBind loc rdr_name eqns,
2257 L loc (TypeSig [L loc rdr_name] sig_ty))
2258 where
2259 rdr_name = con2tag_RDR tycon
2260
2261 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
2262 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
2263 mkParentType tycon `mkFunTy` intPrimTy
2264
2265 lots_of_constructors = tyConFamilySize tycon > 8
2266 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
2267 -- but we don't do vectored returns any more.
2268
2269 eqns | lots_of_constructors = [get_tag_eqn]
2270 | otherwise = map mk_eqn (tyConDataCons tycon)
2271
2272 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
2273
2274 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
2275 mk_eqn con = ([nlWildConPat con],
2276 nlHsLit (HsIntPrim ""
2277 (toInteger ((dataConTag con) - fIRST_TAG))))
2278
2279 genAuxBindSpec loc (DerivTag2Con tycon)
2280 = (mk_FunBind loc rdr_name
2281 [([nlConVarPat intDataCon_RDR [a_RDR]],
2282 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2283 L loc (TypeSig [L loc rdr_name] sig_ty))
2284 where
2285 sig_ty = mkLHsSigWcType $ L loc $
2286 HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
2287 intTy `mkFunTy` mkParentType tycon
2288
2289 rdr_name = tag2con_RDR tycon
2290
2291 genAuxBindSpec loc (DerivMaxTag tycon)
2292 = (mkHsVarBind loc rdr_name rhs,
2293 L loc (TypeSig [L loc rdr_name] sig_ty))
2294 where
2295 rdr_name = maxtag_RDR tycon
2296 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
2297 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2298 max_tag = case (tyConDataCons tycon) of
2299 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2300
2301 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
2302 ( Bag (LHsBind RdrName, LSig RdrName)
2303 -- Extra bindings (used by Generic only)
2304 , Bag (FamInst) -- Extra family instances
2305 , Bag (InstInfo RdrName)) -- Extra instances
2306
2307 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2308 genAuxBinds loc b = genAuxBinds' b2 where
2309 (b1,b2) = partitionBagWith splitDerivAuxBind b
2310 splitDerivAuxBind (DerivAuxBind x) = Left x
2311 splitDerivAuxBind x = Right x
2312
2313 rm_dups = foldrBag dup_check emptyBag
2314 dup_check a b = if anyBag (== a) b then b else consBag a b
2315
2316 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2317 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2318 , emptyBag, emptyBag)
2319 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2320 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2321 f (DerivHsBind b) = add1 b
2322 f (DerivFamInst t) = add2 t
2323 f (DerivInst i) = add3 i
2324
2325 add1 x (a,b,c) = (x `consBag` a,b,c)
2326 add2 x (a,b,c) = (a,x `consBag` b,c)
2327 add3 x (a,b,c) = (a,b,x `consBag` c)
2328
2329 mk_data_type_name :: TyCon -> RdrName -- "$tT"
2330 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
2331
2332 mk_constr_name :: DataCon -> RdrName -- "$cC"
2333 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
2334
2335 mkParentType :: TyCon -> Type
2336 -- Turn the representation tycon of a family into
2337 -- a use of its family constructor
2338 mkParentType tc
2339 = case tyConFamInst_maybe tc of
2340 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2341 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2342
2343 {-
2344 ************************************************************************
2345 * *
2346 \subsection{Utility bits for generating bindings}
2347 * *
2348 ************************************************************************
2349 -}
2350
2351 mk_FunBind :: SrcSpan -> RdrName
2352 -> [([LPat RdrName], LHsExpr RdrName)]
2353 -> LHsBind RdrName
2354 mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind,
2355 -- the caller says that the Void case needs no
2356 -- patterns
2357
2358 -- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before
2359 -- the "=" in the empty-data-decl case. This is necessary if the function
2360 -- has a higher-rank type, like foldl. (See deriving/should_compile/T4302)
2361 mk_HRFunBind :: Arity -> SrcSpan -> RdrName
2362 -> [([LPat RdrName], LHsExpr RdrName)]
2363 -> LHsBind RdrName
2364 mk_HRFunBind arity loc fun pats_and_exprs
2365 = mkHRRdrFunBind arity (L loc fun) matches
2366 where
2367 matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
2368 (noLoc emptyLocalBinds)
2369 | (p,e) <-pats_and_exprs]
2370
2371 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2372 mkRdrFunBind = mkHRRdrFunBind 0
2373
2374 mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2375 mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2376 where
2377 -- Catch-all eqn looks like
2378 -- fmap = error "Void fmap"
2379 -- It's needed if there no data cons at all,
2380 -- which can happen with -XEmptyDataDecls
2381 -- See Trac #4302
2382 matches' = if null matches
2383 then [mkMatch (FunRhs fun Prefix)
2384 (replicate arity nlWildPat)
2385 (error_Expr str) (noLoc emptyLocalBinds)]
2386 else matches
2387 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2388
2389 box :: String -- The class involved
2390 -> TyCon -- The tycon involved
2391 -> LHsExpr RdrName -- The argument
2392 -> Type -- The argument type
2393 -> LHsExpr RdrName -- Boxed version of the arg
2394 -- See Note [Deriving and unboxed types] in TcDeriv
2395 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2396 where
2397 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2398
2399 ---------------------
2400 primOrdOps :: String -- The class involved
2401 -> TyCon -- The tycon involved
2402 -> Type -- The type
2403 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2404 -- See Note [Deriving and unboxed types] in TcDeriv
2405 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2406
2407 primLitOps :: String -- The class involved
2408 -> TyCon -- The tycon involved
2409 -> Type -- The type
2410 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
2411 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
2412 )
2413 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2414 , \v -> nlHsVar boxRDR `nlHsApp` v
2415 )
2416 where
2417 boxRDR
2418 | ty `eqType` addrPrimTy = unpackCString_RDR
2419 | otherwise = assoc_ty_id str tycon boxConTbl ty
2420
2421 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2422 ordOpTbl
2423 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2424 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2425 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2426 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2427 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2428 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2429
2430 boxConTbl :: [(Type, RdrName)]
2431 boxConTbl
2432 = [(charPrimTy , getRdrName charDataCon )
2433 ,(intPrimTy , getRdrName intDataCon )
2434 ,(wordPrimTy , getRdrName wordDataCon )
2435 ,(floatPrimTy , getRdrName floatDataCon )
2436 ,(doublePrimTy, getRdrName doubleDataCon)
2437 ]
2438
2439 -- | A table of postfix modifiers for unboxed values.
2440 postfixModTbl :: [(Type, String)]
2441 postfixModTbl
2442 = [(charPrimTy , "#" )
2443 ,(intPrimTy , "#" )
2444 ,(wordPrimTy , "##")
2445 ,(floatPrimTy , "#" )
2446 ,(doublePrimTy, "##")
2447 ]
2448
2449 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
2450 litConTbl
2451 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2452 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2453 . nlHsApp (nlHsVar toInteger_RDR))
2454 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2455 . nlHsApp (nlHsVar toInteger_RDR))
2456 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2457 . nlHsApp (nlHsApp
2458 (nlHsVar map_RDR)
2459 (compose_RDR `nlHsApps`
2460 [ nlHsVar fromIntegral_RDR
2461 , nlHsVar fromEnum_RDR
2462 ])))
2463 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2464 . nlHsApp (nlHsVar toRational_RDR))
2465 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2466 . nlHsApp (nlHsVar toRational_RDR))
2467 ]
2468
2469 -- | Lookup `Type` in an association list.
2470 assoc_ty_id :: String -- The class involved
2471 -> TyCon -- The tycon involved
2472 -> [(Type,a)] -- The table
2473 -> Type -- The type
2474 -> a -- The result of the lookup
2475 assoc_ty_id cls_str _ tbl ty
2476 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2477 text "for primitive type" <+> ppr ty)
2478 | otherwise = head res
2479 where
2480 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2481
2482 -----------------------------------------------------------------------
2483
2484 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2485 and_Expr a b = genOpApp a and_RDR b
2486
2487 -----------------------------------------------------------------------
2488
2489 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2490 eq_Expr tycon ty a b
2491 | not (isUnliftedType ty) = genOpApp a eq_RDR b
2492 | otherwise = genPrimOpApp a prim_eq b
2493 where
2494 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2495
2496 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2497 untag_Expr _ [] expr = expr
2498 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2499 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2500 [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2501
2502 enum_from_to_Expr
2503 :: LHsExpr RdrName -> LHsExpr RdrName
2504 -> LHsExpr RdrName
2505 enum_from_then_to_Expr
2506 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2507 -> LHsExpr RdrName
2508
2509 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2510 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2511
2512 showParen_Expr
2513 :: LHsExpr RdrName -> LHsExpr RdrName
2514 -> LHsExpr RdrName
2515
2516 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2517
2518 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2519
2520 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2521 nested_compose_Expr [e] = parenify e
2522 nested_compose_Expr (e:es)
2523 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2524
2525 -- impossible_Expr is used in case RHSs that should never happen.
2526 -- We generate these to keep the desugarer from complaining that they *might* happen!
2527 error_Expr :: String -> LHsExpr RdrName
2528 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2529
2530 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2531 -- method. It is currently only used by Enum.{succ,pred}
2532 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2533 illegal_Expr meth tp msg =
2534 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2535
2536 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2537 -- to include the value of a_RDR in the error string.
2538 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2539 illegal_toEnum_tag tp maxtag =
2540 nlHsApp (nlHsVar error_RDR)
2541 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2542 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2543 (nlHsApp (nlHsApp (nlHsApp
2544 (nlHsVar showsPrec_RDR)
2545 (nlHsIntLit 0))
2546 (nlHsVar a_RDR))
2547 (nlHsApp (nlHsApp
2548 (nlHsVar append_RDR)
2549 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2550 (nlHsApp (nlHsApp (nlHsApp
2551 (nlHsVar showsPrec_RDR)
2552 (nlHsIntLit 0))
2553 (nlHsVar maxtag))
2554 (nlHsLit (mkHsString ")"))))))
2555
2556 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2557 parenify e@(L _ (HsVar _)) = e
2558 parenify e = mkHsPar e
2559
2560 -- genOpApp wraps brackets round the operator application, so that the
2561 -- renamer won't subsequently try to re-associate it.
2562 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2563 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2564
2565 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2566 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2567
2568 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2569 :: RdrName
2570 a_RDR = mkVarUnqual (fsLit "a")
2571 b_RDR = mkVarUnqual (fsLit "b")
2572 c_RDR = mkVarUnqual (fsLit "c")
2573 d_RDR = mkVarUnqual (fsLit "d")
2574 f_RDR = mkVarUnqual (fsLit "f")
2575 k_RDR = mkVarUnqual (fsLit "k")
2576 z_RDR = mkVarUnqual (fsLit "z")
2577 ah_RDR = mkVarUnqual (fsLit "a#")
2578 bh_RDR = mkVarUnqual (fsLit "b#")
2579 ch_RDR = mkVarUnqual (fsLit "c#")
2580 dh_RDR = mkVarUnqual (fsLit "d#")
2581
2582 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2583 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2584 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2585 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2586
2587 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2588 false_Expr, true_Expr, fmap_Expr,
2589 mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2590 a_Expr = nlHsVar a_RDR
2591 -- b_Expr = nlHsVar b_RDR
2592 c_Expr = nlHsVar c_RDR
2593 f_Expr = nlHsVar f_RDR
2594 z_Expr = nlHsVar z_RDR
2595 ltTag_Expr = nlHsVar ltTag_RDR
2596 eqTag_Expr = nlHsVar eqTag_RDR
2597 gtTag_Expr = nlHsVar gtTag_RDR
2598 false_Expr = nlHsVar false_RDR
2599 true_Expr = nlHsVar true_RDR
2600 fmap_Expr = nlHsVar fmap_RDR
2601 -- pure_Expr = nlHsVar pure_RDR
2602 mempty_Expr = nlHsVar mempty_RDR
2603 foldMap_Expr = nlHsVar foldMap_RDR
2604 traverse_Expr = nlHsVar traverse_RDR
2605
2606 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2607 a_Pat = nlVarPat a_RDR
2608 b_Pat = nlVarPat b_RDR
2609 c_Pat = nlVarPat c_RDR
2610 d_Pat = nlVarPat d_RDR
2611 f_Pat = nlVarPat f_RDR
2612 k_Pat = nlVarPat k_RDR
2613 z_Pat = nlVarPat z_RDR
2614
2615 minusInt_RDR, tagToEnum_RDR :: RdrName
2616 minusInt_RDR = getRdrName (primOpId IntSubOp )
2617 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2618
2619 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2620 -- Generates Orig s RdrName, for the binding positions
2621 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2622 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2623 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2624
2625 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2626 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2627
2628 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2629 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2630 -- See Note [Auxiliary binders]
2631 mkAuxBinderName parent occ_fun
2632 = mkRdrUnqual (occ_fun stable_parent_occ)
2633 where
2634 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2635 stable_string
2636 | opt_PprStyle_Debug = parent_stable
2637 | otherwise = parent_stable_hash
2638 parent_stable = nameStableString parent
2639 parent_stable_hash =
2640 let Fingerprint high low = fingerprintString parent_stable
2641 in toBase62 high ++ toBase62Padded low
2642 -- See Note [Base 62 encoding 128-bit integers]
2643 parent_occ = nameOccName parent
2644
2645
2646 {-
2647 Note [Auxiliary binders]
2648 ~~~~~~~~~~~~~~~~~~~~~~~~
2649 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2650
2651 instance Ord T where
2652 compare a b = $con2tag a `compare` $con2tag b
2653
2654 $con2tag :: T -> Int
2655 $con2tag = ...code....
2656
2657 Of course these top-level bindings should all have distinct name, and we are
2658 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2659 because with standalone deriving two imported TyCons might both be called T!
2660 (See Trac #7947.)
2661
2662 So we use package name, module name and the name of the parent
2663 (T in this example) as part of the OccName we generate for the new binding.
2664 To make the symbol names short we take a base62 hash of the full name.
2665
2666 In the past we used the *unique* from the parent, but that's not stable across
2667 recompilations as uniques are nondeterministic.
2668
2669 Note [DeriveFoldable with ExistentialQuantification]
2670 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2671 Functor and Traversable instances can only be derived for data types whose
2672 last type parameter is truly universally polymorphic. For example:
2673
2674 data T a b where
2675 T1 :: b -> T a b -- YES, b is unconstrained
2676 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
2677 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
2678 T4 :: Int -> T a Int -- NO, this is just like T3
2679 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
2680 -- though a is existential
2681 T6 :: Int -> T Int b -- YES, b is unconstrained
2682
2683 For Foldable instances, however, we can completely lift the constraint that
2684 the last type parameter be truly universally polymorphic. This means that T
2685 (as defined above) can have a derived Foldable instance:
2686
2687 instance Foldable (T a) where
2688 foldr f z (T1 b) = f b z
2689 foldr f z (T2 b) = f b z
2690 foldr f z (T3 b) = f b z
2691 foldr f z (T4 b) = z
2692 foldr f z (T5 a b) = f b z
2693 foldr f z (T6 a) = z
2694
2695 foldMap f (T1 b) = f b
2696 foldMap f (T2 b) = f b
2697 foldMap f (T3 b) = f b
2698 foldMap f (T4 b) = mempty
2699 foldMap f (T5 a b) = f b
2700 foldMap f (T6 a) = mempty
2701
2702 In a Foldable instance, it is safe to fold over an occurrence of the last type
2703 parameter that is not truly universally polymorphic. However, there is a bit
2704 of subtlety in determining what is actually an occurrence of a type parameter.
2705 T3 and T4, as defined above, provide one example:
2706
2707 data T a b where
2708 ...
2709 T3 :: b ~ Int => b -> T a b
2710 T4 :: Int -> T a Int
2711 ...
2712
2713 instance Foldable (T a) where
2714 ...
2715 foldr f z (T3 b) = f b z
2716 foldr f z (T4 b) = z
2717 ...
2718 foldMap f (T3 b) = f b
2719 foldMap f (T4 b) = mempty
2720 ...
2721
2722 Notice that the argument of T3 is folded over, whereas the argument of T4 is
2723 not. This is because we only fold over constructor arguments that
2724 syntactically mention the universally quantified type parameter of that
2725 particular data constructor. See foldDataConArgs for how this is implemented.
2726
2727 As another example, consider the following data type. The argument of each
2728 constructor has the same type as the last type parameter:
2729
2730 data E a where
2731 E1 :: (a ~ Int) => a -> E a
2732 E2 :: Int -> E Int
2733 E3 :: (a ~ Int) => a -> E Int
2734 E4 :: (a ~ Int) => Int -> E a
2735
2736 Only E1's argument is an occurrence of a universally quantified type variable
2737 that is syntactically equivalent to the last type parameter, so only E1's
2738 argument will be be folded over in a derived Foldable instance.
2739
2740 See Trac #10447 for the original discussion on this feature. Also see
2741 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
2742 for a more in-depth explanation.
2743
2744 Note [FFoldType and functorLikeTraverse]
2745 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2746 Deriving Functor, Foldable, and Traversable all require generating expressions
2747 which perform an operation on each argument of a data constructor depending
2748 on the argument's type. In particular, a generated operation can be different
2749 depending on whether the type mentions the last type variable of the datatype
2750 (e.g., if you have data T a = MkT a Int, then a generated foldr expresion would
2751 fold over the first argument of MkT, but not the second).
2752
2753 This pattern is abstracted with the FFoldType datatype, which provides hooks
2754 for the user to specify how a constructor argument should be folded when it
2755 has a type with a particular "shape". The shapes are as follows (assume that
2756 a is the last type variable in a given datatype):
2757
2758 * ft_triv: The type does not mention the last type variable at all.
2759 Examples: Int, b
2760
2761 * ft_var: The type is syntactically equal to the last type variable.
2762 Moreover, the type appears in a covariant position (see
2763 the Deriving Functor instances section of the users' guide
2764 for an in-depth explanation of covariance vs. contravariance).
2765 Example: a (covariantly)
2766
2767 * ft_co_var: The type is syntactically equal to the last type variable.
2768 Moreover, the type appears in a contravariant position.
2769 Example: a (contravariantly)
2770
2771 * ft_fun: A function type which mentions the last type variable in
2772 the argument position, result position or both.
2773 Examples: a -> Int, Int -> a, Maybe a -> [a]
2774
2775 * ft_tup: A tuple type which mentions the last type variable in at least
2776 one of its fields. The TyCon argument of ft_tup represents the
2777 particular tuple's type constructor.
2778 Examples: (a, Int), (Maybe a, [a], Either a Int)
2779
2780 * ft_ty_app: A type is being applied to the last type parameter, where the
2781 applied type does not mention the last type parameter (if it
2782 did, it would fall under ft_bad_app). The Type argument to
2783 ft_ty_app represents the applied type.
2784
2785 Note that functions, tuples, and foralls are distinct cases
2786 and take precedence of ft_ty_app. (For example, (Int -> a) would
2787 fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
2788 Examples: Maybe a, Either b a
2789
2790 * ft_bad_app: A type application uses the last type parameter in a position
2791 other than the last argument. This case is singled out because
2792 Functor, Foldable, and Traversable instances cannot be derived
2793 for datatypes containing arguments with such types.
2794 Examples: Either a Int, Const a b
2795
2796 * ft_forall: A forall'd type mentions the last type parameter on its right-
2797 hand side (and is not quantified on the left-hand side). This
2798 case is present mostly for plumbing purposes.
2799 Example: forall b. Either b a
2800
2801 If FFoldType describes a strategy for folding subcomponents of a Type, then
2802 functorLikeTraverse is the function that applies that strategy to the entirety
2803 of a Type, returning the final folded-up result.
2804
2805 foldDataConArgs applies functorLikeTraverse to every argument type of a
2806 constructor, returning a list of the fold results. This makes foldDataConArgs
2807 a natural way to generate the subexpressions in a generated fmap, foldr,
2808 foldMap, or traverse definition (the subexpressions must then be combined in
2809 a method-specific fashion to form the final generated expression).
2810
2811 Deriving Generic1 also does validity checking by looking for the last type
2812 variable in certain positions of a constructor's argument types, so it also
2813 uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.
2814
2815 Note [Generated code for DeriveFoldable and DeriveTraversable]
2816 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2817 We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
2818 that of -XDeriveFunctor. However, there an important difference between deriving
2819 the former two typeclasses and the latter one, which is best illustrated by the
2820 following scenario:
2821
2822 data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
2823
2824 The generated code for the Functor instance is straightforward:
2825
2826 instance Functor WithInt where
2827 fmap f (WithInt a i) = WithInt (f a) i
2828
2829 But if we use too similar of a strategy for deriving the Foldable and
2830 Traversable instances, we end up with this code:
2831
2832 instance Foldable WithInt where
2833 foldMap f (WithInt a i) = f a <> mempty
2834
2835 instance Traversable WithInt where
2836 traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
2837
2838 This is unsatisfying for two reasons:
2839
2840 1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
2841 expects an argument whose type is of kind *. This effectively prevents
2842 Traversable from being derived for any datatype with an unlifted argument
2843 type (Trac #11174).
2844
2845 2. The generated code contains superfluous expressions. By the Monoid laws,
2846 we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
2847 reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
2848
2849 We can fix both of these issues by incorporating a slight twist to the usual
2850 algorithm that we use for -XDeriveFunctor. The differences can be summarized
2851 as follows:
2852
2853 1. In the generated expression, we only fold over arguments whose types
2854 mention the last type parameter. Any other argument types will simply
2855 produce useless 'mempty's or 'pure's, so they can be safely ignored.
2856
2857 2. In the case of -XDeriveTraversable, instead of applying ConName,
2858 we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
2859
2860 * ConName has n arguments
2861 * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
2862 to the arguments whose types mention the last type parameter. As a
2863 consequence, taking the difference of {a_1, ..., a_n} and
2864 {b_i, ..., b_k} yields the all the argument values of ConName whose types
2865 do not mention the last type parameter. Note that [i, ..., k] is a
2866 strictly increasing—but not necessarily consecutive—integer sequence.
2867
2868 For example, the datatype
2869
2870 data Foo a = Foo Int a Int a
2871
2872 would generate the following Traversable instance:
2873
2874 instance Traversable Foo where
2875 traverse f (Foo a1 a2 a3 a4) =
2876 fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
2877
2878 Technically, this approach would also work for -XDeriveFunctor as well, but we
2879 decide not to do so because:
2880
2881 1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
2882 instead of (WithInt (f a) i).
2883
2884 2. There would be certain datatypes for which the above strategy would
2885 generate Functor code that would fail to typecheck. For example:
2886
2887 data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
2888
2889 With the conventional algorithm, it would generate something like:
2890
2891 fmap f (Bar a) = Bar (fmap f a)
2892
2893 which typechecks. But with the strategy mentioned above, it would generate:
2894
2895 fmap f (Bar a) = (\b -> Bar b) (fmap f a)
2896
2897 which does not typecheck, since GHC cannot unify the rank-2 type variables
2898 in the types of b and (fmap f a).
2899 -}