Fix DeriveAnyClass (Trac #9968)
[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 MkCore ( eRROR_ID )
45 import PrelNames hiding (error_RDR)
46 import THNames
47 import Module ( moduleName, moduleNameString
48 , moduleUnitId, unitIdString )
49 import MkId ( coerceId )
50 import PrimOp
51 import SrcLoc
52 import TyCon
53 import TcType
54 import TysPrim
55 import TysWiredIn
56 import Type
57 import Class
58 import TypeRep
59 import VarSet
60 import VarEnv
61 import State
62 import Util
63 import Var
64 #if __GLASGOW_HASKELL__ < 709
65 import MonadUtils
66 #endif
67 import Outputable
68 import Lexeme
69 import FastString
70 import Pair
71 import Bag
72 import TcEnv (InstInfo)
73 import StaticFlags( opt_PprStyle_Debug )
74
75 import ListSetOps ( assocMaybe )
76 import Data.List ( partition, intersperse )
77
78 type BagDerivStuff = Bag DerivStuff
79
80 data AuxBindSpec
81 = DerivCon2Tag TyCon -- The con2Tag for given TyCon
82 | DerivTag2Con TyCon -- ...ditto tag2Con
83 | DerivMaxTag TyCon -- ...and maxTag
84 deriving( Eq )
85 -- All these generate ZERO-BASED tag operations
86 -- I.e first constructor has tag 0
87
88 data DerivStuff -- Please add this auxiliary stuff
89 = DerivAuxBind AuxBindSpec
90
91 -- Generics
92 | DerivFamInst FamInst -- New type family instances
93
94 -- New top-level auxiliary bindings
95 | DerivHsBind (LHsBind RdrName, LSig RdrName) -- Also used for SYB
96 | DerivInst (InstInfo RdrName) -- New, auxiliary instances
97
98 {-
99 ************************************************************************
100 * *
101 Class deriving diagnostics
102 * *
103 ************************************************************************
104
105 Only certain blessed classes can be used in a deriving clause. These classes
106 are listed below in the definition of hasBuiltinDeriving (with the exception
107 of Generic and Generic1, which are handled separately in TcGenGenerics).
108
109 A class might be able to be used in a deriving clause if it -XDeriveAnyClass
110 is willing to support it. The canDeriveAnyClass function checks if this is
111 the case.
112 -}
113
114 hasBuiltinDeriving :: DynFlags
115 -> (Name -> Fixity)
116 -> Class
117 -> Maybe (SrcSpan
118 -> TyCon
119 -> (LHsBinds RdrName, BagDerivStuff))
120 hasBuiltinDeriving dflags fix_env clas = assocMaybe gen_list (getUnique clas)
121 where
122 gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff))]
123 gen_list = [ (eqClassKey, gen_Eq_binds)
124 , (ordClassKey, gen_Ord_binds)
125 , (enumClassKey, gen_Enum_binds)
126 , (boundedClassKey, gen_Bounded_binds)
127 , (ixClassKey, gen_Ix_binds)
128 , (showClassKey, gen_Show_binds fix_env)
129 , (readClassKey, gen_Read_binds fix_env)
130 , (dataClassKey, gen_Data_binds dflags)
131 , (functorClassKey, gen_Functor_binds)
132 , (foldableClassKey, gen_Foldable_binds)
133 , (traversableClassKey, gen_Traversable_binds)
134 , (liftClassKey, gen_Lift_binds) ]
135
136 {-
137 ************************************************************************
138 * *
139 Eq instances
140 * *
141 ************************************************************************
142
143 Here are the heuristics for the code we generate for @Eq@. Let's
144 assume we have a data type with some (possibly zero) nullary data
145 constructors and some ordinary, non-nullary ones (the rest, also
146 possibly zero of them). Here's an example, with both \tr{N}ullary and
147 \tr{O}rdinary data cons.
148
149 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
150
151 * For the ordinary constructors (if any), we emit clauses to do The
152 Usual Thing, e.g.,:
153
154 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
155 (==) (O2 a1) (O2 a2) = a1 == a2
156 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
157
158 Note: if we're comparing unlifted things, e.g., if 'a1' and
159 'a2' are Float#s, then we have to generate
160 case (a1 `eqFloat#` a2) of r -> r
161 for that particular test.
162
163 * If there are a lot of (more than en) nullary constructors, we emit a
164 catch-all clause of the form:
165
166 (==) a b = case (con2tag_Foo a) of { a# ->
167 case (con2tag_Foo b) of { b# ->
168 case (a# ==# b#) of {
169 r -> r }}}
170
171 If con2tag gets inlined this leads to join point stuff, so
172 it's better to use regular pattern matching if there aren't too
173 many nullary constructors. "Ten" is arbitrary, of course
174
175 * If there aren't any nullary constructors, we emit a simpler
176 catch-all:
177
178 (==) a b = False
179
180 * For the @(/=)@ method, we normally just use the default method.
181 If the type is an enumeration type, we could/may/should? generate
182 special code that calls @con2tag_Foo@, much like for @(==)@ shown
183 above.
184
185 We thought about doing this: If we're also deriving 'Ord' for this
186 tycon, we generate:
187 instance ... Eq (Foo ...) where
188 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
189 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
190 However, that requires that (Ord <whatever>) was put in the context
191 for the instance decl, which it probably wasn't, so the decls
192 produced don't get through the typechecker.
193 -}
194
195 gen_Eq_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
196 gen_Eq_binds loc tycon
197 = (method_binds, aux_binds)
198 where
199 all_cons = tyConDataCons tycon
200 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
201
202 -- If there are ten or more (arbitrary number) nullary constructors,
203 -- use the con2tag stuff. For small types it's better to use
204 -- ordinary pattern matching.
205 (tag_match_cons, pat_match_cons)
206 | nullary_cons `lengthExceeds` 10 = (nullary_cons, non_nullary_cons)
207 | otherwise = ([], all_cons)
208
209 no_tag_match_cons = null tag_match_cons
210
211 fall_through_eqn
212 | no_tag_match_cons -- All constructors have arguments
213 = case pat_match_cons of
214 [] -> [] -- No constructors; no fall-though case
215 [_] -> [] -- One constructor; no fall-though case
216 _ -> -- Two or more constructors; add fall-through of
217 -- (==) _ _ = False
218 [([nlWildPat, nlWildPat], false_Expr)]
219
220 | otherwise -- One or more tag_match cons; add fall-through of
221 -- extract tags compare for equality
222 = [([a_Pat, b_Pat],
223 untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
224 (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
225
226 aux_binds | no_tag_match_cons = emptyBag
227 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
228
229 method_binds = listToBag [eq_bind, ne_bind]
230 eq_bind = mk_FunBind loc eq_RDR (map pats_etc pat_match_cons ++ fall_through_eqn)
231 ne_bind = mk_easy_FunBind loc ne_RDR [a_Pat, b_Pat] (
232 nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR])))
233
234 ------------------------------------------------------------------
235 pats_etc data_con
236 = let
237 con1_pat = nlConVarPat data_con_RDR as_needed
238 con2_pat = nlConVarPat data_con_RDR bs_needed
239
240 data_con_RDR = getRdrName data_con
241 con_arity = length tys_needed
242 as_needed = take con_arity as_RDRs
243 bs_needed = take con_arity bs_RDRs
244 tys_needed = dataConOrigArgTys data_con
245 in
246 ([con1_pat, con2_pat], nested_eq_expr tys_needed as_needed bs_needed)
247 where
248 nested_eq_expr [] [] [] = true_Expr
249 nested_eq_expr tys as bs
250 = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
251 where
252 nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b))
253
254 {-
255 ************************************************************************
256 * *
257 Ord instances
258 * *
259 ************************************************************************
260
261 Note [Generating Ord instances]
262 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
263 Suppose constructors are K1..Kn, and some are nullary.
264 The general form we generate is:
265
266 * Do case on first argument
267 case a of
268 K1 ... -> rhs_1
269 K2 ... -> rhs_2
270 ...
271 Kn ... -> rhs_n
272 _ -> nullary_rhs
273
274 * To make rhs_i
275 If i = 1, 2, n-1, n, generate a single case.
276 rhs_2 case b of
277 K1 {} -> LT
278 K2 ... -> ...eq_rhs(K2)...
279 _ -> GT
280
281 Otherwise do a tag compare against the bigger range
282 (because this is the one most likely to succeed)
283 rhs_3 case tag b of tb ->
284 if 3 <# tg then GT
285 else case b of
286 K3 ... -> ...eq_rhs(K3)....
287 _ -> LT
288
289 * To make eq_rhs(K), which knows that
290 a = K a1 .. av
291 b = K b1 .. bv
292 we just want to compare (a1,b1) then (a2,b2) etc.
293 Take care on the last field to tail-call into comparing av,bv
294
295 * To make nullary_rhs generate this
296 case con2tag a of a# ->
297 case con2tag b of ->
298 a# `compare` b#
299
300 Several special cases:
301
302 * Two or fewer nullary constructors: don't generate nullary_rhs
303
304 * Be careful about unlifted comparisons. When comparing unboxed
305 values we can't call the overloaded functions.
306 See function unliftedOrdOp
307
308 Note [Do not rely on compare]
309 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
310 It's a bad idea to define only 'compare', and build the other binary
311 comparisons on top of it; see Trac #2130, #4019. Reason: we don't
312 want to laboriously make a three-way comparison, only to extract a
313 binary result, something like this:
314 (>) (I# x) (I# y) = case <# x y of
315 True -> False
316 False -> case ==# x y of
317 True -> False
318 False -> True
319
320 So for sufficiently small types (few constructors, or all nullary)
321 we generate all methods; for large ones we just use 'compare'.
322 -}
323
324 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
325
326 ------------
327 ordMethRdr :: OrdOp -> RdrName
328 ordMethRdr op
329 = case op of
330 OrdCompare -> compare_RDR
331 OrdLT -> lt_RDR
332 OrdLE -> le_RDR
333 OrdGE -> ge_RDR
334 OrdGT -> gt_RDR
335
336 ------------
337 ltResult :: OrdOp -> LHsExpr RdrName
338 -- Knowing a<b, what is the result for a `op` b?
339 ltResult OrdCompare = ltTag_Expr
340 ltResult OrdLT = true_Expr
341 ltResult OrdLE = true_Expr
342 ltResult OrdGE = false_Expr
343 ltResult OrdGT = false_Expr
344
345 ------------
346 eqResult :: OrdOp -> LHsExpr RdrName
347 -- Knowing a=b, what is the result for a `op` b?
348 eqResult OrdCompare = eqTag_Expr
349 eqResult OrdLT = false_Expr
350 eqResult OrdLE = true_Expr
351 eqResult OrdGE = true_Expr
352 eqResult OrdGT = false_Expr
353
354 ------------
355 gtResult :: OrdOp -> LHsExpr RdrName
356 -- Knowing a>b, what is the result for a `op` b?
357 gtResult OrdCompare = gtTag_Expr
358 gtResult OrdLT = false_Expr
359 gtResult OrdLE = false_Expr
360 gtResult OrdGE = true_Expr
361 gtResult OrdGT = true_Expr
362
363 ------------
364 gen_Ord_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
365 gen_Ord_binds loc tycon
366 | null tycon_data_cons -- No data-cons => invoke bale-out case
367 = (unitBag $ mk_FunBind loc compare_RDR [], emptyBag)
368 | otherwise
369 = (unitBag (mkOrdOp OrdCompare) `unionBags` other_ops, aux_binds)
370 where
371 aux_binds | single_con_type = emptyBag
372 | otherwise = unitBag $ DerivAuxBind $ DerivCon2Tag tycon
373
374 -- Note [Do not rely on compare]
375 other_ops | (last_tag - first_tag) <= 2 -- 1-3 constructors
376 || null non_nullary_cons -- Or it's an enumeration
377 = listToBag (map mkOrdOp [OrdLT,OrdLE,OrdGE,OrdGT])
378 | otherwise
379 = emptyBag
380
381 get_tag con = dataConTag con - fIRST_TAG
382 -- We want *zero-based* tags, because that's what
383 -- con2Tag returns (generated by untag_Expr)!
384
385 tycon_data_cons = tyConDataCons tycon
386 single_con_type = isSingleton tycon_data_cons
387 (first_con : _) = tycon_data_cons
388 (last_con : _) = reverse tycon_data_cons
389 first_tag = get_tag first_con
390 last_tag = get_tag last_con
391
392 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
393
394
395 mkOrdOp :: OrdOp -> LHsBind RdrName
396 -- Returns a binding op a b = ... compares a and b according to op ....
397 mkOrdOp op = mk_easy_FunBind loc (ordMethRdr op) [a_Pat, b_Pat] (mkOrdOpRhs op)
398
399 mkOrdOpRhs :: OrdOp -> LHsExpr RdrName
400 mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
401 | length nullary_cons <= 2 -- Two nullary or fewer, so use cases
402 = nlHsCase (nlHsVar a_RDR) $
403 map (mkOrdOpAlt op) tycon_data_cons
404 -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
405 -- C2 x -> case b of C2 x -> ....comopare x.... }
406
407 | null non_nullary_cons -- All nullary, so go straight to comparing tags
408 = mkTagCmp op
409
410 | otherwise -- Mixed nullary and non-nullary
411 = nlHsCase (nlHsVar a_RDR) $
412 (map (mkOrdOpAlt op) non_nullary_cons
413 ++ [mkSimpleHsAlt nlWildPat (mkTagCmp op)])
414
415
416 mkOrdOpAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
417 -- Make the alternative (Ki a1 a2 .. av ->
418 mkOrdOpAlt op data_con
419 = mkSimpleHsAlt (nlConVarPat data_con_RDR as_needed) (mkInnerRhs op data_con)
420 where
421 as_needed = take (dataConSourceArity data_con) as_RDRs
422 data_con_RDR = getRdrName data_con
423
424 mkInnerRhs op data_con
425 | single_con_type
426 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
427
428 | tag == first_tag
429 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
430 , mkSimpleHsAlt nlWildPat (ltResult op) ]
431 | tag == last_tag
432 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
433 , mkSimpleHsAlt nlWildPat (gtResult op) ]
434
435 | tag == first_tag + 1
436 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat first_con) (gtResult op)
437 , mkInnerEqAlt op data_con
438 , mkSimpleHsAlt nlWildPat (ltResult op) ]
439 | tag == last_tag - 1
440 = nlHsCase (nlHsVar b_RDR) [ mkSimpleHsAlt (nlConWildPat last_con) (ltResult op)
441 , mkInnerEqAlt op data_con
442 , mkSimpleHsAlt nlWildPat (gtResult op) ]
443
444 | tag > last_tag `div` 2 -- lower range is larger
445 = untag_Expr tycon [(b_RDR, bh_RDR)] $
446 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
447 (gtResult op) $ -- Definitely GT
448 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
449 , mkSimpleHsAlt nlWildPat (ltResult op) ]
450
451 | otherwise -- upper range is larger
452 = untag_Expr tycon [(b_RDR, bh_RDR)] $
453 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
454 (ltResult op) $ -- Definitely LT
455 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
456 , mkSimpleHsAlt nlWildPat (gtResult op) ]
457 where
458 tag = get_tag data_con
459 tag_lit = noLoc (HsLit (HsIntPrim "" (toInteger tag)))
460
461 mkInnerEqAlt :: OrdOp -> DataCon -> LMatch RdrName (LHsExpr RdrName)
462 -- First argument 'a' known to be built with K
463 -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
464 mkInnerEqAlt op data_con
465 = mkSimpleHsAlt (nlConVarPat data_con_RDR bs_needed) $
466 mkCompareFields tycon op (dataConOrigArgTys data_con)
467 where
468 data_con_RDR = getRdrName data_con
469 bs_needed = take (dataConSourceArity data_con) bs_RDRs
470
471 mkTagCmp :: OrdOp -> LHsExpr RdrName
472 -- Both constructors known to be nullary
473 -- genreates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
474 mkTagCmp op = untag_Expr tycon [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
475 unliftedOrdOp tycon intPrimTy op ah_RDR bh_RDR
476
477 mkCompareFields :: TyCon -> OrdOp -> [Type] -> LHsExpr RdrName
478 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
479 -- where the ai,bi have the given types
480 mkCompareFields tycon op tys
481 = go tys as_RDRs bs_RDRs
482 where
483 go [] _ _ = eqResult op
484 go [ty] (a:_) (b:_)
485 | isUnLiftedType ty = unliftedOrdOp tycon ty op a b
486 | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
487 go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
488 (ltResult op)
489 (go tys as bs)
490 (gtResult op)
491 go _ _ _ = panic "mkCompareFields"
492
493 -- (mk_compare ty a b) generates
494 -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
495 -- but with suitable special cases for
496 mk_compare ty a b lt eq gt
497 | isUnLiftedType ty
498 = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
499 | otherwise
500 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
501 [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) lt,
502 mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq,
503 mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gt]
504 where
505 a_expr = nlHsVar a
506 b_expr = nlHsVar b
507 (lt_op, _, eq_op, _, _) = primOrdOps "Ord" tycon ty
508
509 unliftedOrdOp :: TyCon -> Type -> OrdOp -> RdrName -> RdrName -> LHsExpr RdrName
510 unliftedOrdOp tycon ty op a b
511 = case op of
512 OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
513 ltTag_Expr eqTag_Expr gtTag_Expr
514 OrdLT -> wrap lt_op
515 OrdLE -> wrap le_op
516 OrdGE -> wrap ge_op
517 OrdGT -> wrap gt_op
518 where
519 (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" tycon ty
520 wrap prim_op = genPrimOpApp a_expr prim_op b_expr
521 a_expr = nlHsVar a
522 b_expr = nlHsVar b
523
524 unliftedCompare :: RdrName -> RdrName
525 -> LHsExpr RdrName -> LHsExpr RdrName -- What to cmpare
526 -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName -- Three results
527 -> LHsExpr RdrName
528 -- Return (if a < b then lt else if a == b then eq else gt)
529 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
530 = nlHsIf (genPrimOpApp a_expr lt_op b_expr) lt $
531 -- Test (<) first, not (==), because the latter
532 -- is true less often, so putting it first would
533 -- mean more tests (dynamically)
534 nlHsIf (genPrimOpApp a_expr eq_op b_expr) eq gt
535
536 nlConWildPat :: DataCon -> LPat RdrName
537 -- The pattern (K {})
538 nlConWildPat con = noLoc (ConPatIn (noLoc (getRdrName con))
539 (RecCon (HsRecFields { rec_flds = []
540 , rec_dotdot = Nothing })))
541
542 {-
543 ************************************************************************
544 * *
545 Enum instances
546 * *
547 ************************************************************************
548
549 @Enum@ can only be derived for enumeration types. For a type
550 \begin{verbatim}
551 data Foo ... = N1 | N2 | ... | Nn
552 \end{verbatim}
553
554 we use both @con2tag_Foo@ and @tag2con_Foo@ functions, as well as a
555 @maxtag_Foo@ variable (all generated by @gen_tag_n_con_binds@).
556
557 \begin{verbatim}
558 instance ... Enum (Foo ...) where
559 succ x = toEnum (1 + fromEnum x)
560 pred x = toEnum (fromEnum x - 1)
561
562 toEnum i = tag2con_Foo i
563
564 enumFrom a = map tag2con_Foo [con2tag_Foo a .. maxtag_Foo]
565
566 -- or, really...
567 enumFrom a
568 = case con2tag_Foo a of
569 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
570
571 enumFromThen a b
572 = map tag2con_Foo [con2tag_Foo a, con2tag_Foo b .. maxtag_Foo]
573
574 -- or, really...
575 enumFromThen a b
576 = case con2tag_Foo a of { a# ->
577 case con2tag_Foo b of { b# ->
578 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
579 }}
580 \end{verbatim}
581
582 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
583 -}
584
585 gen_Enum_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
586 gen_Enum_binds loc tycon
587 = (method_binds, aux_binds)
588 where
589 method_binds = listToBag [
590 succ_enum,
591 pred_enum,
592 to_enum,
593 enum_from,
594 enum_from_then,
595 from_enum
596 ]
597 aux_binds = listToBag $ map DerivAuxBind
598 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon]
599
600 occ_nm = getOccString tycon
601
602 succ_enum
603 = mk_easy_FunBind loc succ_RDR [a_Pat] $
604 untag_Expr tycon [(a_RDR, ah_RDR)] $
605 nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon),
606 nlHsVarApps intDataCon_RDR [ah_RDR]])
607 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
608 (nlHsApp (nlHsVar (tag2con_RDR tycon))
609 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
610 nlHsIntLit 1]))
611
612 pred_enum
613 = mk_easy_FunBind loc pred_RDR [a_Pat] $
614 untag_Expr tycon [(a_RDR, ah_RDR)] $
615 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
616 nlHsVarApps intDataCon_RDR [ah_RDR]])
617 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
618 (nlHsApp (nlHsVar (tag2con_RDR tycon))
619 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
620 nlHsLit (HsInt "-1" (-1))]))
621
622 to_enum
623 = mk_easy_FunBind loc toEnum_RDR [a_Pat] $
624 nlHsIf (nlHsApps and_RDR
625 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
626 nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]])
627 (nlHsVarApps (tag2con_RDR tycon) [a_RDR])
628 (illegal_toEnum_tag occ_nm (maxtag_RDR tycon))
629
630 enum_from
631 = mk_easy_FunBind loc enumFrom_RDR [a_Pat] $
632 untag_Expr tycon [(a_RDR, ah_RDR)] $
633 nlHsApps map_RDR
634 [nlHsVar (tag2con_RDR tycon),
635 nlHsPar (enum_from_to_Expr
636 (nlHsVarApps intDataCon_RDR [ah_RDR])
637 (nlHsVar (maxtag_RDR tycon)))]
638
639 enum_from_then
640 = mk_easy_FunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
641 untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
642 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
643 nlHsPar (enum_from_then_to_Expr
644 (nlHsVarApps intDataCon_RDR [ah_RDR])
645 (nlHsVarApps intDataCon_RDR [bh_RDR])
646 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
647 nlHsVarApps intDataCon_RDR [bh_RDR]])
648 (nlHsIntLit 0)
649 (nlHsVar (maxtag_RDR tycon))
650 ))
651
652 from_enum
653 = mk_easy_FunBind loc fromEnum_RDR [a_Pat] $
654 untag_Expr tycon [(a_RDR, ah_RDR)] $
655 (nlHsVarApps intDataCon_RDR [ah_RDR])
656
657 {-
658 ************************************************************************
659 * *
660 Bounded instances
661 * *
662 ************************************************************************
663 -}
664
665 gen_Bounded_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
666 gen_Bounded_binds loc tycon
667 | isEnumerationTyCon tycon
668 = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
669 | otherwise
670 = ASSERT(isSingleton data_cons)
671 (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
672 where
673 data_cons = tyConDataCons tycon
674
675 ----- enum-flavored: ---------------------------
676 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
677 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
678
679 data_con_1 = head data_cons
680 data_con_N = last data_cons
681 data_con_1_RDR = getRdrName data_con_1
682 data_con_N_RDR = getRdrName data_con_N
683
684 ----- single-constructor-flavored: -------------
685 arity = dataConSourceArity data_con_1
686
687 min_bound_1con = mkHsVarBind loc minBound_RDR $
688 nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR)
689 max_bound_1con = mkHsVarBind loc maxBound_RDR $
690 nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR)
691
692 {-
693 ************************************************************************
694 * *
695 Ix instances
696 * *
697 ************************************************************************
698
699 Deriving @Ix@ is only possible for enumeration types and
700 single-constructor types. We deal with them in turn.
701
702 For an enumeration type, e.g.,
703 \begin{verbatim}
704 data Foo ... = N1 | N2 | ... | Nn
705 \end{verbatim}
706 things go not too differently from @Enum@:
707 \begin{verbatim}
708 instance ... Ix (Foo ...) where
709 range (a, b)
710 = map tag2con_Foo [con2tag_Foo a .. con2tag_Foo b]
711
712 -- or, really...
713 range (a, b)
714 = case (con2tag_Foo a) of { a# ->
715 case (con2tag_Foo b) of { b# ->
716 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
717 }}
718
719 -- Generate code for unsafeIndex, because using index leads
720 -- to lots of redundant range tests
721 unsafeIndex c@(a, b) d
722 = case (con2tag_Foo d -# con2tag_Foo a) of
723 r# -> I# r#
724
725 inRange (a, b) c
726 = let
727 p_tag = con2tag_Foo c
728 in
729 p_tag >= con2tag_Foo a && p_tag <= con2tag_Foo b
730
731 -- or, really...
732 inRange (a, b) c
733 = case (con2tag_Foo a) of { a_tag ->
734 case (con2tag_Foo b) of { b_tag ->
735 case (con2tag_Foo c) of { c_tag ->
736 if (c_tag >=# a_tag) then
737 c_tag <=# b_tag
738 else
739 False
740 }}}
741 \end{verbatim}
742 (modulo suitable case-ification to handle the unlifted tags)
743
744 For a single-constructor type (NB: this includes all tuples), e.g.,
745 \begin{verbatim}
746 data Foo ... = MkFoo a b Int Double c c
747 \end{verbatim}
748 we follow the scheme given in Figure~19 of the Haskell~1.2 report
749 (p.~147).
750 -}
751
752 gen_Ix_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
753
754 gen_Ix_binds loc tycon
755 | isEnumerationTyCon tycon
756 = ( enum_ixes
757 , listToBag $ map DerivAuxBind
758 [DerivCon2Tag tycon, DerivTag2Con tycon, DerivMaxTag tycon])
759 | otherwise
760 = (single_con_ixes, unitBag (DerivAuxBind (DerivCon2Tag tycon)))
761 where
762 --------------------------------------------------------------
763 enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ]
764
765 enum_range
766 = mk_easy_FunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
767 untag_Expr tycon [(a_RDR, ah_RDR)] $
768 untag_Expr tycon [(b_RDR, bh_RDR)] $
769 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $
770 nlHsPar (enum_from_to_Expr
771 (nlHsVarApps intDataCon_RDR [ah_RDR])
772 (nlHsVarApps intDataCon_RDR [bh_RDR]))
773
774 enum_index
775 = mk_easy_FunBind loc unsafeIndex_RDR
776 [noLoc (AsPat (noLoc c_RDR)
777 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
778 d_Pat] (
779 untag_Expr tycon [(a_RDR, ah_RDR)] (
780 untag_Expr tycon [(d_RDR, dh_RDR)] (
781 let
782 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
783 in
784 nlHsCase
785 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
786 [mkSimpleHsAlt (nlVarPat c_RDR) rhs]
787 ))
788 )
789
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 nlHsIf (genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) (
796 (genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR))
797 ) {-else-} (
798 false_Expr
799 ))))
800
801 --------------------------------------------------------------
802 single_con_ixes
803 = listToBag [single_con_range, single_con_index, single_con_inRange]
804
805 data_con
806 = case tyConSingleDataCon_maybe tycon of -- just checking...
807 Nothing -> panic "get_Ix_binds"
808 Just dc -> dc
809
810 con_arity = dataConSourceArity data_con
811 data_con_RDR = getRdrName data_con
812
813 as_needed = take con_arity as_RDRs
814 bs_needed = take con_arity bs_RDRs
815 cs_needed = take con_arity cs_RDRs
816
817 con_pat xs = nlConVarPat data_con_RDR xs
818 con_expr = nlHsVarApps data_con_RDR cs_needed
819
820 --------------------------------------------------------------
821 single_con_range
822 = mk_easy_FunBind loc range_RDR
823 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
824 noLoc (mkHsComp ListComp stmts con_expr)
825 where
826 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
827
828 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
829 (nlHsApp (nlHsVar range_RDR)
830 (mkLHsVarTuple [a,b]))
831
832 ----------------
833 single_con_index
834 = mk_easy_FunBind loc unsafeIndex_RDR
835 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
836 con_pat cs_needed]
837 -- We need to reverse the order we consider the components in
838 -- so that
839 -- range (l,u) !! index (l,u) i == i -- when i is in range
840 -- (from http://haskell.org/onlinereport/ix.html) holds.
841 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
842 where
843 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
844 mk_index [] = nlHsIntLit 0
845 mk_index [(l,u,i)] = mk_one l u i
846 mk_index ((l,u,i) : rest)
847 = genOpApp (
848 mk_one l u i
849 ) plus_RDR (
850 genOpApp (
851 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
852 (mkLHsVarTuple [l,u]))
853 ) times_RDR (mk_index rest)
854 )
855 mk_one l u i
856 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
857
858 ------------------
859 single_con_inRange
860 = mk_easy_FunBind loc inRange_RDR
861 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
862 con_pat cs_needed] $
863 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
864 where
865 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
866
867 {-
868 ************************************************************************
869 * *
870 Read instances
871 * *
872 ************************************************************************
873
874 Example
875
876 infix 4 %%
877 data T = Int %% Int
878 | T1 { f1 :: Int }
879 | T2 T
880
881 instance Read T where
882 readPrec =
883 parens
884 ( prec 4 (
885 do x <- ReadP.step Read.readPrec
886 expectP (Symbol "%%")
887 y <- ReadP.step Read.readPrec
888 return (x %% y))
889 +++
890 prec (appPrec+1) (
891 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
892 -- Record construction binds even more tightly than application
893 do expectP (Ident "T1")
894 expectP (Punc '{')
895 expectP (Ident "f1")
896 expectP (Punc '=')
897 x <- ReadP.reset Read.readPrec
898 expectP (Punc '}')
899 return (T1 { f1 = x }))
900 +++
901 prec appPrec (
902 do expectP (Ident "T2")
903 x <- ReadP.step Read.readPrec
904 return (T2 x))
905 )
906
907 readListPrec = readListPrecDefault
908 readList = readListDefault
909
910
911 Note [Use expectP]
912 ~~~~~~~~~~~~~~~~~~
913 Note that we use
914 expectP (Ident "T1")
915 rather than
916 Ident "T1" <- lexP
917 The latter desugares to inline code for matching the Ident and the
918 string, and this can be very voluminous. The former is much more
919 compact. Cf Trac #7258, although that also concerned non-linearity in
920 the occurrence analyser, a separate issue.
921
922 Note [Read for empty data types]
923 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
924 What should we get for this? (Trac #7931)
925 data Emp deriving( Read ) -- No data constructors
926
927 Here we want
928 read "[]" :: [Emp] to succeed, returning []
929 So we do NOT want
930 instance Read Emp where
931 readPrec = error "urk"
932 Rather we want
933 instance Read Emp where
934 readPred = pfail -- Same as choose []
935
936 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
937 These instances are also useful for Read (Either Int Emp), where
938 we want to be able to parse (Left 3) just fine.
939 -}
940
941 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
942
943 gen_Read_binds get_fixity loc tycon
944 = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
945 where
946 -----------------------------------------------------------------------
947 default_readlist
948 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
949
950 default_readlistprec
951 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
952 -----------------------------------------------------------------------
953
954 data_cons = tyConDataCons tycon
955 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
956
957 read_prec = mkHsVarBind loc readPrec_RDR
958 (nlHsApp (nlHsVar parens_RDR) read_cons)
959
960 read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types]
961 | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
962 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
963
964 read_nullary_cons
965 = case nullary_cons of
966 [] -> []
967 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
968 _ -> [nlHsApp (nlHsVar choose_RDR)
969 (nlList (map mk_pair nullary_cons))]
970 -- NB For operators the parens around (:=:) are matched by the
971 -- enclosing "parens" call, so here we must match the naked
972 -- data_con_str con
973
974 match_con con | isSym con_str = [symbol_pat con_str]
975 | otherwise = ident_h_pat con_str
976 where
977 con_str = data_con_str con
978 -- For nullary constructors we must match Ident s for normal constrs
979 -- and Symbol s for operators
980
981 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
982 result_expr con []]
983
984 read_non_nullary_con data_con
985 | is_infix = mk_parser infix_prec infix_stmts body
986 | is_record = mk_parser record_prec record_stmts body
987 -- Using these two lines instead allows the derived
988 -- read for infix and record bindings to read the prefix form
989 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
990 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
991 | otherwise = prefix_parser
992 where
993 body = result_expr data_con as_needed
994 con_str = data_con_str data_con
995
996 prefix_parser = mk_parser prefix_prec prefix_stmts body
997
998 read_prefix_con
999 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
1000 | otherwise = ident_h_pat con_str
1001
1002 read_infix_con
1003 | isSym con_str = [symbol_pat con_str]
1004 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
1005
1006 prefix_stmts -- T a b c
1007 = read_prefix_con ++ read_args
1008
1009 infix_stmts -- a %% b, or a `T` b
1010 = [read_a1]
1011 ++ read_infix_con
1012 ++ [read_a2]
1013
1014 record_stmts -- T { f1 = a, f2 = b }
1015 = read_prefix_con
1016 ++ [read_punc "{"]
1017 ++ concat (intersperse [read_punc ","] field_stmts)
1018 ++ [read_punc "}"]
1019
1020 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
1021
1022 con_arity = dataConSourceArity data_con
1023 labels = map flLabel $ dataConFieldLabels data_con
1024 dc_nm = getName data_con
1025 is_infix = dataConIsInfix data_con
1026 is_record = length labels > 0
1027 as_needed = take con_arity as_RDRs
1028 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
1029 (read_a1:read_a2:_) = read_args
1030
1031 prefix_prec = appPrecedence
1032 infix_prec = getPrecedence get_fixity dc_nm
1033 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
1034 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
1035
1036 ------------------------------------------------------------------------
1037 -- Helpers
1038 ------------------------------------------------------------------------
1039 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
1040 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
1041 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
1042 con_app con as = nlHsVarApps (getRdrName con) as -- con as
1043 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1044
1045 -- For constructors and field labels ending in '#', we hackily
1046 -- let the lexer generate two tokens, and look for both in sequence
1047 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
1048 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
1049 | otherwise = [ ident_pat s ]
1050
1051 bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
1052 -- See Note [Use expectP]
1053 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo")
1054 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>")
1055 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<")
1056
1057 data_con_str con = occNameString (getOccName con)
1058
1059 read_arg a ty = ASSERT( not (isUnLiftedType ty) )
1060 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
1061
1062 read_field lbl a = read_lbl lbl ++
1063 [read_punc "=",
1064 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
1065
1066 -- When reading field labels we might encounter
1067 -- a = 3
1068 -- _a = 3
1069 -- or (#) = 4
1070 -- Note the parens!
1071 read_lbl lbl | isSym lbl_str
1072 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1073 | otherwise
1074 = ident_h_pat lbl_str
1075 where
1076 lbl_str = unpackFS lbl
1077
1078 {-
1079 ************************************************************************
1080 * *
1081 Show instances
1082 * *
1083 ************************************************************************
1084
1085 Example
1086
1087 infixr 5 :^:
1088
1089 data Tree a = Leaf a | Tree a :^: Tree a
1090
1091 instance (Show a) => Show (Tree a) where
1092
1093 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1094 where
1095 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1096
1097 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1098 where
1099 showStr = showsPrec (up_prec+1) u .
1100 showString " :^: " .
1101 showsPrec (up_prec+1) v
1102 -- Note: right-associativity of :^: ignored
1103
1104 up_prec = 5 -- Precedence of :^:
1105 app_prec = 10 -- Application has precedence one more than
1106 -- the most tightly-binding operator
1107 -}
1108
1109 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1110
1111 gen_Show_binds get_fixity loc tycon
1112 = (listToBag [shows_prec, show_list], emptyBag)
1113 where
1114 -----------------------------------------------------------------------
1115 show_list = mkHsVarBind loc showList_RDR
1116 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1117 -----------------------------------------------------------------------
1118 data_cons = tyConDataCons tycon
1119 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
1120
1121 pats_etc data_con
1122 | nullary_con = -- skip the showParen junk...
1123 ASSERT(null bs_needed)
1124 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1125 | record_syntax = -- skip showParen (#2530)
1126 ([a_Pat, con_pat], nlHsPar (nested_compose_Expr show_thingies))
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_FunBind 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_FunBind 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 `mkArrowKind` liftedTypeKind
1399 kind2 = liftedTypeKind `mkArrowKind` 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 -- fmap f = \x -> x
1567 , ft_var = return f_Expr -- fmap f = f
1568 , ft_fun = \g h -> do -- fmap f = \x b -> h (x (g b))
1569 gg <- g
1570 hh <- h
1571 mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b))
1572 , ft_tup = \t gs -> do -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1573 gg <- sequence gs
1574 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1575 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g -- fmap f = fmap g
1576 , ft_forall = \_ g -> g
1577 , ft_bad_app = panic "in other argument"
1578 , ft_co_var = panic "contravariant" }
1579
1580 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
1581 match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
1582 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1583 match_for_con = mkSimpleConMatch $
1584 \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 ..
1585
1586 {-
1587 Utility functions related to Functor deriving.
1588
1589 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1590 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1591 -}
1592
1593 -- Generic traversal for Functor deriving
1594 data FFoldType a -- Describes how to fold over a Type in a functor like way
1595 = FT { ft_triv :: a -- Does not contain variable
1596 , ft_var :: a -- The variable itself
1597 , ft_co_var :: a -- The variable itself, contravariantly
1598 , ft_fun :: a -> a -> a -- Function type
1599 , ft_tup :: TyCon -> [a] -> a -- Tuple type
1600 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1601 , ft_bad_app :: a -- Type app, variable other than in last argument
1602 , ft_forall :: TcTyVar -> a -> a -- Forall type
1603 }
1604
1605 functorLikeTraverse :: forall a.
1606 TyVar -- ^ Variable to look for
1607 -> FFoldType a -- ^ How to fold
1608 -> Type -- ^ Type to process
1609 -> a
1610 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1611 , ft_co_var = caseCoVar, ft_fun = caseFun
1612 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1613 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1614 ty
1615 = fst (go False ty)
1616 where
1617 go :: Bool -- Covariant or contravariant context
1618 -> Type
1619 -> (a, Bool) -- (result of type a, does type contain var)
1620
1621 go co ty | Just ty' <- coreView ty = go co ty'
1622 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1623 go co (FunTy x y) | isPredTy x = go co y
1624 | xc || yc = (caseFun xr yr,True)
1625 where (xr,xc) = go (not co) x
1626 (yr,yc) = go co y
1627 go co (AppTy x y) | xc = (caseWrongArg, True)
1628 | yc = (caseTyApp x yr, True)
1629 where (_, xc) = go co x
1630 (yr,yc) = go co y
1631 go co ty@(TyConApp con args)
1632 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
1633 -- At this point we know that xrs, xcs is not empty,
1634 -- and at least one xr is True
1635 | isTupleTyCon con = (caseTuple con xrs, True)
1636 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
1637 | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty
1638 = (caseTyApp fun_ty (last xrs), True)
1639 | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
1640 where
1641 (xrs,xcs) = unzip (map (go co) args)
1642 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1643 where (xr,xc) = go co x
1644 go _ _ = (caseTrivial,False)
1645
1646 -- Return all syntactic subterms of ty that contain var somewhere
1647 -- These are the things that should appear in instance constraints
1648 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1649 deepSubtypesContaining tv
1650 = functorLikeTraverse tv
1651 (FT { ft_triv = []
1652 , ft_var = []
1653 , ft_fun = (++)
1654 , ft_tup = \_ xs -> concat xs
1655 , ft_ty_app = (:)
1656 , ft_bad_app = panic "in other argument"
1657 , ft_co_var = panic "contravariant"
1658 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1659
1660
1661 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1662 -- Fold over the arguments of the datacon
1663 foldDataConArgs ft con
1664 = map foldArg (dataConOrigArgTys con)
1665 where
1666 foldArg
1667 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
1668 Just tv -> functorLikeTraverse tv ft
1669 Nothing -> const (ft_triv ft)
1670 -- If we are deriving Foldable for a GADT, there is a chance that the last
1671 -- type variable in the data type isn't actually a type variable at all.
1672 -- (for example, this can happen if the last type variable is refined to
1673 -- be a concrete type such as Int). If the last type variable is refined
1674 -- to be a specific type, then getTyVar_maybe will return Nothing.
1675 -- See Note [DeriveFoldable with ExistentialQuantification]
1676 --
1677 -- The kind checks have ensured the last type parameter is of kind *.
1678
1679 -- Make a HsLam using a fresh variable from a State monad
1680 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1681 -> State [RdrName] (LHsExpr RdrName)
1682 -- (mkSimpleLam fn) returns (\x. fn(x))
1683 mkSimpleLam lam = do
1684 (n:names) <- get
1685 put names
1686 body <- lam (nlHsVar n)
1687 return (mkHsLam [nlVarPat n] body)
1688
1689 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
1690 -> State [RdrName] (LHsExpr RdrName))
1691 -> State [RdrName] (LHsExpr RdrName)
1692 mkSimpleLam2 lam = do
1693 (n1:n2:names) <- get
1694 put names
1695 body <- lam (nlHsVar n1) (nlHsVar n2)
1696 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1697
1698 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1699 mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1700 -> [LPat RdrName]
1701 -> DataCon
1702 -> [LHsExpr RdrName]
1703 -> m (LMatch RdrName (LHsExpr RdrName))
1704 mkSimpleConMatch fold extra_pats con insides = do
1705 let con_name = getRdrName con
1706 let vars_needed = takeList insides as_RDRs
1707 let pat = nlConVarPat con_name vars_needed
1708 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1709 return $ mkMatch (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds)
1710
1711 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1712 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1713 -> m (LMatch RdrName (LHsExpr RdrName)))
1714 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1715 mkSimpleTupleCase match_for_con tc insides x
1716 = do { let data_con = tyConSingleDataCon tc
1717 ; match <- match_for_con [] data_con insides
1718 ; return $ nlHsCase x [match] }
1719
1720 {-
1721 ************************************************************************
1722 * *
1723 Foldable instances
1724
1725 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1726
1727 * *
1728 ************************************************************************
1729
1730 Deriving Foldable instances works the same way as Functor instances,
1731 only Foldable instances are not possible for function types at all.
1732 Here the derived instance for the type T above is:
1733
1734 instance Foldable T where
1735 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1736
1737 The cases are:
1738
1739 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
1740 $(foldr 'a 'a) = f
1741 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1742 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
1743
1744 Note that the arguments to the real foldr function are the wrong way around,
1745 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1746
1747 Foldable instances differ from Functor and Traversable instances in that
1748 Foldable instances can be derived for data types in which the last type
1749 variable is existentially quantified. In particular, if the last type variable
1750 is refined to a more specific type in a GADT:
1751
1752 data GADT a where
1753 G :: a ~ Int => a -> G Int
1754
1755 then the deriving machinery does not attempt to check that the type a contains
1756 Int, since it is not syntactically equal to a type variable. That is, the
1757 derived Foldable instance for GADT is:
1758
1759 instance Foldable GADT where
1760 foldr _ z (GADT _) = z
1761
1762 See Note [DeriveFoldable with ExistentialQuantification].
1763
1764 -}
1765
1766 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1767 gen_Foldable_binds loc tycon
1768 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1769 where
1770 data_cons = tyConDataCons tycon
1771
1772 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1773 eqns = map foldr_eqn data_cons
1774 foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1775 where
1776 parts = sequence $ foldDataConArgs ft_foldr con
1777
1778 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1779 foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1780 where
1781 parts = sequence $ foldDataConArgs ft_foldMap con
1782
1783 ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
1784 ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z -> return z -- foldr f = \x z -> z
1785 , ft_var = return f_Expr -- foldr f = f
1786 , ft_tup = \t g -> do gg <- sequence g -- foldr f = (\x z -> case x of ...)
1787 mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
1788 , ft_ty_app = \_ g -> do gg <- g -- foldr f = (\x z -> foldr g z x)
1789 mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1790 , ft_forall = \_ g -> g
1791 , ft_co_var = panic "contravariant"
1792 , ft_fun = panic "function"
1793 , ft_bad_app = panic "in other argument" }
1794
1795 match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z))
1796
1797 ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1798 ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr -- foldMap f = \x -> mempty
1799 , ft_var = return f_Expr -- foldMap f = f
1800 , ft_tup = \t g -> do gg <- sequence g -- foldMap f = \x -> case x of (..,)
1801 mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
1802 , ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g -- foldMap f = foldMap g
1803 , ft_forall = \_ g -> g
1804 , ft_co_var = panic "contravariant"
1805 , ft_fun = panic "function"
1806 , ft_bad_app = panic "in other argument" }
1807
1808 match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
1809 case xs of
1810 [] -> mempty_Expr
1811 xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
1812
1813 {-
1814 ************************************************************************
1815 * *
1816 Traversable instances
1817
1818 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1819 * *
1820 ************************************************************************
1821
1822 Again, Traversable is much like Functor and Foldable.
1823
1824 The cases are:
1825
1826 $(traverse 'a 'b) = pure -- when b does not contain a
1827 $(traverse 'a 'a) = f
1828 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1829 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
1830
1831 Note that the generated code is not as efficient as it could be. For instance:
1832
1833 data T a = T Int a deriving Traversable
1834
1835 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1836 instead of: traverse f (T x y) = T x <$> f y
1837 -}
1838
1839 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1840 gen_Traversable_binds loc tycon
1841 = (unitBag traverse_bind, emptyBag)
1842 where
1843 data_cons = tyConDataCons tycon
1844
1845 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
1846 eqns = map traverse_eqn data_cons
1847 traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1848 where
1849 parts = sequence $ foldDataConArgs ft_trav con
1850
1851
1852 ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
1853 ft_trav = FT { ft_triv = return pure_Expr -- traverse f = pure x
1854 , ft_var = return f_Expr -- traverse f = f x
1855 , ft_tup = \t gs -> do -- traverse f = \x -> case x of (a1,a2,..) ->
1856 gg <- sequence gs -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1857 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1858 , ft_ty_app = \_ g -> nlHsApp traverse_Expr <$> g -- traverse f = travese g
1859 , ft_forall = \_ g -> g
1860 , ft_co_var = panic "contravariant"
1861 , ft_fun = panic "function"
1862 , ft_bad_app = panic "in other argument" }
1863
1864 -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
1865 match_for_con = mkSimpleConMatch $
1866 \con_name xs -> return $ mkApCon (nlHsVar con_name) xs
1867
1868 -- ((Con <$> x1) <*> x2) <*> ..
1869 mkApCon con [] = nlHsApps pure_RDR [con]
1870 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1871 where appAp x y = nlHsApps ap_RDR [x,y]
1872
1873 {-
1874 ************************************************************************
1875 * *
1876 Lift instances
1877 * *
1878 ************************************************************************
1879
1880 Example:
1881
1882 data Foo a = Foo a | a :^: a deriving Lift
1883
1884 ==>
1885
1886 instance (Lift a) => Lift (Foo a) where
1887 lift (Foo a)
1888 = appE
1889 (conE
1890 (mkNameG_d "package-name" "ModuleName" "Foo"))
1891 (lift a)
1892 lift (u :^: v)
1893 = infixApp
1894 (lift u)
1895 (conE
1896 (mkNameG_d "package-name" "ModuleName" ":^:"))
1897 (lift v)
1898
1899 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
1900 'Foo would be when using the -XTemplateHaskell extension. To make sure that
1901 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
1902 makeG_d.
1903 -}
1904
1905 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1906 gen_Lift_binds loc tycon
1907 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
1908 [mkMatch [nlWildPat] errorMsg_Expr
1909 (noLoc emptyLocalBinds)])
1910 , emptyBag)
1911 | otherwise = (unitBag lift_bind, emptyBag)
1912 where
1913 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
1914 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
1915
1916 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
1917 data_cons = tyConDataCons tycon
1918 tycon_str = occNameString . nameOccName . tyConName $ tycon
1919
1920 pats_etc data_con
1921 = ([con_pat], lift_Expr)
1922 where
1923 con_pat = nlConVarPat data_con_RDR as_needed
1924 data_con_RDR = getRdrName data_con
1925 con_arity = dataConSourceArity data_con
1926 as_needed = take con_arity as_RDRs
1927 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1928 tys_needed as_needed
1929 tycon_name = tyConName tycon
1930 is_infix = dataConIsInfix data_con
1931 tys_needed = dataConOrigArgTys data_con
1932
1933 mk_lift_app ty a
1934 | not (isUnLiftedType ty) = nlHsApp (nlHsVar lift_RDR)
1935 (nlHsVar a)
1936 | otherwise = nlHsApp (nlHsVar litE_RDR)
1937 (primLitOp (mkBoxExp (nlHsVar a)))
1938 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1939
1940 pkg_name = unitIdString . moduleUnitId
1941 . nameModule $ tycon_name
1942 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1943 con_name = occNameString . nameOccName . dataConName $ data_con
1944
1945 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1946 (nlHsApps mkNameG_dRDR
1947 (map (nlHsLit . mkHsString)
1948 [pkg_name, mod_name, con_name]))
1949
1950 lift_Expr
1951 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1952 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1953 (a1:a2:_) = lifted_as
1954
1955 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1956 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1957
1958 {-
1959 ************************************************************************
1960 * *
1961 Newtype-deriving instances
1962 * *
1963 ************************************************************************
1964
1965 We take every method in the original instance and `coerce` it to fit
1966 into the derived instance. We need a type annotation on the argument
1967 to `coerce` to make it obvious what instantiation of the method we're
1968 coercing from.
1969
1970 See #8503 for more discussion.
1971 -}
1972
1973 mkCoerceClassMethEqn :: Class -- the class being derived
1974 -> [TyVar] -- the tvs in the instance head
1975 -> [Type] -- instance head parameters (incl. newtype)
1976 -> Type -- the representation type (already eta-reduced)
1977 -> Id -- the method to look at
1978 -> Pair Type
1979 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
1980 = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty)
1981 where
1982 cls_tvs = classTyVars cls
1983 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1984 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
1985 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
1986 (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
1987
1988 changeLast :: [a] -> a -> [a]
1989 changeLast [] _ = panic "changeLast"
1990 changeLast [_] x = [x]
1991 changeLast (x:xs) x' = x : changeLast xs x'
1992
1993
1994 gen_Newtype_binds :: SrcSpan
1995 -> Class -- the class being derived
1996 -> [TyVar] -- the tvs in the instance head
1997 -> [Type] -- instance head parameters (incl. newtype)
1998 -> Type -- the representation type (already eta-reduced)
1999 -> LHsBinds RdrName
2000 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
2001 = listToBag $ zipWith mk_bind
2002 (classMethods cls)
2003 (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
2004 where
2005 coerce_RDR = getRdrName coerceId
2006 mk_bind :: Id -> Pair Type -> LHsBind RdrName
2007 mk_bind id (Pair tau_ty user_ty)
2008 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
2009 where
2010 meth_RDR = getRdrName id
2011 rhs_expr
2012 = ( nlHsVar coerce_RDR
2013 `nlHsApp`
2014 (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType tau_ty'))
2015 `nlExprWithTySig` toLHsSigWcType user_ty
2016 -- Open the representation type here, so that it's forall'ed type
2017 -- variables refer to the ones bound in the user_ty
2018 (_, _, tau_ty') = tcSplitSigmaTy tau_ty
2019
2020 nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
2021 nlExprWithTySig e s = noLoc (ExprWithTySig e s)
2022
2023 {-
2024 ************************************************************************
2025 * *
2026 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
2027 * *
2028 ************************************************************************
2029
2030 \begin{verbatim}
2031 data Foo ... = ...
2032
2033 con2tag_Foo :: Foo ... -> Int#
2034 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2035 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2036 \end{verbatim}
2037
2038 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2039 fiddling around.
2040 -}
2041
2042 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
2043 genAuxBindSpec loc (DerivCon2Tag tycon)
2044 = (mk_FunBind loc rdr_name eqns,
2045 L loc (TypeSig [L loc rdr_name] sig_ty))
2046 where
2047 rdr_name = con2tag_RDR tycon
2048
2049 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
2050 mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
2051 mkParentType tycon `mkFunTy` intPrimTy
2052
2053 lots_of_constructors = tyConFamilySize tycon > 8
2054 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
2055 -- but we don't do vectored returns any more.
2056
2057 eqns | lots_of_constructors = [get_tag_eqn]
2058 | otherwise = map mk_eqn (tyConDataCons tycon)
2059
2060 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
2061
2062 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
2063 mk_eqn con = ([nlWildConPat con],
2064 nlHsLit (HsIntPrim ""
2065 (toInteger ((dataConTag con) - fIRST_TAG))))
2066
2067 genAuxBindSpec loc (DerivTag2Con tycon)
2068 = (mk_FunBind loc rdr_name
2069 [([nlConVarPat intDataCon_RDR [a_RDR]],
2070 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2071 L loc (TypeSig [L loc rdr_name] sig_ty))
2072 where
2073 sig_ty = mkLHsSigWcType $ L loc $
2074 HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
2075 intTy `mkFunTy` mkParentType tycon
2076
2077 rdr_name = tag2con_RDR tycon
2078
2079 genAuxBindSpec loc (DerivMaxTag tycon)
2080 = (mkHsVarBind loc rdr_name rhs,
2081 L loc (TypeSig [L loc rdr_name] sig_ty))
2082 where
2083 rdr_name = maxtag_RDR tycon
2084 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
2085 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2086 max_tag = case (tyConDataCons tycon) of
2087 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2088
2089 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
2090 ( Bag (LHsBind RdrName, LSig RdrName)
2091 -- Extra bindings (used by Generic only)
2092 , Bag (FamInst) -- Extra family instances
2093 , Bag (InstInfo RdrName)) -- Extra instances
2094
2095 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2096 genAuxBinds loc b = genAuxBinds' b2 where
2097 (b1,b2) = partitionBagWith splitDerivAuxBind b
2098 splitDerivAuxBind (DerivAuxBind x) = Left x
2099 splitDerivAuxBind x = Right x
2100
2101 rm_dups = foldrBag dup_check emptyBag
2102 dup_check a b = if anyBag (== a) b then b else consBag a b
2103
2104 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2105 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2106 , emptyBag, emptyBag)
2107 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2108 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2109 f (DerivHsBind b) = add1 b
2110 f (DerivFamInst t) = add2 t
2111 f (DerivInst i) = add3 i
2112
2113 add1 x (a,b,c) = (x `consBag` a,b,c)
2114 add2 x (a,b,c) = (a,x `consBag` b,c)
2115 add3 x (a,b,c) = (a,b,x `consBag` c)
2116
2117 mk_data_type_name :: TyCon -> RdrName -- "$tT"
2118 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
2119
2120 mk_constr_name :: DataCon -> RdrName -- "$cC"
2121 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
2122
2123 mkParentType :: TyCon -> Type
2124 -- Turn the representation tycon of a family into
2125 -- a use of its family constructor
2126 mkParentType tc
2127 = case tyConFamInst_maybe tc of
2128 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2129 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2130
2131 {-
2132 ************************************************************************
2133 * *
2134 \subsection{Utility bits for generating bindings}
2135 * *
2136 ************************************************************************
2137 -}
2138
2139 mk_FunBind :: SrcSpan -> RdrName
2140 -> [([LPat RdrName], LHsExpr RdrName)]
2141 -> LHsBind RdrName
2142 mk_FunBind loc fun pats_and_exprs
2143 = mkRdrFunBind (L loc fun) matches
2144 where
2145 matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs]
2146
2147 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2148 mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2149 where
2150 -- Catch-all eqn looks like
2151 -- fmap = error "Void fmap"
2152 -- It's needed if there no data cons at all,
2153 -- which can happen with -XEmptyDataDecls
2154 -- See Trac #4302
2155 matches' = if null matches
2156 then [mkMatch [] (error_Expr str) (noLoc emptyLocalBinds)]
2157 else matches
2158 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2159
2160 box :: String -- The class involved
2161 -> TyCon -- The tycon involved
2162 -> LHsExpr RdrName -- The argument
2163 -> Type -- The argument type
2164 -> LHsExpr RdrName -- Boxed version of the arg
2165 -- See Note [Deriving and unboxed types] in TcDeriv
2166 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2167 where
2168 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2169
2170 ---------------------
2171 primOrdOps :: String -- The class involved
2172 -> TyCon -- The tycon involved
2173 -> Type -- The type
2174 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2175 -- See Note [Deriving and unboxed types] in TcDeriv
2176 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2177
2178 primLitOps :: String -- The class involved
2179 -> TyCon -- The tycon involved
2180 -> Type -- The type
2181 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
2182 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
2183 )
2184 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2185 , \v -> nlHsVar boxRDR `nlHsApp` v
2186 )
2187 where
2188 boxRDR
2189 | ty == addrPrimTy = unpackCString_RDR
2190 | otherwise = assoc_ty_id str tycon boxConTbl ty
2191
2192 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2193 ordOpTbl
2194 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2195 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2196 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2197 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2198 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2199 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2200
2201 boxConTbl :: [(Type, RdrName)]
2202 boxConTbl
2203 = [(charPrimTy , getRdrName charDataCon )
2204 ,(intPrimTy , getRdrName intDataCon )
2205 ,(wordPrimTy , getRdrName wordDataCon )
2206 ,(floatPrimTy , getRdrName floatDataCon )
2207 ,(doublePrimTy, getRdrName doubleDataCon)
2208 ]
2209
2210 -- | A table of postfix modifiers for unboxed values.
2211 postfixModTbl :: [(Type, String)]
2212 postfixModTbl
2213 = [(charPrimTy , "#" )
2214 ,(intPrimTy , "#" )
2215 ,(wordPrimTy , "##")
2216 ,(floatPrimTy , "#" )
2217 ,(doublePrimTy, "##")
2218 ]
2219
2220 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
2221 litConTbl
2222 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2223 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2224 . nlHsApp (nlHsVar toInteger_RDR))
2225 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2226 . nlHsApp (nlHsVar toInteger_RDR))
2227 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2228 . nlHsApp (nlHsApp
2229 (nlHsVar map_RDR)
2230 (compose_RDR `nlHsApps`
2231 [ nlHsVar fromIntegral_RDR
2232 , nlHsVar fromEnum_RDR
2233 ])))
2234 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2235 . nlHsApp (nlHsVar toRational_RDR))
2236 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2237 . nlHsApp (nlHsVar toRational_RDR))
2238 ]
2239
2240 -- | Lookup `Type` in an association list.
2241 assoc_ty_id :: String -- The class involved
2242 -> TyCon -- The tycon involved
2243 -> [(Type,a)] -- The table
2244 -> Type -- The type
2245 -> a -- The result of the lookup
2246 assoc_ty_id cls_str _ tbl ty
2247 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2248 text "for primitive type" <+> ppr ty)
2249 | otherwise = head res
2250 where
2251 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2252
2253 -----------------------------------------------------------------------
2254
2255 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2256 and_Expr a b = genOpApp a and_RDR b
2257
2258 -----------------------------------------------------------------------
2259
2260 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2261 eq_Expr tycon ty a b
2262 | not (isUnLiftedType ty) = genOpApp a eq_RDR b
2263 | otherwise = genPrimOpApp a prim_eq b
2264 where
2265 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2266
2267 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2268 untag_Expr _ [] expr = expr
2269 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2270 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2271 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2272
2273 enum_from_to_Expr
2274 :: LHsExpr RdrName -> LHsExpr RdrName
2275 -> LHsExpr RdrName
2276 enum_from_then_to_Expr
2277 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2278 -> LHsExpr RdrName
2279
2280 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2281 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2282
2283 showParen_Expr
2284 :: LHsExpr RdrName -> LHsExpr RdrName
2285 -> LHsExpr RdrName
2286
2287 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2288
2289 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2290
2291 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2292 nested_compose_Expr [e] = parenify e
2293 nested_compose_Expr (e:es)
2294 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2295
2296 -- impossible_Expr is used in case RHSs that should never happen.
2297 -- We generate these to keep the desugarer from complaining that they *might* happen!
2298 error_Expr :: String -> LHsExpr RdrName
2299 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2300
2301 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2302 -- method. It is currently only used by Enum.{succ,pred}
2303 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2304 illegal_Expr meth tp msg =
2305 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2306
2307 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2308 -- to include the value of a_RDR in the error string.
2309 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2310 illegal_toEnum_tag tp maxtag =
2311 nlHsApp (nlHsVar error_RDR)
2312 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2313 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2314 (nlHsApp (nlHsApp (nlHsApp
2315 (nlHsVar showsPrec_RDR)
2316 (nlHsIntLit 0))
2317 (nlHsVar a_RDR))
2318 (nlHsApp (nlHsApp
2319 (nlHsVar append_RDR)
2320 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2321 (nlHsApp (nlHsApp (nlHsApp
2322 (nlHsVar showsPrec_RDR)
2323 (nlHsIntLit 0))
2324 (nlHsVar maxtag))
2325 (nlHsLit (mkHsString ")"))))))
2326
2327 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2328 parenify e@(L _ (HsVar _)) = e
2329 parenify e = mkHsPar e
2330
2331 -- genOpApp wraps brackets round the operator application, so that the
2332 -- renamer won't subsequently try to re-associate it.
2333 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2334 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2335
2336 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2337 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2338
2339 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2340 :: RdrName
2341 a_RDR = mkVarUnqual (fsLit "a")
2342 b_RDR = mkVarUnqual (fsLit "b")
2343 c_RDR = mkVarUnqual (fsLit "c")
2344 d_RDR = mkVarUnqual (fsLit "d")
2345 f_RDR = mkVarUnqual (fsLit "f")
2346 k_RDR = mkVarUnqual (fsLit "k")
2347 z_RDR = mkVarUnqual (fsLit "z")
2348 ah_RDR = mkVarUnqual (fsLit "a#")
2349 bh_RDR = mkVarUnqual (fsLit "b#")
2350 ch_RDR = mkVarUnqual (fsLit "c#")
2351 dh_RDR = mkVarUnqual (fsLit "d#")
2352
2353 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2354 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2355 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2356 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2357
2358 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2359 false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2360 a_Expr = nlHsVar a_RDR
2361 -- b_Expr = nlHsVar b_RDR
2362 c_Expr = nlHsVar c_RDR
2363 f_Expr = nlHsVar f_RDR
2364 z_Expr = nlHsVar z_RDR
2365 ltTag_Expr = nlHsVar ltTag_RDR
2366 eqTag_Expr = nlHsVar eqTag_RDR
2367 gtTag_Expr = nlHsVar gtTag_RDR
2368 false_Expr = nlHsVar false_RDR
2369 true_Expr = nlHsVar true_RDR
2370 fmap_Expr = nlHsVar fmap_RDR
2371 pure_Expr = nlHsVar pure_RDR
2372 mempty_Expr = nlHsVar mempty_RDR
2373 foldMap_Expr = nlHsVar foldMap_RDR
2374 traverse_Expr = nlHsVar traverse_RDR
2375
2376 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2377 a_Pat = nlVarPat a_RDR
2378 b_Pat = nlVarPat b_RDR
2379 c_Pat = nlVarPat c_RDR
2380 d_Pat = nlVarPat d_RDR
2381 f_Pat = nlVarPat f_RDR
2382 k_Pat = nlVarPat k_RDR
2383 z_Pat = nlVarPat z_RDR
2384
2385 minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
2386 minusInt_RDR = getRdrName (primOpId IntSubOp )
2387 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2388 error_RDR = getRdrName eRROR_ID
2389
2390 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2391 -- Generates Orig s RdrName, for the binding positions
2392 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2393 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2394 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2395
2396 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2397 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2398
2399 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2400 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2401 -- See Note [Auxiliary binders]
2402 mkAuxBinderName parent occ_fun
2403 = mkRdrUnqual (occ_fun stable_parent_occ)
2404 where
2405 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2406 stable_string
2407 | opt_PprStyle_Debug = parent_stable
2408 | otherwise = parent_stable_hash
2409 parent_stable = nameStableString parent
2410 parent_stable_hash =
2411 let Fingerprint high low = fingerprintString parent_stable
2412 in toBase62 high ++ toBase62Padded low
2413 -- See Note [Base 62 encoding 128-bit integers]
2414 parent_occ = nameOccName parent
2415
2416
2417 {-
2418 Note [Auxiliary binders]
2419 ~~~~~~~~~~~~~~~~~~~~~~~~
2420 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2421
2422 instance Ord T where
2423 compare a b = $con2tag a `compare` $con2tag b
2424
2425 $con2tag :: T -> Int
2426 $con2tag = ...code....
2427
2428 Of course these top-level bindings should all have distinct name, and we are
2429 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2430 because with standalone deriving two imported TyCons might both be called T!
2431 (See Trac #7947.)
2432
2433 So we use package name, module name and the name of the parent
2434 (T in this example) as part of the OccName we generate for the new binding.
2435 To make the symbol names short we take a base62 hash of the full name.
2436
2437 In the past we used the *unique* from the parent, but that's not stable across
2438 recompilations as uniques are nondeterministic.
2439
2440 Note [DeriveFoldable with ExistentialQuantification]
2441 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2442 Functor and Traversable instances can only be derived for data types whose
2443 last type parameter is truly universally polymorphic. For example:
2444
2445 data T a b where
2446 T1 :: b -> T a b -- YES, b is unconstrained
2447 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
2448 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
2449 T4 :: Int -> T a Int -- NO, this is just like T3
2450 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
2451 -- though a is existential
2452 T6 :: Int -> T Int b -- YES, b is unconstrained
2453
2454 For Foldable instances, however, we can completely lift the constraint that
2455 the last type parameter be truly universally polymorphic. This means that T
2456 (as defined above) can have a derived Foldable instance:
2457
2458 instance Foldable (T a) where
2459 foldr f z (T1 b) = f b z
2460 foldr f z (T2 b) = f b z
2461 foldr f z (T3 b) = f b z
2462 foldr f z (T4 b) = z
2463 foldr f z (T5 a b) = f b z
2464 foldr f z (T6 a) = z
2465
2466 foldMap f (T1 b) = f b
2467 foldMap f (T2 b) = f b
2468 foldMap f (T3 b) = f b
2469 foldMap f (T4 b) = mempty
2470 foldMap f (T5 a b) = f b
2471 foldMap f (T6 a) = mempty
2472
2473 In a Foldable instance, it is safe to fold over an occurrence of the last type
2474 parameter that is not truly universally polymorphic. However, there is a bit
2475 of subtlety in determining what is actually an occurrence of a type parameter.
2476 T3 and T4, as defined above, provide one example:
2477
2478 data T a b where
2479 ...
2480 T3 :: b ~ Int => b -> T a b
2481 T4 :: Int -> T a Int
2482 ...
2483
2484 instance Foldable (T a) where
2485 ...
2486 foldr f z (T3 b) = f b z
2487 foldr f z (T4 b) = z
2488 ...
2489 foldMap f (T3 b) = f b
2490 foldMap f (T4 b) = mempty
2491 ...
2492
2493 Notice that the argument of T3 is folded over, whereas the argument of T4 is
2494 not. This is because we only fold over constructor arguments that
2495 syntactically mention the universally quantified type parameter of that
2496 particular data constructor. See foldDataConArgs for how this is implemented.
2497
2498 As another example, consider the following data type. The argument of each
2499 constructor has the same type as the last type parameter:
2500
2501 data E a where
2502 E1 :: (a ~ Int) => a -> E a
2503 E2 :: Int -> E Int
2504 E3 :: (a ~ Int) => a -> E Int
2505 E4 :: (a ~ Int) => Int -> E a
2506
2507 Only E1's argument is an occurrence of a universally quantified type variable
2508 that is syntactically equivalent to the last type parameter, so only E1's
2509 argument will be be folded over in a derived Foldable instance.
2510
2511 See Trac #10447 for the original discussion on this feature. Also see
2512 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
2513 for a more in-depth explanation.
2514
2515 -}