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