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