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