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