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