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