Visible type application
[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 TyCoRep
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 `mkFunTy` liftedTypeKind
1399 kind2 = liftedTypeKind `mkFunTy` kind1
1400
1401 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1402 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1403 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1404 constr_RDR, dataType_RDR,
1405 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1406 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1407 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1408 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1409 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1410 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1411 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1412 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1413 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1414 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1415 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1416 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1417 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1418 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1419 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1420 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1421 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1422 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1423 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1424 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1425 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1426
1427 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1428 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1429 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1430 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1431 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1432
1433 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1434 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1435 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1436 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1437 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1438
1439 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1440 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1441 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1442 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1443 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1444
1445 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1446 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1447 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1448 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1449 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1450
1451 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1452 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1453 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1454 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1455 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1456
1457 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1458 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1459 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1460 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1461 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1462
1463 {-
1464 ************************************************************************
1465 * *
1466 Functor instances
1467
1468 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1469
1470 * *
1471 ************************************************************************
1472
1473 For the data type:
1474
1475 data T a = T1 Int a | T2 (T a)
1476
1477 We generate the instance:
1478
1479 instance Functor T where
1480 fmap f (T1 b1 a) = T1 b1 (f a)
1481 fmap f (T2 ta) = T2 (fmap f ta)
1482
1483 Notice that we don't simply apply 'fmap' to the constructor arguments.
1484 Rather
1485 - Do nothing to an argument whose type doesn't mention 'a'
1486 - Apply 'f' to an argument of type 'a'
1487 - Apply 'fmap f' to other arguments
1488 That's why we have to recurse deeply into the constructor argument types,
1489 rather than just one level, as we typically do.
1490
1491 What about types with more than one type parameter? In general, we only
1492 derive Functor for the last position:
1493
1494 data S a b = S1 [b] | S2 (a, T a b)
1495 instance Functor (S a) where
1496 fmap f (S1 bs) = S1 (fmap f bs)
1497 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1498
1499 However, we have special cases for
1500 - tuples
1501 - functions
1502
1503 More formally, we write the derivation of fmap code over type variable
1504 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1505 instance for T is:
1506
1507 instance Functor T where
1508 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1509 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1510
1511 $(fmap 'a 'b) = \x -> x -- when b does not contain a
1512 $(fmap 'a 'a) = f
1513 $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1514 $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2
1515 $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1516
1517 For functions, the type parameter 'a can occur in a contravariant position,
1518 which means we need to derive a function like:
1519
1520 cofmap :: (a -> b) -> (f b -> f a)
1521
1522 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1523
1524 $(cofmap 'a 'b) = \x -> x -- when b does not contain a
1525 $(cofmap 'a 'a) = error "type variable in contravariant position"
1526 $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1527 $(cofmap 'a '[b]) = map $(cofmap 'a 'b)
1528 $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2
1529 $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1530
1531 Note that the code produced by $(fmap _ _) is always a higher order function,
1532 with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
1533 matching on the type, this means create a lambda function (see the (,) case above).
1534 The resulting code for fmap can look a bit weird, for example:
1535
1536 data X a = X (a,Int)
1537 -- generated instance
1538 instance Functor X where
1539 fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
1540
1541 The optimizer should be able to simplify this code by simple inlining.
1542
1543 An older version of the deriving code tried to avoid these applied
1544 lambda functions by producing a meta level function. But the function to
1545 be mapped, `f`, is a function on the code level, not on the meta level,
1546 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
1547 It is better to produce too many lambdas than to eta expand, see ticket #7436.
1548 -}
1549
1550 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1551 gen_Functor_binds loc tycon
1552 = (unitBag fmap_bind, emptyBag)
1553 where
1554 data_cons = tyConDataCons tycon
1555 fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns
1556
1557 fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1558 where
1559 parts = sequence $ foldDataConArgs ft_fmap con
1560
1561 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1562 (error_Expr "Void fmap")]
1563 | otherwise = map fmap_eqn data_cons
1564
1565 ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1566 ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x -- 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 (ForAllTy (Anon 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 _ (ForAllTy (Named _ Visible) _) = panic "unexpected visible binder"
1643 go co (ForAllTy (Named v _) x) | v /= var && xc = (caseForAll v xr,True)
1644 where (xr,xc) = go co x
1645
1646 go _ _ = (caseTrivial,False)
1647
1648 -- Return all syntactic subterms of ty that contain var somewhere
1649 -- These are the things that should appear in instance constraints
1650 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1651 deepSubtypesContaining tv
1652 = functorLikeTraverse tv
1653 (FT { ft_triv = []
1654 , ft_var = []
1655 , ft_fun = (++)
1656 , ft_tup = \_ xs -> concat xs
1657 , ft_ty_app = (:)
1658 , ft_bad_app = panic "in other argument"
1659 , ft_co_var = panic "contravariant"
1660 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
1661
1662
1663 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1664 -- Fold over the arguments of the datacon
1665 foldDataConArgs ft con
1666 = map foldArg (dataConOrigArgTys con)
1667 where
1668 foldArg
1669 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
1670 Just tv -> functorLikeTraverse tv ft
1671 Nothing -> const (ft_triv ft)
1672 -- If we are deriving Foldable for a GADT, there is a chance that the last
1673 -- type variable in the data type isn't actually a type variable at all.
1674 -- (for example, this can happen if the last type variable is refined to
1675 -- be a concrete type such as Int). If the last type variable is refined
1676 -- to be a specific type, then getTyVar_maybe will return Nothing.
1677 -- See Note [DeriveFoldable with ExistentialQuantification]
1678 --
1679 -- The kind checks have ensured the last type parameter is of kind *.
1680
1681 -- Make a HsLam using a fresh variable from a State monad
1682 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1683 -> State [RdrName] (LHsExpr RdrName)
1684 -- (mkSimpleLam fn) returns (\x. fn(x))
1685 mkSimpleLam lam = do
1686 (n:names) <- get
1687 put names
1688 body <- lam (nlHsVar n)
1689 return (mkHsLam [nlVarPat n] body)
1690
1691 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
1692 -> State [RdrName] (LHsExpr RdrName))
1693 -> State [RdrName] (LHsExpr RdrName)
1694 mkSimpleLam2 lam = do
1695 (n1:n2:names) <- get
1696 put names
1697 body <- lam (nlHsVar n1) (nlHsVar n2)
1698 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1699
1700 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1701 mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1702 -> [LPat RdrName]
1703 -> DataCon
1704 -> [LHsExpr RdrName]
1705 -> m (LMatch RdrName (LHsExpr RdrName))
1706 mkSimpleConMatch fold extra_pats con insides = do
1707 let con_name = getRdrName con
1708 let vars_needed = takeList insides as_RDRs
1709 let pat = nlConVarPat con_name vars_needed
1710 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1711 return $ mkMatch (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds)
1712
1713 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1714 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1715 -> m (LMatch RdrName (LHsExpr RdrName)))
1716 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1717 mkSimpleTupleCase match_for_con tc insides x
1718 = do { let data_con = tyConSingleDataCon tc
1719 ; match <- match_for_con [] data_con insides
1720 ; return $ nlHsCase x [match] }
1721
1722 {-
1723 ************************************************************************
1724 * *
1725 Foldable instances
1726
1727 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1728
1729 * *
1730 ************************************************************************
1731
1732 Deriving Foldable instances works the same way as Functor instances,
1733 only Foldable instances are not possible for function types at all.
1734 Here the derived instance for the type T above is:
1735
1736 instance Foldable T where
1737 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1738
1739 The cases are:
1740
1741 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
1742 $(foldr 'a 'a) = f
1743 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1744 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
1745
1746 Note that the arguments to the real foldr function are the wrong way around,
1747 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1748
1749 Foldable instances differ from Functor and Traversable instances in that
1750 Foldable instances can be derived for data types in which the last type
1751 variable is existentially quantified. In particular, if the last type variable
1752 is refined to a more specific type in a GADT:
1753
1754 data GADT a where
1755 G :: a ~ Int => a -> G Int
1756
1757 then the deriving machinery does not attempt to check that the type a contains
1758 Int, since it is not syntactically equal to a type variable. That is, the
1759 derived Foldable instance for GADT is:
1760
1761 instance Foldable GADT where
1762 foldr _ z (GADT _) = z
1763
1764 See Note [DeriveFoldable with ExistentialQuantification].
1765
1766 -}
1767
1768 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1769 gen_Foldable_binds loc tycon
1770 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1771 where
1772 data_cons = tyConDataCons tycon
1773
1774 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1775 eqns = map foldr_eqn data_cons
1776 foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1777 where
1778 parts = sequence $ foldDataConArgs ft_foldr con
1779
1780 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1781 foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1782 where
1783 parts = sequence $ foldDataConArgs ft_foldMap con
1784
1785 ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
1786 ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z -> return z -- foldr f = \x z -> z
1787 , ft_var = return f_Expr -- foldr f = f
1788 , ft_tup = \t g -> do gg <- sequence g -- foldr f = (\x z -> case x of ...)
1789 mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
1790 , ft_ty_app = \_ g -> do gg <- g -- foldr f = (\x z -> foldr g z x)
1791 mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1792 , ft_forall = \_ g -> g
1793 , ft_co_var = panic "contravariant"
1794 , ft_fun = panic "function"
1795 , ft_bad_app = panic "in other argument" }
1796
1797 match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z))
1798
1799 ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1800 ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr -- foldMap f = \x -> mempty
1801 , ft_var = return f_Expr -- foldMap f = f
1802 , ft_tup = \t g -> do gg <- sequence g -- foldMap f = \x -> case x of (..,)
1803 mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
1804 , ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g -- foldMap f = foldMap g
1805 , ft_forall = \_ g -> g
1806 , ft_co_var = panic "contravariant"
1807 , ft_fun = panic "function"
1808 , ft_bad_app = panic "in other argument" }
1809
1810 match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
1811 case xs of
1812 [] -> mempty_Expr
1813 xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
1814
1815 {-
1816 ************************************************************************
1817 * *
1818 Traversable instances
1819
1820 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1821 * *
1822 ************************************************************************
1823
1824 Again, Traversable is much like Functor and Foldable.
1825
1826 The cases are:
1827
1828 $(traverse 'a 'b) = pure -- when b does not contain a
1829 $(traverse 'a 'a) = f
1830 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1831 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
1832
1833 Note that the generated code is not as efficient as it could be. For instance:
1834
1835 data T a = T Int a deriving Traversable
1836
1837 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1838 instead of: traverse f (T x y) = T x <$> f y
1839 -}
1840
1841 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1842 gen_Traversable_binds loc tycon
1843 = (unitBag traverse_bind, emptyBag)
1844 where
1845 data_cons = tyConDataCons tycon
1846
1847 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
1848 eqns = map traverse_eqn data_cons
1849 traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1850 where
1851 parts = sequence $ foldDataConArgs ft_trav con
1852
1853
1854 ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
1855 ft_trav = FT { ft_triv = return pure_Expr -- traverse f = pure x
1856 , ft_var = return f_Expr -- traverse f = f x
1857 , ft_tup = \t gs -> do -- traverse f = \x -> case x of (a1,a2,..) ->
1858 gg <- sequence gs -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1859 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1860 , ft_ty_app = \_ g -> nlHsApp traverse_Expr <$> g -- traverse f = travese g
1861 , ft_forall = \_ g -> g
1862 , ft_co_var = panic "contravariant"
1863 , ft_fun = panic "function"
1864 , ft_bad_app = panic "in other argument" }
1865
1866 -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
1867 match_for_con = mkSimpleConMatch $
1868 \con_name xs -> return $ mkApCon (nlHsVar con_name) xs
1869
1870 -- ((Con <$> x1) <*> x2) <*> ..
1871 mkApCon con [] = nlHsApps pure_RDR [con]
1872 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1873 where appAp x y = nlHsApps ap_RDR [x,y]
1874
1875 {-
1876 ************************************************************************
1877 * *
1878 Lift instances
1879 * *
1880 ************************************************************************
1881
1882 Example:
1883
1884 data Foo a = Foo a | a :^: a deriving Lift
1885
1886 ==>
1887
1888 instance (Lift a) => Lift (Foo a) where
1889 lift (Foo a)
1890 = appE
1891 (conE
1892 (mkNameG_d "package-name" "ModuleName" "Foo"))
1893 (lift a)
1894 lift (u :^: v)
1895 = infixApp
1896 (lift u)
1897 (conE
1898 (mkNameG_d "package-name" "ModuleName" ":^:"))
1899 (lift v)
1900
1901 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
1902 'Foo would be when using the -XTemplateHaskell extension. To make sure that
1903 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
1904 makeG_d.
1905 -}
1906
1907 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1908 gen_Lift_binds loc tycon
1909 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
1910 [mkMatch [nlWildPat] errorMsg_Expr
1911 (noLoc emptyLocalBinds)])
1912 , emptyBag)
1913 | otherwise = (unitBag lift_bind, emptyBag)
1914 where
1915 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
1916 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
1917
1918 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
1919 data_cons = tyConDataCons tycon
1920 tycon_str = occNameString . nameOccName . tyConName $ tycon
1921
1922 pats_etc data_con
1923 = ([con_pat], lift_Expr)
1924 where
1925 con_pat = nlConVarPat data_con_RDR as_needed
1926 data_con_RDR = getRdrName data_con
1927 con_arity = dataConSourceArity data_con
1928 as_needed = take con_arity as_RDRs
1929 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1930 tys_needed as_needed
1931 tycon_name = tyConName tycon
1932 is_infix = dataConIsInfix data_con
1933 tys_needed = dataConOrigArgTys data_con
1934
1935 mk_lift_app ty a
1936 | not (isUnLiftedType ty) = nlHsApp (nlHsVar lift_RDR)
1937 (nlHsVar a)
1938 | otherwise = nlHsApp (nlHsVar litE_RDR)
1939 (primLitOp (mkBoxExp (nlHsVar a)))
1940 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1941
1942 pkg_name = unitIdString . moduleUnitId
1943 . nameModule $ tycon_name
1944 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1945 con_name = occNameString . nameOccName . dataConName $ data_con
1946
1947 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1948 (nlHsApps mkNameG_dRDR
1949 (map (nlHsLit . mkHsString)
1950 [pkg_name, mod_name, con_name]))
1951
1952 lift_Expr
1953 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1954 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1955 (a1:a2:_) = lifted_as
1956
1957 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1958 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1959
1960 {-
1961 ************************************************************************
1962 * *
1963 Newtype-deriving instances
1964 * *
1965 ************************************************************************
1966
1967 We take every method in the original instance and `coerce` it to fit
1968 into the derived instance. We need a type annotation on the argument
1969 to `coerce` to make it obvious what instantiation of the method we're
1970 coercing from.
1971
1972 See #8503 for more discussion.
1973 -}
1974
1975 mkCoerceClassMethEqn :: Class -- the class being derived
1976 -> [TyVar] -- the tvs in the instance head
1977 -> [Type] -- instance head parameters (incl. newtype)
1978 -> Type -- the representation type (already eta-reduced)
1979 -> Id -- the method to look at
1980 -> Pair Type
1981 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
1982 = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty)
1983 where
1984 cls_tvs = classTyVars cls
1985 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1986 lhs_subst = mkTCvSubst in_scope (zipTyEnv cls_tvs cls_tys, emptyCvSubstEnv)
1987 rhs_subst = mkTCvSubst in_scope
1988 ( zipTyEnv cls_tvs (changeLast cls_tys rhs_ty)
1989 , emptyCvSubstEnv )
1990 (_class_tvs, _class_constraint, user_meth_ty)
1991 = tcSplitSigmaTy (varType id)
1992
1993 changeLast :: [a] -> a -> [a]
1994 changeLast [] _ = panic "changeLast"
1995 changeLast [_] x = [x]
1996 changeLast (x:xs) x' = x : changeLast xs x'
1997
1998
1999 gen_Newtype_binds :: SrcSpan
2000 -> Class -- the class being derived
2001 -> [TyVar] -- the tvs in the instance head
2002 -> [Type] -- instance head parameters (incl. newtype)
2003 -> Type -- the representation type (already eta-reduced)
2004 -> LHsBinds RdrName
2005 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
2006 = listToBag $ zipWith mk_bind
2007 (classMethods cls)
2008 (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
2009 where
2010 coerce_RDR = getRdrName coerceId
2011 mk_bind :: Id -> Pair Type -> LHsBind RdrName
2012 mk_bind id (Pair tau_ty user_ty)
2013 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
2014 where
2015 meth_RDR = getRdrName id
2016 rhs_expr
2017 = ( nlHsVar coerce_RDR
2018 `nlHsApp`
2019 (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType tau_ty'))
2020 `nlExprWithTySig` toLHsSigWcType user_ty
2021 -- Open the representation type here, so that it's forall'ed type
2022 -- variables refer to the ones bound in the user_ty
2023 (_, _, tau_ty') = tcSplitSigmaTy tau_ty
2024
2025 nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
2026 nlExprWithTySig e s = noLoc (ExprWithTySig e s)
2027
2028 {-
2029 ************************************************************************
2030 * *
2031 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
2032 * *
2033 ************************************************************************
2034
2035 \begin{verbatim}
2036 data Foo ... = ...
2037
2038 con2tag_Foo :: Foo ... -> Int#
2039 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2040 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2041 \end{verbatim}
2042
2043 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2044 fiddling around.
2045 -}
2046
2047 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
2048 genAuxBindSpec loc (DerivCon2Tag tycon)
2049 = (mk_FunBind loc rdr_name eqns,
2050 L loc (TypeSig [L loc rdr_name] sig_ty))
2051 where
2052 rdr_name = con2tag_RDR tycon
2053
2054 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
2055 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
2056 mkParentType tycon `mkFunTy` intPrimTy
2057
2058 lots_of_constructors = tyConFamilySize tycon > 8
2059 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
2060 -- but we don't do vectored returns any more.
2061
2062 eqns | lots_of_constructors = [get_tag_eqn]
2063 | otherwise = map mk_eqn (tyConDataCons tycon)
2064
2065 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
2066
2067 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
2068 mk_eqn con = ([nlWildConPat con],
2069 nlHsLit (HsIntPrim ""
2070 (toInteger ((dataConTag con) - fIRST_TAG))))
2071
2072 genAuxBindSpec loc (DerivTag2Con tycon)
2073 = (mk_FunBind loc rdr_name
2074 [([nlConVarPat intDataCon_RDR [a_RDR]],
2075 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2076 L loc (TypeSig [L loc rdr_name] sig_ty))
2077 where
2078 sig_ty = mkLHsSigWcType $ L loc $
2079 HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
2080 intTy `mkFunTy` mkParentType tycon
2081
2082 rdr_name = tag2con_RDR tycon
2083
2084 genAuxBindSpec loc (DerivMaxTag tycon)
2085 = (mkHsVarBind loc rdr_name rhs,
2086 L loc (TypeSig [L loc rdr_name] sig_ty))
2087 where
2088 rdr_name = maxtag_RDR tycon
2089 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
2090 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2091 max_tag = case (tyConDataCons tycon) of
2092 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2093
2094 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
2095 ( Bag (LHsBind RdrName, LSig RdrName)
2096 -- Extra bindings (used by Generic only)
2097 , Bag (FamInst) -- Extra family instances
2098 , Bag (InstInfo RdrName)) -- Extra instances
2099
2100 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2101 genAuxBinds loc b = genAuxBinds' b2 where
2102 (b1,b2) = partitionBagWith splitDerivAuxBind b
2103 splitDerivAuxBind (DerivAuxBind x) = Left x
2104 splitDerivAuxBind x = Right x
2105
2106 rm_dups = foldrBag dup_check emptyBag
2107 dup_check a b = if anyBag (== a) b then b else consBag a b
2108
2109 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2110 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2111 , emptyBag, emptyBag)
2112 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2113 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2114 f (DerivHsBind b) = add1 b
2115 f (DerivFamInst t) = add2 t
2116 f (DerivInst i) = add3 i
2117
2118 add1 x (a,b,c) = (x `consBag` a,b,c)
2119 add2 x (a,b,c) = (a,x `consBag` b,c)
2120 add3 x (a,b,c) = (a,b,x `consBag` c)
2121
2122 mk_data_type_name :: TyCon -> RdrName -- "$tT"
2123 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
2124
2125 mk_constr_name :: DataCon -> RdrName -- "$cC"
2126 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
2127
2128 mkParentType :: TyCon -> Type
2129 -- Turn the representation tycon of a family into
2130 -- a use of its family constructor
2131 mkParentType tc
2132 = case tyConFamInst_maybe tc of
2133 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2134 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2135
2136 {-
2137 ************************************************************************
2138 * *
2139 \subsection{Utility bits for generating bindings}
2140 * *
2141 ************************************************************************
2142 -}
2143
2144 mk_FunBind :: SrcSpan -> RdrName
2145 -> [([LPat RdrName], LHsExpr RdrName)]
2146 -> LHsBind RdrName
2147 mk_FunBind loc fun pats_and_exprs
2148 = mkRdrFunBind (L loc fun) matches
2149 where
2150 matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs]
2151
2152 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2153 mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2154 where
2155 -- Catch-all eqn looks like
2156 -- fmap = error "Void fmap"
2157 -- It's needed if there no data cons at all,
2158 -- which can happen with -XEmptyDataDecls
2159 -- See Trac #4302
2160 matches' = if null matches
2161 then [mkMatch [] (error_Expr str) (noLoc emptyLocalBinds)]
2162 else matches
2163 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2164
2165 box :: String -- The class involved
2166 -> TyCon -- The tycon involved
2167 -> LHsExpr RdrName -- The argument
2168 -> Type -- The argument type
2169 -> LHsExpr RdrName -- Boxed version of the arg
2170 -- See Note [Deriving and unboxed types] in TcDeriv
2171 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2172 where
2173 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2174
2175 ---------------------
2176 primOrdOps :: String -- The class involved
2177 -> TyCon -- The tycon involved
2178 -> Type -- The type
2179 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2180 -- See Note [Deriving and unboxed types] in TcDeriv
2181 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2182
2183 primLitOps :: String -- The class involved
2184 -> TyCon -- The tycon involved
2185 -> Type -- The type
2186 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
2187 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
2188 )
2189 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2190 , \v -> nlHsVar boxRDR `nlHsApp` v
2191 )
2192 where
2193 boxRDR
2194 | ty `eqType` addrPrimTy = unpackCString_RDR
2195 | otherwise = assoc_ty_id str tycon boxConTbl ty
2196
2197 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2198 ordOpTbl
2199 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2200 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2201 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2202 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2203 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2204 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2205
2206 boxConTbl :: [(Type, RdrName)]
2207 boxConTbl
2208 = [(charPrimTy , getRdrName charDataCon )
2209 ,(intPrimTy , getRdrName intDataCon )
2210 ,(wordPrimTy , getRdrName wordDataCon )
2211 ,(floatPrimTy , getRdrName floatDataCon )
2212 ,(doublePrimTy, getRdrName doubleDataCon)
2213 ]
2214
2215 -- | A table of postfix modifiers for unboxed values.
2216 postfixModTbl :: [(Type, String)]
2217 postfixModTbl
2218 = [(charPrimTy , "#" )
2219 ,(intPrimTy , "#" )
2220 ,(wordPrimTy , "##")
2221 ,(floatPrimTy , "#" )
2222 ,(doublePrimTy, "##")
2223 ]
2224
2225 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
2226 litConTbl
2227 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2228 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2229 . nlHsApp (nlHsVar toInteger_RDR))
2230 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2231 . nlHsApp (nlHsVar toInteger_RDR))
2232 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2233 . nlHsApp (nlHsApp
2234 (nlHsVar map_RDR)
2235 (compose_RDR `nlHsApps`
2236 [ nlHsVar fromIntegral_RDR
2237 , nlHsVar fromEnum_RDR
2238 ])))
2239 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2240 . nlHsApp (nlHsVar toRational_RDR))
2241 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2242 . nlHsApp (nlHsVar toRational_RDR))
2243 ]
2244
2245 -- | Lookup `Type` in an association list.
2246 assoc_ty_id :: String -- The class involved
2247 -> TyCon -- The tycon involved
2248 -> [(Type,a)] -- The table
2249 -> Type -- The type
2250 -> a -- The result of the lookup
2251 assoc_ty_id cls_str _ tbl ty
2252 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2253 text "for primitive type" <+> ppr ty)
2254 | otherwise = head res
2255 where
2256 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2257
2258 -----------------------------------------------------------------------
2259
2260 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2261 and_Expr a b = genOpApp a and_RDR b
2262
2263 -----------------------------------------------------------------------
2264
2265 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2266 eq_Expr tycon ty a b
2267 | not (isUnLiftedType ty) = genOpApp a eq_RDR b
2268 | otherwise = genPrimOpApp a prim_eq b
2269 where
2270 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2271
2272 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2273 untag_Expr _ [] expr = expr
2274 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2275 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2276 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2277
2278 enum_from_to_Expr
2279 :: LHsExpr RdrName -> LHsExpr RdrName
2280 -> LHsExpr RdrName
2281 enum_from_then_to_Expr
2282 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2283 -> LHsExpr RdrName
2284
2285 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2286 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2287
2288 showParen_Expr
2289 :: LHsExpr RdrName -> LHsExpr RdrName
2290 -> LHsExpr RdrName
2291
2292 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2293
2294 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2295
2296 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2297 nested_compose_Expr [e] = parenify e
2298 nested_compose_Expr (e:es)
2299 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2300
2301 -- impossible_Expr is used in case RHSs that should never happen.
2302 -- We generate these to keep the desugarer from complaining that they *might* happen!
2303 error_Expr :: String -> LHsExpr RdrName
2304 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2305
2306 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2307 -- method. It is currently only used by Enum.{succ,pred}
2308 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2309 illegal_Expr meth tp msg =
2310 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2311
2312 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2313 -- to include the value of a_RDR in the error string.
2314 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2315 illegal_toEnum_tag tp maxtag =
2316 nlHsApp (nlHsVar error_RDR)
2317 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2318 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2319 (nlHsApp (nlHsApp (nlHsApp
2320 (nlHsVar showsPrec_RDR)
2321 (nlHsIntLit 0))
2322 (nlHsVar a_RDR))
2323 (nlHsApp (nlHsApp
2324 (nlHsVar append_RDR)
2325 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2326 (nlHsApp (nlHsApp (nlHsApp
2327 (nlHsVar showsPrec_RDR)
2328 (nlHsIntLit 0))
2329 (nlHsVar maxtag))
2330 (nlHsLit (mkHsString ")"))))))
2331
2332 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2333 parenify e@(L _ (HsVar _)) = e
2334 parenify e = mkHsPar e
2335
2336 -- genOpApp wraps brackets round the operator application, so that the
2337 -- renamer won't subsequently try to re-associate it.
2338 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2339 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2340
2341 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2342 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2343
2344 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2345 :: RdrName
2346 a_RDR = mkVarUnqual (fsLit "a")
2347 b_RDR = mkVarUnqual (fsLit "b")
2348 c_RDR = mkVarUnqual (fsLit "c")
2349 d_RDR = mkVarUnqual (fsLit "d")
2350 f_RDR = mkVarUnqual (fsLit "f")
2351 k_RDR = mkVarUnqual (fsLit "k")
2352 z_RDR = mkVarUnqual (fsLit "z")
2353 ah_RDR = mkVarUnqual (fsLit "a#")
2354 bh_RDR = mkVarUnqual (fsLit "b#")
2355 ch_RDR = mkVarUnqual (fsLit "c#")
2356 dh_RDR = mkVarUnqual (fsLit "d#")
2357
2358 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2359 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2360 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2361 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2362
2363 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2364 false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2365 a_Expr = nlHsVar a_RDR
2366 -- b_Expr = nlHsVar b_RDR
2367 c_Expr = nlHsVar c_RDR
2368 f_Expr = nlHsVar f_RDR
2369 z_Expr = nlHsVar z_RDR
2370 ltTag_Expr = nlHsVar ltTag_RDR
2371 eqTag_Expr = nlHsVar eqTag_RDR
2372 gtTag_Expr = nlHsVar gtTag_RDR
2373 false_Expr = nlHsVar false_RDR
2374 true_Expr = nlHsVar true_RDR
2375 fmap_Expr = nlHsVar fmap_RDR
2376 pure_Expr = nlHsVar pure_RDR
2377 mempty_Expr = nlHsVar mempty_RDR
2378 foldMap_Expr = nlHsVar foldMap_RDR
2379 traverse_Expr = nlHsVar traverse_RDR
2380
2381 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2382 a_Pat = nlVarPat a_RDR
2383 b_Pat = nlVarPat b_RDR
2384 c_Pat = nlVarPat c_RDR
2385 d_Pat = nlVarPat d_RDR
2386 f_Pat = nlVarPat f_RDR
2387 k_Pat = nlVarPat k_RDR
2388 z_Pat = nlVarPat z_RDR
2389
2390 minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
2391 minusInt_RDR = getRdrName (primOpId IntSubOp )
2392 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2393 error_RDR = getRdrName eRROR_ID
2394
2395 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2396 -- Generates Orig s RdrName, for the binding positions
2397 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2398 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2399 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2400
2401 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2402 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2403
2404 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2405 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2406 -- See Note [Auxiliary binders]
2407 mkAuxBinderName parent occ_fun
2408 = mkRdrUnqual (occ_fun stable_parent_occ)
2409 where
2410 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2411 stable_string
2412 | opt_PprStyle_Debug = parent_stable
2413 | otherwise = parent_stable_hash
2414 parent_stable = nameStableString parent
2415 parent_stable_hash =
2416 let Fingerprint high low = fingerprintString parent_stable
2417 in toBase62 high ++ toBase62Padded low
2418 -- See Note [Base 62 encoding 128-bit integers]
2419 parent_occ = nameOccName parent
2420
2421
2422 {-
2423 Note [Auxiliary binders]
2424 ~~~~~~~~~~~~~~~~~~~~~~~~
2425 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2426
2427 instance Ord T where
2428 compare a b = $con2tag a `compare` $con2tag b
2429
2430 $con2tag :: T -> Int
2431 $con2tag = ...code....
2432
2433 Of course these top-level bindings should all have distinct name, and we are
2434 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2435 because with standalone deriving two imported TyCons might both be called T!
2436 (See Trac #7947.)
2437
2438 So we use package name, module name and the name of the parent
2439 (T in this example) as part of the OccName we generate for the new binding.
2440 To make the symbol names short we take a base62 hash of the full name.
2441
2442 In the past we used the *unique* from the parent, but that's not stable across
2443 recompilations as uniques are nondeterministic.
2444
2445 Note [DeriveFoldable with ExistentialQuantification]
2446 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2447 Functor and Traversable instances can only be derived for data types whose
2448 last type parameter is truly universally polymorphic. For example:
2449
2450 data T a b where
2451 T1 :: b -> T a b -- YES, b is unconstrained
2452 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
2453 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
2454 T4 :: Int -> T a Int -- NO, this is just like T3
2455 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
2456 -- though a is existential
2457 T6 :: Int -> T Int b -- YES, b is unconstrained
2458
2459 For Foldable instances, however, we can completely lift the constraint that
2460 the last type parameter be truly universally polymorphic. This means that T
2461 (as defined above) can have a derived Foldable instance:
2462
2463 instance Foldable (T a) where
2464 foldr f z (T1 b) = f b z
2465 foldr f z (T2 b) = f b z
2466 foldr f z (T3 b) = f b z
2467 foldr f z (T4 b) = z
2468 foldr f z (T5 a b) = f b z
2469 foldr f z (T6 a) = z
2470
2471 foldMap f (T1 b) = f b
2472 foldMap f (T2 b) = f b
2473 foldMap f (T3 b) = f b
2474 foldMap f (T4 b) = mempty
2475 foldMap f (T5 a b) = f b
2476 foldMap f (T6 a) = mempty
2477
2478 In a Foldable instance, it is safe to fold over an occurrence of the last type
2479 parameter that is not truly universally polymorphic. However, there is a bit
2480 of subtlety in determining what is actually an occurrence of a type parameter.
2481 T3 and T4, as defined above, provide one example:
2482
2483 data T a b where
2484 ...
2485 T3 :: b ~ Int => b -> T a b
2486 T4 :: Int -> T a Int
2487 ...
2488
2489 instance Foldable (T a) where
2490 ...
2491 foldr f z (T3 b) = f b z
2492 foldr f z (T4 b) = z
2493 ...
2494 foldMap f (T3 b) = f b
2495 foldMap f (T4 b) = mempty
2496 ...
2497
2498 Notice that the argument of T3 is folded over, whereas the argument of T4 is
2499 not. This is because we only fold over constructor arguments that
2500 syntactically mention the universally quantified type parameter of that
2501 particular data constructor. See foldDataConArgs for how this is implemented.
2502
2503 As another example, consider the following data type. The argument of each
2504 constructor has the same type as the last type parameter:
2505
2506 data E a where
2507 E1 :: (a ~ Int) => a -> E a
2508 E2 :: Int -> E Int
2509 E3 :: (a ~ Int) => a -> E Int
2510 E4 :: (a ~ Int) => Int -> E a
2511
2512 Only E1's argument is an occurrence of a universally quantified type variable
2513 that is syntactically equivalent to the last type parameter, so only E1's
2514 argument will be be folded over in a derived Foldable instance.
2515
2516 See Trac #10447 for the original discussion on this feature. Also see
2517 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
2518 for a more in-depth explanation.
2519
2520 -}