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