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