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