never executed always true always false
1 {-
2 %
3 (c) The University of Glasgow 2006
4 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5
6 -}
7
8 {-# LANGUAGE ScopedTypeVariables #-}
9 {-# LANGUAGE FlexibleContexts #-}
10 {-# LANGUAGE TypeFamilies #-}
11 {-# LANGUAGE DataKinds #-}
12
13 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
14
15 -- | Generating derived instance declarations
16 --
17 -- This module is nominally ``subordinate'' to "GHC.Tc.Deriv", which is the
18 -- ``official'' interface to deriving-related things.
19 --
20 -- This is where we do all the grimy bindings' generation.
21 module GHC.Tc.Deriv.Generate (
22 BagDerivStuff, DerivStuff(..),
23
24 gen_Eq_binds,
25 gen_Ord_binds,
26 gen_Enum_binds,
27 gen_Bounded_binds,
28 gen_Ix_binds,
29 gen_Show_binds,
30 gen_Read_binds,
31 gen_Data_binds,
32 gen_Lift_binds,
33 gen_Newtype_binds,
34 mkCoerceClassMethEqn,
35 genAuxBinds,
36 ordOpTbl, boxConTbl, litConTbl,
37 mkRdrFunBind, mkRdrFunBindEC, mkRdrFunBindSE, error_Expr,
38
39 getPossibleDataCons, tyConInstArgTys
40 ) where
41
42 import GHC.Prelude
43
44 import GHC.Tc.Utils.Monad
45 import GHC.Hs
46 import GHC.Types.Name.Reader
47 import GHC.Types.Basic
48 import GHC.Types.Fixity
49 import GHC.Core.DataCon
50 import GHC.Types.Name
51 import GHC.Types.SourceText
52
53 import GHC.Driver.Session
54 import GHC.Builtin.Utils
55 import GHC.Tc.Instance.Family
56 import GHC.Core.FamInstEnv
57 import GHC.Builtin.Names
58 import GHC.Builtin.Names.TH
59 import GHC.Types.Id.Make ( coerceId )
60 import GHC.Builtin.PrimOps
61 import GHC.Types.SrcLoc
62 import GHC.Core.TyCon
63 import GHC.Tc.Utils.Env
64 import GHC.Tc.Utils.TcType
65 import GHC.Tc.Validity ( checkValidCoAxBranch )
66 import GHC.Core.Coercion.Axiom ( coAxiomSingleBranch )
67 import GHC.Builtin.Types.Prim
68 import GHC.Builtin.Types
69 import GHC.Core.Type
70 import GHC.Core.Multiplicity
71 import GHC.Core.Class
72 import GHC.Types.Var.Set
73 import GHC.Types.Var.Env
74 import GHC.Utils.Misc
75 import GHC.Types.Var
76 import GHC.Utils.Outputable
77 import GHC.Utils.Panic
78 import GHC.Utils.Panic.Plain
79 import GHC.Utils.Lexeme
80 import GHC.Data.FastString
81 import GHC.Data.Pair
82 import GHC.Data.Bag
83
84 import Data.List ( find, partition, intersperse )
85 import GHC.Data.Maybe ( expectJust )
86 import GHC.Unit.Module
87
88 type BagDerivStuff = Bag DerivStuff
89
90 -- | A declarative description of an auxiliary binding that should be
91 -- generated. See @Note [Auxiliary binders]@ for a more detailed description
92 -- of how these are used.
93 data AuxBindSpec
94 -- DerivTag2Con, and DerivMaxTag are used in derived Eq, Ord,
95 -- Enum, and Ix instances.
96 -- All these generate ZERO-BASED tag operations
97 -- I.e first constructor has tag 0
98
99 -- | @$tag2con@: Given a tag, computes the corresponding data constructor
100 = DerivTag2Con
101 TyCon -- The type constructor of the data type to which the
102 -- constructors belong
103 RdrName -- The to-be-generated $tag2con binding's RdrName
104
105 -- | @$maxtag@: The maximum possible tag value among a data type's
106 -- constructors
107 | DerivMaxTag
108 TyCon -- The type constructor of the data type to which the
109 -- constructors belong
110 RdrName -- The to-be-generated $maxtag binding's RdrName
111
112 -- DerivDataDataType and DerivDataConstr are only used in derived Data
113 -- instances
114
115 -- | @$t@: The @DataType@ representation for a @Data@ instance
116 | DerivDataDataType
117 TyCon -- The type constructor of the data type to be represented
118 RdrName -- The to-be-generated $t binding's RdrName
119 [RdrName] -- The RdrNames of the to-be-generated $c bindings for each
120 -- data constructor. These are only used on the RHS of the
121 -- to-be-generated $t binding.
122
123 -- | @$c@: The @Constr@ representation for a @Data@ instance
124 | DerivDataConstr
125 DataCon -- The data constructor to be represented
126 RdrName -- The to-be-generated $c binding's RdrName
127 RdrName -- The RdrName of the to-be-generated $t binding for the parent
128 -- data type. This is only used on the RHS of the
129 -- to-be-generated $c binding.
130
131 -- | Retrieve the 'RdrName' of the binding that the supplied 'AuxBindSpec'
132 -- describes.
133 auxBindSpecRdrName :: AuxBindSpec -> RdrName
134 auxBindSpecRdrName (DerivTag2Con _ tag2con_RDR) = tag2con_RDR
135 auxBindSpecRdrName (DerivMaxTag _ maxtag_RDR) = maxtag_RDR
136 auxBindSpecRdrName (DerivDataDataType _ dataT_RDR _) = dataT_RDR
137 auxBindSpecRdrName (DerivDataConstr _ dataC_RDR _) = dataC_RDR
138
139 data DerivStuff -- Please add this auxiliary stuff
140 = DerivAuxBind AuxBindSpec
141 -- ^ A new, top-level auxiliary binding. Used for deriving 'Eq', 'Ord',
142 -- 'Enum', 'Ix', and 'Data'. See Note [Auxiliary binders].
143
144 -- Generics and DeriveAnyClass
145 | DerivFamInst FamInst -- New type family instances
146 -- ^ A new type family instance. Used for:
147 --
148 -- * @DeriveGeneric@, which generates instances of @Rep(1)@
149 --
150 -- * @DeriveAnyClass@, which can fill in associated type family defaults
151 --
152 -- * @GeneralizedNewtypeDeriving@, which generates instances of associated
153 -- type families for newtypes
154
155
156 {-
157 ************************************************************************
158 * *
159 Eq instances
160 * *
161 ************************************************************************
162
163 Here are the heuristics for the code we generate for @Eq@. Let's
164 assume we have a data type with some (possibly zero) nullary data
165 constructors and some ordinary, non-nullary ones (the rest, also
166 possibly zero of them). Here's an example, with both \tr{N}ullary and
167 \tr{O}rdinary data cons.
168
169 data Foo ... = N1 | N2 ... | Nn | O1 a b | O2 Int | O3 Double b b | ...
170
171 * For the ordinary constructors (if any), we emit clauses to do The
172 Usual Thing, e.g.,:
173
174 (==) (O1 a1 b1) (O1 a2 b2) = a1 == a2 && b1 == b2
175 (==) (O2 a1) (O2 a2) = a1 == a2
176 (==) (O3 a1 b1 c1) (O3 a2 b2 c2) = a1 == a2 && b1 == b2 && c1 == c2
177
178 Note: if we're comparing unlifted things, e.g., if 'a1' and
179 'a2' are Float#s, then we have to generate
180 case (a1 `eqFloat#` a2) of r -> r
181 for that particular test.
182
183 * For nullary constructors, we emit a
184 catch-all clause of the form:
185
186 (==) a b = case (dataToTag# a) of { a# ->
187 case (dataToTag# b) of { b# ->
188 case (a# ==# b#) of {
189 r -> r }}}
190
191 An older approach preferred regular pattern matches in some cases
192 but with dataToTag# forcing it's argument, and work on improving
193 join points, this seems no longer necessary.
194
195 * If there aren't any nullary constructors, we emit a simpler
196 catch-all:
197
198 (==) a b = False
199
200 * For the @(/=)@ method, we normally just use the default method.
201 If the type is an enumeration type, we could/may/should? generate
202 special code that calls @dataToTag#@, much like for @(==)@ shown
203 above.
204
205 We thought about doing this: If we're also deriving 'Ord' for this
206 tycon, we generate:
207 instance ... Eq (Foo ...) where
208 (==) a b = case (compare a b) of { _LT -> False; _EQ -> True ; _GT -> False}
209 (/=) a b = case (compare a b) of { _LT -> True ; _EQ -> False; _GT -> True }
210 However, that requires that (Ord <whatever>) was put in the context
211 for the instance decl, which it probably wasn't, so the decls
212 produced don't get through the typechecker.
213 -}
214
215 gen_Eq_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
216 gen_Eq_binds loc tycon tycon_args = do
217 return (method_binds, emptyBag)
218 where
219 all_cons = getPossibleDataCons tycon tycon_args
220 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon all_cons
221
222 -- For nullary constructors, use the getTag stuff.
223 (tag_match_cons, pat_match_cons) = (nullary_cons, non_nullary_cons)
224 no_tag_match_cons = null tag_match_cons
225
226 -- (LHS patterns, result)
227 fall_through_eqn :: [([LPat (GhcPass 'Parsed)] , LHsExpr GhcPs)]
228 fall_through_eqn
229 | no_tag_match_cons -- All constructors have arguments
230 = case pat_match_cons of
231 [] -> [] -- No constructors; no fall-though case
232 [_] -> [] -- One constructor; no fall-though case
233 _ -> -- Two or more constructors; add fall-through of
234 -- (==) _ _ = False
235 [([nlWildPat, nlWildPat], false_Expr)]
236
237 | otherwise -- One or more tag_match cons; add fall-through of
238 -- extract tags compare for equality,
239 -- The case `(C1 x) == (C1 y)` can no longer happen
240 -- at this point as it's matched earlier.
241 = [([a_Pat, b_Pat],
242 untag_Expr [(a_RDR,ah_RDR), (b_RDR,bh_RDR)]
243 (genPrimOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))]
244
245 method_binds = unitBag eq_bind
246 eq_bind
247 = mkFunBindEC 2 loc eq_RDR (const true_Expr)
248 (map pats_etc pat_match_cons
249 ++ fall_through_eqn)
250
251 ------------------------------------------------------------------
252 pats_etc data_con
253 = let
254 con1_pat = nlParPat $ nlConVarPat data_con_RDR as_needed
255 con2_pat = nlParPat $ nlConVarPat data_con_RDR bs_needed
256
257 data_con_RDR = getRdrName data_con
258 con_arity = length tys_needed
259 as_needed = take con_arity as_RDRs
260 bs_needed = take con_arity bs_RDRs
261 tys_needed = dataConOrigArgTys data_con
262 in
263 ([con1_pat, con2_pat], nested_eq_expr (map scaledThing tys_needed) as_needed bs_needed)
264 where
265 nested_eq_expr [] [] [] = true_Expr
266 nested_eq_expr tys as bs
267 = foldr1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs)
268 -- Using 'foldr1' here ensures that the derived code is correctly
269 -- associated. See #10859.
270 where
271 nested_eq ty a b = nlHsPar (eq_Expr ty (nlHsVar a) (nlHsVar b))
272
273 {-
274 ************************************************************************
275 * *
276 Ord instances
277 * *
278 ************************************************************************
279
280 Note [Generating Ord instances]
281 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
282 Suppose constructors are K1..Kn, and some are nullary.
283 The general form we generate is:
284
285 * Do case on first argument
286 case a of
287 K1 ... -> rhs_1
288 K2 ... -> rhs_2
289 ...
290 Kn ... -> rhs_n
291 _ -> nullary_rhs
292
293 * To make rhs_i
294 If i = 1, 2, n-1, n, generate a single case.
295 rhs_2 case b of
296 K1 {} -> LT
297 K2 ... -> ...eq_rhs(K2)...
298 _ -> GT
299
300 Otherwise do a tag compare against the bigger range
301 (because this is the one most likely to succeed)
302 rhs_3 case tag b of tb ->
303 if 3 <# tg then GT
304 else case b of
305 K3 ... -> ...eq_rhs(K3)....
306 _ -> LT
307
308 * To make eq_rhs(K), which knows that
309 a = K a1 .. av
310 b = K b1 .. bv
311 we just want to compare (a1,b1) then (a2,b2) etc.
312 Take care on the last field to tail-call into comparing av,bv
313
314 * To make nullary_rhs generate this
315 case dataToTag# a of a# ->
316 case dataToTag# b of ->
317 a# `compare` b#
318
319 Several special cases:
320
321 * Two or fewer nullary constructors: don't generate nullary_rhs
322
323 * Be careful about unlifted comparisons. When comparing unboxed
324 values we can't call the overloaded functions.
325 See function unliftedOrdOp
326
327 Note [Game plan for deriving Ord]
328 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
329 It's a bad idea to define only 'compare', and build the other binary
330 comparisons on top of it; see #2130, #4019. Reason: we don't
331 want to laboriously make a three-way comparison, only to extract a
332 binary result, something like this:
333 (>) (I# x) (I# y) = case <# x y of
334 True -> False
335 False -> case ==# x y of
336 True -> False
337 False -> True
338
339 This being said, we can get away with generating full code only for
340 'compare' and '<' thus saving us generation of other three operators.
341 Other operators can be cheaply expressed through '<':
342 a <= b = not $ b < a
343 a > b = b < a
344 a >= b = not $ a < b
345
346 So for sufficiently small types (few constructors, or all nullary)
347 we generate all methods; for large ones we just use 'compare'.
348
349 -}
350
351 data OrdOp = OrdCompare | OrdLT | OrdLE | OrdGE | OrdGT
352
353 ------------
354 ordMethRdr :: OrdOp -> RdrName
355 ordMethRdr op
356 = case op of
357 OrdCompare -> compare_RDR
358 OrdLT -> lt_RDR
359 OrdLE -> le_RDR
360 OrdGE -> ge_RDR
361 OrdGT -> gt_RDR
362
363 ------------
364 ltResult :: OrdOp -> LHsExpr GhcPs
365 -- Knowing a<b, what is the result for a `op` b?
366 ltResult OrdCompare = ltTag_Expr
367 ltResult OrdLT = true_Expr
368 ltResult OrdLE = true_Expr
369 ltResult OrdGE = false_Expr
370 ltResult OrdGT = false_Expr
371
372 ------------
373 eqResult :: OrdOp -> LHsExpr GhcPs
374 -- Knowing a=b, what is the result for a `op` b?
375 eqResult OrdCompare = eqTag_Expr
376 eqResult OrdLT = false_Expr
377 eqResult OrdLE = true_Expr
378 eqResult OrdGE = true_Expr
379 eqResult OrdGT = false_Expr
380
381 ------------
382 gtResult :: OrdOp -> LHsExpr GhcPs
383 -- Knowing a>b, what is the result for a `op` b?
384 gtResult OrdCompare = gtTag_Expr
385 gtResult OrdLT = false_Expr
386 gtResult OrdLE = false_Expr
387 gtResult OrdGE = true_Expr
388 gtResult OrdGT = true_Expr
389
390 ------------
391 gen_Ord_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
392 gen_Ord_binds loc tycon tycon_args = do
393 return $ if null tycon_data_cons -- No data-cons => invoke bale-out case
394 then ( unitBag $ mkFunBindEC 2 loc compare_RDR (const eqTag_Expr) []
395 , emptyBag)
396 else ( unitBag (mkOrdOp OrdCompare)
397 `unionBags` other_ops
398 , aux_binds)
399 where
400 aux_binds = emptyBag
401
402 -- Note [Game plan for deriving Ord]
403 other_ops
404 | (last_tag - first_tag) <= 2 -- 1-3 constructors
405 || null non_nullary_cons -- Or it's an enumeration
406 = listToBag [mkOrdOp OrdLT, lE, gT, gE]
407 | otherwise
408 = emptyBag
409
410 negate_expr = nlHsApp (nlHsVar not_RDR)
411 lE = mkSimpleGeneratedFunBind loc le_RDR [a_Pat, b_Pat] $
412 negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr)
413 gT = mkSimpleGeneratedFunBind loc gt_RDR [a_Pat, b_Pat] $
414 nlHsApp (nlHsApp (nlHsVar lt_RDR) b_Expr) a_Expr
415 gE = mkSimpleGeneratedFunBind loc ge_RDR [a_Pat, b_Pat] $
416 negate_expr (nlHsApp (nlHsApp (nlHsVar lt_RDR) a_Expr) b_Expr)
417
418 get_tag con = dataConTag con - fIRST_TAG
419 -- We want *zero-based* tags, because that's what
420 -- con2Tag returns (generated by untag_Expr)!
421
422 tycon_data_cons = getPossibleDataCons tycon tycon_args
423 single_con_type = isSingleton tycon_data_cons
424 (first_con : _) = tycon_data_cons
425 (last_con : _) = reverse tycon_data_cons
426 first_tag = get_tag first_con
427 last_tag = get_tag last_con
428
429 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon tycon_data_cons
430
431
432 mkOrdOp :: OrdOp -> LHsBind GhcPs
433 -- Returns a binding op a b = ... compares a and b according to op ....
434 mkOrdOp op
435 = mkSimpleGeneratedFunBind loc (ordMethRdr op) [a_Pat, b_Pat]
436 (mkOrdOpRhs op)
437
438 mkOrdOpRhs :: OrdOp -> LHsExpr GhcPs
439 mkOrdOpRhs op -- RHS for comparing 'a' and 'b' according to op
440 | nullary_cons `lengthAtMost` 2 -- Two nullary or fewer, so use cases
441 = nlHsCase (nlHsVar a_RDR) $
442 map (mkOrdOpAlt op) tycon_data_cons
443 -- i.e. case a of { C1 x y -> case b of C1 x y -> ....compare x,y...
444 -- C2 x -> case b of C2 x -> ....comopare x.... }
445
446 | null non_nullary_cons -- All nullary, so go straight to comparing tags
447 = mkTagCmp op
448
449 | otherwise -- Mixed nullary and non-nullary
450 = nlHsCase (nlHsVar a_RDR) $
451 (map (mkOrdOpAlt op) non_nullary_cons
452 ++ [mkHsCaseAlt nlWildPat (mkTagCmp op)])
453
454
455 mkOrdOpAlt :: OrdOp -> DataCon
456 -> LMatch GhcPs (LHsExpr GhcPs)
457 -- Make the alternative (Ki a1 a2 .. av ->
458 mkOrdOpAlt op data_con
459 = mkHsCaseAlt (nlConVarPat data_con_RDR as_needed)
460 (mkInnerRhs op data_con)
461 where
462 as_needed = take (dataConSourceArity data_con) as_RDRs
463 data_con_RDR = getRdrName data_con
464
465 mkInnerRhs op data_con
466 | single_con_type
467 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con ]
468
469 | tag == first_tag
470 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
471 , mkHsCaseAlt nlWildPat (ltResult op) ]
472 | tag == last_tag
473 = nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
474 , mkHsCaseAlt nlWildPat (gtResult op) ]
475
476 | tag == first_tag + 1
477 = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat first_con)
478 (gtResult op)
479 , mkInnerEqAlt op data_con
480 , mkHsCaseAlt nlWildPat (ltResult op) ]
481 | tag == last_tag - 1
482 = nlHsCase (nlHsVar b_RDR) [ mkHsCaseAlt (nlConWildPat last_con)
483 (ltResult op)
484 , mkInnerEqAlt op data_con
485 , mkHsCaseAlt nlWildPat (gtResult op) ]
486
487 | tag > last_tag `div` 2 -- lower range is larger
488 = untag_Expr [(b_RDR, bh_RDR)] $
489 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) ltInt_RDR tag_lit)
490 (gtResult op) $ -- Definitely GT
491 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
492 , mkHsCaseAlt nlWildPat (ltResult op) ]
493
494 | otherwise -- upper range is larger
495 = untag_Expr [(b_RDR, bh_RDR)] $
496 nlHsIf (genPrimOpApp (nlHsVar bh_RDR) gtInt_RDR tag_lit)
497 (ltResult op) $ -- Definitely LT
498 nlHsCase (nlHsVar b_RDR) [ mkInnerEqAlt op data_con
499 , mkHsCaseAlt nlWildPat (gtResult op) ]
500 where
501 tag = get_tag data_con
502 tag_lit
503 = noLocA (HsLit noComments (HsIntPrim NoSourceText (toInteger tag)))
504
505 mkInnerEqAlt :: OrdOp -> DataCon -> LMatch GhcPs (LHsExpr GhcPs)
506 -- First argument 'a' known to be built with K
507 -- Returns a case alternative Ki b1 b2 ... bv -> compare (a1,a2,...) with (b1,b2,...)
508 mkInnerEqAlt op data_con
509 = mkHsCaseAlt (nlConVarPat data_con_RDR bs_needed) $
510 mkCompareFields op (map scaledThing $ dataConOrigArgTys data_con)
511 where
512 data_con_RDR = getRdrName data_con
513 bs_needed = take (dataConSourceArity data_con) bs_RDRs
514
515 mkTagCmp :: OrdOp -> LHsExpr GhcPs
516 -- Both constructors known to be nullary
517 -- generates (case data2Tag a of a# -> case data2Tag b of b# -> a# `op` b#
518 mkTagCmp op =
519 untag_Expr [(a_RDR, ah_RDR),(b_RDR, bh_RDR)] $
520 unliftedOrdOp intPrimTy op ah_RDR bh_RDR
521
522 mkCompareFields :: OrdOp -> [Type] -> LHsExpr GhcPs
523 -- Generates nested comparisons for (a1,a2...) against (b1,b2,...)
524 -- where the ai,bi have the given types
525 mkCompareFields op tys
526 = go tys as_RDRs bs_RDRs
527 where
528 go [] _ _ = eqResult op
529 go [ty] (a:_) (b:_)
530 | isUnliftedType ty = unliftedOrdOp ty op a b
531 | otherwise = genOpApp (nlHsVar a) (ordMethRdr op) (nlHsVar b)
532 go (ty:tys) (a:as) (b:bs) = mk_compare ty a b
533 (ltResult op)
534 (go tys as bs)
535 (gtResult op)
536 go _ _ _ = panic "mkCompareFields"
537
538 -- (mk_compare ty a b) generates
539 -- (case (compare a b) of { LT -> <lt>; EQ -> <eq>; GT -> <bt> })
540 -- but with suitable special cases for
541 mk_compare ty a b lt eq gt
542 | isUnliftedType ty
543 = unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
544 | otherwise
545 = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a_expr) b_expr))
546 [mkHsCaseAlt (nlNullaryConPat ltTag_RDR) lt,
547 mkHsCaseAlt (nlNullaryConPat eqTag_RDR) eq,
548 mkHsCaseAlt (nlNullaryConPat gtTag_RDR) gt]
549 where
550 a_expr = nlHsVar a
551 b_expr = nlHsVar b
552 (lt_op, _, eq_op, _, _) = primOrdOps "Ord" ty
553
554 unliftedOrdOp :: Type -> OrdOp -> RdrName -> RdrName -> LHsExpr GhcPs
555 unliftedOrdOp ty op a b
556 = case op of
557 OrdCompare -> unliftedCompare lt_op eq_op a_expr b_expr
558 ltTag_Expr eqTag_Expr gtTag_Expr
559 OrdLT -> wrap lt_op
560 OrdLE -> wrap le_op
561 OrdGE -> wrap ge_op
562 OrdGT -> wrap gt_op
563 where
564 (lt_op, le_op, eq_op, ge_op, gt_op) = primOrdOps "Ord" ty
565 wrap prim_op = genPrimOpApp a_expr prim_op b_expr
566 a_expr = nlHsVar a
567 b_expr = nlHsVar b
568
569 unliftedCompare :: RdrName -> RdrName
570 -> LHsExpr GhcPs -> LHsExpr GhcPs -- What to compare
571 -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
572 -- Three results
573 -> LHsExpr GhcPs
574 -- Return (if a < b then lt else if a == b then eq else gt)
575 unliftedCompare lt_op eq_op a_expr b_expr lt eq gt
576 = nlHsIf (ascribeBool $ genPrimOpApp a_expr lt_op b_expr) lt $
577 -- Test (<) first, not (==), because the latter
578 -- is true less often, so putting it first would
579 -- mean more tests (dynamically)
580 nlHsIf (ascribeBool $ genPrimOpApp a_expr eq_op b_expr) eq gt
581 where
582 ascribeBool e = noLocA $ ExprWithTySig noAnn e
583 $ mkHsWildCardBndrs $ noLocA $ mkHsImplicitSigType
584 $ nlHsTyVar boolTyCon_RDR
585
586 nlConWildPat :: DataCon -> LPat GhcPs
587 -- The pattern (K {})
588 nlConWildPat con = noLocA $ ConPat
589 { pat_con_ext = noAnn
590 , pat_con = noLocA $ getRdrName con
591 , pat_args = RecCon $ HsRecFields
592 { rec_flds = []
593 , rec_dotdot = Nothing }
594 }
595
596 {-
597 ************************************************************************
598 * *
599 Enum instances
600 * *
601 ************************************************************************
602
603 @Enum@ can only be derived for enumeration types. For a type
604 \begin{verbatim}
605 data Foo ... = N1 | N2 | ... | Nn
606 \end{verbatim}
607
608 we use both dataToTag# and @tag2con_Foo@ functions, as well as a
609 @maxtag_Foo@ variable, the later generated by @gen_tag_n_con_binds.
610
611 \begin{verbatim}
612 instance ... Enum (Foo ...) where
613 succ x = toEnum (1 + fromEnum x)
614 pred x = toEnum (fromEnum x - 1)
615
616 toEnum i = tag2con_Foo i
617
618 enumFrom a = map tag2con_Foo [dataToTag# a .. maxtag_Foo]
619
620 -- or, really...
621 enumFrom a
622 = case dataToTag# a of
623 a# -> map tag2con_Foo (enumFromTo (I# a#) maxtag_Foo)
624
625 enumFromThen a b
626 = map tag2con_Foo [dataToTag# a, dataToTag# b .. maxtag_Foo]
627
628 -- or, really...
629 enumFromThen a b
630 = case dataToTag# a of { a# ->
631 case dataToTag# b of { b# ->
632 map tag2con_Foo (enumFromThenTo (I# a#) (I# b#) maxtag_Foo)
633 }}
634 \end{verbatim}
635
636 For @enumFromTo@ and @enumFromThenTo@, we use the default methods.
637 -}
638
639 gen_Enum_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
640 gen_Enum_binds loc tycon _ = do
641 -- See Note [Auxiliary binders]
642 tag2con_RDR <- new_tag2con_rdr_name loc tycon
643 maxtag_RDR <- new_maxtag_rdr_name loc tycon
644
645 return ( method_binds tag2con_RDR maxtag_RDR
646 , aux_binds tag2con_RDR maxtag_RDR )
647 where
648 method_binds tag2con_RDR maxtag_RDR = listToBag
649 [ succ_enum tag2con_RDR maxtag_RDR
650 , pred_enum tag2con_RDR
651 , to_enum tag2con_RDR maxtag_RDR
652 , enum_from tag2con_RDR maxtag_RDR -- [0 ..]
653 , enum_from_then tag2con_RDR maxtag_RDR -- [0, 1 ..]
654 , from_enum
655 ]
656 aux_binds tag2con_RDR maxtag_RDR = listToBag $ map DerivAuxBind
657 [ DerivTag2Con tycon tag2con_RDR
658 , DerivMaxTag tycon maxtag_RDR
659 ]
660
661 occ_nm = getOccString tycon
662
663 succ_enum tag2con_RDR maxtag_RDR
664 = mkSimpleGeneratedFunBind loc succ_RDR [a_Pat] $
665 untag_Expr [(a_RDR, ah_RDR)] $
666 nlHsIf (nlHsApps eq_RDR [nlHsVar maxtag_RDR,
667 nlHsVarApps intDataCon_RDR [ah_RDR]])
668 (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration")
669 (nlHsApp (nlHsVar tag2con_RDR)
670 (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
671 nlHsIntLit 1]))
672
673 pred_enum tag2con_RDR
674 = mkSimpleGeneratedFunBind loc pred_RDR [a_Pat] $
675 untag_Expr [(a_RDR, ah_RDR)] $
676 nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0,
677 nlHsVarApps intDataCon_RDR [ah_RDR]])
678 (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration")
679 (nlHsApp (nlHsVar tag2con_RDR)
680 (nlHsApps plus_RDR
681 [ nlHsVarApps intDataCon_RDR [ah_RDR]
682 , nlHsLit (HsInt noExtField
683 (mkIntegralLit (-1 :: Int)))]))
684
685 to_enum tag2con_RDR maxtag_RDR
686 = mkSimpleGeneratedFunBind loc toEnum_RDR [a_Pat] $
687 nlHsIf (nlHsApps and_RDR
688 [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0],
689 nlHsApps le_RDR [ nlHsVar a_RDR
690 , nlHsVar maxtag_RDR]])
691 (nlHsVarApps tag2con_RDR [a_RDR])
692 (illegal_toEnum_tag occ_nm maxtag_RDR)
693
694 enum_from tag2con_RDR maxtag_RDR
695 = mkSimpleGeneratedFunBind loc enumFrom_RDR [a_Pat] $
696 untag_Expr [(a_RDR, ah_RDR)] $
697 nlHsApps map_RDR
698 [nlHsVar tag2con_RDR,
699 nlHsPar (enum_from_to_Expr
700 (nlHsVarApps intDataCon_RDR [ah_RDR])
701 (nlHsVar maxtag_RDR))]
702
703 enum_from_then tag2con_RDR maxtag_RDR
704 = mkSimpleGeneratedFunBind loc enumFromThen_RDR [a_Pat, b_Pat] $
705 untag_Expr [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $
706 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
707 nlHsPar (enum_from_then_to_Expr
708 (nlHsVarApps intDataCon_RDR [ah_RDR])
709 (nlHsVarApps intDataCon_RDR [bh_RDR])
710 (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR],
711 nlHsVarApps intDataCon_RDR [bh_RDR]])
712 (nlHsIntLit 0)
713 (nlHsVar maxtag_RDR)
714 ))
715
716 from_enum
717 = mkSimpleGeneratedFunBind loc fromEnum_RDR [a_Pat] $
718 untag_Expr [(a_RDR, ah_RDR)] $
719 (nlHsVarApps intDataCon_RDR [ah_RDR])
720
721 {-
722 ************************************************************************
723 * *
724 Bounded instances
725 * *
726 ************************************************************************
727 -}
728
729 gen_Bounded_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
730 gen_Bounded_binds loc tycon _
731 | isEnumerationTyCon tycon
732 = (listToBag [ min_bound_enum, max_bound_enum ], emptyBag)
733 | otherwise
734 = assert (isSingleton data_cons)
735 (listToBag [ min_bound_1con, max_bound_1con ], emptyBag)
736 where
737 data_cons = tyConDataCons tycon
738
739 ----- enum-flavored: ---------------------------
740 min_bound_enum = mkHsVarBind loc minBound_RDR (nlHsVar data_con_1_RDR)
741 max_bound_enum = mkHsVarBind loc maxBound_RDR (nlHsVar data_con_N_RDR)
742
743 data_con_1 = head data_cons
744 data_con_N = last data_cons
745 data_con_1_RDR = getRdrName data_con_1
746 data_con_N_RDR = getRdrName data_con_N
747
748 ----- single-constructor-flavored: -------------
749 arity = dataConSourceArity data_con_1
750
751 min_bound_1con = mkHsVarBind loc minBound_RDR $
752 nlHsVarApps data_con_1_RDR (replicate arity minBound_RDR)
753 max_bound_1con = mkHsVarBind loc maxBound_RDR $
754 nlHsVarApps data_con_1_RDR (replicate arity maxBound_RDR)
755
756 {-
757 ************************************************************************
758 * *
759 Ix instances
760 * *
761 ************************************************************************
762
763 Deriving @Ix@ is only possible for enumeration types and
764 single-constructor types. We deal with them in turn.
765
766 For an enumeration type, e.g.,
767 \begin{verbatim}
768 data Foo ... = N1 | N2 | ... | Nn
769 \end{verbatim}
770 things go not too differently from @Enum@:
771 \begin{verbatim}
772 instance ... Ix (Foo ...) where
773 range (a, b)
774 = map tag2con_Foo [dataToTag# a .. dataToTag# b]
775
776 -- or, really...
777 range (a, b)
778 = case (dataToTag# a) of { a# ->
779 case (dataToTag# b) of { b# ->
780 map tag2con_Foo (enumFromTo (I# a#) (I# b#))
781 }}
782
783 -- Generate code for unsafeIndex, because using index leads
784 -- to lots of redundant range tests
785 unsafeIndex c@(a, b) d
786 = case (dataToTag# d -# dataToTag# a) of
787 r# -> I# r#
788
789 inRange (a, b) c
790 = let
791 p_tag = dataToTag# c
792 in
793 p_tag >= dataToTag# a && p_tag <= dataToTag# b
794
795 -- or, really...
796 inRange (a, b) c
797 = case (dataToTag# a) of { a_tag ->
798 case (dataToTag# b) of { b_tag ->
799 case (dataToTag# c) of { c_tag ->
800 if (c_tag >=# a_tag) then
801 c_tag <=# b_tag
802 else
803 False
804 }}}
805 \end{verbatim}
806 (modulo suitable case-ification to handle the unlifted tags)
807
808 For a single-constructor type (NB: this includes all tuples), e.g.,
809 \begin{verbatim}
810 data Foo ... = MkFoo a b Int Double c c
811 \end{verbatim}
812 we follow the scheme given in Figure~19 of the Haskell~1.2 report
813 (p.~147).
814 -}
815
816 gen_Ix_binds :: SrcSpan -> TyCon -> [Type] -> TcM (LHsBinds GhcPs, BagDerivStuff)
817
818 gen_Ix_binds loc tycon _ = do
819 -- See Note [Auxiliary binders]
820 tag2con_RDR <- new_tag2con_rdr_name loc tycon
821
822 return $ if isEnumerationTyCon tycon
823 then (enum_ixes tag2con_RDR, listToBag $ map DerivAuxBind
824 [ DerivTag2Con tycon tag2con_RDR
825 ])
826 else (single_con_ixes, emptyBag)
827 where
828 --------------------------------------------------------------
829 enum_ixes tag2con_RDR = listToBag
830 [ enum_range tag2con_RDR
831 , enum_index
832 , enum_inRange
833 ]
834
835 enum_range tag2con_RDR
836 = mkSimpleGeneratedFunBind loc range_RDR [nlTuplePat [a_Pat, b_Pat] Boxed] $
837 untag_Expr [(a_RDR, ah_RDR)] $
838 untag_Expr [(b_RDR, bh_RDR)] $
839 nlHsApp (nlHsVarApps map_RDR [tag2con_RDR]) $
840 nlHsPar (enum_from_to_Expr
841 (nlHsVarApps intDataCon_RDR [ah_RDR])
842 (nlHsVarApps intDataCon_RDR [bh_RDR]))
843
844 enum_index
845 = mkSimpleGeneratedFunBind loc unsafeIndex_RDR
846 [noLocA (AsPat noAnn (noLocA c_RDR)
847 (nlTuplePat [a_Pat, nlWildPat] Boxed)),
848 d_Pat] (
849 untag_Expr [(a_RDR, ah_RDR)] (
850 untag_Expr [(d_RDR, dh_RDR)] (
851 let
852 rhs = nlHsVarApps intDataCon_RDR [c_RDR]
853 in
854 nlHsCase
855 (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR))
856 [mkHsCaseAlt (nlVarPat c_RDR) rhs]
857 ))
858 )
859
860 -- This produces something like `(ch >= ah) && (ch <= bh)`
861 enum_inRange
862 = mkSimpleGeneratedFunBind loc inRange_RDR [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] $
863 untag_Expr [(a_RDR, ah_RDR)] (
864 untag_Expr [(b_RDR, bh_RDR)] (
865 untag_Expr [(c_RDR, ch_RDR)] (
866 -- This used to use `if`, which interacts badly with RebindableSyntax.
867 -- See #11396.
868 nlHsApps and_RDR
869 [ genPrimOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)
870 , genPrimOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)
871 ]
872 )))
873
874 --------------------------------------------------------------
875 single_con_ixes
876 = listToBag [single_con_range, single_con_index, single_con_inRange]
877
878 data_con
879 = case tyConSingleDataCon_maybe tycon of -- just checking...
880 Nothing -> panic "get_Ix_binds"
881 Just dc -> dc
882
883 con_arity = dataConSourceArity data_con
884 data_con_RDR = getRdrName data_con
885
886 as_needed = take con_arity as_RDRs
887 bs_needed = take con_arity bs_RDRs
888 cs_needed = take con_arity cs_RDRs
889
890 con_pat xs = nlConVarPat data_con_RDR xs
891 con_expr = nlHsVarApps data_con_RDR cs_needed
892
893 --------------------------------------------------------------
894 single_con_range
895 = mkSimpleGeneratedFunBind loc range_RDR
896 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $
897 noLocA (mkHsComp ListComp stmts con_expr)
898 where
899 stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed
900
901 mk_qual a b c = noLocA $ mkPsBindStmt noAnn (nlVarPat c)
902 (nlHsApp (nlHsVar range_RDR)
903 (mkLHsVarTuple [a,b] noAnn))
904
905 ----------------
906 single_con_index
907 = mkSimpleGeneratedFunBind loc unsafeIndex_RDR
908 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
909 con_pat cs_needed]
910 -- We need to reverse the order we consider the components in
911 -- so that
912 -- range (l,u) !! index (l,u) i == i -- when i is in range
913 -- (from http://haskell.org/onlinereport/ix.html) holds.
914 (mk_index (reverse $ zip3 as_needed bs_needed cs_needed))
915 where
916 -- index (l1,u1) i1 + rangeSize (l1,u1) * (index (l2,u2) i2 + ...)
917 mk_index [] = nlHsIntLit 0
918 mk_index [(l,u,i)] = mk_one l u i
919 mk_index ((l,u,i) : rest)
920 = genOpApp (
921 mk_one l u i
922 ) plus_RDR (
923 genOpApp (
924 (nlHsApp (nlHsVar unsafeRangeSize_RDR)
925 (mkLHsVarTuple [l,u] noAnn))
926 ) times_RDR (mk_index rest)
927 )
928 mk_one l u i
929 = nlHsApps unsafeIndex_RDR [mkLHsVarTuple [l,u] noAnn, nlHsVar i]
930
931 ------------------
932 single_con_inRange
933 = mkSimpleGeneratedFunBind loc inRange_RDR
934 [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed,
935 con_pat cs_needed] $
936 if con_arity == 0
937 -- If the product type has no fields, inRange is trivially true
938 -- (see #12853).
939 then true_Expr
940 else foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range
941 as_needed bs_needed cs_needed)
942 where
943 in_range a b c
944 = nlHsApps inRange_RDR [mkLHsVarTuple [a,b] noAnn, nlHsVar c]
945
946 {-
947 ************************************************************************
948 * *
949 Read instances
950 * *
951 ************************************************************************
952
953 Example
954
955 infix 4 %%
956 data T = Int %% Int
957 | T1 { f1 :: Int }
958 | T2 T
959
960 instance Read T where
961 readPrec =
962 parens
963 ( prec 4 (
964 do x <- ReadP.step Read.readPrec
965 expectP (Symbol "%%")
966 y <- ReadP.step Read.readPrec
967 return (x %% y))
968 +++
969 prec (appPrec+1) (
970 -- Note the "+1" part; "T2 T1 {f1=3}" should parse ok
971 -- Record construction binds even more tightly than application
972 do expectP (Ident "T1")
973 expectP (Punc '{')
974 x <- Read.readField "f1" (ReadP.reset readPrec)
975 expectP (Punc '}')
976 return (T1 { f1 = x }))
977 +++
978 prec appPrec (
979 do expectP (Ident "T2")
980 x <- ReadP.step Read.readPrec
981 return (T2 x))
982 )
983
984 readListPrec = readListPrecDefault
985 readList = readListDefault
986
987
988 Note [Use expectP]
989 ~~~~~~~~~~~~~~~~~~
990 Note that we use
991 expectP (Ident "T1")
992 rather than
993 Ident "T1" <- lexP
994 The latter desugares to inline code for matching the Ident and the
995 string, and this can be very voluminous. The former is much more
996 compact. Cf #7258, although that also concerned non-linearity in
997 the occurrence analyser, a separate issue.
998
999 Note [Read for empty data types]
1000 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1001 What should we get for this? (#7931)
1002 data Emp deriving( Read ) -- No data constructors
1003
1004 Here we want
1005 read "[]" :: [Emp] to succeed, returning []
1006 So we do NOT want
1007 instance Read Emp where
1008 readPrec = error "urk"
1009 Rather we want
1010 instance Read Emp where
1011 readPred = pfail -- Same as choose []
1012
1013 Because 'pfail' allows the parser to backtrack, but 'error' doesn't.
1014 These instances are also useful for Read (Either Int Emp), where
1015 we want to be able to parse (Left 3) just fine.
1016 -}
1017
1018 gen_Read_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
1019 -> (LHsBinds GhcPs, BagDerivStuff)
1020
1021 gen_Read_binds get_fixity loc tycon _
1022 = (listToBag [read_prec, default_readlist, default_readlistprec], emptyBag)
1023 where
1024 -----------------------------------------------------------------------
1025 default_readlist
1026 = mkHsVarBind loc readList_RDR (nlHsVar readListDefault_RDR)
1027
1028 default_readlistprec
1029 = mkHsVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR)
1030 -----------------------------------------------------------------------
1031
1032 data_cons = tyConDataCons tycon
1033 (nullary_cons, non_nullary_cons) = partition isNullarySrcDataCon data_cons
1034
1035 read_prec = mkHsVarBind loc readPrec_RDR rhs
1036 where
1037 rhs | null data_cons -- See Note [Read for empty data types]
1038 = nlHsVar pfail_RDR
1039 | otherwise
1040 = nlHsApp (nlHsVar parens_RDR)
1041 (foldr1 mk_alt (read_nullary_cons ++
1042 read_non_nullary_cons))
1043
1044 read_non_nullary_cons = map read_non_nullary_con non_nullary_cons
1045
1046 read_nullary_cons
1047 = case nullary_cons of
1048 [] -> []
1049 [con] -> [nlHsDo (DoExpr Nothing) (match_con con ++ [noLocA $ mkLastStmt (result_expr con [])])]
1050 _ -> [nlHsApp (nlHsVar choose_RDR)
1051 (nlList (map mk_pair nullary_cons))]
1052 -- NB For operators the parens around (:=:) are matched by the
1053 -- enclosing "parens" call, so here we must match the naked
1054 -- data_con_str con
1055
1056 match_con con | isSym con_str = [symbol_pat con_str]
1057 | otherwise = ident_h_pat con_str
1058 where
1059 con_str = data_con_str con
1060 -- For nullary constructors we must match Ident s for normal constrs
1061 -- and Symbol s for operators
1062
1063 mk_pair con = mkLHsTupleExpr [nlHsLit (mkHsString (data_con_str con)),
1064 result_expr con []] noAnn
1065
1066 read_non_nullary_con data_con
1067 | is_infix = mk_parser infix_prec infix_stmts body
1068 | is_record = mk_parser record_prec record_stmts body
1069 -- Using these two lines instead allows the derived
1070 -- read for infix and record bindings to read the prefix form
1071 -- | is_infix = mk_alt prefix_parser (mk_parser infix_prec infix_stmts body)
1072 -- | is_record = mk_alt prefix_parser (mk_parser record_prec record_stmts body)
1073 | otherwise = prefix_parser
1074 where
1075 body = result_expr data_con as_needed
1076 con_str = data_con_str data_con
1077
1078 prefix_parser = mk_parser prefix_prec prefix_stmts body
1079
1080 read_prefix_con
1081 | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"]
1082 | otherwise = ident_h_pat con_str
1083
1084 read_infix_con
1085 | isSym con_str = [symbol_pat con_str]
1086 | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"]
1087
1088 prefix_stmts -- T a b c
1089 = read_prefix_con ++ read_args
1090
1091 infix_stmts -- a %% b, or a `T` b
1092 = [read_a1]
1093 ++ read_infix_con
1094 ++ [read_a2]
1095
1096 record_stmts -- T { f1 = a, f2 = b }
1097 = read_prefix_con
1098 ++ [read_punc "{"]
1099 ++ concat (intersperse [read_punc ","] field_stmts)
1100 ++ [read_punc "}"]
1101
1102 field_stmts = zipWithEqual "lbl_stmts" read_field labels as_needed
1103
1104 con_arity = dataConSourceArity data_con
1105 labels = map flLabel $ dataConFieldLabels data_con
1106 dc_nm = getName data_con
1107 is_infix = dataConIsInfix data_con
1108 is_record = labels `lengthExceeds` 0
1109 as_needed = take con_arity as_RDRs
1110 read_args = zipWithEqual "gen_Read_binds" read_arg as_needed (map scaledThing $ dataConOrigArgTys data_con)
1111 (read_a1:read_a2:_) = read_args
1112
1113 prefix_prec = appPrecedence
1114 infix_prec = getPrecedence get_fixity dc_nm
1115 record_prec = appPrecedence + 1 -- Record construction binds even more tightly
1116 -- than application; e.g. T2 T1 {x=2} means T2 (T1 {x=2})
1117
1118 ------------------------------------------------------------------------
1119 -- Helpers
1120 ------------------------------------------------------------------------
1121 mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2
1122 mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b })
1123 , nlHsDo (DoExpr Nothing) (ss ++ [noLocA $ mkLastStmt b])]
1124 con_app con as = nlHsVarApps (getRdrName con) as -- con as
1125 result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as)
1126
1127 -- For constructors and field labels ending in '#', we hackily
1128 -- let the lexer generate two tokens, and look for both in sequence
1129 -- Thus [Ident "I"; Symbol "#"]. See #5041
1130 ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ]
1131 | otherwise = [ ident_pat s ]
1132
1133 bindLex pat = noLocA (mkBodyStmt (nlHsApp (nlHsVar expectP_RDR) pat)) -- expectP p
1134 -- See Note [Use expectP]
1135 ident_pat s = bindLex $ nlHsApps ident_RDR [nlHsLit (mkHsString s)] -- expectP (Ident "foo")
1136 symbol_pat s = bindLex $ nlHsApps symbol_RDR [nlHsLit (mkHsString s)] -- expectP (Symbol ">>")
1137 read_punc c = bindLex $ nlHsApps punc_RDR [nlHsLit (mkHsString c)] -- expectP (Punc "<")
1138
1139 data_con_str con = occNameString (getOccName con)
1140
1141 read_arg a ty = assert (not (isUnliftedType ty)) $
1142 noLocA (mkPsBindStmt noAnn (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]))
1143
1144 -- When reading field labels we might encounter
1145 -- a = 3
1146 -- _a = 3
1147 -- or (#) = 4
1148 -- Note the parens!
1149 read_field lbl a =
1150 [noLocA
1151 (mkPsBindStmt noAnn
1152 (nlVarPat a)
1153 (nlHsApp
1154 read_field
1155 (nlHsVarApps reset_RDR [readPrec_RDR])
1156 )
1157 )
1158 ]
1159 where
1160 lbl_str = unpackFS lbl
1161 mk_read_field read_field_rdr lbl
1162 = nlHsApps read_field_rdr [nlHsLit (mkHsString lbl)]
1163 read_field
1164 | isSym lbl_str
1165 = mk_read_field readSymField_RDR lbl_str
1166 | Just (ss, '#') <- snocView lbl_str -- #14918
1167 = mk_read_field readFieldHash_RDR ss
1168 | otherwise
1169 = mk_read_field readField_RDR lbl_str
1170
1171 {-
1172 ************************************************************************
1173 * *
1174 Show instances
1175 * *
1176 ************************************************************************
1177
1178 Example
1179
1180 infixr 5 :^:
1181
1182 data Tree a = Leaf a | Tree a :^: Tree a
1183
1184 instance (Show a) => Show (Tree a) where
1185
1186 showsPrec d (Leaf m) = showParen (d > app_prec) showStr
1187 where
1188 showStr = showString "Leaf " . showsPrec (app_prec+1) m
1189
1190 showsPrec d (u :^: v) = showParen (d > up_prec) showStr
1191 where
1192 showStr = showsPrec (up_prec+1) u .
1193 showString " :^: " .
1194 showsPrec (up_prec+1) v
1195 -- Note: right-associativity of :^: ignored
1196
1197 up_prec = 5 -- Precedence of :^:
1198 app_prec = 10 -- Application has precedence one more than
1199 -- the most tightly-binding operator
1200 -}
1201
1202 gen_Show_binds :: (Name -> Fixity) -> SrcSpan -> TyCon -> [Type]
1203 -> (LHsBinds GhcPs, BagDerivStuff)
1204
1205 gen_Show_binds get_fixity loc tycon tycon_args
1206 = (unitBag shows_prec, emptyBag)
1207 where
1208 data_cons = getPossibleDataCons tycon tycon_args
1209 shows_prec = mkFunBindEC 2 loc showsPrec_RDR id (map pats_etc data_cons)
1210 comma_space = nlHsVar showCommaSpace_RDR
1211
1212 pats_etc data_con
1213 | nullary_con = -- skip the showParen junk...
1214 assert (null bs_needed)
1215 ([nlWildPat, con_pat], mk_showString_app op_con_str)
1216 | otherwise =
1217 ([a_Pat, con_pat],
1218 showParen_Expr (genOpApp a_Expr ge_RDR (nlHsLit
1219 (HsInt noExtField (mkIntegralLit con_prec_plus_one))))
1220 (nlHsPar (nested_compose_Expr show_thingies)))
1221 where
1222 data_con_RDR = getRdrName data_con
1223 con_arity = dataConSourceArity data_con
1224 bs_needed = take con_arity bs_RDRs
1225 arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed
1226 con_pat = nlConVarPat data_con_RDR bs_needed
1227 nullary_con = con_arity == 0
1228 labels = map flLabel $ dataConFieldLabels data_con
1229 lab_fields = length labels
1230 record_syntax = lab_fields > 0
1231
1232 dc_nm = getName data_con
1233 dc_occ_nm = getOccName data_con
1234 con_str = occNameString dc_occ_nm
1235 op_con_str = wrapOpParens con_str
1236 backquote_str = wrapOpBackquotes con_str
1237
1238 show_thingies
1239 | is_infix = [show_arg1, mk_showString_app (" " ++ backquote_str ++ " "), show_arg2]
1240 | record_syntax = mk_showString_app (op_con_str ++ " {") :
1241 show_record_args ++ [mk_showString_app "}"]
1242 | otherwise = mk_showString_app (op_con_str ++ " ") : show_prefix_args
1243
1244 show_label l = mk_showString_app (nm ++ " = ")
1245 -- Note the spaces around the "=" sign. If we
1246 -- don't have them then we get Foo { x=-1 } and
1247 -- the "=-" parses as a single lexeme. Only the
1248 -- space after the '=' is necessary, but it
1249 -- seems tidier to have them both sides.
1250 where
1251 nm = wrapOpParens (unpackFS l)
1252
1253 show_args = zipWithEqual "gen_Show_binds" show_arg bs_needed (map scaledThing arg_tys)
1254 (show_arg1:show_arg2:_) = show_args
1255 show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args
1256
1257 -- Assumption for record syntax: no of fields == no of
1258 -- labelled fields (and in same order)
1259 show_record_args = concat $
1260 intersperse [comma_space] $
1261 [ [show_label lbl, arg]
1262 | (lbl,arg) <- zipEqual "gen_Show_binds"
1263 labels show_args ]
1264
1265 show_arg :: RdrName -> Type -> LHsExpr GhcPs
1266 show_arg b arg_ty
1267 | isUnliftedType arg_ty
1268 -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
1269 = with_conv $
1270 nlHsApps compose_RDR
1271 [mk_shows_app boxed_arg, mk_showString_app postfixMod]
1272 | otherwise
1273 = mk_showsPrec_app arg_prec arg
1274 where
1275 arg = nlHsVar b
1276 boxed_arg = box "Show" arg arg_ty
1277 postfixMod = assoc_ty_id "Show" postfixModTbl arg_ty
1278 with_conv expr
1279 | (Just conv) <- assoc_ty_id_maybe primConvTbl arg_ty =
1280 nested_compose_Expr
1281 [ mk_showString_app ("(" ++ conv ++ " ")
1282 , expr
1283 , mk_showString_app ")"
1284 ]
1285 | otherwise = expr
1286
1287 -- Fixity stuff
1288 is_infix = dataConIsInfix data_con
1289 con_prec_plus_one = 1 + getPrec is_infix get_fixity dc_nm
1290 arg_prec | record_syntax = 0 -- Record fields don't need parens
1291 | otherwise = con_prec_plus_one
1292
1293 wrapOpParens :: String -> String
1294 wrapOpParens s | isSym s = '(' : s ++ ")"
1295 | otherwise = s
1296
1297 wrapOpBackquotes :: String -> String
1298 wrapOpBackquotes s | isSym s = s
1299 | otherwise = '`' : s ++ "`"
1300
1301 isSym :: String -> Bool
1302 isSym "" = False
1303 isSym (c : _) = startsVarSym c || startsConSym c
1304
1305 -- | showString :: String -> ShowS
1306 mk_showString_app :: String -> LHsExpr GhcPs
1307 mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str))
1308
1309 -- | showsPrec :: Show a => Int -> a -> ShowS
1310 mk_showsPrec_app :: Integer -> LHsExpr GhcPs -> LHsExpr GhcPs
1311 mk_showsPrec_app p x
1312 = nlHsApps showsPrec_RDR [nlHsLit (HsInt noExtField (mkIntegralLit p)), x]
1313
1314 -- | shows :: Show a => a -> ShowS
1315 mk_shows_app :: LHsExpr GhcPs -> LHsExpr GhcPs
1316 mk_shows_app x = nlHsApp (nlHsVar shows_RDR) x
1317
1318 getPrec :: Bool -> (Name -> Fixity) -> Name -> Integer
1319 getPrec is_infix get_fixity nm
1320 | not is_infix = appPrecedence
1321 | otherwise = getPrecedence get_fixity nm
1322
1323 appPrecedence :: Integer
1324 appPrecedence = fromIntegral maxPrecedence + 1
1325 -- One more than the precedence of the most
1326 -- tightly-binding operator
1327
1328 getPrecedence :: (Name -> Fixity) -> Name -> Integer
1329 getPrecedence get_fixity nm
1330 = case get_fixity nm of
1331 Fixity _ x _assoc -> fromIntegral x
1332 -- NB: the Report says that associativity is not taken
1333 -- into account for either Read or Show; hence we
1334 -- ignore associativity here
1335
1336 {-
1337 ************************************************************************
1338 * *
1339 Data instances
1340 * *
1341 ************************************************************************
1342
1343 From the data type
1344
1345 data T a b = T1 a b | T2
1346
1347 we generate
1348
1349 $cT1 = mkDataCon $dT "T1" Prefix
1350 $cT2 = mkDataCon $dT "T2" Prefix
1351 $dT = mkDataType "Module.T" [] [$con_T1, $con_T2]
1352 -- the [] is for field labels.
1353
1354 instance (Data a, Data b) => Data (T a b) where
1355 gfoldl k z (T1 a b) = z T `k` a `k` b
1356 gfoldl k z T2 = z T2
1357 -- ToDo: add gmapT,Q,M, gfoldr
1358
1359 gunfold k z c = case conIndex c of
1360 I# 1# -> k (k (z T1))
1361 I# 2# -> z T2
1362
1363 toConstr (T1 _ _) = $cT1
1364 toConstr T2 = $cT2
1365
1366 dataTypeOf _ = $dT
1367
1368 dataCast1 = gcast1 -- If T :: * -> *
1369 dataCast2 = gcast2 -- if T :: * -> * -> *
1370 -}
1371
1372 gen_Data_binds :: SrcSpan
1373 -> TyCon -- For data families, this is the
1374 -- *representation* TyCon
1375 -> [Type]
1376 -> TcM (LHsBinds GhcPs, -- The method bindings
1377 BagDerivStuff) -- Auxiliary bindings
1378 gen_Data_binds loc rep_tc _
1379 = do { -- See Note [Auxiliary binders]
1380 dataT_RDR <- new_dataT_rdr_name loc rep_tc
1381 ; dataC_RDRs <- traverse (new_dataC_rdr_name loc) data_cons
1382
1383 ; pure ( listToBag [ gfoldl_bind, gunfold_bind
1384 , toCon_bind dataC_RDRs, dataTypeOf_bind dataT_RDR ]
1385 `unionBags` gcast_binds
1386 -- Auxiliary definitions: the data type and constructors
1387 , listToBag $ map DerivAuxBind
1388 ( DerivDataDataType rep_tc dataT_RDR dataC_RDRs
1389 : zipWith (\data_con dataC_RDR ->
1390 DerivDataConstr data_con dataC_RDR dataT_RDR)
1391 data_cons dataC_RDRs )
1392 ) }
1393 where
1394 data_cons = tyConDataCons rep_tc
1395 n_cons = length data_cons
1396 one_constr = n_cons == 1
1397
1398 ------------ gfoldl
1399 gfoldl_bind = mkFunBindEC 3 loc gfoldl_RDR id (map gfoldl_eqn data_cons)
1400
1401 gfoldl_eqn con
1402 = ([nlVarPat k_RDR, z_Pat, nlConVarPat con_name as_needed],
1403 foldl' mk_k_app (z_Expr `nlHsApp` (eta_expand_data_con con)) as_needed)
1404 where
1405 con_name :: RdrName
1406 con_name = getRdrName con
1407 as_needed = take (dataConSourceArity con) as_RDRs
1408 mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v))
1409
1410 ------------ gunfold
1411 gunfold_bind = mkSimpleGeneratedFunBind loc
1412 gunfold_RDR
1413 [k_Pat, z_Pat, if one_constr then nlWildPat else c_Pat]
1414 gunfold_rhs
1415
1416 gunfold_rhs
1417 | one_constr = mk_unfold_rhs (head data_cons) -- No need for case
1418 | otherwise = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr)
1419 (map gunfold_alt data_cons)
1420
1421 gunfold_alt dc = mkHsCaseAlt (mk_unfold_pat dc) (mk_unfold_rhs dc)
1422 mk_unfold_rhs dc = foldr nlHsApp
1423 (z_Expr `nlHsApp` (eta_expand_data_con dc))
1424 (replicate (dataConSourceArity dc) (nlHsVar k_RDR))
1425
1426 eta_expand_data_con dc =
1427 mkHsLam eta_expand_pats
1428 (foldl nlHsApp (nlHsVar (getRdrName dc)) eta_expand_hsvars)
1429 where
1430 eta_expand_pats = map nlVarPat eta_expand_vars
1431 eta_expand_hsvars = map nlHsVar eta_expand_vars
1432 eta_expand_vars = take (dataConSourceArity dc) as_RDRs
1433
1434
1435 mk_unfold_pat dc -- Last one is a wild-pat, to avoid
1436 -- redundant test, and annoying warning
1437 | tag-fIRST_TAG == n_cons-1 = nlWildPat -- Last constructor
1438 | otherwise = nlConPat intDataCon_RDR
1439 [nlLitPat (HsIntPrim NoSourceText (toInteger tag))]
1440 where
1441 tag = dataConTag dc
1442
1443 ------------ toConstr
1444 toCon_bind dataC_RDRs
1445 = mkFunBindEC 1 loc toConstr_RDR id
1446 (zipWith to_con_eqn data_cons dataC_RDRs)
1447 to_con_eqn dc con_name = ([nlWildConPat dc], nlHsVar con_name)
1448
1449 ------------ dataTypeOf
1450 dataTypeOf_bind dataT_RDR
1451 = mkSimpleGeneratedFunBind
1452 loc
1453 dataTypeOf_RDR
1454 [nlWildPat]
1455 (nlHsVar dataT_RDR)
1456
1457 ------------ gcast1/2
1458 -- Make the binding dataCast1 x = gcast1 x -- if T :: * -> *
1459 -- or dataCast2 x = gcast2 s -- if T :: * -> * -> *
1460 -- (or nothing if T has neither of these two types)
1461
1462 -- But care is needed for data families:
1463 -- If we have data family D a
1464 -- data instance D (a,b,c) = A | B deriving( Data )
1465 -- and we want instance ... => Data (D [(a,b,c)]) where ...
1466 -- then we need dataCast1 x = gcast1 x
1467 -- because D :: * -> *
1468 -- even though rep_tc has kind * -> * -> * -> *
1469 -- Hence looking for the kind of fam_tc not rep_tc
1470 -- See #4896
1471 tycon_kind = case tyConFamInst_maybe rep_tc of
1472 Just (fam_tc, _) -> tyConKind fam_tc
1473 Nothing -> tyConKind rep_tc
1474 gcast_binds | tycon_kind `tcEqKind` kind1 = mk_gcast dataCast1_RDR gcast1_RDR
1475 | tycon_kind `tcEqKind` kind2 = mk_gcast dataCast2_RDR gcast2_RDR
1476 | otherwise = emptyBag
1477 mk_gcast dataCast_RDR gcast_RDR
1478 = unitBag (mkSimpleGeneratedFunBind loc dataCast_RDR [nlVarPat f_RDR]
1479 (nlHsVar gcast_RDR `nlHsApp` nlHsVar f_RDR))
1480
1481
1482 kind1, kind2 :: Kind
1483 kind1 = typeToTypeKind
1484 kind2 = liftedTypeKind `mkVisFunTyMany` kind1
1485
1486 gfoldl_RDR, gunfold_RDR, toConstr_RDR, dataTypeOf_RDR, mkConstrTag_RDR,
1487 mkDataType_RDR, conIndex_RDR, prefix_RDR, infix_RDR,
1488 dataCast1_RDR, dataCast2_RDR, gcast1_RDR, gcast2_RDR,
1489 constr_RDR, dataType_RDR,
1490 eqChar_RDR , ltChar_RDR , geChar_RDR , gtChar_RDR , leChar_RDR ,
1491 eqInt_RDR , ltInt_RDR , geInt_RDR , gtInt_RDR , leInt_RDR ,
1492 eqInt8_RDR , ltInt8_RDR , geInt8_RDR , gtInt8_RDR , leInt8_RDR ,
1493 eqInt16_RDR , ltInt16_RDR , geInt16_RDR , gtInt16_RDR , leInt16_RDR ,
1494 eqInt32_RDR , ltInt32_RDR , geInt32_RDR , gtInt32_RDR , leInt32_RDR ,
1495 eqInt64_RDR , ltInt64_RDR , geInt64_RDR , gtInt64_RDR , leInt64_RDR ,
1496 eqWord_RDR , ltWord_RDR , geWord_RDR , gtWord_RDR , leWord_RDR ,
1497 eqWord8_RDR , ltWord8_RDR , geWord8_RDR , gtWord8_RDR , leWord8_RDR ,
1498 eqWord16_RDR, ltWord16_RDR, geWord16_RDR, gtWord16_RDR, leWord16_RDR,
1499 eqWord32_RDR, ltWord32_RDR, geWord32_RDR, gtWord32_RDR, leWord32_RDR,
1500 eqWord64_RDR, ltWord64_RDR, geWord64_RDR, gtWord64_RDR, leWord64_RDR,
1501 eqAddr_RDR , ltAddr_RDR , geAddr_RDR , gtAddr_RDR , leAddr_RDR ,
1502 eqFloat_RDR , ltFloat_RDR , geFloat_RDR , gtFloat_RDR , leFloat_RDR ,
1503 eqDouble_RDR, ltDouble_RDR, geDouble_RDR, gtDouble_RDR, leDouble_RDR,
1504 word8ToWord_RDR , int8ToInt_RDR ,
1505 word16ToWord_RDR, int16ToInt_RDR,
1506 word32ToWord_RDR, int32ToInt_RDR
1507 :: RdrName
1508 gfoldl_RDR = varQual_RDR gENERICS (fsLit "gfoldl")
1509 gunfold_RDR = varQual_RDR gENERICS (fsLit "gunfold")
1510 toConstr_RDR = varQual_RDR gENERICS (fsLit "toConstr")
1511 dataTypeOf_RDR = varQual_RDR gENERICS (fsLit "dataTypeOf")
1512 dataCast1_RDR = varQual_RDR gENERICS (fsLit "dataCast1")
1513 dataCast2_RDR = varQual_RDR gENERICS (fsLit "dataCast2")
1514 gcast1_RDR = varQual_RDR tYPEABLE (fsLit "gcast1")
1515 gcast2_RDR = varQual_RDR tYPEABLE (fsLit "gcast2")
1516 mkConstrTag_RDR = varQual_RDR gENERICS (fsLit "mkConstrTag")
1517 constr_RDR = tcQual_RDR gENERICS (fsLit "Constr")
1518 mkDataType_RDR = varQual_RDR gENERICS (fsLit "mkDataType")
1519 dataType_RDR = tcQual_RDR gENERICS (fsLit "DataType")
1520 conIndex_RDR = varQual_RDR gENERICS (fsLit "constrIndex")
1521 prefix_RDR = dataQual_RDR gENERICS (fsLit "Prefix")
1522 infix_RDR = dataQual_RDR gENERICS (fsLit "Infix")
1523
1524 eqChar_RDR = varQual_RDR gHC_PRIM (fsLit "eqChar#")
1525 ltChar_RDR = varQual_RDR gHC_PRIM (fsLit "ltChar#")
1526 leChar_RDR = varQual_RDR gHC_PRIM (fsLit "leChar#")
1527 gtChar_RDR = varQual_RDR gHC_PRIM (fsLit "gtChar#")
1528 geChar_RDR = varQual_RDR gHC_PRIM (fsLit "geChar#")
1529
1530 eqInt_RDR = varQual_RDR gHC_PRIM (fsLit "==#")
1531 ltInt_RDR = varQual_RDR gHC_PRIM (fsLit "<#" )
1532 leInt_RDR = varQual_RDR gHC_PRIM (fsLit "<=#")
1533 gtInt_RDR = varQual_RDR gHC_PRIM (fsLit ">#" )
1534 geInt_RDR = varQual_RDR gHC_PRIM (fsLit ">=#")
1535
1536 eqInt8_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt8#")
1537 ltInt8_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt8#" )
1538 leInt8_RDR = varQual_RDR gHC_PRIM (fsLit "leInt8#")
1539 gtInt8_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt8#" )
1540 geInt8_RDR = varQual_RDR gHC_PRIM (fsLit "geInt8#")
1541
1542 eqInt16_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt16#")
1543 ltInt16_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt16#" )
1544 leInt16_RDR = varQual_RDR gHC_PRIM (fsLit "leInt16#")
1545 gtInt16_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt16#" )
1546 geInt16_RDR = varQual_RDR gHC_PRIM (fsLit "geInt16#")
1547
1548 eqInt32_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt32#")
1549 ltInt32_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt32#" )
1550 leInt32_RDR = varQual_RDR gHC_PRIM (fsLit "leInt32#")
1551 gtInt32_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt32#" )
1552 geInt32_RDR = varQual_RDR gHC_PRIM (fsLit "geInt32#")
1553
1554 eqInt64_RDR = varQual_RDR gHC_PRIM (fsLit "eqInt64#")
1555 ltInt64_RDR = varQual_RDR gHC_PRIM (fsLit "ltInt64#" )
1556 leInt64_RDR = varQual_RDR gHC_PRIM (fsLit "leInt64#")
1557 gtInt64_RDR = varQual_RDR gHC_PRIM (fsLit "gtInt64#" )
1558 geInt64_RDR = varQual_RDR gHC_PRIM (fsLit "geInt64#")
1559
1560 eqWord_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord#")
1561 ltWord_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord#")
1562 leWord_RDR = varQual_RDR gHC_PRIM (fsLit "leWord#")
1563 gtWord_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord#")
1564 geWord_RDR = varQual_RDR gHC_PRIM (fsLit "geWord#")
1565
1566 eqWord8_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord8#")
1567 ltWord8_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord8#" )
1568 leWord8_RDR = varQual_RDR gHC_PRIM (fsLit "leWord8#")
1569 gtWord8_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord8#" )
1570 geWord8_RDR = varQual_RDR gHC_PRIM (fsLit "geWord8#")
1571
1572 eqWord16_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord16#")
1573 ltWord16_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord16#" )
1574 leWord16_RDR = varQual_RDR gHC_PRIM (fsLit "leWord16#")
1575 gtWord16_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord16#" )
1576 geWord16_RDR = varQual_RDR gHC_PRIM (fsLit "geWord16#")
1577
1578 eqWord32_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord32#")
1579 ltWord32_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord32#" )
1580 leWord32_RDR = varQual_RDR gHC_PRIM (fsLit "leWord32#")
1581 gtWord32_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord32#" )
1582 geWord32_RDR = varQual_RDR gHC_PRIM (fsLit "geWord32#")
1583
1584 eqWord64_RDR = varQual_RDR gHC_PRIM (fsLit "eqWord64#")
1585 ltWord64_RDR = varQual_RDR gHC_PRIM (fsLit "ltWord64#" )
1586 leWord64_RDR = varQual_RDR gHC_PRIM (fsLit "leWord64#")
1587 gtWord64_RDR = varQual_RDR gHC_PRIM (fsLit "gtWord64#" )
1588 geWord64_RDR = varQual_RDR gHC_PRIM (fsLit "geWord64#")
1589
1590 eqAddr_RDR = varQual_RDR gHC_PRIM (fsLit "eqAddr#")
1591 ltAddr_RDR = varQual_RDR gHC_PRIM (fsLit "ltAddr#")
1592 leAddr_RDR = varQual_RDR gHC_PRIM (fsLit "leAddr#")
1593 gtAddr_RDR = varQual_RDR gHC_PRIM (fsLit "gtAddr#")
1594 geAddr_RDR = varQual_RDR gHC_PRIM (fsLit "geAddr#")
1595
1596 eqFloat_RDR = varQual_RDR gHC_PRIM (fsLit "eqFloat#")
1597 ltFloat_RDR = varQual_RDR gHC_PRIM (fsLit "ltFloat#")
1598 leFloat_RDR = varQual_RDR gHC_PRIM (fsLit "leFloat#")
1599 gtFloat_RDR = varQual_RDR gHC_PRIM (fsLit "gtFloat#")
1600 geFloat_RDR = varQual_RDR gHC_PRIM (fsLit "geFloat#")
1601
1602 eqDouble_RDR = varQual_RDR gHC_PRIM (fsLit "==##")
1603 ltDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<##" )
1604 leDouble_RDR = varQual_RDR gHC_PRIM (fsLit "<=##")
1605 gtDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">##" )
1606 geDouble_RDR = varQual_RDR gHC_PRIM (fsLit ">=##")
1607
1608 word8ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word8ToWord#")
1609 int8ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int8ToInt#")
1610
1611 word16ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word16ToWord#")
1612 int16ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int16ToInt#")
1613
1614 word32ToWord_RDR = varQual_RDR gHC_PRIM (fsLit "word32ToWord#")
1615 int32ToInt_RDR = varQual_RDR gHC_PRIM (fsLit "int32ToInt#")
1616
1617 {-
1618 ************************************************************************
1619 * *
1620 Lift instances
1621 * *
1622 ************************************************************************
1623
1624 Example:
1625
1626 data Foo a = Foo a | a :^: a deriving Lift
1627
1628 ==>
1629
1630 instance (Lift a) => Lift (Foo a) where
1631 lift (Foo a) = [| Foo a |]
1632 lift ((:^:) u v) = [| (:^:) u v |]
1633
1634 liftTyped (Foo a) = [|| Foo a ||]
1635 liftTyped ((:^:) u v) = [|| (:^:) u v ||]
1636 -}
1637
1638
1639 gen_Lift_binds :: SrcSpan -> TyCon -> [Type] -> (LHsBinds GhcPs, BagDerivStuff)
1640 gen_Lift_binds loc tycon tycon_args = (listToBag [lift_bind, liftTyped_bind], emptyBag)
1641 where
1642 lift_bind = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
1643 (map (pats_etc mk_exp) data_cons)
1644 liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)
1645 (map (pats_etc mk_texp) data_cons)
1646
1647 mk_exp = ExpBr noExtField
1648 mk_texp = TExpBr noExtField
1649 data_cons = getPossibleDataCons tycon tycon_args
1650
1651 pats_etc mk_bracket data_con
1652 = ([con_pat], lift_Expr)
1653 where
1654 con_pat = nlConVarPat data_con_RDR as_needed
1655 data_con_RDR = getRdrName data_con
1656 con_arity = dataConSourceArity data_con
1657 as_needed = take con_arity as_RDRs
1658 lift_Expr = noLocA (HsBracket noAnn (mk_bracket br_body))
1659 br_body = nlHsApps (Exact (dataConName data_con))
1660 (map nlHsVar as_needed)
1661
1662 {-
1663 ************************************************************************
1664 * *
1665 Newtype-deriving instances
1666 * *
1667 ************************************************************************
1668
1669 Note [Newtype-deriving instances]
1670 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1671 We take every method in the original instance and `coerce` it to fit
1672 into the derived instance. We need type applications on the argument
1673 to `coerce` to make it obvious what instantiation of the method we're
1674 coercing from. So from, say,
1675
1676 class C a b where
1677 op :: forall c. a -> [b] -> c -> Int
1678
1679 newtype T x = MkT <rep-ty>
1680
1681 instance C a <rep-ty> => C a (T x) where
1682 op :: forall c. a -> [T x] -> c -> Int
1683 op = coerce @(a -> [<rep-ty>] -> c -> Int)
1684 @(a -> [T x] -> c -> Int)
1685 op
1686
1687 In addition to the type applications, we also have an explicit
1688 type signature on the entire RHS. This brings the method-bound variable
1689 `c` into scope over the two type applications.
1690 See Note [GND and QuantifiedConstraints] for more information on why this
1691 is important.
1692
1693 Giving 'coerce' two explicitly-visible type arguments grants us finer control
1694 over how it should be instantiated. Recall
1695
1696 coerce :: Coercible a b => a -> b
1697
1698 By giving it explicit type arguments we deal with the case where
1699 'op' has a higher rank type, and so we must instantiate 'coerce' with
1700 a polytype. E.g.
1701
1702 class C a where op :: a -> forall b. b -> b
1703 newtype T x = MkT <rep-ty>
1704 instance C <rep-ty> => C (T x) where
1705 op :: T x -> forall b. b -> b
1706 op = coerce @(<rep-ty> -> forall b. b -> b)
1707 @(T x -> forall b. b -> b)
1708 op
1709
1710 The use of type applications is crucial here. We have to instantiate
1711 both type args of (coerce :: Coercible a b => a -> b) to polytypes,
1712 and we can only do that with VTA or Quick Look. Here VTA seems more
1713 appropriate for machine generated code: it's simple and robust.
1714
1715 However, to allow VTA with polytypes we must switch on
1716 -XImpredicativeTypes locally in GHC.Tc.Deriv.genInst.
1717 See #8503 for more discussion.
1718
1719 Note [Newtype-deriving trickiness]
1720 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1721 Consider (#12768):
1722 class C a where { op :: D a => a -> a }
1723
1724 instance C a => C [a] where { op = opList }
1725
1726 opList :: (C a, D [a]) => [a] -> [a]
1727 opList = ...
1728
1729 Now suppose we try GND on this:
1730 newtype N a = MkN [a] deriving( C )
1731
1732 The GND is expecting to get an implementation of op for N by
1733 coercing opList, thus:
1734
1735 instance C a => C (N a) where { op = opN }
1736
1737 opN :: (C a, D (N a)) => N a -> N a
1738 opN = coerce @([a] -> [a])
1739 @([N a] -> [N a]
1740 opList :: D (N a) => [N a] -> [N a]
1741
1742 But there is no reason to suppose that (D [a]) and (D (N a))
1743 are inter-coercible; these instances might completely different.
1744 So GHC rightly rejects this code.
1745
1746 Note [GND and QuantifiedConstraints]
1747 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1748 Consider the following example from #15290:
1749
1750 class C m where
1751 join :: m (m a) -> m a
1752
1753 newtype T m a = MkT (m a)
1754
1755 deriving instance
1756 (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
1757 C (T m)
1758
1759 The code that GHC used to generate for this was:
1760
1761 instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
1762 C (T m) where
1763 join = coerce @(forall a. m (m a) -> m a)
1764 @(forall a. T m (T m a) -> T m a)
1765 join
1766
1767 This instantiates `coerce` at a polymorphic type, a form of impredicative
1768 polymorphism, so we're already on thin ice. And in fact the ice breaks,
1769 as we'll explain:
1770
1771 The call to `coerce` gives rise to:
1772
1773 Coercible (forall a. m (m a) -> m a)
1774 (forall a. T m (T m a) -> T m a)
1775
1776 And that simplified to the following implication constraint:
1777
1778 forall a <no-ev>. m (T m a) ~R# m (m a)
1779
1780 But because this constraint is under a `forall`, inside a type, we have to
1781 prove it *without computing any term evidence* (hence the <no-ev>). Alas, we
1782 *must* generate a term-level evidence binding in order to instantiate the
1783 quantified constraint! In response, GHC currently chooses not to use such
1784 a quantified constraint.
1785 See Note [Instances in no-evidence implications] in GHC.Tc.Solver.Interact.
1786
1787 But this isn't the death knell for combining QuantifiedConstraints with GND.
1788 On the contrary, if we generate GND bindings in a slightly different way, then
1789 we can avoid this situation altogether. Instead of applying `coerce` to two
1790 polymorphic types, we instead let an instance signature do the polymorphic
1791 instantiation, and omit the `forall`s in the type applications.
1792 More concretely, we generate the following code instead:
1793
1794 instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
1795 C (T m) where
1796 join :: forall a. T m (T m a) -> T m a
1797 join = coerce @( m (m a) -> m a)
1798 @(T m (T m a) -> T m a)
1799 join
1800
1801 Now the visible type arguments are both monotypes, so we don't need any of this
1802 funny quantified constraint instantiation business. While this particular
1803 example no longer uses impredicative instantiation, we still need to enable
1804 ImpredicativeTypes to typecheck GND-generated code for class methods with
1805 higher-rank types. See Note [Newtype-deriving instances].
1806
1807 You might think that that second @(T m (T m a) -> T m a) argument is redundant
1808 in the presence of the instance signature, but in fact leaving it off will
1809 break this example (from the T15290d test case):
1810
1811 class C a where
1812 c :: Int -> forall b. b -> a
1813
1814 instance C Int
1815
1816 instance C Age where
1817 c :: Int -> forall b. b -> Age
1818 c = coerce @(Int -> forall b. b -> Int)
1819 c
1820
1821 That is because we still need to instantiate the second argument of
1822 coerce with a polytype, and we can only do that with VTA or QuickLook.
1823
1824 Be aware that the use of an instance signature doesn't /solve/ this
1825 problem; it just makes it less likely to occur. For example, if a class has
1826 a truly higher-rank type like so:
1827
1828 class CProblem m where
1829 op :: (forall b. ... (m b) ...) -> Int
1830
1831 Then the same situation will arise again. But at least it won't arise for the
1832 common case of methods with ordinary, prenex-quantified types.
1833
1834 -----
1835 -- Wrinkle: Use HsOuterExplicit
1836 -----
1837
1838 One minor complication with the plan above is that we need to ensure that the
1839 type variables from a method's instance signature properly scope over the body
1840 of the method. For example, recall:
1841
1842 instance (C m, forall p q. Coercible p q => Coercible (m p) (m q)) =>
1843 C (T m) where
1844 join :: forall a. T m (T m a) -> T m a
1845 join = coerce @( m (m a) -> m a)
1846 @(T m (T m a) -> T m a)
1847 join
1848
1849 In the example above, it is imperative that the `a` in the instance signature
1850 for `join` scope over the body of `join` by way of ScopedTypeVariables.
1851 This might sound obvious, but note that in gen_Newtype_binds, which is
1852 responsible for generating the code above, the type in `join`'s instance
1853 signature is given as a Core type, whereas gen_Newtype_binds will eventually
1854 produce HsBinds (i.e., source Haskell) that is renamed and typechecked. We
1855 must ensure that `a` is in scope over the body of `join` during renaming
1856 or else the generated code will be rejected.
1857
1858 In short, we need to convert the instance signature from a Core type to an
1859 HsType (i.e., a source Haskell type). Two possible options are:
1860
1861 1. Convert the Core type entirely to an HsType (i.e., a source Haskell type).
1862 2. Embed the entire Core type using HsCoreTy.
1863
1864 Neither option is quite satisfactory:
1865
1866 1. Converting a Core type to an HsType in full generality is surprisingly
1867 complicated. Previous versions of GHCs did this, but it was the source of
1868 numerous bugs (see #14579 and #16518, for instance).
1869 2. While HsCoreTy is much less complicated that option (1), it's not quite
1870 what we want. In order for `a` to be in scope over the body of `join` during
1871 renaming, the `forall` must be contained in an HsOuterExplicit.
1872 (See Note [Lexically scoped type variables] in GHC.Hs.Type.) HsCoreTy
1873 bypasses HsOuterExplicit, so this won't work either.
1874
1875 As a compromise, we adopt a combination of the two options above:
1876
1877 * Split apart the top-level ForAllTys in the instance signature's Core type,
1878 * Convert the top-level ForAllTys to an HsOuterExplicit, and
1879 * Embed the remainder of the Core type in an HsCoreTy.
1880
1881 This retains most of the simplicity of option (2) while still ensuring that
1882 the type variables are correctly scoped.
1883
1884 Note that splitting apart top-level ForAllTys will expand any type synonyms
1885 in the Core type itself. This ends up being important to fix a corner case
1886 observed in #18914. Consider this example:
1887
1888 type T f = forall a. f a
1889
1890 class C f where
1891 m :: T f
1892
1893 newtype N f a = MkN (f a)
1894 deriving C
1895
1896 What code should `deriving C` generate? It will have roughly the following
1897 shape:
1898
1899 instance C f => C (N f) where
1900 m :: T (N f)
1901 m = coerce @(...) (...) (m @f)
1902
1903 At a minimum, we must instantiate `coerce` with `@(T f)` and `@(T (N f))`, but
1904 with the `forall`s removed in order to make them monotypes. However, the
1905 `forall` is hidden underneath the `T` type synonym, so we must first expand `T`
1906 before we can strip of the `forall`. Expanding `T`, we get
1907 `coerce @(forall a. f a) @(forall a. N f a)`, and after omitting the `forall`s,
1908 we get `coerce @(f a) @(N f a)`.
1909
1910 We can't stop there, however, or else we would end up with this code:
1911
1912 instance C f => C (N f) where
1913 m :: T (N f)
1914 m = coerce @(f a) @(N f a) (m @f)
1915
1916 Notice that the type variable `a` is completely unbound. In order to make sure
1917 that `a` is in scope, we must /also/ expand the `T` in `m :: T (N f)` to get
1918 `m :: forall a. N f a`. Fortunately, we will do just that in the plan outlined
1919 above, since when we split off the top-level ForAllTys in the instance
1920 signature, we must first expand the T type synonym.
1921
1922 Note [GND and ambiguity]
1923 ~~~~~~~~~~~~~~~~~~~~~~~~
1924 We make an effort to make the code generated through GND be robust w.r.t.
1925 ambiguous type variables. As one example, consider the following example
1926 (from #15637):
1927
1928 class C a where f :: String
1929 instance C () where f = "foo"
1930 newtype T = T () deriving C
1931
1932 A naïve attempt and generating a C T instance would be:
1933
1934 instance C T where
1935 f :: String
1936 f = coerce @String @String f
1937
1938 This isn't going to typecheck, however, since GHC doesn't know what to
1939 instantiate the type variable `a` with in the call to `f` in the method body.
1940 (Note that `f :: forall a. String`!) To compensate for the possibility of
1941 ambiguity here, we explicitly instantiate `a` like so:
1942
1943 instance C T where
1944 f :: String
1945 f = coerce @String @String (f @())
1946
1947 All better now.
1948 -}
1949
1950 gen_Newtype_binds :: SrcSpan
1951 -> Class -- the class being derived
1952 -> [TyVar] -- the tvs in the instance head (this includes
1953 -- the tvs from both the class types and the
1954 -- newtype itself)
1955 -> [Type] -- instance head parameters (incl. newtype)
1956 -> Type -- the representation type
1957 -> TcM (LHsBinds GhcPs, [LSig GhcPs], BagDerivStuff)
1958 -- See Note [Newtype-deriving instances]
1959 gen_Newtype_binds loc' cls inst_tvs inst_tys rhs_ty
1960 = do let ats = classATs cls
1961 (binds, sigs) = mapAndUnzip mk_bind_and_sig (classMethods cls)
1962 atf_insts <- assert (all (not . isDataFamilyTyCon) ats) $
1963 mapM mk_atf_inst ats
1964 return ( listToBag binds
1965 , sigs
1966 , listToBag $ map DerivFamInst atf_insts )
1967 where
1968 locn = noAnnSrcSpan loc'
1969 loca = noAnnSrcSpan loc'
1970 -- For each class method, generate its derived binding and instance
1971 -- signature. Using the first example from
1972 -- Note [Newtype-deriving instances]:
1973 --
1974 -- class C a b where
1975 -- op :: forall c. a -> [b] -> c -> Int
1976 --
1977 -- newtype T x = MkT <rep-ty>
1978 --
1979 -- Then we would generate <derived-op-impl> below:
1980 --
1981 -- instance C a <rep-ty> => C a (T x) where
1982 -- <derived-op-impl>
1983 mk_bind_and_sig :: Id -> (LHsBind GhcPs, LSig GhcPs)
1984 mk_bind_and_sig meth_id
1985 = ( -- The derived binding, e.g.,
1986 --
1987 -- op = coerce @(a -> [<rep-ty>] -> c -> Int)
1988 -- @(a -> [T x] -> c -> Int)
1989 -- op
1990 mkRdrFunBind loc_meth_RDR [mkSimpleMatch
1991 (mkPrefixFunRhs loc_meth_RDR)
1992 [] rhs_expr]
1993 , -- The derived instance signature, e.g.,
1994 --
1995 -- op :: forall c. a -> [T x] -> c -> Int
1996 --
1997 -- Make sure that `forall c` is in an HsOuterExplicit so that it
1998 -- scopes over the body of `op`. See "Wrinkle: Use HsOuterExplicit" in
1999 -- Note [GND and QuantifiedConstraints].
2000 L loca $ ClassOpSig noAnn False [loc_meth_RDR]
2001 $ L loca $ mkHsExplicitSigType noAnn
2002 (map mk_hs_tvb to_tvbs)
2003 (nlHsCoreTy to_rho)
2004 )
2005 where
2006 Pair from_ty to_ty = mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty meth_id
2007 (_, _, from_tau) = tcSplitSigmaTy from_ty
2008 (to_tvbs, to_rho) = tcSplitForAllInvisTVBinders to_ty
2009 (_, to_tau) = tcSplitPhiTy to_rho
2010 -- The use of tcSplitForAllInvisTVBinders above expands type synonyms,
2011 -- which is important to ensure correct type variable scoping.
2012 -- See "Wrinkle: Use HsOuterExplicit" in
2013 -- Note [GND and QuantifiedConstraints].
2014
2015 mk_hs_tvb :: VarBndr TyVar flag -> LHsTyVarBndr flag GhcPs
2016 mk_hs_tvb (Bndr tv flag) = noLocA $ KindedTyVar noAnn
2017 flag
2018 (noLocA (getRdrName tv))
2019 (nlHsCoreTy (tyVarKind tv))
2020
2021 meth_RDR = getRdrName meth_id
2022 loc_meth_RDR = L locn meth_RDR
2023
2024 rhs_expr = nlHsVar (getRdrName coerceId)
2025 `nlHsAppType` from_tau
2026 `nlHsAppType` to_tau
2027 `nlHsApp` meth_app
2028
2029 -- The class method, applied to all of the class instance types
2030 -- (including the representation type) to avoid potential ambiguity.
2031 -- See Note [GND and ambiguity]
2032 meth_app = foldl' nlHsAppType (nlHsVar meth_RDR) $
2033 filterOutInferredTypes (classTyCon cls) underlying_inst_tys
2034 -- Filter out any inferred arguments, since they can't be
2035 -- applied with visible type application.
2036
2037 mk_atf_inst :: TyCon -> TcM FamInst
2038 mk_atf_inst fam_tc = do
2039 rep_tc_name <- newFamInstTyConName (L locn (tyConName fam_tc))
2040 rep_lhs_tys
2041 let axiom = mkSingleCoAxiom Nominal rep_tc_name rep_tvs' [] rep_cvs'
2042 fam_tc rep_lhs_tys rep_rhs_ty
2043 -- Check (c) from Note [GND and associated type families] in GHC.Tc.Deriv
2044 checkValidCoAxBranch fam_tc (coAxiomSingleBranch axiom)
2045 newFamInst SynFamilyInst axiom
2046 where
2047 cls_tvs = classTyVars cls
2048 in_scope = mkInScopeSet $ mkVarSet inst_tvs
2049 lhs_env = zipTyEnv cls_tvs inst_tys
2050 lhs_subst = mkTvSubst in_scope lhs_env
2051 rhs_env = zipTyEnv cls_tvs underlying_inst_tys
2052 rhs_subst = mkTvSubst in_scope rhs_env
2053 fam_tvs = tyConTyVars fam_tc
2054 rep_lhs_tys = substTyVars lhs_subst fam_tvs
2055 rep_rhs_tys = substTyVars rhs_subst fam_tvs
2056 rep_rhs_ty = mkTyConApp fam_tc rep_rhs_tys
2057 rep_tcvs = tyCoVarsOfTypesList rep_lhs_tys
2058 (rep_tvs, rep_cvs) = partition isTyVar rep_tcvs
2059 rep_tvs' = scopedSort rep_tvs
2060 rep_cvs' = scopedSort rep_cvs
2061
2062 -- Same as inst_tys, but with the last argument type replaced by the
2063 -- representation type.
2064 underlying_inst_tys :: [Type]
2065 underlying_inst_tys = changeLast inst_tys rhs_ty
2066
2067 nlHsAppType :: LHsExpr GhcPs -> Type -> LHsExpr GhcPs
2068 nlHsAppType e s = noLocA (HsAppType noSrcSpan e hs_ty)
2069 where
2070 hs_ty = mkHsWildCardBndrs $ parenthesizeHsType appPrec $ nlHsCoreTy s
2071
2072 nlHsCoreTy :: HsCoreTy -> LHsType GhcPs
2073 nlHsCoreTy = noLocA . XHsType
2074
2075 mkCoerceClassMethEqn :: Class -- the class being derived
2076 -> [TyVar] -- the tvs in the instance head (this includes
2077 -- the tvs from both the class types and the
2078 -- newtype itself)
2079 -> [Type] -- instance head parameters (incl. newtype)
2080 -> Type -- the representation type
2081 -> Id -- the method to look at
2082 -> Pair Type
2083 -- See Note [Newtype-deriving instances]
2084 -- See also Note [Newtype-deriving trickiness]
2085 -- The pair is the (from_type, to_type), where to_type is
2086 -- the type of the method we are trying to get
2087 mkCoerceClassMethEqn cls inst_tvs inst_tys rhs_ty id
2088 = Pair (substTy rhs_subst user_meth_ty)
2089 (substTy lhs_subst user_meth_ty)
2090 where
2091 cls_tvs = classTyVars cls
2092 in_scope = mkInScopeSet $ mkVarSet inst_tvs
2093 lhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs inst_tys)
2094 rhs_subst = mkTvSubst in_scope (zipTyEnv cls_tvs (changeLast inst_tys rhs_ty))
2095 (_class_tvs, _class_constraint, user_meth_ty)
2096 = tcSplitMethodTy (varType id)
2097
2098 {-
2099 ************************************************************************
2100 * *
2101 \subsection{Generating extra binds (@tag2con@, etc.)}
2102 * *
2103 ************************************************************************
2104
2105 \begin{verbatim}
2106 data Foo ... = ...
2107
2108 tag2con_Foo :: Int -> Foo ... -- easier if Int, not Int#
2109 maxtag_Foo :: Int -- ditto (NB: not unlifted)
2110 \end{verbatim}
2111
2112 The `tags' here start at zero, hence the @fIRST_TAG@ (currently one)
2113 fiddling around.
2114 -}
2115
2116 -- | Generate the full code for an auxiliary binding.
2117 -- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
2118 genAuxBindSpecOriginal :: DynFlags -> SrcSpan -> AuxBindSpec
2119 -> (LHsBind GhcPs, LSig GhcPs)
2120 genAuxBindSpecOriginal dflags loc spec
2121 = (gen_bind spec,
2122 L loca (TypeSig noAnn [L locn (auxBindSpecRdrName spec)]
2123 (genAuxBindSpecSig loc spec)))
2124 where
2125 loca = noAnnSrcSpan loc
2126 locn = noAnnSrcSpan loc
2127 gen_bind :: AuxBindSpec -> LHsBind GhcPs
2128 gen_bind (DerivTag2Con _ tag2con_RDR)
2129 = mkFunBindSE 0 loc tag2con_RDR
2130 [([nlConVarPat intDataCon_RDR [a_RDR]],
2131 nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)]
2132
2133 gen_bind (DerivMaxTag tycon maxtag_RDR)
2134 = mkHsVarBind loc maxtag_RDR rhs
2135 where
2136 rhs = nlHsApp (nlHsVar intDataCon_RDR)
2137 (nlHsLit (HsIntPrim NoSourceText max_tag))
2138 max_tag = case (tyConDataCons tycon) of
2139 data_cons -> toInteger ((length data_cons) - fIRST_TAG)
2140
2141 gen_bind (DerivDataDataType tycon dataT_RDR dataC_RDRs)
2142 = mkHsVarBind loc dataT_RDR rhs
2143 where
2144 tc_name = tyConName tycon
2145 tc_name_string = occNameString (getOccName tc_name)
2146 definition_mod_name = moduleNameString (moduleName (expectJust "gen_bind DerivDataDataType" $ nameModule_maybe tc_name))
2147 ctx = initDefaultSDocContext dflags
2148 rhs = nlHsVar mkDataType_RDR
2149 `nlHsApp` nlHsLit (mkHsString (showSDocOneLine ctx (text definition_mod_name <> dot <> text tc_name_string)))
2150 `nlHsApp` nlList (map nlHsVar dataC_RDRs)
2151
2152 gen_bind (DerivDataConstr dc dataC_RDR dataT_RDR)
2153 = mkHsVarBind loc dataC_RDR rhs
2154 where
2155 rhs = nlHsApps mkConstrTag_RDR constr_args
2156
2157 constr_args
2158 = [ nlHsVar dataT_RDR -- DataType
2159 , nlHsLit (mkHsString (occNameString dc_occ)) -- Constructor name
2160 , nlHsIntLit (toInteger (dataConTag dc)) -- Constructor tag
2161 , nlList labels -- Field labels
2162 , nlHsVar fixity ] -- Fixity
2163
2164 labels = map (nlHsLit . mkHsString . unpackFS . flLabel)
2165 (dataConFieldLabels dc)
2166 dc_occ = getOccName dc
2167 is_infix = isDataSymOcc dc_occ
2168 fixity | is_infix = infix_RDR
2169 | otherwise = prefix_RDR
2170
2171 -- | Generate the code for an auxiliary binding that is a duplicate of another
2172 -- auxiliary binding.
2173 -- See @Note [Auxiliary binders] (Wrinkle: Reducing code duplication)@.
2174 genAuxBindSpecDup :: SrcSpan -> RdrName -> AuxBindSpec
2175 -> (LHsBind GhcPs, LSig GhcPs)
2176 genAuxBindSpecDup loc original_rdr_name dup_spec
2177 = (mkHsVarBind loc dup_rdr_name (nlHsVar original_rdr_name),
2178 L loca (TypeSig noAnn [L locn dup_rdr_name]
2179 (genAuxBindSpecSig loc dup_spec)))
2180 where
2181 loca = noAnnSrcSpan loc
2182 locn = noAnnSrcSpan loc
2183 dup_rdr_name = auxBindSpecRdrName dup_spec
2184
2185 -- | Generate the type signature of an auxiliary binding.
2186 -- See @Note [Auxiliary binders]@.
2187 genAuxBindSpecSig :: SrcSpan -> AuxBindSpec -> LHsSigWcType GhcPs
2188 genAuxBindSpecSig loc spec = case spec of
2189 DerivTag2Con tycon _
2190 -> mk_sig $ L (noAnnSrcSpan loc) $
2191 XHsType $ mkSpecForAllTys (tyConTyVars tycon) $
2192 intTy `mkVisFunTyMany` mkParentType tycon
2193 DerivMaxTag _ _
2194 -> mk_sig (L (noAnnSrcSpan loc) (XHsType intTy))
2195 DerivDataDataType _ _ _
2196 -> mk_sig (nlHsTyVar dataType_RDR)
2197 DerivDataConstr _ _ _
2198 -> mk_sig (nlHsTyVar constr_RDR)
2199 where
2200 mk_sig = mkHsWildCardBndrs . L (noAnnSrcSpan loc) . mkHsImplicitSigType
2201
2202 type SeparateBagsDerivStuff =
2203 -- DerivAuxBinds
2204 ( Bag (LHsBind GhcPs, LSig GhcPs)
2205
2206 -- Extra family instances (used by DeriveGeneric, DeriveAnyClass, and
2207 -- GeneralizedNewtypeDeriving)
2208 , Bag FamInst )
2209
2210 -- | Take a 'BagDerivStuff' and partition it into 'SeparateBagsDerivStuff'.
2211 -- Also generate the code for auxiliary bindings based on the declarative
2212 -- descriptions in the supplied 'AuxBindSpec's. See @Note [Auxiliary binders]@.
2213 genAuxBinds :: DynFlags -> SrcSpan -> BagDerivStuff -> SeparateBagsDerivStuff
2214 genAuxBinds dflags loc b = (gen_aux_bind_specs b1, b2) where
2215 (b1,b2) = partitionBagWith splitDerivAuxBind b
2216 splitDerivAuxBind (DerivAuxBind x) = Left x
2217 splitDerivAuxBind (DerivFamInst t) = Right t
2218
2219 gen_aux_bind_specs = snd . foldr gen_aux_bind_spec (emptyOccEnv, emptyBag)
2220
2221 -- Perform a CSE-like pass over the generated auxiliary bindings to avoid
2222 -- code duplication, as described in
2223 -- Note [Auxiliary binders] (Wrinkle: Reducing code duplication).
2224 -- The OccEnv remembers the first occurrence of each sort of auxiliary
2225 -- binding and maps it to the unique RdrName for that binding.
2226 gen_aux_bind_spec :: AuxBindSpec
2227 -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
2228 -> (OccEnv RdrName, Bag (LHsBind GhcPs, LSig GhcPs))
2229 gen_aux_bind_spec spec (original_rdr_name_env, spec_bag) =
2230 case lookupOccEnv original_rdr_name_env spec_occ of
2231 Nothing
2232 -> ( extendOccEnv original_rdr_name_env spec_occ spec_rdr_name
2233 , genAuxBindSpecOriginal dflags loc spec `consBag` spec_bag )
2234 Just original_rdr_name
2235 -> ( original_rdr_name_env
2236 , genAuxBindSpecDup loc original_rdr_name spec `consBag` spec_bag )
2237 where
2238 spec_rdr_name = auxBindSpecRdrName spec
2239 spec_occ = rdrNameOcc spec_rdr_name
2240
2241 mkParentType :: TyCon -> Type
2242 -- Turn the representation tycon of a family into
2243 -- a use of its family constructor
2244 mkParentType tc
2245 = case tyConFamInst_maybe tc of
2246 Nothing -> mkTyConApp tc (mkTyVarTys (tyConTyVars tc))
2247 Just (fam_tc,tys) -> mkTyConApp fam_tc tys
2248
2249 {-
2250 ************************************************************************
2251 * *
2252 \subsection{Utility bits for generating bindings}
2253 * *
2254 ************************************************************************
2255 -}
2256
2257 -- | Make a function binding. If no equations are given, produce a function
2258 -- with the given arity that produces a stock error.
2259 mkFunBindSE :: Arity -> SrcSpan -> RdrName
2260 -> [([LPat GhcPs], LHsExpr GhcPs)]
2261 -> LHsBind GhcPs
2262 mkFunBindSE arity loc fun pats_and_exprs
2263 = mkRdrFunBindSE arity (L (noAnnSrcSpan loc) fun) matches
2264 where
2265 matches = [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
2266 (map (parenthesizePat appPrec) p) e
2267 emptyLocalBinds
2268 | (p,e) <-pats_and_exprs]
2269
2270 mkRdrFunBind :: LocatedN RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
2271 -> LHsBind GhcPs
2272 mkRdrFunBind fun@(L loc _fun_rdr) matches
2273 = L (na2la loc) (mkFunBind Generated fun matches)
2274
2275 -- | Make a function binding. If no equations are given, produce a function
2276 -- with the given arity that uses an empty case expression for the last
2277 -- argument that is passes to the given function to produce the right-hand
2278 -- side.
2279 mkFunBindEC :: Arity -> SrcSpan -> RdrName
2280 -> (LHsExpr GhcPs -> LHsExpr GhcPs)
2281 -> [([LPat GhcPs], LHsExpr GhcPs)]
2282 -> LHsBind GhcPs
2283 mkFunBindEC arity loc fun catch_all pats_and_exprs
2284 = mkRdrFunBindEC arity catch_all (L (noAnnSrcSpan loc) fun) matches
2285 where
2286 matches = [ mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun))
2287 (map (parenthesizePat appPrec) p) e
2288 emptyLocalBinds
2289 | (p,e) <- pats_and_exprs ]
2290
2291 -- | Produces a function binding. When no equations are given, it generates
2292 -- a binding of the given arity and an empty case expression
2293 -- for the last argument that it passes to the given function to produce
2294 -- the right-hand side.
2295 mkRdrFunBindEC :: Arity
2296 -> (LHsExpr GhcPs -> LHsExpr GhcPs)
2297 -> LocatedN RdrName
2298 -> [LMatch GhcPs (LHsExpr GhcPs)]
2299 -> LHsBind GhcPs
2300 mkRdrFunBindEC arity catch_all fun@(L loc _fun_rdr) matches
2301 = L (na2la loc) (mkFunBind Generated fun matches')
2302 where
2303 -- Catch-all eqn looks like
2304 -- fmap _ z = case z of {}
2305 -- or
2306 -- traverse _ z = pure (case z of)
2307 -- or
2308 -- foldMap _ z = mempty
2309 -- It's needed if there no data cons at all,
2310 -- which can happen with -XEmptyDataDecls
2311 -- See #4302
2312 matches' = if null matches
2313 then [mkMatch (mkPrefixFunRhs fun)
2314 (replicate (arity - 1) nlWildPat ++ [z_Pat])
2315 (catch_all $ nlHsCase z_Expr [])
2316 emptyLocalBinds]
2317 else matches
2318
2319 -- | Produces a function binding. When there are no equations, it generates
2320 -- a binding with the given arity that produces an error based on the name of
2321 -- the type of the last argument.
2322 mkRdrFunBindSE :: Arity -> LocatedN RdrName ->
2323 [LMatch GhcPs (LHsExpr GhcPs)] -> LHsBind GhcPs
2324 mkRdrFunBindSE arity fun@(L loc fun_rdr) matches
2325 = L (na2la loc) (mkFunBind Generated fun matches')
2326 where
2327 -- Catch-all eqn looks like
2328 -- compare _ _ = error "Void compare"
2329 -- It's needed if there no data cons at all,
2330 -- which can happen with -XEmptyDataDecls
2331 -- See #4302
2332 matches' = if null matches
2333 then [mkMatch (mkPrefixFunRhs fun)
2334 (replicate arity nlWildPat)
2335 (error_Expr str) emptyLocalBinds]
2336 else matches
2337 str = "Void " ++ occNameString (rdrNameOcc fun_rdr)
2338
2339
2340 box :: String -- The class involved
2341 -> LHsExpr GhcPs -- The argument
2342 -> Type -- The argument type
2343 -> LHsExpr GhcPs -- Boxed version of the arg
2344 -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
2345 box cls_str arg arg_ty = assoc_ty_id cls_str boxConTbl arg_ty arg
2346
2347 ---------------------
2348 primOrdOps :: String -- The class involved
2349 -> Type -- The type
2350 -> (RdrName, RdrName, RdrName, RdrName, RdrName) -- (lt,le,eq,ge,gt)
2351 -- See Note [Deriving and unboxed types] in GHC.Tc.Deriv.Infer
2352 primOrdOps str ty = assoc_ty_id str ordOpTbl ty
2353
2354 ordOpTbl :: [(Type, (RdrName, RdrName, RdrName, RdrName, RdrName))]
2355 ordOpTbl
2356 = [(charPrimTy , (ltChar_RDR , leChar_RDR
2357 , eqChar_RDR , geChar_RDR , gtChar_RDR ))
2358 ,(intPrimTy , (ltInt_RDR , leInt_RDR
2359 , eqInt_RDR , geInt_RDR , gtInt_RDR ))
2360 ,(int8PrimTy , (ltInt8_RDR , leInt8_RDR
2361 , eqInt8_RDR , geInt8_RDR , gtInt8_RDR ))
2362 ,(int16PrimTy , (ltInt16_RDR , leInt16_RDR
2363 , eqInt16_RDR , geInt16_RDR , gtInt16_RDR ))
2364 ,(int32PrimTy , (ltInt32_RDR , leInt32_RDR
2365 , eqInt32_RDR , geInt32_RDR , gtInt32_RDR ))
2366 ,(int64PrimTy , (ltInt64_RDR , leInt64_RDR
2367 , eqInt64_RDR , geInt64_RDR , gtInt64_RDR ))
2368 ,(wordPrimTy , (ltWord_RDR , leWord_RDR
2369 , eqWord_RDR , geWord_RDR , gtWord_RDR ))
2370 ,(word8PrimTy , (ltWord8_RDR , leWord8_RDR
2371 , eqWord8_RDR , geWord8_RDR , gtWord8_RDR ))
2372 ,(word16PrimTy, (ltWord16_RDR, leWord16_RDR
2373 , eqWord16_RDR, geWord16_RDR, gtWord16_RDR ))
2374 ,(word32PrimTy, (ltWord32_RDR, leWord32_RDR
2375 , eqWord32_RDR, geWord32_RDR, gtWord32_RDR ))
2376 ,(word64PrimTy, (ltWord64_RDR, leWord64_RDR
2377 , eqWord64_RDR, geWord64_RDR, gtWord64_RDR ))
2378 ,(addrPrimTy , (ltAddr_RDR , leAddr_RDR
2379 , eqAddr_RDR , geAddr_RDR , gtAddr_RDR ))
2380 ,(floatPrimTy , (ltFloat_RDR , leFloat_RDR
2381 , eqFloat_RDR , geFloat_RDR , gtFloat_RDR ))
2382 ,(doublePrimTy, (ltDouble_RDR, leDouble_RDR
2383 , eqDouble_RDR, geDouble_RDR, gtDouble_RDR)) ]
2384
2385 -- A mapping from a primitive type to a function that constructs its boxed
2386 -- version.
2387 -- NOTE: Int8#/Word8# will become Int/Word.
2388 boxConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
2389 boxConTbl =
2390 [ (charPrimTy , nlHsApp (nlHsVar $ getRdrName charDataCon))
2391 , (intPrimTy , nlHsApp (nlHsVar $ getRdrName intDataCon))
2392 , (wordPrimTy , nlHsApp (nlHsVar $ getRdrName wordDataCon ))
2393 , (floatPrimTy , nlHsApp (nlHsVar $ getRdrName floatDataCon ))
2394 , (doublePrimTy, nlHsApp (nlHsVar $ getRdrName doubleDataCon))
2395 , (int8PrimTy,
2396 nlHsApp (nlHsVar $ getRdrName intDataCon)
2397 . nlHsApp (nlHsVar int8ToInt_RDR))
2398 , (word8PrimTy,
2399 nlHsApp (nlHsVar $ getRdrName wordDataCon)
2400 . nlHsApp (nlHsVar word8ToWord_RDR))
2401 , (int16PrimTy,
2402 nlHsApp (nlHsVar $ getRdrName intDataCon)
2403 . nlHsApp (nlHsVar int16ToInt_RDR))
2404 , (word16PrimTy,
2405 nlHsApp (nlHsVar $ getRdrName wordDataCon)
2406 . nlHsApp (nlHsVar word16ToWord_RDR))
2407 , (int32PrimTy,
2408 nlHsApp (nlHsVar $ getRdrName intDataCon)
2409 . nlHsApp (nlHsVar int32ToInt_RDR))
2410 , (word32PrimTy,
2411 nlHsApp (nlHsVar $ getRdrName wordDataCon)
2412 . nlHsApp (nlHsVar word32ToWord_RDR))
2413 ]
2414
2415
2416 -- | A table of postfix modifiers for unboxed values.
2417 postfixModTbl :: [(Type, String)]
2418 postfixModTbl
2419 = [(charPrimTy , "#" )
2420 ,(intPrimTy , "#" )
2421 ,(wordPrimTy , "##")
2422 ,(floatPrimTy , "#" )
2423 ,(doublePrimTy, "##")
2424 ,(int8PrimTy, "#")
2425 ,(word8PrimTy, "##")
2426 ,(int16PrimTy, "#")
2427 ,(word16PrimTy, "##")
2428 ,(int32PrimTy, "#")
2429 ,(word32PrimTy, "##")
2430 ]
2431
2432 primConvTbl :: [(Type, String)]
2433 primConvTbl =
2434 [ (int8PrimTy, "intToInt8#")
2435 , (word8PrimTy, "wordToWord8#")
2436 , (int16PrimTy, "intToInt16#")
2437 , (word16PrimTy, "wordToWord16#")
2438 , (int32PrimTy, "intToInt32#")
2439 , (word32PrimTy, "wordToWord32#")
2440 ]
2441
2442 litConTbl :: [(Type, LHsExpr GhcPs -> LHsExpr GhcPs)]
2443 litConTbl
2444 = [(charPrimTy , nlHsApp (nlHsVar charPrimL_RDR))
2445 ,(intPrimTy , nlHsApp (nlHsVar intPrimL_RDR)
2446 . nlHsApp (nlHsVar toInteger_RDR))
2447 ,(wordPrimTy , nlHsApp (nlHsVar wordPrimL_RDR)
2448 . nlHsApp (nlHsVar toInteger_RDR))
2449 ,(addrPrimTy , nlHsApp (nlHsVar stringPrimL_RDR)
2450 . nlHsApp (nlHsApp
2451 (nlHsVar map_RDR)
2452 (compose_RDR `nlHsApps`
2453 [ nlHsVar fromIntegral_RDR
2454 , nlHsVar fromEnum_RDR
2455 ])))
2456 ,(floatPrimTy , nlHsApp (nlHsVar floatPrimL_RDR)
2457 . nlHsApp (nlHsVar toRational_RDR))
2458 ,(doublePrimTy, nlHsApp (nlHsVar doublePrimL_RDR)
2459 . nlHsApp (nlHsVar toRational_RDR))
2460 ]
2461
2462 -- | Lookup `Type` in an association list.
2463 assoc_ty_id :: HasCallStack => String -- The class involved
2464 -> [(Type,a)] -- The table
2465 -> Type -- The type
2466 -> a -- The result of the lookup
2467 assoc_ty_id cls_str tbl ty
2468 | Just a <- assoc_ty_id_maybe tbl ty = a
2469 | otherwise =
2470 pprPanic "Error in deriving:"
2471 (text "Can't derive" <+> text cls_str <+>
2472 text "for primitive type" <+> ppr ty)
2473
2474 -- | Lookup `Type` in an association list.
2475 assoc_ty_id_maybe :: [(Type, a)] -> Type -> Maybe a
2476 assoc_ty_id_maybe tbl ty = snd <$> find (\(t, _) -> t `eqType` ty) tbl
2477
2478 -----------------------------------------------------------------------
2479
2480 and_Expr :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
2481 and_Expr a b = genOpApp a and_RDR b
2482
2483 -----------------------------------------------------------------------
2484
2485 eq_Expr :: Type -> LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
2486 eq_Expr ty a b
2487 | not (isUnliftedType ty) = genOpApp a eq_RDR b
2488 | otherwise = genPrimOpApp a prim_eq b
2489 where
2490 (_, _, prim_eq, _, _) = primOrdOps "Eq" ty
2491
2492 untag_Expr :: [(RdrName, RdrName)]
2493 -> LHsExpr GhcPs -> LHsExpr GhcPs
2494 untag_Expr [] expr = expr
2495 untag_Expr ((untag_this, put_tag_here) : more) expr
2496 = nlHsCase (nlHsPar (nlHsVarApps dataToTag_RDR [untag_this])) {-of-}
2497 [mkHsCaseAlt (nlVarPat put_tag_here) (untag_Expr more expr)]
2498
2499 enum_from_to_Expr
2500 :: LHsExpr GhcPs -> LHsExpr GhcPs
2501 -> LHsExpr GhcPs
2502 enum_from_then_to_Expr
2503 :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
2504 -> LHsExpr GhcPs
2505
2506 enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2
2507 enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2
2508
2509 showParen_Expr
2510 :: LHsExpr GhcPs -> LHsExpr GhcPs
2511 -> LHsExpr GhcPs
2512
2513 showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2
2514
2515 nested_compose_Expr :: [LHsExpr GhcPs] -> LHsExpr GhcPs
2516
2517 nested_compose_Expr [] = panic "nested_compose_expr" -- Arg is always non-empty
2518 nested_compose_Expr [e] = parenify e
2519 nested_compose_Expr (e:es)
2520 = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es)
2521
2522 -- impossible_Expr is used in case RHSs that should never happen.
2523 -- We generate these to keep the desugarer from complaining that they *might* happen!
2524 error_Expr :: String -> LHsExpr GhcPs
2525 error_Expr string = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString string))
2526
2527 -- illegal_Expr is used when signalling error conditions in the RHS of a derived
2528 -- method. It is currently only used by Enum.{succ,pred}
2529 illegal_Expr :: String -> String -> String -> LHsExpr GhcPs
2530 illegal_Expr meth tp msg =
2531 nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg)))
2532
2533 -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you
2534 -- to include the value of a_RDR in the error string.
2535 illegal_toEnum_tag :: String -> RdrName -> LHsExpr GhcPs
2536 illegal_toEnum_tag tp maxtag =
2537 nlHsApp (nlHsVar error_RDR)
2538 (nlHsApp (nlHsApp (nlHsVar append_RDR)
2539 (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag ("))))
2540 (nlHsApp (nlHsApp (nlHsApp
2541 (nlHsVar showsPrec_RDR)
2542 (nlHsIntLit 0))
2543 (nlHsVar a_RDR))
2544 (nlHsApp (nlHsApp
2545 (nlHsVar append_RDR)
2546 (nlHsLit (mkHsString ") is outside of enumeration's range (0,")))
2547 (nlHsApp (nlHsApp (nlHsApp
2548 (nlHsVar showsPrec_RDR)
2549 (nlHsIntLit 0))
2550 (nlHsVar maxtag))
2551 (nlHsLit (mkHsString ")"))))))
2552
2553 parenify :: LHsExpr GhcPs -> LHsExpr GhcPs
2554 parenify e@(L _ (HsVar _ _)) = e
2555 parenify e = mkHsPar e
2556
2557 -- genOpApp wraps brackets round the operator application, so that the
2558 -- renamer won't subsequently try to re-associate it.
2559 genOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
2560 genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2)
2561
2562 genPrimOpApp :: LHsExpr GhcPs -> RdrName -> LHsExpr GhcPs -> LHsExpr GhcPs
2563 genPrimOpApp e1 op e2 = nlHsPar (nlHsApp (nlHsVar tagToEnum_RDR) (nlHsOpApp e1 op e2))
2564
2565 a_RDR, b_RDR, c_RDR, d_RDR, f_RDR, k_RDR, z_RDR, ah_RDR, bh_RDR, ch_RDR, dh_RDR
2566 :: RdrName
2567 a_RDR = mkVarUnqual (fsLit "a")
2568 b_RDR = mkVarUnqual (fsLit "b")
2569 c_RDR = mkVarUnqual (fsLit "c")
2570 d_RDR = mkVarUnqual (fsLit "d")
2571 f_RDR = mkVarUnqual (fsLit "f")
2572 k_RDR = mkVarUnqual (fsLit "k")
2573 z_RDR = mkVarUnqual (fsLit "z")
2574 ah_RDR = mkVarUnqual (fsLit "a#")
2575 bh_RDR = mkVarUnqual (fsLit "b#")
2576 ch_RDR = mkVarUnqual (fsLit "c#")
2577 dh_RDR = mkVarUnqual (fsLit "d#")
2578
2579 as_RDRs, bs_RDRs, cs_RDRs :: [RdrName]
2580 as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ]
2581 bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ]
2582 cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ]
2583
2584 a_Expr, b_Expr, c_Expr, z_Expr, ltTag_Expr, eqTag_Expr, gtTag_Expr, false_Expr,
2585 true_Expr, pure_Expr, unsafeCodeCoerce_Expr :: LHsExpr GhcPs
2586 a_Expr = nlHsVar a_RDR
2587 b_Expr = nlHsVar b_RDR
2588 c_Expr = nlHsVar c_RDR
2589 z_Expr = nlHsVar z_RDR
2590 ltTag_Expr = nlHsVar ltTag_RDR
2591 eqTag_Expr = nlHsVar eqTag_RDR
2592 gtTag_Expr = nlHsVar gtTag_RDR
2593 false_Expr = nlHsVar false_RDR
2594 true_Expr = nlHsVar true_RDR
2595 pure_Expr = nlHsVar pure_RDR
2596 unsafeCodeCoerce_Expr = nlHsVar unsafeCodeCoerce_RDR
2597
2598 a_Pat, b_Pat, c_Pat, d_Pat, k_Pat, z_Pat :: LPat GhcPs
2599 a_Pat = nlVarPat a_RDR
2600 b_Pat = nlVarPat b_RDR
2601 c_Pat = nlVarPat c_RDR
2602 d_Pat = nlVarPat d_RDR
2603 k_Pat = nlVarPat k_RDR
2604 z_Pat = nlVarPat z_RDR
2605
2606 minusInt_RDR, tagToEnum_RDR :: RdrName
2607 minusInt_RDR = getRdrName (primOpId IntSubOp )
2608 tagToEnum_RDR = getRdrName (primOpId TagToEnumOp)
2609
2610 new_tag2con_rdr_name, new_maxtag_rdr_name
2611 :: SrcSpan -> TyCon -> TcM RdrName
2612 -- Generates Exact RdrNames, for the binding positions
2613 new_tag2con_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkTag2ConOcc
2614 new_maxtag_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkMaxTagOcc
2615
2616 new_dataT_rdr_name :: SrcSpan -> TyCon -> TcM RdrName
2617 new_dataT_rdr_name dflags tycon = new_tc_deriv_rdr_name dflags tycon mkDataTOcc
2618
2619 new_dataC_rdr_name :: SrcSpan -> DataCon -> TcM RdrName
2620 new_dataC_rdr_name dflags dc = new_dc_deriv_rdr_name dflags dc mkDataCOcc
2621
2622 new_tc_deriv_rdr_name :: SrcSpan -> TyCon -> (OccName -> OccName) -> TcM RdrName
2623 new_tc_deriv_rdr_name loc tycon occ_fun
2624 = newAuxBinderRdrName loc (tyConName tycon) occ_fun
2625
2626 new_dc_deriv_rdr_name :: SrcSpan -> DataCon -> (OccName -> OccName) -> TcM RdrName
2627 new_dc_deriv_rdr_name loc dc occ_fun
2628 = newAuxBinderRdrName loc (dataConName dc) occ_fun
2629
2630 -- | Generate the name for an auxiliary binding, giving it a fresh 'Unique'.
2631 -- Returns an 'Exact' 'RdrName' with an underlying 'System' 'Name'.
2632 -- See @Note [Auxiliary binders]@.
2633 newAuxBinderRdrName :: SrcSpan -> Name -> (OccName -> OccName) -> TcM RdrName
2634 newAuxBinderRdrName loc parent occ_fun = do
2635 uniq <- newUnique
2636 pure $ Exact $ mkSystemNameAt uniq (occ_fun (nameOccName parent)) loc
2637
2638 -- | @getPossibleDataCons tycon tycon_args@ returns the constructors of @tycon@
2639 -- whose return types match when checked against @tycon_args@.
2640 --
2641 -- See Note [Filter out impossible GADT data constructors]
2642 getPossibleDataCons :: TyCon -> [Type] -> [DataCon]
2643 getPossibleDataCons tycon tycon_args = filter isPossible $ tyConDataCons tycon
2644 where
2645 isPossible = not . dataConCannotMatch (tyConInstArgTys tycon tycon_args)
2646
2647 -- | Given a type constructor @tycon@ of arity /n/ and a list of argument types
2648 -- @tycon_args@ of length /m/,
2649 --
2650 -- @
2651 -- tyConInstArgTys tycon tycon_args
2652 -- @
2653 --
2654 -- returns
2655 --
2656 -- @
2657 -- [tycon_arg_{1}, tycon_arg_{2}, ..., tycon_arg_{m}, extra_arg_{m+1}, ..., extra_arg_{n}]
2658 -- @
2659 --
2660 -- where @extra_args@ are distinct type variables.
2661 --
2662 -- Examples:
2663 --
2664 -- * Given @tycon: Foo a b@ and @tycon_args: [Int, Bool]@, return @[Int, Bool]@.
2665 --
2666 -- * Given @tycon: Foo a b@ and @tycon_args: [Int]@, return @[Int, b]@.
2667 tyConInstArgTys :: TyCon -> [Type] -> [Type]
2668 tyConInstArgTys tycon tycon_args = chkAppend tycon_args $ map mkTyVarTy tycon_args_suffix
2669 where
2670 tycon_args_suffix = drop (length tycon_args) $ tyConTyVars tycon
2671
2672 {-
2673 Note [Auxiliary binders]
2674 ~~~~~~~~~~~~~~~~~~~~~~~~
2675 We often want to make top-level auxiliary bindings in derived instances.
2676 For example, derived Ix instances sometimes generate code like this:
2677
2678 data T = ...
2679 deriving instance Ix T
2680
2681 ==>
2682
2683 instance Ix T where
2684 range (a, b) = map tag2con_T [dataToTag# a .. dataToTag# b]
2685
2686 $tag2con_T :: Int -> T
2687 $tag2con_T = ...code....
2688
2689 Note that multiple instances of the same type might need to use the same sort
2690 of auxiliary binding. For example, $tag2con is used not only in derived Ix
2691 instances, but also in derived Enum instances:
2692
2693 deriving instance Enum T
2694
2695 ==>
2696
2697 instance Enum T where
2698 toEnum i = tag2con_T i
2699
2700 $tag2con_T :: Int -> T
2701 $tag2con_T = ...code....
2702
2703 How do we ensure that the two usages of $tag2con_T do not conflict with each
2704 other? We do so by generating a separate $tag2con_T definition for each
2705 instance, giving each definition an Exact RdrName with a separate Unique to
2706 avoid name clashes:
2707
2708 instance Ix T where
2709 range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b]
2710
2711 instance Enum T where
2712 toEnum a = $tag2con_T{Uniq2} a
2713
2714 -- $tag2con_T{Uniq1} and $tag2con_T{Uniq2} are Exact RdrNames with
2715 -- underlying System Names
2716
2717 $tag2con_T{Uniq1} :: Int -> T
2718 $tag2con_T{Uniq1} = ...code....
2719
2720 $tag2con_T{Uniq2} :: Int -> T
2721 $tag2con_T{Uniq2} = ...code....
2722
2723 Note that:
2724
2725 * This is /precisely/ the same mechanism that we use for
2726 Template Haskell–generated code.
2727 See Note [Binders in Template Haskell] in GHC.ThToHs.
2728 There we explain why we use a 'System' flavour of the Name we generate.
2729
2730 * See "Wrinkle: Reducing code duplication" for how we can avoid generating
2731 lots of duplicated code in common situations.
2732
2733 * See "Wrinkle: Why we sometimes do generated duplicate code" for why this
2734 de-duplication mechanism isn't perfect, so we fall back to CSE
2735 (which is very effective within a single module).
2736
2737 * Note that the "_T" part of "$tag2con_T" is just for debug-printing
2738 purposes. We could call them all "$tag2con", or even just "aux".
2739 The Unique is enough to keep them separate.
2740
2741 This is important: we might be generating an Eq instance for two
2742 completely-distinct imported type constructors T.
2743
2744 At first glance, it might appear that this plan is infeasible, as it would
2745 require generating multiple top-level declarations with the same OccName. But
2746 what if auxiliary bindings /weren't/ top-level? Conceptually, we could imagine
2747 that auxiliary bindings are /local/ to the instance declarations in which they
2748 are used. Using some hypothetical Haskell syntax, it might look like this:
2749
2750 let {
2751 $tag2con_T{Uniq1} :: Int -> T
2752 $tag2con_T{Uniq1} = ...code....
2753
2754 $tag2con_T{Uniq2} :: Int -> T
2755 $tag2con_T{Uniq2} = ...code....
2756 } in {
2757 instance Ix T where
2758 range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b]
2759
2760 instance Enum T where
2761 toEnum a = $tag2con_T{Uniq2} a
2762 }
2763
2764 Making auxiliary bindings local is key to making this work, since GHC will
2765 not reject local bindings with duplicate names provided that:
2766
2767 * Each binding has a distinct unique, and
2768 * Each binding has an Exact RdrName with a System Name.
2769
2770 Even though the hypothetical Haskell syntax above does not exist, we can
2771 accomplish the same end result through some sleight of hand in renameDeriv:
2772 we rename auxiliary bindings with rnLocalValBindsLHS. (If we had used
2773 rnTopBindsLHS instead, then GHC would spuriously reject auxiliary bindings
2774 with the same OccName as duplicates.) Luckily, no special treatment is needed
2775 to typecheck them; we can typecheck them as normal top-level bindings
2776 (using tcTopBinds) without danger.
2777
2778 -----
2779 -- Wrinkle: Reducing code duplication
2780 -----
2781
2782 While the approach of generating copies of each sort of auxiliary binder per
2783 derived instance is simpler, it can lead to code bloat if done naïvely.
2784 Consider this example:
2785
2786 data T = ...
2787 deriving instance Eq T
2788 deriving instance Ord T
2789
2790 ==>
2791
2792 instance Ix T where
2793 range (a, b) = map tag2con_T{Uniq2} [dataToTag# a .. dataToTag# b]
2794
2795 instance Enum T where
2796 toEnum a = $tag2con_T{Uniq2} a
2797
2798 $tag2con_T{Uniq1} :: Int -> T
2799 $tag2con_T{Uniq1} = ...code....
2800
2801 $tag2con_T{Uniq2} :: Int -> T
2802 $tag2con_T{Uniq2} = ...code....
2803
2804 $tag2con_T{Uniq1} and $tag2con_T{Uniq2} are blatant duplicates of each other,
2805 which is not ideal. Surely GHC can do better than that at the very least! And
2806 indeed it does. Within the genAuxBinds function, GHC performs a small CSE-like
2807 pass to define duplicate auxiliary binders in terms of the original one. On
2808 the example above, that would look like this:
2809
2810 $tag2con_T{Uniq1} :: Int -> T
2811 $tag2con_T{Uniq1} = ...code....
2812
2813 $tag2con_T{Uniq2} :: Int -> T
2814 $tag2con_T{Uniq2} = $tag2con_T{Uniq1}
2815
2816 (Note that this pass does not cover all possible forms of code duplication.
2817 See "Wrinkle: Why we sometimes do generate duplicate code" for situations
2818 where genAuxBinds does not deduplicate code.)
2819
2820 To start, genAuxBinds is given a list of AuxBindSpecs, which describe the sort
2821 of auxiliary bindings that must be generates along with their RdrNames. As
2822 genAuxBinds processes this list, it marks the first occurrence of each sort of
2823 auxiliary binding as the "original". For example, if genAuxBinds sees a
2824 DerivCon2Tag for the first time (with the RdrName $tag2con_T{Uniq1}), then it
2825 will generate the full code for a $tag2con binding:
2826
2827 $tag2con_T{Uniq1} :: Int -> T
2828 $tag2con_T{Uniq1} = ...code....
2829
2830 Later, if genAuxBinds sees any additional DerivCon2Tag values, it will treat
2831 them as duplicates. For example, if genAuxBinds later sees a DerivCon2Tag with
2832 the RdrName $tag2con_T{Uniq2}, it will generate this code, which is much more
2833 compact:
2834
2835 $tag2con_T{Uniq2} :: Int -> T
2836 $tag2con_T{Uniq2} = $tag2con_T{Uniq1}
2837
2838 An alternative approach would be /not/ performing any kind of deduplication in
2839 genAuxBinds at all and simply relying on GHC's simplifier to perform this kind
2840 of CSE. But this is a more expensive analysis in general, while genAuxBinds can
2841 accomplish the same result with a simple check.
2842
2843 -----
2844 -- Wrinkle: Why we sometimes do generate duplicate code
2845 -----
2846
2847 It is worth noting that deduplicating auxiliary binders is difficult in the
2848 general case. Here are two particular examples where GHC cannot easily remove
2849 duplicate copies of an auxiliary binding:
2850
2851 1. When derived instances are contained in different modules, as in the
2852 following example:
2853
2854 module A where
2855 data T = ...
2856 module B where
2857 import A
2858 deriving instance Ix T
2859 module C where
2860 import B
2861 deriving instance Enum T
2862
2863 The derived Eq and Enum instances for T make use of $tag2con_T, and since
2864 they are defined in separate modules, each module must produce its own copy
2865 of $tag2con_T.
2866
2867 2. When derived instances are separated by TH splices (#18321), as in the
2868 following example:
2869
2870 module M where
2871
2872 data T = ...
2873 deriving instance Ix T
2874 $(pure [])
2875 deriving instance Enum T
2876
2877 Due to the way that GHC typechecks TyClGroups, genAuxBinds will run twice
2878 in this program: once for all the declarations before the TH splice, and
2879 once again for all the declarations after the TH splice. As a result,
2880 $tag2con_T will be generated twice, since genAuxBinds will be unable to
2881 recognize the presence of duplicates.
2882
2883 These situations are much rarer, so we do not spend any effort to deduplicate
2884 auxiliary bindings there. Instead, we focus on the common case of multiple
2885 derived instances within the same module, not separated by any TH splices.
2886 (This is the case described in "Wrinkle: Reducing code duplication".) In
2887 situation (1), we can at least fall back on GHC's simplifier to pick up
2888 genAuxBinds' slack.
2889
2890 Note [Filter out impossible GADT data constructors]
2891 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2892
2893 Some stock-derivable classes will filter out impossible GADT data constructors,
2894 to rule out problematic constructors when deriving instances. e.g.
2895
2896 ```
2897 data Foo a where
2898 X :: Foo Int
2899 Y :: (Bool -> Bool) -> Foo Bool
2900 ```
2901
2902 when deriving an instance on `Foo Int`, `Y` should be treated as if it didn't
2903 exist in the first place. For instance, if we write
2904
2905 ```
2906 deriving instance Eq (Foo Int)
2907 ```
2908
2909 it should generate:
2910
2911 ```
2912 instance Eq (Foo Int) where
2913 X == X = True
2914 ```
2915
2916 Classes that filter constructors:
2917
2918 * Eq
2919 * Ord
2920 * Show
2921 * Lift
2922 * Functor
2923 * Foldable
2924 * Traversable
2925
2926 Classes that do not filter constructors:
2927
2928 * Enum: doesn't make sense for GADTs in the first place
2929 * Bounded: only makes sense for GADTs with a single constructor
2930 * Ix: only makes sense for GADTs with a single constructor
2931 * Read: `Read a` returns `a` instead of consumes `a`, so filtering data
2932 constructors would make this function _more_ partial instead of less
2933 * Data: derived implementations of gunfold rely on a constructor-indexing
2934 scheme that wouldn't work if certain constructors were filtered out
2935 * Generic/Generic1: doesn't make sense for GADTs
2936
2937 Classes that do not currently filter constructors may do so in the future, if
2938 there is a valid use-case and we have requirements for how they should work.
2939
2940 See #16341 and the T16341.hs test case.
2941 -}