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