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