Use (&&) instead of `if` in Ix derivation
[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 -- This produces something like `(ch >= ah) && (ch <= bh)`
787 enum_inRange
788 = mk_easy_FunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
789 untag_Expr tycon [(a_RDR, ah_RDR)] (
790 untag_Expr tycon [(b_RDR, bh_RDR)] (
791 untag_Expr tycon [(c_RDR, ch_RDR)] (
792 -- This used to use `if`, which interacts badly with RebindableSyntax.
793 -- See #11396.
794 nlHsApps and_RDR
795 [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
796 , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
797 ]
798 )))
799
800 --------------------------------------------------------------
801 single_con_ixes
802 = listToBag [single_con_range, single_con_index, single_con_inRange]
803
804 data_con
805 = case tyConSingleDataCon_maybe tycon of -- just checking...
806 Nothing -> panic "get_Ix_binds"
807 Just dc -> dc
808
809 con_arity = dataConSourceArity data_con
810 data_con_RDR = getRdrName data_con
811
812 as_needed = take con_arity as_RDRs
813 bs_needed = take con_arity bs_RDRs
814 cs_needed = take con_arity cs_RDRs
815
816 con_pat xs = nlConVarPat data_con_RDR xs
817 con_expr = nlHsVarApps data_con_RDR cs_needed
818
819 --------------------------------------------------------------
820 single_con_range
821 = mk_easy_FunBind loc range_RDR
822 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
823 noLoc (mkHsComp ListComp stmts con_expr)
824 where
825 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
826
827 mk_qual a b c = noLoc $ mkBindStmt (nlVarPat c)
828 (nlHsApp (nlHsVar range_RDR)
829 (mkLHsVarTuple [a,b]))
830
831 ----------------
832 single_con_index
833 = mk_easy_FunBind loc unsafeIndex_RDR
834 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
835 con_pat cs_needed]
836 -- We need to reverse the order we consider the components in
837 -- so that
838 -- range (l,u) !! index (l,u) i == i -- when i is in range
839 -- (from http://haskell.org/onlinereport/ix.html) holds.
840 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
841 where
842 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
843 mk_index [] = nlHsIntLit 0
844 mk_index [(l,u,i)] = mk_one l u i
845 mk_index ((l,u,i) : rest)
846 = genOpApp (
847 mk_one l u i
848 ) plus_RDR (
849 genOpApp (
850 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
851 (mkLHsVarTuple [l,u]))
852 ) times_RDR (mk_index rest)
853 )
854 mk_one l u i
855 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u], nlHsVar i]
856
857 ------------------
858 single_con_inRange
859 = mk_easy_FunBind loc inRange_RDR
860 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
861 con_pat cs_needed] $
862 foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)
863 where
864 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
865
866 {-
867 ************************************************************************
868 * *
869 Read instances
870 * *
871 ************************************************************************
872
873 Example
874
875 infix 4 %%
876 data T = Int %% Int
877 | T1 { f1 :: Int }
878 | T2 T
879
880 instance Read T where
881 readPrec =
882 parens
883 ( prec 4 (
884 do x <- ReadP.step Read.readPrec
885 expectP (Symbol "%%")
886 y <- ReadP.step Read.readPrec
887 return (x %% y))
888 +++
889 prec (appPrec+1) (
890 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
891 -- Record construction binds even more tightly than application
892 do expectP (Ident "T1")
893 expectP (Punc '{')
894 expectP (Ident "f1")
895 expectP (Punc '=')
896 x <- ReadP.reset Read.readPrec
897 expectP (Punc '}')
898 return (T1 { f1 = x }))
899 +++
900 prec appPrec (
901 do expectP (Ident "T2")
902 x <- ReadP.step Read.readPrec
903 return (T2 x))
904 )
905
906 readListPrec = readListPrecDefault
907 readList = readListDefault
908
909
910 Note [Use expectP]
911 ~~~~~~~~~~~~~~~~~~
912 Note that we use
913 expectP (Ident "T1")
914 rather than
915 Ident "T1" <- lexP
916 The latter desugares to inline code for matching the Ident and the
917 string, and this can be very voluminous. The former is much more
918 compact. Cf Trac #7258, although that also concerned non-linearity in
919 the occurrence analyser, a separate issue.
920
921 Note [Read for empty data types]
922 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
923 What should we get for this? (Trac #7931)
924 data Emp deriving( Read ) -- No data constructors
925
926 Here we want
927 read "[]" :: [Emp] to succeed, returning []
928 So we do NOT want
929 instance Read Emp where
930 readPrec = error "urk"
931 Rather we want
932 instance Read Emp where
933 readPred = pfail -- Same as choose []
934
935 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
936 These instances are also useful for Read (Either Int Emp), where
937 we want to be able to parse (Left 3) just fine.
938 -}
939
940 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
941
942 gen_Read_binds get_fixity loc tycon
943 = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
944 where
945 -----------------------------------------------------------------------
946 default_readlist
947 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
948
949 default_readlistprec
950 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
951 -----------------------------------------------------------------------
952
953 data_cons = tyConDataCons tycon
954 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
955
956 read_prec = mkHsVarBind loc readPrec_RDR
957 (nlHsApp (nlHsVar parens_RDR) read_cons)
958
959 read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types]
960 | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
961 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
962
963 read_nullary_cons
964 = case nullary_cons of
965 [] -> []
966 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
967 _ -> [nlHsApp (nlHsVar choose_RDR)
968 (nlList (map mk_pair nullary_cons))]
969 -- NB For operators the parens around (:=:) are matched by the
970 -- enclosing "parens" call, so here we must match the naked
971 -- data_con_str con
972
973 match_con con | isSym con_str = [symbol_pat con_str]
974 | otherwise = ident_h_pat con_str
975 where
976 con_str = data_con_str con
977 -- For nullary constructors we must match Ident s for normal constrs
978 -- and Symbol s for operators
979
980 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
981 result_expr con []]
982
983 read_non_nullary_con data_con
984 | is_infix = mk_parser infix_prec infix_stmts body
985 | is_record = mk_parser record_prec record_stmts body
986 -- Using these two lines instead allows the derived
987 -- read for infix and record bindings to read the prefix form
988 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
989 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
990 | otherwise = prefix_parser
991 where
992 body = result_expr data_con as_needed
993 con_str = data_con_str data_con
994
995 prefix_parser = mk_parser prefix_prec prefix_stmts body
996
997 read_prefix_con
998 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
999 | otherwise = ident_h_pat con_str
1000
1001 read_infix_con
1002 | isSym con_str = [symbol_pat con_str]
1003 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
1004
1005 prefix_stmts -- T a b c
1006 = read_prefix_con ++ read_args
1007
1008 infix_stmts -- a %% b, or a `T` b
1009 = [read_a1]
1010 ++ read_infix_con
1011 ++ [read_a2]
1012
1013 record_stmts -- T { f1 = a, f2 = b }
1014 = read_prefix_con
1015 ++ [read_punc "{"]
1016 ++ concat (intersperse [read_punc ","] field_stmts)
1017 ++ [read_punc "}"]
1018
1019 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
1020
1021 con_arity = dataConSourceArity data_con
1022 labels = map flLabel $ dataConFieldLabels data_con
1023 dc_nm = getName data_con
1024 is_infix = dataConIsInfix data_con
1025 is_record = length labels > 0
1026 as_needed = take con_arity as_RDRs
1027 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
1028 (read_a1:read_a2:_) = read_args
1029
1030 prefix_prec = appPrecedence
1031 infix_prec = getPrecedence get_fixity dc_nm
1032 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
1033 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
1034
1035 ------------------------------------------------------------------------
1036 -- Helpers
1037 ------------------------------------------------------------------------
1038 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
1039 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
1040 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
1041 con_app con as = nlHsVarApps (getRdrName con) as -- con as
1042 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1043
1044 -- For constructors and field labels ending in '#', we hackily
1045 -- let the lexer generate two tokens, and look for both in sequence
1046 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
1047 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
1048 | otherwise = [ ident_pat s ]
1049
1050 bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
1051 -- See Note [Use expectP]
1052 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo")
1053 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>")
1054 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<")
1055
1056 data_con_str con = occNameString (getOccName con)
1057
1058 read_arg a ty = ASSERT( not (isUnLiftedType ty) )
1059 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
1060
1061 read_field lbl a = read_lbl lbl ++
1062 [read_punc "=",
1063 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
1064
1065 -- When reading field labels we might encounter
1066 -- a = 3
1067 -- _a = 3
1068 -- or (#) = 4
1069 -- Note the parens!
1070 read_lbl lbl | isSym lbl_str
1071 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1072 | otherwise
1073 = ident_h_pat lbl_str
1074 where
1075 lbl_str = unpackFS lbl
1076
1077 {-
1078 ************************************************************************
1079 * *
1080 Show instances
1081 * *
1082 ************************************************************************
1083
1084 Example
1085
1086 infixr 5 :^:
1087
1088 data Tree a = Leaf a | Tree a :^: Tree a
1089
1090 instance (Show a) => Show (Tree a) where
1091
1092 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1093 where
1094 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1095
1096 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1097 where
1098 showStr = showsPrec (up_prec+1) u .
1099 showString " :^: " .
1100 showsPrec (up_prec+1) v
1101 -- Note: right-associativity of :^: ignored
1102
1103 up_prec = 5 -- Precedence of :^:
1104 app_prec = 10 -- Application has precedence one more than
1105 -- the most tightly-binding operator
1106 -}
1107
1108 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1109
1110 gen_Show_binds get_fixity loc tycon
1111 = (listToBag [shows_prec, show_list], emptyBag)
1112 where
1113 -----------------------------------------------------------------------
1114 show_list = mkHsVarBind loc showList_RDR
1115 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1116 -----------------------------------------------------------------------
1117 data_cons = tyConDataCons tycon
1118 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
1119
1120 pats_etc data_con
1121 | nullary_con = -- skip the showParen junk...
1122 ASSERT(null bs_needed)
1123 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1124 | record_syntax = -- skip showParen (#2530)
1125 ([a_Pat, con_pat], nlHsPar (nested_compose_Expr show_thingies))
1126 | otherwise =
1127 ([a_Pat, con_pat],
1128 showParen_Expr (genOpApp a_Expr ge_RDR
1129 (nlHsLit (HsInt "" con_prec_plus_one)))
1130 (nlHsPar (nested_compose_Expr show_thingies)))
1131 where
1132 data_con_RDR = getRdrName data_con
1133 con_arity = dataConSourceArity data_con
1134 bs_needed = take con_arity bs_RDRs
1135 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1136 con_pat = nlConVarPat data_con_RDR bs_needed
1137 nullary_con = con_arity == 0
1138 labels = map flLabel $ dataConFieldLabels data_con
1139 lab_fields = length labels
1140 record_syntax = lab_fields > 0
1141
1142 dc_nm = getName data_con
1143 dc_occ_nm = getOccName data_con
1144 con_str = occNameString dc_occ_nm
1145 op_con_str = wrapOpParens con_str
1146 backquote_str = wrapOpBackquotes con_str
1147
1148 show_thingies
1149 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1150 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1151 show_record_args ++ [mk_showString_app "}"]
1152 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1153
1154 show_label l = mk_showString_app (nm ++ " = ")
1155 -- Note the spaces around the "=" sign. If we
1156 -- don't have them then we get Foo { x=-1 } and
1157 -- the "=-" parses as a single lexeme. Only the
1158 -- space after the '=' is necessary, but it
1159 -- seems tidier to have them both sides.
1160 where
1161 nm = wrapOpParens (unpackFS l)
1162
1163 show_args = zipWith show_arg bs_needed arg_tys
1164 (show_arg1:show_arg2:_) = show_args
1165 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1166
1167 -- Assumption for record syntax: no of fields == no of
1168 -- labelled fields (and in same order)
1169 show_record_args = concat $
1170 intersperse [mk_showString_app ", "] $
1171 [ [show_label lbl, arg]
1172 | (lbl,arg) <- zipEqual "gen_Show_binds"
1173 labels show_args ]
1174
1175 show_arg :: RdrName -> Type -> LHsExpr RdrName
1176 show_arg b arg_ty
1177 | isUnLiftedType arg_ty
1178 -- See Note [Deriving and unboxed types] in TcDeriv
1179 = nlHsApps compose_RDR [mk_shows_app boxed_arg,
1180 mk_showString_app postfixMod]
1181 | otherwise
1182 = mk_showsPrec_app arg_prec arg
1183 where
1184 arg = nlHsVar b
1185 boxed_arg = box "Show" tycon arg arg_ty
1186 postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
1187
1188 -- Fixity stuff
1189 is_infix = dataConIsInfix data_con
1190 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1191 arg_prec | record_syntax = 0 -- Record fields don't need parens
1192 | otherwise = con_prec_plus_one
1193
1194 wrapOpParens :: String -> String
1195 wrapOpParens s | isSym s = '(' : s ++ ")"
1196 | otherwise = s
1197
1198 wrapOpBackquotes :: String -> String
1199 wrapOpBackquotes s | isSym s = s
1200 | otherwise = '`' : s ++ "`"
1201
1202 isSym :: String -> Bool
1203 isSym "" = False
1204 isSym (c : _) = startsVarSym c || startsConSym c
1205
1206 -- | showString :: String -> ShowS
1207 mk_showString_app :: String -> LHsExpr RdrName
1208 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1209
1210 -- | showsPrec :: Show a => Int -> a -> ShowS
1211 mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
1212 mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x]
1213
1214 -- | shows :: Show a => a -> ShowS
1215 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
1216 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1217
1218 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1219 getPrec is_infix get_fixity nm
1220 | not is_infix = appPrecedence
1221 | otherwise = getPrecedence get_fixity nm
1222
1223 appPrecedence :: Integer
1224 appPrecedence = fromIntegral maxPrecedence + 1
1225 -- One more than the precedence of the most
1226 -- tightly-binding operator
1227
1228 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1229 getPrecedence get_fixity nm
1230 = case get_fixity nm of
1231 Fixity _ x _assoc -> fromIntegral x
1232 -- NB: the Report says that associativity is not taken
1233 -- into account for either Read or Show; hence we
1234 -- ignore associativity here
1235
1236 {-
1237 ************************************************************************
1238 * *
1239 Data instances
1240 * *
1241 ************************************************************************
1242
1243 From the data type
1244
1245 data T a b = T1 a b | T2
1246
1247 we generate
1248
1249 $cT1 = mkDataCon $dT "T1" Prefix
1250 $cT2 = mkDataCon $dT "T2" Prefix
1251 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1252 -- the [] is for field labels.
1253
1254 instance (Data a, Data b) => Data (T a b) where
1255 gfoldl k z (T1 a b) = z T `k` a `k` b
1256 gfoldl k z T2 = z T2
1257 -- ToDo: add gmapT,Q,M, gfoldr
1258
1259 gunfold k z c = case conIndex c of
1260 I# 1# -> k (k (z T1))
1261 I# 2# -> z T2
1262
1263 toConstr (T1 _ _) = $cT1
1264 toConstr T2 = $cT2
1265
1266 dataTypeOf _ = $dT
1267
1268 dataCast1 = gcast1 -- If T :: * -> *
1269 dataCast2 = gcast2 -- if T :: * -> * -> *
1270 -}
1271
1272 gen_Data_binds :: DynFlags
1273 -> SrcSpan
1274 -> TyCon -- For data families, this is the
1275 -- *representation* TyCon
1276 -> (LHsBinds RdrName, -- The method bindings
1277 BagDerivStuff) -- Auxiliary bindings
1278 gen_Data_binds dflags loc rep_tc
1279 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1280 `unionBags` gcast_binds,
1281 -- Auxiliary definitions: the data type and constructors
1282 listToBag ( DerivHsBind (genDataTyCon)
1283 : map (DerivHsBind . genDataDataCon) data_cons))
1284 where
1285 data_cons = tyConDataCons rep_tc
1286 n_cons = length data_cons
1287 one_constr = n_cons == 1
1288
1289 genDataTyCon :: (LHsBind RdrName, LSig RdrName)
1290 genDataTyCon -- $dT
1291 = (mkHsVarBind loc rdr_name rhs,
1292 L loc (TypeSig [L loc rdr_name] sig_ty))
1293 where
1294 rdr_name = mk_data_type_name rep_tc
1295 sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
1296 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
1297 rhs = nlHsVar mkDataType_RDR
1298 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
1299 `nlHsApp` nlList constrs
1300
1301 genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
1302 genDataDataCon dc -- $cT1 etc
1303 = (mkHsVarBind loc rdr_name rhs,
1304 L loc (TypeSig [L loc rdr_name] sig_ty))
1305 where
1306 rdr_name = mk_constr_name dc
1307 sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
1308 rhs = nlHsApps mkConstr_RDR constr_args
1309
1310 constr_args
1311 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1312 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1313 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1314 nlList labels, -- Field labels
1315 nlHsVar fixity] -- Fixity
1316
1317 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
1318 (dataConFieldLabels dc)
1319 dc_occ = getOccName dc
1320 is_infix = isDataSymOcc dc_occ
1321 fixity | is_infix = infix_RDR
1322 | otherwise = prefix_RDR
1323
1324 ------------ gfoldl
1325 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1326
1327 gfoldl_eqn con
1328 = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1329 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1330 where
1331 con_name :: RdrName
1332 con_name = getRdrName con
1333 as_needed = take (dataConSourceArity con) as_RDRs
1334 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1335
1336 ------------ gunfold
1337 gunfold_bind = mk_FunBind loc
1338 gunfold_RDR
1339 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1340 gunfold_rhs)]
1341
1342 gunfold_rhs
1343 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1344 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1345 (map gunfold_alt data_cons)
1346
1347 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1348 mk_unfold_rhs dc = foldr nlHsApp
1349 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1350 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1351
1352 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1353 -- redundant test, and annoying warning
1354 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1355 | otherwise = nlConPat intDataCon_RDR
1356 [nlLitPat (HsIntPrim "" (toInteger tag))]
1357 where
1358 tag = dataConTag dc
1359
1360 ------------ toConstr
1361 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1362 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1363
1364 ------------ dataTypeOf
1365 dataTypeOf_bind = mk_easy_FunBind
1366 loc
1367 dataTypeOf_RDR
1368 [nlWildPat]
1369 (nlHsVar (mk_data_type_name rep_tc))
1370
1371 ------------ gcast1/2
1372 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1373 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1374 -- (or nothing if T has neither of these two types)
1375
1376 -- But care is needed for data families:
1377 -- If we have data family D a
1378 -- data instance D (a,b,c) = A | B deriving( Data )
1379 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1380 -- then we need dataCast1 x = gcast1 x
1381 -- because D :: * -> *
1382 -- even though rep_tc has kind * -> * -> * -> *
1383 -- Hence looking for the kind of fam_tc not rep_tc
1384 -- See Trac #4896
1385 tycon_kind = case tyConFamInst_maybe rep_tc of
1386 Just (fam_tc, _) -> tyConKind fam_tc
1387 Nothing -> tyConKind rep_tc
1388 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1389 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1390 | otherwise = emptyBag
1391 mk_gcast dataCast_RDR gcast_RDR
1392 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1393 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1394
1395
1396 kind1, kind2 :: Kind
1397 kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
1398 kind2 = liftedTypeKind `mkFunTy` kind1
1399
1400 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1401 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1402 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1403 constr_RDR, dataType_RDR,
1404 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1405 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1406 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1407 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1408 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1409 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1410 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1411 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1412 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1413 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1414 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1415 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1416 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1417 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1418 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1419 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1420 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1421 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1422 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1423 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1424 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1425
1426 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1427 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1428 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1429 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1430 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1431
1432 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1433 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1434 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1435 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1436 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1437
1438 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1439 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1440 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1441 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1442 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1443
1444 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1445 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1446 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1447 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1448 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1449
1450 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1451 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1452 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1453 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1454 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1455
1456 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1457 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1458 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1459 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1460 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1461
1462 {-
1463 ************************************************************************
1464 * *
1465 Functor instances
1466
1467 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1468
1469 * *
1470 ************************************************************************
1471
1472 For the data type:
1473
1474 data T a = T1 Int a | T2 (T a)
1475
1476 We generate the instance:
1477
1478 instance Functor T where
1479 fmap f (T1 b1 a) = T1 b1 (f a)
1480 fmap f (T2 ta) = T2 (fmap f ta)
1481
1482 Notice that we don't simply apply 'fmap' to the constructor arguments.
1483 Rather
1484 - Do nothing to an argument whose type doesn't mention 'a'
1485 - Apply 'f' to an argument of type 'a'
1486 - Apply 'fmap f' to other arguments
1487 That's why we have to recurse deeply into the constructor argument types,
1488 rather than just one level, as we typically do.
1489
1490 What about types with more than one type parameter? In general, we only
1491 derive Functor for the last position:
1492
1493 data S a b = S1 [b] | S2 (a, T a b)
1494 instance Functor (S a) where
1495 fmap f (S1 bs) = S1 (fmap f bs)
1496 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1497
1498 However, we have special cases for
1499 - tuples
1500 - functions
1501
1502 More formally, we write the derivation of fmap code over type variable
1503 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1504 instance for T is:
1505
1506 instance Functor T where
1507 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1508 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1509
1510 $(fmap 'a 'b) = \x -> x -- when b does not contain a
1511 $(fmap 'a 'a) = f
1512 $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1513 $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2
1514 $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1515
1516 For functions, the type parameter 'a can occur in a contravariant position,
1517 which means we need to derive a function like:
1518
1519 cofmap :: (a -> b) -> (f b -> f a)
1520
1521 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1522
1523 $(cofmap 'a 'b) = \x -> x -- when b does not contain a
1524 $(cofmap 'a 'a) = error "type variable in contravariant position"
1525 $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1526 $(cofmap 'a '[b]) = map $(cofmap 'a 'b)
1527 $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2
1528 $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1529
1530 Note that the code produced by $(fmap _ _) is always a higher order function,
1531 with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
1532 matching on the type, this means create a lambda function (see the (,) case above).
1533 The resulting code for fmap can look a bit weird, for example:
1534
1535 data X a = X (a,Int)
1536 -- generated instance
1537 instance Functor X where
1538 fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
1539
1540 The optimizer should be able to simplify this code by simple inlining.
1541
1542 An older version of the deriving code tried to avoid these applied
1543 lambda functions by producing a meta level function. But the function to
1544 be mapped, `f`, is a function on the code level, not on the meta level,
1545 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
1546 It is better to produce too many lambdas than to eta expand, see ticket #7436.
1547 -}
1548
1549 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1550 gen_Functor_binds loc tycon
1551 = (unitBag fmap_bind, emptyBag)
1552 where
1553 data_cons = tyConDataCons tycon
1554 fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns
1555
1556 fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1557 where
1558 parts = sequence $ foldDataConArgs ft_fmap con
1559
1560 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1561 (error_Expr "Void fmap")]
1562 | otherwise = map fmap_eqn data_cons
1563
1564 ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1565 ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x -- fmap f = \x -> x
1566 , ft_var = return f_Expr -- fmap f = f
1567 , ft_fun = \g h -> do -- fmap f = \x b -> h (x (g b))
1568 gg <- g
1569 hh <- h
1570 mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b))
1571 , ft_tup = \t gs -> do -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1572 gg <- sequence gs
1573 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1574 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g -- fmap f = fmap g
1575 , ft_forall = \_ g -> g
1576 , ft_bad_app = panic "in other argument"
1577 , ft_co_var = panic "contravariant" }
1578
1579 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
1580 match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
1581 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1582 match_for_con = mkSimpleConMatch $
1583 \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 ..
1584
1585 {-
1586 Utility functions related to Functor deriving.
1587
1588 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1589 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1590 -}
1591
1592 -- Generic traversal for Functor deriving
1593 data FFoldType a -- Describes how to fold over a Type in a functor like way
1594 = FT { ft_triv :: a -- Does not contain variable
1595 , ft_var :: a -- The variable itself
1596 , ft_co_var :: a -- The variable itself, contravariantly
1597 , ft_fun :: a -> a -> a -- Function type
1598 , ft_tup :: TyCon -> [a] -> a -- Tuple type
1599 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1600 , ft_bad_app :: a -- Type app, variable other than in last argument
1601 , ft_forall :: TcTyVar -> a -> a -- Forall type
1602 }
1603
1604 functorLikeTraverse :: forall a.
1605 TyVar -- ^ Variable to look for
1606 -> FFoldType a -- ^ How to fold
1607 -> Type -- ^ Type to process
1608 -> a
1609 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1610 , ft_co_var = caseCoVar, ft_fun = caseFun
1611 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1612 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1613 ty
1614 = fst (go False ty)
1615 where
1616 go :: Bool -- Covariant or contravariant context
1617 -> Type
1618 -> (a, Bool) -- (result of type a, does type contain var)
1619
1620 go co ty | Just ty' <- coreView ty = go co ty'
1621 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1622 go co (ForAllTy (Anon x) y) | isPredTy x = go co y
1623 | xc || yc = (caseFun xr yr,True)
1624 where (xr,xc) = go (not co) x
1625 (yr,yc) = go co y
1626 go co (AppTy x y) | xc = (caseWrongArg, True)
1627 | yc = (caseTyApp x yr, True)
1628 where (_, xc) = go co x
1629 (yr,yc) = go co y
1630 go co ty@(TyConApp con args)
1631 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
1632 -- At this point we know that xrs, xcs is not empty,
1633 -- and at least one xr is True
1634 | isTupleTyCon con = (caseTuple con xrs, True)
1635 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
1636 | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty
1637 = (caseTyApp fun_ty (last xrs), True)
1638 | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
1639 where
1640 (xrs,xcs) = unzip (map (go co) args)
1641 go _ (ForAllTy (Named _ Visible) _) = panic "unexpected visible binder"
1642 go co (ForAllTy (Named v _) x) | v /= var && xc = (caseForAll v xr,True)
1643 where (xr,xc) = go co x
1644
1645 go _ _ = (caseTrivial,False)
1646
1647 -- Return all syntactic subterms of ty that contain var somewhere
1648 -- These are the things that should appear in instance constraints
1649 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1650 deepSubtypesContaining tv
1651 = functorLikeTraverse tv
1652 (FT { ft_triv = []
1653 , ft_var = []
1654 , ft_fun = (++)
1655 , ft_tup = \_ xs -> concat xs
1656 , ft_ty_app = (:)
1657 , ft_bad_app = panic "in other argument"
1658 , ft_co_var = panic "contravariant"
1659 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
1660
1661
1662 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1663 -- Fold over the arguments of the datacon
1664 foldDataConArgs ft con
1665 = map foldArg (dataConOrigArgTys con)
1666 where
1667 foldArg
1668 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
1669 Just tv -> functorLikeTraverse tv ft
1670 Nothing -> const (ft_triv ft)
1671 -- If we are deriving Foldable for a GADT, there is a chance that the last
1672 -- type variable in the data type isn't actually a type variable at all.
1673 -- (for example, this can happen if the last type variable is refined to
1674 -- be a concrete type such as Int). If the last type variable is refined
1675 -- to be a specific type, then getTyVar_maybe will return Nothing.
1676 -- See Note [DeriveFoldable with ExistentialQuantification]
1677 --
1678 -- The kind checks have ensured the last type parameter is of kind *.
1679
1680 -- Make a HsLam using a fresh variable from a State monad
1681 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1682 -> State [RdrName] (LHsExpr RdrName)
1683 -- (mkSimpleLam fn) returns (\x. fn(x))
1684 mkSimpleLam lam = do
1685 (n:names) <- get
1686 put names
1687 body <- lam (nlHsVar n)
1688 return (mkHsLam [nlVarPat n] body)
1689
1690 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
1691 -> State [RdrName] (LHsExpr RdrName))
1692 -> State [RdrName] (LHsExpr RdrName)
1693 mkSimpleLam2 lam = do
1694 (n1:n2:names) <- get
1695 put names
1696 body <- lam (nlHsVar n1) (nlHsVar n2)
1697 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1698
1699 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1700 mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1701 -> [LPat RdrName]
1702 -> DataCon
1703 -> [LHsExpr RdrName]
1704 -> m (LMatch RdrName (LHsExpr RdrName))
1705 mkSimpleConMatch fold extra_pats con insides = do
1706 let con_name = getRdrName con
1707 let vars_needed = takeList insides as_RDRs
1708 let pat = nlConVarPat con_name vars_needed
1709 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1710 return $ mkMatch (extra_pats ++ [pat]) rhs (noLoc emptyLocalBinds)
1711
1712 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1713 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1714 -> m (LMatch RdrName (LHsExpr RdrName)))
1715 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1716 mkSimpleTupleCase match_for_con tc insides x
1717 = do { let data_con = tyConSingleDataCon tc
1718 ; match <- match_for_con [] data_con insides
1719 ; return $ nlHsCase x [match] }
1720
1721 {-
1722 ************************************************************************
1723 * *
1724 Foldable instances
1725
1726 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1727
1728 * *
1729 ************************************************************************
1730
1731 Deriving Foldable instances works the same way as Functor instances,
1732 only Foldable instances are not possible for function types at all.
1733 Here the derived instance for the type T above is:
1734
1735 instance Foldable T where
1736 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1737
1738 The cases are:
1739
1740 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
1741 $(foldr 'a 'a) = f
1742 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1743 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
1744
1745 Note that the arguments to the real foldr function are the wrong way around,
1746 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1747
1748 Foldable instances differ from Functor and Traversable instances in that
1749 Foldable instances can be derived for data types in which the last type
1750 variable is existentially quantified. In particular, if the last type variable
1751 is refined to a more specific type in a GADT:
1752
1753 data GADT a where
1754 G :: a ~ Int => a -> G Int
1755
1756 then the deriving machinery does not attempt to check that the type a contains
1757 Int, since it is not syntactically equal to a type variable. That is, the
1758 derived Foldable instance for GADT is:
1759
1760 instance Foldable GADT where
1761 foldr _ z (GADT _) = z
1762
1763 See Note [DeriveFoldable with ExistentialQuantification].
1764
1765 -}
1766
1767 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1768 gen_Foldable_binds loc tycon
1769 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1770 where
1771 data_cons = tyConDataCons tycon
1772
1773 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1774 eqns = map foldr_eqn data_cons
1775 foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1776 where
1777 parts = sequence $ foldDataConArgs ft_foldr con
1778
1779 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1780 foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1781 where
1782 parts = sequence $ foldDataConArgs ft_foldMap con
1783
1784 ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
1785 ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z -> return z -- foldr f = \x z -> z
1786 , ft_var = return f_Expr -- foldr f = f
1787 , ft_tup = \t g -> do gg <- sequence g -- foldr f = (\x z -> case x of ...)
1788 mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
1789 , ft_ty_app = \_ g -> do gg <- g -- foldr f = (\x z -> foldr g z x)
1790 mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1791 , ft_forall = \_ g -> g
1792 , ft_co_var = panic "contravariant"
1793 , ft_fun = panic "function"
1794 , ft_bad_app = panic "in other argument" }
1795
1796 match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z))
1797
1798 ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1799 ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr -- foldMap f = \x -> mempty
1800 , ft_var = return f_Expr -- foldMap f = f
1801 , ft_tup = \t g -> do gg <- sequence g -- foldMap f = \x -> case x of (..,)
1802 mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
1803 , ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g -- foldMap f = foldMap g
1804 , ft_forall = \_ g -> g
1805 , ft_co_var = panic "contravariant"
1806 , ft_fun = panic "function"
1807 , ft_bad_app = panic "in other argument" }
1808
1809 match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
1810 case xs of
1811 [] -> mempty_Expr
1812 xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
1813
1814 {-
1815 ************************************************************************
1816 * *
1817 Traversable instances
1818
1819 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1820 * *
1821 ************************************************************************
1822
1823 Again, Traversable is much like Functor and Foldable.
1824
1825 The cases are:
1826
1827 $(traverse 'a 'b) = pure -- when b does not contain a
1828 $(traverse 'a 'a) = f
1829 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1830 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
1831
1832 Note that the generated code is not as efficient as it could be. For instance:
1833
1834 data T a = T Int a deriving Traversable
1835
1836 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1837 instead of: traverse f (T x y) = T x <$> f y
1838 -}
1839
1840 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1841 gen_Traversable_binds loc tycon
1842 = (unitBag traverse_bind, emptyBag)
1843 where
1844 data_cons = tyConDataCons tycon
1845
1846 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
1847 eqns = map traverse_eqn data_cons
1848 traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1849 where
1850 parts = sequence $ foldDataConArgs ft_trav con
1851
1852
1853 ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
1854 ft_trav = FT { ft_triv = return pure_Expr -- traverse f = pure x
1855 , ft_var = return f_Expr -- traverse f = f x
1856 , ft_tup = \t gs -> do -- traverse f = \x -> case x of (a1,a2,..) ->
1857 gg <- sequence gs -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1858 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1859 , ft_ty_app = \_ g -> nlHsApp traverse_Expr <$> g -- traverse f = travese g
1860 , ft_forall = \_ g -> g
1861 , ft_co_var = panic "contravariant"
1862 , ft_fun = panic "function"
1863 , ft_bad_app = panic "in other argument" }
1864
1865 -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
1866 match_for_con = mkSimpleConMatch $
1867 \con_name xs -> return $ mkApCon (nlHsVar con_name) xs
1868
1869 -- ((Con <$> x1) <*> x2) <*> ..
1870 mkApCon con [] = nlHsApps pure_RDR [con]
1871 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1872 where appAp x y = nlHsApps ap_RDR [x,y]
1873
1874 {-
1875 ************************************************************************
1876 * *
1877 Lift instances
1878 * *
1879 ************************************************************************
1880
1881 Example:
1882
1883 data Foo a = Foo a | a :^: a deriving Lift
1884
1885 ==>
1886
1887 instance (Lift a) => Lift (Foo a) where
1888 lift (Foo a)
1889 = appE
1890 (conE
1891 (mkNameG_d "package-name" "ModuleName" "Foo"))
1892 (lift a)
1893 lift (u :^: v)
1894 = infixApp
1895 (lift u)
1896 (conE
1897 (mkNameG_d "package-name" "ModuleName" ":^:"))
1898 (lift v)
1899
1900 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
1901 'Foo would be when using the -XTemplateHaskell extension. To make sure that
1902 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
1903 makeG_d.
1904 -}
1905
1906 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1907 gen_Lift_binds loc tycon
1908 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
1909 [mkMatch [nlWildPat] errorMsg_Expr
1910 (noLoc emptyLocalBinds)])
1911 , emptyBag)
1912 | otherwise = (unitBag lift_bind, emptyBag)
1913 where
1914 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
1915 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
1916
1917 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
1918 data_cons = tyConDataCons tycon
1919 tycon_str = occNameString . nameOccName . tyConName $ tycon
1920
1921 pats_etc data_con
1922 = ([con_pat], lift_Expr)
1923 where
1924 con_pat = nlConVarPat data_con_RDR as_needed
1925 data_con_RDR = getRdrName data_con
1926 con_arity = dataConSourceArity data_con
1927 as_needed = take con_arity as_RDRs
1928 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1929 tys_needed as_needed
1930 tycon_name = tyConName tycon
1931 is_infix = dataConIsInfix data_con
1932 tys_needed = dataConOrigArgTys data_con
1933
1934 mk_lift_app ty a
1935 | not (isUnLiftedType ty) = nlHsApp (nlHsVar lift_RDR)
1936 (nlHsVar a)
1937 | otherwise = nlHsApp (nlHsVar litE_RDR)
1938 (primLitOp (mkBoxExp (nlHsVar a)))
1939 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1940
1941 pkg_name = unitIdString . moduleUnitId
1942 . nameModule $ tycon_name
1943 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1944 con_name = occNameString . nameOccName . dataConName $ data_con
1945
1946 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1947 (nlHsApps mkNameG_dRDR
1948 (map (nlHsLit . mkHsString)
1949 [pkg_name, mod_name, con_name]))
1950
1951 lift_Expr
1952 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1953 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1954 (a1:a2:_) = lifted_as
1955
1956 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1957 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1958
1959 {-
1960 ************************************************************************
1961 * *
1962 Newtype-deriving instances
1963 * *
1964 ************************************************************************
1965
1966 We take every method in the original instance and `coerce` it to fit
1967 into the derived instance. We need a type annotation on the argument
1968 to `coerce` to make it obvious what instantiation of the method we're
1969 coercing from.
1970
1971 See #8503 for more discussion.
1972 -}
1973
1974 mkCoerceClassMethEqn :: Class -- the class being derived
1975 -> [TyVar] -- the tvs in the instance head
1976 -> [Type] -- instance head parameters (incl. newtype)
1977 -> Type -- the representation type (already eta-reduced)
1978 -> Id -- the method to look at
1979 -> Pair Type
1980 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
1981 = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty)
1982 where
1983 cls_tvs = classTyVars cls
1984 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1985 lhs_subst = mkTCvSubst in_scope (zipTyEnv cls_tvs cls_tys, emptyCvSubstEnv)
1986 rhs_subst = mkTCvSubst in_scope
1987 ( zipTyEnv cls_tvs (changeLast cls_tys rhs_ty)
1988 , emptyCvSubstEnv )
1989 (_class_tvs, _class_constraint, user_meth_ty)
1990 = tcSplitSigmaTy (varType id)
1991
1992 changeLast :: [a] -> a -> [a]
1993 changeLast [] _ = panic "changeLast"
1994 changeLast [_] x = [x]
1995 changeLast (x:xs) x' = x : changeLast xs x'
1996
1997
1998 gen_Newtype_binds :: SrcSpan
1999 -> Class -- the class being derived
2000 -> [TyVar] -- the tvs in the instance head
2001 -> [Type] -- instance head parameters (incl. newtype)
2002 -> Type -- the representation type (already eta-reduced)
2003 -> LHsBinds RdrName
2004 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
2005 = listToBag $ zipWith mk_bind
2006 (classMethods cls)
2007 (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
2008 where
2009 coerce_RDR = getRdrName coerceId
2010 mk_bind :: Id -> Pair Type -> LHsBind RdrName
2011 mk_bind id (Pair tau_ty user_ty)
2012 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
2013 where
2014 meth_RDR = getRdrName id
2015 rhs_expr
2016 = ( nlHsVar coerce_RDR
2017 `nlHsApp`
2018 (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType tau_ty'))
2019 `nlExprWithTySig` toLHsSigWcType user_ty
2020 -- Open the representation type here, so that it's forall'ed type
2021 -- variables refer to the ones bound in the user_ty
2022 (_, _, tau_ty') = tcSplitSigmaTy tau_ty
2023
2024 nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
2025 nlExprWithTySig e s = noLoc (ExprWithTySig e s)
2026
2027 {-
2028 ************************************************************************
2029 * *
2030 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
2031 * *
2032 ************************************************************************
2033
2034 \begin{verbatim}
2035 data Foo ... = ...
2036
2037 con2tag_Foo :: Foo ... -> Int#
2038 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2039 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2040 \end{verbatim}
2041
2042 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2043 fiddling around.
2044 -}
2045
2046 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
2047 genAuxBindSpec loc (DerivCon2Tag tycon)
2048 = (mk_FunBind loc rdr_name eqns,
2049 L loc (TypeSig [L loc rdr_name] sig_ty))
2050 where
2051 rdr_name = con2tag_RDR tycon
2052
2053 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
2054 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
2055 mkParentType tycon `mkFunTy` intPrimTy
2056
2057 lots_of_constructors = tyConFamilySize tycon > 8
2058 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
2059 -- but we don't do vectored returns any more.
2060
2061 eqns | lots_of_constructors = [get_tag_eqn]
2062 | otherwise = map mk_eqn (tyConDataCons tycon)
2063
2064 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
2065
2066 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
2067 mk_eqn con = ([nlWildConPat con],
2068 nlHsLit (HsIntPrim ""
2069 (toInteger ((dataConTag con) - fIRST_TAG))))
2070
2071 genAuxBindSpec loc (DerivTag2Con tycon)
2072 = (mk_FunBind loc rdr_name
2073 [([nlConVarPat intDataCon_RDR [a_RDR]],
2074 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2075 L loc (TypeSig [L loc rdr_name] sig_ty))
2076 where
2077 sig_ty = mkLHsSigWcType $ L loc $
2078 HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
2079 intTy `mkFunTy` mkParentType tycon
2080
2081 rdr_name = tag2con_RDR tycon
2082
2083 genAuxBindSpec loc (DerivMaxTag tycon)
2084 = (mkHsVarBind loc rdr_name rhs,
2085 L loc (TypeSig [L loc rdr_name] sig_ty))
2086 where
2087 rdr_name = maxtag_RDR tycon
2088 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
2089 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2090 max_tag = case (tyConDataCons tycon) of
2091 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2092
2093 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
2094 ( Bag (LHsBind RdrName, LSig RdrName)
2095 -- Extra bindings (used by Generic only)
2096 , Bag (FamInst) -- Extra family instances
2097 , Bag (InstInfo RdrName)) -- Extra instances
2098
2099 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2100 genAuxBinds loc b = genAuxBinds' b2 where
2101 (b1,b2) = partitionBagWith splitDerivAuxBind b
2102 splitDerivAuxBind (DerivAuxBind x) = Left x
2103 splitDerivAuxBind x = Right x
2104
2105 rm_dups = foldrBag dup_check emptyBag
2106 dup_check a b = if anyBag (== a) b then b else consBag a b
2107
2108 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2109 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2110 , emptyBag, emptyBag)
2111 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2112 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2113 f (DerivHsBind b) = add1 b
2114 f (DerivFamInst t) = add2 t
2115 f (DerivInst i) = add3 i
2116
2117 add1 x (a,b,c) = (x `consBag` a,b,c)
2118 add2 x (a,b,c) = (a,x `consBag` b,c)
2119 add3 x (a,b,c) = (a,b,x `consBag` c)
2120
2121 mk_data_type_name :: TyCon -> RdrName -- "$tT"
2122 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
2123
2124 mk_constr_name :: DataCon -> RdrName -- "$cC"
2125 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
2126
2127 mkParentType :: TyCon -> Type
2128 -- Turn the representation tycon of a family into
2129 -- a use of its family constructor
2130 mkParentType tc
2131 = case tyConFamInst_maybe tc of
2132 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2133 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2134
2135 {-
2136 ************************************************************************
2137 * *
2138 \subsection{Utility bits for generating bindings}
2139 * *
2140 ************************************************************************
2141 -}
2142
2143 mk_FunBind :: SrcSpan -> RdrName
2144 -> [([LPat RdrName], LHsExpr RdrName)]
2145 -> LHsBind RdrName
2146 mk_FunBind loc fun pats_and_exprs
2147 = mkRdrFunBind (L loc fun) matches
2148 where
2149 matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs]
2150
2151 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2152 mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2153 where
2154 -- Catch-all eqn looks like
2155 -- fmap = error "Void fmap"
2156 -- It's needed if there no data cons at all,
2157 -- which can happen with -XEmptyDataDecls
2158 -- See Trac #4302
2159 matches' = if null matches
2160 then [mkMatch [] (error_Expr str) (noLoc emptyLocalBinds)]
2161 else matches
2162 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2163
2164 box :: String -- The class involved
2165 -> TyCon -- The tycon involved
2166 -> LHsExpr RdrName -- The argument
2167 -> Type -- The argument type
2168 -> LHsExpr RdrName -- Boxed version of the arg
2169 -- See Note [Deriving and unboxed types] in TcDeriv
2170 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2171 where
2172 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2173
2174 ---------------------
2175 primOrdOps :: String -- The class involved
2176 -> TyCon -- The tycon involved
2177 -> Type -- The type
2178 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2179 -- See Note [Deriving and unboxed types] in TcDeriv
2180 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2181
2182 primLitOps :: String -- The class involved
2183 -> TyCon -- The tycon involved
2184 -> Type -- The type
2185 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
2186 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
2187 )
2188 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2189 , \v -> nlHsVar boxRDR `nlHsApp` v
2190 )
2191 where
2192 boxRDR
2193 | ty `eqType` addrPrimTy = unpackCString_RDR
2194 | otherwise = assoc_ty_id str tycon boxConTbl ty
2195
2196 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2197 ordOpTbl
2198 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2199 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2200 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2201 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2202 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2203 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2204
2205 boxConTbl :: [(Type, RdrName)]
2206 boxConTbl
2207 = [(charPrimTy , getRdrName charDataCon )
2208 ,(intPrimTy , getRdrName intDataCon )
2209 ,(wordPrimTy , getRdrName wordDataCon )
2210 ,(floatPrimTy , getRdrName floatDataCon )
2211 ,(doublePrimTy, getRdrName doubleDataCon)
2212 ]
2213
2214 -- | A table of postfix modifiers for unboxed values.
2215 postfixModTbl :: [(Type, String)]
2216 postfixModTbl
2217 = [(charPrimTy , "#" )
2218 ,(intPrimTy , "#" )
2219 ,(wordPrimTy , "##")
2220 ,(floatPrimTy , "#" )
2221 ,(doublePrimTy, "##")
2222 ]
2223
2224 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
2225 litConTbl
2226 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2227 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2228 . nlHsApp (nlHsVar toInteger_RDR))
2229 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2230 . nlHsApp (nlHsVar toInteger_RDR))
2231 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2232 . nlHsApp (nlHsApp
2233 (nlHsVar map_RDR)
2234 (compose_RDR `nlHsApps`
2235 [ nlHsVar fromIntegral_RDR
2236 , nlHsVar fromEnum_RDR
2237 ])))
2238 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2239 . nlHsApp (nlHsVar toRational_RDR))
2240 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2241 . nlHsApp (nlHsVar toRational_RDR))
2242 ]
2243
2244 -- | Lookup `Type` in an association list.
2245 assoc_ty_id :: String -- The class involved
2246 -> TyCon -- The tycon involved
2247 -> [(Type,a)] -- The table
2248 -> Type -- The type
2249 -> a -- The result of the lookup
2250 assoc_ty_id cls_str _ tbl ty
2251 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2252 text "for primitive type" <+> ppr ty)
2253 | otherwise = head res
2254 where
2255 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2256
2257 -----------------------------------------------------------------------
2258
2259 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2260 and_Expr a b = genOpApp a and_RDR b
2261
2262 -----------------------------------------------------------------------
2263
2264 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2265 eq_Expr tycon ty a b
2266 | not (isUnLiftedType ty) = genOpApp a eq_RDR b
2267 | otherwise = genPrimOpApp a prim_eq b
2268 where
2269 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2270
2271 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2272 untag_Expr _ [] expr = expr
2273 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2274 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2275 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2276
2277 enum_from_to_Expr
2278 :: LHsExpr RdrName -> LHsExpr RdrName
2279 -> LHsExpr RdrName
2280 enum_from_then_to_Expr
2281 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2282 -> LHsExpr RdrName
2283
2284 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2285 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2286
2287 showParen_Expr
2288 :: LHsExpr RdrName -> LHsExpr RdrName
2289 -> LHsExpr RdrName
2290
2291 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2292
2293 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2294
2295 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2296 nested_compose_Expr [e] = parenify e
2297 nested_compose_Expr (e:es)
2298 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2299
2300 -- impossible_Expr is used in case RHSs that should never happen.
2301 -- We generate these to keep the desugarer from complaining that they *might* happen!
2302 error_Expr :: String -> LHsExpr RdrName
2303 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2304
2305 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2306 -- method. It is currently only used by Enum.{succ,pred}
2307 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2308 illegal_Expr meth tp msg =
2309 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2310
2311 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2312 -- to include the value of a_RDR in the error string.
2313 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2314 illegal_toEnum_tag tp maxtag =
2315 nlHsApp (nlHsVar error_RDR)
2316 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2317 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2318 (nlHsApp (nlHsApp (nlHsApp
2319 (nlHsVar showsPrec_RDR)
2320 (nlHsIntLit 0))
2321 (nlHsVar a_RDR))
2322 (nlHsApp (nlHsApp
2323 (nlHsVar append_RDR)
2324 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2325 (nlHsApp (nlHsApp (nlHsApp
2326 (nlHsVar showsPrec_RDR)
2327 (nlHsIntLit 0))
2328 (nlHsVar maxtag))
2329 (nlHsLit (mkHsString ")"))))))
2330
2331 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2332 parenify e@(L _ (HsVar _)) = e
2333 parenify e = mkHsPar e
2334
2335 -- genOpApp wraps brackets round the operator application, so that the
2336 -- renamer won't subsequently try to re-associate it.
2337 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2338 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2339
2340 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2341 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2342
2343 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2344 :: RdrName
2345 a_RDR = mkVarUnqual (fsLit "a")
2346 b_RDR = mkVarUnqual (fsLit "b")
2347 c_RDR = mkVarUnqual (fsLit "c")
2348 d_RDR = mkVarUnqual (fsLit "d")
2349 f_RDR = mkVarUnqual (fsLit "f")
2350 k_RDR = mkVarUnqual (fsLit "k")
2351 z_RDR = mkVarUnqual (fsLit "z")
2352 ah_RDR = mkVarUnqual (fsLit "a#")
2353 bh_RDR = mkVarUnqual (fsLit "b#")
2354 ch_RDR = mkVarUnqual (fsLit "c#")
2355 dh_RDR = mkVarUnqual (fsLit "d#")
2356
2357 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2358 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2359 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2360 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2361
2362 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2363 false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2364 a_Expr = nlHsVar a_RDR
2365 -- b_Expr = nlHsVar b_RDR
2366 c_Expr = nlHsVar c_RDR
2367 f_Expr = nlHsVar f_RDR
2368 z_Expr = nlHsVar z_RDR
2369 ltTag_Expr = nlHsVar ltTag_RDR
2370 eqTag_Expr = nlHsVar eqTag_RDR
2371 gtTag_Expr = nlHsVar gtTag_RDR
2372 false_Expr = nlHsVar false_RDR
2373 true_Expr = nlHsVar true_RDR
2374 fmap_Expr = nlHsVar fmap_RDR
2375 pure_Expr = nlHsVar pure_RDR
2376 mempty_Expr = nlHsVar mempty_RDR
2377 foldMap_Expr = nlHsVar foldMap_RDR
2378 traverse_Expr = nlHsVar traverse_RDR
2379
2380 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2381 a_Pat = nlVarPat a_RDR
2382 b_Pat = nlVarPat b_RDR
2383 c_Pat = nlVarPat c_RDR
2384 d_Pat = nlVarPat d_RDR
2385 f_Pat = nlVarPat f_RDR
2386 k_Pat = nlVarPat k_RDR
2387 z_Pat = nlVarPat z_RDR
2388
2389 minusInt_RDR, tagToEnum_RDR :: RdrName
2390 minusInt_RDR = getRdrName (primOpId IntSubOp )
2391 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2392
2393 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2394 -- Generates Orig s RdrName, for the binding positions
2395 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2396 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2397 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2398
2399 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2400 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2401
2402 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2403 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2404 -- See Note [Auxiliary binders]
2405 mkAuxBinderName parent occ_fun
2406 = mkRdrUnqual (occ_fun stable_parent_occ)
2407 where
2408 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2409 stable_string
2410 | opt_PprStyle_Debug = parent_stable
2411 | otherwise = parent_stable_hash
2412 parent_stable = nameStableString parent
2413 parent_stable_hash =
2414 let Fingerprint high low = fingerprintString parent_stable
2415 in toBase62 high ++ toBase62Padded low
2416 -- See Note [Base 62 encoding 128-bit integers]
2417 parent_occ = nameOccName parent
2418
2419
2420 {-
2421 Note [Auxiliary binders]
2422 ~~~~~~~~~~~~~~~~~~~~~~~~
2423 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2424
2425 instance Ord T where
2426 compare a b = $con2tag a `compare` $con2tag b
2427
2428 $con2tag :: T -> Int
2429 $con2tag = ...code....
2430
2431 Of course these top-level bindings should all have distinct name, and we are
2432 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2433 because with standalone deriving two imported TyCons might both be called T!
2434 (See Trac #7947.)
2435
2436 So we use package name, module name and the name of the parent
2437 (T in this example) as part of the OccName we generate for the new binding.
2438 To make the symbol names short we take a base62 hash of the full name.
2439
2440 In the past we used the *unique* from the parent, but that's not stable across
2441 recompilations as uniques are nondeterministic.
2442
2443 Note [DeriveFoldable with ExistentialQuantification]
2444 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2445 Functor and Traversable instances can only be derived for data types whose
2446 last type parameter is truly universally polymorphic. For example:
2447
2448 data T a b where
2449 T1 :: b -> T a b -- YES, b is unconstrained
2450 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
2451 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
2452 T4 :: Int -> T a Int -- NO, this is just like T3
2453 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
2454 -- though a is existential
2455 T6 :: Int -> T Int b -- YES, b is unconstrained
2456
2457 For Foldable instances, however, we can completely lift the constraint that
2458 the last type parameter be truly universally polymorphic. This means that T
2459 (as defined above) can have a derived Foldable instance:
2460
2461 instance Foldable (T a) where
2462 foldr f z (T1 b) = f b z
2463 foldr f z (T2 b) = f b z
2464 foldr f z (T3 b) = f b z
2465 foldr f z (T4 b) = z
2466 foldr f z (T5 a b) = f b z
2467 foldr f z (T6 a) = z
2468
2469 foldMap f (T1 b) = f b
2470 foldMap f (T2 b) = f b
2471 foldMap f (T3 b) = f b
2472 foldMap f (T4 b) = mempty
2473 foldMap f (T5 a b) = f b
2474 foldMap f (T6 a) = mempty
2475
2476 In a Foldable instance, it is safe to fold over an occurrence of the last type
2477 parameter that is not truly universally polymorphic. However, there is a bit
2478 of subtlety in determining what is actually an occurrence of a type parameter.
2479 T3 and T4, as defined above, provide one example:
2480
2481 data T a b where
2482 ...
2483 T3 :: b ~ Int => b -> T a b
2484 T4 :: Int -> T a Int
2485 ...
2486
2487 instance Foldable (T a) where
2488 ...
2489 foldr f z (T3 b) = f b z
2490 foldr f z (T4 b) = z
2491 ...
2492 foldMap f (T3 b) = f b
2493 foldMap f (T4 b) = mempty
2494 ...
2495
2496 Notice that the argument of T3 is folded over, whereas the argument of T4 is
2497 not. This is because we only fold over constructor arguments that
2498 syntactically mention the universally quantified type parameter of that
2499 particular data constructor. See foldDataConArgs for how this is implemented.
2500
2501 As another example, consider the following data type. The argument of each
2502 constructor has the same type as the last type parameter:
2503
2504 data E a where
2505 E1 :: (a ~ Int) => a -> E a
2506 E2 :: Int -> E Int
2507 E3 :: (a ~ Int) => a -> E Int
2508 E4 :: (a ~ Int) => Int -> E a
2509
2510 Only E1's argument is an occurrence of a universally quantified type variable
2511 that is syntactically equivalent to the last type parameter, so only E1's
2512 argument will be be folded over in a derived Foldable instance.
2513
2514 See Trac #10447 for the original discussion on this feature. Also see
2515 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
2516 for a more in-depth explanation.
2517
2518 -}