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