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