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