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