Remove knot-tying bug in TcHsSyn.zonkTyVarOcc
[ghc.git] / compiler / typecheck / TcInstDcls.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 TcInstDecls: Typechecking instance declarations
7 -}
8
9 {-# LANGUAGE CPP #-}
10 {-# LANGUAGE FlexibleContexts #-}
11 {-# LANGUAGE TypeFamilies #-}
12
13 module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where
14
15 #include "HsVersions.h"
16
17 import GhcPrelude
18
19 import HsSyn
20 import TcBinds
21 import TcTyClsDecls
22 import TcTyDecls ( addTyConsToGblEnv )
23 import TcClassDcl( tcClassDecl2, tcATDefault,
24 HsSigFun, mkHsSigFun,
25 findMethodBind, instantiateMethod )
26 import TcSigs
27 import TcRnMonad
28 import TcValidity
29 import TcHsSyn
30 import TcMType
31 import TcType
32 import BuildTyCl
33 import Inst
34 import InstEnv
35 import FamInst
36 import FamInstEnv
37 import TcDeriv
38 import TcEnv
39 import TcHsType
40 import TcUnify
41 import CoreSyn ( Expr(..), mkApps, mkVarApps, mkLams )
42 import MkCore ( nO_METHOD_BINDING_ERROR_ID )
43 import CoreUnfold ( mkInlineUnfoldingWithArity, mkDFunUnfolding )
44 import Type
45 import TcEvidence
46 import TyCon
47 import CoAxiom
48 import DataCon
49 import ConLike
50 import Class
51 import Var
52 import VarEnv
53 import VarSet
54 import Bag
55 import BasicTypes
56 import DynFlags
57 import ErrUtils
58 import FastString
59 import Id
60 import ListSetOps
61 import MkId
62 import Name
63 import NameSet
64 import Outputable
65 import SrcLoc
66 import Util
67 import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
68 import qualified GHC.LanguageExtensions as LangExt
69
70 import Control.Monad
71 import Maybes
72
73
74 {-
75 Typechecking instance declarations is done in two passes. The first
76 pass, made by @tcInstDecls1@, collects information to be used in the
77 second pass.
78
79 This pre-processed info includes the as-yet-unprocessed bindings
80 inside the instance declaration. These are type-checked in the second
81 pass, when the class-instance envs and GVE contain all the info from
82 all the instance and value decls. Indeed that's the reason we need
83 two passes over the instance decls.
84
85
86 Note [How instance declarations are translated]
87 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
88 Here is how we translate instance declarations into Core
89
90 Running example:
91 class C a where
92 op1, op2 :: Ix b => a -> b -> b
93 op2 = <dm-rhs>
94
95 instance C a => C [a]
96 {-# INLINE [2] op1 #-}
97 op1 = <rhs>
98 ===>
99 -- Method selectors
100 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
101 op1 = ...
102 op2 = ...
103
104 -- Default methods get the 'self' dictionary as argument
105 -- so they can call other methods at the same type
106 -- Default methods get the same type as their method selector
107 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
108 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
109 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
110 -- Note [Tricky type variable scoping]
111
112 -- A top-level definition for each instance method
113 -- Here op1_i, op2_i are the "instance method Ids"
114 -- The INLINE pragma comes from the user pragma
115 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
116 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
117 op1_i = /\a. \(d:C a).
118 let this :: C [a]
119 this = df_i a d
120 -- Note [Subtle interaction of recursion and overlap]
121
122 local_op1 :: forall b. Ix b => [a] -> b -> b
123 local_op1 = <rhs>
124 -- Source code; run the type checker on this
125 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
126 -- Note [Tricky type variable scoping]
127
128 in local_op1 a d
129
130 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
131
132 -- The dictionary function itself
133 {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
134 df_i :: forall a. C a -> C [a]
135 df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
136 -- But see Note [Default methods in instances]
137 -- We can't apply the type checker to the default-method call
138
139 -- Use a RULE to short-circuit applications of the class ops
140 {-# RULE "op1@C[a]" forall a, d:C a.
141 op1 [a] (df_i d) = op1_i a d #-}
142
143 Note [Instances and loop breakers]
144 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
145 * Note that df_i may be mutually recursive with both op1_i and op2_i.
146 It's crucial that df_i is not chosen as the loop breaker, even
147 though op1_i has a (user-specified) INLINE pragma.
148
149 * Instead the idea is to inline df_i into op1_i, which may then select
150 methods from the MkC record, and thereby break the recursion with
151 df_i, leaving a *self*-recursive op1_i. (If op1_i doesn't call op at
152 the same type, it won't mention df_i, so there won't be recursion in
153 the first place.)
154
155 * If op1_i is marked INLINE by the user there's a danger that we won't
156 inline df_i in it, and that in turn means that (since it'll be a
157 loop-breaker because df_i isn't), op1_i will ironically never be
158 inlined. But this is OK: the recursion breaking happens by way of
159 a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
160 unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
161
162 Note [ClassOp/DFun selection]
163 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
164 One thing we see a lot is stuff like
165 op2 (df d1 d2)
166 where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
167 'op2' and 'df' to get
168 case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
169 MkD _ op2 _ _ _ -> op2
170 And that will reduce to ($cop2 d1 d2) which is what we wanted.
171
172 But it's tricky to make this work in practice, because it requires us to
173 inline both 'op2' and 'df'. But neither is keen to inline without having
174 seen the other's result; and it's very easy to get code bloat (from the
175 big intermediate) if you inline a bit too much.
176
177 Instead we use a cunning trick.
178 * We arrange that 'df' and 'op2' NEVER inline.
179
180 * We arrange that 'df' is ALWAYS defined in the sylised form
181 df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
182
183 * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
184 that lists its methods.
185
186 * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
187 a suitable constructor application -- inlining df "on the fly" as it
188 were.
189
190 * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that
191 extracts the right piece iff its argument satisfies
192 exprIsConApp_maybe. This is done in MkId mkDictSelId
193
194 * We make 'df' CONLIKE, so that shared uses still match; eg
195 let d = df d1 d2
196 in ...(op2 d)...(op1 d)...
197
198 Note [Single-method classes]
199 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
200 If the class has just one method (or, more accurately, just one element
201 of {superclasses + methods}), then we use a different strategy.
202
203 class C a where op :: a -> a
204 instance C a => C [a] where op = <blah>
205
206 We translate the class decl into a newtype, which just gives a
207 top-level axiom. The "constructor" MkC expands to a cast, as does the
208 class-op selector.
209
210 axiom Co:C a :: C a ~ (a->a)
211
212 op :: forall a. C a -> (a -> a)
213 op a d = d |> (Co:C a)
214
215 MkC :: forall a. (a->a) -> C a
216 MkC = /\a.\op. op |> (sym Co:C a)
217
218 The clever RULE stuff doesn't work now, because ($df a d) isn't
219 a constructor application, so exprIsConApp_maybe won't return
220 Just <blah>.
221
222 Instead, we simply rely on the fact that casts are cheap:
223
224 $df :: forall a. C a => C [a]
225 {-# INLINE df #-} -- NB: INLINE this
226 $df = /\a. \d. MkC [a] ($cop_list a d)
227 = $cop_list |> forall a. C a -> (sym (Co:C [a]))
228
229 $cop_list :: forall a. C a => [a] -> [a]
230 $cop_list = <blah>
231
232 So if we see
233 (op ($df a d))
234 we'll inline 'op' and '$df', since both are simply casts, and
235 good things happen.
236
237 Why do we use this different strategy? Because otherwise we
238 end up with non-inlined dictionaries that look like
239 $df = $cop |> blah
240 which adds an extra indirection to every use, which seems stupid. See
241 Trac #4138 for an example (although the regression reported there
242 wasn't due to the indirection).
243
244 There is an awkward wrinkle though: we want to be very
245 careful when we have
246 instance C a => C [a] where
247 {-# INLINE op #-}
248 op = ...
249 then we'll get an INLINE pragma on $cop_list but it's important that
250 $cop_list only inlines when it's applied to *two* arguments (the
251 dictionary and the list argument). So we must not eta-expand $df
252 above. We ensure that this doesn't happen by putting an INLINE
253 pragma on the dfun itself; after all, it ends up being just a cast.
254
255 There is one more dark corner to the INLINE story, even more deeply
256 buried. Consider this (Trac #3772):
257
258 class DeepSeq a => C a where
259 gen :: Int -> a
260
261 instance C a => C [a] where
262 gen n = ...
263
264 class DeepSeq a where
265 deepSeq :: a -> b -> b
266
267 instance DeepSeq a => DeepSeq [a] where
268 {-# INLINE deepSeq #-}
269 deepSeq xs b = foldr deepSeq b xs
270
271 That gives rise to these defns:
272
273 $cdeepSeq :: DeepSeq a -> [a] -> b -> b
274 -- User INLINE( 3 args )!
275 $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
276
277 $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
278 -- DFun (with auto INLINE pragma)
279 $fDeepSeq[] a d = $cdeepSeq a d |> blah
280
281 $cp1 a d :: C a => DeepSep [a]
282 -- We don't want to eta-expand this, lest
283 -- $cdeepSeq gets inlined in it!
284 $cp1 a d = $fDeepSep[] a (scsel a d)
285
286 $fC[] :: C a => C [a]
287 -- Ordinary DFun
288 $fC[] a d = MkC ($cp1 a d) ($cgen a d)
289
290 Here $cp1 is the code that generates the superclass for C [a]. The
291 issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
292 and then $cdeepSeq will inline there, which is definitely wrong. Like
293 on the dfun, we solve this by adding an INLINE pragma to $cp1.
294
295 Note [Subtle interaction of recursion and overlap]
296 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
297 Consider this
298 class C a where { op1,op2 :: a -> a }
299 instance C a => C [a] where
300 op1 x = op2 x ++ op2 x
301 op2 x = ...
302 instance C [Int] where
303 ...
304
305 When type-checking the C [a] instance, we need a C [a] dictionary (for
306 the call of op2). If we look up in the instance environment, we find
307 an overlap. And in *general* the right thing is to complain (see Note
308 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
309 complain, because we just want to delegate to the op2 of this same
310 instance.
311
312 Why is this justified? Because we generate a (C [a]) constraint in
313 a context in which 'a' cannot be instantiated to anything that matches
314 other overlapping instances, or else we would not be executing this
315 version of op1 in the first place.
316
317 It might even be a bit disguised:
318
319 nullFail :: C [a] => [a] -> [a]
320 nullFail x = op2 x ++ op2 x
321
322 instance C a => C [a] where
323 op1 x = nullFail x
324
325 Precisely this is used in package 'regex-base', module Context.hs.
326 See the overlapping instances for RegexContext, and the fact that they
327 call 'nullFail' just like the example above. The DoCon package also
328 does the same thing; it shows up in module Fraction.hs.
329
330 Conclusion: when typechecking the methods in a C [a] instance, we want to
331 treat the 'a' as an *existential* type variable, in the sense described
332 by Note [Binding when looking up instances]. That is why isOverlappableTyVar
333 responds True to an InstSkol, which is the kind of skolem we use in
334 tcInstDecl2.
335
336
337 Note [Tricky type variable scoping]
338 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
339 In our example
340 class C a where
341 op1, op2 :: Ix b => a -> b -> b
342 op2 = <dm-rhs>
343
344 instance C a => C [a]
345 {-# INLINE [2] op1 #-}
346 op1 = <rhs>
347
348 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
349 in scope in <rhs>. In particular, we must make sure that 'b' is in
350 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
351 which brings appropriate tyvars into scope. This happens for both
352 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
353 complained if 'b' is mentioned in <rhs>.
354
355
356
357 ************************************************************************
358 * *
359 \subsection{Extracting instance decls}
360 * *
361 ************************************************************************
362
363 Gather up the instance declarations from their various sources
364 -}
365
366 tcInstDecls1 -- Deal with both source-code and imported instance decls
367 :: [LInstDecl GhcRn] -- Source code instance decls
368 -> TcM (TcGblEnv, -- The full inst env
369 [InstInfo GhcRn], -- Source-code instance decls to process;
370 -- contains all dfuns for this module
371 [DerivInfo]) -- From data family instances
372
373 tcInstDecls1 inst_decls
374 = do { -- Do class and family instance declarations
375 ; stuff <- mapAndRecoverM tcLocalInstDecl inst_decls
376
377 ; let (local_infos_s, fam_insts_s, datafam_deriv_infos) = unzip3 stuff
378 fam_insts = concat fam_insts_s
379 local_infos = concat local_infos_s
380
381 ; gbl_env <- addClsInsts local_infos $
382 addFamInsts fam_insts $
383 getGblEnv
384
385 ; return ( gbl_env
386 , local_infos
387 , concat datafam_deriv_infos ) }
388
389 -- | Use DerivInfo for data family instances (produced by tcInstDecls1),
390 -- datatype declarations (TyClDecl), and standalone deriving declarations
391 -- (DerivDecl) to check and process all derived class instances.
392 tcInstDeclsDeriv
393 :: [DerivInfo]
394 -> [LTyClDecl GhcRn]
395 -> [LDerivDecl GhcRn]
396 -> TcM (TcGblEnv, [InstInfo GhcRn], HsValBinds GhcRn)
397 tcInstDeclsDeriv datafam_deriv_infos tyclds derivds
398 = do th_stage <- getStage -- See Note [Deriving inside TH brackets]
399 if isBrackStage th_stage
400 then do { gbl_env <- getGblEnv
401 ; return (gbl_env, bagToList emptyBag, emptyValBindsOut) }
402 else do { data_deriv_infos <- mkDerivInfos tyclds
403 ; let deriv_infos = datafam_deriv_infos ++ data_deriv_infos
404 ; (tcg_env, info_bag, valbinds) <- tcDeriving deriv_infos derivds
405 ; return (tcg_env, bagToList info_bag, valbinds) }
406
407 addClsInsts :: [InstInfo GhcRn] -> TcM a -> TcM a
408 addClsInsts infos thing_inside
409 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
410
411 addFamInsts :: [FamInst] -> TcM a -> TcM a
412 -- Extend (a) the family instance envt
413 -- (b) the type envt with stuff from data type decls
414 addFamInsts fam_insts thing_inside
415 = tcExtendLocalFamInstEnv fam_insts $
416 tcExtendGlobalEnv axioms $
417 do { traceTc "addFamInsts" (pprFamInsts fam_insts)
418 ; gbl_env <- addTyConsToGblEnv data_rep_tycons
419 -- Does not add its axiom; that comes
420 -- from adding the 'axioms' above
421 ; setGblEnv gbl_env thing_inside }
422 where
423 axioms = map (ACoAxiom . toBranchedAxiom . famInstAxiom) fam_insts
424 data_rep_tycons = famInstsRepTyCons fam_insts
425 -- The representation tycons for 'data instances' declarations
426
427 {-
428 Note [Deriving inside TH brackets]
429 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
430 Given a declaration bracket
431 [d| data T = A | B deriving( Show ) |]
432
433 there is really no point in generating the derived code for deriving(
434 Show) and then type-checking it. This will happen at the call site
435 anyway, and the type check should never fail! Moreover (Trac #6005)
436 the scoping of the generated code inside the bracket does not seem to
437 work out.
438
439 The easy solution is simply not to generate the derived instances at
440 all. (A less brutal solution would be to generate them with no
441 bindings.) This will become moot when we shift to the new TH plan, so
442 the brutal solution will do.
443 -}
444
445 tcLocalInstDecl :: LInstDecl GhcRn
446 -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
447 -- A source-file instance declaration
448 -- Type-check all the stuff before the "where"
449 --
450 -- We check for respectable instance type, and context
451 tcLocalInstDecl (L loc (TyFamInstD { tfid_inst = decl }))
452 = do { fam_inst <- tcTyFamInstDecl Nothing (L loc decl)
453 ; return ([], [fam_inst], []) }
454
455 tcLocalInstDecl (L loc (DataFamInstD { dfid_inst = decl }))
456 = do { (fam_inst, m_deriv_info) <- tcDataFamInstDecl Nothing (L loc decl)
457 ; return ([], [fam_inst], maybeToList m_deriv_info) }
458
459 tcLocalInstDecl (L loc (ClsInstD { cid_inst = decl }))
460 = do { (insts, fam_insts, deriv_infos) <- tcClsInstDecl (L loc decl)
461 ; return (insts, fam_insts, deriv_infos) }
462
463 tcLocalInstDecl (L _ (XInstDecl _)) = panic "tcLocalInstDecl"
464
465 tcClsInstDecl :: LClsInstDecl GhcRn
466 -> TcM ([InstInfo GhcRn], [FamInst], [DerivInfo])
467 -- The returned DerivInfos are for any associated data families
468 tcClsInstDecl (L loc (ClsInstDecl { cid_poly_ty = poly_ty, cid_binds = binds
469 , cid_sigs = uprags, cid_tyfam_insts = ats
470 , cid_overlap_mode = overlap_mode
471 , cid_datafam_insts = adts }))
472 = setSrcSpan loc $
473 addErrCtxt (instDeclCtxt1 poly_ty) $
474 do { (tyvars, theta, clas, inst_tys)
475 <- tcHsClsInstType (InstDeclCtxt False) poly_ty
476 -- NB: tcHsClsInstType does checkValidInstance
477
478 ; let mini_env = mkVarEnv (classTyVars clas `zip` inst_tys)
479 mini_subst = mkTvSubst (mkInScopeSet (mkVarSet tyvars)) mini_env
480 mb_info = Just (clas, tyvars, mini_env)
481
482 -- Next, process any associated types.
483 ; traceTc "tcLocalInstDecl" (ppr poly_ty)
484 ; tyfam_insts0 <- scopeTyVars InstSkol tyvars $
485 mapAndRecoverM (tcTyFamInstDecl mb_info) ats
486 ; datafam_stuff <- scopeTyVars InstSkol tyvars $
487 mapAndRecoverM (tcDataFamInstDecl mb_info) adts
488 ; let (datafam_insts, m_deriv_infos) = unzip datafam_stuff
489 deriv_infos = catMaybes m_deriv_infos
490
491 -- Check for missing associated types and build them
492 -- from their defaults (if available)
493 ; let defined_ats = mkNameSet (map (tyFamInstDeclName . unLoc) ats)
494 `unionNameSet`
495 mkNameSet (map (unLoc . feqn_tycon
496 . hsib_body
497 . dfid_eqn
498 . unLoc) adts)
499 ; tyfam_insts1 <- mapM (tcATDefault loc mini_subst defined_ats)
500 (classATItems clas)
501
502 -- Finally, construct the Core representation of the instance.
503 -- (This no longer includes the associated types.)
504 ; dfun_name <- newDFunName clas inst_tys (getLoc (hsSigType poly_ty))
505 -- Dfun location is that of instance *header*
506
507 ; ispec <- newClsInst (fmap unLoc overlap_mode) dfun_name tyvars theta
508 clas inst_tys
509
510 ; let inst_info = InstInfo { iSpec = ispec
511 , iBinds = InstBindings
512 { ib_binds = binds
513 , ib_tyvars = map Var.varName tyvars -- Scope over bindings
514 , ib_pragmas = uprags
515 , ib_extensions = []
516 , ib_derived = False } }
517
518 -- In hs-boot files there should be no bindings
519 ; is_boot <- tcIsHsBootOrSig
520 ; let no_binds = isEmptyLHsBinds binds && null uprags
521 ; failIfTc (is_boot && not no_binds) badBootDeclErr
522
523 ; return ( [inst_info], tyfam_insts0 ++ concat tyfam_insts1 ++ datafam_insts
524 , deriv_infos ) }
525 tcClsInstDecl (L _ (XClsInstDecl _)) = panic "tcClsInstDecl"
526
527 {-
528 ************************************************************************
529 * *
530 Type checking family instances
531 * *
532 ************************************************************************
533
534 Family instances are somewhat of a hybrid. They are processed together with
535 class instance heads, but can contain data constructors and hence they share a
536 lot of kinding and type checking code with ordinary algebraic data types (and
537 GADTs).
538 -}
539
540 tcFamInstDeclCombined :: Maybe ClsInstInfo
541 -> Located Name -> TcM TyCon
542 tcFamInstDeclCombined mb_clsinfo fam_tc_lname
543 = do { -- Type family instances require -XTypeFamilies
544 -- and can't (currently) be in an hs-boot file
545 ; traceTc "tcFamInstDecl" (ppr fam_tc_lname)
546 ; type_families <- xoptM LangExt.TypeFamilies
547 ; is_boot <- tcIsHsBootOrSig -- Are we compiling an hs-boot file?
548 ; checkTc type_families $ badFamInstDecl fam_tc_lname
549 ; checkTc (not is_boot) $ badBootFamInstDeclErr
550
551 -- Look up the family TyCon and check for validity including
552 -- check that toplevel type instances are not for associated types.
553 ; fam_tc <- tcLookupLocatedTyCon fam_tc_lname
554 ; when (isNothing mb_clsinfo && -- Not in a class decl
555 isTyConAssoc fam_tc) -- but an associated type
556 (addErr $ assocInClassErr fam_tc_lname)
557
558 ; return fam_tc }
559
560 tcTyFamInstDecl :: Maybe ClsInstInfo
561 -> LTyFamInstDecl GhcRn -> TcM FamInst
562 -- "type instance"
563 tcTyFamInstDecl mb_clsinfo (L loc decl@(TyFamInstDecl { tfid_eqn = eqn }))
564 = setSrcSpan loc $
565 tcAddTyFamInstCtxt decl $
566 do { let fam_lname = feqn_tycon (hsib_body eqn)
567 ; fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_lname
568
569 -- (0) Check it's an open type family
570 ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
571 ; checkTc (isTypeFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
572 ; checkTc (isOpenTypeFamilyTyCon fam_tc) (notOpenFamily fam_tc)
573
574 -- (1) do the work of verifying the synonym group
575 ; co_ax_branch <- tcTyFamInstEqn fam_tc mb_clsinfo
576 (L (getLoc fam_lname) eqn)
577
578 -- (2) check for validity
579 ; checkValidCoAxBranch mb_clsinfo fam_tc co_ax_branch
580
581 -- (3) construct coercion axiom
582 ; rep_tc_name <- newFamInstAxiomName fam_lname [coAxBranchLHS co_ax_branch]
583 ; let axiom = mkUnbranchedCoAxiom rep_tc_name fam_tc co_ax_branch
584 ; newFamInst SynFamilyInst axiom }
585
586 tcDataFamInstDecl :: Maybe ClsInstInfo
587 -> LDataFamInstDecl GhcRn -> TcM (FamInst, Maybe DerivInfo)
588 -- "newtype instance" and "data instance"
589 tcDataFamInstDecl mb_clsinfo
590 (L loc decl@(DataFamInstDecl { dfid_eqn = HsIB { hsib_ext = tv_names
591 , hsib_body =
592 FamEqn { feqn_pats = pats
593 , feqn_tycon = fam_tc_name
594 , feqn_fixity = fixity
595 , feqn_rhs = HsDataDefn { dd_ND = new_or_data
596 , dd_cType = cType
597 , dd_ctxt = ctxt
598 , dd_cons = cons
599 , dd_kindSig = m_ksig
600 , dd_derivs = derivs } }}}))
601 = setSrcSpan loc $
602 tcAddDataFamInstCtxt decl $
603 do { fam_tc <- tcFamInstDeclCombined mb_clsinfo fam_tc_name
604
605 -- Check that the family declaration is for the right kind
606 ; checkTc (isFamilyTyCon fam_tc) (notFamily fam_tc)
607 ; checkTc (isDataFamilyTyCon fam_tc) (wrongKindOfFamily fam_tc)
608
609 -- Kind check type patterns
610 ; let mb_kind_env = thdOf3 <$> mb_clsinfo
611 ; tcFamTyPats fam_tc mb_clsinfo tv_names pats
612 (kcDataDefn mb_kind_env decl) $
613 \tvs pats res_kind ->
614 do { stupid_theta <- solveEqualities $ tcHsContext ctxt
615
616 -- Zonk the patterns etc into the Type world
617 ; (ze, tvs') <- zonkTyBndrs tvs
618 ; pats' <- zonkTcTypesToTypesX ze pats
619 ; res_kind' <- zonkTcTypeToTypeX ze res_kind
620 ; stupid_theta' <- zonkTcTypesToTypesX ze stupid_theta
621
622 ; gadt_syntax <- dataDeclChecks (tyConName fam_tc) new_or_data stupid_theta' cons
623
624 -- Construct representation tycon
625 ; rep_tc_name <- newFamInstTyConName fam_tc_name pats'
626 ; axiom_name <- newFamInstAxiomName fam_tc_name [pats']
627
628 ; let (eta_pats, etad_tvs) = eta_reduce pats'
629 eta_tvs = filterOut (`elem` etad_tvs) tvs'
630 -- NB: the "extra" tvs from tcDataKindSig would always be eta-reduced
631
632 full_tcbs = mkTyConBindersPreferAnon (eta_tvs ++ etad_tvs) res_kind'
633 -- Put the eta-removed tyvars at the end
634 -- Remember, tvs' is in arbitrary order (except kind vars are
635 -- first, so there is no reason to suppose that the etad_tvs
636 -- (obtained from the pats) are at the end (Trac #11148)
637
638 -- Deal with any kind signature.
639 -- See also Note [Arity of data families] in FamInstEnv
640 ; (extra_tcbs, final_res_kind) <- tcDataKindSig full_tcbs res_kind'
641 ; checkTc (tcIsLiftedTypeKind final_res_kind) (badKindSig True res_kind')
642
643 ; let extra_pats = map (mkTyVarTy . binderVar) extra_tcbs
644 all_pats = pats' `chkAppend` extra_pats
645 orig_res_ty = mkTyConApp fam_tc all_pats
646
647 ; (rep_tc, axiom) <- fixM $ \ ~(rec_rep_tc, _) ->
648 do { let ty_binders = full_tcbs `chkAppend` extra_tcbs
649 ; data_cons <- tcConDecls rec_rep_tc
650 (ty_binders, orig_res_ty) cons
651 ; tc_rhs <- case new_or_data of
652 DataType -> return (mkDataTyConRhs data_cons)
653 NewType -> ASSERT( not (null data_cons) )
654 mkNewTyConRhs rep_tc_name rec_rep_tc (head data_cons)
655 -- freshen tyvars
656 ; let axiom = mkSingleCoAxiom Representational
657 axiom_name eta_tvs [] fam_tc eta_pats
658 (mkTyConApp rep_tc (mkTyVarTys eta_tvs))
659 parent = DataFamInstTyCon axiom fam_tc all_pats
660
661
662 -- NB: Use the full ty_binders from the pats. See bullet toward
663 -- the end of Note [Data type families] in TyCon
664 rep_tc = mkAlgTyCon rep_tc_name
665 ty_binders liftedTypeKind
666 (map (const Nominal) ty_binders)
667 (fmap unLoc cType) stupid_theta
668 tc_rhs parent
669 gadt_syntax
670 -- We always assume that indexed types are recursive. Why?
671 -- (1) Due to their open nature, we can never be sure that a
672 -- further instance might not introduce a new recursive
673 -- dependency. (2) They are always valid loop breakers as
674 -- they involve a coercion.
675 ; return (rep_tc, axiom) }
676
677 -- Remember to check validity; no recursion to worry about here
678 -- Check that left-hand sides are ok (mono-types, no type families,
679 -- consistent instantiations, etc)
680 ; checkValidFamPats mb_clsinfo fam_tc tvs' [] pats' extra_pats pp_hs_pats
681
682 -- Result kind must be '*' (otherwise, we have too few patterns)
683 ; checkTc (tcIsLiftedTypeKind final_res_kind) $
684 tooFewParmsErr (tyConArity fam_tc)
685
686 ; checkValidTyCon rep_tc
687
688 ; let m_deriv_info = case derivs of
689 L _ [] -> Nothing
690 L _ preds ->
691 Just $ DerivInfo { di_rep_tc = rep_tc
692 , di_clauses = preds
693 , di_ctxt = tcMkDataFamInstCtxt decl }
694
695 ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
696 ; return (fam_inst, m_deriv_info) } }
697 where
698 eta_reduce :: [Type] -> ([Type], [TyVar])
699 -- See Note [Eta reduction for data families] in FamInstEnv
700 -- Splits the incoming patterns into two: the [TyVar]
701 -- are the patterns that can be eta-reduced away.
702 -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c])
703 --
704 -- NB: quadratic algorithm, but types are small here
705 eta_reduce pats
706 = go (reverse pats) []
707 go (pat:pats) etad_tvs
708 | Just tv <- getTyVar_maybe pat
709 , not (tv `elemVarSet` tyCoVarsOfTypes pats)
710 = go pats (tv : etad_tvs)
711 go pats etad_tvs = (reverse pats, etad_tvs)
712
713 pp_hs_pats = pprFamInstLHS fam_tc_name pats fixity (unLoc ctxt) m_ksig
714
715 tcDataFamInstDecl _
716 (L _ (DataFamInstDecl
717 { dfid_eqn = HsIB { hsib_body = FamEqn { feqn_rhs = XHsDataDefn _ }}}))
718 = panic "tcDataFamInstDecl"
719 tcDataFamInstDecl _ (L _ (DataFamInstDecl (XHsImplicitBndrs _)))
720 = panic "tcDataFamInstDecl"
721 tcDataFamInstDecl _ (L _ (DataFamInstDecl (HsIB _ (XFamEqn _))))
722 = panic "tcDataFamInstDecl"
723
724
725 {- *********************************************************************
726 * *
727 Type-checking instance declarations, pass 2
728 * *
729 ********************************************************************* -}
730
731 tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
732 -> TcM (LHsBinds GhcTc)
733 -- (a) From each class declaration,
734 -- generate any default-method bindings
735 -- (b) From each instance decl
736 -- generate the dfun binding
737
738 tcInstDecls2 tycl_decls inst_decls
739 = do { -- (a) Default methods from class decls
740 let class_decls = filter (isClassDecl . unLoc) tycl_decls
741 ; dm_binds_s <- mapM tcClassDecl2 class_decls
742 ; let dm_binds = unionManyBags dm_binds_s
743
744 -- (b) instance declarations
745 ; let dm_ids = collectHsBindsBinders dm_binds
746 -- Add the default method Ids (again)
747 -- (they were arready added in TcTyDecls.tcAddImplicits)
748 -- See Note [Default methods in the type environment]
749 ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $
750 mapM tcInstDecl2 inst_decls
751
752 -- Done
753 ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
754
755 {- Note [Default methods in the type environment]
756 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
757 The default method Ids are already in the type environment (see Note
758 [Default method Ids and Template Haskell] in TcTyDcls), BUT they
759 don't have their InlinePragmas yet. Usually that would not matter,
760 because the simplifier propagates information from binding site to
761 use. But, unusually, when compiling instance decls we *copy* the
762 INLINE pragma from the default method to the method for that
763 particular operation (see Note [INLINE and default methods] below).
764
765 So right here in tcInstDecls2 we must re-extend the type envt with
766 the default method Ids replete with their INLINE pragmas. Urk.
767 -}
768
769 tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
770 -- Returns a binding for the dfun
771 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
772 = recoverM (return emptyLHsBinds) $
773 setSrcSpan loc $
774 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
775 do { -- Instantiate the instance decl with skolem constants
776 ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id
777 ; dfun_ev_vars <- newEvVars dfun_theta
778 -- We instantiate the dfun_id with superSkolems.
779 -- See Note [Subtle interaction of recursion and overlap]
780 -- and Note [Binding when looking up instances]
781
782 ; let (clas, inst_tys) = tcSplitDFunHead inst_head
783 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
784 sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta
785
786 ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
787
788 -- Deal with 'SPECIALISE instance' pragmas
789 -- See Note [SPECIALISE instance pragmas]
790 ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
791
792 -- Typecheck superclasses and methods
793 -- See Note [Typechecking plan for instance declarations]
794 ; dfun_ev_binds_var <- newTcEvBinds
795 ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var
796 ; ((sc_meth_ids, sc_meth_binds, sc_meth_implics), tclvl)
797 <- pushTcLevelM $
798 do { (sc_ids, sc_binds, sc_implics)
799 <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars
800 inst_tys dfun_ev_binds
801 sc_theta'
802
803 -- Typecheck the methods
804 ; (meth_ids, meth_binds, meth_implics)
805 <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars
806 inst_tys dfun_ev_binds spec_inst_info
807 op_items ibinds
808
809 ; return ( sc_ids ++ meth_ids
810 , sc_binds `unionBags` meth_binds
811 , sc_implics `unionBags` meth_implics ) }
812
813 ; imp <- newImplication
814 ; emitImplication $
815 imp { ic_tclvl = tclvl
816 , ic_skols = inst_tyvars
817 , ic_given = dfun_ev_vars
818 , ic_wanted = mkImplicWC sc_meth_implics
819 , ic_binds = dfun_ev_binds_var
820 , ic_info = InstSkol }
821
822 -- Create the result bindings
823 ; self_dict <- newDict clas inst_tys
824 ; let class_tc = classTyCon clas
825 [dict_constr] = tyConDataCons class_tc
826 dict_bind = mkVarBind self_dict (L loc con_app_args)
827
828 -- We don't produce a binding for the dict_constr; instead we
829 -- rely on the simplifier to unfold this saturated application
830 -- We do this rather than generate an HsCon directly, because
831 -- it means that the special cases (e.g. dictionary with only one
832 -- member) are dealt with by the common MkId.mkDataConWrapId
833 -- code rather than needing to be repeated here.
834 -- con_app_tys = MkD ty1 ty2
835 -- con_app_scs = MkD ty1 ty2 sc1 sc2
836 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
837 con_app_tys = mkHsWrap (mkWpTyApps inst_tys)
838 (HsConLikeOut noExt (RealDataCon dict_constr))
839 -- NB: We *can* have covars in inst_tys, in the case of
840 -- promoted GADT constructors.
841
842 con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids
843
844 app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
845 app_to_meth fun meth_id = HsApp noExt (L loc fun)
846 (L loc (wrapId arg_wrapper meth_id))
847
848 inst_tv_tys = mkTyVarTys inst_tyvars
849 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
850
851 is_newtype = isNewTyCon class_tc
852 dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids
853 dfun_spec_prags
854 | is_newtype = SpecPrags []
855 | otherwise = SpecPrags spec_inst_prags
856 -- Newtype dfuns just inline unconditionally,
857 -- so don't attempt to specialise them
858
859 export = ABE { abe_ext = noExt
860 , abe_wrap = idHsWrapper
861 , abe_poly = dfun_id_w_prags
862 , abe_mono = self_dict
863 , abe_prags = dfun_spec_prags }
864 -- NB: see Note [SPECIALISE instance pragmas]
865 main_bind = AbsBinds { abs_ext = noExt
866 , abs_tvs = inst_tyvars
867 , abs_ev_vars = dfun_ev_vars
868 , abs_exports = [export]
869 , abs_ev_binds = []
870 , abs_binds = unitBag dict_bind
871 , abs_sig = True }
872
873 ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
874 }
875 where
876 dfun_id = instanceDFunId ispec
877 loc = getSrcSpan dfun_id
878
879 addDFunPrags :: DFunId -> [Id] -> DFunId
880 -- DFuns need a special Unfolding and InlinePrag
881 -- See Note [ClassOp/DFun selection]
882 -- and Note [Single-method classes]
883 -- It's easiest to create those unfoldings right here, where
884 -- have all the pieces in hand, even though we are messing with
885 -- Core at this point, which the typechecker doesn't usually do
886 -- However we take care to build the unfolding using the TyVars from
887 -- the DFunId rather than from the skolem pieces that the typechecker
888 -- is messing with.
889 addDFunPrags dfun_id sc_meth_ids
890 | is_newtype
891 = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app
892 `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
893 | otherwise
894 = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
895 `setInlinePragma` dfunInlinePragma
896 where
897 con_app = mkLams dfun_bndrs $
898 mkApps (Var (dataConWrapId dict_con)) dict_args
899 -- mkApps is OK because of the checkForLevPoly call in checkValidClass
900 -- See Note [Levity polymorphism checking] in DsMonad
901 dict_args = map Type inst_tys ++
902 [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]
903
904 (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
905 ev_ids = mkTemplateLocalsNum 1 dfun_theta
906 dfun_bndrs = dfun_tvs ++ ev_ids
907 clas_tc = classTyCon clas
908 [dict_con] = tyConDataCons clas_tc
909 is_newtype = isNewTyCon clas_tc
910
911 wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)
912 wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id))
913
914 {- Note [Typechecking plan for instance declarations]
915 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
916 For instance declarations we generate the following bindings and implication
917 constraints. Example:
918
919 instance Ord a => Ord [a] where compare = <compare-rhs>
920
921 generates this:
922
923 Bindings:
924 -- Method bindings
925 $ccompare :: forall a. Ord a => a -> a -> Ordering
926 $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...
927
928 -- Superclass bindings
929 $cp1Ord :: forall a. Ord a => Eq [a]
930 $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>
931 in dfEqList (dw :: Eq a)
932
933 Constraints:
934 forall a. Ord a =>
935 -- Method constraint
936 (forall. (empty) => <constraints from compare-rhs>)
937 -- Superclass constraint
938 /\ (forall. (empty) => dw :: Eq a)
939
940 Notice that
941
942 * Per-meth/sc implication. There is one inner implication per
943 superclass or method, with no skolem variables or givens. The only
944 reason for this one is to gather the evidence bindings privately
945 for this superclass or method. This implication is generated
946 by checkInstConstraints.
947
948 * Overall instance implication. There is an overall enclosing
949 implication for the whole instance declaration, with the expected
950 skolems and givens. We need this to get the correct "redundant
951 constraint" warnings, gathering all the uses from all the methods
952 and superclasses. See TcSimplify Note [Tracking redundant
953 constraints]
954
955 * The given constraints in the outer implication may generate
956 evidence, notably by superclass selection. Since the method and
957 superclass bindings are top-level, we want that evidence copied
958 into *every* method or superclass definition. (Some of it will
959 be usused in some, but dead-code elimination will drop it.)
960
961 We achieve this by putting the evidence variable for the overall
962 instance implication into the AbsBinds for each method/superclass.
963 Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.
964 (And that in turn is why the abs_ev_binds field of AbBinds is a
965 [TcEvBinds] rather than simply TcEvBinds.
966
967 This is a bit of a hack, but works very nicely in practice.
968
969 * Note that if a method has a locally-polymorphic binding, there will
970 be yet another implication for that, generated by tcPolyCheck
971 in tcMethodBody. E.g.
972 class C a where
973 foo :: forall b. Ord b => blah
974
975
976 ************************************************************************
977 * *
978 Type-checking superclasses
979 * *
980 ************************************************************************
981 -}
982
983 tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
984 -> TcEvBinds
985 -> TcThetaType
986 -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
987 -- Make a new top-level function binding for each superclass,
988 -- something like
989 -- $Ordp1 :: forall a. Ord a => Eq [a]
990 -- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
991 --
992 -- See Note [Recursive superclasses] for why this is so hard!
993 -- In effect, we build a special-purpose solver for the first step
994 -- of solving each superclass constraint
995 tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
996 = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])
997 ; return (ids, listToBag binds, listToBag implics) }
998 where
999 loc = getSrcSpan dfun_id
1000 size = sizeTypes inst_tys
1001 tc_super (sc_pred, n)
1002 = do { (sc_implic, ev_binds_var, sc_ev_tm)
1003 <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred
1004
1005 ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
1006 ; sc_ev_id <- newEvVar sc_pred
1007 ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
1008 ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)
1009 sc_top_id = mkLocalId sc_top_name sc_top_ty
1010 export = ABE { abe_ext = noExt
1011 , abe_wrap = idHsWrapper
1012 , abe_poly = sc_top_id
1013 , abe_mono = sc_ev_id
1014 , abe_prags = noSpecPrags }
1015 local_ev_binds = TcEvBinds ev_binds_var
1016 bind = AbsBinds { abs_ext = noExt
1017 , abs_tvs = tyvars
1018 , abs_ev_vars = dfun_evs
1019 , abs_exports = [export]
1020 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1021 , abs_binds = emptyBag
1022 , abs_sig = False }
1023 ; return (sc_top_id, L loc bind, sc_implic) }
1024
1025 -------------------
1026 checkInstConstraints :: TcM result
1027 -> TcM (Implication, EvBindsVar, result)
1028 -- See Note [Typechecking plan for instance declarations]
1029 checkInstConstraints thing_inside
1030 = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $
1031 thing_inside
1032
1033 ; ev_binds_var <- newTcEvBinds
1034 ; implic <- newImplication
1035 ; let implic' = implic { ic_tclvl = tclvl
1036 , ic_wanted = wanted
1037 , ic_binds = ev_binds_var
1038 , ic_info = InstSkol }
1039
1040 ; return (implic', ev_binds_var, result) }
1041
1042 {-
1043 Note [Recursive superclasses]
1044 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1045 See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all
1046 describe somewhat more complicated situations, but ones
1047 encountered in practice.
1048
1049 See also tests tcrun020, tcrun021, tcrun033, and Trac #11427.
1050
1051 ----- THE PROBLEM --------
1052 The problem is that it is all too easy to create a class whose
1053 superclass is bottom when it should not be.
1054
1055 Consider the following (extreme) situation:
1056 class C a => D a where ...
1057 instance D [a] => D [a] where ... (dfunD)
1058 instance C [a] => C [a] where ... (dfunC)
1059 Although this looks wrong (assume D [a] to prove D [a]), it is only a
1060 more extreme case of what happens with recursive dictionaries, and it
1061 can, just about, make sense because the methods do some work before
1062 recursing.
1063
1064 To implement the dfunD we must generate code for the superclass C [a],
1065 which we had better not get by superclass selection from the supplied
1066 argument:
1067 dfunD :: forall a. D [a] -> D [a]
1068 dfunD = \d::D [a] -> MkD (scsel d) ..
1069
1070 Otherwise if we later encounter a situation where
1071 we have a [Wanted] dw::D [a] we might solve it thus:
1072 dw := dfunD dw
1073 Which is all fine except that now ** the superclass C is bottom **!
1074
1075 The instance we want is:
1076 dfunD :: forall a. D [a] -> D [a]
1077 dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
1078
1079 ----- THE SOLUTION --------
1080 The basic solution is simple: be very careful about using superclass
1081 selection to generate a superclass witness in a dictionary function
1082 definition. More precisely:
1083
1084 Superclass Invariant: in every class dictionary,
1085 every superclass dictionary field
1086 is non-bottom
1087
1088 To achieve the Superclass Invariant, in a dfun definition we can
1089 generate a guaranteed-non-bottom superclass witness from:
1090 (sc1) one of the dictionary arguments itself (all non-bottom)
1091 (sc2) an immediate superclass of a smaller dictionary
1092 (sc3) a call of a dfun (always returns a dictionary constructor)
1093
1094 The tricky case is (sc2). We proceed by induction on the size of
1095 the (type of) the dictionary, defined by TcValidity.sizeTypes.
1096 Let's suppose we are building a dictionary of size 3, and
1097 suppose the Superclass Invariant holds of smaller dictionaries.
1098 Then if we have a smaller dictionary, its immediate superclasses
1099 will be non-bottom by induction.
1100
1101 What does "we have a smaller dictionary" mean? It might be
1102 one of the arguments of the instance, or one of its superclasses.
1103 Here is an example, taken from CmmExpr:
1104 class Ord r => UserOfRegs r a where ...
1105 (i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where
1106 (i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
1107
1108 For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
1109 since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
1110
1111 But for (i2) that isn't the case, so we must add an explicit, and
1112 perhaps surprising, (Ord r) argument to the instance declaration.
1113
1114 Here's another example from Trac #6161:
1115
1116 class Super a => Duper a where ...
1117 class Duper (Fam a) => Foo a where ...
1118 (i3) instance Foo a => Duper (Fam a) where ...
1119 (i4) instance Foo Float where ...
1120
1121 It would be horribly wrong to define
1122 dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3)
1123 dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
1124
1125 dfFooFloat :: Foo Float -- from (i4)
1126 dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
1127
1128 Now the Super superclass of Duper is definitely bottom!
1129
1130 This won't happen because when processing (i3) we can use the
1131 superclasses of (Foo a), which is smaller, namely Duper (Fam a). But
1132 that is *not* smaller than the target so we can't take *its*
1133 superclasses. As a result the program is rightly rejected, unless you
1134 add (Super (Fam a)) to the context of (i3).
1135
1136 Note [Solving superclass constraints]
1137 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1138 How do we ensure that every superclass witness is generated by
1139 one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].
1140 Answer:
1141
1142 * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)
1143 where 'size' is the size of the instance declaration. e.g.
1144 class C a => D a where...
1145 instance blah => D [a] where ...
1146 The wanted superclass constraint for C [a] has origin
1147 ScOrigin size, where size = size( D [a] ).
1148
1149 * (sc1) When we rewrite such a wanted constraint, it retains its
1150 origin. But if we apply an instance declaration, we can set the
1151 origin to (ScOrigin infinity), thus lifting any restrictions by
1152 making prohibitedSuperClassSolve return False.
1153
1154 * (sc2) ScOrigin wanted constraints can't be solved from a
1155 superclass selection, except at a smaller type. This test is
1156 implemented by TcInteract.prohibitedSuperClassSolve
1157
1158 * The "given" constraints of an instance decl have CtOrigin
1159 GivenOrigin InstSkol.
1160
1161 * When we make a superclass selection from InstSkol we use
1162 a SkolemInfo of (InstSC size), where 'size' is the size of
1163 the constraint whose superclass we are taking. A similarly
1164 when taking the superclass of an InstSC. This is implemented
1165 in TcCanonical.newSCWorkFromFlavored
1166
1167 Note [Silent superclass arguments] (historical interest only)
1168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1169 NB1: this note describes our *old* solution to the
1170 recursive-superclass problem. I'm keeping the Note
1171 for now, just as institutional memory.
1172 However, the code for silent superclass arguments
1173 was removed in late Dec 2014
1174
1175 NB2: the silent-superclass solution introduced new problems
1176 of its own, in the form of instance overlap. Tests
1177 SilentParametersOverlapping, T5051, and T7862 are examples
1178
1179 NB3: the silent-superclass solution also generated tons of
1180 extra dictionaries. For example, in monad-transformer
1181 code, when constructing a Monad dictionary you had to pass
1182 an Applicative dictionary; and to construct that you neede
1183 a Functor dictionary. Yet these extra dictionaries were
1184 often never used. Test T3064 compiled *far* faster after
1185 silent superclasses were eliminated.
1186
1187 Our solution to this problem "silent superclass arguments". We pass
1188 to each dfun some ``silent superclass arguments’’, which are the
1189 immediate superclasses of the dictionary we are trying to
1190 construct. In our example:
1191 dfun :: forall a. C [a] -> D [a] -> D [a]
1192 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
1193 Notice the extra (dc :: C [a]) argument compared to the previous version.
1194
1195 This gives us:
1196
1197 -----------------------------------------------------------
1198 DFun Superclass Invariant
1199 ~~~~~~~~~~~~~~~~~~~~~~~~
1200 In the body of a DFun, every superclass argument to the
1201 returned dictionary is
1202 either * one of the arguments of the DFun,
1203 or * constant, bound at top level
1204 -----------------------------------------------------------
1205
1206 This net effect is that it is safe to treat a dfun application as
1207 wrapping a dictionary constructor around its arguments (in particular,
1208 a dfun never picks superclasses from the arguments under the
1209 dictionary constructor). No superclass is hidden inside a dfun
1210 application.
1211
1212 The extra arguments required to satisfy the DFun Superclass Invariant
1213 always come first, and are called the "silent" arguments. You can
1214 find out how many silent arguments there are using Id.dfunNSilent;
1215 and then you can just drop that number of arguments to see the ones
1216 that were in the original instance declaration.
1217
1218 DFun types are built (only) by MkId.mkDictFunId, so that is where we
1219 decide what silent arguments are to be added.
1220 -}
1221
1222 {-
1223 ************************************************************************
1224 * *
1225 Type-checking an instance method
1226 * *
1227 ************************************************************************
1228
1229 tcMethod
1230 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1231 - Remembering to use fresh Name (the instance method Name) as the binder
1232 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1233 - Use sig_fn mapping instance method Name -> instance tyvars
1234 - Ditto prag_fn
1235 - Use tcValBinds to do the checking
1236 -}
1237
1238 tcMethods :: DFunId -> Class
1239 -> [TcTyVar] -> [EvVar]
1240 -> [TcType]
1241 -> TcEvBinds
1242 -> ([Located TcSpecPrag], TcPragEnv)
1243 -> [ClassOpItem]
1244 -> InstBindings GhcRn
1245 -> TcM ([Id], LHsBinds GhcTc, Bag Implication)
1246 -- The returned inst_meth_ids all have types starting
1247 -- forall tvs. theta => ...
1248 tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1249 dfun_ev_binds (spec_inst_prags, prag_fn) op_items
1250 (InstBindings { ib_binds = binds
1251 , ib_tyvars = lexical_tvs
1252 , ib_pragmas = sigs
1253 , ib_extensions = exts
1254 , ib_derived = is_derived })
1255 -- tcExtendTyVarEnv (not scopeTyVars) is OK because the TcLevel is pushed
1256 -- in checkInstConstraints
1257 = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $
1258 -- The lexical_tvs scope over the 'where' part
1259 do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
1260 ; checkMinimalDefinition
1261 ; checkMethBindMembership
1262 ; (ids, binds, mb_implics) <- set_exts exts $
1263 unset_warnings_deriving $
1264 mapAndUnzip3M tc_item op_items
1265 ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
1266 where
1267 set_exts :: [LangExt.Extension] -> TcM a -> TcM a
1268 set_exts es thing = foldr setXOptM thing es
1269
1270 -- See Note [Avoid -Winaccessible-code when deriving]
1271 unset_warnings_deriving :: TcM a -> TcM a
1272 unset_warnings_deriving
1273 | is_derived = unsetWOptM Opt_WarnInaccessibleCode
1274 | otherwise = id
1275
1276 hs_sig_fn = mkHsSigFun sigs
1277 inst_loc = getSrcSpan dfun_id
1278
1279 ----------------------
1280 tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
1281 tc_item (sel_id, dm_info)
1282 | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn
1283 = tcMethodBody clas tyvars dfun_ev_vars inst_tys
1284 dfun_ev_binds is_derived hs_sig_fn
1285 spec_inst_prags prags
1286 sel_id user_bind bndr_loc
1287 | otherwise
1288 = do { traceTc "tc_def" (ppr sel_id)
1289 ; tc_default sel_id dm_info }
1290
1291 ----------------------
1292 tc_default :: Id -> DefMethInfo
1293 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1294
1295 tc_default sel_id (Just (dm_name, _))
1296 = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name
1297 ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
1298 dfun_ev_binds is_derived hs_sig_fn
1299 spec_inst_prags inline_prags
1300 sel_id meth_bind inst_loc }
1301
1302 tc_default sel_id Nothing -- No default method at all
1303 = do { traceTc "tc_def: warn" (ppr sel_id)
1304 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
1305 inst_tys sel_id
1306 ; dflags <- getDynFlags
1307 ; let meth_bind = mkVarBind meth_id $
1308 mkLHsWrap lam_wrapper (error_rhs dflags)
1309 ; return (meth_id, meth_bind, Nothing) }
1310 where
1311 error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)
1312 error_fun = L inst_loc $
1313 wrapId (mkWpTyApps
1314 [ getRuntimeRep meth_tau, meth_tau])
1315 nO_METHOD_BINDING_ERROR_ID
1316 error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim NoSourceText
1317 (unsafeMkByteString (error_string dflags))))
1318 meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys)
1319 error_string dflags = showSDoc dflags
1320 (hcat [ppr inst_loc, vbar, ppr sel_id ])
1321 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1322
1323 ----------------------
1324 -- Check if one of the minimal complete definitions is satisfied
1325 checkMinimalDefinition
1326 = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
1327 warnUnsatisfiedMinimalDefinition
1328
1329 methodExists meth = isJust (findMethodBind meth binds prag_fn)
1330
1331 ----------------------
1332 -- Check if any method bindings do not correspond to the class.
1333 -- See Note [Mismatched class methods and associated type families].
1334 checkMethBindMembership
1335 = let bind_nms = map unLoc $ collectMethodBinders binds
1336 cls_meth_nms = map (idName . fst) op_items
1337 mismatched_meths = bind_nms `minusList` cls_meth_nms
1338 in forM_ mismatched_meths $ \mismatched_meth ->
1339 addErrTc $ hsep
1340 [ text "Class", quotes (ppr (className clas))
1341 , text "does not have a method", quotes (ppr mismatched_meth)]
1342
1343 {-
1344 Note [Mismatched class methods and associated type families]
1345 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1346 It's entirely possible for someone to put methods or associated type family
1347 instances inside of a class in which it doesn't belong. For instance, we'd
1348 want to fail if someone wrote this:
1349
1350 instance Eq () where
1351 type Rep () = Maybe
1352 compare = undefined
1353
1354 Since neither the type family `Rep` nor the method `compare` belong to the
1355 class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,
1356 since that would discover that the parent class `Eq` is incorrect.
1357
1358 However, there is a scenario in which the renamer could fail to catch this:
1359 if the instance was generated through Template Haskell, as in #12387. In that
1360 case, Template Haskell will provide fully resolved names (e.g.,
1361 `GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
1362 on. For this reason, we also put an extra validity check for this in the
1363 typechecker as a last resort.
1364
1365 Note [Avoid -Winaccessible-code when deriving]
1366 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1367 -Winaccessible-code can be particularly noisy when deriving instances for
1368 GADTs. Consider the following example (adapted from #8128):
1369
1370 data T a where
1371 MkT1 :: Int -> T Int
1372 MkT2 :: T Bool
1373 MkT3 :: T Bool
1374 deriving instance Eq (T a)
1375 deriving instance Ord (T a)
1376
1377 In the derived Ord instance, GHC will generate the following code:
1378
1379 instance Ord (T a) where
1380 compare x y
1381 = case x of
1382 MkT2
1383 -> case y of
1384 MkT1 {} -> GT
1385 MkT2 -> EQ
1386 _ -> LT
1387 ...
1388
1389 However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2
1390 differ, so if -Winaccessible-code is enabled, then deriving this instance will
1391 result in unwelcome warnings.
1392
1393 One conceivable approach to fixing this issue would be to change `deriving Ord`
1394 such that it becomes smarter about not generating unreachable cases. This,
1395 however, would be a highly nontrivial refactor, as we'd have to propagate
1396 through typing information everywhere in the algorithm that generates Ord
1397 instances in order to determine which cases were unreachable. This seems like
1398 a lot of work for minimal gain, so we have opted not to go for this approach.
1399
1400 Instead, we take the much simpler approach of always disabling
1401 -Winaccessible-code for derived code. To accomplish this, we do the following:
1402
1403 1. In tcMethods (which typechecks method bindings), disable
1404 -Winaccessible-code.
1405 2. When creating Implications during typechecking, record the Env
1406 (through ic_env) at the time of creation. Since the Env also stores
1407 DynFlags, this will remember that -Winaccessible-code was disabled over
1408 the scope of that implication.
1409 3. After typechecking comes error reporting, where GHC must decide how to
1410 report inaccessible code to the user, on an Implication-by-Implication
1411 basis. If an Implication's DynFlags indicate that -Winaccessible-code was
1412 disabled, then don't bother reporting it. That's it!
1413 -}
1414
1415 ------------------------
1416 tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
1417 -> TcEvBinds -> Bool
1418 -> HsSigFun
1419 -> [LTcSpecPrag] -> [LSig GhcRn]
1420 -> Id -> LHsBind GhcRn -> SrcSpan
1421 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1422 tcMethodBody clas tyvars dfun_ev_vars inst_tys
1423 dfun_ev_binds is_derived
1424 sig_fn spec_inst_prags prags
1425 sel_id (L bind_loc meth_bind) bndr_loc
1426 = add_meth_ctxt $
1427 do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
1428 ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
1429 mkMethIds clas tyvars dfun_ev_vars
1430 inst_tys sel_id
1431
1432 ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
1433 -- Substitute the local_meth_name for the binder
1434 -- NB: the binding is always a FunBind
1435
1436 -- taking instance signature into account might change the type of
1437 -- the local_meth_id
1438 ; (meth_implic, ev_binds_var, tc_bind)
1439 <- checkInstConstraints $
1440 tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
1441
1442 ; global_meth_id <- addInlinePrags global_meth_id prags
1443 ; spec_prags <- tcSpecPrags global_meth_id prags
1444
1445 ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
1446 export = ABE { abe_ext = noExt
1447 , abe_poly = global_meth_id
1448 , abe_mono = local_meth_id
1449 , abe_wrap = idHsWrapper
1450 , abe_prags = specs }
1451
1452 local_ev_binds = TcEvBinds ev_binds_var
1453 full_bind = AbsBinds { abs_ext = noExt
1454 , abs_tvs = tyvars
1455 , abs_ev_vars = dfun_ev_vars
1456 , abs_exports = [export]
1457 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1458 , abs_binds = tc_bind
1459 , abs_sig = True }
1460
1461 ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
1462 where
1463 -- For instance decls that come from deriving clauses
1464 -- we want to print out the full source code if there's an error
1465 -- because otherwise the user won't see the code at all
1466 add_meth_ctxt thing
1467 | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
1468 | otherwise = thing
1469
1470 tcMethodBodyHelp :: HsSigFun -> Id -> TcId
1471 -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId)
1472 tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
1473 | Just hs_sig_ty <- hs_sig_fn sel_name
1474 -- There is a signature in the instance
1475 -- See Note [Instance method signatures]
1476 = do { let ctxt = FunSigCtxt sel_name True
1477 ; (sig_ty, hs_wrap)
1478 <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
1479 do { inst_sigs <- xoptM LangExt.InstanceSigs
1480 ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
1481 ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty
1482 ; let local_meth_ty = idType local_meth_id
1483 ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $
1484 tcSubType_NC ctxt sig_ty local_meth_ty
1485 ; return (sig_ty, hs_wrap) }
1486
1487 ; inner_meth_name <- newName (nameOccName sel_name)
1488 ; let inner_meth_id = mkLocalId inner_meth_name sig_ty
1489 inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
1490 , sig_ctxt = ctxt
1491 , sig_loc = getLoc (hsSigType hs_sig_ty) }
1492
1493
1494 ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
1495
1496 ; let export = ABE { abe_ext = noExt
1497 , abe_poly = local_meth_id
1498 , abe_mono = inner_id
1499 , abe_wrap = hs_wrap
1500 , abe_prags = noSpecPrags }
1501
1502 ; return (unitBag $ L (getLoc meth_bind) $
1503 AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []
1504 , abs_exports = [export]
1505 , abs_binds = tc_bind, abs_ev_binds = []
1506 , abs_sig = True }) }
1507
1508 | otherwise -- No instance signature
1509 = do { let ctxt = FunSigCtxt sel_name False
1510 -- False <=> don't report redundant constraints
1511 -- The signature is not under the users control!
1512 tc_sig = completeSigFromId ctxt local_meth_id
1513 -- Absent a type sig, there are no new scoped type variables here
1514 -- Only the ones from the instance decl itself, which are already
1515 -- in scope. Example:
1516 -- class C a where { op :: forall b. Eq b => ... }
1517 -- instance C [c] where { op = <rhs> }
1518 -- In <rhs>, 'c' is scope but 'b' is not!
1519
1520 ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
1521 ; return tc_bind }
1522
1523 where
1524 sel_name = idName sel_id
1525 no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
1526 -- they are all for meth_id
1527
1528
1529 ------------------------
1530 mkMethIds :: Class -> [TcTyVar] -> [EvVar]
1531 -> [TcType] -> Id -> TcM (TcId, TcId)
1532 -- returns (poly_id, local_id), but ignoring any instance signature
1533 -- See Note [Instance method signatures]
1534 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1535 = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ)
1536 ; local_meth_name <- newName sel_occ
1537 -- Base the local_meth_name on the selector name, because
1538 -- type errors from tcMethodBody come from here
1539 ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty
1540 local_meth_id = mkLocalId local_meth_name local_meth_ty
1541
1542 ; return (poly_meth_id, local_meth_id) }
1543 where
1544 sel_name = idName sel_id
1545 sel_occ = nameOccName sel_name
1546 local_meth_ty = instantiateMethod clas sel_id inst_tys
1547 poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty
1548 theta = map idType dfun_ev_vars
1549
1550 methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1551 methSigCtxt sel_name sig_ty meth_ty env0
1552 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty
1553 ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
1554 ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))
1555 2 (vcat [ text "is more general than its signature in the class"
1556 , text "Instance sig:" <+> ppr sig_ty
1557 , text " Class sig:" <+> ppr meth_ty ])
1558 ; return (env2, msg) }
1559
1560 misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
1561 misplacedInstSig name hs_ty
1562 = vcat [ hang (text "Illegal type signature in instance declaration:")
1563 2 (hang (pprPrefixName name)
1564 2 (dcolon <+> ppr hs_ty))
1565 , text "(Use InstanceSigs to allow this)" ]
1566
1567 {- Note [Instance method signatures]
1568 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1569 With -XInstanceSigs we allow the user to supply a signature for the
1570 method in an instance declaration. Here is an artificial example:
1571
1572 data T a = MkT a
1573 instance Ord a => Ord (T a) where
1574 (>) :: forall b. b -> b -> Bool
1575 (>) = error "You can't compare Ts"
1576
1577 The instance signature can be *more* polymorphic than the instantiated
1578 class method (in this case: Age -> Age -> Bool), but it cannot be less
1579 polymorphic. Moreover, if a signature is given, the implementation
1580 code should match the signature, and type variables bound in the
1581 singature should scope over the method body.
1582
1583 We achieve this by building a TcSigInfo for the method, whether or not
1584 there is an instance method signature, and using that to typecheck
1585 the declaration (in tcMethodBody). That means, conveniently,
1586 that the type variables bound in the signature will scope over the body.
1587
1588 What about the check that the instance method signature is more
1589 polymorphic than the instantiated class method type? We just do a
1590 tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like
1591 this (for the example above
1592
1593 AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]
1594 , abs_exports
1595 = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool
1596 , gr_lcl :: T a -> T a -> Bool }
1597 , abs_binds
1598 = AbsBind { abs_tvs = [], abs_ev_vars = []
1599 , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool
1600 , gr_inner :: forall b. b -> b -> Bool }
1601 , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []
1602 , ..etc.. }
1603 } }
1604
1605 Wow! Three nested AbsBinds!
1606 * The outer one abstracts over the tyvars and dicts for the instance
1607 * The middle one is only present if there is an instance signature,
1608 and does the impedance matching for that signature
1609 * The inner one is for the method binding itself against either the
1610 signature from the class, or the instance signature.
1611 -}
1612
1613 ----------------------
1614 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
1615 -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
1616 -- There are two sources:
1617 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1618 -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
1619 -- These ones have the dfun inside, but [perhaps surprisingly]
1620 -- the correct wrapper.
1621 -- See Note [Handling SPECIALISE pragmas] in TcBinds
1622 mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
1623 = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
1624 where
1625 spec_prags_from_inst
1626 | isInlinePragma (idInlinePragma meth_id)
1627 = [] -- Do not inherit SPECIALISE from the instance if the
1628 -- method is marked INLINE, because then it'll be inlined
1629 -- and the specialisation would do nothing. (Indeed it'll provoke
1630 -- a warning from the desugarer
1631 | otherwise
1632 = [ L inst_loc (SpecPrag meth_id wrap inl)
1633 | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
1634
1635
1636 mkDefMethBind :: Class -> [Type] -> Id -> Name
1637 -> TcM (LHsBind GhcRn, [LSig GhcRn])
1638 -- The is a default method (vanailla or generic) defined in the class
1639 -- So make a binding op = $dmop @t1 @t2
1640 -- where $dmop is the name of the default method in the class,
1641 -- and t1,t2 are the instance types.
1642 -- See Note [Default methods in instances] for why we use
1643 -- visible type application here
1644 mkDefMethBind clas inst_tys sel_id dm_name
1645 = do { dflags <- getDynFlags
1646 ; dm_id <- tcLookupId dm_name
1647 ; let inline_prag = idInlinePragma dm_id
1648 inline_prags | isAnyInlinePragma inline_prag
1649 = [noLoc (InlineSig noExt fn inline_prag)]
1650 | otherwise
1651 = []
1652 -- Copy the inline pragma (if any) from the default method
1653 -- to this version. Note [INLINE and default methods]
1654
1655 fn = noLoc (idName sel_id)
1656 visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
1657 , tyConBinderArgFlag tcb /= Inferred ]
1658 rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
1659 bind = noLoc $ mkTopFunBind Generated fn $
1660 [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
1661
1662 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
1663 (vcat [ppr clas <+> ppr inst_tys,
1664 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
1665
1666 ; return (bind, inline_prags) }
1667 where
1668 mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
1669 mk_vta fun ty = noLoc (HsAppType (mkEmptyWildCardBndrs $ nlHsParTy
1670 $ noLoc $ XHsType $ NHsCoreTy ty) fun)
1671 -- NB: use visible type application
1672 -- See Note [Default methods in instances]
1673
1674 ----------------------
1675 derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
1676 derivBindCtxt sel_id clas tys
1677 = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)
1678 , nest 2 (text "in a derived instance for"
1679 <+> quotes (pprClassPred clas tys) <> colon)
1680 , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]
1681
1682 warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
1683 warnUnsatisfiedMinimalDefinition mindef
1684 = do { warn <- woptM Opt_WarnMissingMethods
1685 ; warnTc (Reason Opt_WarnMissingMethods) warn message
1686 }
1687 where
1688 message = vcat [text "No explicit implementation for"
1689 ,nest 2 $ pprBooleanFormulaNice mindef
1690 ]
1691
1692 {-
1693 Note [Export helper functions]
1694 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1695 We arrange to export the "helper functions" of an instance declaration,
1696 so that they are not subject to preInlineUnconditionally, even if their
1697 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1698 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1699 non-variable for them.
1700
1701 We could change this by making DFunUnfoldings have CoreExprs, but it
1702 seems a bit simpler this way.
1703
1704 Note [Default methods in instances]
1705 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1706 Consider this
1707
1708 class Baz v x where
1709 foo :: x -> x
1710 foo y = <blah>
1711
1712 instance Baz Int Int
1713
1714 From the class decl we get
1715
1716 $dmfoo :: forall v x. Baz v x => x -> x
1717 $dmfoo y = <blah>
1718
1719 Notice that the type is ambiguous. So we use Visible Type Application
1720 to disambiguate:
1721
1722 $dBazIntInt = MkBaz fooIntInt
1723 fooIntInt = $dmfoo @Int @Int
1724
1725 Lacking VTA we'd get ambiguity errors involving the default method. This applies
1726 equally to vanilla default methods (Trac #1061) and generic default methods
1727 (Trac #12220).
1728
1729 Historical note: before we had VTA we had to generate
1730 post-type-checked code, which took a lot more code, and didn't work for
1731 generic default methods.
1732
1733 Note [INLINE and default methods]
1734 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1735 Default methods need special case. They are supposed to behave rather like
1736 macros. For example
1737
1738 class Foo a where
1739 op1, op2 :: Bool -> a -> a
1740
1741 {-# INLINE op1 #-}
1742 op1 b x = op2 (not b) x
1743
1744 instance Foo Int where
1745 -- op1 via default method
1746 op2 b x = <blah>
1747
1748 The instance declaration should behave
1749
1750 just as if 'op1' had been defined with the
1751 code, and INLINE pragma, from its original
1752 definition.
1753
1754 That is, just as if you'd written
1755
1756 instance Foo Int where
1757 op2 b x = <blah>
1758
1759 {-# INLINE op1 #-}
1760 op1 b x = op2 (not b) x
1761
1762 So for the above example we generate:
1763
1764 {-# INLINE $dmop1 #-}
1765 -- $dmop1 has an InlineCompulsory unfolding
1766 $dmop1 d b x = op2 d (not b) x
1767
1768 $fFooInt = MkD $cop1 $cop2
1769
1770 {-# INLINE $cop1 #-}
1771 $cop1 = $dmop1 $fFooInt
1772
1773 $cop2 = <blah>
1774
1775 Note carefully:
1776
1777 * We *copy* any INLINE pragma from the default method $dmop1 to the
1778 instance $cop1. Otherwise we'll just inline the former in the
1779 latter and stop, which isn't what the user expected
1780
1781 * Regardless of its pragma, we give the default method an
1782 unfolding with an InlineCompulsory source. That means
1783 that it'll be inlined at every use site, notably in
1784 each instance declaration, such as $cop1. This inlining
1785 must happen even though
1786 a) $dmop1 is not saturated in $cop1
1787 b) $cop1 itself has an INLINE pragma
1788
1789 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1790 recursion between $fooInt and $cop1 to be broken
1791
1792 * To communicate the need for an InlineCompulsory to the desugarer
1793 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1794 in TcSpecPrags.
1795
1796
1797 ************************************************************************
1798 * *
1799 Specialise instance pragmas
1800 * *
1801 ************************************************************************
1802
1803 Note [SPECIALISE instance pragmas]
1804 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1805 Consider
1806
1807 instance (Ix a, Ix b) => Ix (a,b) where
1808 {-# SPECIALISE instance Ix (Int,Int) #-}
1809 range (x,y) = ...
1810
1811 We make a specialised version of the dictionary function, AND
1812 specialised versions of each *method*. Thus we should generate
1813 something like this:
1814
1815 $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
1816 {-# DFUN [$crangePair, ...] #-}
1817 {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
1818 $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
1819
1820 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
1821 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
1822 $crange da db = <blah>
1823
1824 The SPECIALISE pragmas are acted upon by the desugarer, which generate
1825
1826 dii :: Ix Int
1827 dii = ...
1828
1829 $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
1830 {-# DFUN [$crangePair di di, ...] #-}
1831 $s$dfIxPair = Ix ($crangePair di di) (...)
1832
1833 {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
1834
1835 $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
1836 $c$crangePair = ...specialised RHS of $crangePair...
1837
1838 {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
1839
1840 Note that
1841
1842 * The specialised dictionary $s$dfIxPair is very much needed, in case we
1843 call a function that takes a dictionary, but in a context where the
1844 specialised dictionary can be used. See Trac #7797.
1845
1846 * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
1847 it still has a DFunUnfolding. See Note [ClassOp/DFun selection]
1848
1849 * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
1850 --> {ClassOp rule for range} $crangePair Int Int d1 d2
1851 --> {SPEC rule for $crangePair} $s$crangePair
1852 or thus:
1853 --> {SPEC rule for $dfIxPair} range $s$dfIxPair
1854 --> {ClassOpRule for range} $s$crangePair
1855 It doesn't matter which way.
1856
1857 * We want to specialise the RHS of both $dfIxPair and $crangePair,
1858 but the SAME HsWrapper will do for both! We can call tcSpecPrag
1859 just once, and pass the result (in spec_inst_info) to tcMethods.
1860 -}
1861
1862 tcSpecInstPrags :: DFunId -> InstBindings GhcRn
1863 -> TcM ([Located TcSpecPrag], TcPragEnv)
1864 tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
1865 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
1866 filter isSpecInstLSig uprags
1867 -- The filter removes the pragmas for methods
1868 ; return (spec_inst_prags, mkPragEnv uprags binds) }
1869
1870 ------------------------------
1871 tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
1872 tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
1873 = addErrCtxt (spec_ctxt prag) $
1874 do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty
1875 ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
1876 ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
1877 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
1878 where
1879 spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
1880
1881 tcSpecInst _ _ = panic "tcSpecInst"
1882
1883 {-
1884 ************************************************************************
1885 * *
1886 \subsection{Error messages}
1887 * *
1888 ************************************************************************
1889 -}
1890
1891 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
1892 instDeclCtxt1 hs_inst_ty
1893 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
1894
1895 instDeclCtxt2 :: Type -> SDoc
1896 instDeclCtxt2 dfun_ty
1897 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1898 where
1899 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1900
1901 inst_decl_ctxt :: SDoc -> SDoc
1902 inst_decl_ctxt doc = hang (text "In the instance declaration for")
1903 2 (quotes doc)
1904
1905 badBootFamInstDeclErr :: SDoc
1906 badBootFamInstDeclErr
1907 = text "Illegal family instance in hs-boot file"
1908
1909 notFamily :: TyCon -> SDoc
1910 notFamily tycon
1911 = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
1912 , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]
1913
1914 tooFewParmsErr :: Arity -> SDoc
1915 tooFewParmsErr arity
1916 = text "Family instance has too few parameters; expected" <+>
1917 ppr arity
1918
1919 assocInClassErr :: Located Name -> SDoc
1920 assocInClassErr name
1921 = text "Associated type" <+> quotes (ppr name) <+>
1922 text "must be inside a class instance"
1923
1924 badFamInstDecl :: Located Name -> SDoc
1925 badFamInstDecl tc_name
1926 = vcat [ text "Illegal family instance for" <+>
1927 quotes (ppr tc_name)
1928 , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]
1929
1930 notOpenFamily :: TyCon -> SDoc
1931 notOpenFamily tc
1932 = text "Illegal instance for closed family" <+> quotes (ppr tc)