APIAnnotations:add Locations in hsSyn for layout
[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 (noLoc 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
1923 (noLoc emptyLocalBinds)])
1924 , emptyBag)
1925 | otherwise = (unitBag lift_bind, emptyBag)
1926 where
1927 errorMsg_Expr = nlHsVar error_RDR `nlHsApp` nlHsLit
1928 (mkHsString $ "Can't lift value of empty datatype " ++ tycon_str)
1929
1930 lift_bind = mk_FunBind loc lift_RDR (map pats_etc data_cons)
1931 data_cons = tyConDataCons tycon
1932 tycon_str = occNameString . nameOccName . tyConName $ tycon
1933
1934 pats_etc data_con
1935 = ([con_pat], lift_Expr)
1936 where
1937 con_pat = nlConVarPat data_con_RDR as_needed
1938 data_con_RDR = getRdrName data_con
1939 con_arity = dataConSourceArity data_con
1940 as_needed = take con_arity as_RDRs
1941 lifted_as = zipWithEqual "mk_lift_app" mk_lift_app
1942 tys_needed as_needed
1943 tycon_name = tyConName tycon
1944 is_infix = dataConIsInfix data_con
1945 tys_needed = dataConOrigArgTys data_con
1946
1947 mk_lift_app ty a
1948 | not (isUnLiftedType ty) = nlHsApp (nlHsVar lift_RDR)
1949 (nlHsVar a)
1950 | otherwise = nlHsApp (nlHsVar litE_RDR)
1951 (primLitOp (mkBoxExp (nlHsVar a)))
1952 where (primLitOp, mkBoxExp) = primLitOps "Lift" tycon ty
1953
1954 pkg_name = unitIdString . moduleUnitId
1955 . nameModule $ tycon_name
1956 mod_name = moduleNameString . moduleName . nameModule $ tycon_name
1957 con_name = occNameString . nameOccName . dataConName $ data_con
1958
1959 conE_Expr = nlHsApp (nlHsVar conE_RDR)
1960 (nlHsApps mkNameG_dRDR
1961 (map (nlHsLit . mkHsString)
1962 [pkg_name, mod_name, con_name]))
1963
1964 lift_Expr
1965 | is_infix = nlHsApps infixApp_RDR [a1, conE_Expr, a2]
1966 | otherwise = foldl mk_appE_app conE_Expr lifted_as
1967 (a1:a2:_) = lifted_as
1968
1969 mk_appE_app :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
1970 mk_appE_app a b = nlHsApps appE_RDR [a, b]
1971
1972 {-
1973 ************************************************************************
1974 * *
1975 Newtype-deriving instances
1976 * *
1977 ************************************************************************
1978
1979 We take every method in the original instance and `coerce` it to fit
1980 into the derived instance. We need a type annotation on the argument
1981 to `coerce` to make it obvious what instantiation of the method we're
1982 coercing from.
1983
1984 See #8503 for more discussion.
1985 -}
1986
1987 mkCoerceClassMethEqn :: Class -- the class being derived
1988 -> [TyVar] -- the tvs in the instance head
1989 -> [Type] -- instance head parameters (incl. newtype)
1990 -> Type -- the representation type (already eta-reduced)
1991 -> Id -- the method to look at
1992 -> Pair Type
1993 mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty id
1994 = Pair (substTy rhs_subst user_meth_ty) (substTy lhs_subst user_meth_ty)
1995 where
1996 cls_tvs = classTyVars cls
1997 in_scope = mkInScopeSet $ mkVarSet inst_tvs
1998 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs cls_tys)
1999 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast cls_tys rhs_ty))
2000 (_class_tvs, _class_constraint, user_meth_ty) = tcSplitSigmaTy (varType id)
2001
2002 changeLast :: [a] -> a -> [a]
2003 changeLast [] _ = panic "changeLast"
2004 changeLast [_] x = [x]
2005 changeLast (x:xs) x' = x : changeLast xs x'
2006
2007
2008 gen_Newtype_binds :: SrcSpan
2009 -> Class -- the class being derived
2010 -> [TyVar] -- the tvs in the instance head
2011 -> [Type] -- instance head parameters (incl. newtype)
2012 -> Type -- the representation type (already eta-reduced)
2013 -> LHsBinds RdrName
2014 gen_Newtype_binds loc cls inst_tvs cls_tys rhs_ty
2015 = listToBag $ zipWith mk_bind
2016 (classMethods cls)
2017 (map (mkCoerceClassMethEqn cls inst_tvs cls_tys rhs_ty) (classMethods cls))
2018 where
2019 coerce_RDR = getRdrName coerceId
2020 mk_bind :: Id -> Pair Type -> LHsBind RdrName
2021 mk_bind id (Pair tau_ty user_ty)
2022 = mkRdrFunBind (L loc meth_RDR) [mkSimpleMatch [] rhs_expr]
2023 where
2024 meth_RDR = getRdrName id
2025 rhs_expr
2026 = ( nlHsVar coerce_RDR
2027 `nlHsApp`
2028 (nlHsVar meth_RDR `nlExprWithTySig` toHsType tau_ty'))
2029 `nlExprWithTySig` toHsType user_ty
2030 -- Open the representation type here, so that it's forall'ed type
2031 -- variables refer to the ones bound in the user_ty
2032 (_, _, tau_ty') = tcSplitSigmaTy tau_ty
2033
2034 nlExprWithTySig :: LHsExpr RdrName -> LHsType RdrName -> LHsExpr RdrName
2035 nlExprWithTySig e s = noLoc (ExprWithTySig e s PlaceHolder)
2036
2037 {-
2038 ************************************************************************
2039 * *
2040 \subsection{Generating extra binds (@con2tag@ and @tag2con@)}
2041 * *
2042 ************************************************************************
2043
2044 \begin{verbatim}
2045 data Foo ... = ...
2046
2047 con2tag_Foo :: Foo ... -> Int#
2048 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2049 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2050 \end{verbatim}
2051
2052 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2053 fiddling around.
2054 -}
2055
2056 genAuxBindSpec :: SrcSpan -> AuxBindSpec -> (LHsBind RdrName, LSig RdrName)
2057 genAuxBindSpec loc (DerivCon2Tag tycon)
2058 = (mk_FunBind loc rdr_name eqns,
2059 L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
2060 where
2061 rdr_name = con2tag_RDR tycon
2062
2063 sig_ty = HsCoreTy $
2064 mkSigmaTy (tyConTyVars tycon) (tyConStupidTheta tycon) $
2065 mkParentType tycon `mkFunTy` intPrimTy
2066
2067 lots_of_constructors = tyConFamilySize tycon > 8
2068 -- was: mAX_FAMILY_SIZE_FOR_VEC_RETURNS
2069 -- but we don't do vectored returns any more.
2070
2071 eqns | lots_of_constructors = [get_tag_eqn]
2072 | otherwise = map mk_eqn (tyConDataCons tycon)
2073
2074 get_tag_eqn = ([nlVarPat a_RDR], nlHsApp (nlHsVar getTag_RDR) a_Expr)
2075
2076 mk_eqn :: DataCon -> ([LPat RdrName], LHsExpr RdrName)
2077 mk_eqn con = ([nlWildConPat con],
2078 nlHsLit (HsIntPrim ""
2079 (toInteger ((dataConTag con) - fIRST_TAG))))
2080
2081 genAuxBindSpec loc (DerivTag2Con tycon)
2082 = (mk_FunBind loc rdr_name
2083 [([nlConVarPat intDataCon_RDR [a_RDR]],
2084 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)],
2085 L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
2086 where
2087 sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $
2088 intTy `mkFunTy` mkParentType tycon
2089
2090 rdr_name = tag2con_RDR tycon
2091
2092 genAuxBindSpec loc (DerivMaxTag tycon)
2093 = (mkHsVarBind loc rdr_name rhs,
2094 L loc (TypeSig [L loc rdr_name] (L loc sig_ty) PlaceHolder))
2095 where
2096 rdr_name = maxtag_RDR tycon
2097 sig_ty = HsCoreTy intTy
2098 rhs = nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim "" max_tag))
2099 max_tag = case (tyConDataCons tycon) of
2100 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2101
2102 type SeparateBagsDerivStuff = -- AuxBinds and SYB bindings
2103 ( Bag (LHsBind RdrName, LSig RdrName)
2104 -- Extra bindings (used by Generic only)
2105 , Bag TyCon -- Extra top-level datatypes
2106 , Bag (FamInst) -- Extra family instances
2107 , Bag (InstInfo RdrName)) -- Extra instances
2108
2109 genAuxBinds :: SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2110 genAuxBinds loc b = genAuxBinds' b2 where
2111 (b1,b2) = partitionBagWith splitDerivAuxBind b
2112 splitDerivAuxBind (DerivAuxBind x) = Left x
2113 splitDerivAuxBind x = Right x
2114
2115 rm_dups = foldrBag dup_check emptyBag
2116 dup_check a b = if anyBag (== a) b then b else consBag a b
2117
2118 genAuxBinds' :: BagDerivStuff -> SeparateBagsDerivStuff
2119 genAuxBinds' = foldrBag f ( mapBag (genAuxBindSpec loc) (rm_dups b1)
2120 , emptyBag, emptyBag, emptyBag)
2121 f :: DerivStuff -> SeparateBagsDerivStuff -> SeparateBagsDerivStuff
2122 f (DerivAuxBind _) = panic "genAuxBinds'" -- We have removed these before
2123 f (DerivHsBind b) = add1 b
2124 f (DerivTyCon t) = add2 t
2125 f (DerivFamInst t) = add3 t
2126 f (DerivInst i) = add4 i
2127
2128 add1 x (a,b,c,d) = (x `consBag` a,b,c,d)
2129 add2 x (a,b,c,d) = (a,x `consBag` b,c,d)
2130 add3 x (a,b,c,d) = (a,b,x `consBag` c,d)
2131 add4 x (a,b,c,d) = (a,b,c,x `consBag` d)
2132
2133 mk_data_type_name :: TyCon -> RdrName -- "$tT"
2134 mk_data_type_name tycon = mkAuxBinderName (tyConName tycon) mkDataTOcc
2135
2136 mk_constr_name :: DataCon -> RdrName -- "$cC"
2137 mk_constr_name con = mkAuxBinderName (dataConName con) mkDataCOcc
2138
2139 mkParentType :: TyCon -> Type
2140 -- Turn the representation tycon of a family into
2141 -- a use of its family constructor
2142 mkParentType tc
2143 = case tyConFamInst_maybe tc of
2144 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2145 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2146
2147 {-
2148 ************************************************************************
2149 * *
2150 \subsection{Utility bits for generating bindings}
2151 * *
2152 ************************************************************************
2153 -}
2154
2155 mk_FunBind :: SrcSpan -> RdrName
2156 -> [([LPat RdrName], LHsExpr RdrName)]
2157 -> LHsBind RdrName
2158 mk_FunBind loc fun pats_and_exprs
2159 = mkRdrFunBind (L loc fun) matches
2160 where
2161 matches = [mkMatch p e (noLoc emptyLocalBinds) | (p,e) <-pats_and_exprs]
2162
2163 mkRdrFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)] -> LHsBind RdrName
2164 mkRdrFunBind fun@(L loc fun_rdr) matches = L loc (mkFunBind fun matches')
2165 where
2166 -- Catch-all eqn looks like
2167 -- fmap = error "Void fmap"
2168 -- It's needed if there no data cons at all,
2169 -- which can happen with -XEmptyDataDecls
2170 -- See Trac #4302
2171 matches' = if null matches
2172 then [mkMatch [] (error_Expr str) (noLoc emptyLocalBinds)]
2173 else matches
2174 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2175
2176 box :: String -- The class involved
2177 -> TyCon -- The tycon involved
2178 -> LHsExpr RdrName -- The argument
2179 -> Type -- The argument type
2180 -> LHsExpr RdrName -- Boxed version of the arg
2181 -- See Note [Deriving and unboxed types] in TcDeriv
2182 box cls_str tycon arg arg_ty = nlHsApp (nlHsVar box_con) arg
2183 where
2184 box_con = assoc_ty_id cls_str tycon boxConTbl arg_ty
2185
2186 ---------------------
2187 primOrdOps :: String -- The class involved
2188 -> TyCon -- The tycon involved
2189 -> Type -- The type
2190 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2191 -- See Note [Deriving and unboxed types] in TcDeriv
2192 primOrdOps str tycon ty = assoc_ty_id str tycon ordOpTbl ty
2193
2194 primLitOps :: String -- The class involved
2195 -> TyCon -- The tycon involved
2196 -> Type -- The type
2197 -> ( LHsExpr RdrName -> LHsExpr RdrName -- Constructs a Q Exp value
2198 , LHsExpr RdrName -> LHsExpr RdrName -- Constructs a boxed value
2199 )
2200 primLitOps str tycon ty = ( assoc_ty_id str tycon litConTbl ty
2201 , \v -> nlHsVar boxRDR `nlHsApp` v
2202 )
2203 where
2204 boxRDR
2205 | ty == addrPrimTy = unpackCString_RDR
2206 | otherwise = assoc_ty_id str tycon boxConTbl ty
2207
2208 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2209 ordOpTbl
2210 = [(charPrimTy , (ltChar_RDR , leChar_RDR , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2211 ,(intPrimTy , (ltInt_RDR , leInt_RDR , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2212 ,(wordPrimTy , (ltWord_RDR , leWord_RDR , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2213 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2214 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2215 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR, eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2216
2217 boxConTbl :: [(Type, RdrName)]
2218 boxConTbl
2219 = [(charPrimTy , getRdrName charDataCon )
2220 ,(intPrimTy , getRdrName intDataCon )
2221 ,(wordPrimTy , getRdrName wordDataCon )
2222 ,(floatPrimTy , getRdrName floatDataCon )
2223 ,(doublePrimTy, getRdrName doubleDataCon)
2224 ]
2225
2226 -- | A table of postfix modifiers for unboxed values.
2227 postfixModTbl :: [(Type, String)]
2228 postfixModTbl
2229 = [(charPrimTy , "#" )
2230 ,(intPrimTy , "#" )
2231 ,(wordPrimTy , "##")
2232 ,(floatPrimTy , "#" )
2233 ,(doublePrimTy, "##")
2234 ]
2235
2236 litConTbl :: [(Type, LHsExpr RdrName -> LHsExpr RdrName)]
2237 litConTbl
2238 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2239 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2240 . nlHsApp (nlHsVar toInteger_RDR))
2241 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2242 . nlHsApp (nlHsVar toInteger_RDR))
2243 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2244 . nlHsApp (nlHsApp
2245 (nlHsVar map_RDR)
2246 (compose_RDR `nlHsApps`
2247 [ nlHsVar fromIntegral_RDR
2248 , nlHsVar fromEnum_RDR
2249 ])))
2250 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2251 . nlHsApp (nlHsVar toRational_RDR))
2252 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2253 . nlHsApp (nlHsVar toRational_RDR))
2254 ]
2255
2256 -- | Lookup `Type` in an association list.
2257 assoc_ty_id :: String -- The class involved
2258 -> TyCon -- The tycon involved
2259 -> [(Type,a)] -- The table
2260 -> Type -- The type
2261 -> a -- The result of the lookup
2262 assoc_ty_id cls_str _ tbl ty
2263 | null res = pprPanic "Error in deriving:" (text "Can't derive" <+> text cls_str <+>
2264 text "for primitive type" <+> ppr ty)
2265 | otherwise = head res
2266 where
2267 res = [id | (ty',id) <- tbl, ty `eqType` ty']
2268
2269 -----------------------------------------------------------------------
2270
2271 and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2272 and_Expr a b = genOpApp a and_RDR b
2273
2274 -----------------------------------------------------------------------
2275
2276 eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2277 eq_Expr tycon ty a b
2278 | not (isUnLiftedType ty) = genOpApp a eq_RDR b
2279 | otherwise = genPrimOpApp a prim_eq b
2280 where
2281 (_, _, prim_eq, _, _) = primOrdOps "Eq" tycon ty
2282
2283 untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName
2284 untag_Expr _ [] expr = expr
2285 untag_Expr tycon ((untag_this, put_tag_here) : more) expr
2286 = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-}
2287 [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)]
2288
2289 enum_from_to_Expr
2290 :: LHsExpr RdrName -> LHsExpr RdrName
2291 -> LHsExpr RdrName
2292 enum_from_then_to_Expr
2293 :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2294 -> LHsExpr RdrName
2295
2296 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2297 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2298
2299 showParen_Expr
2300 :: LHsExpr RdrName -> LHsExpr RdrName
2301 -> LHsExpr RdrName
2302
2303 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2304
2305 nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName
2306
2307 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2308 nested_compose_Expr [e] = parenify e
2309 nested_compose_Expr (e:es)
2310 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2311
2312 -- impossible_Expr is used in case RHSs that should never happen.
2313 -- We generate these to keep the desugarer from complaining that they *might* happen!
2314 error_Expr :: String -> LHsExpr RdrName
2315 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2316
2317 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2318 -- method. It is currently only used by Enum.{succ,pred}
2319 illegal_Expr :: String -> String -> String -> LHsExpr RdrName
2320 illegal_Expr meth tp msg =
2321 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2322
2323 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2324 -- to include the value of a_RDR in the error string.
2325 illegal_toEnum_tag :: String -> RdrName -> LHsExpr RdrName
2326 illegal_toEnum_tag tp maxtag =
2327 nlHsApp (nlHsVar error_RDR)
2328 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2329 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2330 (nlHsApp (nlHsApp (nlHsApp
2331 (nlHsVar showsPrec_RDR)
2332 (nlHsIntLit 0))
2333 (nlHsVar a_RDR))
2334 (nlHsApp (nlHsApp
2335 (nlHsVar append_RDR)
2336 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2337 (nlHsApp (nlHsApp (nlHsApp
2338 (nlHsVar showsPrec_RDR)
2339 (nlHsIntLit 0))
2340 (nlHsVar maxtag))
2341 (nlHsLit (mkHsString ")"))))))
2342
2343 parenify :: LHsExpr RdrName -> LHsExpr RdrName
2344 parenify e@(L _ (HsVar _)) = e
2345 parenify e = mkHsPar e
2346
2347 -- genOpApp wraps brackets round the operator application, so that the
2348 -- renamer won't subsequently try to re-associate it.
2349 genOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2350 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2351
2352 genPrimOpApp :: LHsExpr RdrName -> RdrName -> LHsExpr RdrName -> LHsExpr RdrName
2353 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2354
2355 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2356 :: RdrName
2357 a_RDR = mkVarUnqual (fsLit "a")
2358 b_RDR = mkVarUnqual (fsLit "b")
2359 c_RDR = mkVarUnqual (fsLit "c")
2360 d_RDR = mkVarUnqual (fsLit "d")
2361 f_RDR = mkVarUnqual (fsLit "f")
2362 k_RDR = mkVarUnqual (fsLit "k")
2363 z_RDR = mkVarUnqual (fsLit "z")
2364 ah_RDR = mkVarUnqual (fsLit "a#")
2365 bh_RDR = mkVarUnqual (fsLit "b#")
2366 ch_RDR = mkVarUnqual (fsLit "c#")
2367 dh_RDR = mkVarUnqual (fsLit "d#")
2368
2369 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2370 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2371 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2372 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2373
2374 a_Expr, c_Expr, f_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr,
2375 false_Expr, true_Expr, fmap_Expr, pure_Expr, mempty_Expr, foldMap_Expr, traverse_Expr :: LHsExpr RdrName
2376 a_Expr = nlHsVar a_RDR
2377 -- b_Expr = nlHsVar b_RDR
2378 c_Expr = nlHsVar c_RDR
2379 f_Expr = nlHsVar f_RDR
2380 z_Expr = nlHsVar z_RDR
2381 ltTag_Expr = nlHsVar ltTag_RDR
2382 eqTag_Expr = nlHsVar eqTag_RDR
2383 gtTag_Expr = nlHsVar gtTag_RDR
2384 false_Expr = nlHsVar false_RDR
2385 true_Expr = nlHsVar true_RDR
2386 fmap_Expr = nlHsVar fmap_RDR
2387 pure_Expr = nlHsVar pure_RDR
2388 mempty_Expr = nlHsVar mempty_RDR
2389 foldMap_Expr = nlHsVar foldMap_RDR
2390 traverse_Expr = nlHsVar traverse_RDR
2391
2392 a_Pat, b_Pat, c_Pat, d_Pat, f_Pat, k_Pat, z_Pat :: LPat RdrName
2393 a_Pat = nlVarPat a_RDR
2394 b_Pat = nlVarPat b_RDR
2395 c_Pat = nlVarPat c_RDR
2396 d_Pat = nlVarPat d_RDR
2397 f_Pat = nlVarPat f_RDR
2398 k_Pat = nlVarPat k_RDR
2399 z_Pat = nlVarPat z_RDR
2400
2401 minusInt_RDR, tagToEnum_RDR, error_RDR :: RdrName
2402 minusInt_RDR = getRdrName (primOpId IntSubOp )
2403 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2404 error_RDR = getRdrName eRROR_ID
2405
2406 con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName
2407 -- Generates Orig s RdrName, for the binding positions
2408 con2tag_RDR tycon = mk_tc_deriv_name tycon mkCon2TagOcc
2409 tag2con_RDR tycon = mk_tc_deriv_name tycon mkTag2ConOcc
2410 maxtag_RDR tycon = mk_tc_deriv_name tycon mkMaxTagOcc
2411
2412 mk_tc_deriv_name :: TyCon -> (OccName -> OccName) -> RdrName
2413 mk_tc_deriv_name tycon occ_fun = mkAuxBinderName (tyConName tycon) occ_fun
2414
2415 mkAuxBinderName :: Name -> (OccName -> OccName) -> RdrName
2416 -- ^ Make a top-level binder name for an auxiliary binding for a parent name
2417 -- See Note [Auxiliary binders]
2418 mkAuxBinderName parent occ_fun
2419 = mkRdrUnqual (occ_fun stable_parent_occ)
2420 where
2421 stable_parent_occ = mkOccName (occNameSpace parent_occ) stable_string
2422 stable_string
2423 | opt_PprStyle_Debug = parent_stable
2424 | otherwise = parent_stable_hash
2425 parent_stable = nameStableString parent
2426 parent_stable_hash =
2427 let Fingerprint high low = fingerprintString parent_stable
2428 in toBase62 high ++ toBase62Padded low
2429 -- See Note [Base 62 encoding 128-bit integers]
2430 parent_occ = nameOccName parent
2431
2432
2433 {-
2434 Note [Auxiliary binders]
2435 ~~~~~~~~~~~~~~~~~~~~~~~~
2436 We often want to make a top-level auxiliary binding. E.g. for comparison we haev
2437
2438 instance Ord T where
2439 compare a b = $con2tag a `compare` $con2tag b
2440
2441 $con2tag :: T -> Int
2442 $con2tag = ...code....
2443
2444 Of course these top-level bindings should all have distinct name, and we are
2445 generating RdrNames here. We can't just use the TyCon or DataCon to distinguish
2446 because with standalone deriving two imported TyCons might both be called T!
2447 (See Trac #7947.)
2448
2449 So we use package name, module name and the name of the parent
2450 (T in this example) as part of the OccName we generate for the new binding.
2451 To make the symbol names short we take a base62 hash of the full name.
2452
2453 In the past we used the *unique* from the parent, but that's not stable across
2454 recompilations as uniques are nondeterministic.
2455
2456 Note [DeriveFoldable with ExistentialQuantification]
2457 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2458 Functor and Traversable instances can only be derived for data types whose
2459 last type parameter is truly universally polymorphic. For example:
2460
2461 data T a b where
2462 T1 :: b -> T a b -- YES, b is unconstrained
2463 T2 :: Ord b => b -> T a b -- NO, b is constrained by (Ord b)
2464 T3 :: b ~ Int => b -> T a b -- NO, b is constrained by (b ~ Int)
2465 T4 :: Int -> T a Int -- NO, this is just like T3
2466 T5 :: Ord a => a -> b -> T a b -- YES, b is unconstrained, even
2467 -- though a is existential
2468 T6 :: Int -> T Int b -- YES, b is unconstrained
2469
2470 For Foldable instances, however, we can completely lift the constraint that
2471 the last type parameter be truly universally polymorphic. This means that T
2472 (as defined above) can have a derived Foldable instance:
2473
2474 instance Foldable (T a) where
2475 foldr f z (T1 b) = f b z
2476 foldr f z (T2 b) = f b z
2477 foldr f z (T3 b) = f b z
2478 foldr f z (T4 b) = z
2479 foldr f z (T5 a b) = f b z
2480 foldr f z (T6 a) = z
2481
2482 foldMap f (T1 b) = f b
2483 foldMap f (T2 b) = f b
2484 foldMap f (T3 b) = f b
2485 foldMap f (T4 b) = mempty
2486 foldMap f (T5 a b) = f b
2487 foldMap f (T6 a) = mempty
2488
2489 In a Foldable instance, it is safe to fold over an occurrence of the last type
2490 parameter that is not truly universally polymorphic. However, there is a bit
2491 of subtlety in determining what is actually an occurrence of a type parameter.
2492 T3 and T4, as defined above, provide one example:
2493
2494 data T a b where
2495 ...
2496 T3 :: b ~ Int => b -> T a b
2497 T4 :: Int -> T a Int
2498 ...
2499
2500 instance Foldable (T a) where
2501 ...
2502 foldr f z (T3 b) = f b z
2503 foldr f z (T4 b) = z
2504 ...
2505 foldMap f (T3 b) = f b
2506 foldMap f (T4 b) = mempty
2507 ...
2508
2509 Notice that the argument of T3 is folded over, whereas the argument of T4 is
2510 not. This is because we only fold over constructor arguments that
2511 syntactically mention the universally quantified type parameter of that
2512 particular data constructor. See foldDataConArgs for how this is implemented.
2513
2514 As another example, consider the following data type. The argument of each
2515 constructor has the same type as the last type parameter:
2516
2517 data E a where
2518 E1 :: (a ~ Int) => a -> E a
2519 E2 :: Int -> E Int
2520 E3 :: (a ~ Int) => a -> E Int
2521 E4 :: (a ~ Int) => Int -> E a
2522
2523 Only E1's argument is an occurrence of a universally quantified type variable
2524 that is syntactically equivalent to the last type parameter, so only E1's
2525 argument will be be folded over in a derived Foldable instance.
2526
2527 See Trac #10447 for the original discussion on this feature. Also see
2528 https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor
2529 for a more in-depth explanation.
2530
2531 -}