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