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