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