c8746ff00e09c16dfee6226c779553dcb3b4a330
[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, tcInstanceMethodBody )
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 )
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 -- We instantiate the dfun_id with superSkolems.
821 -- See Note [Subtle interaction of recursion and overlap]
822 -- and Note [Binding when looking up instances]
823 ; let (clas, inst_tys) = tcSplitDFunHead inst_head
824 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
825 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
826
827 ; dfun_ev_vars <- newEvVars dfun_theta
828
829 ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
830 ; fam_envs <- tcGetFamInstEnvs
831 ; (sc_ids, sc_binds) <- tcSuperClasses fam_envs loc clas inst_tyvars
832 dfun_ev_vars sc_theta' inst_tys
833
834 -- Deal with 'SPECIALISE instance' pragmas
835 -- See Note [SPECIALISE instance pragmas]
836 ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
837
838 -- Typecheck the methods
839 ; (meth_ids, meth_binds)
840 <- tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
841 inst_tys spec_inst_info
842 op_items ibinds
843
844 -- Create the result bindings
845 ; self_dict <- newDict clas inst_tys
846 ; let class_tc = classTyCon clas
847 [dict_constr] = tyConDataCons class_tc
848 dict_bind = mkVarBind self_dict (L loc con_app_args)
849
850 -- We don't produce a binding for the dict_constr; instead we
851 -- rely on the simplifier to unfold this saturated application
852 -- We do this rather than generate an HsCon directly, because
853 -- it means that the special cases (e.g. dictionary with only one
854 -- member) are dealt with by the common MkId.mkDataConWrapId
855 -- code rather than needing to be repeated here.
856 -- con_app_tys = MkD ty1 ty2
857 -- con_app_scs = MkD ty1 ty2 sc1 sc2
858 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
859 con_app_tys = wrapId (mkWpTyApps inst_tys)
860 (dataConWrapId dict_constr)
861 -- con_app_scs = mkHsWrap (mkWpEvApps (map EvId sc_ev_vars)) con_app_tys
862 con_app_args = foldl app_to_meth con_app_tys (sc_ids ++ meth_ids)
863
864 app_to_meth :: HsExpr Id -> Id -> HsExpr Id
865 app_to_meth fun meth_id = L loc fun `HsApp` L loc (wrapId arg_wrapper meth_id)
866
867 inst_tv_tys = mkTyVarTys inst_tyvars
868 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
869
870 -- Do not inline the dfun; instead give it a magic DFunFunfolding
871 dfun_spec_prags
872 | isNewTyCon class_tc = SpecPrags []
873 -- Newtype dfuns just inline unconditionally,
874 -- so don't attempt to specialise them
875 | otherwise
876 = SpecPrags spec_inst_prags
877
878 export = ABE { abe_wrap = idHsWrapper, abe_poly = dfun_id
879 , abe_mono = self_dict, abe_prags = dfun_spec_prags }
880 -- NB: see Note [SPECIALISE instance pragmas]
881 main_bind = AbsBinds { abs_tvs = inst_tyvars
882 , abs_ev_vars = dfun_ev_vars
883 , abs_exports = [export]
884 , abs_ev_binds = emptyTcEvBinds
885 , abs_binds = unitBag dict_bind }
886
887 ; return (unitBag (L loc main_bind) `unionBags`
888 listToBag meth_binds `unionBags`
889 listToBag sc_binds)
890 }
891 where
892 dfun_id = instanceDFunId ispec
893 loc = getSrcSpan dfun_id
894
895 ----------------------
896 mkMethIds :: HsSigFun -> Class -> [TcTyVar] -> [EvVar]
897 -> [TcType] -> Id -> TcM (TcId, TcSigInfo, HsWrapper)
898 mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
899 = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ)
900 ; local_meth_name <- newName sel_occ
901 -- Base the local_meth_name on the selector name, because
902 -- type errors from tcInstanceMethodBody come from here
903 ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty
904 local_meth_id = mkLocalId local_meth_name local_meth_ty
905
906 ; case lookupHsSig sig_fn sel_name of
907 Just lhs_ty -- There is a signature in the instance declaration
908 -- See Note [Instance method signatures]
909 -> setSrcSpan (getLoc lhs_ty) $
910 do { inst_sigs <- xoptM Opt_InstanceSigs
911 ; checkTc inst_sigs (misplacedInstSig sel_name lhs_ty)
912 ; sig_ty <- tcHsSigType (FunSigCtxt sel_name) lhs_ty
913 ; let poly_sig_ty = mkSigmaTy tyvars theta sig_ty
914 ; tc_sig <- instTcTySig lhs_ty sig_ty Nothing [] local_meth_name
915 ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name poly_sig_ty poly_meth_ty) $
916 tcSubType (FunSigCtxt sel_name) poly_sig_ty poly_meth_ty
917 ; return (poly_meth_id, tc_sig, hs_wrap) }
918
919 Nothing -- No type signature
920 -> do { tc_sig <- instTcTySigFromId local_meth_id
921 ; return (poly_meth_id, tc_sig, idHsWrapper) } }
922 -- Absent a type sig, there are no new scoped type variables here
923 -- Only the ones from the instance decl itself, which are already
924 -- in scope. Example:
925 -- class C a where { op :: forall b. Eq b => ... }
926 -- instance C [c] where { op = <rhs> }
927 -- In <rhs>, 'c' is scope but 'b' is not!
928 where
929 sel_name = idName sel_id
930 sel_occ = nameOccName sel_name
931 local_meth_ty = instantiateMethod clas sel_id inst_tys
932 poly_meth_ty = mkSigmaTy tyvars theta local_meth_ty
933 theta = map idType dfun_ev_vars
934
935 methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
936 methSigCtxt sel_name sig_ty meth_ty env0
937 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty
938 ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
939 ; let msg = hang (ptext (sLit "When checking that instance signature for") <+> quotes (ppr sel_name))
940 2 (vcat [ ptext (sLit "is more general than its signature in the class")
941 , ptext (sLit "Instance sig:") <+> ppr sig_ty
942 , ptext (sLit " Class sig:") <+> ppr meth_ty ])
943 ; return (env2, msg) }
944
945 misplacedInstSig :: Name -> LHsType Name -> SDoc
946 misplacedInstSig name hs_ty
947 = vcat [ hang (ptext (sLit "Illegal type signature in instance declaration:"))
948 2 (hang (pprPrefixName name)
949 2 (dcolon <+> ppr hs_ty))
950 , ptext (sLit "(Use InstanceSigs to allow this)") ]
951
952 {-
953 Note [Instance method signatures]
954 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
955 With -XInstanceSigs we allow the user to supply a signature for the
956 method in an instance declaration. Here is an artificial example:
957
958 data Age = MkAge Int
959 instance Ord Age where
960 compare :: a -> a -> Bool
961 compare = error "You can't compare Ages"
962
963 The instance signature can be *more* polymorphic than the instantiated
964 class method (in this case: Age -> Age -> Bool), but it cannot be less
965 polymorphic. Moreover, if a signature is given, the implementation
966 code should match the signature, and type variables bound in the
967 singature should scope over the method body.
968
969 We achieve this by building a TcSigInfo for the method, whether or not
970 there is an instance method signature, and using that to typecheck
971 the declaration (in tcInstanceMethodBody). That means, conveniently,
972 that the type variables bound in the signature will scope over the body.
973
974 What about the check that the instance method signature is more
975 polymorphic than the instantiated class method type? We just do a
976 tcSubType call in mkMethIds, and use the HsWrapper thus generated in
977 the method AbsBind. It's very like the tcSubType impedence-matching
978 call in mkExport. We have to pass the HsWrapper into
979 tcInstanceMethodBody.
980
981
982 ************************************************************************
983 * *
984 Type-checking superclases
985 * *
986 ************************************************************************
987 -}
988
989 tcSuperClasses :: FamInstEnvs -> SrcSpan
990 -> Class -> [TcTyVar] -> [EvVar]
991 -> TcThetaType -> [TcType]
992 -> TcM ([EvVar], [LHsBind Id])
993 -- Make a new top-level function binding for each superclass,
994 -- something like
995 -- $Ordp0 :: forall a. Ord a => Eq [a]
996 -- $Ordp0 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
997 --
998 -- See Note [Recursive superclasses] for why this is so hard!
999 -- In effect, be build a special-purpose solver for the first step
1000 -- of solving each superclass constraint
1001 tcSuperClasses fam_envs loc cls tyvars dfun_evs sc_theta inst_tys
1002 = do { traceTc "tcSuperClasses" (ppr cls $$ ppr inst_tys $$ ppr given_cls_preds)
1003 ; mapAndUnzipM tc_super (zip sc_theta [0..]) }
1004 where
1005 head_size = sizeTypes inst_tys
1006
1007 ------------
1008 given_cls_preds :: [(EvTerm, TcType)] -- (ev_term, type of that ev_term)
1009 -- given_cls_preds is the list of (ev_term, type) that can be derived
1010 -- from the dfun_evs, using the rules (sc1) and (sc3) of
1011 -- Note [Recursive superclasses] below
1012 -- When solving for superclasses, we search this list
1013 given_cls_preds
1014 = [ ev_pr | dfun_ev <- dfun_evs
1015 , ev_pr <- super_classes (EvId dfun_ev, idType dfun_ev) ]
1016
1017 ------------
1018 super_classes ev_pair
1019 | (ev_tm, pred) <- normalise_pr ev_pair
1020 , ClassPred cls tys <- classifyPredType pred
1021 = (ev_tm, pred) : super_classes_help ev_tm cls tys
1022 | otherwise
1023 = []
1024
1025 ------------
1026 super_classes_help :: EvTerm -> Class -> [TcType] -> [(EvTerm, TcType)]
1027 super_classes_help ev_tm cls tys -- ev_tm :: cls tys
1028 | sizeTypes tys >= head_size -- Here is where we test for
1029 = [] -- a smaller dictionary
1030 | otherwise
1031 = concatMap super_classes ([EvSuperClass ev_tm i | i <- [0..]]
1032 `zip` immSuperClasses cls tys)
1033
1034 ------------
1035 normalise_pr :: (EvTerm, TcPredType) -> (EvTerm, TcPredType)
1036 -- Normalise type functions as much as possible
1037 normalise_pr (ev_tm, pred)
1038 | isReflCo norm_co = (ev_tm, pred)
1039 | otherwise = (mkEvCast ev_tm tc_co, norm_pred)
1040 where
1041 (norm_co, norm_pred) = normaliseType fam_envs Nominal pred
1042 tc_co = TcCoercion (mkSubCo norm_co)
1043
1044 ------------
1045 tc_super (sc_pred, n)
1046 = do { (ev_binds, sc_ev_id) <- checkScConstraints InstSkol tyvars dfun_evs $
1047 emit_sc_pred fam_envs sc_pred
1048
1049 ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
1050 ; let sc_top_ty = mkForAllTys tyvars (mkPiTypes dfun_evs sc_pred)
1051 sc_top_id = mkLocalId sc_top_name sc_top_ty
1052 export = ABE { abe_wrap = idHsWrapper, abe_poly = sc_top_id
1053 , abe_mono = sc_ev_id
1054 , abe_prags = SpecPrags [] }
1055 bind = AbsBinds { abs_tvs = tyvars
1056 , abs_ev_vars = dfun_evs
1057 , abs_exports = [export]
1058 , abs_ev_binds = ev_binds
1059 , abs_binds = emptyBag }
1060 ; return (sc_top_id, L loc bind) }
1061
1062 -------------------
1063 emit_sc_pred fam_envs sc_pred ev_binds
1064 | (sc_co, norm_sc_pred) <- normaliseType fam_envs Nominal sc_pred
1065 -- sc_co :: sc_pred ~ norm_sc_pred
1066 , ClassPred cls tys <- classifyPredType norm_sc_pred
1067 = do { (ok, sc_ev_tm) <- emit_sc_cls_pred norm_sc_pred cls tys
1068 ; sc_ev_id <- newEvVar sc_pred
1069 ; let tc_co = TcCoercion (mkSubCo (mkSymCo sc_co))
1070 ; addTcEvBind ev_binds sc_ev_id (mkEvCast sc_ev_tm tc_co)
1071 ; return (ok, sc_ev_id) }
1072
1073 | otherwise
1074 = do { sc_ev_id <- emitWanted ScOrigin sc_pred
1075 ; traceTc "tcSuperClass 4" (ppr sc_pred $$ ppr sc_ev_id)
1076 ; return (True, sc_ev_id) }
1077
1078 -------------------
1079 emit_sc_cls_pred sc_pred cls tys
1080 | (ev_tm:_) <- [ ev_tm | (ev_tm, ev_ty) <- given_cls_preds
1081 , ev_ty `tcEqType` sc_pred ]
1082 = do { traceTc "tcSuperClass 1" (ppr sc_pred $$ ppr ev_tm)
1083 ; return (True, ev_tm) }
1084
1085 | otherwise
1086 = do { inst_envs <- tcGetInstEnvs
1087 ; case lookupInstEnv inst_envs cls tys of
1088 ([(ispec, dfun_inst_tys)], [], _) -- A single match
1089 -> do { let dfun_id = instanceDFunId ispec
1090 ; (inst_tys, inst_theta) <- instDFunType dfun_id dfun_inst_tys
1091 ; arg_evs <- emitWanteds ScOrigin inst_theta
1092 ; let dict_app = EvDFunApp dfun_id inst_tys (map EvId arg_evs)
1093 ; traceTc "tcSuperClass 2" (ppr sc_pred $$ ppr dict_app)
1094 ; return (True, dict_app) }
1095
1096 _ -> do { sc_ev_id <- emitWanted ScOrigin sc_pred
1097 ; traceTc "tcSuperClass 3" (ppr sc_pred $$ ppr sc_ev_id)
1098 ; return (False, EvId sc_ev_id) } }
1099
1100
1101 {-
1102 Note [Recursive superclasses]
1103 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1104 See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all
1105 describe somewhat more complicated situations, but ones
1106 encountered in practice.
1107
1108 See also tests tcrun020, tcrun021, tcrun033
1109
1110
1111 ----- THE PROBLEM --------
1112 The problem is that it is all too easy to create a class whose
1113 superclass is bottom when it should not be.
1114
1115 Consider the following (extreme) situation:
1116 class C a => D a where ...
1117 instance D [a] => D [a] where ... (dfunD)
1118 instance C [a] => C [a] where ... (dfunC)
1119 Although this looks wrong (assume D [a] to prove D [a]), it is only a
1120 more extreme case of what happens with recursive dictionaries, and it
1121 can, just about, make sense because the methods do some work before
1122 recursing.
1123
1124 To implement the dfunD we must generate code for the superclass C [a],
1125 which we had better not get by superclass selection from the supplied
1126 argument:
1127 dfunD :: forall a. D [a] -> D [a]
1128 dfunD = \d::D [a] -> MkD (scsel d) ..
1129
1130 Otherwise if we later encounter a situation where
1131 we have a [Wanted] dw::D [a] we might solve it thus:
1132 dw := dfunD dw
1133 Which is all fine except that now ** the superclass C is bottom **!
1134
1135 The instance we want is:
1136 dfunD :: forall a. D [a] -> D [a]
1137 dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
1138
1139 ----- THE SOLUTION --------
1140 The basic solution is simple: be very careful about using superclass
1141 selection to generate a superclass witness in a dictionary function
1142 definition. More precisely:
1143
1144 Superclass Invariant: in every class dictionary,
1145 every superclass dictionary field
1146 is non-bottom
1147
1148 To achieve the Superclass Invariant, in a dfun definition we can
1149 generate a guaranteed-non-bottom superclass witness from:
1150 (sc1) one of the dictionary arguments itself (all non-bottom)
1151 (sc2) a call of a dfun (always returns a dictionary constructor)
1152 (sc3) an immediate superclass of a smaller dictionary
1153
1154 The tricky case is (sc3). We proceed by induction on the size of
1155 the (type of) the dictionary, defined by TcValidity.sizePred.
1156 Let's suppose we are building a dictionary of size 3, and
1157 suppose the Superclass Invariant holds of smaller dictionaries.
1158 Then if we have a smaller dictionary, its immediate superclasses
1159 will be non-bottom by induction.
1160
1161 What does "we have a smaller dictionary" mean? It might be
1162 one of the arguments of the instance, or one of its superclasses.
1163 Here is an example, taken from CmmExpr:
1164 class Ord r => UserOfRegs r a where ...
1165 (i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where
1166 (i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
1167
1168 For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
1169 since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
1170
1171 But for (i2) that isn't the case, so we must add an explicit, and
1172 perhaps surprising, (Ord r) argument to the instance declaration.
1173
1174 Here's another example from Trac #6161:
1175
1176 class Super a => Duper a where ...
1177 class Duper (Fam a) => Foo a where ...
1178 (i3) instance Foo a => Duper (Fam a) where ...
1179 (i4) instance Foo Float where ...
1180
1181 It would be horribly wrong to define
1182 dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3)
1183 dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
1184
1185 dfFooFloat :: Foo Float -- from (i4)
1186 dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
1187
1188 Now the Super superclass of Duper is definitely bottom!
1189
1190 This won't happen because when processing (i3) we can use the
1191 superclasses of (Foo a), which is smaller, namely Duper (Fam a). But
1192 that is *not* smaller than the target so we can't take *its*
1193 superclasses. As a result the program is rightly rejected, unless you
1194 add (Super (Fam a)) to the context of (i3).
1195
1196 Note [Silent superclass arguments] (historical interest)
1197 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1198 NB1: this note describes our *old* solution to the
1199 recursive-superclass problem. I'm keeping the Note
1200 for now, just as institutional memory.
1201 However, the code for silent superclass arguments
1202 was removed in late Dec 2014
1203
1204 NB2: the silent-superclass solution introduced new problems
1205 of its own, in the form of instance overlap. Tests
1206 SilentParametersOverlapping, T5051, and T7862 are examples
1207
1208 NB3: the silent-superclass solution also generated tons of
1209 extra dictionaries. For example, in monad-transformer
1210 code, when constructing a Monad dictionary you had to pass
1211 an Applicative dictionary; and to construct that you neede
1212 a Functor dictionary. Yet these extra dictionaries were
1213 often never used. Test T3064 compiled *far* faster after
1214 silent superclasses were eliminated.
1215
1216 Our solution to this problem "silent superclass arguments". We pass
1217 to each dfun some ``silent superclass arguments’’, which are the
1218 immediate superclasses of the dictionary we are trying to
1219 construct. In our example:
1220 dfun :: forall a. C [a] -> D [a] -> D [a]
1221 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
1222 Notice the extra (dc :: C [a]) argument compared to the previous version.
1223
1224 This gives us:
1225
1226 -----------------------------------------------------------
1227 DFun Superclass Invariant
1228 ~~~~~~~~~~~~~~~~~~~~~~~~
1229 In the body of a DFun, every superclass argument to the
1230 returned dictionary is
1231 either * one of the arguments of the DFun,
1232 or * constant, bound at top level
1233 -----------------------------------------------------------
1234
1235 This net effect is that it is safe to treat a dfun application as
1236 wrapping a dictionary constructor around its arguments (in particular,
1237 a dfun never picks superclasses from the arguments under the
1238 dictionary constructor). No superclass is hidden inside a dfun
1239 application.
1240
1241 The extra arguments required to satisfy the DFun Superclass Invariant
1242 always come first, and are called the "silent" arguments. You can
1243 find out how many silent arguments there are using Id.dfunNSilent;
1244 and then you can just drop that number of arguments to see the ones
1245 that were in the original instance declaration.
1246
1247 DFun types are built (only) by MkId.mkDictFunId, so that is where we
1248 decide what silent arguments are to be added.
1249
1250
1251 ************************************************************************
1252 * *
1253 Specialise instance pragmas
1254 * *
1255 ************************************************************************
1256
1257 Note [SPECIALISE instance pragmas]
1258 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1259 Consider
1260
1261 instance (Ix a, Ix b) => Ix (a,b) where
1262 {-# SPECIALISE instance Ix (Int,Int) #-}
1263 range (x,y) = ...
1264
1265 We make a specialised version of the dictionary function, AND
1266 specialised versions of each *method*. Thus we should generate
1267 something like this:
1268
1269 $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
1270 {-# DFUN [$crangePair, ...] #-}
1271 {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
1272 $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
1273
1274 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
1275 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
1276 $crange da db = <blah>
1277
1278 The SPECIALISE pragmas are acted upon by the desugarer, which generate
1279
1280 dii :: Ix Int
1281 dii = ...
1282
1283 $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
1284 {-# DFUN [$crangePair di di, ...] #-}
1285 $s$dfIxPair = Ix ($crangePair di di) (...)
1286
1287 {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
1288
1289 $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
1290 $c$crangePair = ...specialised RHS of $crangePair...
1291
1292 {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
1293
1294 Note that
1295
1296 * The specialised dictionary $s$dfIxPair is very much needed, in case we
1297 call a function that takes a dictionary, but in a context where the
1298 specialised dictionary can be used. See Trac #7797.
1299
1300 * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
1301 it still has a DFunUnfolding. See Note [ClassOp/DFun selection]
1302
1303 * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
1304 --> {ClassOp rule for range} $crangePair Int Int d1 d2
1305 --> {SPEC rule for $crangePair} $s$crangePair
1306 or thus:
1307 --> {SPEC rule for $dfIxPair} range $s$dfIxPair
1308 --> {ClassOpRule for range} $s$crangePair
1309 It doesn't matter which way.
1310
1311 * We want to specialise the RHS of both $dfIxPair and $crangePair,
1312 but the SAME HsWrapper will do for both! We can call tcSpecPrag
1313 just once, and pass the result (in spec_inst_info) to tcInstanceMethods.
1314 -}
1315
1316 tcSpecInstPrags :: DFunId -> InstBindings Name
1317 -> TcM ([Located TcSpecPrag], PragFun)
1318 tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
1319 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
1320 filter isSpecInstLSig uprags
1321 -- The filter removes the pragmas for methods
1322 ; return (spec_inst_prags, mkPragFun uprags binds) }
1323
1324 ------------------------------
1325 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
1326 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
1327 = addErrCtxt (spec_ctxt prag) $
1328 do { (tyvars, theta, clas, tys) <- tcHsInstHead SpecInstCtxt hs_ty
1329 ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
1330 ; co_fn <- tcSubType SpecInstCtxt (idType dfun_id) spec_dfun_ty
1331 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
1332 where
1333 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
1334
1335 tcSpecInst _ _ = panic "tcSpecInst"
1336
1337 {-
1338 ************************************************************************
1339 * *
1340 Type-checking an instance method
1341 * *
1342 ************************************************************************
1343
1344 tcInstanceMethod
1345 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1346 - Remembering to use fresh Name (the instance method Name) as the binder
1347 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1348 - Use sig_fn mapping instance method Name -> instance tyvars
1349 - Ditto prag_fn
1350 - Use tcValBinds to do the checking
1351 -}
1352
1353 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
1354 -> [EvVar]
1355 -> [TcType]
1356 -> ([Located TcSpecPrag], PragFun)
1357 -> [(Id, DefMeth)]
1358 -> InstBindings Name
1359 -> TcM ([Id], [LHsBind Id])
1360 -- The returned inst_meth_ids all have types starting
1361 -- forall tvs. theta => ...
1362 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1363 (spec_inst_prags, prag_fn)
1364 op_items (InstBindings { ib_binds = binds
1365 , ib_tyvars = lexical_tvs
1366 , ib_pragmas = sigs
1367 , ib_extensions = exts
1368 , ib_derived = is_derived })
1369 = tcExtendTyVarEnv2 (lexical_tvs `zip` tyvars) $
1370 -- The lexical_tvs scope over the 'where' part
1371 do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
1372 ; let hs_sig_fn = mkHsSigFun sigs
1373 ; checkMinimalDefinition
1374 ; set_exts exts $ mapAndUnzipM (tc_item hs_sig_fn) op_items }
1375 where
1376 set_exts :: [ExtensionFlag] -> TcM a -> TcM a
1377 set_exts es thing = foldr setXOptM thing es
1378
1379 ----------------------
1380 tc_item :: HsSigFun -> (Id, DefMeth) -> TcM (Id, LHsBind Id)
1381 tc_item sig_fn (sel_id, dm_info)
1382 = case findMethodBind (idName sel_id) binds of
1383 Just (user_bind, bndr_loc)
1384 -> tc_body sig_fn sel_id user_bind bndr_loc
1385 Nothing -> do { traceTc "tc_def" (ppr sel_id)
1386 ; tc_default sig_fn sel_id dm_info }
1387
1388 ----------------------
1389 tc_body :: HsSigFun -> Id -> LHsBind Name
1390 -> SrcSpan -> TcM (TcId, LHsBind Id)
1391 tc_body sig_fn sel_id rn_bind bndr_loc
1392 = add_meth_ctxt sel_id rn_bind $
1393 do { traceTc "tc_item" (ppr sel_id <+> ppr (idType sel_id))
1394 ; (meth_id, local_meth_sig, hs_wrap)
1395 <- setSrcSpan bndr_loc $
1396 mkMethIds sig_fn clas tyvars dfun_ev_vars
1397 inst_tys sel_id
1398 ; let prags = prag_fn (idName sel_id)
1399 ; meth_id1 <- addInlinePrags meth_id prags
1400 ; spec_prags <- tcSpecPrags meth_id1 prags
1401 ; bind <- tcInstanceMethodBody InstSkol
1402 tyvars dfun_ev_vars
1403 meth_id1 local_meth_sig hs_wrap
1404 (mk_meth_spec_prags meth_id1 spec_prags)
1405 rn_bind
1406 ; return (meth_id1, bind) }
1407
1408 ----------------------
1409 tc_default :: HsSigFun -> Id -> DefMeth -> TcM (TcId, LHsBind Id)
1410
1411 tc_default sig_fn sel_id (GenDefMeth dm_name)
1412 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name
1413 ; tc_body sig_fn sel_id meth_bind inst_loc }
1414
1415 tc_default sig_fn sel_id NoDefMeth -- No default method at all
1416 = do { traceTc "tc_def: warn" (ppr sel_id)
1417 ; (meth_id, _, _) <- mkMethIds sig_fn clas tyvars dfun_ev_vars
1418 inst_tys sel_id
1419 ; dflags <- getDynFlags
1420 ; return (meth_id,
1421 mkVarBind meth_id $
1422 mkLHsWrap lam_wrapper (error_rhs dflags)) }
1423 where
1424 error_rhs dflags = L inst_loc $ HsApp error_fun (error_msg dflags)
1425 error_fun = L inst_loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
1426 error_msg dflags = L inst_loc (HsLit (HsStringPrim ""
1427 (unsafeMkByteString (error_string dflags))))
1428 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
1429 error_string dflags = showSDoc dflags (hcat [ppr inst_loc, text "|", ppr sel_id ])
1430 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1431
1432 tc_default sig_fn sel_id (DefMeth dm_name) -- A polymorphic default method
1433 = do { -- Build the typechecked version directly,
1434 -- without calling typecheck_method;
1435 -- see Note [Default methods in instances]
1436 -- Generate /\as.\ds. let self = df as ds
1437 -- in $dm inst_tys self
1438 -- The 'let' is necessary only because HsSyn doesn't allow
1439 -- you to apply a function to a dictionary *expression*.
1440
1441 ; self_dict <- newDict clas inst_tys
1442 ; let self_ev_bind = EvBind self_dict
1443 (EvDFunApp dfun_id (mkTyVarTys tyvars) (map EvId dfun_ev_vars))
1444
1445 ; (meth_id, local_meth_sig, hs_wrap)
1446 <- mkMethIds sig_fn clas tyvars dfun_ev_vars inst_tys sel_id
1447 ; dm_id <- tcLookupId dm_name
1448 ; let dm_inline_prag = idInlinePragma dm_id
1449 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
1450 HsVar dm_id
1451
1452 local_meth_id = sig_id local_meth_sig
1453 meth_bind = mkVarBind local_meth_id (L inst_loc rhs)
1454 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
1455 -- Copy the inline pragma (if any) from the default
1456 -- method to this version. Note [INLINE and default methods]
1457
1458
1459 export = ABE { abe_wrap = hs_wrap, abe_poly = meth_id1
1460 , abe_mono = local_meth_id
1461 , abe_prags = mk_meth_spec_prags meth_id1 [] }
1462 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1463 , abs_exports = [export]
1464 , abs_ev_binds = EvBinds (unitBag self_ev_bind)
1465 , abs_binds = unitBag meth_bind }
1466 -- Default methods in an instance declaration can't have their own
1467 -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
1468 -- currently they are rejected with
1469 -- "INLINE pragma lacks an accompanying binding"
1470
1471 ; return (meth_id1, L inst_loc bind) }
1472
1473 ----------------------
1474 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
1475 -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
1476 -- There are two sources:
1477 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1478 -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
1479 -- These ones have the dfun inside, but [perhaps surprisingly]
1480 -- the correct wrapper.
1481 mk_meth_spec_prags meth_id spec_prags_for_me
1482 = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
1483 where
1484 spec_prags_from_inst
1485 | isInlinePragma (idInlinePragma meth_id)
1486 = [] -- Do not inherit SPECIALISE from the instance if the
1487 -- method is marked INLINE, because then it'll be inlined
1488 -- and the specialisation would do nothing. (Indeed it'll provoke
1489 -- a warning from the desugarer
1490 | otherwise
1491 = [ L inst_loc (SpecPrag meth_id wrap inl)
1492 | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
1493
1494 inst_loc = getSrcSpan dfun_id
1495
1496 -- For instance decls that come from deriving clauses
1497 -- we want to print out the full source code if there's an error
1498 -- because otherwise the user won't see the code at all
1499 add_meth_ctxt sel_id rn_bind thing
1500 | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
1501 | otherwise = thing
1502
1503 ----------------------
1504
1505 -- check if one of the minimal complete definitions is satisfied
1506 checkMinimalDefinition
1507 = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
1508 warnUnsatisifiedMinimalDefinition
1509 where
1510 methodExists meth = isJust (findMethodBind meth binds)
1511
1512 mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name)
1513 mkGenericDefMethBind clas inst_tys sel_id dm_name
1514 = -- A generic default method
1515 -- If the method is defined generically, we only have to call the
1516 -- dm_name.
1517 do { dflags <- getDynFlags
1518 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
1519 (vcat [ppr clas <+> ppr inst_tys,
1520 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
1521
1522 ; return (noLoc $ mkTopFunBind Generated (noLoc (idName sel_id))
1523 [mkSimpleMatch [] rhs]) }
1524 where
1525 rhs = nlHsVar dm_name
1526
1527 ----------------------
1528 wrapId :: HsWrapper -> id -> HsExpr id
1529 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1530
1531 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1532 derivBindCtxt sel_id clas tys _bind
1533 = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1534 , nest 2 (ptext (sLit "in a derived instance for")
1535 <+> quotes (pprClassPred clas tys) <> colon)
1536 , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1537
1538 warnMissingMethodOrAT :: String -> Name -> TcM ()
1539 warnMissingMethodOrAT what name
1540 = do { warn <- woptM Opt_WarnMissingMethods
1541 ; traceTc "warn" (ppr name <+> ppr warn <+> ppr (not (startsWithUnderscore (getOccName name))))
1542 ; warnTc (warn -- Warn only if -fwarn-missing-methods
1543 && not (startsWithUnderscore (getOccName name)))
1544 -- Don't warn about _foo methods
1545 (ptext (sLit "No explicit") <+> text what <+> ptext (sLit "or default declaration for")
1546 <+> quotes (ppr name)) }
1547
1548 warnUnsatisifiedMinimalDefinition :: ClassMinimalDef -> TcM ()
1549 warnUnsatisifiedMinimalDefinition mindef
1550 = do { warn <- woptM Opt_WarnMissingMethods
1551 ; warnTc warn message
1552 }
1553 where
1554 message = vcat [ptext (sLit "No explicit implementation for")
1555 ,nest 2 $ pprBooleanFormulaNice mindef
1556 ]
1557
1558 {-
1559 Note [Export helper functions]
1560 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1561 We arrange to export the "helper functions" of an instance declaration,
1562 so that they are not subject to preInlineUnconditionally, even if their
1563 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1564 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1565 non-variable for them.
1566
1567 We could change this by making DFunUnfoldings have CoreExprs, but it
1568 seems a bit simpler this way.
1569
1570 Note [Default methods in instances]
1571 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1572 Consider this
1573
1574 class Baz v x where
1575 foo :: x -> x
1576 foo y = <blah>
1577
1578 instance Baz Int Int
1579
1580 From the class decl we get
1581
1582 $dmfoo :: forall v x. Baz v x => x -> x
1583 $dmfoo y = <blah>
1584
1585 Notice that the type is ambiguous. That's fine, though. The instance
1586 decl generates
1587
1588 $dBazIntInt = MkBaz fooIntInt
1589 fooIntInt = $dmfoo Int Int $dBazIntInt
1590
1591 BUT this does mean we must generate the dictionary translation of
1592 fooIntInt directly, rather than generating source-code and
1593 type-checking it. That was the bug in Trac #1061. In any case it's
1594 less work to generate the translated version!
1595
1596 Note [INLINE and default methods]
1597 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1598 Default methods need special case. They are supposed to behave rather like
1599 macros. For exmample
1600
1601 class Foo a where
1602 op1, op2 :: Bool -> a -> a
1603
1604 {-# INLINE op1 #-}
1605 op1 b x = op2 (not b) x
1606
1607 instance Foo Int where
1608 -- op1 via default method
1609 op2 b x = <blah>
1610
1611 The instance declaration should behave
1612
1613 just as if 'op1' had been defined with the
1614 code, and INLINE pragma, from its original
1615 definition.
1616
1617 That is, just as if you'd written
1618
1619 instance Foo Int where
1620 op2 b x = <blah>
1621
1622 {-# INLINE op1 #-}
1623 op1 b x = op2 (not b) x
1624
1625 So for the above example we generate:
1626
1627 {-# INLINE $dmop1 #-}
1628 -- $dmop1 has an InlineCompulsory unfolding
1629 $dmop1 d b x = op2 d (not b) x
1630
1631 $fFooInt = MkD $cop1 $cop2
1632
1633 {-# INLINE $cop1 #-}
1634 $cop1 = $dmop1 $fFooInt
1635
1636 $cop2 = <blah>
1637
1638 Note carefully:
1639
1640 * We *copy* any INLINE pragma from the default method $dmop1 to the
1641 instance $cop1. Otherwise we'll just inline the former in the
1642 latter and stop, which isn't what the user expected
1643
1644 * Regardless of its pragma, we give the default method an
1645 unfolding with an InlineCompulsory source. That means
1646 that it'll be inlined at every use site, notably in
1647 each instance declaration, such as $cop1. This inlining
1648 must happen even though
1649 a) $dmop1 is not saturated in $cop1
1650 b) $cop1 itself has an INLINE pragma
1651
1652 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1653 recursion between $fooInt and $cop1 to be broken
1654
1655 * To communicate the need for an InlineCompulsory to the desugarer
1656 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1657 in TcSpecPrags.
1658
1659
1660 ************************************************************************
1661 * *
1662 \subsection{Error messages}
1663 * *
1664 ************************************************************************
1665 -}
1666
1667 instDeclCtxt1 :: LHsType Name -> SDoc
1668 instDeclCtxt1 hs_inst_ty
1669 = inst_decl_ctxt (case unLoc hs_inst_ty of
1670 HsForAllTy _ _ _ _ (L _ ty') -> ppr ty'
1671 _ -> ppr hs_inst_ty) -- Don't expect this
1672 instDeclCtxt2 :: Type -> SDoc
1673 instDeclCtxt2 dfun_ty
1674 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1675 where
1676 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1677
1678 inst_decl_ctxt :: SDoc -> SDoc
1679 inst_decl_ctxt doc = hang (ptext (sLit "In the instance declaration for"))
1680 2 (quotes doc)
1681
1682 badBootFamInstDeclErr :: SDoc
1683 badBootFamInstDeclErr
1684 = ptext (sLit "Illegal family instance in hs-boot file")
1685
1686 notFamily :: TyCon -> SDoc
1687 notFamily tycon
1688 = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon)
1689 , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))]
1690
1691 tooFewParmsErr :: Arity -> SDoc
1692 tooFewParmsErr arity
1693 = ptext (sLit "Family instance has too few parameters; expected") <+>
1694 ppr arity
1695
1696 assocInClassErr :: Located Name -> SDoc
1697 assocInClassErr name
1698 = ptext (sLit "Associated type") <+> quotes (ppr name) <+>
1699 ptext (sLit "must be inside a class instance")
1700
1701 badFamInstDecl :: Located Name -> SDoc
1702 badFamInstDecl tc_name
1703 = vcat [ ptext (sLit "Illegal family instance for") <+>
1704 quotes (ppr tc_name)
1705 , nest 2 (parens $ ptext (sLit "Use TypeFamilies to allow indexed type families")) ]
1706
1707 notOpenFamily :: TyCon -> SDoc
1708 notOpenFamily tc
1709 = ptext (sLit "Illegal instance for closed family") <+> quotes (ppr tc)