Add nakedSubstTy and use it in TcHsType.tcInferApps
[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 ; env <- getLclEnv
817 ; emitImplication $
818 newImplication { 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_env = env
824 , ic_info = InstSkol }
825
826 -- Create the result bindings
827 ; self_dict <- newDict clas inst_tys
828 ; let class_tc = classTyCon clas
829 [dict_constr] = tyConDataCons class_tc
830 dict_bind = mkVarBind self_dict (L loc con_app_args)
831
832 -- We don't produce a binding for the dict_constr; instead we
833 -- rely on the simplifier to unfold this saturated application
834 -- We do this rather than generate an HsCon directly, because
835 -- it means that the special cases (e.g. dictionary with only one
836 -- member) are dealt with by the common MkId.mkDataConWrapId
837 -- code rather than needing to be repeated here.
838 -- con_app_tys = MkD ty1 ty2
839 -- con_app_scs = MkD ty1 ty2 sc1 sc2
840 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
841 con_app_tys = mkHsWrap (mkWpTyApps inst_tys)
842 (HsConLikeOut noExt (RealDataCon dict_constr))
843 -- NB: We *can* have covars in inst_tys, in the case of
844 -- promoted GADT constructors.
845
846 con_app_args = foldl app_to_meth con_app_tys sc_meth_ids
847
848 app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
849 app_to_meth fun meth_id = HsApp noExt (L loc fun)
850 (L loc (wrapId arg_wrapper meth_id))
851
852 inst_tv_tys = mkTyVarTys inst_tyvars
853 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
854
855 is_newtype = isNewTyCon class_tc
856 dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids
857 dfun_spec_prags
858 | is_newtype = SpecPrags []
859 | otherwise = SpecPrags spec_inst_prags
860 -- Newtype dfuns just inline unconditionally,
861 -- so don't attempt to specialise them
862
863 export = ABE { abe_ext = noExt
864 , abe_wrap = idHsWrapper
865 , abe_poly = dfun_id_w_prags
866 , abe_mono = self_dict
867 , abe_prags = dfun_spec_prags }
868 -- NB: see Note [SPECIALISE instance pragmas]
869 main_bind = AbsBinds { abs_ext = noExt
870 , abs_tvs = inst_tyvars
871 , abs_ev_vars = dfun_ev_vars
872 , abs_exports = [export]
873 , abs_ev_binds = []
874 , abs_binds = unitBag dict_bind
875 , abs_sig = True }
876
877 ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
878 }
879 where
880 dfun_id = instanceDFunId ispec
881 loc = getSrcSpan dfun_id
882
883 addDFunPrags :: DFunId -> [Id] -> DFunId
884 -- DFuns need a special Unfolding and InlinePrag
885 -- See Note [ClassOp/DFun selection]
886 -- and Note [Single-method classes]
887 -- It's easiest to create those unfoldings right here, where
888 -- have all the pieces in hand, even though we are messing with
889 -- Core at this point, which the typechecker doesn't usually do
890 -- However we take care to build the unfolding using the TyVars from
891 -- the DFunId rather than from the skolem pieces that the typechecker
892 -- is messing with.
893 addDFunPrags dfun_id sc_meth_ids
894 | is_newtype
895 = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app
896 `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
897 | otherwise
898 = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
899 `setInlinePragma` dfunInlinePragma
900 where
901 con_app = mkLams dfun_bndrs $
902 mkApps (Var (dataConWrapId dict_con)) dict_args
903 -- mkApps is OK because of the checkForLevPoly call in checkValidClass
904 -- See Note [Levity polymorphism checking] in DsMonad
905 dict_args = map Type inst_tys ++
906 [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]
907
908 (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
909 ev_ids = mkTemplateLocalsNum 1 dfun_theta
910 dfun_bndrs = dfun_tvs ++ ev_ids
911 clas_tc = classTyCon clas
912 [dict_con] = tyConDataCons clas_tc
913 is_newtype = isNewTyCon clas_tc
914
915 wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)
916 wrapId wrapper id = mkHsWrap wrapper (HsVar noExt (noLoc id))
917
918 {- Note [Typechecking plan for instance declarations]
919 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
920 For instance declarations we generate the following bindings and implication
921 constraints. Example:
922
923 instance Ord a => Ord [a] where compare = <compare-rhs>
924
925 generates this:
926
927 Bindings:
928 -- Method bindings
929 $ccompare :: forall a. Ord a => a -> a -> Ordering
930 $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...
931
932 -- Superclass bindings
933 $cp1Ord :: forall a. Ord a => Eq [a]
934 $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>
935 in dfEqList (dw :: Eq a)
936
937 Constraints:
938 forall a. Ord a =>
939 -- Method constraint
940 (forall. (empty) => <constraints from compare-rhs>)
941 -- Superclass constraint
942 /\ (forall. (empty) => dw :: Eq a)
943
944 Notice that
945
946 * Per-meth/sc implication. There is one inner implication per
947 superclass or method, with no skolem variables or givens. The only
948 reason for this one is to gather the evidence bindings privately
949 for this superclass or method. This implication is generated
950 by checkInstConstraints.
951
952 * Overall instance implication. There is an overall enclosing
953 implication for the whole instance declaration, with the expected
954 skolems and givens. We need this to get the correct "redundant
955 constraint" warnings, gathering all the uses from all the methods
956 and superclasses. See TcSimplify Note [Tracking redundant
957 constraints]
958
959 * The given constraints in the outer implication may generate
960 evidence, notably by superclass selection. Since the method and
961 superclass bindings are top-level, we want that evidence copied
962 into *every* method or superclass definition. (Some of it will
963 be usused in some, but dead-code elimination will drop it.)
964
965 We achieve this by putting the evidence variable for the overall
966 instance implication into the AbsBinds for each method/superclass.
967 Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.
968 (And that in turn is why the abs_ev_binds field of AbBinds is a
969 [TcEvBinds] rather than simply TcEvBinds.
970
971 This is a bit of a hack, but works very nicely in practice.
972
973 * Note that if a method has a locally-polymorphic binding, there will
974 be yet another implication for that, generated by tcPolyCheck
975 in tcMethodBody. E.g.
976 class C a where
977 foo :: forall b. Ord b => blah
978
979
980 ************************************************************************
981 * *
982 Type-checking superclasses
983 * *
984 ************************************************************************
985 -}
986
987 tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
988 -> TcEvBinds
989 -> TcThetaType
990 -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
991 -- Make a new top-level function binding for each superclass,
992 -- something like
993 -- $Ordp1 :: forall a. Ord a => Eq [a]
994 -- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
995 --
996 -- See Note [Recursive superclasses] for why this is so hard!
997 -- In effect, we build a special-purpose solver for the first step
998 -- of solving each superclass constraint
999 tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
1000 = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])
1001 ; return (ids, listToBag binds, listToBag implics) }
1002 where
1003 loc = getSrcSpan dfun_id
1004 size = sizeTypes inst_tys
1005 tc_super (sc_pred, n)
1006 = do { (sc_implic, ev_binds_var, sc_ev_tm)
1007 <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred
1008
1009 ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
1010 ; sc_ev_id <- newEvVar sc_pred
1011 ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
1012 ; let sc_top_ty = mkInvForAllTys tyvars (mkLamTypes dfun_evs sc_pred)
1013 sc_top_id = mkLocalId sc_top_name sc_top_ty
1014 export = ABE { abe_ext = noExt
1015 , abe_wrap = idHsWrapper
1016 , abe_poly = sc_top_id
1017 , abe_mono = sc_ev_id
1018 , abe_prags = noSpecPrags }
1019 local_ev_binds = TcEvBinds ev_binds_var
1020 bind = AbsBinds { abs_ext = noExt
1021 , abs_tvs = tyvars
1022 , abs_ev_vars = dfun_evs
1023 , abs_exports = [export]
1024 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1025 , abs_binds = emptyBag
1026 , abs_sig = False }
1027 ; return (sc_top_id, L loc bind, sc_implic) }
1028
1029 -------------------
1030 checkInstConstraints :: TcM result
1031 -> TcM (Implication, EvBindsVar, result)
1032 -- See Note [Typechecking plan for instance declarations]
1033 checkInstConstraints thing_inside
1034 = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $
1035 thing_inside
1036
1037 ; ev_binds_var <- newTcEvBinds
1038 ; env <- getLclEnv
1039 ; let implic = newImplication { ic_tclvl = tclvl
1040 , ic_wanted = wanted
1041 , ic_binds = ev_binds_var
1042 , ic_env = env
1043 , ic_info = InstSkol }
1044
1045 ; return (implic, ev_binds_var, result) }
1046
1047 {-
1048 Note [Recursive superclasses]
1049 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1050 See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all
1051 describe somewhat more complicated situations, but ones
1052 encountered in practice.
1053
1054 See also tests tcrun020, tcrun021, tcrun033, and Trac #11427.
1055
1056 ----- THE PROBLEM --------
1057 The problem is that it is all too easy to create a class whose
1058 superclass is bottom when it should not be.
1059
1060 Consider the following (extreme) situation:
1061 class C a => D a where ...
1062 instance D [a] => D [a] where ... (dfunD)
1063 instance C [a] => C [a] where ... (dfunC)
1064 Although this looks wrong (assume D [a] to prove D [a]), it is only a
1065 more extreme case of what happens with recursive dictionaries, and it
1066 can, just about, make sense because the methods do some work before
1067 recursing.
1068
1069 To implement the dfunD we must generate code for the superclass C [a],
1070 which we had better not get by superclass selection from the supplied
1071 argument:
1072 dfunD :: forall a. D [a] -> D [a]
1073 dfunD = \d::D [a] -> MkD (scsel d) ..
1074
1075 Otherwise if we later encounter a situation where
1076 we have a [Wanted] dw::D [a] we might solve it thus:
1077 dw := dfunD dw
1078 Which is all fine except that now ** the superclass C is bottom **!
1079
1080 The instance we want is:
1081 dfunD :: forall a. D [a] -> D [a]
1082 dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
1083
1084 ----- THE SOLUTION --------
1085 The basic solution is simple: be very careful about using superclass
1086 selection to generate a superclass witness in a dictionary function
1087 definition. More precisely:
1088
1089 Superclass Invariant: in every class dictionary,
1090 every superclass dictionary field
1091 is non-bottom
1092
1093 To achieve the Superclass Invariant, in a dfun definition we can
1094 generate a guaranteed-non-bottom superclass witness from:
1095 (sc1) one of the dictionary arguments itself (all non-bottom)
1096 (sc2) an immediate superclass of a smaller dictionary
1097 (sc3) a call of a dfun (always returns a dictionary constructor)
1098
1099 The tricky case is (sc2). We proceed by induction on the size of
1100 the (type of) the dictionary, defined by TcValidity.sizeTypes.
1101 Let's suppose we are building a dictionary of size 3, and
1102 suppose the Superclass Invariant holds of smaller dictionaries.
1103 Then if we have a smaller dictionary, its immediate superclasses
1104 will be non-bottom by induction.
1105
1106 What does "we have a smaller dictionary" mean? It might be
1107 one of the arguments of the instance, or one of its superclasses.
1108 Here is an example, taken from CmmExpr:
1109 class Ord r => UserOfRegs r a where ...
1110 (i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where
1111 (i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
1112
1113 For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
1114 since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
1115
1116 But for (i2) that isn't the case, so we must add an explicit, and
1117 perhaps surprising, (Ord r) argument to the instance declaration.
1118
1119 Here's another example from Trac #6161:
1120
1121 class Super a => Duper a where ...
1122 class Duper (Fam a) => Foo a where ...
1123 (i3) instance Foo a => Duper (Fam a) where ...
1124 (i4) instance Foo Float where ...
1125
1126 It would be horribly wrong to define
1127 dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3)
1128 dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
1129
1130 dfFooFloat :: Foo Float -- from (i4)
1131 dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
1132
1133 Now the Super superclass of Duper is definitely bottom!
1134
1135 This won't happen because when processing (i3) we can use the
1136 superclasses of (Foo a), which is smaller, namely Duper (Fam a). But
1137 that is *not* smaller than the target so we can't take *its*
1138 superclasses. As a result the program is rightly rejected, unless you
1139 add (Super (Fam a)) to the context of (i3).
1140
1141 Note [Solving superclass constraints]
1142 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1143 How do we ensure that every superclass witness is generated by
1144 one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].
1145 Answer:
1146
1147 * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)
1148 where 'size' is the size of the instance declaration. e.g.
1149 class C a => D a where...
1150 instance blah => D [a] where ...
1151 The wanted superclass constraint for C [a] has origin
1152 ScOrigin size, where size = size( D [a] ).
1153
1154 * (sc1) When we rewrite such a wanted constraint, it retains its
1155 origin. But if we apply an instance declaration, we can set the
1156 origin to (ScOrigin infinity), thus lifting any restrictions by
1157 making prohibitedSuperClassSolve return False.
1158
1159 * (sc2) ScOrigin wanted constraints can't be solved from a
1160 superclass selection, except at a smaller type. This test is
1161 implemented by TcInteract.prohibitedSuperClassSolve
1162
1163 * The "given" constraints of an instance decl have CtOrigin
1164 GivenOrigin InstSkol.
1165
1166 * When we make a superclass selection from InstSkol we use
1167 a SkolemInfo of (InstSC size), where 'size' is the size of
1168 the constraint whose superclass we are taking. A similarly
1169 when taking the superclass of an InstSC. This is implemented
1170 in TcCanonical.newSCWorkFromFlavored
1171
1172 Note [Silent superclass arguments] (historical interest only)
1173 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1174 NB1: this note describes our *old* solution to the
1175 recursive-superclass problem. I'm keeping the Note
1176 for now, just as institutional memory.
1177 However, the code for silent superclass arguments
1178 was removed in late Dec 2014
1179
1180 NB2: the silent-superclass solution introduced new problems
1181 of its own, in the form of instance overlap. Tests
1182 SilentParametersOverlapping, T5051, and T7862 are examples
1183
1184 NB3: the silent-superclass solution also generated tons of
1185 extra dictionaries. For example, in monad-transformer
1186 code, when constructing a Monad dictionary you had to pass
1187 an Applicative dictionary; and to construct that you neede
1188 a Functor dictionary. Yet these extra dictionaries were
1189 often never used. Test T3064 compiled *far* faster after
1190 silent superclasses were eliminated.
1191
1192 Our solution to this problem "silent superclass arguments". We pass
1193 to each dfun some ``silent superclass arguments’’, which are the
1194 immediate superclasses of the dictionary we are trying to
1195 construct. In our example:
1196 dfun :: forall a. C [a] -> D [a] -> D [a]
1197 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
1198 Notice the extra (dc :: C [a]) argument compared to the previous version.
1199
1200 This gives us:
1201
1202 -----------------------------------------------------------
1203 DFun Superclass Invariant
1204 ~~~~~~~~~~~~~~~~~~~~~~~~
1205 In the body of a DFun, every superclass argument to the
1206 returned dictionary is
1207 either * one of the arguments of the DFun,
1208 or * constant, bound at top level
1209 -----------------------------------------------------------
1210
1211 This net effect is that it is safe to treat a dfun application as
1212 wrapping a dictionary constructor around its arguments (in particular,
1213 a dfun never picks superclasses from the arguments under the
1214 dictionary constructor). No superclass is hidden inside a dfun
1215 application.
1216
1217 The extra arguments required to satisfy the DFun Superclass Invariant
1218 always come first, and are called the "silent" arguments. You can
1219 find out how many silent arguments there are using Id.dfunNSilent;
1220 and then you can just drop that number of arguments to see the ones
1221 that were in the original instance declaration.
1222
1223 DFun types are built (only) by MkId.mkDictFunId, so that is where we
1224 decide what silent arguments are to be added.
1225 -}
1226
1227 {-
1228 ************************************************************************
1229 * *
1230 Type-checking an instance method
1231 * *
1232 ************************************************************************
1233
1234 tcMethod
1235 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1236 - Remembering to use fresh Name (the instance method Name) as the binder
1237 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1238 - Use sig_fn mapping instance method Name -> instance tyvars
1239 - Ditto prag_fn
1240 - Use tcValBinds to do the checking
1241 -}
1242
1243 tcMethods :: DFunId -> Class
1244 -> [TcTyVar] -> [EvVar]
1245 -> [TcType]
1246 -> TcEvBinds
1247 -> ([Located TcSpecPrag], TcPragEnv)
1248 -> [ClassOpItem]
1249 -> InstBindings GhcRn
1250 -> TcM ([Id], LHsBinds GhcTc, Bag Implication)
1251 -- The returned inst_meth_ids all have types starting
1252 -- forall tvs. theta => ...
1253 tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1254 dfun_ev_binds (spec_inst_prags, prag_fn) op_items
1255 (InstBindings { ib_binds = binds
1256 , ib_tyvars = lexical_tvs
1257 , ib_pragmas = sigs
1258 , ib_extensions = exts
1259 , ib_derived = is_derived })
1260 -- tcExtendTyVarEnv (not scopeTyVars) is OK because the TcLevel is pushed
1261 -- in checkInstConstraints
1262 = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $
1263 -- The lexical_tvs scope over the 'where' part
1264 do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
1265 ; checkMinimalDefinition
1266 ; checkMethBindMembership
1267 ; (ids, binds, mb_implics) <- set_exts exts $
1268 mapAndUnzip3M tc_item op_items
1269 ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
1270 where
1271 set_exts :: [LangExt.Extension] -> TcM a -> TcM a
1272 set_exts es thing = foldr setXOptM thing es
1273
1274 hs_sig_fn = mkHsSigFun sigs
1275 inst_loc = getSrcSpan dfun_id
1276
1277 ----------------------
1278 tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
1279 tc_item (sel_id, dm_info)
1280 | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn
1281 = tcMethodBody clas tyvars dfun_ev_vars inst_tys
1282 dfun_ev_binds is_derived hs_sig_fn
1283 spec_inst_prags prags
1284 sel_id user_bind bndr_loc
1285 | otherwise
1286 = do { traceTc "tc_def" (ppr sel_id)
1287 ; tc_default sel_id dm_info }
1288
1289 ----------------------
1290 tc_default :: Id -> DefMethInfo
1291 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1292
1293 tc_default sel_id (Just (dm_name, _))
1294 = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name
1295 ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
1296 dfun_ev_binds is_derived hs_sig_fn
1297 spec_inst_prags inline_prags
1298 sel_id meth_bind inst_loc }
1299
1300 tc_default sel_id Nothing -- No default method at all
1301 = do { traceTc "tc_def: warn" (ppr sel_id)
1302 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
1303 inst_tys sel_id
1304 ; dflags <- getDynFlags
1305 ; let meth_bind = mkVarBind meth_id $
1306 mkLHsWrap lam_wrapper (error_rhs dflags)
1307 ; return (meth_id, meth_bind, Nothing) }
1308 where
1309 error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)
1310 error_fun = L inst_loc $
1311 wrapId (mkWpTyApps
1312 [ getRuntimeRep meth_tau, meth_tau])
1313 nO_METHOD_BINDING_ERROR_ID
1314 error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim NoSourceText
1315 (unsafeMkByteString (error_string dflags))))
1316 meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys)
1317 error_string dflags = showSDoc dflags
1318 (hcat [ppr inst_loc, vbar, ppr sel_id ])
1319 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1320
1321 ----------------------
1322 -- Check if one of the minimal complete definitions is satisfied
1323 checkMinimalDefinition
1324 = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
1325 warnUnsatisfiedMinimalDefinition
1326
1327 methodExists meth = isJust (findMethodBind meth binds prag_fn)
1328
1329 ----------------------
1330 -- Check if any method bindings do not correspond to the class.
1331 -- See Note [Mismatched class methods and associated type families].
1332 checkMethBindMembership
1333 = let bind_nms = map unLoc $ collectMethodBinders binds
1334 cls_meth_nms = map (idName . fst) op_items
1335 mismatched_meths = bind_nms `minusList` cls_meth_nms
1336 in forM_ mismatched_meths $ \mismatched_meth ->
1337 addErrTc $ hsep
1338 [ text "Class", quotes (ppr (className clas))
1339 , text "does not have a method", quotes (ppr mismatched_meth)]
1340
1341 {-
1342 Note [Mismatched class methods and associated type families]
1343 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1344 It's entirely possible for someone to put methods or associated type family
1345 instances inside of a class in which it doesn't belong. For instance, we'd
1346 want to fail if someone wrote this:
1347
1348 instance Eq () where
1349 type Rep () = Maybe
1350 compare = undefined
1351
1352 Since neither the type family `Rep` nor the method `compare` belong to the
1353 class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,
1354 since that would discover that the parent class `Eq` is incorrect.
1355
1356 However, there is a scenario in which the renamer could fail to catch this:
1357 if the instance was generated through Template Haskell, as in #12387. In that
1358 case, Template Haskell will provide fully resolved names (e.g.,
1359 `GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
1360 on. For this reason, we also put an extra validity check for this in the
1361 typechecker as a last resort.
1362 -}
1363
1364 ------------------------
1365 tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
1366 -> TcEvBinds -> Bool
1367 -> HsSigFun
1368 -> [LTcSpecPrag] -> [LSig GhcRn]
1369 -> Id -> LHsBind GhcRn -> SrcSpan
1370 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1371 tcMethodBody clas tyvars dfun_ev_vars inst_tys
1372 dfun_ev_binds is_derived
1373 sig_fn spec_inst_prags prags
1374 sel_id (L bind_loc meth_bind) bndr_loc
1375 = add_meth_ctxt $
1376 do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
1377 ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
1378 mkMethIds clas tyvars dfun_ev_vars
1379 inst_tys sel_id
1380
1381 ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
1382 -- Substitute the local_meth_name for the binder
1383 -- NB: the binding is always a FunBind
1384
1385 -- taking instance signature into account might change the type of
1386 -- the local_meth_id
1387 ; (meth_implic, ev_binds_var, tc_bind)
1388 <- checkInstConstraints $
1389 tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
1390
1391 ; global_meth_id <- addInlinePrags global_meth_id prags
1392 ; spec_prags <- tcSpecPrags global_meth_id prags
1393
1394 ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
1395 export = ABE { abe_ext = noExt
1396 , abe_poly = global_meth_id
1397 , abe_mono = local_meth_id
1398 , abe_wrap = idHsWrapper
1399 , abe_prags = specs }
1400
1401 local_ev_binds = TcEvBinds ev_binds_var
1402 full_bind = AbsBinds { abs_ext = noExt
1403 , abs_tvs = tyvars
1404 , abs_ev_vars = dfun_ev_vars
1405 , abs_exports = [export]
1406 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1407 , abs_binds = tc_bind
1408 , abs_sig = True }
1409
1410 ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
1411 where
1412 -- For instance decls that come from deriving clauses
1413 -- we want to print out the full source code if there's an error
1414 -- because otherwise the user won't see the code at all
1415 add_meth_ctxt thing
1416 | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
1417 | otherwise = thing
1418
1419 tcMethodBodyHelp :: HsSigFun -> Id -> TcId
1420 -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId)
1421 tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
1422 | Just hs_sig_ty <- hs_sig_fn sel_name
1423 -- There is a signature in the instance
1424 -- See Note [Instance method signatures]
1425 = do { let ctxt = FunSigCtxt sel_name True
1426 ; (sig_ty, hs_wrap)
1427 <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
1428 do { inst_sigs <- xoptM LangExt.InstanceSigs
1429 ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
1430 ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty
1431 ; let local_meth_ty = idType local_meth_id
1432 ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $
1433 tcSubType_NC ctxt sig_ty local_meth_ty
1434 ; return (sig_ty, hs_wrap) }
1435
1436 ; inner_meth_name <- newName (nameOccName sel_name)
1437 ; let inner_meth_id = mkLocalId inner_meth_name sig_ty
1438 inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
1439 , sig_ctxt = ctxt
1440 , sig_loc = getLoc (hsSigType hs_sig_ty) }
1441
1442
1443 ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
1444
1445 ; let export = ABE { abe_ext = noExt
1446 , abe_poly = local_meth_id
1447 , abe_mono = inner_id
1448 , abe_wrap = hs_wrap
1449 , abe_prags = noSpecPrags }
1450
1451 ; return (unitBag $ L (getLoc meth_bind) $
1452 AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []
1453 , abs_exports = [export]
1454 , abs_binds = tc_bind, abs_ev_binds = []
1455 , abs_sig = True }) }
1456
1457 | otherwise -- No instance signature
1458 = do { let ctxt = FunSigCtxt sel_name False
1459 -- False <=> don't report redundant constraints
1460 -- The signature is not under the users control!
1461 tc_sig = completeSigFromId ctxt local_meth_id
1462 -- Absent a type sig, there are no new scoped type variables here
1463 -- Only the ones from the instance decl itself, which are already
1464 -- in scope. Example:
1465 -- class C a where { op :: forall b. Eq b => ... }
1466 -- instance C [c] where { op = <rhs> }
1467 -- In <rhs>, 'c' is scope but 'b' is not!
1468
1469 ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
1470 ; return tc_bind }
1471
1472 where
1473 sel_name = idName sel_id
1474 no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
1475 -- they are all for meth_id
1476
1477
1478 ------------------------
1479 mkMethIds :: Class -> [TcTyVar] -> [EvVar]
1480 -> [TcType] -> Id -> TcM (TcId, TcId)
1481 -- returns (poly_id, local_id), but ignoring any instance signature
1482 -- See Note [Instance method signatures]
1483 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1484 = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ)
1485 ; local_meth_name <- newName sel_occ
1486 -- Base the local_meth_name on the selector name, because
1487 -- type errors from tcMethodBody come from here
1488 ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty
1489 local_meth_id = mkLocalId local_meth_name local_meth_ty
1490
1491 ; return (poly_meth_id, local_meth_id) }
1492 where
1493 sel_name = idName sel_id
1494 sel_occ = nameOccName sel_name
1495 local_meth_ty = instantiateMethod clas sel_id inst_tys
1496 poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty
1497 theta = map idType dfun_ev_vars
1498
1499 methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1500 methSigCtxt sel_name sig_ty meth_ty env0
1501 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty
1502 ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
1503 ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))
1504 2 (vcat [ text "is more general than its signature in the class"
1505 , text "Instance sig:" <+> ppr sig_ty
1506 , text " Class sig:" <+> ppr meth_ty ])
1507 ; return (env2, msg) }
1508
1509 misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
1510 misplacedInstSig name hs_ty
1511 = vcat [ hang (text "Illegal type signature in instance declaration:")
1512 2 (hang (pprPrefixName name)
1513 2 (dcolon <+> ppr hs_ty))
1514 , text "(Use InstanceSigs to allow this)" ]
1515
1516 {- Note [Instance method signatures]
1517 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1518 With -XInstanceSigs we allow the user to supply a signature for the
1519 method in an instance declaration. Here is an artificial example:
1520
1521 data T a = MkT a
1522 instance Ord a => Ord (T a) where
1523 (>) :: forall b. b -> b -> Bool
1524 (>) = error "You can't compare Ts"
1525
1526 The instance signature can be *more* polymorphic than the instantiated
1527 class method (in this case: Age -> Age -> Bool), but it cannot be less
1528 polymorphic. Moreover, if a signature is given, the implementation
1529 code should match the signature, and type variables bound in the
1530 singature should scope over the method body.
1531
1532 We achieve this by building a TcSigInfo for the method, whether or not
1533 there is an instance method signature, and using that to typecheck
1534 the declaration (in tcMethodBody). That means, conveniently,
1535 that the type variables bound in the signature will scope over the body.
1536
1537 What about the check that the instance method signature is more
1538 polymorphic than the instantiated class method type? We just do a
1539 tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like
1540 this (for the example above
1541
1542 AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]
1543 , abs_exports
1544 = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool
1545 , gr_lcl :: T a -> T a -> Bool }
1546 , abs_binds
1547 = AbsBind { abs_tvs = [], abs_ev_vars = []
1548 , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool
1549 , gr_inner :: forall b. b -> b -> Bool }
1550 , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []
1551 , ..etc.. }
1552 } }
1553
1554 Wow! Three nested AbsBinds!
1555 * The outer one abstracts over the tyvars and dicts for the instance
1556 * The middle one is only present if there is an instance signature,
1557 and does the impedance matching for that signature
1558 * The inner one is for the method binding itself against either the
1559 signature from the class, or the instance signature.
1560 -}
1561
1562 ----------------------
1563 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
1564 -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
1565 -- There are two sources:
1566 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1567 -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
1568 -- These ones have the dfun inside, but [perhaps surprisingly]
1569 -- the correct wrapper.
1570 -- See Note [Handling SPECIALISE pragmas] in TcBinds
1571 mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
1572 = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
1573 where
1574 spec_prags_from_inst
1575 | isInlinePragma (idInlinePragma meth_id)
1576 = [] -- Do not inherit SPECIALISE from the instance if the
1577 -- method is marked INLINE, because then it'll be inlined
1578 -- and the specialisation would do nothing. (Indeed it'll provoke
1579 -- a warning from the desugarer
1580 | otherwise
1581 = [ L inst_loc (SpecPrag meth_id wrap inl)
1582 | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
1583
1584
1585 mkDefMethBind :: Class -> [Type] -> Id -> Name
1586 -> TcM (LHsBind GhcRn, [LSig GhcRn])
1587 -- The is a default method (vanailla or generic) defined in the class
1588 -- So make a binding op = $dmop @t1 @t2
1589 -- where $dmop is the name of the default method in the class,
1590 -- and t1,t2 are the instance types.
1591 -- See Note [Default methods in instances] for why we use
1592 -- visible type application here
1593 mkDefMethBind clas inst_tys sel_id dm_name
1594 = do { dflags <- getDynFlags
1595 ; dm_id <- tcLookupId dm_name
1596 ; let inline_prag = idInlinePragma dm_id
1597 inline_prags | isAnyInlinePragma inline_prag
1598 = [noLoc (InlineSig noExt fn inline_prag)]
1599 | otherwise
1600 = []
1601 -- Copy the inline pragma (if any) from the default method
1602 -- to this version. Note [INLINE and default methods]
1603
1604 fn = noLoc (idName sel_id)
1605 visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
1606 , tyConBinderArgFlag tcb /= Inferred ]
1607 rhs = foldl mk_vta (nlHsVar dm_name) visible_inst_tys
1608 bind = noLoc $ mkTopFunBind Generated fn $
1609 [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
1610
1611 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
1612 (vcat [ppr clas <+> ppr inst_tys,
1613 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
1614
1615 ; return (bind, inline_prags) }
1616 where
1617 mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
1618 mk_vta fun ty = noLoc (HsAppType (mkEmptyWildCardBndrs $ nlHsParTy
1619 $ noLoc $ XHsType $ NHsCoreTy ty) fun)
1620 -- NB: use visible type application
1621 -- See Note [Default methods in instances]
1622
1623 ----------------------
1624 derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
1625 derivBindCtxt sel_id clas tys
1626 = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)
1627 , nest 2 (text "in a derived instance for"
1628 <+> quotes (pprClassPred clas tys) <> colon)
1629 , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]
1630
1631 warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
1632 warnUnsatisfiedMinimalDefinition mindef
1633 = do { warn <- woptM Opt_WarnMissingMethods
1634 ; warnTc (Reason Opt_WarnMissingMethods) warn message
1635 }
1636 where
1637 message = vcat [text "No explicit implementation for"
1638 ,nest 2 $ pprBooleanFormulaNice mindef
1639 ]
1640
1641 {-
1642 Note [Export helper functions]
1643 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1644 We arrange to export the "helper functions" of an instance declaration,
1645 so that they are not subject to preInlineUnconditionally, even if their
1646 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1647 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1648 non-variable for them.
1649
1650 We could change this by making DFunUnfoldings have CoreExprs, but it
1651 seems a bit simpler this way.
1652
1653 Note [Default methods in instances]
1654 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1655 Consider this
1656
1657 class Baz v x where
1658 foo :: x -> x
1659 foo y = <blah>
1660
1661 instance Baz Int Int
1662
1663 From the class decl we get
1664
1665 $dmfoo :: forall v x. Baz v x => x -> x
1666 $dmfoo y = <blah>
1667
1668 Notice that the type is ambiguous. So we use Visible Type Application
1669 to disambiguate:
1670
1671 $dBazIntInt = MkBaz fooIntInt
1672 fooIntInt = $dmfoo @Int @Int
1673
1674 Lacking VTA we'd get ambiguity errors involving the default method. This applies
1675 equally to vanilla default methods (Trac #1061) and generic default methods
1676 (Trac #12220).
1677
1678 Historical note: before we had VTA we had to generate
1679 post-type-checked code, which took a lot more code, and didn't work for
1680 generic default methods.
1681
1682 Note [INLINE and default methods]
1683 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1684 Default methods need special case. They are supposed to behave rather like
1685 macros. For example
1686
1687 class Foo a where
1688 op1, op2 :: Bool -> a -> a
1689
1690 {-# INLINE op1 #-}
1691 op1 b x = op2 (not b) x
1692
1693 instance Foo Int where
1694 -- op1 via default method
1695 op2 b x = <blah>
1696
1697 The instance declaration should behave
1698
1699 just as if 'op1' had been defined with the
1700 code, and INLINE pragma, from its original
1701 definition.
1702
1703 That is, just as if you'd written
1704
1705 instance Foo Int where
1706 op2 b x = <blah>
1707
1708 {-# INLINE op1 #-}
1709 op1 b x = op2 (not b) x
1710
1711 So for the above example we generate:
1712
1713 {-# INLINE $dmop1 #-}
1714 -- $dmop1 has an InlineCompulsory unfolding
1715 $dmop1 d b x = op2 d (not b) x
1716
1717 $fFooInt = MkD $cop1 $cop2
1718
1719 {-# INLINE $cop1 #-}
1720 $cop1 = $dmop1 $fFooInt
1721
1722 $cop2 = <blah>
1723
1724 Note carefully:
1725
1726 * We *copy* any INLINE pragma from the default method $dmop1 to the
1727 instance $cop1. Otherwise we'll just inline the former in the
1728 latter and stop, which isn't what the user expected
1729
1730 * Regardless of its pragma, we give the default method an
1731 unfolding with an InlineCompulsory source. That means
1732 that it'll be inlined at every use site, notably in
1733 each instance declaration, such as $cop1. This inlining
1734 must happen even though
1735 a) $dmop1 is not saturated in $cop1
1736 b) $cop1 itself has an INLINE pragma
1737
1738 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1739 recursion between $fooInt and $cop1 to be broken
1740
1741 * To communicate the need for an InlineCompulsory to the desugarer
1742 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1743 in TcSpecPrags.
1744
1745
1746 ************************************************************************
1747 * *
1748 Specialise instance pragmas
1749 * *
1750 ************************************************************************
1751
1752 Note [SPECIALISE instance pragmas]
1753 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1754 Consider
1755
1756 instance (Ix a, Ix b) => Ix (a,b) where
1757 {-# SPECIALISE instance Ix (Int,Int) #-}
1758 range (x,y) = ...
1759
1760 We make a specialised version of the dictionary function, AND
1761 specialised versions of each *method*. Thus we should generate
1762 something like this:
1763
1764 $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
1765 {-# DFUN [$crangePair, ...] #-}
1766 {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
1767 $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
1768
1769 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
1770 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
1771 $crange da db = <blah>
1772
1773 The SPECIALISE pragmas are acted upon by the desugarer, which generate
1774
1775 dii :: Ix Int
1776 dii = ...
1777
1778 $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
1779 {-# DFUN [$crangePair di di, ...] #-}
1780 $s$dfIxPair = Ix ($crangePair di di) (...)
1781
1782 {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
1783
1784 $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
1785 $c$crangePair = ...specialised RHS of $crangePair...
1786
1787 {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
1788
1789 Note that
1790
1791 * The specialised dictionary $s$dfIxPair is very much needed, in case we
1792 call a function that takes a dictionary, but in a context where the
1793 specialised dictionary can be used. See Trac #7797.
1794
1795 * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
1796 it still has a DFunUnfolding. See Note [ClassOp/DFun selection]
1797
1798 * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
1799 --> {ClassOp rule for range} $crangePair Int Int d1 d2
1800 --> {SPEC rule for $crangePair} $s$crangePair
1801 or thus:
1802 --> {SPEC rule for $dfIxPair} range $s$dfIxPair
1803 --> {ClassOpRule for range} $s$crangePair
1804 It doesn't matter which way.
1805
1806 * We want to specialise the RHS of both $dfIxPair and $crangePair,
1807 but the SAME HsWrapper will do for both! We can call tcSpecPrag
1808 just once, and pass the result (in spec_inst_info) to tcMethods.
1809 -}
1810
1811 tcSpecInstPrags :: DFunId -> InstBindings GhcRn
1812 -> TcM ([Located TcSpecPrag], TcPragEnv)
1813 tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
1814 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
1815 filter isSpecInstLSig uprags
1816 -- The filter removes the pragmas for methods
1817 ; return (spec_inst_prags, mkPragEnv uprags binds) }
1818
1819 ------------------------------
1820 tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
1821 tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
1822 = addErrCtxt (spec_ctxt prag) $
1823 do { (tyvars, theta, clas, tys) <- tcHsClsInstType SpecInstCtxt hs_ty
1824 ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys
1825 ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
1826 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
1827 where
1828 spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
1829
1830 tcSpecInst _ _ = panic "tcSpecInst"
1831
1832 {-
1833 ************************************************************************
1834 * *
1835 \subsection{Error messages}
1836 * *
1837 ************************************************************************
1838 -}
1839
1840 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
1841 instDeclCtxt1 hs_inst_ty
1842 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
1843
1844 instDeclCtxt2 :: Type -> SDoc
1845 instDeclCtxt2 dfun_ty
1846 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1847 where
1848 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
1849
1850 inst_decl_ctxt :: SDoc -> SDoc
1851 inst_decl_ctxt doc = hang (text "In the instance declaration for")
1852 2 (quotes doc)
1853
1854 badBootFamInstDeclErr :: SDoc
1855 badBootFamInstDeclErr
1856 = text "Illegal family instance in hs-boot file"
1857
1858 notFamily :: TyCon -> SDoc
1859 notFamily tycon
1860 = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
1861 , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]
1862
1863 tooFewParmsErr :: Arity -> SDoc
1864 tooFewParmsErr arity
1865 = text "Family instance has too few parameters; expected" <+>
1866 ppr arity
1867
1868 assocInClassErr :: Located Name -> SDoc
1869 assocInClassErr name
1870 = text "Associated type" <+> quotes (ppr name) <+>
1871 text "must be inside a class instance"
1872
1873 badFamInstDecl :: Located Name -> SDoc
1874 badFamInstDecl tc_name
1875 = vcat [ text "Illegal family instance for" <+>
1876 quotes (ppr tc_name)
1877 , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]
1878
1879 notOpenFamily :: TyCon -> SDoc
1880 notOpenFamily tc
1881 = text "Illegal instance for closed family" <+> quotes (ppr tc)