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