Implement DuplicateRecordFields
[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 = map flLabel $ 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 = unpackFS 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 = map flLabel $ 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 nm = wrapOpParens (unpackFS l)
1177
1178 show_args = zipWith show_arg bs_needed arg_tys
1179 (show_arg1:show_arg2:_) = show_args
1180 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1181
1182 -- Assumption for record syntax: no of fields == no of
1183 -- labelled fields (and in same order)
1184 show_record_args = concat $
1185 intersperse [mk_showString_app ", "] $
1186 [ [show_label lbl, arg]
1187 | (lbl,arg) <- zipEqual "gen_Show_binds"
1188 labels show_args ]
1189
1190 show_arg :: RdrName -> Type -> LHsExpr RdrName
1191 show_arg b arg_ty
1192 | isUnLiftedType arg_ty
1193 -- See Note [Deriving and unboxed types] in TcDeriv
1194 = nlHsApps compose_RDR [mk_shows_app boxed_arg,
1195 mk_showString_app postfixMod]
1196 | otherwise
1197 = mk_showsPrec_app arg_prec arg
1198 where
1199 arg = nlHsVar b
1200 boxed_arg = box "Show" tycon arg arg_ty
1201 postfixMod = assoc_ty_id "Show" tycon postfixModTbl arg_ty
1202
1203 -- Fixity stuff
1204 is_infix = dataConIsInfix data_con
1205 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1206 arg_prec | record_syntax = 0 -- Record fields don't need parens
1207 | otherwise = con_prec_plus_one
1208
1209 wrapOpParens :: String -> String
1210 wrapOpParens s | isSym s = '(' : s ++ ")"
1211 | otherwise = s
1212
1213 wrapOpBackquotes :: String -> String
1214 wrapOpBackquotes s | isSym s = s
1215 | otherwise = '`' : s ++ "`"
1216
1217 isSym :: String -> Bool
1218 isSym "" = False
1219 isSym (c : _) = startsVarSym c || startsConSym c
1220
1221 -- | showString :: String -> ShowS
1222 mk_showString_app :: String -> LHsExpr RdrName
1223 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1224
1225 -- | showsPrec :: Show a => Int -> a -> ShowS
1226 mk_showsPrec_app :: Integer -> LHsExpr RdrName -> LHsExpr RdrName
1227 mk_showsPrec_app p x = nlHsApps showsPrec_RDR [nlHsLit (HsInt "" p), x]
1228
1229 -- | shows :: Show a => a -> ShowS
1230 mk_shows_app :: LHsExpr RdrName -> LHsExpr RdrName
1231 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1232
1233 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1234 getPrec is_infix get_fixity nm
1235 | not is_infix = appPrecedence
1236 | otherwise = getPrecedence get_fixity nm
1237
1238 appPrecedence :: Integer
1239 appPrecedence = fromIntegral maxPrecedence + 1
1240 -- One more than the precedence of the most
1241 -- tightly-binding operator
1242
1243 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1244 getPrecedence get_fixity nm
1245 = case get_fixity nm of
1246 Fixity x _assoc -> fromIntegral x
1247 -- NB: the Report says that associativity is not taken
1248 -- into account for either Read or Show; hence we
1249 -- ignore associativity here
1250
1251 {-
1252 ************************************************************************
1253 * *
1254 Data instances
1255 * *
1256 ************************************************************************
1257
1258 From the data type
1259
1260 data T a b = T1 a b | T2
1261
1262 we generate
1263
1264 $cT1 = mkDataCon $dT "T1" Prefix
1265 $cT2 = mkDataCon $dT "T2" Prefix
1266 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1267 -- the [] is for field labels.
1268
1269 instance (Data a, Data b) => Data (T a b) where
1270 gfoldl k z (T1 a b) = z T `k` a `k` b
1271 gfoldl k z T2 = z T2
1272 -- ToDo: add gmapT,Q,M, gfoldr
1273
1274 gunfold k z c = case conIndex c of
1275 I# 1# -> k (k (z T1))
1276 I# 2# -> z T2
1277
1278 toConstr (T1 _ _) = $cT1
1279 toConstr T2 = $cT2
1280
1281 dataTypeOf _ = $dT
1282
1283 dataCast1 = gcast1 -- If T :: * -> *
1284 dataCast2 = gcast2 -- if T :: * -> * -> *
1285 -}
1286
1287 gen_Data_binds :: DynFlags
1288 -> SrcSpan
1289 -> TyCon -- For data families, this is the
1290 -- *representation* TyCon
1291 -> (LHsBinds RdrName, -- The method bindings
1292 BagDerivStuff) -- Auxiliary bindings
1293 gen_Data_binds dflags loc rep_tc
1294 = (listToBag [gfoldl_bind, gunfold_bind, toCon_bind, dataTypeOf_bind]
1295 `unionBags` gcast_binds,
1296 -- Auxiliary definitions: the data type and constructors
1297 listToBag ( DerivHsBind (genDataTyCon)
1298 : map (DerivHsBind . genDataDataCon) data_cons))
1299 where
1300 data_cons = tyConDataCons rep_tc
1301 n_cons = length data_cons
1302 one_constr = n_cons == 1
1303
1304 genDataTyCon :: (LHsBind RdrName, LSig RdrName)
1305 genDataTyCon -- $dT
1306 = (mkHsVarBind loc rdr_name rhs,
1307 L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
1308 where
1309 rdr_name = mk_data_type_name rep_tc
1310 sig_ty = nlHsTyVar dataType_RDR
1311 constrs = [nlHsVar (mk_constr_name con) | con <- tyConDataCons rep_tc]
1312 rhs = nlHsVar mkDataType_RDR
1313 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine dflags (ppr rep_tc)))
1314 `nlHsApp` nlList constrs
1315
1316 genDataDataCon :: DataCon -> (LHsBind RdrName, LSig RdrName)
1317 genDataDataCon dc -- $cT1 etc
1318 = (mkHsVarBind loc rdr_name rhs,
1319 L loc (TypeSig [L loc rdr_name] sig_ty PlaceHolder))
1320 where
1321 rdr_name = mk_constr_name dc
1322 sig_ty = nlHsTyVar constr_RDR
1323 rhs = nlHsApps mkConstr_RDR constr_args
1324
1325 constr_args
1326 = [ -- nlHsIntLit (toInteger (dataConTag dc)), -- Tag
1327 nlHsVar (mk_data_type_name (dataConTyCon dc)), -- DataType
1328 nlHsLit (mkHsString (occNameString dc_occ)), -- String name
1329 nlList labels, -- Field labels
1330 nlHsVar fixity] -- Fixity
1331
1332 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
1333 (dataConFieldLabels dc)
1334 dc_occ = getOccName dc
1335 is_infix = isDataSymOcc dc_occ
1336 fixity | is_infix = infix_RDR
1337 | otherwise = prefix_RDR
1338
1339 ------------ gfoldl
1340 gfoldl_bind = mk_FunBind loc gfoldl_RDR (map gfoldl_eqn data_cons)
1341
1342 gfoldl_eqn con
1343 = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed],
1344 foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed)
1345 where
1346 con_name :: RdrName
1347 con_name = getRdrName con
1348 as_needed = take (dataConSourceArity con) as_RDRs
1349 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1350
1351 ------------ gunfold
1352 gunfold_bind = mk_FunBind loc
1353 gunfold_RDR
1354 [([k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat],
1355 gunfold_rhs)]
1356
1357 gunfold_rhs
1358 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1359 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1360 (map gunfold_alt data_cons)
1361
1362 gunfold_alt dc = mkSimpleHsAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1363 mk_unfold_rhs dc = foldr nlHsApp
1364 (nlHsVar z_RDR `nlHsApp` nlHsVar (getRdrName dc))
1365 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1366
1367 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1368 -- redundant test, and annoying warning
1369 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1370 | otherwise = nlConPat intDataCon_RDR
1371 [nlLitPat (HsIntPrim "" (toInteger tag))]
1372 where
1373 tag = dataConTag dc
1374
1375 ------------ toConstr
1376 toCon_bind = mk_FunBind loc toConstr_RDR (map to_con_eqn data_cons)
1377 to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc))
1378
1379 ------------ dataTypeOf
1380 dataTypeOf_bind = mk_easy_FunBind
1381 loc
1382 dataTypeOf_RDR
1383 [nlWildPat]
1384 (nlHsVar (mk_data_type_name rep_tc))
1385
1386 ------------ gcast1/2
1387 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1388 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1389 -- (or nothing if T has neither of these two types)
1390
1391 -- But care is needed for data families:
1392 -- If we have data family D a
1393 -- data instance D (a,b,c) = A | B deriving( Data )
1394 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1395 -- then we need dataCast1 x = gcast1 x
1396 -- because D :: * -> *
1397 -- even though rep_tc has kind * -> * -> * -> *
1398 -- Hence looking for the kind of fam_tc not rep_tc
1399 -- See Trac #4896
1400 tycon_kind = case tyConFamInst_maybe rep_tc of
1401 Just (fam_tc, _) -> tyConKind fam_tc
1402 Nothing -> tyConKind rep_tc
1403 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1404 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1405 | otherwise = emptyBag
1406 mk_gcast dataCast_RDR gcast_RDR
1407 = unitBag (mk_easy_FunBind loc dataCast_RDR [nlVarPat f_RDR]
1408 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1409
1410
1411 kind1, kind2 :: Kind
1412 kind1 = liftedTypeKind `mkArrowKind` liftedTypeKind
1413 kind2 = liftedTypeKind `mkArrowKind` kind1
1414
1415 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstr_RDR,
1416 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1417 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1418 constr_RDR, dataType_RDR,
1419 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1420 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1421 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1422 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1423 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1424 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR :: RdrName
1425 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1426 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1427 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1428 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1429 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1430 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1431 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1432 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1433 mkConstr_RDR = varQual_RDR gENERICS (fsLit "mkConstr")
1434 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1435 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1436 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1437 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1438 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1439 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1440
1441 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1442 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1443 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1444 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1445 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1446
1447 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1448 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1449 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1450 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1451 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1452
1453 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1454 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1455 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1456 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1457 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1458
1459 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1460 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1461 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1462 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1463 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1464
1465 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1466 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1467 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1468 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1469 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1470
1471 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1472 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1473 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1474 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1475 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1476
1477 {-
1478 ************************************************************************
1479 * *
1480 Functor instances
1481
1482 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1483
1484 * *
1485 ************************************************************************
1486
1487 For the data type:
1488
1489 data T a = T1 Int a | T2 (T a)
1490
1491 We generate the instance:
1492
1493 instance Functor T where
1494 fmap f (T1 b1 a) = T1 b1 (f a)
1495 fmap f (T2 ta) = T2 (fmap f ta)
1496
1497 Notice that we don't simply apply 'fmap' to the constructor arguments.
1498 Rather
1499 - Do nothing to an argument whose type doesn't mention 'a'
1500 - Apply 'f' to an argument of type 'a'
1501 - Apply 'fmap f' to other arguments
1502 That's why we have to recurse deeply into the constructor argument types,
1503 rather than just one level, as we typically do.
1504
1505 What about types with more than one type parameter? In general, we only
1506 derive Functor for the last position:
1507
1508 data S a b = S1 [b] | S2 (a, T a b)
1509 instance Functor (S a) where
1510 fmap f (S1 bs) = S1 (fmap f bs)
1511 fmap f (S2 (p,q)) = S2 (a, fmap f q)
1512
1513 However, we have special cases for
1514 - tuples
1515 - functions
1516
1517 More formally, we write the derivation of fmap code over type variable
1518 'a for type 'b as ($fmap 'a 'b). In this general notation the derived
1519 instance for T is:
1520
1521 instance Functor T where
1522 fmap f (T1 x1 x2) = T1 ($(fmap 'a 'b1) x1) ($(fmap 'a 'a) x2)
1523 fmap f (T2 x1) = T2 ($(fmap 'a '(T a)) x1)
1524
1525 $(fmap 'a 'b) = \x -> x -- when b does not contain a
1526 $(fmap 'a 'a) = f
1527 $(fmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(fmap 'a 'b1) x1, $(fmap 'a 'b2) x2)
1528 $(fmap 'a '(T b1 b2)) = fmap $(fmap 'a 'b2) -- when a only occurs in the last parameter, b2
1529 $(fmap 'a '(b -> c)) = \x b -> $(fmap 'a' 'c) (x ($(cofmap 'a 'b) b))
1530
1531 For functions, the type parameter 'a can occur in a contravariant position,
1532 which means we need to derive a function like:
1533
1534 cofmap :: (a -> b) -> (f b -> f a)
1535
1536 This is pretty much the same as $fmap, only without the $(cofmap 'a 'a) case:
1537
1538 $(cofmap 'a 'b) = \x -> x -- when b does not contain a
1539 $(cofmap 'a 'a) = error "type variable in contravariant position"
1540 $(cofmap 'a '(b1,b2)) = \x -> case x of (x1,x2) -> ($(cofmap 'a 'b1) x1, $(cofmap 'a 'b2) x2)
1541 $(cofmap 'a '[b]) = map $(cofmap 'a 'b)
1542 $(cofmap 'a '(T b1 b2)) = fmap $(cofmap 'a 'b2) -- when a only occurs in the last parameter, b2
1543 $(cofmap 'a '(b -> c)) = \x b -> $(cofmap 'a' 'c) (x ($(fmap 'a 'c) b))
1544
1545 Note that the code produced by $(fmap _ _) is always a higher order function,
1546 with type `(a -> b) -> (g a -> g b)` for some g. When we need to do pattern
1547 matching on the type, this means create a lambda function (see the (,) case above).
1548 The resulting code for fmap can look a bit weird, for example:
1549
1550 data X a = X (a,Int)
1551 -- generated instance
1552 instance Functor X where
1553 fmap f (X x) = (\y -> case y of (x1,x2) -> X (f x1, (\z -> z) x2)) x
1554
1555 The optimizer should be able to simplify this code by simple inlining.
1556
1557 An older version of the deriving code tried to avoid these applied
1558 lambda functions by producing a meta level function. But the function to
1559 be mapped, `f`, is a function on the code level, not on the meta level,
1560 so it was eta expanded to `\x -> [| f $x |]`. This resulted in too much eta expansion.
1561 It is better to produce too many lambdas than to eta expand, see ticket #7436.
1562 -}
1563
1564 gen_Functor_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1565 gen_Functor_binds loc tycon
1566 = (unitBag fmap_bind, emptyBag)
1567 where
1568 data_cons = tyConDataCons tycon
1569 fmap_bind = mkRdrFunBind (L loc fmap_RDR) eqns
1570
1571 fmap_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1572 where
1573 parts = sequence $ foldDataConArgs ft_fmap con
1574
1575 eqns | null data_cons = [mkSimpleMatch [nlWildPat, nlWildPat]
1576 (error_Expr "Void fmap")]
1577 | otherwise = map fmap_eqn data_cons
1578
1579 ft_fmap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1580 ft_fmap = FT { ft_triv = mkSimpleLam $ \x -> return x -- fmap f = \x -> x
1581 , ft_var = return f_Expr -- fmap f = f
1582 , ft_fun = \g h -> do -- fmap f = \x b -> h (x (g b))
1583 gg <- g
1584 hh <- h
1585 mkSimpleLam2 $ \x b -> return $ nlHsApp hh (nlHsApp x (nlHsApp gg b))
1586 , ft_tup = \t gs -> do -- fmap f = \x -> case x of (a1,a2,..) -> (g1 a1,g2 a2,..)
1587 gg <- sequence gs
1588 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1589 , ft_ty_app = \_ g -> nlHsApp fmap_Expr <$> g -- fmap f = fmap g
1590 , ft_forall = \_ g -> g
1591 , ft_bad_app = panic "in other argument"
1592 , ft_co_var = panic "contravariant" }
1593
1594 -- Con a1 a2 ... -> Con (f1 a1) (f2 a2) ...
1595 match_for_con :: [LPat RdrName] -> DataCon -> [LHsExpr RdrName]
1596 -> State [RdrName] (LMatch RdrName (LHsExpr RdrName))
1597 match_for_con = mkSimpleConMatch $
1598 \con_name xs -> return $ nlHsApps con_name xs -- Con x1 x2 ..
1599
1600 {-
1601 Utility functions related to Functor deriving.
1602
1603 Since several things use the same pattern of traversal, this is abstracted into functorLikeTraverse.
1604 This function works like a fold: it makes a value of type 'a' in a bottom up way.
1605 -}
1606
1607 -- Generic traversal for Functor deriving
1608 data FFoldType a -- Describes how to fold over a Type in a functor like way
1609 = FT { ft_triv :: a -- Does not contain variable
1610 , ft_var :: a -- The variable itself
1611 , ft_co_var :: a -- The variable itself, contravariantly
1612 , ft_fun :: a -> a -> a -- Function type
1613 , ft_tup :: TyCon -> [a] -> a -- Tuple type
1614 , ft_ty_app :: Type -> a -> a -- Type app, variable only in last argument
1615 , ft_bad_app :: a -- Type app, variable other than in last argument
1616 , ft_forall :: TcTyVar -> a -> a -- Forall type
1617 }
1618
1619 functorLikeTraverse :: forall a.
1620 TyVar -- ^ Variable to look for
1621 -> FFoldType a -- ^ How to fold
1622 -> Type -- ^ Type to process
1623 -> a
1624 functorLikeTraverse var (FT { ft_triv = caseTrivial, ft_var = caseVar
1625 , ft_co_var = caseCoVar, ft_fun = caseFun
1626 , ft_tup = caseTuple, ft_ty_app = caseTyApp
1627 , ft_bad_app = caseWrongArg, ft_forall = caseForAll })
1628 ty
1629 = fst (go False ty)
1630 where
1631 go :: Bool -- Covariant or contravariant context
1632 -> Type
1633 -> (a, Bool) -- (result of type a, does type contain var)
1634
1635 go co ty | Just ty' <- coreView ty = go co ty'
1636 go co (TyVarTy v) | v == var = (if co then caseCoVar else caseVar,True)
1637 go co (FunTy x y) | isPredTy x = go co y
1638 | xc || yc = (caseFun xr yr,True)
1639 where (xr,xc) = go (not co) x
1640 (yr,yc) = go co y
1641 go co (AppTy x y) | xc = (caseWrongArg, True)
1642 | yc = (caseTyApp x yr, True)
1643 where (_, xc) = go co x
1644 (yr,yc) = go co y
1645 go co ty@(TyConApp con args)
1646 | not (or xcs) = (caseTrivial, False) -- Variable does not occur
1647 -- At this point we know that xrs, xcs is not empty,
1648 -- and at least one xr is True
1649 | isTupleTyCon con = (caseTuple con xrs, True)
1650 | or (init xcs) = (caseWrongArg, True) -- T (..var..) ty
1651 | Just (fun_ty, _) <- splitAppTy_maybe ty -- T (..no var..) ty
1652 = (caseTyApp fun_ty (last xrs), True)
1653 | otherwise = (caseWrongArg, True) -- Non-decomposable (eg type function)
1654 where
1655 (xrs,xcs) = unzip (map (go co) args)
1656 go co (ForAllTy v x) | v /= var && xc = (caseForAll v xr,True)
1657 where (xr,xc) = go co x
1658 go _ _ = (caseTrivial,False)
1659
1660 -- Return all syntactic subterms of ty that contain var somewhere
1661 -- These are the things that should appear in instance constraints
1662 deepSubtypesContaining :: TyVar -> Type -> [TcType]
1663 deepSubtypesContaining tv
1664 = functorLikeTraverse tv
1665 (FT { ft_triv = []
1666 , ft_var = []
1667 , ft_fun = (++)
1668 , ft_tup = \_ xs -> concat xs
1669 , ft_ty_app = (:)
1670 , ft_bad_app = panic "in other argument"
1671 , ft_co_var = panic "contravariant"
1672 , ft_forall = \v xs -> filterOut ((v `elemVarSet`) . tyVarsOfType) xs })
1673
1674
1675 foldDataConArgs :: FFoldType a -> DataCon -> [a]
1676 -- Fold over the arguments of the datacon
1677 foldDataConArgs ft con
1678 = map foldArg (dataConOrigArgTys con)
1679 where
1680 foldArg
1681 = case getTyVar_maybe (last (tyConAppArgs (dataConOrigResTy con))) of
1682 Just tv -> functorLikeTraverse tv ft
1683 Nothing -> const (ft_triv ft)
1684 -- If we are deriving Foldable for a GADT, there is a chance that the last
1685 -- type variable in the data type isn't actually a type variable at all.
1686 -- (for example, this can happen if the last type variable is refined to
1687 -- be a concrete type such as Int). If the last type variable is refined
1688 -- to be a specific type, then getTyVar_maybe will return Nothing.
1689 -- See Note [DeriveFoldable with ExistentialQuantification]
1690 --
1691 -- The kind checks have ensured the last type parameter is of kind *.
1692
1693 -- Make a HsLam using a fresh variable from a State monad
1694 mkSimpleLam :: (LHsExpr RdrName -> State [RdrName] (LHsExpr RdrName))
1695 -> State [RdrName] (LHsExpr RdrName)
1696 -- (mkSimpleLam fn) returns (\x. fn(x))
1697 mkSimpleLam lam = do
1698 (n:names) <- get
1699 put names
1700 body <- lam (nlHsVar n)
1701 return (mkHsLam [nlVarPat n] body)
1702
1703 mkSimpleLam2 :: (LHsExpr RdrName -> LHsExpr RdrName
1704 -> State [RdrName] (LHsExpr RdrName))
1705 -> State [RdrName] (LHsExpr RdrName)
1706 mkSimpleLam2 lam = do
1707 (n1:n2:names) <- get
1708 put names
1709 body <- lam (nlHsVar n1) (nlHsVar n2)
1710 return (mkHsLam [nlVarPat n1,nlVarPat n2] body)
1711
1712 -- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"
1713 mkSimpleConMatch :: Monad m => (RdrName -> [LHsExpr RdrName] -> m (LHsExpr RdrName))
1714 -> [LPat RdrName]
1715 -> DataCon
1716 -> [LHsExpr RdrName]
1717 -> m (LMatch RdrName (LHsExpr RdrName))
1718 mkSimpleConMatch fold extra_pats con insides = do
1719 let con_name = getRdrName con
1720 let vars_needed = takeList insides as_RDRs
1721 let pat = nlConVarPat con_name vars_needed
1722 rhs <- fold con_name (zipWith nlHsApp insides (map nlHsVar vars_needed))
1723 return $ mkMatch (extra_pats ++ [pat]) rhs emptyLocalBinds
1724
1725 -- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"
1726 mkSimpleTupleCase :: Monad m => ([LPat RdrName] -> DataCon -> [a]
1727 -> m (LMatch RdrName (LHsExpr RdrName)))
1728 -> TyCon -> [a] -> LHsExpr RdrName -> m (LHsExpr RdrName)
1729 mkSimpleTupleCase match_for_con tc insides x
1730 = do { let data_con = tyConSingleDataCon tc
1731 ; match <- match_for_con [] data_con insides
1732 ; return $ nlHsCase x [match] }
1733
1734 {-
1735 ************************************************************************
1736 * *
1737 Foldable instances
1738
1739 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1740
1741 * *
1742 ************************************************************************
1743
1744 Deriving Foldable instances works the same way as Functor instances,
1745 only Foldable instances are not possible for function types at all.
1746 Here the derived instance for the type T above is:
1747
1748 instance Foldable T where
1749 foldr f z (T1 x1 x2 x3) = $(foldr 'a 'b1) x1 ( $(foldr 'a 'a) x2 ( $(foldr 'a 'b2) x3 z ) )
1750
1751 The cases are:
1752
1753 $(foldr 'a 'b) = \x z -> z -- when b does not contain a
1754 $(foldr 'a 'a) = f
1755 $(foldr 'a '(b1,b2)) = \x z -> case x of (x1,x2) -> $(foldr 'a 'b1) x1 ( $(foldr 'a 'b2) x2 z )
1756 $(foldr 'a '(T b1 b2)) = \x z -> foldr $(foldr 'a 'b2) z x -- when a only occurs in the last parameter, b2
1757
1758 Note that the arguments to the real foldr function are the wrong way around,
1759 since (f :: a -> b -> b), while (foldr f :: b -> t a -> b).
1760
1761 Foldable instances differ from Functor and Traversable instances in that
1762 Foldable instances can be derived for data types in which the last type
1763 variable is existentially quantified. In particular, if the last type variable
1764 is refined to a more specific type in a GADT:
1765
1766 data GADT a where
1767 G :: a ~ Int => a -> G Int
1768
1769 then the deriving machinery does not attempt to check that the type a contains
1770 Int, since it is not syntactically equal to a type variable. That is, the
1771 derived Foldable instance for GADT is:
1772
1773 instance Foldable GADT where
1774 foldr _ z (GADT _) = z
1775
1776 See Note [DeriveFoldable with ExistentialQuantification].
1777
1778 -}
1779
1780 gen_Foldable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1781 gen_Foldable_binds loc tycon
1782 = (listToBag [foldr_bind, foldMap_bind], emptyBag)
1783 where
1784 data_cons = tyConDataCons tycon
1785
1786 foldr_bind = mkRdrFunBind (L loc foldable_foldr_RDR) eqns
1787 eqns = map foldr_eqn data_cons
1788 foldr_eqn con = evalState (match_foldr z_Expr [f_Pat,z_Pat] con =<< parts) bs_RDRs
1789 where
1790 parts = sequence $ foldDataConArgs ft_foldr con
1791
1792 foldMap_bind = mkRdrFunBind (L loc foldMap_RDR) (map foldMap_eqn data_cons)
1793 foldMap_eqn con = evalState (match_foldMap [f_Pat] con =<< parts) bs_RDRs
1794 where
1795 parts = sequence $ foldDataConArgs ft_foldMap con
1796
1797 ft_foldr :: FFoldType (State [RdrName] (LHsExpr RdrName))
1798 ft_foldr = FT { ft_triv = mkSimpleLam2 $ \_ z -> return z -- foldr f = \x z -> z
1799 , ft_var = return f_Expr -- foldr f = f
1800 , ft_tup = \t g -> do gg <- sequence g -- foldr f = (\x z -> case x of ...)
1801 mkSimpleLam2 $ \x z -> mkSimpleTupleCase (match_foldr z) t gg x
1802 , ft_ty_app = \_ g -> do gg <- g -- foldr f = (\x z -> foldr g z x)
1803 mkSimpleLam2 $ \x z -> return $ nlHsApps foldable_foldr_RDR [gg,z,x]
1804 , ft_forall = \_ g -> g
1805 , ft_co_var = panic "contravariant"
1806 , ft_fun = panic "function"
1807 , ft_bad_app = panic "in other argument" }
1808
1809 match_foldr z = mkSimpleConMatch $ \_con_name xs -> return $ foldr nlHsApp z xs -- g1 v1 (g2 v2 (.. z))
1810
1811 ft_foldMap :: FFoldType (State [RdrName] (LHsExpr RdrName))
1812 ft_foldMap = FT { ft_triv = mkSimpleLam $ \_ -> return mempty_Expr -- foldMap f = \x -> mempty
1813 , ft_var = return f_Expr -- foldMap f = f
1814 , ft_tup = \t g -> do gg <- sequence g -- foldMap f = \x -> case x of (..,)
1815 mkSimpleLam $ mkSimpleTupleCase match_foldMap t gg
1816 , ft_ty_app = \_ g -> nlHsApp foldMap_Expr <$> g -- foldMap f = foldMap g
1817 , ft_forall = \_ g -> g
1818 , ft_co_var = panic "contravariant"
1819 , ft_fun = panic "function"
1820 , ft_bad_app = panic "in other argument" }
1821
1822 match_foldMap = mkSimpleConMatch $ \_con_name xs -> return $
1823 case xs of
1824 [] -> mempty_Expr
1825 xs -> foldr1 (\x y -> nlHsApps mappend_RDR [x,y]) xs
1826
1827 {-
1828 ************************************************************************
1829 * *
1830 Traversable instances
1831
1832 see http://www.mail-archive.com/haskell-prime@haskell.org/msg02116.html
1833 * *
1834 ************************************************************************
1835
1836 Again, Traversable is much like Functor and Foldable.
1837
1838 The cases are:
1839
1840 $(traverse 'a 'b) = pure -- when b does not contain a
1841 $(traverse 'a 'a) = f
1842 $(traverse 'a '(b1,b2)) = \x -> case x of (x1,x2) -> (,) <$> $(traverse 'a 'b1) x1 <*> $(traverse 'a 'b2) x2
1843 $(traverse 'a '(T b1 b2)) = traverse $(traverse 'a 'b2) -- when a only occurs in the last parameter, b2
1844
1845 Note that the generated code is not as efficient as it could be. For instance:
1846
1847 data T a = T Int a deriving Traversable
1848
1849 gives the function: traverse f (T x y) = T <$> pure x <*> f y
1850 instead of: traverse f (T x y) = T x <$> f y
1851 -}
1852
1853 gen_Traversable_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1854 gen_Traversable_binds loc tycon
1855 = (unitBag traverse_bind, emptyBag)
1856 where
1857 data_cons = tyConDataCons tycon
1858
1859 traverse_bind = mkRdrFunBind (L loc traverse_RDR) eqns
1860 eqns = map traverse_eqn data_cons
1861 traverse_eqn con = evalState (match_for_con [f_Pat] con =<< parts) bs_RDRs
1862 where
1863 parts = sequence $ foldDataConArgs ft_trav con
1864
1865
1866 ft_trav :: FFoldType (State [RdrName] (LHsExpr RdrName))
1867 ft_trav = FT { ft_triv = return pure_Expr -- traverse f = pure x
1868 , ft_var = return f_Expr -- traverse f = f x
1869 , ft_tup = \t gs -> do -- traverse f = \x -> case x of (a1,a2,..) ->
1870 gg <- sequence gs -- (,,) <$> g1 a1 <*> g2 a2 <*> ..
1871 mkSimpleLam $ mkSimpleTupleCase match_for_con t gg
1872 , ft_ty_app = \_ g -> nlHsApp traverse_Expr <$> g -- traverse f = travese g
1873 , ft_forall = \_ g -> g
1874 , ft_co_var = panic "contravariant"
1875 , ft_fun = panic "function"
1876 , ft_bad_app = panic "in other argument" }
1877
1878 -- Con a1 a2 ... -> Con <$> g1 a1 <*> g2 a2 <*> ...
1879 match_for_con = mkSimpleConMatch $
1880 \con_name xs -> return $ mkApCon (nlHsVar con_name) xs
1881
1882 -- ((Con <$> x1) <*> x2) <*> ..
1883 mkApCon con [] = nlHsApps pure_RDR [con]
1884 mkApCon con (x:xs) = foldl appAp (nlHsApps fmap_RDR [con,x]) xs
1885 where appAp x y = nlHsApps ap_RDR [x,y]
1886
1887 {-
1888 ************************************************************************
1889 * *
1890 Lift instances
1891 * *
1892 ************************************************************************
1893
1894 Example:
1895
1896 data Foo a = Foo a | a :^: a deriving Lift
1897
1898 ==>
1899
1900 instance (Lift a) => Lift (Foo a) where
1901 lift (Foo a)
1902 = appE
1903 (conE
1904 (mkNameG_d "package-name" "ModuleName" "Foo"))
1905 (lift a)
1906 lift (u :^: v)
1907 = infixApp
1908 (lift u)
1909 (conE
1910 (mkNameG_d "package-name" "ModuleName" ":^:"))
1911 (lift v)
1912
1913 Note that (mkNameG_d "package-name" "ModuleName" "Foo") is equivalent to what
1914 'Foo would be when using the -XTemplateHaskell extension. To make sure that
1915 -XDeriveLift can be used on stage-1 compilers, however, we expliticly invoke
1916 makeG_d.
1917 -}
1918
1919 gen_Lift_binds :: SrcSpan -> TyCon -> (LHsBinds RdrName, BagDerivStuff)
1920 gen_Lift_binds loc tycon
1921 | null data_cons = (unitBag (L loc $ mkFunBind (L loc lift_RDR)
1922 [mkMatch [nlWildPat] errorMsg_Expr emptyLocalBinds])
1923 , emptyBag)
1924 | otherwise = (unitBag lift_bind, emptyBag)
1925 where
1926 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
1927 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
1928
1929 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
1930 data_cons = tyConDataCons tycon
1931 tycon_str = occNameString . nameOccName . tyConName $ tycon
1932
1933 pats_etc data_con
1934 = ([con_pat], lift_Expr)
1935 where
1936 con_pat = nlConVarPat data_con_RDR as_needed
1937 data_con_RDR = getRdrName data_con
1938 con_arity = dataConSourceArity data_con
1939 as_needed = take con_arity as_RDRs
1940 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1941 tys_needed as_needed
1942 tycon_name = tyConName tycon
1943 is_infix = dataConIsInfix data_con
1944 tys_needed = dataConOrigArgTys data_con
1945
1946 mk_lift_app ty a
1947 | not (isUnLiftedType ty) = nlHsApp (nlHsVar lift_RDR)
1948 (nlHsVar a)
1949 | otherwise = nlHsApp (nlHsVar litE_RDR)
1950 (primLitOp (mkBoxExp (nlHsVar a)))
1951 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1952
1953 pkg_name = unitIdString . moduleUnitId
1954 . nameModule $ tycon_name
1955 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1956 con_name = occNameString . nameOccName . dataConName $ data_con
1957
1958 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1959 (nlHsApps mkNameG_dRDR
1960 (map (nlHsLit . mkHsString)
1961 [pkg_name, mod_name, con_name]))
1962
1963 lift_Expr
1964 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1965 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1966 (a1:a2:_) = lifted_as
1967
1968 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1969 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1970
1971 {-
1972 ************************************************************************
1973 * *
1974 Newtype-deriving instances
1975 * *
1976 ************************************************************************
1977
1978 We take every method in the original instance and `coerce` it to fit
1979 into the derived instance. We need a type annotation on the argument
1980 to `coerce` to make it obvious what instantiation of the method we're
1981 coercing from.
1982
1983 See #8503 for more discussion.
1984 -}
1985
1986 mkCoerceClassMethEqn :: Class -- the class being derived
1987 -> [TyVar] -- the tvs in the instance head
1988 -> [Type] -- instance head parameters (incl. newtype)
1989 -> Type -- the representation type (already eta-reduced)
1990 -> Id -- the method to look at
1991 -> Pair Type
1992 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
1993 = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty)
1994 where
1995 cls_tvs = classTyVars cls
1996 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1997 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
1998 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
1999 (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
2000
2001 changeLast :: [a] -> a -> [a]
2002 changeLast [] _ = panic "changeLast"
2003 changeLast [_] x = [x]
2004 changeLast (x:xs) x' = x : changeLast xs x'
2005
2006
2007 gen_Newtype_binds :: SrcSpan
2008 -> Class -- the class being derived
2009 -> [TyVar] -- the tvs in the instance head
2010 -> [Type] -- instance head parameters (incl. newtype)
2011 -> Type -- the representation type (already eta-reduced)
2012 -> LHsBinds RdrName
2013 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
2014 = listToBag $ zipWith mk_bind
2015 (classMethods cls)
2016 (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
2017 where
2018 coerce_RDR = getRdrName coerceId
2019 mk_bind :: Id -> Pair Type -> LHsBind RdrName
2020 mk_bind id (Pair tau_ty user_ty)
2021 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
2022 where
2023 meth_RDR = getRdrName id
2024 rhs_expr
2025 = ( nlHsVar coerce_RDR
2026 `nlHsApp`
2027 (nlHsVar meth_RDR `nlExprWithTySig` toHsType tau_ty'))
2028 `nlExprWithTySig` toHsType user_ty
2029 -- Open the representation type here, so that it's forall'ed type
2030 -- variables refer to the ones bound in the user_ty
2031 (_, _, tau_ty') = tcSplitSigmaTy tau_ty
2032
2033 nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName
2034 nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder)
2035
2036 {-
2037 ************************************************************************
2038 * *
2039 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
2040 * *
2041 ************************************************************************
2042
2043 \begin{verbatim}
2044 data Foo ... = ...
2045
2046 con2tag_Foo :: Foo ... -> Int#
2047 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2048 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2049 \end{verbatim}
2050
2051 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2052 fiddling around.
2053 -}
2054
2055 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
2056 genAuxBindSpec loc (DerivCon2Tag tycon)
2057 = (mk_FunBind loc rdr_name eqns,
2058 L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
2059 where
2060 rdr_name = con2tag_RDR tycon
2061
2062 sig_ty = HsCoreTy $
2063 mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
2064 mkParentType tycon `mkFunTy` intPrimTy
2065
2066 lots_of_constructors = tyConFamilySize tycon > 8
2067 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
2068 -- but we don't do vectored returns any more.
2069
2070 eqns | lots_of_constructors = [get_tag_eqn]
2071 | otherwise = map mk_eqn (tyConDataCons tycon)
2072
2073 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
2074
2075 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
2076 mk_eqn con = ([nlWildConPat con],
2077 nlHsLit (HsIntPrim ""
2078 (toInteger ((dataConTag con) - fIRST_TAG))))
2079
2080 genAuxBindSpec loc (DerivTag2Con tycon)
2081 = (mk_FunBind loc rdr_name
2082 [([nlConVarPat intDataCon_RDR [a_RDR]],
2083 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2084 L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
2085 where
2086 sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
2087 intTy `mkFunTy` mkParentType tycon
2088
2089 rdr_name = tag2con_RDR tycon
2090
2091 genAuxBindSpec loc (DerivMaxTag tycon)
2092 = (mkHsVarBind loc rdr_name rhs,
2093 L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
2094 where
2095 rdr_name = maxtag_RDR tycon
2096 sig_ty = HsCoreTy intTy
2097 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2098 max_tag = case (tyConDataCons tycon) of
2099 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2100
2101 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
2102 ( Bag (LHsBind RdrName, LSig RdrName)
2103 -- Extra bindings (used by Generic only)
2104 , Bag TyCon -- Extra top-level datatypes
2105 , Bag (FamInst) -- Extra family instances
2106 , Bag (InstInfo RdrName)) -- Extra instances
2107
2108 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2109 genAuxBinds loc b = genAuxBinds' b2 where
2110 (b1,b2) = partitionBagWith splitDerivAuxBind b
2111 splitDerivAuxBind (DerivAuxBind x) = Left x
2112 splitDerivAuxBind x = Right x
2113
2114 rm_dups = foldrBag dup_check emptyBag
2115 dup_check a b = if anyBag (== a) b then b else consBag a b
2116
2117 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2118 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2119 , emptyBag, emptyBag, emptyBag)
2120 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2121 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2122 f (DerivHsBind b) = add1 b
2123 f (DerivTyCon t) = add2 t
2124 f (DerivFamInst t) = add3 t
2125 f (DerivInst i) = add4 i
2126
2127 add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
2128 add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
2129 add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
2130 add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
2131
2132 mk_data_type_name :: TyCon -> RdrName -- "$tT"
2133 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
2134
2135 mk_constr_name :: DataCon -> RdrName -- "$cC"
2136 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
2137
2138 mkParentType :: TyCon -> Type
2139 -- Turn the representation tycon of a family into
2140 -- a use of its family constructor
2141 mkParentType tc
2142 = case tyConFamInst_maybe tc of
2143 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2144 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2145
2146 {-
2147 ************************************************************************
2148 * *
2149 \subsection{Utility bits for generating bindings}
2150 * *
2151 ************************************************************************
2152 -}
2153
2154 mk_FunBind :: SrcSpan -> RdrName
2155 -> [([LPat RdrName], LHsExpr RdrName)]
2156 -> LHsBind RdrName
2157 mk_FunBind loc fun pats_and_exprs
2158 = mkRdrFunBind (L loc fun) matches
2159 where
2160 matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs]
2161
2162 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2163 mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2164 where
2165 -- Catch-all eqn looks like
2166 -- fmap = error "Void fmap"
2167 -- It's needed if there no data cons at all,
2168 -- which can happen with -XEmptyDataDecls
2169 -- See Trac #4302
2170 matches' = if null matches
2171 then [mkMatch [] (error_Expr str) emptyLocalBinds]
2172 else matches
2173 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2174
2175 box :: String -- The class involved
2176 -> TyCon -- The tycon involved
2177 -> LHsExpr RdrName -- The argument
2178 -> Type -- The argument type
2179 -> LHsExpr RdrName -- Boxed version of the arg
2180 -- See Note [Deriving and unboxed types] in TcDeriv
2181 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2182 where
2183 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2184
2185 ---------------------
2186 primOrdOps :: String -- The class involved
2187 -> TyCon -- The tycon involved
2188 -> Type -- The type
2189 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2190 -- See Note [Deriving and unboxed types] in TcDeriv
2191 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2192
2193 primLitOps :: String -- The class involved
2194 -> TyCon -- The tycon involved
2195 -> Type -- The type
2196 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
2197 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
2198 )
2199 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2200 , \v -> nlHsVar boxRDR `nlHsApp` v
2201 )
2202 where
2203 boxRDR
2204 | ty == addrPrimTy = unpackCString_RDR
2205 | otherwise = assoc_ty_id str tycon boxConTbl ty
2206
2207 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2208 ordOpTbl
2209 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2210 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2211 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2212 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2213 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2214 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2215
2216 boxConTbl :: [(Type, RdrName)]
2217 boxConTbl
2218 = [(charPrimTy , getRdrName charDataCon )
2219 ,(intPrimTy , getRdrName intDataCon )
2220 ,(wordPrimTy , getRdrName wordDataCon )
2221 ,(floatPrimTy , getRdrName floatDataCon )
2222 ,(doublePrimTy, getRdrName doubleDataCon)
2223 ]
2224
2225 -- | A table of postfix modifiers for unboxed values.
2226 postfixModTbl :: [(Type, String)]
2227 postfixModTbl
2228 = [(charPrimTy , "#" )
2229 ,(intPrimTy , "#" )
2230 ,(wordPrimTy , "##")
2231 ,(floatPrimTy , "#" )
2232 ,(doublePrimTy, "##")
2233 ]
2234
2235 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
2236 litConTbl
2237 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2238 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2239 . nlHsApp (nlHsVar toInteger_RDR))
2240 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2241 . nlHsApp (nlHsVar toInteger_RDR))
2242 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2243 . nlHsApp (nlHsApp
2244 (nlHsVar map_RDR)
2245 (compose_RDR `nlHsApps`
2246 [ nlHsVar fromIntegral_RDR
2247 , nlHsVar fromEnum_RDR
2248 ])))
2249 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2250 . nlHsApp (nlHsVar toRational_RDR))
2251 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2252 . nlHsApp (nlHsVar toRational_RDR))
2253 ]
2254
2255 -- | Lookup `Type` in an association list.
2256 assoc_ty_id :: String -- The class involved
2257 -> TyCon -- The tycon involved
2258 -> [(Type,a)] -- The table
2259 -> Type -- The type
2260 -> a -- The result of the lookup
2261 assoc_ty_id cls_str _ tbl ty
2262 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2263 text "for primitive type" <+> ppr ty)
2264 | otherwise = head res
2265 where
2266 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2267
2268 -----------------------------------------------------------------------
2269
2270 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2271 and_Expr a b = genOpApp a and_RDR b
2272
2273 -----------------------------------------------------------------------
2274
2275 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2276 eq_Expr tycon ty a b
2277 | not (isUnLiftedType ty) = genOpApp a eq_RDR b
2278 | otherwise = genPrimOpApp a prim_eq b
2279 where
2280 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2281
2282 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2283 untag_Expr _ [] expr = expr
2284 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2285 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2286 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2287
2288 enum_from_to_Expr
2289 :: LHsExpr RdrName -> LHsExpr RdrName
2290 -> LHsExpr RdrName
2291 enum_from_then_to_Expr
2292 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2293 -> LHsExpr RdrName
2294
2295 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2296 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2297
2298 showParen_Expr
2299 :: LHsExpr RdrName -> LHsExpr RdrName
2300 -> LHsExpr RdrName
2301
2302 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2303
2304 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2305
2306 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2307 nested_compose_Expr [e] = parenify e
2308 nested_compose_Expr (e:es)
2309 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2310
2311 -- impossible_Expr is used in case RHSs that should never happen.
2312 -- We generate these to keep the desugarer from complaining that they *might* happen!
2313 error_Expr :: String -> LHsExpr RdrName
2314 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2315
2316 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2317 -- method. It is currently only used by Enum.{succ,pred}
2318 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2319 illegal_Expr meth tp msg =
2320 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2321
2322 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2323 -- to include the value of a_RDR in the error string.
2324 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2325 illegal_toEnum_tag tp maxtag =
2326 nlHsApp (nlHsVar error_RDR)
2327 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2328 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2329 (nlHsApp (nlHsApp (nlHsApp
2330 (nlHsVar showsPrec_RDR)
2331 (nlHsIntLit 0))
2332 (nlHsVar a_RDR))
2333 (nlHsApp (nlHsApp
2334 (nlHsVar append_RDR)
2335 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2336 (nlHsApp (nlHsApp (nlHsApp
2337 (nlHsVar showsPrec_RDR)
2338 (nlHsIntLit 0))
2339 (nlHsVar maxtag))
2340 (nlHsLit (mkHsString ")"))))))
2341
2342 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2343 parenify e@(L _ (HsVar _)) = e
2344 parenify e = mkHsPar e
2345
2346 -- genOpApp wraps brackets round the operator application, so that the
2347 -- renamer won't subsequently try to re-associate it.
2348 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2349 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2350
2351 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2352 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2353
2354 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2355 :: RdrName
2356 a_RDR = mkVarUnqual (fsLit "a")
2357 b_RDR = mkVarUnqual (fsLit "b")
2358 c_RDR = mkVarUnqual (fsLit "c")
2359 d_RDR = mkVarUnqual (fsLit "d")
2360 f_RDR = mkVarUnqual (fsLit "f")
2361 k_RDR = mkVarUnqual (fsLit "k")
2362 z_RDR = mkVarUnqual (fsLit "z")
2363 ah_RDR = mkVarUnqual (fsLit "a#")
2364 bh_RDR = mkVarUnqual (fsLit "b#")
2365 ch_RDR = mkVarUnqual (fsLit "c#")
2366 dh_RDR = mkVarUnqual (fsLit "d#")
2367
2368 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2369 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2370 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2371 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2372
2373 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2374 false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2375 a_Expr = nlHsVar a_RDR
2376 -- b_Expr = nlHsVar b_RDR
2377 c_Expr = nlHsVar c_RDR
2378 f_Expr = nlHsVar f_RDR
2379 z_Expr = nlHsVar z_RDR
2380 ltTag_Expr = nlHsVar ltTag_RDR
2381 eqTag_Expr = nlHsVar eqTag_RDR
2382 gtTag_Expr = nlHsVar gtTag_RDR
2383 false_Expr = nlHsVar false_RDR
2384 true_Expr = nlHsVar true_RDR
2385 fmap_Expr = nlHsVar fmap_RDR
2386 pure_Expr = nlHsVar pure_RDR
2387 mempty_Expr = nlHsVar mempty_RDR
2388 foldMap_Expr = nlHsVar foldMap_RDR
2389 traverse_Expr = nlHsVar traverse_RDR
2390
2391 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2392 a_Pat = nlVarPat a_RDR
2393 b_Pat = nlVarPat b_RDR
2394 c_Pat = nlVarPat c_RDR
2395 d_Pat = nlVarPat d_RDR
2396 f_Pat = nlVarPat f_RDR
2397 k_Pat = nlVarPat k_RDR
2398 z_Pat = nlVarPat z_RDR
2399
2400 minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
2401 minusInt_RDR = getRdrName (primOpId IntSubOp )
2402 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2403 error_RDR = getRdrName eRROR_ID
2404
2405 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2406 -- Generates Orig s RdrName, for the binding positions
2407 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2408 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2409 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2410
2411 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2412 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2413
2414 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2415 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2416 -- See Note [Auxiliary binders]
2417 mkAuxBinderName parent occ_fun
2418 = mkRdrUnqual (occ_fun stable_parent_occ)
2419 where
2420 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2421 stable_string
2422 | opt_PprStyle_Debug = parent_stable
2423 | otherwise = parent_stable_hash
2424 parent_stable = nameStableString parent
2425 parent_stable_hash =
2426 let Fingerprint high low = fingerprintString parent_stable
2427 in toBase62 high ++ toBase62Padded low
2428 -- See Note [Base 62 encoding 128-bit integers]
2429 parent_occ = nameOccName parent
2430
2431
2432 {-
2433 Note [Auxiliary binders]
2434 ~~~~~~~~~~~~~~~~~~~~~~~~
2435 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2436
2437 instance Ord T where
2438 compare a b = $con2tag a `compare` $con2tag b
2439
2440 $con2tag :: T -> Int
2441 $con2tag = ...code....
2442
2443 Of course these top-level bindings should all have distinct name, and we are
2444 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2445 because with standalone deriving two imported TyCons might both be called T!
2446 (See Trac #7947.)
2447
2448 So we use package name, module name and the name of the parent
2449 (T in this example) as part of the OccName we generate for the new binding.
2450 To make the symbol names short we take a base62 hash of the full name.
2451
2452 In the past we used the *unique* from the parent, but that's not stable across
2453 recompilations as uniques are nondeterministic.
2454
2455 Note [DeriveFoldable with ExistentialQuantification]
2456 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2457 Functor and Traversable instances can only be derived for data types whose
2458 last type parameter is truly universally polymorphic. For example:
2459
2460 data T a b where
2461 T1 :: b -> T a b -- YES, b is unconstrained
2462 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
2463 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
2464 T4 :: Int -> T a Int -- NO, this is just like T3
2465 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
2466 -- though a is existential
2467 T6 :: Int -> T Int b -- YES, b is unconstrained
2468
2469 For Foldable instances, however, we can completely lift the constraint that
2470 the last type parameter be truly universally polymorphic. This means that T
2471 (as defined above) can have a derived Foldable instance:
2472
2473 instance Foldable (T a) where
2474 foldr f z (T1 b) = f b z
2475 foldr f z (T2 b) = f b z
2476 foldr f z (T3 b) = f b z
2477 foldr f z (T4 b) = z
2478 foldr f z (T5 a b) = f b z
2479 foldr f z (T6 a) = z
2480
2481 foldMap f (T1 b) = f b
2482 foldMap f (T2 b) = f b
2483 foldMap f (T3 b) = f b
2484 foldMap f (T4 b) = mempty
2485 foldMap f (T5 a b) = f b
2486 foldMap f (T6 a) = mempty
2487
2488 In a Foldable instance, it is safe to fold over an occurrence of the last type
2489 parameter that is not truly universally polymorphic. However, there is a bit
2490 of subtlety in determining what is actually an occurrence of a type parameter.
2491 T3 and T4, as defined above, provide one example:
2492
2493 data T a b where
2494 ...
2495 T3 :: b ~ Int => b -> T a b
2496 T4 :: Int -> T a Int
2497 ...
2498
2499 instance Foldable (T a) where
2500 ...
2501 foldr f z (T3 b) = f b z
2502 foldr f z (T4 b) = z
2503 ...
2504 foldMap f (T3 b) = f b
2505 foldMap f (T4 b) = mempty
2506 ...
2507
2508 Notice that the argument of T3 is folded over, whereas the argument of T4 is
2509 not. This is because we only fold over constructor arguments that
2510 syntactically mention the universally quantified type parameter of that
2511 particular data constructor. See foldDataConArgs for how this is implemented.
2512
2513 As another example, consider the following data type. The argument of each
2514 constructor has the same type as the last type parameter:
2515
2516 data E a where
2517 E1 :: (a ~ Int) => a -> E a
2518 E2 :: Int -> E Int
2519 E3 :: (a ~ Int) => a -> E Int
2520 E4 :: (a ~ Int) => Int -> E a
2521
2522 Only E1's argument is an occurrence of a universally quantified type variable
2523 that is syntactically equivalent to the last type parameter, so only E1's
2524 argument will be be folded over in a derived Foldable instance.
2525
2526 See Trac #10447 for the original discussion on this feature. Also see
2527 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
2528 for a more in-depth explanation.
2529
2530 -}