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