Fix derived Ix instances for one-constructor GADTs
[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 if con_arity == 0
912 -- If the product type has no fields, inRange is trivially true
913 -- (see Trac #12853).
914 then true_Expr
915 else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
916 as_needed bs_needed cs_needed)
917 where
918 in_range a b c = nlHsApps inRange_RDR [mkLHsVarTuple [a,b], nlHsVar c]
919
920 {-
921 ************************************************************************
922 * *
923 Read instances
924 * *
925 ************************************************************************
926
927 Example
928
929 infix 4 %%
930 data T = Int %% Int
931 | T1 { f1 :: Int }
932 | T2 T
933
934 instance Read T where
935 readPrec =
936 parens
937 ( prec 4 (
938 do x <- ReadP.step Read.readPrec
939 expectP (Symbol "%%")
940 y <- ReadP.step Read.readPrec
941 return (x %% y))
942 +++
943 prec (appPrec+1) (
944 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
945 -- Record construction binds even more tightly than application
946 do expectP (Ident "T1")
947 expectP (Punc '{')
948 expectP (Ident "f1")
949 expectP (Punc '=')
950 x <- ReadP.reset Read.readPrec
951 expectP (Punc '}')
952 return (T1 { f1 = x }))
953 +++
954 prec appPrec (
955 do expectP (Ident "T2")
956 x <- ReadP.step Read.readPrec
957 return (T2 x))
958 )
959
960 readListPrec = readListPrecDefault
961 readList = readListDefault
962
963
964 Note [Use expectP]
965 ~~~~~~~~~~~~~~~~~~
966 Note that we use
967 expectP (Ident "T1")
968 rather than
969 Ident "T1" <- lexP
970 The latter desugares to inline code for matching the Ident and the
971 string, and this can be very voluminous. The former is much more
972 compact. Cf Trac #7258, although that also concerned non-linearity in
973 the occurrence analyser, a separate issue.
974
975 Note [Read for empty data types]
976 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
977 What should we get for this? (Trac #7931)
978 data Emp deriving( Read ) -- No data constructors
979
980 Here we want
981 read "[]" :: [Emp] to succeed, returning []
982 So we do NOT want
983 instance Read Emp where
984 readPrec = error "urk"
985 Rather we want
986 instance Read Emp where
987 readPred = pfail -- Same as choose []
988
989 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
990 These instances are also useful for Read (Either Int Emp), where
991 we want to be able to parse (Left 3) just fine.
992 -}
993
994 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
995
996 gen_Read_binds get_fixity loc tycon
997 = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
998 where
999 -----------------------------------------------------------------------
1000 default_readlist
1001 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
1002
1003 default_readlistprec
1004 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
1005 -----------------------------------------------------------------------
1006
1007 data_cons = tyConDataCons tycon
1008 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
1009
1010 read_prec = mkHsVarBind loc readPrec_RDR
1011 (nlHsApp (nlHsVar parens_RDR) read_cons)
1012
1013 read_cons | null data_cons = nlHsVar pfail_RDR -- See Note [Read for empty data types]
1014 | otherwise = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons)
1015 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
1016
1017 read_nullary_cons
1018 = case nullary_cons of
1019 [] -> []
1020 [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])]
1021 _ -> [nlHsApp (nlHsVar choose_RDR)
1022 (nlList (map mk_pair nullary_cons))]
1023 -- NB For operators the parens around (:=:) are matched by the
1024 -- enclosing "parens" call, so here we must match the naked
1025 -- data_con_str con
1026
1027 match_con con | isSym con_str = [symbol_pat con_str]
1028 | otherwise = ident_h_pat con_str
1029 where
1030 con_str = data_con_str con
1031 -- For nullary constructors we must match Ident s for normal constrs
1032 -- and Symbol s for operators
1033
1034 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
1035 result_expr con []]
1036
1037 read_non_nullary_con data_con
1038 | is_infix = mk_parser infix_prec infix_stmts body
1039 | is_record = mk_parser record_prec record_stmts body
1040 -- Using these two lines instead allows the derived
1041 -- read for infix and record bindings to read the prefix form
1042 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
1043 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
1044 | otherwise = prefix_parser
1045 where
1046 body = result_expr data_con as_needed
1047 con_str = data_con_str data_con
1048
1049 prefix_parser = mk_parser prefix_prec prefix_stmts body
1050
1051 read_prefix_con
1052 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
1053 | otherwise = ident_h_pat con_str
1054
1055 read_infix_con
1056 | isSym con_str = [symbol_pat con_str]
1057 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
1058
1059 prefix_stmts -- T a b c
1060 = read_prefix_con ++ read_args
1061
1062 infix_stmts -- a %% b, or a `T` b
1063 = [read_a1]
1064 ++ read_infix_con
1065 ++ [read_a2]
1066
1067 record_stmts -- T { f1 = a, f2 = b }
1068 = read_prefix_con
1069 ++ [read_punc "{"]
1070 ++ concat (intersperse [read_punc ","] field_stmts)
1071 ++ [read_punc "}"]
1072
1073 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
1074
1075 con_arity = dataConSourceArity data_con
1076 labels = map flLabel $ dataConFieldLabels data_con
1077 dc_nm = getName data_con
1078 is_infix = dataConIsInfix data_con
1079 is_record = length labels > 0
1080 as_needed = take con_arity as_RDRs
1081 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (dataConOrigArgTys data_con)
1082 (read_a1:read_a2:_) = read_args
1083
1084 prefix_prec = appPrecedence
1085 infix_prec = getPrecedence get_fixity dc_nm
1086 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
1087 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
1088
1089 ------------------------------------------------------------------------
1090 -- Helpers
1091 ------------------------------------------------------------------------
1092 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
1093 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
1094 , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])]
1095 con_app con as = nlHsVarApps (getRdrName con) as -- con as
1096 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1097
1098 -- For constructors and field labels ending in '#', we hackily
1099 -- let the lexer generate two tokens, and look for both in sequence
1100 -- Thus [Ident "I"; Symbol "#"]. See Trac #5041
1101 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
1102 | otherwise = [ ident_pat s ]
1103
1104 bindLex pat = noLoc (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
1105 -- See Note [Use expectP]
1106 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo")
1107 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>")
1108 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<")
1109
1110 data_con_str con = occNameString (getOccName con)
1111
1112 read_arg a ty = ASSERT( not (isUnliftedType ty) )
1113 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
1114
1115 read_field lbl a = read_lbl lbl ++
1116 [read_punc "=",
1117 noLoc (mkBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR]))]
1118
1119 -- When reading field labels we might encounter
1120 -- a = 3
1121 -- _a = 3
1122 -- or (#) = 4
1123 -- Note the parens!
1124 read_lbl lbl | isSym lbl_str
1125 = [read_punc "(", symbol_pat lbl_str, read_punc ")"]
1126 | otherwise
1127 = ident_h_pat lbl_str
1128 where
1129 lbl_str = unpackFS lbl
1130
1131 {-
1132 ************************************************************************
1133 * *
1134 Show instances
1135 * *
1136 ************************************************************************
1137
1138 Example
1139
1140 infixr 5 :^:
1141
1142 data Tree a = Leaf a | Tree a :^: Tree a
1143
1144 instance (Show a) => Show (Tree a) where
1145
1146 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1147 where
1148 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1149
1150 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1151 where
1152 showStr = showsPrec (up_prec+1) u .
1153 showString " :^: " .
1154 showsPrec (up_prec+1) v
1155 -- Note: right-associativity of :^: ignored
1156
1157 up_prec = 5 -- Precedence of :^:
1158 app_prec = 10 -- Application has precedence one more than
1159 -- the most tightly-binding operator
1160 -}
1161
1162 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1163
1164 gen_Show_binds get_fixity loc tycon
1165 = (listToBag [shows_prec, show_list], emptyBag)
1166 where
1167 -----------------------------------------------------------------------
1168 show_list = mkHsVarBind loc showList_RDR
1169 (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0))))
1170 -----------------------------------------------------------------------
1171 data_cons = tyConDataCons tycon
1172 shows_prec = mk_FunBind loc showsPrec_RDR (map pats_etc data_cons)
1173
1174 pats_etc data_con
1175 | nullary_con = -- skip the showParen junk...
1176 ASSERT(null bs_needed)
1177 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1178 | otherwise =
1179 ([a_Pat, con_pat],
1180 showParen_Expr (genOpApp a_Expr ge_RDR
1181 (nlHsLit (HsInt "" con_prec_plus_one)))
1182 (nlHsPar (nested_compose_Expr show_thingies)))
1183 where
1184 data_con_RDR = getRdrName data_con
1185 con_arity = dataConSourceArity data_con
1186 bs_needed = take con_arity bs_RDRs
1187 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1188 con_pat = nlConVarPat data_con_RDR bs_needed
1189 nullary_con = con_arity == 0
1190 labels = map flLabel $ dataConFieldLabels data_con
1191 lab_fields = length labels
1192 record_syntax = lab_fields > 0
1193
1194 dc_nm = getName data_con
1195 dc_occ_nm = getOccName data_con
1196 con_str = occNameString dc_occ_nm
1197 op_con_str = wrapOpParens con_str
1198 backquote_str = wrapOpBackquotes con_str
1199
1200 show_thingies
1201 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1202 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1203 show_record_args ++ [mk_showString_app "}"]
1204 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1205
1206 show_label l = mk_showString_app (nm ++ " = ")
1207 -- Note the spaces around the "=" sign. If we
1208 -- don't have them then we get Foo { x=-1 } and
1209 -- the "=-" parses as a single lexeme. Only the
1210 -- space after the '=' is necessary, but it
1211 -- seems tidier to have them both sides.
1212 where
1213 nm = wrapOpParens (unpackFS l)
1214
1215 show_args = zipWith show_arg bs_needed arg_tys
1216 (show_arg1:show_arg2:_) = show_args
1217 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1218
1219 -- Assumption for record syntax: no of fields == no of
1220 -- labelled fields (and in same order)
1221 show_record_args = concat $
1222 intersperse [mk_showString_app ", "] $
1223 [ [show_label lbl, arg]
1224 | (lbl,arg) <- zipEqual "gen_Show_binds"
1225 labels show_args ]
1226
1227 show_arg :: RdrName -> Type -> LHsExpr RdrName
1228 show_arg b arg_ty
1229 | isUnliftedType arg_ty
1230 -- See Note [Deriving and unboxed types] in TcDeriv
1231 = nlHsApps compose_RDR [mk_shows_app boxed_arg,
1232 mk_showString_app postfixMod]
1233 | otherwise
1234 = mk_showsPrec_app arg_prec arg
1235 where
1236 arg = nlHsVar b
1237 boxed_arg = box "Show" tycon arg arg_ty
1238 postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
1239
1240 -- Fixity stuff
1241 is_infix = dataConIsInfix data_con
1242 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1243 arg_prec | record_syntax = 0 -- Record fields don't need parens
1244 | otherwise = con_prec_plus_one
1245
1246 wrapOpParens :: String -> String
1247 wrapOpParens s | isSym s = '(' : s ++ ")"
1248 | otherwise = s
1249
1250 wrapOpBackquotes :: String -> String
1251 wrapOpBackquotes s | isSym s = s
1252 | otherwise = '`' : s ++ "`"
1253
1254 isSym :: String -> Bool
1255 isSym "" = False
1256 isSym (c : _) = startsVarSym c || startsConSym c
1257
1258 -- | showString :: String -> ShowS
1259 mk_showString_app :: String -> LHsExpr RdrName
1260 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1261
1262 -- | showsPrec :: Show a => Int -> a -> ShowS
1263 mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
1264 mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x]
1265
1266 -- | shows :: Show a => a -> ShowS
1267 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
1268 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1269
1270 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1271 getPrec is_infix get_fixity nm
1272 | not is_infix = appPrecedence
1273 | otherwise = getPrecedence get_fixity nm
1274
1275 appPrecedence :: Integer
1276 appPrecedence = fromIntegral maxPrecedence + 1
1277 -- One more than the precedence of the most
1278 -- tightly-binding operator
1279
1280 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1281 getPrecedence get_fixity nm
1282 = case get_fixity nm of
1283 Fixity _ x _assoc -> fromIntegral x
1284 -- NB: the Report says that associativity is not taken
1285 -- into account for either Read or Show; hence we
1286 -- ignore associativity here
1287
1288 {-
1289 ************************************************************************
1290 * *
1291 Data instances
1292 * *
1293 ************************************************************************
1294
1295 From the data type
1296
1297 data T a b = T1 a b | T2
1298
1299 we generate
1300
1301 $cT1 = mkDataCon $dT "T1" Prefix
1302 $cT2 = mkDataCon $dT "T2" Prefix
1303 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1304 -- the [] is for field labels.
1305
1306 instance (Data a, Data b) => Data (T a b) where
1307 gfoldl k z (T1 a b) = z T `k` a `k` b
1308 gfoldl k z T2 = z T2
1309 -- ToDo: add gmapT,Q,M, gfoldr
1310
1311 gunfold k z c = case conIndex c of
1312 I# 1# -> k (k (z T1))
1313 I# 2# -> z T2
1314
1315 toConstr (T1 _ _) = $cT1
1316 toConstr T2 = $cT2
1317
1318 dataTypeOf _ = $dT
1319
1320 dataCast1 = gcast1 -- If T :: * -> *
1321 dataCast2 = gcast2 -- if T :: * -> * -> *
1322 -}
1323
1324 gen_Data_binds :: SrcSpan
1325 -> TyCon -- For data families, this is the
1326 -- *representation* TyCon
1327 -> TcM (LHsBinds RdrName, -- The method bindings
1328 BagDerivStuff) -- Auxiliary bindings
1329 gen_Data_binds loc rep_tc
1330 = do { dflags <- getDynFlags
1331
1332 -- Make unique names for the data type and constructor
1333 -- auxiliary bindings. Start with the name of the TyCon/DataCon
1334 -- but that might not be unique: see Trac #12245.
1335 ; dt_occ <- chooseUniqueOccTc (mkDataTOcc (getOccName rep_tc))
1336 ; dc_occs <- mapM (chooseUniqueOccTc . mkDataCOcc . getOccName)
1337 (tyConDataCons rep_tc)
1338 ; let dt_rdr = mkRdrUnqual dt_occ
1339 dc_rdrs = map mkRdrUnqual dc_occs
1340
1341 -- OK, now do the work
1342 ; return (gen_data dflags dt_rdr dc_rdrs loc rep_tc) }
1343
1344 gen_data :: DynFlags -> RdrName -> [RdrName]
1345 -> SrcSpan -> TyCon
1346 -> (LHsBinds RdrName, -- The method bindings
1347 BagDerivStuff) -- Auxiliary bindings
1348 gen_data dflags data_type_name constr_names loc rep_tc
1349 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1350 `unionBags` gcast_binds,
1351 -- Auxiliary definitions: the data type and constructors
1352 listToBag ( genDataTyCon
1353 : zipWith genDataDataCon data_cons constr_names ) )
1354 where
1355 data_cons = tyConDataCons rep_tc
1356 n_cons = length data_cons
1357 one_constr = n_cons == 1
1358 genDataTyCon :: DerivStuff
1359 genDataTyCon -- $dT
1360 = DerivHsBind (mkHsVarBind loc data_type_name rhs,
1361 L loc (TypeSig [L loc data_type_name] sig_ty))
1362
1363 sig_ty = mkLHsSigWcType (nlHsTyVar dataType_RDR)
1364 rhs = nlHsVar mkDataType_RDR
1365 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
1366 `nlHsApp` nlList (map nlHsVar constr_names)
1367
1368 genDataDataCon :: DataCon -> RdrName -> DerivStuff
1369 genDataDataCon dc constr_name -- $cT1 etc
1370 = DerivHsBind (mkHsVarBind loc constr_name rhs,
1371 L loc (TypeSig [L loc constr_name] sig_ty))
1372 where
1373 sig_ty = mkLHsSigWcType (nlHsTyVar constr_RDR)
1374 rhs = nlHsApps mkConstr_RDR constr_args
1375
1376 constr_args
1377 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1378 nlHsVar (data_type_name) -- DataType
1379 , nlHsLit (mkHsString (occNameString dc_occ)) -- String name
1380 , nlList labels -- Field labels
1381 , nlHsVar fixity ] -- Fixity
1382
1383 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
1384 (dataConFieldLabels dc)
1385 dc_occ = getOccName dc
1386 is_infix = isDataSymOcc dc_occ
1387 fixity | is_infix = infix_RDR
1388 | otherwise = prefix_RDR
1389
1390 ------------ gfoldl
1391 gfoldl_bind = mk_HRFunBind 2 loc gfoldl_RDR (map gfoldl_eqn data_cons)
1392
1393 gfoldl_eqn con
1394 = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1395 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1396 where
1397 con_name :: RdrName
1398 con_name = getRdrName con
1399 as_needed = take (dataConSourceArity con) as_RDRs
1400 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1401
1402 ------------ gunfold
1403 gunfold_bind = mk_HRFunBind 2 loc
1404 gunfold_RDR
1405 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1406 gunfold_rhs)]
1407
1408 gunfold_rhs
1409 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1410 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1411 (map gunfold_alt data_cons)
1412
1413 gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1414 mk_unfold_rhs dc = foldr nlHsApp
1415 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1416 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1417
1418 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1419 -- redundant test, and annoying warning
1420 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1421 | otherwise = nlConPat intDataCon_RDR
1422 [nlLitPat (HsIntPrim "" (toInteger tag))]
1423 where
1424 tag = dataConTag dc
1425
1426 ------------ toConstr
1427 toCon_bind = mk_FunBind loc toConstr_RDR (zipWith to_con_eqn data_cons constr_names)
1428 to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
1429
1430 ------------ dataTypeOf
1431 dataTypeOf_bind = mk_easy_FunBind
1432 loc
1433 dataTypeOf_RDR
1434 [nlWildPat]
1435 (nlHsVar data_type_name)
1436
1437 ------------ gcast1/2
1438 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1439 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1440 -- (or nothing if T has neither of these two types)
1441
1442 -- But care is needed for data families:
1443 -- If we have data family D a
1444 -- data instance D (a,b,c) = A | B deriving( Data )
1445 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1446 -- then we need dataCast1 x = gcast1 x
1447 -- because D :: * -> *
1448 -- even though rep_tc has kind * -> * -> * -> *
1449 -- Hence looking for the kind of fam_tc not rep_tc
1450 -- See Trac #4896
1451 tycon_kind = case tyConFamInst_maybe rep_tc of
1452 Just (fam_tc, _) -> tyConKind fam_tc
1453 Nothing -> tyConKind rep_tc
1454 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1455 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1456 | otherwise = emptyBag
1457 mk_gcast dataCast_RDR gcast_RDR
1458 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1459 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1460
1461
1462 kind1, kind2 :: Kind
1463 kind1 = liftedTypeKind `mkFunTy` liftedTypeKind
1464 kind2 = liftedTypeKind `mkFunTy` kind1
1465
1466 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1467 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1468 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1469 constr_RDR, dataType_RDR,
1470 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1471 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1472 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1473 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1474 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1475 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1476 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1477 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1478 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1479 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1480 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1481 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1482 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1483 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1484 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1485 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1486 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1487 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1488 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1489 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1490 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1491
1492 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1493 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1494 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1495 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1496 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1497
1498 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1499 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1500 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1501 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1502 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1503
1504 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1505 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1506 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1507 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1508 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1509
1510 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1511 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1512 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1513 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1514 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1515
1516 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1517 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1518 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1519 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1520 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1521
1522 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1523 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1524 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1525 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1526 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1527
1528 {-
1529 ************************************************************************
1530 * *
1531 Functor instances
1532
1533 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1534
1535 * *
1536 ************************************************************************
1537
1538 For the data type:
1539
1540 data T a = T1 Int a | T2 (T a)
1541
1542 We generate the instance:
1543
1544 instance Functor T where
1545 fmap f (T1 b1 a) = T1 b1 (f a)
1546 fmap f (T2 ta) = T2 (fmap f ta)
1547
1548 Notice that we don't simply apply 'fmap' to the constructor arguments.
1549 Rather
1550 - Do nothing to an argument whose type doesn't mention 'a'
1551 - Apply 'f' to an argument of type 'a'
1552 - Apply 'fmap f' to other arguments
1553 That's why we have to recurse deeply into the constructor argument types,
1554 rather than just one level, as we typically do.
1555
1556 What about types with more than one type parameter? In general, we only
1557 derive Functor for the last position:
1558
1559 data S a b = S1 [b] | S2 (a, T a b)
1560 instance Functor (S a) where
1561 fmap f (S1 bs) = S1 (fmap f bs)
1562 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1563
1564 However, we have special cases for
1565 - tuples
1566 - functions
1567
1568 More formally, we write the derivation of fmap code over type variable
1569 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1570 instance for T is:
1571
1572 instance Functor T where
1573 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1574 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1575
1576 $(fmap 'a 'b) = \x -> x -- when b does not contain a
1577 $(fmap 'a 'a) = f
1578 $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1579 $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2
1580 $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1581
1582 For functions, the type parameter 'a can occur in a contravariant position,
1583 which means we need to derive a function like:
1584
1585 cofmap :: (a -> b) -> (f b -> f a)
1586
1587 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1588
1589 $(cofmap 'a 'b) = \x -> x -- when b does not contain a
1590 $(cofmap 'a 'a) = error "type variable in contravariant position"
1591 $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1592 $(cofmap 'a '[b]) = map $(cofmap 'a 'b)
1593 $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2
1594 $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1595
1596 Note that the code produced by $(fmap _ _) is always a higher order function,
1597 with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
1598 matching on the type, this means create a lambda function (see the (,) case above).
1599 The resulting code for fmap can look a bit weird, for example:
1600
1601 data X a = X (a,Int)
1602 -- generated instance
1603 instance Functor X where
1604 fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
1605
1606 The optimizer should be able to simplify this code by simple inlining.
1607
1608 An older version of the deriving code tried to avoid these applied
1609 lambda functions by producing a meta level function. But the function to
1610 be mapped, `f`, is a function on the code level, not on the meta level,
1611 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
1612 It is better to produce too many lambdas than to eta expand, see ticket #7436.
1613 -}
1614
1615 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1616 gen_Functor_binds loc tycon
1617 = (unitBag fmap_bind, emptyBag)
1618 where
1619 data_cons = tyConDataCons tycon
1620 fun_name = L loc fmap_RDR
1621 fmap_bind = mkRdrFunBind fun_name eqns
1622
1623 fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1624 where
1625 parts = sequence $ foldDataConArgs ft_fmap con
1626
1627 eqns | null data_cons = [mkSimpleMatch (FunRhs fun_name Prefix)
1628 [nlWildPat, nlWildPat]
1629 (error_Expr "Void fmap")]
1630 | otherwise = map fmap_eqn data_cons
1631
1632 ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1633 ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x
1634 -- fmap f = \x -> x
1635 , ft_var = return f_Expr
1636 -- fmap f = f
1637 , ft_fun = \g h -> do
1638 gg <- g
1639 hh <- h
1640 mkSimpleLam2 $ \x b -> return $
1641 nlHsApp hh (nlHsApp x (nlHsApp gg b))
1642 -- fmap f = \x b -> h (x (g b))
1643 , ft_tup = \t gs -> do
1644 gg <- sequence gs
1645 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1646 -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1647 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g
1648 -- fmap f = fmap g
1649 , ft_forall = \_ g -> g
1650 , ft_bad_app = panic "in other argument"
1651 , ft_co_var = panic "contravariant" }
1652
1653 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
1654 match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
1655 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1656 match_for_con = mkSimpleConMatch CaseAlt $
1657 \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 ..
1658
1659 {-
1660 Utility functions related to Functor deriving.
1661
1662 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1663 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1664 -}
1665
1666 -- Generic traversal for Functor deriving
1667 -- See Note [FFoldType and functorLikeTraverse]
1668 data FFoldType a -- Describes how to fold over a Type in a functor like way
1669 = FT { ft_triv :: a
1670 -- ^ Does not contain variable
1671 , ft_var :: a
1672 -- ^ The variable itself
1673 , ft_co_var :: a
1674 -- ^ The variable itself, contravariantly
1675 , ft_fun :: a -> a -> a
1676 -- ^ Function type
1677 , ft_tup :: TyCon -> [a] -> a
1678 -- ^ Tuple type
1679 , ft_ty_app :: Type -> a -> a
1680 -- ^ Type app, variable only in last argument
1681 , ft_bad_app :: a
1682 -- ^ Type app, variable other than in last argument
1683 , ft_forall :: TcTyVar -> a -> a
1684 -- ^ Forall type
1685 }
1686
1687 functorLikeTraverse :: forall a.
1688 TyVar -- ^ Variable to look for
1689 -> FFoldType a -- ^ How to fold
1690 -> Type -- ^ Type to process
1691 -> a
1692 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1693 , ft_co_var = caseCoVar, ft_fun = caseFun
1694 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1695 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1696 ty
1697 = fst (go False ty)
1698 where
1699 go :: Bool -- Covariant or contravariant context
1700 -> Type
1701 -> (a, Bool) -- (result of type a, does type contain var)
1702
1703 go co ty | Just ty' <- coreView ty = go co ty'
1704 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1705 go co (FunTy x y) | isPredTy x = go co y
1706 | xc || yc = (caseFun xr yr,True)
1707 where (xr,xc) = go (not co) x
1708 (yr,yc) = go co y
1709 go co (AppTy x y) | xc = (caseWrongArg, True)
1710 | yc = (caseTyApp x yr, True)
1711 where (_, xc) = go co x
1712 (yr,yc) = go co y
1713 go co ty@(TyConApp con args)
1714 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
1715 -- At this point we know that xrs, xcs is not empty,
1716 -- and at least one xr is True
1717 | isTupleTyCon con = (caseTuple con xrs, True)
1718 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
1719 | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty
1720 = (caseTyApp fun_ty (last xrs), True)
1721 | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
1722 where
1723 -- When folding over an unboxed tuple, we must explicitly drop the
1724 -- runtime rep arguments, or else GHC will generate twice as many
1725 -- variables in a unboxed tuple pattern match and expression as it
1726 -- actually needs. See Trac #12399
1727 (xrs,xcs) = unzip (map (go co) (dropRuntimeRepArgs args))
1728 go co (ForAllTy (TvBndr v vis) x)
1729 | isVisibleArgFlag vis = panic "unexpected visible binder"
1730 | v /= var && xc = (caseForAll v xr,True)
1731 where (xr,xc) = go co x
1732
1733 go _ _ = (caseTrivial,False)
1734
1735 -- Return all syntactic subterms of ty that contain var somewhere
1736 -- These are the things that should appear in instance constraints
1737 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1738 deepSubtypesContaining tv
1739 = functorLikeTraverse tv
1740 (FT { ft_triv = []
1741 , ft_var = []
1742 , ft_fun = (++)
1743 , ft_tup = \_ xs -> concat xs
1744 , ft_ty_app = (:)
1745 , ft_bad_app = panic "in other argument"
1746 , ft_co_var = panic "contravariant"
1747 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyCoVarsOfType) xs })
1748
1749
1750 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1751 -- Fold over the arguments of the datacon
1752 foldDataConArgs ft con
1753 = map foldArg (dataConOrigArgTys con)
1754 where
1755 foldArg
1756 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
1757 Just tv -> functorLikeTraverse tv ft
1758 Nothing -> const (ft_triv ft)
1759 -- If we are deriving Foldable for a GADT, there is a chance that the last
1760 -- type variable in the data type isn't actually a type variable at all.
1761 -- (for example, this can happen if the last type variable is refined to
1762 -- be a concrete type such as Int). If the last type variable is refined
1763 -- to be a specific type, then getTyVar_maybe will return Nothing.
1764 -- See Note [DeriveFoldable with ExistentialQuantification]
1765 --
1766 -- The kind checks have ensured the last type parameter is of kind *.
1767
1768 -- Make a HsLam using a fresh variable from a State monad
1769 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1770 -> State [RdrName] (LHsExpr RdrName)
1771 -- (mkSimpleLam fn) returns (\x. fn(x))
1772 mkSimpleLam lam = do
1773 (n:names) <- get
1774 put names
1775 body <- lam (nlHsVar n)
1776 return (mkHsLam [nlVarPat n] body)
1777
1778 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
1779 -> State [RdrName] (LHsExpr RdrName))
1780 -> State [RdrName] (LHsExpr RdrName)
1781 mkSimpleLam2 lam = do
1782 (n1:n2:names) <- get
1783 put names
1784 body <- lam (nlHsVar n1) (nlHsVar n2)
1785 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1786
1787 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1788 --
1789 -- @mkSimpleConMatch fold extra_pats con insides@ produces a match clause in
1790 -- which the LHS pattern-matches on @extra_pats@, followed by a match on the
1791 -- constructor @con@ and its arguments. The RHS folds (with @fold@) over @con@
1792 -- and its arguments, applying an expression (from @insides@) to each of the
1793 -- respective arguments of @con@.
1794 mkSimpleConMatch :: Monad m => HsMatchContext RdrName
1795 -> (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1796 -> [LPat RdrName]
1797 -> DataCon
1798 -> [LHsExpr RdrName]
1799 -> m (LMatch RdrName (LHsExpr RdrName))
1800 mkSimpleConMatch ctxt fold extra_pats con insides = do
1801 let con_name = getRdrName con
1802 let vars_needed = takeList insides as_RDRs
1803 let pat = nlConVarPat con_name vars_needed
1804 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1805 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
1806 (noLoc emptyLocalBinds)
1807
1808 -- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"
1809 --
1810 -- @mkSimpleConMatch2 fold extra_pats con insides@ behaves very similarly to
1811 -- 'mkSimpleConMatch', with two key differences:
1812 --
1813 -- 1. @insides@ is a @[Maybe (LHsExpr RdrName)]@ instead of a
1814 -- @[LHsExpr RdrName]@. This is because it filters out the expressions
1815 -- corresponding to arguments whose types do not mention the last type
1816 -- variable in a derived 'Foldable' or 'Traversable' instance (i.e., the
1817 -- 'Nothing' elements of @insides@).
1818 --
1819 -- 2. @fold@ takes an expression as its first argument instead of a
1820 -- constructor name. This is because it uses a specialized
1821 -- constructor function expression that only takes as many parameters as
1822 -- there are argument types that mention the last type variable.
1823 --
1824 -- See Note [Generated code for DeriveFoldable and DeriveTraversable]
1825 mkSimpleConMatch2 :: Monad m
1826 => HsMatchContext RdrName
1827 -> (LHsExpr RdrName -> [LHsExpr RdrName]
1828 -> m (LHsExpr RdrName))
1829 -> [LPat RdrName]
1830 -> DataCon
1831 -> [Maybe (LHsExpr RdrName)]
1832 -> m (LMatch RdrName (LHsExpr RdrName))
1833 mkSimpleConMatch2 ctxt fold extra_pats con insides = do
1834 let con_name = getRdrName con
1835 vars_needed = takeList insides as_RDRs
1836 pat = nlConVarPat con_name vars_needed
1837 -- Make sure to zip BEFORE invoking catMaybes. We want the variable
1838 -- indicies in each expression to match up with the argument indices
1839 -- in con_expr (defined below).
1840 exps = catMaybes $ zipWith (\i v -> (`nlHsApp` v) <$> i)
1841 insides (map nlHsVar vars_needed)
1842 -- An element of argTysTyVarInfo is True if the constructor argument
1843 -- with the same index has a type which mentions the last type
1844 -- variable.
1845 argTysTyVarInfo = map isJust insides
1846 (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo as_RDRs
1847
1848 con_expr
1849 | null asWithTyVar = nlHsApps con_name $ map nlHsVar asWithoutTyVar
1850 | otherwise =
1851 let bs = filterByList argTysTyVarInfo bs_RDRs
1852 vars = filterByLists argTysTyVarInfo
1853 (map nlHsVar bs_RDRs)
1854 (map nlHsVar as_RDRs)
1855 in mkHsLam (map nlVarPat bs) (nlHsApps con_name vars)
1856
1857 rhs <- fold con_expr exps
1858 return $ mkMatch ctxt (extra_pats ++ [pat]) rhs
1859 (noLoc emptyLocalBinds)
1860
1861 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1862 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1863 -> m (LMatch RdrName (LHsExpr RdrName)))
1864 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1865 mkSimpleTupleCase match_for_con tc insides x
1866 = do { let data_con = tyConSingleDataCon tc
1867 ; match <- match_for_con [] data_con insides
1868 ; return $ nlHsCase x [match] }
1869
1870 {-
1871 ************************************************************************
1872 * *
1873 Foldable instances
1874
1875 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1876
1877 * *
1878 ************************************************************************
1879
1880 Deriving Foldable instances works the same way as Functor instances,
1881 only Foldable instances are not possible for function types at all.
1882 Given (data T a = T a a (T a) deriving Foldable), we get:
1883
1884 instance Foldable T where
1885 foldr f z (T x1 x2 x3) =
1886 $(foldr 'a 'a) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a '(T a)) x3 z ) )
1887
1888 -XDeriveFoldable is different from -XDeriveFunctor in that it filters out
1889 arguments to the constructor that would produce useless code in a Foldable
1890 instance. For example, the following datatype:
1891
1892 data Foo a = Foo Int a Int deriving Foldable
1893
1894 would have the following generated Foldable instance:
1895
1896 instance Foldable Foo where
1897 foldr f z (Foo x1 x2 x3) = $(foldr 'a 'a) x2
1898
1899 since neither of the two Int arguments are folded over.
1900
1901 The cases are:
1902
1903 $(foldr 'a 'a) = f
1904 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1905 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
1906
1907 Note that the arguments to the real foldr function are the wrong way around,
1908 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1909
1910 One can envision a case for types that don't contain the last type variable:
1911
1912 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
1913
1914 But this case will never materialize, since the aforementioned filtering
1915 removes all such types from consideration.
1916 See Note [Generated code for DeriveFoldable and DeriveTraversable].
1917
1918 Foldable instances differ from Functor and Traversable instances in that
1919 Foldable instances can be derived for data types in which the last type
1920 variable is existentially quantified. In particular, if the last type variable
1921 is refined to a more specific type in a GADT:
1922
1923 data GADT a where
1924 G :: a ~ Int => a -> G Int
1925
1926 then the deriving machinery does not attempt to check that the type a contains
1927 Int, since it is not syntactically equal to a type variable. That is, the
1928 derived Foldable instance for GADT is:
1929
1930 instance Foldable GADT where
1931 foldr _ z (GADT _) = z
1932
1933 See Note [DeriveFoldable with ExistentialQuantification].
1934
1935 -}
1936
1937 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1938 gen_Foldable_binds loc tycon
1939 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1940 where
1941 data_cons = tyConDataCons tycon
1942
1943 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1944 eqns = map foldr_eqn data_cons
1945 foldr_eqn con
1946 = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1947 where
1948 parts = sequence $ foldDataConArgs ft_foldr con
1949
1950 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1951 foldMap_eqn con
1952 = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1953 where
1954 parts = sequence $ foldDataConArgs ft_foldMap con
1955
1956 -- Yields 'Just' an expression if we're folding over a type that mentions
1957 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
1958 -- See Note [FFoldType and functorLikeTraverse]
1959 ft_foldr :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
1960 ft_foldr
1961 = FT { ft_triv = return Nothing
1962 -- foldr f = \x z -> z
1963 , ft_var = return $ Just f_Expr
1964 -- foldr f = f
1965 , ft_tup = \t g -> do
1966 gg <- sequence g
1967 lam <- mkSimpleLam2 $ \x z ->
1968 mkSimpleTupleCase (match_foldr z) t gg x
1969 return (Just lam)
1970 -- foldr f = (\x z -> case x of ...)
1971 , ft_ty_app = \_ g -> do
1972 gg <- g
1973 mapM (\gg' -> mkSimpleLam2 $ \x z -> return $
1974 nlHsApps foldable_foldr_RDR [gg',z,x]) gg
1975 -- foldr f = (\x z -> foldr g z x)
1976 , ft_forall = \_ g -> g
1977 , ft_co_var = panic "contravariant"
1978 , ft_fun = panic "function"
1979 , ft_bad_app = panic "in other argument" }
1980
1981 match_foldr :: LHsExpr RdrName
1982 -> [LPat RdrName]
1983 -> DataCon
1984 -> [Maybe (LHsExpr RdrName)]
1985 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1986 match_foldr z = mkSimpleConMatch2 LambdaExpr $ \_ xs -> return (mkFoldr xs)
1987 where
1988 -- g1 v1 (g2 v2 (.. z))
1989 mkFoldr :: [LHsExpr RdrName] -> LHsExpr RdrName
1990 mkFoldr = foldr nlHsApp z
1991
1992 -- See Note [FFoldType and functorLikeTraverse]
1993 ft_foldMap :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
1994 ft_foldMap
1995 = FT { ft_triv = return Nothing
1996 -- foldMap f = \x -> mempty
1997 , ft_var = return (Just f_Expr)
1998 -- foldMap f = f
1999 , ft_tup = \t g -> do
2000 gg <- sequence g
2001 lam <- mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
2002 return (Just lam)
2003 -- foldMap f = \x -> case x of (..,)
2004 , ft_ty_app = \_ g -> fmap (nlHsApp foldMap_Expr) <$> g
2005 -- foldMap f = foldMap g
2006 , ft_forall = \_ g -> g
2007 , ft_co_var = panic "contravariant"
2008 , ft_fun = panic "function"
2009 , ft_bad_app = panic "in other argument" }
2010
2011 match_foldMap :: [LPat RdrName]
2012 -> DataCon
2013 -> [Maybe (LHsExpr RdrName)]
2014 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
2015 match_foldMap = mkSimpleConMatch2 CaseAlt $ \_ xs -> return (mkFoldMap xs)
2016 where
2017 -- mappend v1 (mappend v2 ..)
2018 mkFoldMap :: [LHsExpr RdrName] -> LHsExpr RdrName
2019 mkFoldMap [] = mempty_Expr
2020 mkFoldMap xs = foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
2021
2022 {-
2023 ************************************************************************
2024 * *
2025 Traversable instances
2026
2027 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
2028 * *
2029 ************************************************************************
2030
2031 Again, Traversable is much like Functor and Foldable.
2032
2033 The cases are:
2034
2035 $(traverse 'a 'a) = f
2036 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
2037 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
2038
2039 Like -XDeriveFoldable, -XDeriveTraversable filters out arguments whose types
2040 do not mention the last type parameter. Therefore, the following datatype:
2041
2042 data Foo a = Foo Int a Int
2043
2044 would have the following derived Traversable instance:
2045
2046 instance Traversable Foo where
2047 traverse f (Foo x1 x2 x3) =
2048 fmap (\b2 -> Foo x1 b2 x3) ( $(traverse 'a 'a) x2 )
2049
2050 since the two Int arguments do not produce any effects in a traversal.
2051
2052 One can envision a case for types that do not mention the last type parameter:
2053
2054 $(traverse 'a 'b) = pure -- when b does not contain a
2055
2056 But this case will never materialize, since the aforementioned filtering
2057 removes all such types from consideration.
2058 See Note [Generated code for DeriveFoldable and DeriveTraversable].
2059 -}
2060
2061 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
2062 gen_Traversable_binds loc tycon
2063 = (unitBag traverse_bind, emptyBag)
2064 where
2065 data_cons = tyConDataCons tycon
2066
2067 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
2068 eqns = map traverse_eqn data_cons
2069 traverse_eqn con
2070 = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
2071 where
2072 parts = sequence $ foldDataConArgs ft_trav con
2073
2074 -- Yields 'Just' an expression if we're folding over a type that mentions
2075 -- the last type parameter of the datatype. Otherwise, yields 'Nothing'.
2076 -- See Note [FFoldType and functorLikeTraverse]
2077 ft_trav :: FFoldType (State [RdrName] (Maybe (LHsExpr RdrName)))
2078 ft_trav
2079 = FT { ft_triv = return Nothing
2080 -- traverse f = pure x
2081 , ft_var = return (Just f_Expr)
2082 -- traverse f = f x
2083 , ft_tup = \t gs -> do
2084 gg <- sequence gs
2085 lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
2086 return (Just lam)
2087 -- traverse f = \x -> case x of (a1,a2,..) ->
2088 -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
2089 , ft_ty_app = \_ g -> fmap (nlHsApp traverse_Expr) <$> g
2090 -- traverse f = traverse g
2091 , ft_forall = \_ g -> g
2092 , ft_co_var = panic "contravariant"
2093 , ft_fun = panic "function"
2094 , ft_bad_app = panic "in other argument" }
2095
2096 -- Con a1 a2 ... -> fmap (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)
2097 -- <*> g2 a2 <*> ...
2098 match_for_con :: [LPat RdrName]
2099 -> DataCon
2100 -> [Maybe (LHsExpr RdrName)]
2101 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
2102 match_for_con = mkSimpleConMatch2 CaseAlt $
2103 \con xs -> return (mkApCon con xs)
2104 where
2105 -- fmap (\b1 b2 ... -> Con b1 b2 ...) x1 <*> x2 <*> ..
2106 mkApCon :: LHsExpr RdrName -> [LHsExpr RdrName] -> LHsExpr RdrName
2107 mkApCon con [] = nlHsApps pure_RDR [con]
2108 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
2109 where appAp x y = nlHsApps ap_RDR [x,y]
2110
2111 {-
2112 ************************************************************************
2113 * *
2114 Lift instances
2115 * *
2116 ************************************************************************
2117
2118 Example:
2119
2120 data Foo a = Foo a | a :^: a deriving Lift
2121
2122 ==>
2123
2124 instance (Lift a) => Lift (Foo a) where
2125 lift (Foo a)
2126 = appE
2127 (conE
2128 (mkNameG_d "package-name" "ModuleName" "Foo"))
2129 (lift a)
2130 lift (u :^: v)
2131 = infixApp
2132 (lift u)
2133 (conE
2134 (mkNameG_d "package-name" "ModuleName" ":^:"))
2135 (lift v)
2136
2137 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
2138 'Foo would be when using the -XTemplateHaskell extension. To make sure that
2139 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
2140 makeG_d.
2141 -}
2142
2143 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
2144 gen_Lift_binds loc tycon
2145 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
2146 [mkMatch (FunRhs (L loc lift_RDR) Prefix)
2147 [nlWildPat] errorMsg_Expr
2148 (noLoc emptyLocalBinds)])
2149 , emptyBag)
2150 | otherwise = (unitBag lift_bind, emptyBag)
2151 where
2152 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
2153 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
2154
2155 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
2156 data_cons = tyConDataCons tycon
2157 tycon_str = occNameString . nameOccName . tyConName $ tycon
2158
2159 pats_etc data_con
2160 = ([con_pat], lift_Expr)
2161 where
2162 con_pat = nlConVarPat data_con_RDR as_needed
2163 data_con_RDR = getRdrName data_con
2164 con_arity = dataConSourceArity data_con
2165 as_needed = take con_arity as_RDRs
2166 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
2167 tys_needed as_needed
2168 tycon_name = tyConName tycon
2169 is_infix = dataConIsInfix data_con
2170 tys_needed = dataConOrigArgTys data_con
2171
2172 mk_lift_app ty a
2173 | not (isUnliftedType ty) = nlHsApp (nlHsVar lift_RDR)
2174 (nlHsVar a)
2175 | otherwise = nlHsApp (nlHsVar litE_RDR)
2176 (primLitOp (mkBoxExp (nlHsVar a)))
2177 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
2178
2179 pkg_name = unitIdString . moduleUnitId
2180 . nameModule $ tycon_name
2181 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
2182 con_name = occNameString . nameOccName . dataConName $ data_con
2183
2184 conE_Expr = nlHsApp (nlHsVar conE_RDR)
2185 (nlHsApps mkNameG_dRDR
2186 (map (nlHsLit . mkHsString)
2187 [pkg_name, mod_name, con_name]))
2188
2189 lift_Expr
2190 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
2191 | otherwise = foldl mk_appE_app conE_Expr lifted_as
2192 (a1:a2:_) = lifted_as
2193
2194 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2195 mk_appE_app a b = nlHsApps appE_RDR [a, b]
2196
2197 {-
2198 ************************************************************************
2199 * *
2200 Newtype-deriving instances
2201 * *
2202 ************************************************************************
2203
2204 Note [Newtype-deriving instances]
2205 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2206 We take every method in the original instance and `coerce` it to fit
2207 into the derived instance. We need a type annotation on the argument
2208 to `coerce` to make it obvious what instantiation of the method we're
2209 coercing from. So from, say,
2210 class C a b where
2211 op :: a -> [b] -> Int
2212
2213 newtype T x = MkT <rep-ty>
2214
2215 instance C a <rep-ty> => C a (T x) where
2216 op = (coerce
2217 (op :: a -> [<rep-ty>] -> Int)
2218 ) :: a -> [T x] -> Int
2219
2220 Notice that we give the 'coerce' call two type signatures: one to
2221 fix the type of the inner call, and one for the expected type. The outer
2222 type signature ought to be redundant, but may improve error messages.
2223 The inner one is essential to fix the type at which 'op' is called.
2224
2225 See #8503 for more discussion.
2226
2227 Here's a wrinkle. Supppose 'op' is locally overloaded:
2228
2229 class C2 b where
2230 op2 :: forall a. Eq a => a -> [b] -> Int
2231
2232 Then we could do exactly as above, but it's a bit redundant to
2233 instantiate op, then re-generalise with the inner signature.
2234 (The inner sig is only there to fix the type at which 'op' is
2235 called.) So we just instantiate the signature, and add
2236
2237 instance C2 <rep-ty> => C2 (T x) where
2238 op2 = (coerce
2239 (op2 :: a -> [<rep-ty>] -> Int)
2240 ) :: forall a. Eq a => a -> [T x] -> Int
2241 -}
2242
2243 gen_Newtype_binds :: SrcSpan
2244 -> Class -- the class being derived
2245 -> [TyVar] -- the tvs in the instance head
2246 -> [Type] -- instance head parameters (incl. newtype)
2247 -> Type -- the representation type (already eta-reduced)
2248 -> LHsBinds RdrName
2249 -- See Note [Newtype-deriving instances]
2250 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
2251 = listToBag $ map mk_bind (classMethods cls)
2252 where
2253 coerce_RDR = getRdrName coerceId
2254
2255 mk_bind :: Id -> LHsBind RdrName
2256 mk_bind meth_id
2257 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch
2258 (FunRhs (L loc meth_RDR) Prefix)
2259 [] rhs_expr]
2260 where
2261 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty meth_id
2262
2263 -- See "wrinkle" in Note [Newtype-deriving instances]
2264 (_, _, from_ty') = tcSplitSigmaTy from_ty
2265
2266 meth_RDR = getRdrName meth_id
2267
2268 rhs_expr = ( nlHsVar coerce_RDR
2269 `nlHsApp`
2270 (nlHsVar meth_RDR `nlExprWithTySig` toLHsSigWcType from_ty'))
2271 `nlExprWithTySig` toLHsSigWcType to_ty
2272
2273
2274 nlExprWithTySig :: LHsExpr RdrName -> LHsSigWcType RdrName -> LHsExpr RdrName
2275 nlExprWithTySig e s = noLoc (ExprWithTySig e s)
2276
2277 mkCoerceClassMethEqn :: Class -- the class being derived
2278 -> [TyVar] -- the tvs in the instance head
2279 -> [Type] -- instance head parameters (incl. newtype)
2280 -> Type -- the representation type (already eta-reduced)
2281 -> Id -- the method to look at
2282 -> Pair Type
2283 -- See Note [Newtype-deriving instances]
2284 -- The pair is the (from_type, to_type), where to_type is
2285 -- the type of the method we are tyrying to get
2286 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
2287 = Pair (substTy rhs_subst user_meth_ty)
2288 (substTy lhs_subst user_meth_ty)
2289 where
2290 cls_tvs = classTyVars cls
2291 in_scope = mkInScopeSet $ mkVarSet inst_tvs
2292 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
2293 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
2294 (_class_tvs, _class_constraint, user_meth_ty)
2295 = tcSplitMethodTy (varType id)
2296
2297 changeLast :: [a] -> a -> [a]
2298 changeLast [] _ = panic "changeLast"
2299 changeLast [_] x = [x]
2300 changeLast (x:xs) x' = x : changeLast xs x'
2301
2302 {-
2303 ************************************************************************
2304 * *
2305 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
2306 * *
2307 ************************************************************************
2308
2309 \begin{verbatim}
2310 data Foo ... = ...
2311
2312 con2tag_Foo :: Foo ... -> Int#
2313 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2314 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2315 \end{verbatim}
2316
2317 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2318 fiddling around.
2319 -}
2320
2321 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
2322 genAuxBindSpec loc (DerivCon2Tag tycon)
2323 = (mk_FunBind loc rdr_name eqns,
2324 L loc (TypeSig [L loc rdr_name] sig_ty))
2325 where
2326 rdr_name = con2tag_RDR tycon
2327
2328 sig_ty = mkLHsSigWcType $ L loc $ HsCoreTy $
2329 mkSpecSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
2330 mkParentType tycon `mkFunTy` intPrimTy
2331
2332 lots_of_constructors = tyConFamilySize tycon > 8
2333 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
2334 -- but we don't do vectored returns any more.
2335
2336 eqns | lots_of_constructors = [get_tag_eqn]
2337 | otherwise = map mk_eqn (tyConDataCons tycon)
2338
2339 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
2340
2341 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
2342 mk_eqn con = ([nlWildConPat con],
2343 nlHsLit (HsIntPrim ""
2344 (toInteger ((dataConTag con) - fIRST_TAG))))
2345
2346 genAuxBindSpec loc (DerivTag2Con tycon)
2347 = (mk_FunBind loc rdr_name
2348 [([nlConVarPat intDataCon_RDR [a_RDR]],
2349 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2350 L loc (TypeSig [L loc rdr_name] sig_ty))
2351 where
2352 sig_ty = mkLHsSigWcType $ L loc $
2353 HsCoreTy $ mkSpecForAllTys (tyConTyVars tycon) $
2354 intTy `mkFunTy` mkParentType tycon
2355
2356 rdr_name = tag2con_RDR tycon
2357
2358 genAuxBindSpec loc (DerivMaxTag tycon)
2359 = (mkHsVarBind loc rdr_name rhs,
2360 L loc (TypeSig [L loc rdr_name] sig_ty))
2361 where
2362 rdr_name = maxtag_RDR tycon
2363 sig_ty = mkLHsSigWcType (L loc (HsCoreTy intTy))
2364 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2365 max_tag = case (tyConDataCons tycon) of
2366 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2367
2368 type SeparateBagsDerivStuff =
2369 -- AuxBinds and SYB bindings
2370 ( Bag (LHsBind RdrName, LSig RdrName)
2371 -- Extra family instances (used by Generic and DeriveAnyClass)
2372 , Bag (FamInst) )
2373
2374 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2375 genAuxBinds loc b = genAuxBinds' b2 where
2376 (b1,b2) = partitionBagWith splitDerivAuxBind b
2377 splitDerivAuxBind (DerivAuxBind x) = Left x
2378 splitDerivAuxBind x = Right x
2379
2380 rm_dups = foldrBag dup_check emptyBag
2381 dup_check a b = if anyBag (== a) b then b else consBag a b
2382
2383 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2384 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2385 , emptyBag )
2386 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2387 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2388 f (DerivHsBind b) = add1 b
2389 f (DerivFamInst t) = add2 t
2390
2391 add1 x (a,b) = (x `consBag` a,b)
2392 add2 x (a,b) = (a,x `consBag` b)
2393
2394 mkParentType :: TyCon -> Type
2395 -- Turn the representation tycon of a family into
2396 -- a use of its family constructor
2397 mkParentType tc
2398 = case tyConFamInst_maybe tc of
2399 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2400 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2401
2402 {-
2403 ************************************************************************
2404 * *
2405 \subsection{Utility bits for generating bindings}
2406 * *
2407 ************************************************************************
2408 -}
2409
2410 mk_FunBind :: SrcSpan -> RdrName
2411 -> [([LPat RdrName], LHsExpr RdrName)]
2412 -> LHsBind RdrName
2413 mk_FunBind = mk_HRFunBind 0 -- by using mk_FunBind and not mk_HRFunBind,
2414 -- the caller says that the Void case needs no
2415 -- patterns
2416
2417 -- | This variant of 'mk_FunBind' puts an 'Arity' number of wildcards before
2418 -- the "=" in the empty-data-decl case. This is necessary if the function
2419 -- has a higher-rank type, like foldl. (See deriving/should_compile/T4302)
2420 mk_HRFunBind :: Arity -> SrcSpan -> RdrName
2421 -> [([LPat RdrName], LHsExpr RdrName)]
2422 -> LHsBind RdrName
2423 mk_HRFunBind arity loc fun pats_and_exprs
2424 = mkHRRdrFunBind arity (L loc fun) matches
2425 where
2426 matches = [mkMatch (FunRhs (L loc fun) Prefix) p e
2427 (noLoc emptyLocalBinds)
2428 | (p,e) <-pats_and_exprs]
2429
2430 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2431 mkRdrFunBind = mkHRRdrFunBind 0
2432
2433 mkHRRdrFunBind :: Arity -> Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2434 mkHRRdrFunBind arity fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2435 where
2436 -- Catch-all eqn looks like
2437 -- fmap = error "Void fmap"
2438 -- It's needed if there no data cons at all,
2439 -- which can happen with -XEmptyDataDecls
2440 -- See Trac #4302
2441 matches' = if null matches
2442 then [mkMatch (FunRhs fun Prefix)
2443 (replicate arity nlWildPat)
2444 (error_Expr str) (noLoc emptyLocalBinds)]
2445 else matches
2446 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2447
2448 box :: String -- The class involved
2449 -> TyCon -- The tycon involved
2450 -> LHsExpr RdrName -- The argument
2451 -> Type -- The argument type
2452 -> LHsExpr RdrName -- Boxed version of the arg
2453 -- See Note [Deriving and unboxed types] in TcDeriv
2454 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2455 where
2456 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2457
2458 ---------------------
2459 primOrdOps :: String -- The class involved
2460 -> TyCon -- The tycon involved
2461 -> Type -- The type
2462 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2463 -- See Note [Deriving and unboxed types] in TcDeriv
2464 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2465
2466 primLitOps :: String -- The class involved
2467 -> TyCon -- The tycon involved
2468 -> Type -- The type
2469 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
2470 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
2471 )
2472 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2473 , \v -> nlHsVar boxRDR `nlHsApp` v
2474 )
2475 where
2476 boxRDR
2477 | ty `eqType` addrPrimTy = unpackCString_RDR
2478 | otherwise = assoc_ty_id str tycon boxConTbl ty
2479
2480 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2481 ordOpTbl
2482 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2483 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2484 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2485 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2486 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2487 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2488
2489 boxConTbl :: [(Type, RdrName)]
2490 boxConTbl
2491 = [(charPrimTy , getRdrName charDataCon )
2492 ,(intPrimTy , getRdrName intDataCon )
2493 ,(wordPrimTy , getRdrName wordDataCon )
2494 ,(floatPrimTy , getRdrName floatDataCon )
2495 ,(doublePrimTy, getRdrName doubleDataCon)
2496 ]
2497
2498 -- | A table of postfix modifiers for unboxed values.
2499 postfixModTbl :: [(Type, String)]
2500 postfixModTbl
2501 = [(charPrimTy , "#" )
2502 ,(intPrimTy , "#" )
2503 ,(wordPrimTy , "##")
2504 ,(floatPrimTy , "#" )
2505 ,(doublePrimTy, "##")
2506 ]
2507
2508 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
2509 litConTbl
2510 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2511 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2512 . nlHsApp (nlHsVar toInteger_RDR))
2513 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2514 . nlHsApp (nlHsVar toInteger_RDR))
2515 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2516 . nlHsApp (nlHsApp
2517 (nlHsVar map_RDR)
2518 (compose_RDR `nlHsApps`
2519 [ nlHsVar fromIntegral_RDR
2520 , nlHsVar fromEnum_RDR
2521 ])))
2522 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2523 . nlHsApp (nlHsVar toRational_RDR))
2524 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2525 . nlHsApp (nlHsVar toRational_RDR))
2526 ]
2527
2528 -- | Lookup `Type` in an association list.
2529 assoc_ty_id :: String -- The class involved
2530 -> TyCon -- The tycon involved
2531 -> [(Type,a)] -- The table
2532 -> Type -- The type
2533 -> a -- The result of the lookup
2534 assoc_ty_id cls_str _ tbl ty
2535 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2536 text "for primitive type" <+> ppr ty)
2537 | otherwise = head res
2538 where
2539 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2540
2541 -----------------------------------------------------------------------
2542
2543 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2544 and_Expr a b = genOpApp a and_RDR b
2545
2546 -----------------------------------------------------------------------
2547
2548 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2549 eq_Expr tycon ty a b
2550 | not (isUnliftedType ty) = genOpApp a eq_RDR b
2551 | otherwise = genPrimOpApp a prim_eq b
2552 where
2553 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2554
2555 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2556 untag_Expr _ [] expr = expr
2557 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2558 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2559 [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2560
2561 enum_from_to_Expr
2562 :: LHsExpr RdrName -> LHsExpr RdrName
2563 -> LHsExpr RdrName
2564 enum_from_then_to_Expr
2565 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2566 -> LHsExpr RdrName
2567
2568 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2569 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2570
2571 showParen_Expr
2572 :: LHsExpr RdrName -> LHsExpr RdrName
2573 -> LHsExpr RdrName
2574
2575 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2576
2577 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2578
2579 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2580 nested_compose_Expr [e] = parenify e
2581 nested_compose_Expr (e:es)
2582 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2583
2584 -- impossible_Expr is used in case RHSs that should never happen.
2585 -- We generate these to keep the desugarer from complaining that they *might* happen!
2586 error_Expr :: String -> LHsExpr RdrName
2587 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2588
2589 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2590 -- method. It is currently only used by Enum.{succ,pred}
2591 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2592 illegal_Expr meth tp msg =
2593 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2594
2595 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2596 -- to include the value of a_RDR in the error string.
2597 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2598 illegal_toEnum_tag tp maxtag =
2599 nlHsApp (nlHsVar error_RDR)
2600 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2601 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2602 (nlHsApp (nlHsApp (nlHsApp
2603 (nlHsVar showsPrec_RDR)
2604 (nlHsIntLit 0))
2605 (nlHsVar a_RDR))
2606 (nlHsApp (nlHsApp
2607 (nlHsVar append_RDR)
2608 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2609 (nlHsApp (nlHsApp (nlHsApp
2610 (nlHsVar showsPrec_RDR)
2611 (nlHsIntLit 0))
2612 (nlHsVar maxtag))
2613 (nlHsLit (mkHsString ")"))))))
2614
2615 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2616 parenify e@(L _ (HsVar _)) = e
2617 parenify e = mkHsPar e
2618
2619 -- genOpApp wraps brackets round the operator application, so that the
2620 -- renamer won't subsequently try to re-associate it.
2621 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2622 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2623
2624 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2625 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2626
2627 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2628 :: RdrName
2629 a_RDR = mkVarUnqual (fsLit "a")
2630 b_RDR = mkVarUnqual (fsLit "b")
2631 c_RDR = mkVarUnqual (fsLit "c")
2632 d_RDR = mkVarUnqual (fsLit "d")
2633 f_RDR = mkVarUnqual (fsLit "f")
2634 k_RDR = mkVarUnqual (fsLit "k")
2635 z_RDR = mkVarUnqual (fsLit "z")
2636 ah_RDR = mkVarUnqual (fsLit "a#")
2637 bh_RDR = mkVarUnqual (fsLit "b#")
2638 ch_RDR = mkVarUnqual (fsLit "c#")
2639 dh_RDR = mkVarUnqual (fsLit "d#")
2640
2641 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2642 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2643 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2644 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2645
2646 a_Expr, b_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2647 false_Expr, true_Expr, fmap_Expr,
2648 mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2649 a_Expr = nlHsVar a_RDR
2650 b_Expr = nlHsVar b_RDR
2651 c_Expr = nlHsVar c_RDR
2652 f_Expr = nlHsVar f_RDR
2653 z_Expr = nlHsVar z_RDR
2654 ltTag_Expr = nlHsVar ltTag_RDR
2655 eqTag_Expr = nlHsVar eqTag_RDR
2656 gtTag_Expr = nlHsVar gtTag_RDR
2657 false_Expr = nlHsVar false_RDR
2658 true_Expr = nlHsVar true_RDR
2659 fmap_Expr = nlHsVar fmap_RDR
2660 -- pure_Expr = nlHsVar pure_RDR
2661 mempty_Expr = nlHsVar mempty_RDR
2662 foldMap_Expr = nlHsVar foldMap_RDR
2663 traverse_Expr = nlHsVar traverse_RDR
2664
2665 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2666 a_Pat = nlVarPat a_RDR
2667 b_Pat = nlVarPat b_RDR
2668 c_Pat = nlVarPat c_RDR
2669 d_Pat = nlVarPat d_RDR
2670 f_Pat = nlVarPat f_RDR
2671 k_Pat = nlVarPat k_RDR
2672 z_Pat = nlVarPat z_RDR
2673
2674 minusInt_RDR, tagToEnum_RDR :: RdrName
2675 minusInt_RDR = getRdrName (primOpId IntSubOp )
2676 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2677
2678 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2679 -- Generates Orig s RdrName, for the binding positions
2680 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2681 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2682 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2683
2684 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2685 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2686
2687 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2688 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2689 -- See Note [Auxiliary binders]
2690 mkAuxBinderName parent occ_fun
2691 = mkRdrUnqual (occ_fun stable_parent_occ)
2692 where
2693 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2694 stable_string
2695 | opt_PprStyle_Debug = parent_stable
2696 | otherwise = parent_stable_hash
2697 parent_stable = nameStableString parent
2698 parent_stable_hash =
2699 let Fingerprint high low = fingerprintString parent_stable
2700 in toBase62 high ++ toBase62Padded low
2701 -- See Note [Base 62 encoding 128-bit integers]
2702 parent_occ = nameOccName parent
2703
2704
2705 {-
2706 Note [Auxiliary binders]
2707 ~~~~~~~~~~~~~~~~~~~~~~~~
2708 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2709
2710 instance Ord T where
2711 compare a b = $con2tag a `compare` $con2tag b
2712
2713 $con2tag :: T -> Int
2714 $con2tag = ...code....
2715
2716 Of course these top-level bindings should all have distinct name, and we are
2717 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2718 because with standalone deriving two imported TyCons might both be called T!
2719 (See Trac #7947.)
2720
2721 So we use package name, module name and the name of the parent
2722 (T in this example) as part of the OccName we generate for the new binding.
2723 To make the symbol names short we take a base62 hash of the full name.
2724
2725 In the past we used the *unique* from the parent, but that's not stable across
2726 recompilations as uniques are nondeterministic.
2727
2728 Note [DeriveFoldable with ExistentialQuantification]
2729 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2730 Functor and Traversable instances can only be derived for data types whose
2731 last type parameter is truly universally polymorphic. For example:
2732
2733 data T a b where
2734 T1 :: b -> T a b -- YES, b is unconstrained
2735 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
2736 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
2737 T4 :: Int -> T a Int -- NO, this is just like T3
2738 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
2739 -- though a is existential
2740 T6 :: Int -> T Int b -- YES, b is unconstrained
2741
2742 For Foldable instances, however, we can completely lift the constraint that
2743 the last type parameter be truly universally polymorphic. This means that T
2744 (as defined above) can have a derived Foldable instance:
2745
2746 instance Foldable (T a) where
2747 foldr f z (T1 b) = f b z
2748 foldr f z (T2 b) = f b z
2749 foldr f z (T3 b) = f b z
2750 foldr f z (T4 b) = z
2751 foldr f z (T5 a b) = f b z
2752 foldr f z (T6 a) = z
2753
2754 foldMap f (T1 b) = f b
2755 foldMap f (T2 b) = f b
2756 foldMap f (T3 b) = f b
2757 foldMap f (T4 b) = mempty
2758 foldMap f (T5 a b) = f b
2759 foldMap f (T6 a) = mempty
2760
2761 In a Foldable instance, it is safe to fold over an occurrence of the last type
2762 parameter that is not truly universally polymorphic. However, there is a bit
2763 of subtlety in determining what is actually an occurrence of a type parameter.
2764 T3 and T4, as defined above, provide one example:
2765
2766 data T a b where
2767 ...
2768 T3 :: b ~ Int => b -> T a b
2769 T4 :: Int -> T a Int
2770 ...
2771
2772 instance Foldable (T a) where
2773 ...
2774 foldr f z (T3 b) = f b z
2775 foldr f z (T4 b) = z
2776 ...
2777 foldMap f (T3 b) = f b
2778 foldMap f (T4 b) = mempty
2779 ...
2780
2781 Notice that the argument of T3 is folded over, whereas the argument of T4 is
2782 not. This is because we only fold over constructor arguments that
2783 syntactically mention the universally quantified type parameter of that
2784 particular data constructor. See foldDataConArgs for how this is implemented.
2785
2786 As another example, consider the following data type. The argument of each
2787 constructor has the same type as the last type parameter:
2788
2789 data E a where
2790 E1 :: (a ~ Int) => a -> E a
2791 E2 :: Int -> E Int
2792 E3 :: (a ~ Int) => a -> E Int
2793 E4 :: (a ~ Int) => Int -> E a
2794
2795 Only E1's argument is an occurrence of a universally quantified type variable
2796 that is syntactically equivalent to the last type parameter, so only E1's
2797 argument will be be folded over in a derived Foldable instance.
2798
2799 See Trac #10447 for the original discussion on this feature. Also see
2800 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
2801 for a more in-depth explanation.
2802
2803 Note [FFoldType and functorLikeTraverse]
2804 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2805 Deriving Functor, Foldable, and Traversable all require generating expressions
2806 which perform an operation on each argument of a data constructor depending
2807 on the argument's type. In particular, a generated operation can be different
2808 depending on whether the type mentions the last type variable of the datatype
2809 (e.g., if you have data T a = MkT a Int, then a generated foldr expresion would
2810 fold over the first argument of MkT, but not the second).
2811
2812 This pattern is abstracted with the FFoldType datatype, which provides hooks
2813 for the user to specify how a constructor argument should be folded when it
2814 has a type with a particular "shape". The shapes are as follows (assume that
2815 a is the last type variable in a given datatype):
2816
2817 * ft_triv: The type does not mention the last type variable at all.
2818 Examples: Int, b
2819
2820 * ft_var: The type is syntactically equal to the last type variable.
2821 Moreover, the type appears in a covariant position (see
2822 the Deriving Functor instances section of the users' guide
2823 for an in-depth explanation of covariance vs. contravariance).
2824 Example: a (covariantly)
2825
2826 * ft_co_var: The type is syntactically equal to the last type variable.
2827 Moreover, the type appears in a contravariant position.
2828 Example: a (contravariantly)
2829
2830 * ft_fun: A function type which mentions the last type variable in
2831 the argument position, result position or both.
2832 Examples: a -> Int, Int -> a, Maybe a -> [a]
2833
2834 * ft_tup: A tuple type which mentions the last type variable in at least
2835 one of its fields. The TyCon argument of ft_tup represents the
2836 particular tuple's type constructor.
2837 Examples: (a, Int), (Maybe a, [a], Either a Int), (# Int, a #)
2838
2839 * ft_ty_app: A type is being applied to the last type parameter, where the
2840 applied type does not mention the last type parameter (if it
2841 did, it would fall under ft_bad_app). The Type argument to
2842 ft_ty_app represents the applied type.
2843
2844 Note that functions, tuples, and foralls are distinct cases
2845 and take precedence of ft_ty_app. (For example, (Int -> a) would
2846 fall under (ft_fun Int a), not (ft_ty_app ((->) Int) a).
2847 Examples: Maybe a, Either b a
2848
2849 * ft_bad_app: A type application uses the last type parameter in a position
2850 other than the last argument. This case is singled out because
2851 Functor, Foldable, and Traversable instances cannot be derived
2852 for datatypes containing arguments with such types.
2853 Examples: Either a Int, Const a b
2854
2855 * ft_forall: A forall'd type mentions the last type parameter on its right-
2856 hand side (and is not quantified on the left-hand side). This
2857 case is present mostly for plumbing purposes.
2858 Example: forall b. Either b a
2859
2860 If FFoldType describes a strategy for folding subcomponents of a Type, then
2861 functorLikeTraverse is the function that applies that strategy to the entirety
2862 of a Type, returning the final folded-up result.
2863
2864 foldDataConArgs applies functorLikeTraverse to every argument type of a
2865 constructor, returning a list of the fold results. This makes foldDataConArgs
2866 a natural way to generate the subexpressions in a generated fmap, foldr,
2867 foldMap, or traverse definition (the subexpressions must then be combined in
2868 a method-specific fashion to form the final generated expression).
2869
2870 Deriving Generic1 also does validity checking by looking for the last type
2871 variable in certain positions of a constructor's argument types, so it also
2872 uses foldDataConArgs. See Note [degenerate use of FFoldType] in TcGenGenerics.
2873
2874 Note [Generated code for DeriveFoldable and DeriveTraversable]
2875 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2876 We adapt the algorithms for -XDeriveFoldable and -XDeriveTraversable based on
2877 that of -XDeriveFunctor. However, there an important difference between deriving
2878 the former two typeclasses and the latter one, which is best illustrated by the
2879 following scenario:
2880
2881 data WithInt a = WithInt a Int# deriving (Functor, Foldable, Traversable)
2882
2883 The generated code for the Functor instance is straightforward:
2884
2885 instance Functor WithInt where
2886 fmap f (WithInt a i) = WithInt (f a) i
2887
2888 But if we use too similar of a strategy for deriving the Foldable and
2889 Traversable instances, we end up with this code:
2890
2891 instance Foldable WithInt where
2892 foldMap f (WithInt a i) = f a <> mempty
2893
2894 instance Traversable WithInt where
2895 traverse f (WithInt a i) = fmap WithInt (f a) <*> pure i
2896
2897 This is unsatisfying for two reasons:
2898
2899 1. The Traversable instance doesn't typecheck! Int# is of kind #, but pure
2900 expects an argument whose type is of kind *. This effectively prevents
2901 Traversable from being derived for any datatype with an unlifted argument
2902 type (Trac #11174).
2903
2904 2. The generated code contains superfluous expressions. By the Monoid laws,
2905 we can reduce (f a <> mempty) to (f a), and by the Applicative laws, we can
2906 reduce (fmap WithInt (f a) <*> pure i) to (fmap (\b -> WithInt b i) (f a)).
2907
2908 We can fix both of these issues by incorporating a slight twist to the usual
2909 algorithm that we use for -XDeriveFunctor. The differences can be summarized
2910 as follows:
2911
2912 1. In the generated expression, we only fold over arguments whose types
2913 mention the last type parameter. Any other argument types will simply
2914 produce useless 'mempty's or 'pure's, so they can be safely ignored.
2915
2916 2. In the case of -XDeriveTraversable, instead of applying ConName,
2917 we apply (\b_i ... b_k -> ConName a_1 ... a_n), where
2918
2919 * ConName has n arguments
2920 * {b_i, ..., b_k} is a subset of {a_1, ..., a_n} whose indices correspond
2921 to the arguments whose types mention the last type parameter. As a
2922 consequence, taking the difference of {a_1, ..., a_n} and
2923 {b_i, ..., b_k} yields the all the argument values of ConName whose types
2924 do not mention the last type parameter. Note that [i, ..., k] is a
2925 strictly increasing—but not necessarily consecutive—integer sequence.
2926
2927 For example, the datatype
2928
2929 data Foo a = Foo Int a Int a
2930
2931 would generate the following Traversable instance:
2932
2933 instance Traversable Foo where
2934 traverse f (Foo a1 a2 a3 a4) =
2935 fmap (\b2 b4 -> Foo a1 b2 a3 b4) (f a2) <*> f a4
2936
2937 Technically, this approach would also work for -XDeriveFunctor as well, but we
2938 decide not to do so because:
2939
2940 1. There's not much benefit to generating, e.g., ((\b -> WithInt b i) (f a))
2941 instead of (WithInt (f a) i).
2942
2943 2. There would be certain datatypes for which the above strategy would
2944 generate Functor code that would fail to typecheck. For example:
2945
2946 data Bar f a = Bar (forall f. Functor f => f a) deriving Functor
2947
2948 With the conventional algorithm, it would generate something like:
2949
2950 fmap f (Bar a) = Bar (fmap f a)
2951
2952 which typechecks. But with the strategy mentioned above, it would generate:
2953
2954 fmap f (Bar a) = (\b -> Bar b) (fmap f a)
2955
2956 which does not typecheck, since GHC cannot unify the rank-2 type variables
2957 in the types of b and (fmap f a).
2958 -}