Major patch to add -fwarn-redundant-constraints
[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 )
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 ( tYPEABLE_INTERNAL, typeableClassName, genericClassNames )
47 import Bag
48 import BasicTypes
49 import DynFlags
50 import ErrUtils
51 import FastString
52 import HscTypes ( isHsBootOrSig )
53 import Id
54 import MkId
55 import Name
56 import NameSet
57 import Outputable
58 import SrcLoc
59 import Util
60 import BooleanFormula ( isUnsatisfied, pprBooleanFormulaNice )
61
62 import Control.Monad
63 import Maybes ( isNothing, isJust, whenIsJust, catMaybes )
64 import Data.List ( mapAccumL, partition )
65
66 {-
67 Typechecking instance declarations is done in two passes. The first
68 pass, made by @tcInstDecls1@, collects information to be used in the
69 second pass.
70
71 This pre-processed info includes the as-yet-unprocessed bindings
72 inside the instance declaration. These are type-checked in the second
73 pass, when the class-instance envs and GVE contain all the info from
74 all the instance and value decls. Indeed that's the reason we need
75 two passes over the instance decls.
76
77
78 Note [How instance declarations are translated]
79 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
80 Here is how we translation instance declarations into Core
81
82 Running example:
83 class C a where
84 op1, op2 :: Ix b => a -> b -> b
85 op2 = <dm-rhs>
86
87 instance C a => C [a]
88 {-# INLINE [2] op1 #-}
89 op1 = <rhs>
90 ===>
91 -- Method selectors
92 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
93 op1 = ...
94 op2 = ...
95
96 -- Default methods get the 'self' dictionary as argument
97 -- so they can call other methods at the same type
98 -- Default methods get the same type as their method selector
99 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
100 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
101 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
102 -- Note [Tricky type variable scoping]
103
104 -- A top-level definition for each instance method
105 -- Here op1_i, op2_i are the "instance method Ids"
106 -- The INLINE pragma comes from the user pragma
107 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
108 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
109 op1_i = /\a. \(d:C a).
110 let this :: C [a]
111 this = df_i a d
112 -- Note [Subtle interaction of recursion and overlap]
113
114 local_op1 :: forall b. Ix b => [a] -> b -> b
115 local_op1 = <rhs>
116 -- Source code; run the type checker on this
117 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
118 -- Note [Tricky type variable scoping]
119
120 in local_op1 a d
121
122 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
123
124 -- The dictionary function itself
125 {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
126 df_i :: forall a. C a -> C [a]
127 df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
128 -- But see Note [Default methods in instances]
129 -- We can't apply the type checker to the default-method call
130
131 -- Use a RULE to short-circuit applications of the class ops
132 {-# RULE "op1@C[a]" forall a, d:C a.
133 op1 [a] (df_i d) = op1_i a d #-}
134
135 Note [Instances and loop breakers]
136 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
137 * Note that df_i may be mutually recursive with both op1_i and op2_i.
138 It's crucial that df_i is not chosen as the loop breaker, even
139 though op1_i has a (user-specified) INLINE pragma.
140
141 * Instead the idea is to inline df_i into op1_i, which may then select
142 methods from the MkC record, and thereby break the recursion with
143 df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
144 the same type, it won't mention df_i, so there won't be recursion in
145 the first place.)
146
147 * If op1_i is marked INLINE by the user there's a danger that we won't
148 inline df_i in it, and that in turn means that (since it'll be a
149 loop-breaker because df_i isn't), op1_i will ironically never be
150 inlined. But this is OK: the recursion breaking happens by way of
151 a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
152 unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
153
154 Note [ClassOp/DFun selection]
155 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
156 One thing we see a lot is stuff like
157 op2 (df d1 d2)
158 where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
159 'op2' and 'df' to get
160 case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
161 MkD _ op2 _ _ _ -> op2
162 And that will reduce to ($cop2 d1 d2) which is what we wanted.
163
164 But it's tricky to make this work in practice, because it requires us to
165 inline both 'op2' and 'df'. But neither is keen to inline without having
166 seen the other's result; and it's very easy to get code bloat (from the
167 big intermediate) if you inline a bit too much.
168
169 Instead we use a cunning trick.
170 * We arrange that 'df' and 'op2' NEVER inline.
171
172 * We arrange that 'df' is ALWAYS defined in the sylised form
173 df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
174
175 * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
176 that lists its methods.
177
178 * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
179 a suitable constructor application -- inlining df "on the fly" as it
180 were.
181
182 * ClassOp rules: We give the ClassOp 'op2' a BuiltinRule that
183 extracts the right piece iff its argument satisfies
184 exprIsConApp_maybe. This is done in MkId mkDictSelId
185
186 * We make 'df' CONLIKE, so that shared uses still match; eg
187 let d = df d1 d2
188 in ...(op2 d)...(op1 d)...
189
190 Note [Single-method classes]
191 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
192 If the class has just one method (or, more accurately, just one element
193 of {superclasses + methods}), then we use a different strategy.
194
195 class C a where op :: a -> a
196 instance C a => C [a] where op = <blah>
197
198 We translate the class decl into a newtype, which just gives a
199 top-level axiom. The "constructor" MkC expands to a cast, as does the
200 class-op selector.
201
202 axiom Co:C a :: C a ~ (a->a)
203
204 op :: forall a. C a -> (a -> a)
205 op a d = d |> (Co:C a)
206
207 MkC :: forall a. (a->a) -> C a
208 MkC = /\a.\op. op |> (sym Co:C a)
209
210 The clever RULE stuff doesn't work now, because ($df a d) isn't
211 a constructor application, so exprIsConApp_maybe won't return
212 Just <blah>.
213
214 Instead, we simply rely on the fact that casts are cheap:
215
216 $df :: forall a. C a => C [a]
217 {-# INLINE df #-} -- NB: INLINE this
218 $df = /\a. \d. MkC [a] ($cop_list a d)
219 = $cop_list |> forall a. C a -> (sym (Co:C [a]))
220
221 $cop_list :: forall a. C a => [a] -> [a]
222 $cop_list = <blah>
223
224 So if we see
225 (op ($df a d))
226 we'll inline 'op' and '$df', since both are simply casts, and
227 good things happen.
228
229 Why do we use this different strategy? Because otherwise we
230 end up with non-inlined dictionaries that look like
231 $df = $cop |> blah
232 which adds an extra indirection to every use, which seems stupid. See
233 Trac #4138 for an example (although the regression reported there
234 wasn't due to the indirection).
235
236 There is an awkward wrinkle though: we want to be very
237 careful when we have
238 instance C a => C [a] where
239 {-# INLINE op #-}
240 op = ...
241 then we'll get an INLINE pragma on $cop_list but it's important that
242 $cop_list only inlines when it's applied to *two* arguments (the
243 dictionary and the list argument). So we must not eta-expand $df
244 above. We ensure that this doesn't happen by putting an INLINE
245 pragma on the dfun itself; after all, it ends up being just a cast.
246
247 There is one more dark corner to the INLINE story, even more deeply
248 buried. Consider this (Trac #3772):
249
250 class DeepSeq a => C a where
251 gen :: Int -> a
252
253 instance C a => C [a] where
254 gen n = ...
255
256 class DeepSeq a where
257 deepSeq :: a -> b -> b
258
259 instance DeepSeq a => DeepSeq [a] where
260 {-# INLINE deepSeq #-}
261 deepSeq xs b = foldr deepSeq b xs
262
263 That gives rise to these defns:
264
265 $cdeepSeq :: DeepSeq a -> [a] -> b -> b
266 -- User INLINE( 3 args )!
267 $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ...
268
269 $fDeepSeq[] :: DeepSeq a -> DeepSeq [a]
270 -- DFun (with auto INLINE pragma)
271 $fDeepSeq[] a d = $cdeepSeq a d |> blah
272
273 $cp1 a d :: C a => DeepSep [a]
274 -- We don't want to eta-expand this, lest
275 -- $cdeepSeq gets inlined in it!
276 $cp1 a d = $fDeepSep[] a (scsel a d)
277
278 $fC[] :: C a => C [a]
279 -- Ordinary DFun
280 $fC[] a d = MkC ($cp1 a d) ($cgen a d)
281
282 Here $cp1 is the code that generates the superclass for C [a]. The
283 issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[]
284 and then $cdeepSeq will inline there, which is definitely wrong. Like
285 on the dfun, we solve this by adding an INLINE pragma to $cp1.
286
287 Note [Subtle interaction of recursion and overlap]
288 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
289 Consider this
290 class C a where { op1,op2 :: a -> a }
291 instance C a => C [a] where
292 op1 x = op2 x ++ op2 x
293 op2 x = ...
294 instance C [Int] where
295 ...
296
297 When type-checking the C [a] instance, we need a C [a] dictionary (for
298 the call of op2). If we look up in the instance environment, we find
299 an overlap. And in *general* the right thing is to complain (see Note
300 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
301 complain, because we just want to delegate to the op2 of this same
302 instance.
303
304 Why is this justified? Because we generate a (C [a]) constraint in
305 a context in which 'a' cannot be instantiated to anything that matches
306 other overlapping instances, or else we would not be executing this
307 version of op1 in the first place.
308
309 It might even be a bit disguised:
310
311 nullFail :: C [a] => [a] -> [a]
312 nullFail x = op2 x ++ op2 x
313
314 instance C a => C [a] where
315 op1 x = nullFail x
316
317 Precisely this is used in package 'regex-base', module Context.hs.
318 See the overlapping instances for RegexContext, and the fact that they
319 call 'nullFail' just like the example above. The DoCon package also
320 does the same thing; it shows up in module Fraction.hs.
321
322 Conclusion: when typechecking the methods in a C [a] instance, we want to
323 treat the 'a' as an *existential* type variable, in the sense described
324 by Note [Binding when looking up instances]. That is why isOverlappableTyVar
325 responds True to an InstSkol, which is the kind of skolem we use in
326 tcInstDecl2.
327
328
329 Note [Tricky type variable scoping]
330 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
331 In our example
332 class C a where
333 op1, op2 :: Ix b => a -> b -> b
334 op2 = <dm-rhs>
335
336 instance C a => C [a]
337 {-# INLINE [2] op1 #-}
338 op1 = <rhs>
339
340 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
341 in scope in <rhs>. In particular, we must make sure that 'b' is in
342 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
343 which brings appropriate tyvars into scope. This happens for both
344 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
345 complained if 'b' is mentioned in <rhs>.
346
347
348
349 ************************************************************************
350 * *
351 \subsection{Extracting instance decls}
352 * *
353 ************************************************************************
354
355 Gather up the instance declarations from their various sources
356 -}
357
358 tcInstDecls1 -- Deal with both source-code and imported instance decls
359 :: [LTyClDecl Name] -- For deriving stuff
360 -> [LInstDecl Name] -- Source code instance decls
361 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
362 -> TcM (TcGblEnv, -- The full inst env
363 [InstInfo Name], -- Source-code instance decls to process;
364 -- contains all dfuns for this module
365 HsValBinds Name) -- Supporting bindings for derived instances
366
367 tcInstDecls1 tycl_decls inst_decls deriv_decls
368 = checkNoErrs $
369 do { -- Stop if addInstInfos etc discovers any errors
370 -- (they recover, so that we get more than one error each
371 -- round)
372
373 -- Do class and family instance declarations
374 ; env <- getGblEnv
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 env) 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 env i
427 = -- Class name is Typeable
428 typeableClassName == is_cls_nm (iSpec i)
429 -- but not those that come from Data.Typeable.Internal
430 && tcg_mod env /= tYPEABLE_INTERNAL
431 -- nor those from an .hs-boot or .hsig file
432 -- (deriving can't be used there)
433 && not (isHsBootOrSig (tcg_src env))
434
435 overlapCheck ty = overlapMode (is_flag $ iSpec ty) /= NoOverlap
436 genInstCheck ty = is_cls_nm (iSpec ty) `elem` genericClassNames
437 genInstErr i = hang (ptext (sLit $ "Generic instances can only be "
438 ++ "derived in Safe Haskell.") $+$
439 ptext (sLit "Replace the following instance:"))
440 2 (pprInstanceHdr (iSpec i))
441
442 typeable_err i
443 = setSrcSpan (getSrcSpan ispec) $
444 addErrTc $ hang (ptext (sLit "Typeable instances can only be derived"))
445 2 (vcat [ ptext (sLit "Try") <+> quotes (ptext (sLit "deriving instance Typeable")
446 <+> pp_tc)
447 , ptext (sLit "(requires StandaloneDeriving)") ])
448 where
449 ispec = iSpec i
450 pp_tc | [_kind, ty] <- is_tys ispec
451 , Just (tc,_) <- tcSplitTyConApp_maybe ty
452 = ppr tc
453 | otherwise = ptext (sLit "<tycon>")
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 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-polymorhic 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 :: [(EvTerm, TcType)] -- (ev_term, type of that ev_term)
1010 -- given_cls_preds is the list of (ev_term, type) that can be derived
1011 -- from the dfun_evs, using the rules (sc1) and (sc3) 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 (EvId dfun_ev, idType dfun_ev) ]
1017
1018 ------------
1019 super_classes ev_pair
1020 | (ev_tm, pred) <- normalise_pr ev_pair
1021 , ClassPred cls tys <- classifyPredType pred
1022 = (ev_tm, pred) : super_classes_help ev_tm cls tys
1023 | otherwise
1024 = []
1025
1026 ------------
1027 super_classes_help :: EvTerm -> Class -> [TcType] -> [(EvTerm, TcType)]
1028 super_classes_help ev_tm cls tys -- ev_tm :: cls tys
1029 | sizeTypes tys >= head_size -- Here is where we test for
1030 = [] -- a smaller dictionary
1031 | otherwise
1032 = concatMap super_classes ([EvSuperClass ev_tm i | i <- [0..]]
1033 `zip` immSuperClasses cls tys)
1034
1035 ------------
1036 normalise_pr :: (EvTerm, TcPredType) -> (EvTerm, TcPredType)
1037 -- Normalise type functions as much as possible
1038 normalise_pr (ev_tm, pred)
1039 | isReflCo norm_co = (ev_tm, pred)
1040 | otherwise = (mkEvCast ev_tm tc_co, norm_pred)
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 = do { sc_ev_tm <- emit_sc_cls_pred norm_sc_pred cls tys
1070 ; sc_ev_id <- newEvVar sc_pred
1071 ; let tc_co = TcCoercion (mkSubCo (mkSymCo sc_co))
1072 ; addTcEvBind ev_binds (mkWantedEvBind sc_ev_id (mkEvCast sc_ev_tm tc_co))
1073 -- This is where we set the evidence for the superclass, and do so
1074 -- (very unusually) *outside the solver*. That's why
1075 -- checkInstConstraints passes in the evidence bindings
1076 ; return sc_ev_id }
1077
1078 | otherwise
1079 = do { sc_ev_id <- emitWanted ScOrigin sc_pred
1080 ; traceTc "tcSuperClass 4" (ppr sc_pred $$ ppr sc_ev_id)
1081 ; return sc_ev_id }
1082
1083 -------------------
1084 emit_sc_cls_pred sc_pred cls tys
1085 | (ev_tm:_) <- [ ev_tm | (ev_tm, ev_ty) <- given_cls_preds
1086 , ev_ty `tcEqType` sc_pred ]
1087 = do { traceTc "tcSuperClass 1" (ppr sc_pred $$ ppr ev_tm)
1088 ; return ev_tm }
1089
1090 | otherwise
1091 = do { inst_envs <- tcGetInstEnvs
1092 ; case lookupInstEnv inst_envs cls tys of
1093 ([(ispec, dfun_inst_tys)], [], _) -- A single match
1094 -> do { let dfun_id = instanceDFunId ispec
1095 ; (inst_tys, inst_theta) <- instDFunType dfun_id dfun_inst_tys
1096 ; arg_evs <- emitWanteds ScOrigin inst_theta
1097 ; let dict_app = EvDFunApp dfun_id inst_tys (map EvId arg_evs)
1098 ; traceTc "tcSuperClass 2" (ppr sc_pred $$ ppr dict_app)
1099 ; return dict_app }
1100
1101 _ -> -- No instance, so we want to report an error
1102 -- Emitting it as an 'insoluble' prevents the solver
1103 -- attempting to solve it (which might, wrongly, succeed)
1104 do { sc_ev <- newWanted ScOrigin sc_pred
1105 ; emitInsoluble (mkNonCanonical sc_ev)
1106 ; traceTc "tcSuperClass 3" (ppr sc_pred $$ ppr sc_ev)
1107 ; return (ctEvTerm sc_ev) } }
1108
1109 -------------------
1110 checkInstConstraints :: (EvBindsVar -> TcM result)
1111 -> TcM (Implication, result)
1112 -- See Note [Typechecking plan for instance declarations]
1113 -- The thing_inside is also passed the EvBindsVar,
1114 -- so that emit_sc_pred can add evidence for the superclass
1115 -- (not used for methods)
1116 checkInstConstraints thing_inside
1117 = do { ev_binds_var <- newTcEvBinds
1118 ; env <- getLclEnv
1119 ; (result, tclvl, wanted) <- pushLevelAndCaptureConstraints $
1120 thing_inside ev_binds_var
1121
1122 ; let implic = Implic { ic_tclvl = tclvl
1123 , ic_skols = []
1124 , ic_no_eqs = False
1125 , ic_given = []
1126 , ic_wanted = wanted
1127 , ic_status = IC_Unsolved
1128 , ic_binds = ev_binds_var
1129 , ic_env = env
1130 , ic_info = InstSkol }
1131
1132 ; return (implic, result) }
1133
1134 {-
1135 Note [Recursive superclasses]
1136 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1137 See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all
1138 describe somewhat more complicated situations, but ones
1139 encountered in practice.
1140
1141 See also tests tcrun020, tcrun021, tcrun033
1142
1143
1144 ----- THE PROBLEM --------
1145 The problem is that it is all too easy to create a class whose
1146 superclass is bottom when it should not be.
1147
1148 Consider the following (extreme) situation:
1149 class C a => D a where ...
1150 instance D [a] => D [a] where ... (dfunD)
1151 instance C [a] => C [a] where ... (dfunC)
1152 Although this looks wrong (assume D [a] to prove D [a]), it is only a
1153 more extreme case of what happens with recursive dictionaries, and it
1154 can, just about, make sense because the methods do some work before
1155 recursing.
1156
1157 To implement the dfunD we must generate code for the superclass C [a],
1158 which we had better not get by superclass selection from the supplied
1159 argument:
1160 dfunD :: forall a. D [a] -> D [a]
1161 dfunD = \d::D [a] -> MkD (scsel d) ..
1162
1163 Otherwise if we later encounter a situation where
1164 we have a [Wanted] dw::D [a] we might solve it thus:
1165 dw := dfunD dw
1166 Which is all fine except that now ** the superclass C is bottom **!
1167
1168 The instance we want is:
1169 dfunD :: forall a. D [a] -> D [a]
1170 dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
1171
1172 ----- THE SOLUTION --------
1173 The basic solution is simple: be very careful about using superclass
1174 selection to generate a superclass witness in a dictionary function
1175 definition. More precisely:
1176
1177 Superclass Invariant: in every class dictionary,
1178 every superclass dictionary field
1179 is non-bottom
1180
1181 To achieve the Superclass Invariant, in a dfun definition we can
1182 generate a guaranteed-non-bottom superclass witness from:
1183 (sc1) one of the dictionary arguments itself (all non-bottom)
1184 (sc2) a call of a dfun (always returns a dictionary constructor)
1185 (sc3) an immediate superclass of a smaller dictionary
1186
1187 The tricky case is (sc3). We proceed by induction on the size of
1188 the (type of) the dictionary, defined by TcValidity.sizePred.
1189 Let's suppose we are building a dictionary of size 3, and
1190 suppose the Superclass Invariant holds of smaller dictionaries.
1191 Then if we have a smaller dictionary, its immediate superclasses
1192 will be non-bottom by induction.
1193
1194 What does "we have a smaller dictionary" mean? It might be
1195 one of the arguments of the instance, or one of its superclasses.
1196 Here is an example, taken from CmmExpr:
1197 class Ord r => UserOfRegs r a where ...
1198 (i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where
1199 (i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
1200
1201 For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
1202 since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
1203
1204 But for (i2) that isn't the case, so we must add an explicit, and
1205 perhaps surprising, (Ord r) argument to the instance declaration.
1206
1207 Here's another example from Trac #6161:
1208
1209 class Super a => Duper a where ...
1210 class Duper (Fam a) => Foo a where ...
1211 (i3) instance Foo a => Duper (Fam a) where ...
1212 (i4) instance Foo Float where ...
1213
1214 It would be horribly wrong to define
1215 dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3)
1216 dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
1217
1218 dfFooFloat :: Foo Float -- from (i4)
1219 dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
1220
1221 Now the Super superclass of Duper is definitely bottom!
1222
1223 This won't happen because when processing (i3) we can use the
1224 superclasses of (Foo a), which is smaller, namely Duper (Fam a). But
1225 that is *not* smaller than the target so we can't take *its*
1226 superclasses. As a result the program is rightly rejected, unless you
1227 add (Super (Fam a)) to the context of (i3).
1228
1229 Note [Silent superclass arguments] (historical interest)
1230 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1231 NB1: this note describes our *old* solution to the
1232 recursive-superclass problem. I'm keeping the Note
1233 for now, just as institutional memory.
1234 However, the code for silent superclass arguments
1235 was removed in late Dec 2014
1236
1237 NB2: the silent-superclass solution introduced new problems
1238 of its own, in the form of instance overlap. Tests
1239 SilentParametersOverlapping, T5051, and T7862 are examples
1240
1241 NB3: the silent-superclass solution also generated tons of
1242 extra dictionaries. For example, in monad-transformer
1243 code, when constructing a Monad dictionary you had to pass
1244 an Applicative dictionary; and to construct that you neede
1245 a Functor dictionary. Yet these extra dictionaries were
1246 often never used. Test T3064 compiled *far* faster after
1247 silent superclasses were eliminated.
1248
1249 Our solution to this problem "silent superclass arguments". We pass
1250 to each dfun some ``silent superclass arguments’’, which are the
1251 immediate superclasses of the dictionary we are trying to
1252 construct. In our example:
1253 dfun :: forall a. C [a] -> D [a] -> D [a]
1254 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
1255 Notice the extra (dc :: C [a]) argument compared to the previous version.
1256
1257 This gives us:
1258
1259 -----------------------------------------------------------
1260 DFun Superclass Invariant
1261 ~~~~~~~~~~~~~~~~~~~~~~~~
1262 In the body of a DFun, every superclass argument to the
1263 returned dictionary is
1264 either * one of the arguments of the DFun,
1265 or * constant, bound at top level
1266 -----------------------------------------------------------
1267
1268 This net effect is that it is safe to treat a dfun application as
1269 wrapping a dictionary constructor around its arguments (in particular,
1270 a dfun never picks superclasses from the arguments under the
1271 dictionary constructor). No superclass is hidden inside a dfun
1272 application.
1273
1274 The extra arguments required to satisfy the DFun Superclass Invariant
1275 always come first, and are called the "silent" arguments. You can
1276 find out how many silent arguments there are using Id.dfunNSilent;
1277 and then you can just drop that number of arguments to see the ones
1278 that were in the original instance declaration.
1279
1280 DFun types are built (only) by MkId.mkDictFunId, so that is where we
1281 decide what silent arguments are to be added.
1282 -}
1283
1284 {-
1285 ************************************************************************
1286 * *
1287 Type-checking an instance method
1288 * *
1289 ************************************************************************
1290
1291 tcMethod
1292 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1293 - Remembering to use fresh Name (the instance method Name) as the binder
1294 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1295 - Use sig_fn mapping instance method Name -> instance tyvars
1296 - Ditto prag_fn
1297 - Use tcValBinds to do the checking
1298 -}
1299
1300 tcMethods :: DFunId -> Class
1301 -> [TcTyVar] -> [EvVar]
1302 -> [TcType]
1303 -> TcEvBinds
1304 -> ([Located TcSpecPrag], PragFun)
1305 -> [(Id, DefMeth)]
1306 -> InstBindings Name
1307 -> TcM ([Id], LHsBinds Id, Bag Implication)
1308 -- The returned inst_meth_ids all have types starting
1309 -- forall tvs. theta => ...
1310 tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1311 dfun_ev_binds prags@(spec_inst_prags,_) op_items
1312 (InstBindings { ib_binds = binds
1313 , ib_tyvars = lexical_tvs
1314 , ib_pragmas = sigs
1315 , ib_extensions = exts
1316 , ib_derived = is_derived })
1317 = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $
1318 -- The lexical_tvs scope over the 'where' part
1319 do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
1320 ; checkMinimalDefinition
1321 ; (ids, binds, mb_implics) <- set_exts exts $
1322 mapAndUnzip3M tc_item op_items
1323 ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
1324 where
1325 set_exts :: [ExtensionFlag] -> TcM a -> TcM a
1326 set_exts es thing = foldr setXOptM thing es
1327
1328 hs_sig_fn = mkHsSigFun sigs
1329 inst_loc = getSrcSpan dfun_id
1330
1331 ----------------------
1332 tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id, Maybe Implication)
1333 tc_item (sel_id, dm_info)
1334 | Just (user_bind, bndr_loc) <- findMethodBind (idName sel_id) binds
1335 = tcMethodBody clas tyvars dfun_ev_vars inst_tys
1336 dfun_ev_binds is_derived hs_sig_fn prags
1337 sel_id user_bind bndr_loc
1338 | otherwise
1339 = do { traceTc "tc_def" (ppr sel_id)
1340 ; tc_default sel_id dm_info }
1341
1342 ----------------------
1343 tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id, Maybe Implication)
1344
1345 tc_default sel_id (GenDefMeth dm_name)
1346 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
1347 ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
1348 dfun_ev_binds is_derived hs_sig_fn prags
1349 sel_id meth_bind inst_loc }
1350
1351 tc_default sel_id NoDefMeth -- No default method at all
1352 = do { traceTc "tc_def: warn" (ppr sel_id)
1353 ; (meth_id, _, _) <- mkMethIds hs_sig_fn clas tyvars dfun_ev_vars
1354 inst_tys sel_id
1355 ; dflags <- getDynFlags
1356 ; let meth_bind = mkVarBind meth_id $
1357 mkLHsWrap lam_wrapper (error_rhs dflags)
1358 ; return (meth_id, meth_bind, Nothing) }
1359 where
1360 error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
1361 error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
1362 error_msg dflags = L inst_loc (HsLit (HsStringPrim ""
1363 (unsafeMkByteString (error_string dflags))))
1364 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
1365 error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ])
1366 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1367
1368 tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
1369 = do { -- Build the typechecked version directly,
1370 -- without calling typecheck_method;
1371 -- see Note [Default methods in instances]
1372 -- Generate /\as.\ds. let self = df as ds
1373 -- in $dm inst_tys self
1374 -- The 'let' is necessary only because HsSyn doesn't allow
1375 -- you to apply a function to a dictionary *expression*.
1376
1377 ; self_dict <- newDict clas inst_tys
1378 ; let self_ev_bind = mkWantedEvBind self_dict
1379 (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars))
1380
1381 ; (meth_id, local_meth_sig, hs_wrap)
1382 <- mkMethIds hs_sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
1383 ; dm_id <- tcLookupId dm_name
1384 ; let dm_inline_prag = idInlinePragma dm_id
1385 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
1386 HsVar dm_id
1387
1388 local_meth_id = sig_id local_meth_sig
1389 meth_bind = mkVarBind local_meth_id (L inst_loc rhs)
1390 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
1391 -- Copy the inline pragma (if any) from the default
1392 -- method to this version. Note [INLINE and default methods]
1393
1394
1395 export = ABE { abe_wrap = hs_wrap, abe_poly = meth_id1
1396 , abe_mono = local_meth_id
1397 , abe_prags = mk_meth_spec_prags meth_id1 spec_inst_prags [] }
1398 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1399 , abs_exports = [export]
1400 , abs_ev_binds = [EvBinds (unitBag self_ev_bind)]
1401 , abs_binds = unitBag meth_bind }
1402 -- Default methods in an instance declaration can't have their own
1403 -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
1404 -- currently they are rejected with
1405 -- "INLINE pragma lacks an accompanying binding"
1406
1407 ; return (meth_id1, L inst_loc bind, Nothing) }
1408
1409 ----------------------
1410 -- Check if one of the minimal complete definitions is satisfied
1411 checkMinimalDefinition
1412 = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
1413 warnUnsatisifiedMinimalDefinition
1414 where
1415 methodExists meth = isJust (findMethodBind meth binds)
1416
1417 ------------------------
1418 tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
1419 -> TcEvBinds -> Bool
1420 -> HsSigFun
1421 -> ([LTcSpecPrag], PragFun)
1422 -> Id -> LHsBind Name -> SrcSpan
1423 -> TcM (TcId, LHsBind Id, Maybe Implication)
1424 tcMethodBody clas tyvars dfun_ev_vars inst_tys
1425 dfun_ev_binds is_derived
1426 sig_fn (spec_inst_prags, prag_fn)
1427 sel_id (L bind_loc meth_bind) bndr_loc
1428 = add_meth_ctxt $
1429 do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id))
1430 ; (global_meth_id, local_meth_sig, hs_wrap)
1431 <- setSrcSpan bndr_loc $
1432 mkMethIds sig_fn clas tyvars dfun_ev_vars
1433 inst_tys sel_id
1434
1435 ; let prags = prag_fn (idName sel_id)
1436 local_meth_id = sig_id local_meth_sig
1437 lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
1438 -- Substitute the local_meth_name for the binder
1439 -- NB: the binding is always a FunBind
1440
1441 ; global_meth_id <- addInlinePrags global_meth_id prags
1442 ; spec_prags <- tcSpecPrags global_meth_id prags
1443 ; (meth_implic, (tc_bind, _, _))
1444 <- checkInstConstraints $ \ _ev_binds ->
1445 tcPolyCheck NonRecursive no_prag_fn local_meth_sig
1446 (L bind_loc lm_bind)
1447
1448 ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
1449 export = ABE { abe_poly = global_meth_id
1450 , abe_mono = local_meth_id
1451 , abe_wrap = hs_wrap
1452 , abe_prags = specs }
1453
1454 local_ev_binds = TcEvBinds (ic_binds meth_implic)
1455 full_bind = AbsBinds { abs_tvs = tyvars
1456 , abs_ev_vars = dfun_ev_vars
1457 , abs_exports = [export]
1458 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1459 , abs_binds = tc_bind }
1460
1461 ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
1462 where
1463 -- For instance decls that come from deriving clauses
1464 -- we want to print out the full source code if there's an error
1465 -- because otherwise the user won't see the code at all
1466 add_meth_ctxt thing
1467 | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
1468 | otherwise = thing
1469
1470 no_prag_fn _ = [] -- No pragmas for local_meth_id;
1471 -- they are all for meth_id
1472
1473
1474 ------------------------
1475 mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
1476 -> [TcType] -> Id -> TcM (TcId, TcSigInfo, HsWrapper)
1477 mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
1478 = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ)
1479 ; local_meth_name <- newName sel_occ
1480 -- Base the local_meth_name on the selector name, because
1481 -- type errors from tcMethodBody come from here
1482 ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty
1483 local_meth_id = mkLocalId local_meth_name local_meth_ty
1484
1485 ; case lookupHsSig sig_fn sel_name of
1486 Just lhs_ty -- There is a signature in the instance declaration
1487 -- See Note [Instance method signatures]
1488 -> setSrcSpan (getLoc lhs_ty) $
1489 do { inst_sigs <- xoptM Opt_InstanceSigs
1490 ; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty)
1491 ; sig_ty <- tcHsSigType (FunSigCtxt sel_name True) lhs_ty
1492 ; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty
1493 ; tc_sig <- instTcTySig lhs_ty sig_ty Nothing [] local_meth_name
1494 ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $
1495 tcSubType (FunSigCtxt sel_name False) poly_sig_ty poly_meth_ty
1496 ; return (poly_meth_id, tc_sig, hs_wrap) }
1497
1498 Nothing -- No type signature
1499 -> do { tc_sig <- instTcTySigFromId local_meth_id
1500 ; return (poly_meth_id, tc_sig, idHsWrapper) } }
1501 -- Absent a type sig, there are no new scoped type variables here
1502 -- Only the ones from the instance decl itself, which are already
1503 -- in scope. Example:
1504 -- class C a where { op :: forall b. Eq b => ... }
1505 -- instance C [c] where { op = <rhs> }
1506 -- In <rhs>, 'c' is scope but 'b' is not!
1507 where
1508 sel_name = idName sel_id
1509 sel_occ = nameOccName sel_name
1510 local_meth_ty = instantiateMethod clas sel_id inst_tys
1511 poly_meth_ty = mkSigmaTy tyvars theta local_meth_ty
1512 theta = map idType dfun_ev_vars
1513
1514 methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1515 methSigCtxt sel_name sig_ty meth_ty env0
1516 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty
1517 ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
1518 ; let msg = hang (ptext (sLit "When checking that instance signature for") <+> quotes (ppr sel_name))
1519 2 (vcat [ ptext (sLit "is more general than its signature in the class")
1520 , ptext (sLit "Instance sig:") <+> ppr sig_ty
1521 , ptext (sLit " Class sig:") <+> ppr meth_ty ])
1522 ; return (env2, msg) }
1523
1524 misplacedInstSig :: Name -> LHsType Name -> SDoc
1525 misplacedInstSig name hs_ty
1526 = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
1527 2 (hang (pprPrefixName name)
1528 2 (dcolon <+> ppr hs_ty))
1529 , ptext (sLit "(Use InstanceSigs to allow this)") ]
1530
1531 {-
1532 Note [Instance method signatures]
1533 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1534 With -XInstanceSigs we allow the user to supply a signature for the
1535 method in an instance declaration. Here is an artificial example:
1536
1537 data Age = MkAge Int
1538 instance Ord Age where
1539 compare :: a -> a -> Bool
1540 compare = error "You can't compare Ages"
1541
1542 The instance signature can be *more* polymorphic than the instantiated
1543 class method (in this case: Age -> Age -> Bool), but it cannot be less
1544 polymorphic. Moreover, if a signature is given, the implementation
1545 code should match the signature, and type variables bound in the
1546 singature should scope over the method body.
1547
1548 We achieve this by building a TcSigInfo for the method, whether or not
1549 there is an instance method signature, and using that to typecheck
1550 the declaration (in tcMethodBody). That means, conveniently,
1551 that the type variables bound in the signature will scope over the body.
1552
1553 What about the check that the instance method signature is more
1554 polymorphic than the instantiated class method type? We just do a
1555 tcSubType call in mkMethIds, and use the HsWrapper thus generated in
1556 the method AbsBind. It's very like the tcSubType impedence-matching
1557 call in mkExport. We have to pass the HsWrapper into
1558 tcMethodBody.
1559 -}
1560
1561 ----------------------
1562 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
1563 -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
1564 -- There are two sources:
1565 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1566 -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
1567 -- These ones have the dfun inside, but [perhaps surprisingly]
1568 -- the correct wrapper.
1569 mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
1570 = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
1571 where
1572 spec_prags_from_inst
1573 | isInlinePragma (idInlinePragma meth_id)
1574 = [] -- Do not inherit SPECIALISE from the instance if the
1575 -- method is marked INLINE, because then it'll be inlined
1576 -- and the specialisation would do nothing. (Indeed it'll provoke
1577 -- a warning from the desugarer
1578 | otherwise
1579 = [ L inst_loc (SpecPrag meth_id wrap inl)
1580 | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
1581
1582
1583 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
1584 mkGenericDefMethBind clas inst_tys sel_id dm_name
1585 = -- A generic default method
1586 -- If the method is defined generically, we only have to call the
1587 -- dm_name.
1588 do { dflags <- getDynFlags
1589 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
1590 (vcat [ppr clas <+> ppr inst_tys,
1591 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
1592
1593 ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id))
1594 [mkSimpleMatch [] rhs]) }
1595 where
1596 rhs = nlHsVar dm_name
1597
1598 ----------------------
1599 derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
1600 derivBindCtxt sel_id clas tys
1601 = vcat [ ptext (sLit "When typechecking the code for") <+> quotes (ppr sel_id)
1602 , nest 2 (ptext (sLit "in a derived instance for")
1603 <+> quotes (pprClassPred clas tys) <> colon)
1604 , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1605
1606 warnMissingMethodOrAT :: String -> Name -> TcM ()
1607 warnMissingMethodOrAT what name
1608 = do { warn <- woptM Opt_WarnMissingMethods
1609 ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name))))
1610 ; warnTc (warn -- Warn only if -fwarn-missing-methods
1611 && not (startsWithUnderscore (getOccName name)))
1612 -- Don't warn about _foo methods
1613 (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for")
1614 <+> quotes (ppr name)) }
1615
1616 warnUnsatisifiedMinimalDefinition :: ClassMinimalDef -> TcM ()
1617 warnUnsatisifiedMinimalDefinition mindef
1618 = do { warn <- woptM Opt_WarnMissingMethods
1619 ; warnTc warn message
1620 }
1621 where
1622 message = vcat [ptext (sLit "No explicit implementation for")
1623 ,nest 2 $ pprBooleanFormulaNice mindef
1624 ]
1625
1626 {-
1627 Note [Export helper functions]
1628 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1629 We arrange to export the "helper functions" of an instance declaration,
1630 so that they are not subject to preInlineUnconditionally, even if their
1631 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1632 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1633 non-variable for them.
1634
1635 We could change this by making DFunUnfoldings have CoreExprs, but it
1636 seems a bit simpler this way.
1637
1638 Note [Default methods in instances]
1639 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1640 Consider this
1641
1642 class Baz v x where
1643 foo :: x -> x
1644 foo y = <blah>
1645
1646 instance Baz Int Int
1647
1648 From the class decl we get
1649
1650 $dmfoo :: forall v x. Baz v x => x -> x
1651 $dmfoo y = <blah>
1652
1653 Notice that the type is ambiguous. That's fine, though. The instance
1654 decl generates
1655
1656 $dBazIntInt = MkBaz fooIntInt
1657 fooIntInt = $dmfoo Int Int $dBazIntInt
1658
1659 BUT this does mean we must generate the dictionary translation of
1660 fooIntInt directly, rather than generating source-code and
1661 type-checking it. That was the bug in Trac #1061. In any case it's
1662 less work to generate the translated version!
1663
1664 Note [INLINE and default methods]
1665 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1666 Default methods need special case. They are supposed to behave rather like
1667 macros. For exmample
1668
1669 class Foo a where
1670 op1, op2 :: Bool -> a -> a
1671
1672 {-# INLINE op1 #-}
1673 op1 b x = op2 (not b) x
1674
1675 instance Foo Int where
1676 -- op1 via default method
1677 op2 b x = <blah>
1678
1679 The instance declaration should behave
1680
1681 just as if 'op1' had been defined with the
1682 code, and INLINE pragma, from its original
1683 definition.
1684
1685 That is, just as if you'd written
1686
1687 instance Foo Int where
1688 op2 b x = <blah>
1689
1690 {-# INLINE op1 #-}
1691 op1 b x = op2 (not b) x
1692
1693 So for the above example we generate:
1694
1695 {-# INLINE $dmop1 #-}
1696 -- $dmop1 has an InlineCompulsory unfolding
1697 $dmop1 d b x = op2 d (not b) x
1698
1699 $fFooInt = MkD $cop1 $cop2
1700
1701 {-# INLINE $cop1 #-}
1702 $cop1 = $dmop1 $fFooInt
1703
1704 $cop2 = <blah>
1705
1706 Note carefully:
1707
1708 * We *copy* any INLINE pragma from the default method $dmop1 to the
1709 instance $cop1. Otherwise we'll just inline the former in the
1710 latter and stop, which isn't what the user expected
1711
1712 * Regardless of its pragma, we give the default method an
1713 unfolding with an InlineCompulsory source. That means
1714 that it'll be inlined at every use site, notably in
1715 each instance declaration, such as $cop1. This inlining
1716 must happen even though
1717 a) $dmop1 is not saturated in $cop1
1718 b) $cop1 itself has an INLINE pragma
1719
1720 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1721 recursion between $fooInt and $cop1 to be broken
1722
1723 * To communicate the need for an InlineCompulsory to the desugarer
1724 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1725 in TcSpecPrags.
1726
1727
1728 ************************************************************************
1729 * *
1730 Specialise instance pragmas
1731 * *
1732 ************************************************************************
1733
1734 Note [SPECIALISE instance pragmas]
1735 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1736 Consider
1737
1738 instance (Ix a, Ix b) => Ix (a,b) where
1739 {-# SPECIALISE instance Ix (Int,Int) #-}
1740 range (x,y) = ...
1741
1742 We make a specialised version of the dictionary function, AND
1743 specialised versions of each *method*. Thus we should generate
1744 something like this:
1745
1746 $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
1747 {-# DFUN [$crangePair, ...] #-}
1748 {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
1749 $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
1750
1751 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
1752 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
1753 $crange da db = <blah>
1754
1755 The SPECIALISE pragmas are acted upon by the desugarer, which generate
1756
1757 dii :: Ix Int
1758 dii = ...
1759
1760 $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
1761 {-# DFUN [$crangePair di di, ...] #-}
1762 $s$dfIxPair = Ix ($crangePair di di) (...)
1763
1764 {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
1765
1766 $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
1767 $c$crangePair = ...specialised RHS of $crangePair...
1768
1769 {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
1770
1771 Note that
1772
1773 * The specialised dictionary $s$dfIxPair is very much needed, in case we
1774 call a function that takes a dictionary, but in a context where the
1775 specialised dictionary can be used. See Trac #7797.
1776
1777 * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
1778 it still has a DFunUnfolding. See Note [ClassOp/DFun selection]
1779
1780 * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
1781 --> {ClassOp rule for range} $crangePair Int Int d1 d2
1782 --> {SPEC rule for $crangePair} $s$crangePair
1783 or thus:
1784 --> {SPEC rule for $dfIxPair} range $s$dfIxPair
1785 --> {ClassOpRule for range} $s$crangePair
1786 It doesn't matter which way.
1787
1788 * We want to specialise the RHS of both $dfIxPair and $crangePair,
1789 but the SAME HsWrapper will do for both! We can call tcSpecPrag
1790 just once, and pass the result (in spec_inst_info) to tcMethods.
1791 -}
1792
1793 tcSpecInstPrags :: DFunId -> InstBindings Name
1794 -> TcM ([Located TcSpecPrag], PragFun)
1795 tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
1796 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
1797 filter isSpecInstLSig uprags
1798 -- The filter removes the pragmas for methods
1799 ; return (spec_inst_prags, mkPragFun uprags binds) }
1800
1801 ------------------------------
1802 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
1803 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
1804 = addErrCtxt (spec_ctxt prag) $
1805 do { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
1806 ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
1807 ; co_fn <- tcSubType SpecInstCtxt (idType dfun_id) spec_dfun_ty
1808 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
1809 where
1810 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
1811
1812 tcSpecInst _ _ = panic "tcSpecInst"
1813
1814 {-
1815 ************************************************************************
1816 * *
1817 \subsection{Error messages}
1818 * *
1819 ************************************************************************
1820 -}
1821
1822 instDeclCtxt1 :: LHsType Name -> SDoc
1823 instDeclCtxt1 hs_inst_ty
1824 = inst_decl_ctxt (case unLoc hs_inst_ty of
1825 HsForAllTy _ _ _ _ (L _ ty') -> ppr ty'
1826 _ -> ppr hs_inst_ty) -- Don't expect this
1827 instDeclCtxt2 :: Type -> SDoc
1828 instDeclCtxt2 dfun_ty
1829 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1830 where
1831 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1832
1833 inst_decl_ctxt :: SDoc -> SDoc
1834 inst_decl_ctxt doc = hang (ptext (sLit "In the instance declaration for"))
1835 2 (quotes doc)
1836
1837 badBootFamInstDeclErr :: SDoc
1838 badBootFamInstDeclErr
1839 = ptext (sLit "Illegal family instance in hs-boot file")
1840
1841 notFamily :: TyCon -> SDoc
1842 notFamily tycon
1843 = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1844 , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1845
1846 tooFewParmsErr :: Arity -> SDoc
1847 tooFewParmsErr arity
1848 = ptext (sLit "Family instance has too few parameters; expected") <+>
1849 ppr arity
1850
1851 assocInClassErr :: Located Name -> SDoc
1852 assocInClassErr name
1853 = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
1854 ptext (sLit "must be inside a class instance")
1855
1856 badFamInstDecl :: Located Name -> SDoc
1857 badFamInstDecl tc_name
1858 = vcat [ ptext (sLit "Illegal family instance for") <+>
1859 quotes (ppr tc_name)
1860 , nest 2 (parens $ ptext (sLit "Use TypeFamilies to allow indexed type families")) ]
1861
1862 notOpenFamily :: TyCon -> SDoc
1863 notOpenFamily tc
1864 = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc)