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