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