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