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