ghc-cabal: Use fromFlagOrDefault instead of fromFlag
[ghc.git] / compiler / typecheck / TcInstDcls.hs
1 {-
2 (c) The University of Glasgow 2006
3 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
5
6 TcInstDecls: Typechecking instance declarations
7 -}
8
9 {-# LANGUAGE CPP #-}
10 {-# LANGUAGE FlexibleContexts #-}
11 {-# LANGUAGE TypeFamilies #-}
12
13 module TcInstDcls ( tcInstDecls1, tcInstDeclsDeriv, tcInstDecls2 ) where
14
15 #include "HsVersions.h"
16
17 import GhcPrelude
18
19 import HsSyn
20 import TcBinds
21 import TcTyClsDecls
22 import TcTyDecls ( addTyConsToGblEnv )
23 import TcClassDcl( tcClassDecl2, tcATDefault,
24 HsSigFun, mkHsSigFun, 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_clauses = preds
750 , di_ctxt = tcMkDataFamInstCtxt decl }
751
752 ; fam_inst <- newFamInst (DataFamilyInst rep_tc) axiom
753 ; return (fam_inst, m_deriv_info) }
754 where
755 eta_reduce :: TyCon -> [Type] -> ([Type], [TyConBinder])
756 -- See Note [Eta reduction for data families] in FamInstEnv
757 -- Splits the incoming patterns into two: the [TyVar]
758 -- are the patterns that can be eta-reduced away.
759 -- e.g. T [a] Int a d c ==> (T [a] Int a, [d,c])
760 --
761 -- NB: quadratic algorithm, but types are small here
762 eta_reduce fam_tc pats
763 = go (reverse (zip3 pats fvs_s vis_s)) []
764 where
765 vis_s :: [TyConBndrVis]
766 vis_s = tcbVisibilities fam_tc pats
767
768 fvs_s :: [TyCoVarSet] -- 1-1 correspondence with pats
769 -- Each elt is the free vars of all /earlier/ pats
770 (_, fvs_s) = mapAccumL add_fvs emptyVarSet pats
771 add_fvs fvs pat = (fvs `unionVarSet` tyCoVarsOfType pat, fvs)
772
773 go ((pat, fvs_to_the_left, tcb_vis):pats) etad_tvs
774 | Just tv <- getTyVar_maybe pat
775 , not (tv `elemVarSet` fvs_to_the_left)
776 = go pats (Bndr tv tcb_vis : etad_tvs)
777 go pats etad_tvs = (reverse (map fstOf3 pats), etad_tvs)
778
779 tcDataFamInstDecl _ _ = panic "tcDataFamInstDecl"
780
781 -----------------------
782 tcDataFamInstHeader
783 :: AssocInstInfo -> TyCon -> [Name] -> Maybe [LHsTyVarBndr GhcRn]
784 -> LexicalFixity -> LHsContext GhcRn
785 -> HsTyPats GhcRn -> Maybe (LHsKind GhcRn) -> [LConDecl GhcRn]
786 -> NewOrData
787 -> TcM ([TyVar], [Type], Kind, ThetaType)
788 -- The "header" of a data family instance is the part other than
789 -- the data constructors themselves
790 -- e.g. data instance D [a] :: * -> * where ...
791 -- Here the "header" is the bit before the "where"
792 tcDataFamInstHeader mb_clsinfo fam_tc imp_vars mb_bndrs fixity
793 hs_ctxt hs_pats m_ksig hs_cons new_or_data
794 = do { (imp_tvs, (exp_tvs, (stupid_theta, lhs_ty)))
795 <- pushTcLevelM_ $
796 solveEqualities $
797 bindImplicitTKBndrs_Q_Skol imp_vars $
798 bindExplicitTKBndrs_Q_Skol AnyKind exp_bndrs $
799 do { stupid_theta <- tcHsContext hs_ctxt
800 ; (lhs_ty, lhs_kind) <- tcFamTyPats fam_tc hs_pats
801
802 -- Ensure that the instance is consistent
803 -- with its parent class
804 ; addConsistencyConstraints mb_clsinfo lhs_ty
805
806 -- Add constraints from the result signature
807 ; res_kind <- tc_kind_sig m_ksig
808
809 -- Add constraints from the data constructors
810 ; kcConDecls new_or_data res_kind hs_cons
811
812 ; lhs_ty <- checkExpectedKind_pp pp_lhs lhs_ty lhs_kind res_kind
813 ; return (stupid_theta, lhs_ty) }
814
815 -- See TcTyClsDecls Note [Generalising in tcFamTyPatsGuts]
816 -- This code (and the stuff immediately above) is very similar
817 -- to that in tcTyFamInstEqnGuts. Maybe we should abstract the
818 -- common code; but for the moment I concluded that it's
819 -- clearer to duplicate it. Still, if you fix a bug here,
820 -- check there too!
821 ; let scoped_tvs = imp_tvs ++ exp_tvs
822 ; dvs <- candidateQTyVarsOfTypes (lhs_ty : mkTyVarTys scoped_tvs)
823 ; qtvs <- quantifyTyVars emptyVarSet dvs
824
825 -- Zonk the patterns etc into the Type world
826 ; (ze, qtvs) <- zonkTyBndrs qtvs
827 -- See Note [Unifying data family kinds] about the discardCast
828 ; lhs_ty <- zonkTcTypeToTypeX ze (discardCast lhs_ty)
829 ; stupid_theta <- zonkTcTypesToTypesX ze stupid_theta
830
831 -- Check that type patterns match the class instance head
832 -- The call to splitTyConApp_maybe here is just an inlining of
833 -- the body of unravelFamInstPats.
834 ; pats <- case splitTyConApp_maybe lhs_ty of
835 Just (_, pats) -> pure pats
836 Nothing -> pprPanic "tcDataFamInstHeader" (ppr lhs_ty)
837 ; return (qtvs, pats, typeKind lhs_ty, stupid_theta) }
838 -- See Note [Unifying data family kinds] about why we need typeKind here
839 where
840 fam_name = tyConName fam_tc
841 data_ctxt = DataKindCtxt fam_name
842 pp_lhs = pprHsFamInstLHS fam_name mb_bndrs hs_pats fixity hs_ctxt
843 exp_bndrs = mb_bndrs `orElse` []
844
845 -- See Note [Implementation of UnliftedNewtypes] in TcTyClsDecls, wrinkle (2).
846 tc_kind_sig Nothing
847 = do { unlifted_newtypes <- xoptM LangExt.UnliftedNewtypes
848 ; if unlifted_newtypes && new_or_data == NewType
849 then newOpenTypeKind
850 else pure liftedTypeKind
851 }
852
853 -- See Note [Result kind signature for a data family instance]
854 tc_kind_sig (Just hs_kind)
855 = do { sig_kind <- tcLHsKindSig data_ctxt hs_kind
856 ; let (tvs, inner_kind) = tcSplitForAllTys sig_kind
857 ; lvl <- getTcLevel
858 ; (subst, _tvs') <- tcInstSkolTyVarsAt lvl False emptyTCvSubst tvs
859 -- Perhaps surprisingly, we don't need the skolemised tvs themselves
860 ; return (substTy subst inner_kind) }
861
862 {- Note [Result kind signature for a data family instance]
863 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
864 The expected type might have a forall at the type. Normally, we
865 can't skolemise in kinds because we don't have type-level lambda.
866 But here, we're at the top-level of an instance declaration, so
867 we actually have a place to put the regeneralised variables.
868 Thus: skolemise away. cf. Inst.deeplySkolemise and TcUnify.tcSkolemise
869 Examples in indexed-types/should_compile/T12369
870
871 Note [Unifying data family kinds]
872 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
873 When we kind-check a newtype instance with -XUnliftedNewtypes, we must
874 unify the kind of the data family with any declared kind in the instance
875 declaration. For example:
876
877 data Color = Red | Blue
878 type family Interpret (x :: Color) :: RuntimeRep where
879 Interpret 'Red = 'IntRep
880 Interpret 'Blue = 'WordRep
881 data family Foo (x :: Color) :: TYPE (Interpret x)
882 newtype instance Foo 'Red :: TYPE IntRep where
883 FooRedC :: Int# -> Foo 'Red
884
885 We end up unifying `TYPE (Interpret 'Red)` (the kind of Foo, instantiated
886 with 'Red) and `TYPE IntRep` (the declared kind of the instance). This
887 unification succeeds, resulting in a coercion. The big question: what to
888 do with this coercion? Answer: nothing! A kind annotation on a newtype instance
889 is always redundant (except, perhaps, in that it helps guide unification). We
890 have a definitive kind for the data family from the data family declaration,
891 and so we learn nothing really new from the kind signature on an instance.
892 We still must perform this unification (done in the call to checkExpectedKind
893 toward the beginning of tcDataFamInstHeader), but the result is unhelpful. If there
894 is a cast, it will wrap the lhs_ty, and so we just drop it before splitting the
895 lhs_ty to reveal the underlying patterns. Because of the potential of dropping
896 a cast like this, we just use typeKind in the result instead of propagating res_kind
897 from above.
898
899 This Note is wrinkle (3) in Note [Implementation of UnliftedNewtypes] in TcTyClsDecls.
900
901 Note [Eta-reduction for data families]
902 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
903 Consider
904 data D :: * -> * -> * -> * -> *
905
906 data instance D [(a,b)] p q :: * -> * where
907 D1 :: blah1
908 D2 :: blah2
909
910 Then we'll generate a representation data type
911 data Drep a b p q z where
912 D1 :: blah1
913 D2 :: blah2
914
915 and an axiom to connect them
916 axiom AxDrep forall a b p q z. D [(a,b]] p q z = Drep a b p q z
917
918 except that we'll eta-reduce the axiom to
919 axiom AxDrep forall a b. D [(a,b]] = Drep a b
920 There are several fiddly subtleties lurking here
921
922 * The representation tycon Drep is parameerised over the free
923 variables of the pattern, in no particular order. So there is no
924 guarantee that 'p' and 'q' will come last in Drep's parameters, and
925 in the right order. So, if the /patterns/ of the family insatance
926 are eta-redcible, we re-order Drep's parameters to put the
927 eta-reduced type variables last.
928
929 * Although we eta-reduce the axiom, we eta-/expand/ the representation
930 tycon Drep. The kind of D says it takses four arguments, but the
931 data instance header only supplies three. But the AlgTyCOn for Drep
932 itself must have enough TyConBinders so that its result kind is Type.
933 So, with etaExpandAlgTyCon we make up some extra TyConBinders
934
935 * The result kind in the instance might be a polykind, like this:
936 data family DP a :: forall k. k -> *
937 data instance DP [b] :: forall k1 k2. (k1,k2) -> *
938
939 So in type-checking the LHS (DP Int) we need to check that it is
940 more polymorphic than the signature. To do that we must skolemise
941 the siganture and istantiate the call of DP. So we end up with
942 data instance DP [b] @(k1,k2) (z :: (k1,k2)) where
943
944 Note that we must parameterise the representation tycon DPrep over
945 'k1' and 'k2', as well as 'b'.
946
947 The skolemise bit is done in tc_kind_sig, while the instantiate bit
948 is done by tcFamTyPats.
949
950 * Very fiddly point. When we eta-reduce to
951 axiom AxDrep forall a b. D [(a,b]] = Drep a b
952
953 we want the kind of (D [(a,b)]) to be the same as the kind of
954 (Drep a b). This ensures that applying the axiom doesn't change the
955 kind. Why is that hard? Because the kind of (Drep a b) depends on
956 the TyConBndrVis on Drep's arguments. In particular do we have
957 (forall (k::*). blah) or (* -> blah)?
958
959 We must match whatever D does! In #15817 we had
960 data family X a :: forall k. * -> * -- Note: a forall that is not used
961 data instance X Int b = MkX
962
963 So the data instance is really
964 data istance X Int @k b = MkX
965
966 The axiom will look like
967 axiom X Int = Xrep
968
969 and it's important that XRep :: forall k * -> *, following X.
970
971 To achieve this we get the TyConBndrVis flags from tcbVisibilities,
972 and use those flags for any eta-reduced arguments. Sigh.
973
974 * The final turn of the knife is that tcbVisibilities is itself
975 tricky to sort out. Consider
976 data family D k :: k
977 Then consider D (forall k2. k2 -> k2) Type Type
978 The visibilty flags on an application of D may affected by the arguments
979 themselves. Heavy sigh. But not truly hard; that's what tcbVisibilities
980 does.
981
982 -}
983
984
985 {- *********************************************************************
986 * *
987 Class instance declarations, pass 2
988 * *
989 ********************************************************************* -}
990
991 tcInstDecls2 :: [LTyClDecl GhcRn] -> [InstInfo GhcRn]
992 -> TcM (LHsBinds GhcTc)
993 -- (a) From each class declaration,
994 -- generate any default-method bindings
995 -- (b) From each instance decl
996 -- generate the dfun binding
997
998 tcInstDecls2 tycl_decls inst_decls
999 = do { -- (a) Default methods from class decls
1000 let class_decls = filter (isClassDecl . unLoc) tycl_decls
1001 ; dm_binds_s <- mapM tcClassDecl2 class_decls
1002 ; let dm_binds = unionManyBags dm_binds_s
1003
1004 -- (b) instance declarations
1005 ; let dm_ids = collectHsBindsBinders dm_binds
1006 -- Add the default method Ids (again)
1007 -- (they were arready added in TcTyDecls.tcAddImplicits)
1008 -- See Note [Default methods in the type environment]
1009 ; inst_binds_s <- tcExtendGlobalValEnv dm_ids $
1010 mapM tcInstDecl2 inst_decls
1011
1012 -- Done
1013 ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
1014
1015 {- Note [Default methods in the type environment]
1016 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1017 The default method Ids are already in the type environment (see Note
1018 [Default method Ids and Template Haskell] in TcTyDcls), BUT they
1019 don't have their InlinePragmas yet. Usually that would not matter,
1020 because the simplifier propagates information from binding site to
1021 use. But, unusually, when compiling instance decls we *copy* the
1022 INLINE pragma from the default method to the method for that
1023 particular operation (see Note [INLINE and default methods] below).
1024
1025 So right here in tcInstDecls2 we must re-extend the type envt with
1026 the default method Ids replete with their INLINE pragmas. Urk.
1027 -}
1028
1029 tcInstDecl2 :: InstInfo GhcRn -> TcM (LHsBinds GhcTc)
1030 -- Returns a binding for the dfun
1031 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
1032 = recoverM (return emptyLHsBinds) $
1033 setSrcSpan loc $
1034 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
1035 do { -- Instantiate the instance decl with skolem constants
1036 ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType dfun_id
1037 ; dfun_ev_vars <- newEvVars dfun_theta
1038 -- We instantiate the dfun_id with superSkolems.
1039 -- See Note [Subtle interaction of recursion and overlap]
1040 -- and Note [Binding when looking up instances]
1041
1042 ; let (clas, inst_tys) = tcSplitDFunHead inst_head
1043 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
1044 sc_theta' = substTheta (zipTvSubst class_tyvars inst_tys) sc_theta
1045
1046 ; traceTc "tcInstDecl2" (vcat [ppr inst_tyvars, ppr inst_tys, ppr dfun_theta, ppr sc_theta'])
1047
1048 -- Deal with 'SPECIALISE instance' pragmas
1049 -- See Note [SPECIALISE instance pragmas]
1050 ; spec_inst_info@(spec_inst_prags,_) <- tcSpecInstPrags dfun_id ibinds
1051
1052 -- Typecheck superclasses and methods
1053 -- See Note [Typechecking plan for instance declarations]
1054 ; dfun_ev_binds_var <- newTcEvBinds
1055 ; let dfun_ev_binds = TcEvBinds dfun_ev_binds_var
1056 ; (tclvl, (sc_meth_ids, sc_meth_binds, sc_meth_implics))
1057 <- pushTcLevelM $
1058 do { (sc_ids, sc_binds, sc_implics)
1059 <- tcSuperClasses dfun_id clas inst_tyvars dfun_ev_vars
1060 inst_tys dfun_ev_binds
1061 sc_theta'
1062
1063 -- Typecheck the methods
1064 ; (meth_ids, meth_binds, meth_implics)
1065 <- tcMethods dfun_id clas inst_tyvars dfun_ev_vars
1066 inst_tys dfun_ev_binds spec_inst_info
1067 op_items ibinds
1068
1069 ; return ( sc_ids ++ meth_ids
1070 , sc_binds `unionBags` meth_binds
1071 , sc_implics `unionBags` meth_implics ) }
1072
1073 ; imp <- newImplication
1074 ; emitImplication $
1075 imp { ic_tclvl = tclvl
1076 , ic_skols = inst_tyvars
1077 , ic_given = dfun_ev_vars
1078 , ic_wanted = mkImplicWC sc_meth_implics
1079 , ic_binds = dfun_ev_binds_var
1080 , ic_info = InstSkol }
1081
1082 -- Create the result bindings
1083 ; self_dict <- newDict clas inst_tys
1084 ; let class_tc = classTyCon clas
1085 [dict_constr] = tyConDataCons class_tc
1086 dict_bind = mkVarBind self_dict (L loc con_app_args)
1087
1088 -- We don't produce a binding for the dict_constr; instead we
1089 -- rely on the simplifier to unfold this saturated application
1090 -- We do this rather than generate an HsCon directly, because
1091 -- it means that the special cases (e.g. dictionary with only one
1092 -- member) are dealt with by the common MkId.mkDataConWrapId
1093 -- code rather than needing to be repeated here.
1094 -- con_app_tys = MkD ty1 ty2
1095 -- con_app_scs = MkD ty1 ty2 sc1 sc2
1096 -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2
1097 con_app_tys = mkHsWrap (mkWpTyApps inst_tys)
1098 (HsConLikeOut noExtField (RealDataCon dict_constr))
1099 -- NB: We *can* have covars in inst_tys, in the case of
1100 -- promoted GADT constructors.
1101
1102 con_app_args = foldl' app_to_meth con_app_tys sc_meth_ids
1103
1104 app_to_meth :: HsExpr GhcTc -> Id -> HsExpr GhcTc
1105 app_to_meth fun meth_id = HsApp noExtField (L loc fun)
1106 (L loc (wrapId arg_wrapper meth_id))
1107
1108 inst_tv_tys = mkTyVarTys inst_tyvars
1109 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys
1110
1111 is_newtype = isNewTyCon class_tc
1112 dfun_id_w_prags = addDFunPrags dfun_id sc_meth_ids
1113 dfun_spec_prags
1114 | is_newtype = SpecPrags []
1115 | otherwise = SpecPrags spec_inst_prags
1116 -- Newtype dfuns just inline unconditionally,
1117 -- so don't attempt to specialise them
1118
1119 export = ABE { abe_ext = noExtField
1120 , abe_wrap = idHsWrapper
1121 , abe_poly = dfun_id_w_prags
1122 , abe_mono = self_dict
1123 , abe_prags = dfun_spec_prags }
1124 -- NB: see Note [SPECIALISE instance pragmas]
1125 main_bind = AbsBinds { abs_ext = noExtField
1126 , abs_tvs = inst_tyvars
1127 , abs_ev_vars = dfun_ev_vars
1128 , abs_exports = [export]
1129 , abs_ev_binds = []
1130 , abs_binds = unitBag dict_bind
1131 , abs_sig = True }
1132
1133 ; return (unitBag (L loc main_bind) `unionBags` sc_meth_binds)
1134 }
1135 where
1136 dfun_id = instanceDFunId ispec
1137 loc = getSrcSpan dfun_id
1138
1139 addDFunPrags :: DFunId -> [Id] -> DFunId
1140 -- DFuns need a special Unfolding and InlinePrag
1141 -- See Note [ClassOp/DFun selection]
1142 -- and Note [Single-method classes]
1143 -- It's easiest to create those unfoldings right here, where
1144 -- have all the pieces in hand, even though we are messing with
1145 -- Core at this point, which the typechecker doesn't usually do
1146 -- However we take care to build the unfolding using the TyVars from
1147 -- the DFunId rather than from the skolem pieces that the typechecker
1148 -- is messing with.
1149 addDFunPrags dfun_id sc_meth_ids
1150 | is_newtype
1151 = dfun_id `setIdUnfolding` mkInlineUnfoldingWithArity 0 con_app
1152 `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 }
1153 | otherwise
1154 = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_bndrs dict_con dict_args
1155 `setInlinePragma` dfunInlinePragma
1156 where
1157 con_app = mkLams dfun_bndrs $
1158 mkApps (Var (dataConWrapId dict_con)) dict_args
1159 -- mkApps is OK because of the checkForLevPoly call in checkValidClass
1160 -- See Note [Levity polymorphism checking] in DsMonad
1161 dict_args = map Type inst_tys ++
1162 [mkVarApps (Var id) dfun_bndrs | id <- sc_meth_ids]
1163
1164 (dfun_tvs, dfun_theta, clas, inst_tys) = tcSplitDFunTy (idType dfun_id)
1165 ev_ids = mkTemplateLocalsNum 1 dfun_theta
1166 dfun_bndrs = dfun_tvs ++ ev_ids
1167 clas_tc = classTyCon clas
1168 [dict_con] = tyConDataCons clas_tc
1169 is_newtype = isNewTyCon clas_tc
1170
1171 wrapId :: HsWrapper -> IdP (GhcPass id) -> HsExpr (GhcPass id)
1172 wrapId wrapper id = mkHsWrap wrapper (HsVar noExtField (noLoc id))
1173
1174 {- Note [Typechecking plan for instance declarations]
1175 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1176 For instance declarations we generate the following bindings and implication
1177 constraints. Example:
1178
1179 instance Ord a => Ord [a] where compare = <compare-rhs>
1180
1181 generates this:
1182
1183 Bindings:
1184 -- Method bindings
1185 $ccompare :: forall a. Ord a => a -> a -> Ordering
1186 $ccompare = /\a \(d:Ord a). let <meth-ev-binds> in ...
1187
1188 -- Superclass bindings
1189 $cp1Ord :: forall a. Ord a => Eq [a]
1190 $cp1Ord = /\a \(d:Ord a). let <sc-ev-binds>
1191 in dfEqList (dw :: Eq a)
1192
1193 Constraints:
1194 forall a. Ord a =>
1195 -- Method constraint
1196 (forall. (empty) => <constraints from compare-rhs>)
1197 -- Superclass constraint
1198 /\ (forall. (empty) => dw :: Eq a)
1199
1200 Notice that
1201
1202 * Per-meth/sc implication. There is one inner implication per
1203 superclass or method, with no skolem variables or givens. The only
1204 reason for this one is to gather the evidence bindings privately
1205 for this superclass or method. This implication is generated
1206 by checkInstConstraints.
1207
1208 * Overall instance implication. There is an overall enclosing
1209 implication for the whole instance declaration, with the expected
1210 skolems and givens. We need this to get the correct "redundant
1211 constraint" warnings, gathering all the uses from all the methods
1212 and superclasses. See TcSimplify Note [Tracking redundant
1213 constraints]
1214
1215 * The given constraints in the outer implication may generate
1216 evidence, notably by superclass selection. Since the method and
1217 superclass bindings are top-level, we want that evidence copied
1218 into *every* method or superclass definition. (Some of it will
1219 be usused in some, but dead-code elimination will drop it.)
1220
1221 We achieve this by putting the evidence variable for the overall
1222 instance implication into the AbsBinds for each method/superclass.
1223 Hence the 'dfun_ev_binds' passed into tcMethods and tcSuperClasses.
1224 (And that in turn is why the abs_ev_binds field of AbBinds is a
1225 [TcEvBinds] rather than simply TcEvBinds.
1226
1227 This is a bit of a hack, but works very nicely in practice.
1228
1229 * Note that if a method has a locally-polymorphic binding, there will
1230 be yet another implication for that, generated by tcPolyCheck
1231 in tcMethodBody. E.g.
1232 class C a where
1233 foo :: forall b. Ord b => blah
1234
1235
1236 ************************************************************************
1237 * *
1238 Type-checking superclasses
1239 * *
1240 ************************************************************************
1241 -}
1242
1243 tcSuperClasses :: DFunId -> Class -> [TcTyVar] -> [EvVar] -> [TcType]
1244 -> TcEvBinds
1245 -> TcThetaType
1246 -> TcM ([EvVar], LHsBinds GhcTc, Bag Implication)
1247 -- Make a new top-level function binding for each superclass,
1248 -- something like
1249 -- $Ordp1 :: forall a. Ord a => Eq [a]
1250 -- $Ordp1 = /\a \(d:Ord a). dfunEqList a (sc_sel d)
1251 --
1252 -- See Note [Recursive superclasses] for why this is so hard!
1253 -- In effect, we build a special-purpose solver for the first step
1254 -- of solving each superclass constraint
1255 tcSuperClasses dfun_id cls tyvars dfun_evs inst_tys dfun_ev_binds sc_theta
1256 = do { (ids, binds, implics) <- mapAndUnzip3M tc_super (zip sc_theta [fIRST_TAG..])
1257 ; return (ids, listToBag binds, listToBag implics) }
1258 where
1259 loc = getSrcSpan dfun_id
1260 size = sizeTypes inst_tys
1261 tc_super (sc_pred, n)
1262 = do { (sc_implic, ev_binds_var, sc_ev_tm)
1263 <- checkInstConstraints $ emitWanted (ScOrigin size) sc_pred
1264
1265 ; sc_top_name <- newName (mkSuperDictAuxOcc n (getOccName cls))
1266 ; sc_ev_id <- newEvVar sc_pred
1267 ; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id sc_ev_tm
1268 ; let sc_top_ty = mkInvForAllTys tyvars $
1269 mkPhiTy (map idType dfun_evs) sc_pred
1270 sc_top_id = mkLocalId sc_top_name sc_top_ty
1271 export = ABE { abe_ext = noExtField
1272 , abe_wrap = idHsWrapper
1273 , abe_poly = sc_top_id
1274 , abe_mono = sc_ev_id
1275 , abe_prags = noSpecPrags }
1276 local_ev_binds = TcEvBinds ev_binds_var
1277 bind = AbsBinds { abs_ext = noExtField
1278 , abs_tvs = tyvars
1279 , abs_ev_vars = dfun_evs
1280 , abs_exports = [export]
1281 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1282 , abs_binds = emptyBag
1283 , abs_sig = False }
1284 ; return (sc_top_id, L loc bind, sc_implic) }
1285
1286 -------------------
1287 checkInstConstraints :: TcM result
1288 -> TcM (Implication, EvBindsVar, result)
1289 -- See Note [Typechecking plan for instance declarations]
1290 checkInstConstraints thing_inside
1291 = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $
1292 thing_inside
1293
1294 ; ev_binds_var <- newTcEvBinds
1295 ; implic <- newImplication
1296 ; let implic' = implic { ic_tclvl = tclvl
1297 , ic_wanted = wanted
1298 , ic_binds = ev_binds_var
1299 , ic_info = InstSkol }
1300
1301 ; return (implic', ev_binds_var, result) }
1302
1303 {-
1304 Note [Recursive superclasses]
1305 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1306 See #3731, #4809, #5751, #5913, #6117, #6161, which all
1307 describe somewhat more complicated situations, but ones
1308 encountered in practice.
1309
1310 See also tests tcrun020, tcrun021, tcrun033, and #11427.
1311
1312 ----- THE PROBLEM --------
1313 The problem is that it is all too easy to create a class whose
1314 superclass is bottom when it should not be.
1315
1316 Consider the following (extreme) situation:
1317 class C a => D a where ...
1318 instance D [a] => D [a] where ... (dfunD)
1319 instance C [a] => C [a] where ... (dfunC)
1320 Although this looks wrong (assume D [a] to prove D [a]), it is only a
1321 more extreme case of what happens with recursive dictionaries, and it
1322 can, just about, make sense because the methods do some work before
1323 recursing.
1324
1325 To implement the dfunD we must generate code for the superclass C [a],
1326 which we had better not get by superclass selection from the supplied
1327 argument:
1328 dfunD :: forall a. D [a] -> D [a]
1329 dfunD = \d::D [a] -> MkD (scsel d) ..
1330
1331 Otherwise if we later encounter a situation where
1332 we have a [Wanted] dw::D [a] we might solve it thus:
1333 dw := dfunD dw
1334 Which is all fine except that now ** the superclass C is bottom **!
1335
1336 The instance we want is:
1337 dfunD :: forall a. D [a] -> D [a]
1338 dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
1339
1340 ----- THE SOLUTION --------
1341 The basic solution is simple: be very careful about using superclass
1342 selection to generate a superclass witness in a dictionary function
1343 definition. More precisely:
1344
1345 Superclass Invariant: in every class dictionary,
1346 every superclass dictionary field
1347 is non-bottom
1348
1349 To achieve the Superclass Invariant, in a dfun definition we can
1350 generate a guaranteed-non-bottom superclass witness from:
1351 (sc1) one of the dictionary arguments itself (all non-bottom)
1352 (sc2) an immediate superclass of a smaller dictionary
1353 (sc3) a call of a dfun (always returns a dictionary constructor)
1354
1355 The tricky case is (sc2). We proceed by induction on the size of
1356 the (type of) the dictionary, defined by TcValidity.sizeTypes.
1357 Let's suppose we are building a dictionary of size 3, and
1358 suppose the Superclass Invariant holds of smaller dictionaries.
1359 Then if we have a smaller dictionary, its immediate superclasses
1360 will be non-bottom by induction.
1361
1362 What does "we have a smaller dictionary" mean? It might be
1363 one of the arguments of the instance, or one of its superclasses.
1364 Here is an example, taken from CmmExpr:
1365 class Ord r => UserOfRegs r a where ...
1366 (i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where
1367 (i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
1368
1369 For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
1370 since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
1371
1372 But for (i2) that isn't the case, so we must add an explicit, and
1373 perhaps surprising, (Ord r) argument to the instance declaration.
1374
1375 Here's another example from #6161:
1376
1377 class Super a => Duper a where ...
1378 class Duper (Fam a) => Foo a where ...
1379 (i3) instance Foo a => Duper (Fam a) where ...
1380 (i4) instance Foo Float where ...
1381
1382 It would be horribly wrong to define
1383 dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3)
1384 dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
1385
1386 dfFooFloat :: Foo Float -- from (i4)
1387 dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
1388
1389 Now the Super superclass of Duper is definitely bottom!
1390
1391 This won't happen because when processing (i3) we can use the
1392 superclasses of (Foo a), which is smaller, namely Duper (Fam a). But
1393 that is *not* smaller than the target so we can't take *its*
1394 superclasses. As a result the program is rightly rejected, unless you
1395 add (Super (Fam a)) to the context of (i3).
1396
1397 Note [Solving superclass constraints]
1398 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1399 How do we ensure that every superclass witness is generated by
1400 one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].
1401 Answer:
1402
1403 * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)
1404 where 'size' is the size of the instance declaration. e.g.
1405 class C a => D a where...
1406 instance blah => D [a] where ...
1407 The wanted superclass constraint for C [a] has origin
1408 ScOrigin size, where size = size( D [a] ).
1409
1410 * (sc1) When we rewrite such a wanted constraint, it retains its
1411 origin. But if we apply an instance declaration, we can set the
1412 origin to (ScOrigin infinity), thus lifting any restrictions by
1413 making prohibitedSuperClassSolve return False.
1414
1415 * (sc2) ScOrigin wanted constraints can't be solved from a
1416 superclass selection, except at a smaller type. This test is
1417 implemented by TcInteract.prohibitedSuperClassSolve
1418
1419 * The "given" constraints of an instance decl have CtOrigin
1420 GivenOrigin InstSkol.
1421
1422 * When we make a superclass selection from InstSkol we use
1423 a SkolemInfo of (InstSC size), where 'size' is the size of
1424 the constraint whose superclass we are taking. A similarly
1425 when taking the superclass of an InstSC. This is implemented
1426 in TcCanonical.newSCWorkFromFlavored
1427
1428 Note [Silent superclass arguments] (historical interest only)
1429 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1430 NB1: this note describes our *old* solution to the
1431 recursive-superclass problem. I'm keeping the Note
1432 for now, just as institutional memory.
1433 However, the code for silent superclass arguments
1434 was removed in late Dec 2014
1435
1436 NB2: the silent-superclass solution introduced new problems
1437 of its own, in the form of instance overlap. Tests
1438 SilentParametersOverlapping, T5051, and T7862 are examples
1439
1440 NB3: the silent-superclass solution also generated tons of
1441 extra dictionaries. For example, in monad-transformer
1442 code, when constructing a Monad dictionary you had to pass
1443 an Applicative dictionary; and to construct that you neede
1444 a Functor dictionary. Yet these extra dictionaries were
1445 often never used. Test T3064 compiled *far* faster after
1446 silent superclasses were eliminated.
1447
1448 Our solution to this problem "silent superclass arguments". We pass
1449 to each dfun some ``silent superclass arguments’’, which are the
1450 immediate superclasses of the dictionary we are trying to
1451 construct. In our example:
1452 dfun :: forall a. C [a] -> D [a] -> D [a]
1453 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
1454 Notice the extra (dc :: C [a]) argument compared to the previous version.
1455
1456 This gives us:
1457
1458 -----------------------------------------------------------
1459 DFun Superclass Invariant
1460 ~~~~~~~~~~~~~~~~~~~~~~~~
1461 In the body of a DFun, every superclass argument to the
1462 returned dictionary is
1463 either * one of the arguments of the DFun,
1464 or * constant, bound at top level
1465 -----------------------------------------------------------
1466
1467 This net effect is that it is safe to treat a dfun application as
1468 wrapping a dictionary constructor around its arguments (in particular,
1469 a dfun never picks superclasses from the arguments under the
1470 dictionary constructor). No superclass is hidden inside a dfun
1471 application.
1472
1473 The extra arguments required to satisfy the DFun Superclass Invariant
1474 always come first, and are called the "silent" arguments. You can
1475 find out how many silent arguments there are using Id.dfunNSilent;
1476 and then you can just drop that number of arguments to see the ones
1477 that were in the original instance declaration.
1478
1479 DFun types are built (only) by MkId.mkDictFunId, so that is where we
1480 decide what silent arguments are to be added.
1481 -}
1482
1483 {-
1484 ************************************************************************
1485 * *
1486 Type-checking an instance method
1487 * *
1488 ************************************************************************
1489
1490 tcMethod
1491 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1492 - Remembering to use fresh Name (the instance method Name) as the binder
1493 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1494 - Use sig_fn mapping instance method Name -> instance tyvars
1495 - Ditto prag_fn
1496 - Use tcValBinds to do the checking
1497 -}
1498
1499 tcMethods :: DFunId -> Class
1500 -> [TcTyVar] -> [EvVar]
1501 -> [TcType]
1502 -> TcEvBinds
1503 -> ([Located TcSpecPrag], TcPragEnv)
1504 -> [ClassOpItem]
1505 -> InstBindings GhcRn
1506 -> TcM ([Id], LHsBinds GhcTc, Bag Implication)
1507 -- The returned inst_meth_ids all have types starting
1508 -- forall tvs. theta => ...
1509 tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1510 dfun_ev_binds (spec_inst_prags, prag_fn) op_items
1511 (InstBindings { ib_binds = binds
1512 , ib_tyvars = lexical_tvs
1513 , ib_pragmas = sigs
1514 , ib_extensions = exts
1515 , ib_derived = is_derived })
1516 = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $
1517 -- The lexical_tvs scope over the 'where' part
1518 do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
1519 ; checkMinimalDefinition
1520 ; checkMethBindMembership
1521 ; (ids, binds, mb_implics) <- set_exts exts $
1522 unset_warnings_deriving $
1523 mapAndUnzip3M tc_item op_items
1524 ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
1525 where
1526 set_exts :: [LangExt.Extension] -> TcM a -> TcM a
1527 set_exts es thing = foldr setXOptM thing es
1528
1529 -- See Note [Avoid -Winaccessible-code when deriving]
1530 unset_warnings_deriving :: TcM a -> TcM a
1531 unset_warnings_deriving
1532 | is_derived = unsetWOptM Opt_WarnInaccessibleCode
1533 | otherwise = id
1534
1535 hs_sig_fn = mkHsSigFun sigs
1536 inst_loc = getSrcSpan dfun_id
1537
1538 ----------------------
1539 tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
1540 tc_item (sel_id, dm_info)
1541 | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn
1542 = tcMethodBody clas tyvars dfun_ev_vars inst_tys
1543 dfun_ev_binds is_derived hs_sig_fn
1544 spec_inst_prags prags
1545 sel_id user_bind bndr_loc
1546 | otherwise
1547 = do { traceTc "tc_def" (ppr sel_id)
1548 ; tc_default sel_id dm_info }
1549
1550 ----------------------
1551 tc_default :: Id -> DefMethInfo
1552 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1553
1554 tc_default sel_id (Just (dm_name, _))
1555 = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name
1556 ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
1557 dfun_ev_binds is_derived hs_sig_fn
1558 spec_inst_prags inline_prags
1559 sel_id meth_bind inst_loc }
1560
1561 tc_default sel_id Nothing -- No default method at all
1562 = do { traceTc "tc_def: warn" (ppr sel_id)
1563 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
1564 inst_tys sel_id
1565 ; dflags <- getDynFlags
1566 ; let meth_bind = mkVarBind meth_id $
1567 mkLHsWrap lam_wrapper (error_rhs dflags)
1568 ; return (meth_id, meth_bind, Nothing) }
1569 where
1570 error_rhs dflags = L inst_loc $ HsApp noExtField error_fun (error_msg dflags)
1571 error_fun = L inst_loc $
1572 wrapId (mkWpTyApps
1573 [ getRuntimeRep meth_tau, meth_tau])
1574 nO_METHOD_BINDING_ERROR_ID
1575 error_msg dflags = L inst_loc (HsLit noExtField (HsStringPrim NoSourceText
1576 (unsafeMkByteString (error_string dflags))))
1577 meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys)
1578 error_string dflags = showSDoc dflags
1579 (hcat [ppr inst_loc, vbar, ppr sel_id ])
1580 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1581
1582 ----------------------
1583 -- Check if one of the minimal complete definitions is satisfied
1584 checkMinimalDefinition
1585 = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
1586 warnUnsatisfiedMinimalDefinition
1587
1588 methodExists meth = isJust (findMethodBind meth binds prag_fn)
1589
1590 ----------------------
1591 -- Check if any method bindings do not correspond to the class.
1592 -- See Note [Mismatched class methods and associated type families].
1593 checkMethBindMembership
1594 = mapM_ (addErrTc . badMethodErr clas) mismatched_meths
1595 where
1596 bind_nms = map unLoc $ collectMethodBinders binds
1597 cls_meth_nms = map (idName . fst) op_items
1598 mismatched_meths = bind_nms `minusList` cls_meth_nms
1599
1600 {-
1601 Note [Mismatched class methods and associated type families]
1602 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1603 It's entirely possible for someone to put methods or associated type family
1604 instances inside of a class in which it doesn't belong. For instance, we'd
1605 want to fail if someone wrote this:
1606
1607 instance Eq () where
1608 type Rep () = Maybe
1609 compare = undefined
1610
1611 Since neither the type family `Rep` nor the method `compare` belong to the
1612 class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,
1613 since that would discover that the parent class `Eq` is incorrect.
1614
1615 However, there is a scenario in which the renamer could fail to catch this:
1616 if the instance was generated through Template Haskell, as in #12387. In that
1617 case, Template Haskell will provide fully resolved names (e.g.,
1618 `GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
1619 on. For this reason, we also put an extra validity check for this in the
1620 typechecker as a last resort.
1621
1622 Note [Avoid -Winaccessible-code when deriving]
1623 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1624 -Winaccessible-code can be particularly noisy when deriving instances for
1625 GADTs. Consider the following example (adapted from #8128):
1626
1627 data T a where
1628 MkT1 :: Int -> T Int
1629 MkT2 :: T Bool
1630 MkT3 :: T Bool
1631 deriving instance Eq (T a)
1632 deriving instance Ord (T a)
1633
1634 In the derived Ord instance, GHC will generate the following code:
1635
1636 instance Ord (T a) where
1637 compare x y
1638 = case x of
1639 MkT2
1640 -> case y of
1641 MkT1 {} -> GT
1642 MkT2 -> EQ
1643 _ -> LT
1644 ...
1645
1646 However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2
1647 differ, so if -Winaccessible-code is enabled, then deriving this instance will
1648 result in unwelcome warnings.
1649
1650 One conceivable approach to fixing this issue would be to change `deriving Ord`
1651 such that it becomes smarter about not generating unreachable cases. This,
1652 however, would be a highly nontrivial refactor, as we'd have to propagate
1653 through typing information everywhere in the algorithm that generates Ord
1654 instances in order to determine which cases were unreachable. This seems like
1655 a lot of work for minimal gain, so we have opted not to go for this approach.
1656
1657 Instead, we take the much simpler approach of always disabling
1658 -Winaccessible-code for derived code. To accomplish this, we do the following:
1659
1660 1. In tcMethods (which typechecks method bindings), disable
1661 -Winaccessible-code.
1662 2. When creating Implications during typechecking, record the Env
1663 (through ic_env) at the time of creation. Since the Env also stores
1664 DynFlags, this will remember that -Winaccessible-code was disabled over
1665 the scope of that implication.
1666 3. After typechecking comes error reporting, where GHC must decide how to
1667 report inaccessible code to the user, on an Implication-by-Implication
1668 basis. If an Implication's DynFlags indicate that -Winaccessible-code was
1669 disabled, then don't bother reporting it. That's it!
1670 -}
1671
1672 ------------------------
1673 tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
1674 -> TcEvBinds -> Bool
1675 -> HsSigFun
1676 -> [LTcSpecPrag] -> [LSig GhcRn]
1677 -> Id -> LHsBind GhcRn -> SrcSpan
1678 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1679 tcMethodBody clas tyvars dfun_ev_vars inst_tys
1680 dfun_ev_binds is_derived
1681 sig_fn spec_inst_prags prags
1682 sel_id (L bind_loc meth_bind) bndr_loc
1683 = add_meth_ctxt $
1684 do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
1685 ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
1686 mkMethIds clas tyvars dfun_ev_vars
1687 inst_tys sel_id
1688
1689 ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
1690 -- Substitute the local_meth_name for the binder
1691 -- NB: the binding is always a FunBind
1692
1693 -- taking instance signature into account might change the type of
1694 -- the local_meth_id
1695 ; (meth_implic, ev_binds_var, tc_bind)
1696 <- checkInstConstraints $
1697 tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
1698
1699 ; global_meth_id <- addInlinePrags global_meth_id prags
1700 ; spec_prags <- tcSpecPrags global_meth_id prags
1701
1702 ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
1703 export = ABE { abe_ext = noExtField
1704 , abe_poly = global_meth_id
1705 , abe_mono = local_meth_id
1706 , abe_wrap = idHsWrapper
1707 , abe_prags = specs }
1708
1709 local_ev_binds = TcEvBinds ev_binds_var
1710 full_bind = AbsBinds { abs_ext = noExtField
1711 , abs_tvs = tyvars
1712 , abs_ev_vars = dfun_ev_vars
1713 , abs_exports = [export]
1714 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1715 , abs_binds = tc_bind
1716 , abs_sig = True }
1717
1718 ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
1719 where
1720 -- For instance decls that come from deriving clauses
1721 -- we want to print out the full source code if there's an error
1722 -- because otherwise the user won't see the code at all
1723 add_meth_ctxt thing
1724 | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
1725 | otherwise = thing
1726
1727 tcMethodBodyHelp :: HsSigFun -> Id -> TcId
1728 -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId)
1729 tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
1730 | Just hs_sig_ty <- hs_sig_fn sel_name
1731 -- There is a signature in the instance
1732 -- See Note [Instance method signatures]
1733 = do { let ctxt = FunSigCtxt sel_name True
1734 ; (sig_ty, hs_wrap)
1735 <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
1736 do { inst_sigs <- xoptM LangExt.InstanceSigs
1737 ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
1738 ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty
1739 ; let local_meth_ty = idType local_meth_id
1740 ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $
1741 tcSubType_NC ctxt sig_ty local_meth_ty
1742 ; return (sig_ty, hs_wrap) }
1743
1744 ; inner_meth_name <- newName (nameOccName sel_name)
1745 ; let inner_meth_id = mkLocalId inner_meth_name sig_ty
1746 inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
1747 , sig_ctxt = ctxt
1748 , sig_loc = getLoc (hsSigType hs_sig_ty) }
1749
1750
1751 ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
1752
1753 ; let export = ABE { abe_ext = noExtField
1754 , abe_poly = local_meth_id
1755 , abe_mono = inner_id
1756 , abe_wrap = hs_wrap
1757 , abe_prags = noSpecPrags }
1758
1759 ; return (unitBag $ L (getLoc meth_bind) $
1760 AbsBinds { abs_ext = noExtField, abs_tvs = [], abs_ev_vars = []
1761 , abs_exports = [export]
1762 , abs_binds = tc_bind, abs_ev_binds = []
1763 , abs_sig = True }) }
1764
1765 | otherwise -- No instance signature
1766 = do { let ctxt = FunSigCtxt sel_name False
1767 -- False <=> don't report redundant constraints
1768 -- The signature is not under the users control!
1769 tc_sig = completeSigFromId ctxt local_meth_id
1770 -- Absent a type sig, there are no new scoped type variables here
1771 -- Only the ones from the instance decl itself, which are already
1772 -- in scope. Example:
1773 -- class C a where { op :: forall b. Eq b => ... }
1774 -- instance C [c] where { op = <rhs> }
1775 -- In <rhs>, 'c' is scope but 'b' is not!
1776
1777 ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
1778 ; return tc_bind }
1779
1780 where
1781 sel_name = idName sel_id
1782 no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
1783 -- they are all for meth_id
1784
1785
1786 ------------------------
1787 mkMethIds :: Class -> [TcTyVar] -> [EvVar]
1788 -> [TcType] -> Id -> TcM (TcId, TcId)
1789 -- returns (poly_id, local_id), but ignoring any instance signature
1790 -- See Note [Instance method signatures]
1791 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1792 = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ)
1793 ; local_meth_name <- newName sel_occ
1794 -- Base the local_meth_name on the selector name, because
1795 -- type errors from tcMethodBody come from here
1796 ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty
1797 local_meth_id = mkLocalId local_meth_name local_meth_ty
1798
1799 ; return (poly_meth_id, local_meth_id) }
1800 where
1801 sel_name = idName sel_id
1802 sel_occ = nameOccName sel_name
1803 local_meth_ty = instantiateMethod clas sel_id inst_tys
1804 poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty
1805 theta = map idType dfun_ev_vars
1806
1807 methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1808 methSigCtxt sel_name sig_ty meth_ty env0
1809 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty
1810 ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
1811 ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))
1812 2 (vcat [ text "is more general than its signature in the class"
1813 , text "Instance sig:" <+> ppr sig_ty
1814 , text " Class sig:" <+> ppr meth_ty ])
1815 ; return (env2, msg) }
1816
1817 misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
1818 misplacedInstSig name hs_ty
1819 = vcat [ hang (text "Illegal type signature in instance declaration:")
1820 2 (hang (pprPrefixName name)
1821 2 (dcolon <+> ppr hs_ty))
1822 , text "(Use InstanceSigs to allow this)" ]
1823
1824 {- Note [Instance method signatures]
1825 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1826 With -XInstanceSigs we allow the user to supply a signature for the
1827 method in an instance declaration. Here is an artificial example:
1828
1829 data T a = MkT a
1830 instance Ord a => Ord (T a) where
1831 (>) :: forall b. b -> b -> Bool
1832 (>) = error "You can't compare Ts"
1833
1834 The instance signature can be *more* polymorphic than the instantiated
1835 class method (in this case: Age -> Age -> Bool), but it cannot be less
1836 polymorphic. Moreover, if a signature is given, the implementation
1837 code should match the signature, and type variables bound in the
1838 singature should scope over the method body.
1839
1840 We achieve this by building a TcSigInfo for the method, whether or not
1841 there is an instance method signature, and using that to typecheck
1842 the declaration (in tcMethodBody). That means, conveniently,
1843 that the type variables bound in the signature will scope over the body.
1844
1845 What about the check that the instance method signature is more
1846 polymorphic than the instantiated class method type? We just do a
1847 tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like
1848 this (for the example above
1849
1850 AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]
1851 , abs_exports
1852 = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool
1853 , gr_lcl :: T a -> T a -> Bool }
1854 , abs_binds
1855 = AbsBind { abs_tvs = [], abs_ev_vars = []
1856 , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool
1857 , gr_inner :: forall b. b -> b -> Bool }
1858 , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []
1859 , ..etc.. }
1860 } }
1861
1862 Wow! Three nested AbsBinds!
1863 * The outer one abstracts over the tyvars and dicts for the instance
1864 * The middle one is only present if there is an instance signature,
1865 and does the impedance matching for that signature
1866 * The inner one is for the method binding itself against either the
1867 signature from the class, or the instance signature.
1868 -}
1869
1870 ----------------------
1871 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
1872 -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
1873 -- There are two sources:
1874 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1875 -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
1876 -- These ones have the dfun inside, but [perhaps surprisingly]
1877 -- the correct wrapper.
1878 -- See Note [Handling SPECIALISE pragmas] in TcBinds
1879 mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
1880 = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
1881 where
1882 spec_prags_from_inst
1883 | isInlinePragma (idInlinePragma meth_id)
1884 = [] -- Do not inherit SPECIALISE from the instance if the
1885 -- method is marked INLINE, because then it'll be inlined
1886 -- and the specialisation would do nothing. (Indeed it'll provoke
1887 -- a warning from the desugarer
1888 | otherwise
1889 = [ L inst_loc (SpecPrag meth_id wrap inl)
1890 | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
1891
1892
1893 mkDefMethBind :: Class -> [Type] -> Id -> Name
1894 -> TcM (LHsBind GhcRn, [LSig GhcRn])
1895 -- The is a default method (vanailla or generic) defined in the class
1896 -- So make a binding op = $dmop @t1 @t2
1897 -- where $dmop is the name of the default method in the class,
1898 -- and t1,t2 are the instance types.
1899 -- See Note [Default methods in instances] for why we use
1900 -- visible type application here
1901 mkDefMethBind clas inst_tys sel_id dm_name
1902 = do { dflags <- getDynFlags
1903 ; dm_id <- tcLookupId dm_name
1904 ; let inline_prag = idInlinePragma dm_id
1905 inline_prags | isAnyInlinePragma inline_prag
1906 = [noLoc (InlineSig noExtField fn inline_prag)]
1907 | otherwise
1908 = []
1909 -- Copy the inline pragma (if any) from the default method
1910 -- to this version. Note [INLINE and default methods]
1911
1912 fn = noLoc (idName sel_id)
1913 visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
1914 , tyConBinderArgFlag tcb /= Inferred ]
1915 rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
1916 bind = noLoc $ mkTopFunBind Generated fn $
1917 [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
1918
1919 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
1920 (vcat [ppr clas <+> ppr inst_tys,
1921 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
1922
1923 ; return (bind, inline_prags) }
1924 where
1925 mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
1926 mk_vta fun ty = noLoc (HsAppType noExtField fun (mkEmptyWildCardBndrs $ nlHsParTy
1927 $ noLoc $ XHsType $ NHsCoreTy ty))
1928 -- NB: use visible type application
1929 -- See Note [Default methods in instances]
1930
1931 ----------------------
1932 derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
1933 derivBindCtxt sel_id clas tys
1934 = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)
1935 , nest 2 (text "in a derived instance for"
1936 <+> quotes (pprClassPred clas tys) <> colon)
1937 , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]
1938
1939 warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
1940 warnUnsatisfiedMinimalDefinition mindef
1941 = do { warn <- woptM Opt_WarnMissingMethods
1942 ; warnTc (Reason Opt_WarnMissingMethods) warn message
1943 }
1944 where
1945 message = vcat [text "No explicit implementation for"
1946 ,nest 2 $ pprBooleanFormulaNice mindef
1947 ]
1948
1949 {-
1950 Note [Export helper functions]
1951 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1952 We arrange to export the "helper functions" of an instance declaration,
1953 so that they are not subject to preInlineUnconditionally, even if their
1954 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1955 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1956 non-variable for them.
1957
1958 We could change this by making DFunUnfoldings have CoreExprs, but it
1959 seems a bit simpler this way.
1960
1961 Note [Default methods in instances]
1962 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1963 Consider this
1964
1965 class Baz v x where
1966 foo :: x -> x
1967 foo y = <blah>
1968
1969 instance Baz Int Int
1970
1971 From the class decl we get
1972
1973 $dmfoo :: forall v x. Baz v x => x -> x
1974 $dmfoo y = <blah>
1975
1976 Notice that the type is ambiguous. So we use Visible Type Application
1977 to disambiguate:
1978
1979 $dBazIntInt = MkBaz fooIntInt
1980 fooIntInt = $dmfoo @Int @Int
1981
1982 Lacking VTA we'd get ambiguity errors involving the default method. This applies
1983 equally to vanilla default methods (#1061) and generic default methods
1984 (#12220).
1985
1986 Historical note: before we had VTA we had to generate
1987 post-type-checked code, which took a lot more code, and didn't work for
1988 generic default methods.
1989
1990 Note [INLINE and default methods]
1991 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1992 Default methods need special case. They are supposed to behave rather like
1993 macros. For example
1994
1995 class Foo a where
1996 op1, op2 :: Bool -> a -> a
1997
1998 {-# INLINE op1 #-}
1999 op1 b x = op2 (not b) x
2000
2001 instance Foo Int where
2002 -- op1 via default method
2003 op2 b x = <blah>
2004
2005 The instance declaration should behave
2006
2007 just as if 'op1' had been defined with the
2008 code, and INLINE pragma, from its original
2009 definition.
2010
2011 That is, just as if you'd written
2012
2013 instance Foo Int where
2014 op2 b x = <blah>
2015
2016 {-# INLINE op1 #-}
2017 op1 b x = op2 (not b) x
2018
2019 So for the above example we generate:
2020
2021 {-# INLINE $dmop1 #-}
2022 -- $dmop1 has an InlineCompulsory unfolding
2023 $dmop1 d b x = op2 d (not b) x
2024
2025 $fFooInt = MkD $cop1 $cop2
2026
2027 {-# INLINE $cop1 #-}
2028 $cop1 = $dmop1 $fFooInt
2029
2030 $cop2 = <blah>
2031
2032 Note carefully:
2033
2034 * We *copy* any INLINE pragma from the default method $dmop1 to the
2035 instance $cop1. Otherwise we'll just inline the former in the
2036 latter and stop, which isn't what the user expected
2037
2038 * Regardless of its pragma, we give the default method an
2039 unfolding with an InlineCompulsory source. That means
2040 that it'll be inlined at every use site, notably in
2041 each instance declaration, such as $cop1. This inlining
2042 must happen even though
2043 a) $dmop1 is not saturated in $cop1
2044 b) $cop1 itself has an INLINE pragma
2045
2046 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
2047 recursion between $fooInt and $cop1 to be broken
2048
2049 * To communicate the need for an InlineCompulsory to the desugarer
2050 (which makes the Unfoldings), we use the IsDefaultMethod constructor
2051 in TcSpecPrags.
2052
2053
2054 ************************************************************************
2055 * *
2056 Specialise instance pragmas
2057 * *
2058 ************************************************************************
2059
2060 Note [SPECIALISE instance pragmas]
2061 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2062 Consider
2063
2064 instance (Ix a, Ix b) => Ix (a,b) where
2065 {-# SPECIALISE instance Ix (Int,Int) #-}
2066 range (x,y) = ...
2067
2068 We make a specialised version of the dictionary function, AND
2069 specialised versions of each *method*. Thus we should generate
2070 something like this:
2071
2072 $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
2073 {-# DFUN [$crangePair, ...] #-}
2074 {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
2075 $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
2076
2077 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
2078 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
2079 $crange da db = <blah>
2080
2081 The SPECIALISE pragmas are acted upon by the desugarer, which generate
2082
2083 dii :: Ix Int
2084 dii = ...
2085
2086 $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
2087 {-# DFUN [$crangePair di di, ...] #-}
2088 $s$dfIxPair = Ix ($crangePair di di) (...)
2089
2090 {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
2091
2092 $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
2093 $c$crangePair = ...specialised RHS of $crangePair...
2094
2095 {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
2096
2097 Note that
2098
2099 * The specialised dictionary $s$dfIxPair is very much needed, in case we
2100 call a function that takes a dictionary, but in a context where the
2101 specialised dictionary can be used. See #7797.
2102
2103 * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
2104 it still has a DFunUnfolding. See Note [ClassOp/DFun selection]
2105
2106 * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
2107 --> {ClassOp rule for range} $crangePair Int Int d1 d2
2108 --> {SPEC rule for $crangePair} $s$crangePair
2109 or thus:
2110 --> {SPEC rule for $dfIxPair} range $s$dfIxPair
2111 --> {ClassOpRule for range} $s$crangePair
2112 It doesn't matter which way.
2113
2114 * We want to specialise the RHS of both $dfIxPair and $crangePair,
2115 but the SAME HsWrapper will do for both! We can call tcSpecPrag
2116 just once, and pass the result (in spec_inst_info) to tcMethods.
2117 -}
2118
2119 tcSpecInstPrags :: DFunId -> InstBindings GhcRn
2120 -> TcM ([Located TcSpecPrag], TcPragEnv)
2121 tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
2122 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
2123 filter isSpecInstLSig uprags
2124 -- The filter removes the pragmas for methods
2125 ; return (spec_inst_prags, mkPragEnv uprags binds) }
2126
2127 ------------------------------
2128 tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
2129 tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
2130 = addErrCtxt (spec_ctxt prag) $
2131 do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty
2132 ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
2133 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
2134 where
2135 spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
2136
2137 tcSpecInst _ _ = panic "tcSpecInst"
2138
2139 {-
2140 ************************************************************************
2141 * *
2142 \subsection{Error messages}
2143 * *
2144 ************************************************************************
2145 -}
2146
2147 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
2148 instDeclCtxt1 hs_inst_ty
2149 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
2150
2151 instDeclCtxt2 :: Type -> SDoc
2152 instDeclCtxt2 dfun_ty
2153 = inst_decl_ctxt (ppr (mkClassPred cls tys))
2154 where
2155 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
2156
2157 inst_decl_ctxt :: SDoc -> SDoc
2158 inst_decl_ctxt doc = hang (text "In the instance declaration for")
2159 2 (quotes doc)
2160
2161 badBootFamInstDeclErr :: SDoc
2162 badBootFamInstDeclErr
2163 = text "Illegal family instance in hs-boot file"
2164
2165 notFamily :: TyCon -> SDoc
2166 notFamily tycon
2167 = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
2168 , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]
2169
2170 assocInClassErr :: TyCon -> SDoc
2171 assocInClassErr name
2172 = text "Associated type" <+> quotes (ppr name) <+>
2173 text "must be inside a class instance"
2174
2175 badFamInstDecl :: TyCon -> SDoc
2176 badFamInstDecl tc_name
2177 = vcat [ text "Illegal family instance for" <+>
2178 quotes (ppr tc_name)
2179 , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]
2180
2181 notOpenFamily :: TyCon -> SDoc
2182 notOpenFamily tc
2183 = text "Illegal instance for closed family" <+> quotes (ppr tc)