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