Re-add FunTy (big patch)
[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 (FunTy 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 co (ForAllTy (TvBndr v vis) x)
1663 | isVisible vis = panic "unexpected visible binder"
1664 | v /= var && xc = (caseForAll v xr,True)
1665 where (xr,xc) = go co x
1666
1667 go _ _ = (caseTrivial,False)
1668
1669 -- Return all syntactic subterms of ty that contain var somewhere
1670 -- These are the things that should appear in instance constraints
1671 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1672 deepSubtypesContaining tv
1673 = functorLikeTraverse tv
1674 (FT { ft_triv = []
1675 , ft_var = []
1676 , ft_fun = (++)
1677 , ft_tup = \_ xs -> concat xs
1678 , ft_ty_app = (:)
1679 , ft_bad_app = panic "in other argument"
1680 , ft_co_var = panic "contravariant"
1681 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
1682
1683
1684 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1685 -- Fold over the arguments of the datacon
1686 foldDataConArgs ft con
1687 = map foldArg (dataConOrigArgTys con)
1688 where
1689 foldArg
1690 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
1691 Just tv -> functorLikeTraverse tv ft
1692 Nothing -> const (ft_triv ft)
1693 -- If we are deriving Foldable for a GADT, there is a chance that the last
1694 -- type variable in the data type isn't actually a type variable at all.
1695 -- (for example, this can happen if the last type variable is refined to
1696 -- be a concrete type such as Int). If the last type variable is refined
1697 -- to be a specific type, then getTyVar_maybe will return Nothing.
1698 -- See Note [DeriveFoldable with ExistentialQuantification]
1699 --
1700 -- The kind checks have ensured the last type parameter is of kind *.
1701
1702 -- Make a HsLam using a fresh variable from a State monad
1703 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1704 -> State [RdrName] (LHsExpr RdrName)
1705 -- (mkSimpleLam fn) returns (\x. fn(x))
1706 mkSimpleLam lam = do
1707 (n:names) <- get
1708 put names
1709 body <- lam (nlHsVar n)
1710 return (mkHsLam [nlVarPat n] body)
1711
1712 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
1713 -> State [RdrName] (LHsExpr RdrName))
1714 -> State [RdrName] (LHsExpr RdrName)
1715 mkSimpleLam2 lam = do
1716 (n1:n2:names) <- get
1717 put names
1718 body <- lam (nlHsVar n1) (nlHsVar n2)
1719 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1720
1721 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1722 --
1723 -- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
1724 -- which the LHS pattern-matches on @extra_pats@, followed by a match on the
1725 -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
1726 -- and its arguments, applying an expression (from @insides@) to each of the
1727 -- respective arguments of @con@.
1728 mkSimpleConMatch :: Monad m => HsMatchContext RdrName
1729 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1730 -> [LPat RdrName]
1731 -> DataCon
1732 -> [LHsExpr RdrName]
1733 -> m (LMatch RdrName (LHsExpr RdrName))
1734 mkSimpleConMatch ctxt fold extra_pats con insides = do
1735 let con_name = getRdrName con
1736 let vars_needed = takeList insides as_RDRs
1737 let pat = nlConVarPat con_name vars_needed
1738 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1739 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
1740 (noLoc emptyLocalBinds)
1741
1742 -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
1743 --
1744 -- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
1745 -- 'mkSimpleConMatch', with two key differences:
1746 --
1747 -- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
1748 -- @[LHsExpr RdrName]@. This is because it filters out the expressions
1749 -- corresponding to arguments whose types do not mention the last type
1750 -- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
1751 -- 'Nothing' elements of @insides@).
1752 --
1753 -- 2. @fold@ takes an expression as its first argument instead of a
1754 -- constructor name. This is because it uses a specialized
1755 -- constructor function expression that only takes as many parameters as
1756 -- there are argument types that mention the last type variable.
1757 --
1758 -- See Note [Generated code for DeriveFoldable and DeriveTraversable]
1759 mkSimpleConMatch2 :: Monad m
1760 => HsMatchContext RdrName
1761 -> (LHsExpr RdrName -> [LHsExpr RdrName]
1762 -> m (LHsExpr RdrName))
1763 -> [LPat RdrName]
1764 -> DataCon
1765 -> [Maybe (LHsExpr RdrName)]
1766 -> m (LMatch RdrName (LHsExpr RdrName))
1767 mkSimpleConMatch2 ctxt fold extra_pats con insides = do
1768 let con_name = getRdrName con
1769 vars_needed = takeList insides as_RDRs
1770 pat = nlConVarPat con_name vars_needed
1771 -- Make sure to zip BEFORE invoking catMaybes. We want the variable
1772 -- indicies in each expression to match up with the argument indices
1773 -- in con_expr (defined below).
1774 exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i)
1775 insides (map nlHsVar vars_needed)
1776 -- An element of argTysTyVarInfo is True if the constructor argument
1777 -- with the same index has a type which mentions the last type
1778 -- variable.
1779 argTysTyVarInfo = map isJust insides
1780 (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs
1781
1782 con_expr
1783 | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar
1784 | otherwise =
1785 let bs = filterByList argTysTyVarInfo bs_RDRs
1786 vars = filterByLists argTysTyVarInfo
1787 (map nlHsVar bs_RDRs)
1788 (map nlHsVar as_RDRs)
1789 in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
1790
1791 rhs <- fold con_expr exps
1792 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
1793 (noLoc emptyLocalBinds)
1794
1795 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1796 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1797 -> m (LMatch RdrName (LHsExpr RdrName)))
1798 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1799 mkSimpleTupleCase match_for_con tc insides x
1800 = do { let data_con = tyConSingleDataCon tc
1801 ; match <- match_for_con [] data_con insides
1802 ; return $ nlHsCase x [match] }
1803
1804 {-
1805 ************************************************************************
1806 * *
1807 Foldable instances
1808
1809 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1810
1811 * *
1812 ************************************************************************
1813
1814 Deriving Foldable instances works the same way as Functor instances,
1815 only Foldable instances are not possible for function types at all.
1816 Given (data T a = T a a (T a) deriving Foldable), we get:
1817
1818 instance Foldable T where
1819 foldr f z (T x1 x2 x3) =
1820 $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
1821
1822 -XDeriveFoldable is different from -XDeriveFunctor in that it filters out
1823 arguments to the constructor that would produce useless code in a Foldable
1824 instance. For example, the following datatype:
1825
1826 data Foo a = Foo Int a Int deriving Foldable
1827
1828 would have the following generated Foldable instance:
1829
1830 instance Foldable Foo where
1831 foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
1832
1833 since neither of the two Int arguments are folded over.
1834
1835 The cases are:
1836
1837 $(foldr 'a 'a) = f
1838 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1839 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
1840
1841 Note that the arguments to the real foldr function are the wrong way around,
1842 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1843
1844 One can envision a case for types that don't contain the last type variable:
1845
1846 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
1847
1848 But this case will never materialize, since the aforementioned filtering
1849 removes all such types from consideration.
1850 See Note [Generated code for DeriveFoldable and DeriveTraversable].
1851
1852 Foldable instances differ from Functor and Traversable instances in that
1853 Foldable instances can be derived for data types in which the last type
1854 variable is existentially quantified. In particular, if the last type variable
1855 is refined to a more specific type in a GADT:
1856
1857 data GADT a where
1858 G :: a ~ Int => a -> G Int
1859
1860 then the deriving machinery does not attempt to check that the type a contains
1861 Int, since it is not syntactically equal to a type variable. That is, the
1862 derived Foldable instance for GADT is:
1863
1864 instance Foldable GADT where
1865 foldr _ z (GADT _) = z
1866
1867 See Note [DeriveFoldable with ExistentialQuantification].
1868
1869 -}
1870
1871 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1872 gen_Foldable_binds loc tycon
1873 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1874 where
1875 data_cons = tyConDataCons tycon
1876
1877 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1878 eqns = map foldr_eqn data_cons
1879 foldr_eqn con
1880 = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1881 where
1882 parts = sequence $ foldDataConArgs ft_foldr con
1883
1884 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1885 foldMap_eqn con
1886 = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1887 where
1888 parts = sequence $ foldDataConArgs ft_foldMap con
1889
1890 -- Yields 'Just' an expression if we're folding over a type that mentions
1891 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
1892 -- See Note [FFoldType and functorLikeTraverse]
1893 ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
1894 ft_foldr
1895 = FT { ft_triv = return Nothing
1896 -- foldr f = \x z -> z
1897 , ft_var = return $ Just f_Expr
1898 -- foldr f = f
1899 , ft_tup = \t g -> do
1900 gg <- sequence g
1901 lam <- mkSimpleLam2 $ \x z ->
1902 mkSimpleTupleCase (match_foldr z) t gg x
1903 return (Just lam)
1904 -- foldr f = (\x z -> case x of ...)
1905 , ft_ty_app = \_ g -> do
1906 gg <- g
1907 mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
1908 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
1909 -- foldr f = (\x z -> foldr g z x)
1910 , ft_forall = \_ g -> g
1911 , ft_co_var = panic "contravariant"
1912 , ft_fun = panic "function"
1913 , ft_bad_app = panic "in other argument" }
1914
1915 match_foldr :: LHsExpr RdrName
1916 -> [LPat RdrName]
1917 -> DataCon
1918 -> [Maybe (LHsExpr RdrName)]
1919 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1920 match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
1921 where
1922 -- g1 v1 (g2 v2 (.. z))
1923 mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName
1924 mkFoldr = foldr nlHsApp z
1925
1926 -- See Note [FFoldType and functorLikeTraverse]
1927 ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
1928 ft_foldMap
1929 = FT { ft_triv = return Nothing
1930 -- foldMap f = \x -> mempty
1931 , ft_var = return (Just f_Expr)
1932 -- foldMap f = f
1933 , ft_tup = \t g -> do
1934 gg <- sequence g
1935 lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
1936 return (Just lam)
1937 -- foldMap f = \x -> case x of (..,)
1938 , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
1939 -- foldMap f = foldMap g
1940 , ft_forall = \_ g -> g
1941 , ft_co_var = panic "contravariant"
1942 , ft_fun = panic "function"
1943 , ft_bad_app = panic "in other argument" }
1944
1945 match_foldMap :: [LPat RdrName]
1946 -> DataCon
1947 -> [Maybe (LHsExpr RdrName)]
1948 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1949 match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
1950 where
1951 -- mappend v1 (mappend v2 ..)
1952 mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName
1953 mkFoldMap [] = mempty_Expr
1954 mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
1955
1956 {-
1957 ************************************************************************
1958 * *
1959 Traversable instances
1960
1961 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1962 * *
1963 ************************************************************************
1964
1965 Again, Traversable is much like Functor and Foldable.
1966
1967 The cases are:
1968
1969 $(traverse 'a 'a) = f
1970 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1971 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
1972
1973 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
1974 do not mention the last type parameter. Therefore, the following datatype:
1975
1976 data Foo a = Foo Int a Int
1977
1978 would have the following derived Traversable instance:
1979
1980 instance Traversable Foo where
1981 traverse f (Foo x1 x2 x3) =
1982 fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
1983
1984 since the two Int arguments do not produce any effects in a traversal.
1985
1986 One can envision a case for types that do not mention the last type parameter:
1987
1988 $(traverse 'a 'b) = pure -- when b does not contain a
1989
1990 But this case will never materialize, since the aforementioned filtering
1991 removes all such types from consideration.
1992 See Note [Generated code for DeriveFoldable and DeriveTraversable].
1993 -}
1994
1995 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1996 gen_Traversable_binds loc tycon
1997 = (unitBag traverse_bind, emptyBag)
1998 where
1999 data_cons = tyConDataCons tycon
2000
2001 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
2002 eqns = map traverse_eqn data_cons
2003 traverse_eqn con
2004 = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
2005 where
2006 parts = sequence $ foldDataConArgs ft_trav con
2007
2008 -- Yields 'Just' an expression if we're folding over a type that mentions
2009 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
2010 -- See Note [FFoldType and functorLikeTraverse]
2011 ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
2012 ft_trav
2013 = FT { ft_triv = return Nothing
2014 -- traverse f = pure x
2015 , ft_var = return (Just f_Expr)
2016 -- traverse f = f x
2017 , ft_tup = \t gs -> do
2018 gg <- sequence gs
2019 lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
2020 return (Just lam)
2021 -- traverse f = \x -> case x of (a1,a2,..) ->
2022 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
2023 , ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
2024 -- traverse f = traverse g
2025 , ft_forall = \_ g -> g
2026 , ft_co_var = panic "contravariant"
2027 , ft_fun = panic "function"
2028 , ft_bad_app = panic "in other argument" }
2029
2030 -- Con a1 a2 ... -> fmap (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
2031 -- <*> g2 a2 <*> ...
2032 match_for_con :: [LPat RdrName]
2033 -> DataCon
2034 -> [Maybe (LHsExpr RdrName)]
2035 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
2036 match_for_con = mkSimpleConMatch2 CaseAlt $
2037 \con xs -> return (mkApCon con xs)
2038 where
2039 -- fmap (\b1 b2 ... -> Con b1 b2 ...) x1 <*> x2 <*> ..
2040 mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
2041 mkApCon con [] = nlHsApps pure_RDR [con]
2042 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
2043 where appAp x y = nlHsApps ap_RDR [x,y]
2044
2045 {-
2046 ************************************************************************
2047 * *
2048 Lift instances
2049 * *
2050 ************************************************************************
2051
2052 Example:
2053
2054 data Foo a = Foo a | a :^: a deriving Lift
2055
2056 ==>
2057
2058 instance (Lift a) => Lift (Foo a) where
2059 lift (Foo a)
2060 = appE
2061 (conE
2062 (mkNameG_d "package-name" "ModuleName" "Foo"))
2063 (lift a)
2064 lift (u :^: v)
2065 = infixApp
2066 (lift u)
2067 (conE
2068 (mkNameG_d "package-name" "ModuleName" ":^:"))
2069 (lift v)
2070
2071 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
2072 'Foo would be when using the -XTemplateHaskell extension. To make sure that
2073 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
2074 makeG_d.
2075 -}
2076
2077 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
2078 gen_Lift_binds loc tycon
2079 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
2080 [mkMatch (FunRhs (L loc lift_RDR) Prefix)
2081 [nlWildPat] errorMsg_Expr
2082 (noLoc emptyLocalBinds)])
2083 , emptyBag)
2084 | otherwise = (unitBag lift_bind, emptyBag)
2085 where
2086 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
2087 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
2088
2089 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
2090 data_cons = tyConDataCons tycon
2091 tycon_str = occNameString . nameOccName . tyConName $ tycon
2092
2093 pats_etc data_con
2094 = ([con_pat], lift_Expr)
2095 where
2096 con_pat = nlConVarPat data_con_RDR as_needed
2097 data_con_RDR = getRdrName data_con
2098 con_arity = dataConSourceArity data_con
2099 as_needed = take con_arity as_RDRs
2100 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
2101 tys_needed as_needed
2102 tycon_name = tyConName tycon
2103 is_infix = dataConIsInfix data_con
2104 tys_needed = dataConOrigArgTys data_con
2105
2106 mk_lift_app ty a
2107 | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
2108 (nlHsVar a)
2109 | otherwise = nlHsApp (nlHsVar litE_RDR)
2110 (primLitOp (mkBoxExp (nlHsVar a)))
2111 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
2112
2113 pkg_name = unitIdString . moduleUnitId
2114 . nameModule $ tycon_name
2115 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
2116 con_name = occNameString . nameOccName . dataConName $ data_con
2117
2118 conE_Expr = nlHsApp (nlHsVar conE_RDR)
2119 (nlHsApps mkNameG_dRDR
2120 (map (nlHsLit . mkHsString)
2121 [pkg_name, mod_name, con_name]))
2122
2123 lift_Expr
2124 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
2125 | otherwise = foldl mk_appE_app conE_Expr lifted_as
2126 (a1:a2:_) = lifted_as
2127
2128 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2129 mk_appE_app a b = nlHsApps appE_RDR [a, b]
2130
2131 {-
2132 ************************************************************************
2133 * *
2134 Newtype-deriving instances
2135 * *
2136 ************************************************************************
2137
2138 Note [Newtype-deriving instances]
2139 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2140 We take every method in the original instance and `coerce` it to fit
2141 into the derived instance. We need a type annotation on the argument
2142 to `coerce` to make it obvious what instantiation of the method we're
2143 coercing from. So from, say,
2144 class C a b where
2145 op :: a -> [b] -> Int
2146
2147 newtype T x = MkT <rep-ty>
2148
2149 instance C a <rep-ty> => C a (T x) where
2150 op = (coerce
2151 (op :: a -> [<rep-ty>] -> Int)
2152 ) :: a -> [T x] -> Int
2153
2154 Notice that we give the 'coerce' call two type signatures: one to
2155 fix the of the inner call, and one for the expected type. The outer
2156 type signature ought to be redundant, but may improve error messages.
2157 The inner one is essential to fix the type at which 'op' is called.
2158
2159 See #8503 for more discussion.
2160
2161 Here's a wrinkle. Supppose 'op' is locally overloaded:
2162
2163 class C2 b where
2164 op2 :: forall a. Eq a => a -> [b] -> Int
2165
2166 Then we could do exactly as above, but it's a bit redundant to
2167 instantiate op, then re-generalise with the inner signature.
2168 (The inner sig is only there to fix the type at which 'op' is
2169 called.) So we just instantiate the signature, and add
2170
2171 instance C2 <rep-ty> => C2 (T x) where
2172 op2 = (coerce
2173 (op2 :: a -> [<rep-ty>] -> Int)
2174 ) :: forall a. Eq a => a -> [T x] -> Int
2175 -}
2176
2177 gen_Newtype_binds :: SrcSpan
2178 -> Class -- the class being derived
2179 -> [TyVar] -- the tvs in the instance head
2180 -> [Type] -- instance head parameters (incl. newtype)
2181 -> Type -- the representation type (already eta-reduced)
2182 -> LHsBinds RdrName
2183 -- See Note [Newtype-deriving instances]
2184 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
2185 = listToBag $ map mk_bind (classMethods cls)
2186 where
2187 coerce_RDR = getRdrName coerceId
2188
2189 mk_bind :: Id -> LHsBind RdrName
2190 mk_bind meth_id
2191 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
2192 (FunRhs (L loc meth_RDR) Prefix)
2193 [] rhs_expr]
2194 where
2195 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty meth_id
2196
2197 -- See "wrinkle" in Note [Newtype-deriving instances]
2198 (_, _, from_ty') = tcSplitSigmaTy from_ty
2199
2200 meth_RDR = getRdrName meth_id
2201
2202 rhs_expr = ( nlHsVar coerce_RDR
2203 `nlHsApp`
2204 (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType from_ty'))
2205 `nlExprWithTySig` toLHsSigWcType to_ty
2206
2207
2208 nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
2209 nlExprWithTySig e s = noLoc (ExprWithTySig e s)
2210
2211 mkCoerceClassMethEqn :: Class -- the class being derived
2212 -> [TyVar] -- the tvs in the instance head
2213 -> [Type] -- instance head parameters (incl. newtype)
2214 -> Type -- the representation type (already eta-reduced)
2215 -> Id -- the method to look at
2216 -> Pair Type
2217 -- See Note [Newtype-deriving instances]
2218 -- The pair is the (from_type, to_type), where to_type is
2219 -- the type of the method we are tyrying to get
2220 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
2221 = Pair (substTy rhs_subst user_meth_ty)
2222 (substTy lhs_subst user_meth_ty)
2223 where
2224 cls_tvs = classTyVars cls
2225 in_scope = mkInScopeSet $ mkVarSet inst_tvs
2226 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
2227 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
2228 (_class_tvs, _class_constraint, user_meth_ty)
2229 = tcSplitMethodTy (varType id)
2230
2231 changeLast :: [a] -> a -> [a]
2232 changeLast [] _ = panic "changeLast"
2233 changeLast [_] x = [x]
2234 changeLast (x:xs) x' = x : changeLast xs x'
2235
2236 {-
2237 ************************************************************************
2238 * *
2239 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
2240 * *
2241 ************************************************************************
2242
2243 \begin{verbatim}
2244 data Foo ... = ...
2245
2246 con2tag_Foo :: Foo ... -> Int#
2247 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2248 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2249 \end{verbatim}
2250
2251 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2252 fiddling around.
2253 -}
2254
2255 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
2256 genAuxBindSpec loc (DerivCon2Tag tycon)
2257 = (mk_FunBind loc rdr_name eqns,
2258 L loc (TypeSig [L loc rdr_name] sig_ty))
2259 where
2260 rdr_name = con2tag_RDR tycon
2261
2262 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
2263 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
2264 mkParentType tycon `mkFunTy` intPrimTy
2265
2266 lots_of_constructors = tyConFamilySize tycon > 8
2267 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
2268 -- but we don't do vectored returns any more.
2269
2270 eqns | lots_of_constructors = [get_tag_eqn]
2271 | otherwise = map mk_eqn (tyConDataCons tycon)
2272
2273 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
2274
2275 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
2276 mk_eqn con = ([nlWildConPat con],
2277 nlHsLit (HsIntPrim ""
2278 (toInteger ((dataConTag con) - fIRST_TAG))))
2279
2280 genAuxBindSpec loc (DerivTag2Con tycon)
2281 = (mk_FunBind loc rdr_name
2282 [([nlConVarPat intDataCon_RDR [a_RDR]],
2283 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2284 L loc (TypeSig [L loc rdr_name] sig_ty))
2285 where
2286 sig_ty = mkLHsSigWcType $ L loc $
2287 HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
2288 intTy `mkFunTy` mkParentType tycon
2289
2290 rdr_name = tag2con_RDR tycon
2291
2292 genAuxBindSpec loc (DerivMaxTag tycon)
2293 = (mkHsVarBind loc rdr_name rhs,
2294 L loc (TypeSig [L loc rdr_name] sig_ty))
2295 where
2296 rdr_name = maxtag_RDR tycon
2297 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
2298 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2299 max_tag = case (tyConDataCons tycon) of
2300 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2301
2302 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
2303 ( Bag (LHsBind RdrName, LSig RdrName)
2304 -- Extra bindings (used by Generic only)
2305 , Bag (FamInst) -- Extra family instances
2306 , Bag (InstInfo RdrName)) -- Extra instances
2307
2308 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2309 genAuxBinds loc b = genAuxBinds' b2 where
2310 (b1,b2) = partitionBagWith splitDerivAuxBind b
2311 splitDerivAuxBind (DerivAuxBind x) = Left x
2312 splitDerivAuxBind x = Right x
2313
2314 rm_dups = foldrBag dup_check emptyBag
2315 dup_check a b = if anyBag (== a) b then b else consBag a b
2316
2317 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2318 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2319 , emptyBag, emptyBag)
2320 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2321 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2322 f (DerivHsBind b) = add1 b
2323 f (DerivFamInst t) = add2 t
2324 f (DerivInst i) = add3 i
2325
2326 add1 x (a,b,c) = (x `consBag` a,b,c)
2327 add2 x (a,b,c) = (a,x `consBag` b,c)
2328 add3 x (a,b,c) = (a,b,x `consBag` c)
2329
2330 mk_data_type_name :: TyCon -> RdrName -- "$tT"
2331 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
2332
2333 mk_constr_name :: DataCon -> RdrName -- "$cC"
2334 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
2335
2336 mkParentType :: TyCon -> Type
2337 -- Turn the representation tycon of a family into
2338 -- a use of its family constructor
2339 mkParentType tc
2340 = case tyConFamInst_maybe tc of
2341 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2342 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2343
2344 {-
2345 ************************************************************************
2346 * *
2347 \subsection{Utility bits for generating bindings}
2348 * *
2349 ************************************************************************
2350 -}
2351
2352 mk_FunBind :: SrcSpan -> RdrName
2353 -> [([LPat RdrName], LHsExpr RdrName)]
2354 -> LHsBind RdrName
2355 mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind,
2356 -- the caller says that the Void case needs no
2357 -- patterns
2358
2359 -- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before
2360 -- the "=" in the empty-data-decl case. This is necessary if the function
2361 -- has a higher-rank type, like foldl. (See deriving/should_compile/T4302)
2362 mk_HRFunBind :: Arity -> SrcSpan -> RdrName
2363 -> [([LPat RdrName], LHsExpr RdrName)]
2364 -> LHsBind RdrName
2365 mk_HRFunBind arity loc fun pats_and_exprs
2366 = mkHRRdrFunBind arity (L loc fun) matches
2367 where
2368 matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
2369 (noLoc emptyLocalBinds)
2370 | (p,e) <-pats_and_exprs]
2371
2372 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2373 mkRdrFunBind = mkHRRdrFunBind 0
2374
2375 mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2376 mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2377 where
2378 -- Catch-all eqn looks like
2379 -- fmap = error "Void fmap"
2380 -- It's needed if there no data cons at all,
2381 -- which can happen with -XEmptyDataDecls
2382 -- See Trac #4302
2383 matches' = if null matches
2384 then [mkMatch (FunRhs fun Prefix)
2385 (replicate arity nlWildPat)
2386 (error_Expr str) (noLoc emptyLocalBinds)]
2387 else matches
2388 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2389
2390 box :: String -- The class involved
2391 -> TyCon -- The tycon involved
2392 -> LHsExpr RdrName -- The argument
2393 -> Type -- The argument type
2394 -> LHsExpr RdrName -- Boxed version of the arg
2395 -- See Note [Deriving and unboxed types] in TcDeriv
2396 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2397 where
2398 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2399
2400 ---------------------
2401 primOrdOps :: String -- The class involved
2402 -> TyCon -- The tycon involved
2403 -> Type -- The type
2404 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2405 -- See Note [Deriving and unboxed types] in TcDeriv
2406 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2407
2408 primLitOps :: String -- The class involved
2409 -> TyCon -- The tycon involved
2410 -> Type -- The type
2411 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
2412 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
2413 )
2414 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2415 , \v -> nlHsVar boxRDR `nlHsApp` v
2416 )
2417 where
2418 boxRDR
2419 | ty `eqType` addrPrimTy = unpackCString_RDR
2420 | otherwise = assoc_ty_id str tycon boxConTbl ty
2421
2422 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2423 ordOpTbl
2424 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2425 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2426 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2427 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2428 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2429 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2430
2431 boxConTbl :: [(Type, RdrName)]
2432 boxConTbl
2433 = [(charPrimTy , getRdrName charDataCon )
2434 ,(intPrimTy , getRdrName intDataCon )
2435 ,(wordPrimTy , getRdrName wordDataCon )
2436 ,(floatPrimTy , getRdrName floatDataCon )
2437 ,(doublePrimTy, getRdrName doubleDataCon)
2438 ]
2439
2440 -- | A table of postfix modifiers for unboxed values.
2441 postfixModTbl :: [(Type, String)]
2442 postfixModTbl
2443 = [(charPrimTy , "#" )
2444 ,(intPrimTy , "#" )
2445 ,(wordPrimTy , "##")
2446 ,(floatPrimTy , "#" )
2447 ,(doublePrimTy, "##")
2448 ]
2449
2450 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
2451 litConTbl
2452 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2453 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2454 . nlHsApp (nlHsVar toInteger_RDR))
2455 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2456 . nlHsApp (nlHsVar toInteger_RDR))
2457 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2458 . nlHsApp (nlHsApp
2459 (nlHsVar map_RDR)
2460 (compose_RDR `nlHsApps`
2461 [ nlHsVar fromIntegral_RDR
2462 , nlHsVar fromEnum_RDR
2463 ])))
2464 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2465 . nlHsApp (nlHsVar toRational_RDR))
2466 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2467 . nlHsApp (nlHsVar toRational_RDR))
2468 ]
2469
2470 -- | Lookup `Type` in an association list.
2471 assoc_ty_id :: String -- The class involved
2472 -> TyCon -- The tycon involved
2473 -> [(Type,a)] -- The table
2474 -> Type -- The type
2475 -> a -- The result of the lookup
2476 assoc_ty_id cls_str _ tbl ty
2477 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2478 text "for primitive type" <+> ppr ty)
2479 | otherwise = head res
2480 where
2481 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2482
2483 -----------------------------------------------------------------------
2484
2485 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2486 and_Expr a b = genOpApp a and_RDR b
2487
2488 -----------------------------------------------------------------------
2489
2490 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2491 eq_Expr tycon ty a b
2492 | not (isUnliftedType ty) = genOpApp a eq_RDR b
2493 | otherwise = genPrimOpApp a prim_eq b
2494 where
2495 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2496
2497 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2498 untag_Expr _ [] expr = expr
2499 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2500 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2501 [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2502
2503 enum_from_to_Expr
2504 :: LHsExpr RdrName -> LHsExpr RdrName
2505 -> LHsExpr RdrName
2506 enum_from_then_to_Expr
2507 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2508 -> LHsExpr RdrName
2509
2510 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2511 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2512
2513 showParen_Expr
2514 :: LHsExpr RdrName -> LHsExpr RdrName
2515 -> LHsExpr RdrName
2516
2517 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2518
2519 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2520
2521 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2522 nested_compose_Expr [e] = parenify e
2523 nested_compose_Expr (e:es)
2524 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2525
2526 -- impossible_Expr is used in case RHSs that should never happen.
2527 -- We generate these to keep the desugarer from complaining that they *might* happen!
2528 error_Expr :: String -> LHsExpr RdrName
2529 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2530
2531 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2532 -- method. It is currently only used by Enum.{succ,pred}
2533 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2534 illegal_Expr meth tp msg =
2535 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2536
2537 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2538 -- to include the value of a_RDR in the error string.
2539 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2540 illegal_toEnum_tag tp maxtag =
2541 nlHsApp (nlHsVar error_RDR)
2542 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2543 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2544 (nlHsApp (nlHsApp (nlHsApp
2545 (nlHsVar showsPrec_RDR)
2546 (nlHsIntLit 0))
2547 (nlHsVar a_RDR))
2548 (nlHsApp (nlHsApp
2549 (nlHsVar append_RDR)
2550 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2551 (nlHsApp (nlHsApp (nlHsApp
2552 (nlHsVar showsPrec_RDR)
2553 (nlHsIntLit 0))
2554 (nlHsVar maxtag))
2555 (nlHsLit (mkHsString ")"))))))
2556
2557 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2558 parenify e@(L _ (HsVar _)) = e
2559 parenify e = mkHsPar e
2560
2561 -- genOpApp wraps brackets round the operator application, so that the
2562 -- renamer won't subsequently try to re-associate it.
2563 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2564 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2565
2566 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2567 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2568
2569 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2570 :: RdrName
2571 a_RDR = mkVarUnqual (fsLit "a")
2572 b_RDR = mkVarUnqual (fsLit "b")
2573 c_RDR = mkVarUnqual (fsLit "c")
2574 d_RDR = mkVarUnqual (fsLit "d")
2575 f_RDR = mkVarUnqual (fsLit "f")
2576 k_RDR = mkVarUnqual (fsLit "k")
2577 z_RDR = mkVarUnqual (fsLit "z")
2578 ah_RDR = mkVarUnqual (fsLit "a#")
2579 bh_RDR = mkVarUnqual (fsLit "b#")
2580 ch_RDR = mkVarUnqual (fsLit "c#")
2581 dh_RDR = mkVarUnqual (fsLit "d#")
2582
2583 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2584 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2585 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2586 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2587
2588 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2589 false_Expr, true_Expr, fmap_Expr,
2590 mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2591 a_Expr = nlHsVar a_RDR
2592 -- b_Expr = nlHsVar b_RDR
2593 c_Expr = nlHsVar c_RDR
2594 f_Expr = nlHsVar f_RDR
2595 z_Expr = nlHsVar z_RDR
2596 ltTag_Expr = nlHsVar ltTag_RDR
2597 eqTag_Expr = nlHsVar eqTag_RDR
2598 gtTag_Expr = nlHsVar gtTag_RDR
2599 false_Expr = nlHsVar false_RDR
2600 true_Expr = nlHsVar true_RDR
2601 fmap_Expr = nlHsVar fmap_RDR
2602 -- pure_Expr = nlHsVar pure_RDR
2603 mempty_Expr = nlHsVar mempty_RDR
2604 foldMap_Expr = nlHsVar foldMap_RDR
2605 traverse_Expr = nlHsVar traverse_RDR
2606
2607 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2608 a_Pat = nlVarPat a_RDR
2609 b_Pat = nlVarPat b_RDR
2610 c_Pat = nlVarPat c_RDR
2611 d_Pat = nlVarPat d_RDR
2612 f_Pat = nlVarPat f_RDR
2613 k_Pat = nlVarPat k_RDR
2614 z_Pat = nlVarPat z_RDR
2615
2616 minusInt_RDR, tagToEnum_RDR :: RdrName
2617 minusInt_RDR = getRdrName (primOpId IntSubOp )
2618 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2619
2620 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2621 -- Generates Orig s RdrName, for the binding positions
2622 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2623 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2624 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2625
2626 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2627 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2628
2629 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2630 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2631 -- See Note [Auxiliary binders]
2632 mkAuxBinderName parent occ_fun
2633 = mkRdrUnqual (occ_fun stable_parent_occ)
2634 where
2635 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2636 stable_string
2637 | opt_PprStyle_Debug = parent_stable
2638 | otherwise = parent_stable_hash
2639 parent_stable = nameStableString parent
2640 parent_stable_hash =
2641 let Fingerprint high low = fingerprintString parent_stable
2642 in toBase62 high ++ toBase62Padded low
2643 -- See Note [Base 62 encoding 128-bit integers]
2644 parent_occ = nameOccName parent
2645
2646
2647 {-
2648 Note [Auxiliary binders]
2649 ~~~~~~~~~~~~~~~~~~~~~~~~
2650 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2651
2652 instance Ord T where
2653 compare a b = $con2tag a `compare` $con2tag b
2654
2655 $con2tag :: T -> Int
2656 $con2tag = ...code....
2657
2658 Of course these top-level bindings should all have distinct name, and we are
2659 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2660 because with standalone deriving two imported TyCons might both be called T!
2661 (See Trac #7947.)
2662
2663 So we use package name, module name and the name of the parent
2664 (T in this example) as part of the OccName we generate for the new binding.
2665 To make the symbol names short we take a base62 hash of the full name.
2666
2667 In the past we used the *unique* from the parent, but that's not stable across
2668 recompilations as uniques are nondeterministic.
2669
2670 Note [DeriveFoldable with ExistentialQuantification]
2671 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2672 Functor and Traversable instances can only be derived for data types whose
2673 last type parameter is truly universally polymorphic. For example:
2674
2675 data T a b where
2676 T1 :: b -> T a b -- YES, b is unconstrained
2677 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
2678 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
2679 T4 :: Int -> T a Int -- NO, this is just like T3
2680 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
2681 -- though a is existential
2682 T6 :: Int -> T Int b -- YES, b is unconstrained
2683
2684 For Foldable instances, however, we can completely lift the constraint that
2685 the last type parameter be truly universally polymorphic. This means that T
2686 (as defined above) can have a derived Foldable instance:
2687
2688 instance Foldable (T a) where
2689 foldr f z (T1 b) = f b z
2690 foldr f z (T2 b) = f b z
2691 foldr f z (T3 b) = f b z
2692 foldr f z (T4 b) = z
2693 foldr f z (T5 a b) = f b z
2694 foldr f z (T6 a) = z
2695
2696 foldMap f (T1 b) = f b
2697 foldMap f (T2 b) = f b
2698 foldMap f (T3 b) = f b
2699 foldMap f (T4 b) = mempty
2700 foldMap f (T5 a b) = f b
2701 foldMap f (T6 a) = mempty
2702
2703 In a Foldable instance, it is safe to fold over an occurrence of the last type
2704 parameter that is not truly universally polymorphic. However, there is a bit
2705 of subtlety in determining what is actually an occurrence of a type parameter.
2706 T3 and T4, as defined above, provide one example:
2707
2708 data T a b where
2709 ...
2710 T3 :: b ~ Int => b -> T a b
2711 T4 :: Int -> T a Int
2712 ...
2713
2714 instance Foldable (T a) where
2715 ...
2716 foldr f z (T3 b) = f b z
2717 foldr f z (T4 b) = z
2718 ...
2719 foldMap f (T3 b) = f b
2720 foldMap f (T4 b) = mempty
2721 ...
2722
2723 Notice that the argument of T3 is folded over, whereas the argument of T4 is
2724 not. This is because we only fold over constructor arguments that
2725 syntactically mention the universally quantified type parameter of that
2726 particular data constructor. See foldDataConArgs for how this is implemented.
2727
2728 As another example, consider the following data type. The argument of each
2729 constructor has the same type as the last type parameter:
2730
2731 data E a where
2732 E1 :: (a ~ Int) => a -> E a
2733 E2 :: Int -> E Int
2734 E3 :: (a ~ Int) => a -> E Int
2735 E4 :: (a ~ Int) => Int -> E a
2736
2737 Only E1's argument is an occurrence of a universally quantified type variable
2738 that is syntactically equivalent to the last type parameter, so only E1's
2739 argument will be be folded over in a derived Foldable instance.
2740
2741 See Trac #10447 for the original discussion on this feature. Also see
2742 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
2743 for a more in-depth explanation.
2744
2745 Note [FFoldType and functorLikeTraverse]
2746 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2747 Deriving Functor, Foldable, and Traversable all require generating expressions
2748 which perform an operation on each argument of a data constructor depending
2749 on the argument's type. In particular, a generated operation can be different
2750 depending on whether the type mentions the last type variable of the datatype
2751 (e.g., if you have data T a = MkT a Int, then a generated foldr expresion would
2752 fold over the first argument of MkT, but not the second).
2753
2754 This pattern is abstracted with the FFoldType datatype, which provides hooks
2755 for the user to specify how a constructor argument should be folded when it
2756 has a type with a particular "shape". The shapes are as follows (assume that
2757 a is the last type variable in a given datatype):
2758
2759 * ft_triv: The type does not mention the last type variable at all.
2760 Examples: Int, b
2761
2762 * ft_var: The type is syntactically equal to the last type variable.
2763 Moreover, the type appears in a covariant position (see
2764 the Deriving Functor instances section of the users' guide
2765 for an in-depth explanation of covariance vs. contravariance).
2766 Example: a (covariantly)
2767
2768 * ft_co_var: The type is syntactically equal to the last type variable.
2769 Moreover, the type appears in a contravariant position.
2770 Example: a (contravariantly)
2771
2772 * ft_fun: A function type which mentions the last type variable in
2773 the argument position, result position or both.
2774 Examples: a -> Int, Int -> a, Maybe a -> [a]
2775
2776 * ft_tup: A tuple type which mentions the last type variable in at least
2777 one of its fields. The TyCon argument of ft_tup represents the
2778 particular tuple's type constructor.
2779 Examples: (a, Int), (Maybe a, [a], Either a Int)
2780
2781 * ft_ty_app: A type is being applied to the last type parameter, where the
2782 applied type does not mention the last type parameter (if it
2783 did, it would fall under ft_bad_app). The Type argument to
2784 ft_ty_app represents the applied type.
2785
2786 Note that functions, tuples, and foralls are distinct cases
2787 and take precedence of ft_ty_app. (For example, (Int -> a) would
2788 fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
2789 Examples: Maybe a, Either b a
2790
2791 * ft_bad_app: A type application uses the last type parameter in a position
2792 other than the last argument. This case is singled out because
2793 Functor, Foldable, and Traversable instances cannot be derived
2794 for datatypes containing arguments with such types.
2795 Examples: Either a Int, Const a b
2796
2797 * ft_forall: A forall'd type mentions the last type parameter on its right-
2798 hand side (and is not quantified on the left-hand side). This
2799 case is present mostly for plumbing purposes.
2800 Example: forall b. Either b a
2801
2802 If FFoldType describes a strategy for folding subcomponents of a Type, then
2803 functorLikeTraverse is the function that applies that strategy to the entirety
2804 of a Type, returning the final folded-up result.
2805
2806 foldDataConArgs applies functorLikeTraverse to every argument type of a
2807 constructor, returning a list of the fold results. This makes foldDataConArgs
2808 a natural way to generate the subexpressions in a generated fmap, foldr,
2809 foldMap, or traverse definition (the subexpressions must then be combined in
2810 a method-specific fashion to form the final generated expression).
2811
2812 Deriving Generic1 also does validity checking by looking for the last type
2813 variable in certain positions of a constructor's argument types, so it also
2814 uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.
2815
2816 Note [Generated code for DeriveFoldable and DeriveTraversable]
2817 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2818 We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
2819 that of -XDeriveFunctor. However, there an important difference between deriving
2820 the former two typeclasses and the latter one, which is best illustrated by the
2821 following scenario:
2822
2823 data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
2824
2825 The generated code for the Functor instance is straightforward:
2826
2827 instance Functor WithInt where
2828 fmap f (WithInt a i) = WithInt (f a) i
2829
2830 But if we use too similar of a strategy for deriving the Foldable and
2831 Traversable instances, we end up with this code:
2832
2833 instance Foldable WithInt where
2834 foldMap f (WithInt a i) = f a <> mempty
2835
2836 instance Traversable WithInt where
2837 traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
2838
2839 This is unsatisfying for two reasons:
2840
2841 1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
2842 expects an argument whose type is of kind *. This effectively prevents
2843 Traversable from being derived for any datatype with an unlifted argument
2844 type (Trac #11174).
2845
2846 2. The generated code contains superfluous expressions. By the Monoid laws,
2847 we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
2848 reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
2849
2850 We can fix both of these issues by incorporating a slight twist to the usual
2851 algorithm that we use for -XDeriveFunctor. The differences can be summarized
2852 as follows:
2853
2854 1. In the generated expression, we only fold over arguments whose types
2855 mention the last type parameter. Any other argument types will simply
2856 produce useless 'mempty's or 'pure's, so they can be safely ignored.
2857
2858 2. In the case of -XDeriveTraversable, instead of applying ConName,
2859 we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
2860
2861 * ConName has n arguments
2862 * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
2863 to the arguments whose types mention the last type parameter. As a
2864 consequence, taking the difference of {a_1, ..., a_n} and
2865 {b_i, ..., b_k} yields the all the argument values of ConName whose types
2866 do not mention the last type parameter. Note that [i, ..., k] is a
2867 strictly increasing—but not necessarily consecutive—integer sequence.
2868
2869 For example, the datatype
2870
2871 data Foo a = Foo Int a Int a
2872
2873 would generate the following Traversable instance:
2874
2875 instance Traversable Foo where
2876 traverse f (Foo a1 a2 a3 a4) =
2877 fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
2878
2879 Technically, this approach would also work for -XDeriveFunctor as well, but we
2880 decide not to do so because:
2881
2882 1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
2883 instead of (WithInt (f a) i).
2884
2885 2. There would be certain datatypes for which the above strategy would
2886 generate Functor code that would fail to typecheck. For example:
2887
2888 data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
2889
2890 With the conventional algorithm, it would generate something like:
2891
2892 fmap f (Bar a) = Bar (fmap f a)
2893
2894 which typechecks. But with the strategy mentioned above, it would generate:
2895
2896 fmap f (Bar a) = (\b -> Bar b) (fmap f a)
2897
2898 which does not typecheck, since GHC cannot unify the rank-2 type variables
2899 in the types of b and (fmap f a).
2900 -}