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