Make a smart mkAppTyM
[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 Trac #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 (Trac #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 (Trac #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 (Trac #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 Trac #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 (mkLamTypes dfun_evs sc_pred)
1223 sc_top_id = mkLocalId sc_top_name sc_top_ty
1224 export = ABE { abe_ext = noExt
1225 , abe_wrap = idHsWrapper
1226 , abe_poly = sc_top_id
1227 , abe_mono = sc_ev_id
1228 , abe_prags = noSpecPrags }
1229 local_ev_binds = TcEvBinds ev_binds_var
1230 bind = AbsBinds { abs_ext = noExt
1231 , abs_tvs = tyvars
1232 , abs_ev_vars = dfun_evs
1233 , abs_exports = [export]
1234 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1235 , abs_binds = emptyBag
1236 , abs_sig = False }
1237 ; return (sc_top_id, L loc bind, sc_implic) }
1238
1239 -------------------
1240 checkInstConstraints :: TcM result
1241 -> TcM (Implication, EvBindsVar, result)
1242 -- See Note [Typechecking plan for instance declarations]
1243 checkInstConstraints thing_inside
1244 = do { (tclvl, wanted, result) <- pushLevelAndCaptureConstraints $
1245 thing_inside
1246
1247 ; ev_binds_var <- newTcEvBinds
1248 ; implic <- newImplication
1249 ; let implic' = implic { ic_tclvl = tclvl
1250 , ic_wanted = wanted
1251 , ic_binds = ev_binds_var
1252 , ic_info = InstSkol }
1253
1254 ; return (implic', ev_binds_var, result) }
1255
1256 {-
1257 Note [Recursive superclasses]
1258 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1259 See Trac #3731, #4809, #5751, #5913, #6117, #6161, which all
1260 describe somewhat more complicated situations, but ones
1261 encountered in practice.
1262
1263 See also tests tcrun020, tcrun021, tcrun033, and Trac #11427.
1264
1265 ----- THE PROBLEM --------
1266 The problem is that it is all too easy to create a class whose
1267 superclass is bottom when it should not be.
1268
1269 Consider the following (extreme) situation:
1270 class C a => D a where ...
1271 instance D [a] => D [a] where ... (dfunD)
1272 instance C [a] => C [a] where ... (dfunC)
1273 Although this looks wrong (assume D [a] to prove D [a]), it is only a
1274 more extreme case of what happens with recursive dictionaries, and it
1275 can, just about, make sense because the methods do some work before
1276 recursing.
1277
1278 To implement the dfunD we must generate code for the superclass C [a],
1279 which we had better not get by superclass selection from the supplied
1280 argument:
1281 dfunD :: forall a. D [a] -> D [a]
1282 dfunD = \d::D [a] -> MkD (scsel d) ..
1283
1284 Otherwise if we later encounter a situation where
1285 we have a [Wanted] dw::D [a] we might solve it thus:
1286 dw := dfunD dw
1287 Which is all fine except that now ** the superclass C is bottom **!
1288
1289 The instance we want is:
1290 dfunD :: forall a. D [a] -> D [a]
1291 dfunD = \d::D [a] -> MkD (dfunC (scsel d)) ...
1292
1293 ----- THE SOLUTION --------
1294 The basic solution is simple: be very careful about using superclass
1295 selection to generate a superclass witness in a dictionary function
1296 definition. More precisely:
1297
1298 Superclass Invariant: in every class dictionary,
1299 every superclass dictionary field
1300 is non-bottom
1301
1302 To achieve the Superclass Invariant, in a dfun definition we can
1303 generate a guaranteed-non-bottom superclass witness from:
1304 (sc1) one of the dictionary arguments itself (all non-bottom)
1305 (sc2) an immediate superclass of a smaller dictionary
1306 (sc3) a call of a dfun (always returns a dictionary constructor)
1307
1308 The tricky case is (sc2). We proceed by induction on the size of
1309 the (type of) the dictionary, defined by TcValidity.sizeTypes.
1310 Let's suppose we are building a dictionary of size 3, and
1311 suppose the Superclass Invariant holds of smaller dictionaries.
1312 Then if we have a smaller dictionary, its immediate superclasses
1313 will be non-bottom by induction.
1314
1315 What does "we have a smaller dictionary" mean? It might be
1316 one of the arguments of the instance, or one of its superclasses.
1317 Here is an example, taken from CmmExpr:
1318 class Ord r => UserOfRegs r a where ...
1319 (i1) instance UserOfRegs r a => UserOfRegs r (Maybe a) where
1320 (i2) instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
1321
1322 For (i1) we can get the (Ord r) superclass by selection from (UserOfRegs r a),
1323 since it is smaller than the thing we are building (UserOfRegs r (Maybe a).
1324
1325 But for (i2) that isn't the case, so we must add an explicit, and
1326 perhaps surprising, (Ord r) argument to the instance declaration.
1327
1328 Here's another example from Trac #6161:
1329
1330 class Super a => Duper a where ...
1331 class Duper (Fam a) => Foo a where ...
1332 (i3) instance Foo a => Duper (Fam a) where ...
1333 (i4) instance Foo Float where ...
1334
1335 It would be horribly wrong to define
1336 dfDuperFam :: Foo a -> Duper (Fam a) -- from (i3)
1337 dfDuperFam d = MkDuper (sc_sel1 (sc_sel2 d)) ...
1338
1339 dfFooFloat :: Foo Float -- from (i4)
1340 dfFooFloat = MkFoo (dfDuperFam dfFooFloat) ...
1341
1342 Now the Super superclass of Duper is definitely bottom!
1343
1344 This won't happen because when processing (i3) we can use the
1345 superclasses of (Foo a), which is smaller, namely Duper (Fam a). But
1346 that is *not* smaller than the target so we can't take *its*
1347 superclasses. As a result the program is rightly rejected, unless you
1348 add (Super (Fam a)) to the context of (i3).
1349
1350 Note [Solving superclass constraints]
1351 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1352 How do we ensure that every superclass witness is generated by
1353 one of (sc1) (sc2) or (sc3) in Note [Recursive superclasses].
1354 Answer:
1355
1356 * Superclass "wanted" constraints have CtOrigin of (ScOrigin size)
1357 where 'size' is the size of the instance declaration. e.g.
1358 class C a => D a where...
1359 instance blah => D [a] where ...
1360 The wanted superclass constraint for C [a] has origin
1361 ScOrigin size, where size = size( D [a] ).
1362
1363 * (sc1) When we rewrite such a wanted constraint, it retains its
1364 origin. But if we apply an instance declaration, we can set the
1365 origin to (ScOrigin infinity), thus lifting any restrictions by
1366 making prohibitedSuperClassSolve return False.
1367
1368 * (sc2) ScOrigin wanted constraints can't be solved from a
1369 superclass selection, except at a smaller type. This test is
1370 implemented by TcInteract.prohibitedSuperClassSolve
1371
1372 * The "given" constraints of an instance decl have CtOrigin
1373 GivenOrigin InstSkol.
1374
1375 * When we make a superclass selection from InstSkol we use
1376 a SkolemInfo of (InstSC size), where 'size' is the size of
1377 the constraint whose superclass we are taking. A similarly
1378 when taking the superclass of an InstSC. This is implemented
1379 in TcCanonical.newSCWorkFromFlavored
1380
1381 Note [Silent superclass arguments] (historical interest only)
1382 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1383 NB1: this note describes our *old* solution to the
1384 recursive-superclass problem. I'm keeping the Note
1385 for now, just as institutional memory.
1386 However, the code for silent superclass arguments
1387 was removed in late Dec 2014
1388
1389 NB2: the silent-superclass solution introduced new problems
1390 of its own, in the form of instance overlap. Tests
1391 SilentParametersOverlapping, T5051, and T7862 are examples
1392
1393 NB3: the silent-superclass solution also generated tons of
1394 extra dictionaries. For example, in monad-transformer
1395 code, when constructing a Monad dictionary you had to pass
1396 an Applicative dictionary; and to construct that you neede
1397 a Functor dictionary. Yet these extra dictionaries were
1398 often never used. Test T3064 compiled *far* faster after
1399 silent superclasses were eliminated.
1400
1401 Our solution to this problem "silent superclass arguments". We pass
1402 to each dfun some ``silent superclass arguments’’, which are the
1403 immediate superclasses of the dictionary we are trying to
1404 construct. In our example:
1405 dfun :: forall a. C [a] -> D [a] -> D [a]
1406 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
1407 Notice the extra (dc :: C [a]) argument compared to the previous version.
1408
1409 This gives us:
1410
1411 -----------------------------------------------------------
1412 DFun Superclass Invariant
1413 ~~~~~~~~~~~~~~~~~~~~~~~~
1414 In the body of a DFun, every superclass argument to the
1415 returned dictionary is
1416 either * one of the arguments of the DFun,
1417 or * constant, bound at top level
1418 -----------------------------------------------------------
1419
1420 This net effect is that it is safe to treat a dfun application as
1421 wrapping a dictionary constructor around its arguments (in particular,
1422 a dfun never picks superclasses from the arguments under the
1423 dictionary constructor). No superclass is hidden inside a dfun
1424 application.
1425
1426 The extra arguments required to satisfy the DFun Superclass Invariant
1427 always come first, and are called the "silent" arguments. You can
1428 find out how many silent arguments there are using Id.dfunNSilent;
1429 and then you can just drop that number of arguments to see the ones
1430 that were in the original instance declaration.
1431
1432 DFun types are built (only) by MkId.mkDictFunId, so that is where we
1433 decide what silent arguments are to be added.
1434 -}
1435
1436 {-
1437 ************************************************************************
1438 * *
1439 Type-checking an instance method
1440 * *
1441 ************************************************************************
1442
1443 tcMethod
1444 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
1445 - Remembering to use fresh Name (the instance method Name) as the binder
1446 - Bring the instance method Ids into scope, for the benefit of tcInstSig
1447 - Use sig_fn mapping instance method Name -> instance tyvars
1448 - Ditto prag_fn
1449 - Use tcValBinds to do the checking
1450 -}
1451
1452 tcMethods :: DFunId -> Class
1453 -> [TcTyVar] -> [EvVar]
1454 -> [TcType]
1455 -> TcEvBinds
1456 -> ([Located TcSpecPrag], TcPragEnv)
1457 -> [ClassOpItem]
1458 -> InstBindings GhcRn
1459 -> TcM ([Id], LHsBinds GhcTc, Bag Implication)
1460 -- The returned inst_meth_ids all have types starting
1461 -- forall tvs. theta => ...
1462 tcMethods dfun_id clas tyvars dfun_ev_vars inst_tys
1463 dfun_ev_binds (spec_inst_prags, prag_fn) op_items
1464 (InstBindings { ib_binds = binds
1465 , ib_tyvars = lexical_tvs
1466 , ib_pragmas = sigs
1467 , ib_extensions = exts
1468 , ib_derived = is_derived })
1469 = tcExtendNameTyVarEnv (lexical_tvs `zip` tyvars) $
1470 -- The lexical_tvs scope over the 'where' part
1471 do { traceTc "tcInstMeth" (ppr sigs $$ ppr binds)
1472 ; checkMinimalDefinition
1473 ; checkMethBindMembership
1474 ; (ids, binds, mb_implics) <- set_exts exts $
1475 unset_warnings_deriving $
1476 mapAndUnzip3M tc_item op_items
1477 ; return (ids, listToBag binds, listToBag (catMaybes mb_implics)) }
1478 where
1479 set_exts :: [LangExt.Extension] -> TcM a -> TcM a
1480 set_exts es thing = foldr setXOptM thing es
1481
1482 -- See Note [Avoid -Winaccessible-code when deriving]
1483 unset_warnings_deriving :: TcM a -> TcM a
1484 unset_warnings_deriving
1485 | is_derived = unsetWOptM Opt_WarnInaccessibleCode
1486 | otherwise = id
1487
1488 hs_sig_fn = mkHsSigFun sigs
1489 inst_loc = getSrcSpan dfun_id
1490
1491 ----------------------
1492 tc_item :: ClassOpItem -> TcM (Id, LHsBind GhcTc, Maybe Implication)
1493 tc_item (sel_id, dm_info)
1494 | Just (user_bind, bndr_loc, prags) <- findMethodBind (idName sel_id) binds prag_fn
1495 = tcMethodBody clas tyvars dfun_ev_vars inst_tys
1496 dfun_ev_binds is_derived hs_sig_fn
1497 spec_inst_prags prags
1498 sel_id user_bind bndr_loc
1499 | otherwise
1500 = do { traceTc "tc_def" (ppr sel_id)
1501 ; tc_default sel_id dm_info }
1502
1503 ----------------------
1504 tc_default :: Id -> DefMethInfo
1505 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1506
1507 tc_default sel_id (Just (dm_name, _))
1508 = do { (meth_bind, inline_prags) <- mkDefMethBind clas inst_tys sel_id dm_name
1509 ; tcMethodBody clas tyvars dfun_ev_vars inst_tys
1510 dfun_ev_binds is_derived hs_sig_fn
1511 spec_inst_prags inline_prags
1512 sel_id meth_bind inst_loc }
1513
1514 tc_default sel_id Nothing -- No default method at all
1515 = do { traceTc "tc_def: warn" (ppr sel_id)
1516 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
1517 inst_tys sel_id
1518 ; dflags <- getDynFlags
1519 ; let meth_bind = mkVarBind meth_id $
1520 mkLHsWrap lam_wrapper (error_rhs dflags)
1521 ; return (meth_id, meth_bind, Nothing) }
1522 where
1523 error_rhs dflags = L inst_loc $ HsApp noExt error_fun (error_msg dflags)
1524 error_fun = L inst_loc $
1525 wrapId (mkWpTyApps
1526 [ getRuntimeRep meth_tau, meth_tau])
1527 nO_METHOD_BINDING_ERROR_ID
1528 error_msg dflags = L inst_loc (HsLit noExt (HsStringPrim NoSourceText
1529 (unsafeMkByteString (error_string dflags))))
1530 meth_tau = funResultTy (piResultTys (idType sel_id) inst_tys)
1531 error_string dflags = showSDoc dflags
1532 (hcat [ppr inst_loc, vbar, ppr sel_id ])
1533 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
1534
1535 ----------------------
1536 -- Check if one of the minimal complete definitions is satisfied
1537 checkMinimalDefinition
1538 = whenIsJust (isUnsatisfied methodExists (classMinimalDef clas)) $
1539 warnUnsatisfiedMinimalDefinition
1540
1541 methodExists meth = isJust (findMethodBind meth binds prag_fn)
1542
1543 ----------------------
1544 -- Check if any method bindings do not correspond to the class.
1545 -- See Note [Mismatched class methods and associated type families].
1546 checkMethBindMembership
1547 = mapM_ (addErrTc . badMethodErr clas) mismatched_meths
1548 where
1549 bind_nms = map unLoc $ collectMethodBinders binds
1550 cls_meth_nms = map (idName . fst) op_items
1551 mismatched_meths = bind_nms `minusList` cls_meth_nms
1552
1553 {-
1554 Note [Mismatched class methods and associated type families]
1555 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1556 It's entirely possible for someone to put methods or associated type family
1557 instances inside of a class in which it doesn't belong. For instance, we'd
1558 want to fail if someone wrote this:
1559
1560 instance Eq () where
1561 type Rep () = Maybe
1562 compare = undefined
1563
1564 Since neither the type family `Rep` nor the method `compare` belong to the
1565 class `Eq`. Normally, this is caught in the renamer when resolving RdrNames,
1566 since that would discover that the parent class `Eq` is incorrect.
1567
1568 However, there is a scenario in which the renamer could fail to catch this:
1569 if the instance was generated through Template Haskell, as in #12387. In that
1570 case, Template Haskell will provide fully resolved names (e.g.,
1571 `GHC.Classes.compare`), so the renamer won't notice the sleight-of-hand going
1572 on. For this reason, we also put an extra validity check for this in the
1573 typechecker as a last resort.
1574
1575 Note [Avoid -Winaccessible-code when deriving]
1576 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1577 -Winaccessible-code can be particularly noisy when deriving instances for
1578 GADTs. Consider the following example (adapted from #8128):
1579
1580 data T a where
1581 MkT1 :: Int -> T Int
1582 MkT2 :: T Bool
1583 MkT3 :: T Bool
1584 deriving instance Eq (T a)
1585 deriving instance Ord (T a)
1586
1587 In the derived Ord instance, GHC will generate the following code:
1588
1589 instance Ord (T a) where
1590 compare x y
1591 = case x of
1592 MkT2
1593 -> case y of
1594 MkT1 {} -> GT
1595 MkT2 -> EQ
1596 _ -> LT
1597 ...
1598
1599 However, that MkT1 is unreachable, since the type indices for MkT1 and MkT2
1600 differ, so if -Winaccessible-code is enabled, then deriving this instance will
1601 result in unwelcome warnings.
1602
1603 One conceivable approach to fixing this issue would be to change `deriving Ord`
1604 such that it becomes smarter about not generating unreachable cases. This,
1605 however, would be a highly nontrivial refactor, as we'd have to propagate
1606 through typing information everywhere in the algorithm that generates Ord
1607 instances in order to determine which cases were unreachable. This seems like
1608 a lot of work for minimal gain, so we have opted not to go for this approach.
1609
1610 Instead, we take the much simpler approach of always disabling
1611 -Winaccessible-code for derived code. To accomplish this, we do the following:
1612
1613 1. In tcMethods (which typechecks method bindings), disable
1614 -Winaccessible-code.
1615 2. When creating Implications during typechecking, record the Env
1616 (through ic_env) at the time of creation. Since the Env also stores
1617 DynFlags, this will remember that -Winaccessible-code was disabled over
1618 the scope of that implication.
1619 3. After typechecking comes error reporting, where GHC must decide how to
1620 report inaccessible code to the user, on an Implication-by-Implication
1621 basis. If an Implication's DynFlags indicate that -Winaccessible-code was
1622 disabled, then don't bother reporting it. That's it!
1623 -}
1624
1625 ------------------------
1626 tcMethodBody :: Class -> [TcTyVar] -> [EvVar] -> [TcType]
1627 -> TcEvBinds -> Bool
1628 -> HsSigFun
1629 -> [LTcSpecPrag] -> [LSig GhcRn]
1630 -> Id -> LHsBind GhcRn -> SrcSpan
1631 -> TcM (TcId, LHsBind GhcTc, Maybe Implication)
1632 tcMethodBody clas tyvars dfun_ev_vars inst_tys
1633 dfun_ev_binds is_derived
1634 sig_fn spec_inst_prags prags
1635 sel_id (L bind_loc meth_bind) bndr_loc
1636 = add_meth_ctxt $
1637 do { traceTc "tcMethodBody" (ppr sel_id <+> ppr (idType sel_id) $$ ppr bndr_loc)
1638 ; (global_meth_id, local_meth_id) <- setSrcSpan bndr_loc $
1639 mkMethIds clas tyvars dfun_ev_vars
1640 inst_tys sel_id
1641
1642 ; let lm_bind = meth_bind { fun_id = L bndr_loc (idName local_meth_id) }
1643 -- Substitute the local_meth_name for the binder
1644 -- NB: the binding is always a FunBind
1645
1646 -- taking instance signature into account might change the type of
1647 -- the local_meth_id
1648 ; (meth_implic, ev_binds_var, tc_bind)
1649 <- checkInstConstraints $
1650 tcMethodBodyHelp sig_fn sel_id local_meth_id (L bind_loc lm_bind)
1651
1652 ; global_meth_id <- addInlinePrags global_meth_id prags
1653 ; spec_prags <- tcSpecPrags global_meth_id prags
1654
1655 ; let specs = mk_meth_spec_prags global_meth_id spec_inst_prags spec_prags
1656 export = ABE { abe_ext = noExt
1657 , abe_poly = global_meth_id
1658 , abe_mono = local_meth_id
1659 , abe_wrap = idHsWrapper
1660 , abe_prags = specs }
1661
1662 local_ev_binds = TcEvBinds ev_binds_var
1663 full_bind = AbsBinds { abs_ext = noExt
1664 , abs_tvs = tyvars
1665 , abs_ev_vars = dfun_ev_vars
1666 , abs_exports = [export]
1667 , abs_ev_binds = [dfun_ev_binds, local_ev_binds]
1668 , abs_binds = tc_bind
1669 , abs_sig = True }
1670
1671 ; return (global_meth_id, L bind_loc full_bind, Just meth_implic) }
1672 where
1673 -- For instance decls that come from deriving clauses
1674 -- we want to print out the full source code if there's an error
1675 -- because otherwise the user won't see the code at all
1676 add_meth_ctxt thing
1677 | is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
1678 | otherwise = thing
1679
1680 tcMethodBodyHelp :: HsSigFun -> Id -> TcId
1681 -> LHsBind GhcRn -> TcM (LHsBinds GhcTcId)
1682 tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
1683 | Just hs_sig_ty <- hs_sig_fn sel_name
1684 -- There is a signature in the instance
1685 -- See Note [Instance method signatures]
1686 = do { let ctxt = FunSigCtxt sel_name True
1687 ; (sig_ty, hs_wrap)
1688 <- setSrcSpan (getLoc (hsSigType hs_sig_ty)) $
1689 do { inst_sigs <- xoptM LangExt.InstanceSigs
1690 ; checkTc inst_sigs (misplacedInstSig sel_name hs_sig_ty)
1691 ; sig_ty <- tcHsSigType (FunSigCtxt sel_name False) hs_sig_ty
1692 ; let local_meth_ty = idType local_meth_id
1693 ; hs_wrap <- addErrCtxtM (methSigCtxt sel_name sig_ty local_meth_ty) $
1694 tcSubType_NC ctxt sig_ty local_meth_ty
1695 ; return (sig_ty, hs_wrap) }
1696
1697 ; inner_meth_name <- newName (nameOccName sel_name)
1698 ; let inner_meth_id = mkLocalId inner_meth_name sig_ty
1699 inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
1700 , sig_ctxt = ctxt
1701 , sig_loc = getLoc (hsSigType hs_sig_ty) }
1702
1703
1704 ; (tc_bind, [inner_id]) <- tcPolyCheck no_prag_fn inner_meth_sig meth_bind
1705
1706 ; let export = ABE { abe_ext = noExt
1707 , abe_poly = local_meth_id
1708 , abe_mono = inner_id
1709 , abe_wrap = hs_wrap
1710 , abe_prags = noSpecPrags }
1711
1712 ; return (unitBag $ L (getLoc meth_bind) $
1713 AbsBinds { abs_ext = noExt, abs_tvs = [], abs_ev_vars = []
1714 , abs_exports = [export]
1715 , abs_binds = tc_bind, abs_ev_binds = []
1716 , abs_sig = True }) }
1717
1718 | otherwise -- No instance signature
1719 = do { let ctxt = FunSigCtxt sel_name False
1720 -- False <=> don't report redundant constraints
1721 -- The signature is not under the users control!
1722 tc_sig = completeSigFromId ctxt local_meth_id
1723 -- Absent a type sig, there are no new scoped type variables here
1724 -- Only the ones from the instance decl itself, which are already
1725 -- in scope. Example:
1726 -- class C a where { op :: forall b. Eq b => ... }
1727 -- instance C [c] where { op = <rhs> }
1728 -- In <rhs>, 'c' is scope but 'b' is not!
1729
1730 ; (tc_bind, _) <- tcPolyCheck no_prag_fn tc_sig meth_bind
1731 ; return tc_bind }
1732
1733 where
1734 sel_name = idName sel_id
1735 no_prag_fn = emptyPragEnv -- No pragmas for local_meth_id;
1736 -- they are all for meth_id
1737
1738
1739 ------------------------
1740 mkMethIds :: Class -> [TcTyVar] -> [EvVar]
1741 -> [TcType] -> Id -> TcM (TcId, TcId)
1742 -- returns (poly_id, local_id), but ignoring any instance signature
1743 -- See Note [Instance method signatures]
1744 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1745 = do { poly_meth_name <- newName (mkClassOpAuxOcc sel_occ)
1746 ; local_meth_name <- newName sel_occ
1747 -- Base the local_meth_name on the selector name, because
1748 -- type errors from tcMethodBody come from here
1749 ; let poly_meth_id = mkLocalId poly_meth_name poly_meth_ty
1750 local_meth_id = mkLocalId local_meth_name local_meth_ty
1751
1752 ; return (poly_meth_id, local_meth_id) }
1753 where
1754 sel_name = idName sel_id
1755 sel_occ = nameOccName sel_name
1756 local_meth_ty = instantiateMethod clas sel_id inst_tys
1757 poly_meth_ty = mkSpecSigmaTy tyvars theta local_meth_ty
1758 theta = map idType dfun_ev_vars
1759
1760 methSigCtxt :: Name -> TcType -> TcType -> TidyEnv -> TcM (TidyEnv, MsgDoc)
1761 methSigCtxt sel_name sig_ty meth_ty env0
1762 = do { (env1, sig_ty) <- zonkTidyTcType env0 sig_ty
1763 ; (env2, meth_ty) <- zonkTidyTcType env1 meth_ty
1764 ; let msg = hang (text "When checking that instance signature for" <+> quotes (ppr sel_name))
1765 2 (vcat [ text "is more general than its signature in the class"
1766 , text "Instance sig:" <+> ppr sig_ty
1767 , text " Class sig:" <+> ppr meth_ty ])
1768 ; return (env2, msg) }
1769
1770 misplacedInstSig :: Name -> LHsSigType GhcRn -> SDoc
1771 misplacedInstSig name hs_ty
1772 = vcat [ hang (text "Illegal type signature in instance declaration:")
1773 2 (hang (pprPrefixName name)
1774 2 (dcolon <+> ppr hs_ty))
1775 , text "(Use InstanceSigs to allow this)" ]
1776
1777 {- Note [Instance method signatures]
1778 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1779 With -XInstanceSigs we allow the user to supply a signature for the
1780 method in an instance declaration. Here is an artificial example:
1781
1782 data T a = MkT a
1783 instance Ord a => Ord (T a) where
1784 (>) :: forall b. b -> b -> Bool
1785 (>) = error "You can't compare Ts"
1786
1787 The instance signature can be *more* polymorphic than the instantiated
1788 class method (in this case: Age -> Age -> Bool), but it cannot be less
1789 polymorphic. Moreover, if a signature is given, the implementation
1790 code should match the signature, and type variables bound in the
1791 singature should scope over the method body.
1792
1793 We achieve this by building a TcSigInfo for the method, whether or not
1794 there is an instance method signature, and using that to typecheck
1795 the declaration (in tcMethodBody). That means, conveniently,
1796 that the type variables bound in the signature will scope over the body.
1797
1798 What about the check that the instance method signature is more
1799 polymorphic than the instantiated class method type? We just do a
1800 tcSubType call in tcMethodBodyHelp, and generate a nested AbsBind, like
1801 this (for the example above
1802
1803 AbsBind { abs_tvs = [a], abs_ev_vars = [d:Ord a]
1804 , abs_exports
1805 = ABExport { (>) :: forall a. Ord a => T a -> T a -> Bool
1806 , gr_lcl :: T a -> T a -> Bool }
1807 , abs_binds
1808 = AbsBind { abs_tvs = [], abs_ev_vars = []
1809 , abs_exports = ABExport { gr_lcl :: T a -> T a -> Bool
1810 , gr_inner :: forall b. b -> b -> Bool }
1811 , abs_binds = AbsBind { abs_tvs = [b], abs_ev_vars = []
1812 , ..etc.. }
1813 } }
1814
1815 Wow! Three nested AbsBinds!
1816 * The outer one abstracts over the tyvars and dicts for the instance
1817 * The middle one is only present if there is an instance signature,
1818 and does the impedance matching for that signature
1819 * The inner one is for the method binding itself against either the
1820 signature from the class, or the instance signature.
1821 -}
1822
1823 ----------------------
1824 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> [LTcSpecPrag] -> TcSpecPrags
1825 -- Adapt the 'SPECIALISE instance' pragmas to work for this method Id
1826 -- There are two sources:
1827 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
1828 -- * spec_prags_from_inst: derived from {-# SPECIALISE instance :: <blah> #-}
1829 -- These ones have the dfun inside, but [perhaps surprisingly]
1830 -- the correct wrapper.
1831 -- See Note [Handling SPECIALISE pragmas] in TcBinds
1832 mk_meth_spec_prags meth_id spec_inst_prags spec_prags_for_me
1833 = SpecPrags (spec_prags_for_me ++ spec_prags_from_inst)
1834 where
1835 spec_prags_from_inst
1836 | isInlinePragma (idInlinePragma meth_id)
1837 = [] -- Do not inherit SPECIALISE from the instance if the
1838 -- method is marked INLINE, because then it'll be inlined
1839 -- and the specialisation would do nothing. (Indeed it'll provoke
1840 -- a warning from the desugarer
1841 | otherwise
1842 = [ L inst_loc (SpecPrag meth_id wrap inl)
1843 | L inst_loc (SpecPrag _ wrap inl) <- spec_inst_prags]
1844
1845
1846 mkDefMethBind :: Class -> [Type] -> Id -> Name
1847 -> TcM (LHsBind GhcRn, [LSig GhcRn])
1848 -- The is a default method (vanailla or generic) defined in the class
1849 -- So make a binding op = $dmop @t1 @t2
1850 -- where $dmop is the name of the default method in the class,
1851 -- and t1,t2 are the instance types.
1852 -- See Note [Default methods in instances] for why we use
1853 -- visible type application here
1854 mkDefMethBind clas inst_tys sel_id dm_name
1855 = do { dflags <- getDynFlags
1856 ; dm_id <- tcLookupId dm_name
1857 ; let inline_prag = idInlinePragma dm_id
1858 inline_prags | isAnyInlinePragma inline_prag
1859 = [noLoc (InlineSig noExt fn inline_prag)]
1860 | otherwise
1861 = []
1862 -- Copy the inline pragma (if any) from the default method
1863 -- to this version. Note [INLINE and default methods]
1864
1865 fn = noLoc (idName sel_id)
1866 visible_inst_tys = [ ty | (tcb, ty) <- tyConBinders (classTyCon clas) `zip` inst_tys
1867 , tyConBinderArgFlag tcb /= Inferred ]
1868 rhs = foldl' mk_vta (nlHsVar dm_name) visible_inst_tys
1869 bind = noLoc $ mkTopFunBind Generated fn $
1870 [mkSimpleMatch (mkPrefixFunRhs fn) [] rhs]
1871
1872 ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body"
1873 (vcat [ppr clas <+> ppr inst_tys,
1874 nest 2 (ppr sel_id <+> equals <+> ppr rhs)]))
1875
1876 ; return (bind, inline_prags) }
1877 where
1878 mk_vta :: LHsExpr GhcRn -> Type -> LHsExpr GhcRn
1879 mk_vta fun ty = noLoc (HsAppType noExt fun (mkEmptyWildCardBndrs $ nlHsParTy
1880 $ noLoc $ XHsType $ NHsCoreTy ty))
1881 -- NB: use visible type application
1882 -- See Note [Default methods in instances]
1883
1884 ----------------------
1885 derivBindCtxt :: Id -> Class -> [Type ] -> SDoc
1886 derivBindCtxt sel_id clas tys
1887 = vcat [ text "When typechecking the code for" <+> quotes (ppr sel_id)
1888 , nest 2 (text "in a derived instance for"
1889 <+> quotes (pprClassPred clas tys) <> colon)
1890 , nest 2 $ text "To see the code I am typechecking, use -ddump-deriv" ]
1891
1892 warnUnsatisfiedMinimalDefinition :: ClassMinimalDef -> TcM ()
1893 warnUnsatisfiedMinimalDefinition mindef
1894 = do { warn <- woptM Opt_WarnMissingMethods
1895 ; warnTc (Reason Opt_WarnMissingMethods) warn message
1896 }
1897 where
1898 message = vcat [text "No explicit implementation for"
1899 ,nest 2 $ pprBooleanFormulaNice mindef
1900 ]
1901
1902 {-
1903 Note [Export helper functions]
1904 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1905 We arrange to export the "helper functions" of an instance declaration,
1906 so that they are not subject to preInlineUnconditionally, even if their
1907 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1908 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1909 non-variable for them.
1910
1911 We could change this by making DFunUnfoldings have CoreExprs, but it
1912 seems a bit simpler this way.
1913
1914 Note [Default methods in instances]
1915 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1916 Consider this
1917
1918 class Baz v x where
1919 foo :: x -> x
1920 foo y = <blah>
1921
1922 instance Baz Int Int
1923
1924 From the class decl we get
1925
1926 $dmfoo :: forall v x. Baz v x => x -> x
1927 $dmfoo y = <blah>
1928
1929 Notice that the type is ambiguous. So we use Visible Type Application
1930 to disambiguate:
1931
1932 $dBazIntInt = MkBaz fooIntInt
1933 fooIntInt = $dmfoo @Int @Int
1934
1935 Lacking VTA we'd get ambiguity errors involving the default method. This applies
1936 equally to vanilla default methods (Trac #1061) and generic default methods
1937 (Trac #12220).
1938
1939 Historical note: before we had VTA we had to generate
1940 post-type-checked code, which took a lot more code, and didn't work for
1941 generic default methods.
1942
1943 Note [INLINE and default methods]
1944 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1945 Default methods need special case. They are supposed to behave rather like
1946 macros. For example
1947
1948 class Foo a where
1949 op1, op2 :: Bool -> a -> a
1950
1951 {-# INLINE op1 #-}
1952 op1 b x = op2 (not b) x
1953
1954 instance Foo Int where
1955 -- op1 via default method
1956 op2 b x = <blah>
1957
1958 The instance declaration should behave
1959
1960 just as if 'op1' had been defined with the
1961 code, and INLINE pragma, from its original
1962 definition.
1963
1964 That is, just as if you'd written
1965
1966 instance Foo Int where
1967 op2 b x = <blah>
1968
1969 {-# INLINE op1 #-}
1970 op1 b x = op2 (not b) x
1971
1972 So for the above example we generate:
1973
1974 {-# INLINE $dmop1 #-}
1975 -- $dmop1 has an InlineCompulsory unfolding
1976 $dmop1 d b x = op2 d (not b) x
1977
1978 $fFooInt = MkD $cop1 $cop2
1979
1980 {-# INLINE $cop1 #-}
1981 $cop1 = $dmop1 $fFooInt
1982
1983 $cop2 = <blah>
1984
1985 Note carefully:
1986
1987 * We *copy* any INLINE pragma from the default method $dmop1 to the
1988 instance $cop1. Otherwise we'll just inline the former in the
1989 latter and stop, which isn't what the user expected
1990
1991 * Regardless of its pragma, we give the default method an
1992 unfolding with an InlineCompulsory source. That means
1993 that it'll be inlined at every use site, notably in
1994 each instance declaration, such as $cop1. This inlining
1995 must happen even though
1996 a) $dmop1 is not saturated in $cop1
1997 b) $cop1 itself has an INLINE pragma
1998
1999 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
2000 recursion between $fooInt and $cop1 to be broken
2001
2002 * To communicate the need for an InlineCompulsory to the desugarer
2003 (which makes the Unfoldings), we use the IsDefaultMethod constructor
2004 in TcSpecPrags.
2005
2006
2007 ************************************************************************
2008 * *
2009 Specialise instance pragmas
2010 * *
2011 ************************************************************************
2012
2013 Note [SPECIALISE instance pragmas]
2014 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
2015 Consider
2016
2017 instance (Ix a, Ix b) => Ix (a,b) where
2018 {-# SPECIALISE instance Ix (Int,Int) #-}
2019 range (x,y) = ...
2020
2021 We make a specialised version of the dictionary function, AND
2022 specialised versions of each *method*. Thus we should generate
2023 something like this:
2024
2025 $dfIxPair :: (Ix a, Ix b) => Ix (a,b)
2026 {-# DFUN [$crangePair, ...] #-}
2027 {-# SPECIALISE $dfIxPair :: Ix (Int,Int) #-}
2028 $dfIxPair da db = Ix ($crangePair da db) (...other methods...)
2029
2030 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
2031 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
2032 $crange da db = <blah>
2033
2034 The SPECIALISE pragmas are acted upon by the desugarer, which generate
2035
2036 dii :: Ix Int
2037 dii = ...
2038
2039 $s$dfIxPair :: Ix ((Int,Int),(Int,Int))
2040 {-# DFUN [$crangePair di di, ...] #-}
2041 $s$dfIxPair = Ix ($crangePair di di) (...)
2042
2043 {-# RULE forall (d1,d2:Ix Int). $dfIxPair Int Int d1 d2 = $s$dfIxPair #-}
2044
2045 $s$crangePair :: ((Int,Int),(Int,Int)) -> [(Int,Int)]
2046 $c$crangePair = ...specialised RHS of $crangePair...
2047
2048 {-# RULE forall (d1,d2:Ix Int). $crangePair Int Int d1 d2 = $s$crangePair #-}
2049
2050 Note that
2051
2052 * The specialised dictionary $s$dfIxPair is very much needed, in case we
2053 call a function that takes a dictionary, but in a context where the
2054 specialised dictionary can be used. See Trac #7797.
2055
2056 * The ClassOp rule for 'range' works equally well on $s$dfIxPair, because
2057 it still has a DFunUnfolding. See Note [ClassOp/DFun selection]
2058
2059 * A call (range ($dfIxPair Int Int d1 d2)) might simplify two ways:
2060 --> {ClassOp rule for range} $crangePair Int Int d1 d2
2061 --> {SPEC rule for $crangePair} $s$crangePair
2062 or thus:
2063 --> {SPEC rule for $dfIxPair} range $s$dfIxPair
2064 --> {ClassOpRule for range} $s$crangePair
2065 It doesn't matter which way.
2066
2067 * We want to specialise the RHS of both $dfIxPair and $crangePair,
2068 but the SAME HsWrapper will do for both! We can call tcSpecPrag
2069 just once, and pass the result (in spec_inst_info) to tcMethods.
2070 -}
2071
2072 tcSpecInstPrags :: DFunId -> InstBindings GhcRn
2073 -> TcM ([Located TcSpecPrag], TcPragEnv)
2074 tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags })
2075 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
2076 filter isSpecInstLSig uprags
2077 -- The filter removes the pragmas for methods
2078 ; return (spec_inst_prags, mkPragEnv uprags binds) }
2079
2080 ------------------------------
2081 tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag
2082 tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty)
2083 = addErrCtxt (spec_ctxt prag) $
2084 do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty
2085 ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty
2086 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
2087 where
2088 spec_ctxt prag = hang (text "In the SPECIALISE pragma") 2 (ppr prag)
2089
2090 tcSpecInst _ _ = panic "tcSpecInst"
2091
2092 {-
2093 ************************************************************************
2094 * *
2095 \subsection{Error messages}
2096 * *
2097 ************************************************************************
2098 -}
2099
2100 instDeclCtxt1 :: LHsSigType GhcRn -> SDoc
2101 instDeclCtxt1 hs_inst_ty
2102 = inst_decl_ctxt (ppr (getLHsInstDeclHead hs_inst_ty))
2103
2104 instDeclCtxt2 :: Type -> SDoc
2105 instDeclCtxt2 dfun_ty
2106 = inst_decl_ctxt (ppr (mkClassPred cls tys))
2107 where
2108 (_,_,cls,tys) = tcSplitDFunTy dfun_ty
2109
2110 inst_decl_ctxt :: SDoc -> SDoc
2111 inst_decl_ctxt doc = hang (text "In the instance declaration for")
2112 2 (quotes doc)
2113
2114 badBootFamInstDeclErr :: SDoc
2115 badBootFamInstDeclErr
2116 = text "Illegal family instance in hs-boot file"
2117
2118 notFamily :: TyCon -> SDoc
2119 notFamily tycon
2120 = vcat [ text "Illegal family instance for" <+> quotes (ppr tycon)
2121 , nest 2 $ parens (ppr tycon <+> text "is not an indexed type family")]
2122
2123 assocInClassErr :: TyCon -> SDoc
2124 assocInClassErr name
2125 = text "Associated type" <+> quotes (ppr name) <+>
2126 text "must be inside a class instance"
2127
2128 badFamInstDecl :: TyCon -> SDoc
2129 badFamInstDecl tc_name
2130 = vcat [ text "Illegal family instance for" <+>
2131 quotes (ppr tc_name)
2132 , nest 2 (parens $ text "Use TypeFamilies to allow indexed type families") ]
2133
2134 notOpenFamily :: TyCon -> SDoc
2135 notOpenFamily tc
2136 = text "Illegal instance for closed family" <+> quotes (ppr tc)