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