2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 TcInstDecls: Typechecking instance declarations
9 module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
15 import TcPat( addInlinePrags )
16 import TcSimplify( simplifyTop )
24 import MkCore ( nO_METHOD_BINDING_ERROR_ID )
27 import RnSource ( addTcgDUs )
37 import CoreUtils ( mkPiTypes )
38 import CoreUnfold ( mkDFunUnfolding )
39 import CoreSyn ( Expr(Var), DFunArg(..), CoreExpr )
52 import Maybes ( orElse )
57 #include "HsVersions.h"
60 Typechecking instance declarations is done in two passes. The first
61 pass, made by @tcInstDecls1@, collects information to be used in the
64 This pre-processed info includes the as-yet-unprocessed bindings
65 inside the instance declaration. These are type-checked in the second
66 pass, when the class-instance envs and GVE contain all the info from
67 all the instance and value decls. Indeed that's the reason we need
68 two passes over the instance decls.
71 Note [How instance declarations are translated]
72 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
73 Here is how we translation instance declarations into Core
77 op1, op2 :: Ix b => a -> b -> b
81 {-# INLINE [2] op1 #-}
85 op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
89 -- Default methods get the 'self' dictionary as argument
90 -- so they can call other methods at the same type
91 -- Default methods get the same type as their method selector
92 $dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
93 $dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dm-rhs>
94 -- NB: type variables 'a' and 'b' are *both* in scope in <dm-rhs>
95 -- Note [Tricky type variable scoping]
97 -- A top-level definition for each instance method
98 -- Here op1_i, op2_i are the "instance method Ids"
99 -- The INLINE pragma comes from the user pragma
100 {-# INLINE [2] op1_i #-} -- From the instance decl bindings
101 op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
102 op1_i = /\a. \(d:C a).
105 -- Note [Subtle interaction of recursion and overlap]
107 local_op1 :: forall b. Ix b => [a] -> b -> b
109 -- Source code; run the type checker on this
110 -- NB: Type variable 'a' (but not 'b') is in scope in <rhs>
111 -- Note [Tricky type variable scoping]
115 op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
117 -- The dictionary function itself
118 {-# NOINLINE CONLIKE df_i #-} -- Never inline dictionary functions
119 df_i :: forall a. C a -> C [a]
120 df_i = /\a. \d:C a. MkC (op1_i a d) (op2_i a d)
121 -- But see Note [Default methods in instances]
122 -- We can't apply the type checker to the default-method call
124 -- Use a RULE to short-circuit applications of the class ops
125 {-# RULE "op1@C[a]" forall a, d:C a.
126 op1 [a] (df_i d) = op1_i a d #-}
128 Note [Instances and loop breakers]
129 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
130 * Note that df_i may be mutually recursive with both op1_i and op2_i.
131 It's crucial that df_i is not chosen as the loop breaker, even
132 though op1_i has a (user-specified) INLINE pragma.
134 * Instead the idea is to inline df_i into op1_i, which may then select
135 methods from the MkC record, and thereby break the recursion with
136 df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
137 the same type, it won't mention df_i, so there won't be recursion in
140 * If op1_i is marked INLINE by the user there's a danger that we won't
141 inline df_i in it, and that in turn means that (since it'll be a
142 loop-breaker because df_i isn't), op1_i will ironically never be
143 inlined. But this is OK: the recursion breaking happens by way of
144 a RULE (the magic ClassOp rule above), and RULES work inside InlineRule
145 unfoldings. See Note [RULEs enabled in SimplGently] in SimplUtils
147 Note [ClassOp/DFun selection]
148 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
149 One thing we see a lot is stuff like
151 where 'op2' is a ClassOp and 'df' is DFun. Now, we could inline *both*
152 'op2' and 'df' to get
153 case (MkD ($cop1 d1 d2) ($cop2 d1 d2) ... of
154 MkD _ op2 _ _ _ -> op2
155 And that will reduce to ($cop2 d1 d2) which is what we wanted.
157 But it's tricky to make this work in practice, because it requires us to
158 inline both 'op2' and 'df'. But neither is keen to inline without having
159 seen the other's result; and it's very easy to get code bloat (from the
160 big intermediate) if you inline a bit too much.
162 Instead we use a cunning trick.
163 * We arrange that 'df' and 'op2' NEVER inline.
165 * We arrange that 'df' is ALWAYS defined in the sylised form
166 df d1 d2 = MkD ($cop1 d1 d2) ($cop2 d1 d2) ...
168 * We give 'df' a magical unfolding (DFunUnfolding [$cop1, $cop2, ..])
169 that lists its methods.
171 * We make CoreUnfold.exprIsConApp_maybe spot a DFunUnfolding and return
172 a suitable constructor application -- inlining df "on the fly" as it
175 * We give the ClassOp 'op2' a BuiltinRule that extracts the right piece
176 iff its argument satisfies exprIsConApp_maybe. This is done in
179 * We make 'df' CONLIKE, so that shared uses stil match; eg
181 in ...(op2 d)...(op1 d)...
183 Note [Single-method classes]
184 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
185 If the class has just one method (or, more accurately, just one element
186 of {superclasses + methods}), then we still use the *same* strategy
188 class C a where op :: a -> a
189 instance C a => C [a] where op = <blah>
191 We translate the class decl into a newtype, which just gives
194 axiom Co:C a :: C a ~ (a->a)
196 op :: forall a. C a -> (a -> a)
197 op a d = d |> (Co:C a)
199 MkC :: forall a. (a->a) -> C a
200 MkC = /\a.\op. op |> (sym Co:C a)
202 df :: forall a. C a => C [a]
203 {-# NOINLINE df DFun[ $cop_list ] #-}
204 df = /\a. \d. MkC ($cop_list a d)
206 $cop_list :: forall a. C a => [a] -> [a]
209 The "constructor" MkC expands to a cast, as does the class-op selector.
210 The RULE works just like for multi-field dictionaries:
212 * (df a d) returns (Just (MkC,..,[$cop_list a d]))
213 to exprIsConApp_Maybe
215 * The RULE for op picks the right result
217 This is a bit of a hack, because (df a d) isn't *really* a constructor
218 application. But it works just fine in this case, exprIsConApp_maybe
219 is otherwise used only when we hit a case expression which will have
220 a real data constructor in it.
222 The biggest reason for doing it this way, apart from uniformity, is
223 that we want to be very careful when we have
224 instance C a => C [a] where
227 then we'll get an INLINE pragma on $cop_list but it's important that
228 $cop_list only inlines when it's applied to *two* arguments (the
229 dictionary and the list argument
231 The danger is that we'll get something like
232 op_list :: C a => [a] -> [a]
233 op_list = /\a.\d. $cop_list a d
234 and then we'll eta expand, and then we'll inline TOO EARLY. This happened in
235 Trac #3772 and I spent far too long fiddling around trying to fix it.
236 Look at the test for Trac #3772.
238 (Note: re-reading the above, I can't see how using the
239 uniform story solves the problem.)
241 Note [Subtle interaction of recursion and overlap]
242 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
244 class C a where { op1,op2 :: a -> a }
245 instance C a => C [a] where
246 op1 x = op2 x ++ op2 x
248 instance C [Int] where
251 When type-checking the C [a] instance, we need a C [a] dictionary (for
252 the call of op2). If we look up in the instance environment, we find
253 an overlap. And in *general* the right thing is to complain (see Note
254 [Overlapping instances] in InstEnv). But in *this* case it's wrong to
255 complain, because we just want to delegate to the op2 of this same
258 Why is this justified? Because we generate a (C [a]) constraint in
259 a context in which 'a' cannot be instantiated to anything that matches
260 other overlapping instances, or else we would not be excecuting this
261 version of op1 in the first place.
263 It might even be a bit disguised:
265 nullFail :: C [a] => [a] -> [a]
266 nullFail x = op2 x ++ op2 x
268 instance C a => C [a] where
271 Precisely this is used in package 'regex-base', module Context.hs.
272 See the overlapping instances for RegexContext, and the fact that they
273 call 'nullFail' just like the example above. The DoCon package also
274 does the same thing; it shows up in module Fraction.hs
276 Conclusion: when typechecking the methods in a C [a] instance, we want to
277 treat the 'a' as an *existential* type variable, in the sense described
278 by Note [Binding when looking up instances]. That is why isOverlappableTyVar
279 responds True to an InstSkol, which is the kind of skolem we use in
283 Note [Tricky type variable scoping]
284 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
287 op1, op2 :: Ix b => a -> b -> b
290 instance C a => C [a]
291 {-# INLINE [2] op1 #-}
294 note that 'a' and 'b' are *both* in scope in <dm-rhs>, but only 'a' is
295 in scope in <rhs>. In particular, we must make sure that 'b' is in
296 scope when typechecking <dm-rhs>. This is achieved by subFunTys,
297 which brings appropriate tyvars into scope. This happens for both
298 <dm-rhs> and for <rhs>, but that doesn't matter: the *renamer* will have
299 complained if 'b' is mentioned in <rhs>.
303 %************************************************************************
305 \subsection{Extracting instance decls}
307 %************************************************************************
309 Gather up the instance declarations from their various sources
312 tcInstDecls1 -- Deal with both source-code and imported instance decls
313 :: [LTyClDecl Name] -- For deriving stuff
314 -> [LInstDecl Name] -- Source code instance decls
315 -> [LDerivDecl Name] -- Source code stand-alone deriving decls
316 -> TcM (TcGblEnv, -- The full inst env
317 [InstInfo Name], -- Source-code instance decls to process;
318 -- contains all dfuns for this module
319 HsValBinds Name) -- Supporting bindings for derived instances
321 tcInstDecls1 tycl_decls inst_decls deriv_decls
323 do { -- Stop if addInstInfos etc discovers any errors
324 -- (they recover, so that we get more than one error each
327 -- (1) Do class and family instance declarations
328 ; idx_tycons <- mapAndRecoverM (tcFamInstDecl TopLevel) $
329 filter (isFamInstDecl . unLoc) tycl_decls
330 ; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
333 at_tycons_s) = unzip local_info_tycons
334 ; at_idx_tycons = concat at_tycons_s ++ idx_tycons
335 ; clas_decls = filter (isClassDecl.unLoc) tycl_decls
336 ; implicit_things = concatMap implicitTyThings at_idx_tycons
337 ; aux_binds = mkRecSelBinds at_idx_tycons
340 -- (2) Add the tycons of indexed types and their implicit
341 -- tythings to the global environment
342 ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
344 -- (3) Instances from generic class declarations
345 ; generic_inst_info <- getGenericInstances clas_decls
347 -- Next, construct the instance environment so far, consisting
349 -- (a) local instance decls
350 -- (b) generic instances
351 -- (c) local family instance decls
352 ; addInsts local_info $
353 addInsts generic_inst_info $
354 addFamInsts at_idx_tycons $ do {
356 -- (4) Compute instances from "deriving" clauses;
357 -- This stuff computes a context for the derived instance
358 -- decl, so it needs to know about all the instances possible
359 -- NB: class instance declarations can contain derivings as
360 -- part of associated data type declarations
361 failIfErrsM -- If the addInsts stuff gave any errors, don't
362 -- try the deriving stuff, becuase that may give
364 ; (deriv_inst_info, deriv_binds, deriv_dus)
365 <- tcDeriving tycl_decls inst_decls deriv_decls
366 ; gbl_env <- addInsts deriv_inst_info getGblEnv
367 ; return ( addTcgDUs gbl_env deriv_dus,
368 generic_inst_info ++ deriv_inst_info ++ local_info,
369 aux_binds `plusHsValBinds` deriv_binds)
372 addInsts :: [InstInfo Name] -> TcM a -> TcM a
373 addInsts infos thing_inside
374 = tcExtendLocalInstEnv (map iSpec infos) thing_inside
376 addFamInsts :: [TyThing] -> TcM a -> TcM a
377 addFamInsts tycons thing_inside
378 = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
380 mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
381 mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
386 tcLocalInstDecl1 :: LInstDecl Name
387 -> TcM (InstInfo Name, [TyThing])
388 -- A source-file instance declaration
389 -- Type-check all the stuff before the "where"
391 -- We check for respectable instance type, and context
392 tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
394 addErrCtxt (instDeclCtxt1 poly_ty) $
396 do { is_boot <- tcIsHsBoot
397 ; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
400 ; (tyvars, theta, clas, inst_tys) <- tcHsInstHead poly_ty
401 ; checkValidInstance poly_ty tyvars theta clas inst_tys
403 -- Next, process any associated types.
404 ; idx_tycons <- recoverM (return []) $
405 do { idx_tycons <- checkNoErrs $
406 mapAndRecoverM (tcFamInstDecl NotTopLevel) ats
407 ; checkValidAndMissingATs clas (tyvars, inst_tys)
409 ; return idx_tycons }
411 -- Finally, construct the Core representation of the instance.
412 -- (This no longer includes the associated types.)
413 ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
414 -- Dfun location is that of instance *header*
415 ; overlap_flag <- getOverlapFlag
416 ; let (eq_theta,dict_theta) = partition isEqPred theta
417 theta' = eq_theta ++ dict_theta
418 dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
419 ispec = mkLocalInstance dfun overlap_flag
421 ; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False },
425 -- We pass in the source form and the type checked form of the ATs. We
426 -- really need the source form only to be able to produce more informative
428 checkValidAndMissingATs :: Class
429 -> ([TyVar], [TcType]) -- instance types
430 -> [(LTyClDecl Name, -- source form of AT
431 TyThing)] -- Core form of AT
433 checkValidAndMissingATs clas inst_tys ats
434 = do { -- Issue a warning for each class AT that is not defined in this
436 ; let class_ats = map tyConName (classATs clas)
437 defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
438 omitted = filterOut (`elemNameSet` defined_ats) class_ats
439 ; warn <- doptM Opt_WarnMissingMethods
440 ; mapM_ (warnTc warn . omittedATWarn) omitted
442 -- Ensure that all AT indexes that correspond to class parameters
443 -- coincide with the types in the instance head. All remaining
444 -- AT arguments must be variables. Also raise an error for any
445 -- type instances that are not associated with this class.
446 ; mapM_ (checkIndexes clas inst_tys) ats
449 checkIndexes clas inst_tys (hsAT, ATyCon tycon)
450 -- !!!TODO: check that this does the Right Thing for indexed synonyms, too!
451 = checkIndexes' clas inst_tys hsAT
453 snd . fromJust . tyConFamInst_maybe $ tycon)
454 checkIndexes _ _ _ = panic "checkIndexes"
456 checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
457 = let atName = tcdName . unLoc $ hsAT
459 setSrcSpan (getLoc hsAT) $
460 addErrCtxt (atInstCtxt atName) $
461 case find ((atName ==) . tyConName) (classATs clas) of
462 Nothing -> addErrTc $ badATErr clas atName -- not in this class
464 -- The following is tricky! We need to deal with three
465 -- complications: (1) The AT possibly only uses a subset of
466 -- the class parameters as indexes and those it uses may be in
467 -- a different order; (2) the AT may have extra arguments,
468 -- which must be type variables; and (3) variables in AT and
469 -- instance head will be different `Name's even if their
470 -- source lexemes are identical.
472 -- e.g. class C a b c where
473 -- data D b a :: * -> * -- NB (1) b a, omits c
474 -- instance C [x] Bool Char where
475 -- data D Bool [x] v = MkD x [v] -- NB (2) v
476 -- -- NB (3) the x in 'instance C...' have differnt
477 -- -- Names to x's in 'data D...'
479 -- Re (1), `poss' contains a permutation vector to extract the
480 -- class parameters in the right order.
482 -- Re (2), we wrap the (permuted) class parameters in a Maybe
483 -- type and use Nothing for any extra AT arguments. (First
484 -- equation of `checkIndex' below.)
486 -- Re (3), we replace any type variable in the AT parameters
487 -- that has the same source lexeme as some variable in the
488 -- instance types with the instance type variable sharing its
492 -- For *associated* type families, gives the position
493 -- of that 'TyVar' in the class argument list (0-indexed)
494 -- e.g. class C a b c where { type F c a :: *->* }
495 -- Then we get Just [2,0]
496 poss = catMaybes [ tv `elemIndex` classTyVars clas
497 | tv <- tyConTyVars atycon]
498 -- We will get Nothings for the "extra" type
499 -- variables in an associated data type
500 -- e.g. class C a where { data D a :: *->* }
501 -- here D gets arity 2 and has two tyvars
503 relevantInstTys = map (instTys !!) poss
504 instArgs = map Just relevantInstTys ++
505 repeat Nothing -- extra arguments
506 renaming = substSameTyVar atTvs instTvs
508 zipWithM_ checkIndex (substTys renaming atTys) instArgs
510 checkIndex ty Nothing
511 | isTyVarTy ty = return ()
512 | otherwise = addErrTc $ mustBeVarArgErr ty
513 checkIndex ty (Just instTy)
514 | ty `tcEqType` instTy = return ()
515 | otherwise = addErrTc $ wrongATArgErr ty instTy
517 listToNameSet = addListToNameSet emptyNameSet
519 substSameTyVar [] _ = emptyTvSubst
520 substSameTyVar (tv:tvs) replacingTvs =
521 let replacement = case find (tv `sameLexeme`) replacingTvs of
522 Nothing -> mkTyVarTy tv
523 Just rtv -> mkTyVarTy rtv
525 tv1 `sameLexeme` tv2 =
526 nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
528 extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
532 %************************************************************************
534 Type-checking instance declarations, pass 2
536 %************************************************************************
539 tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
541 -- (a) From each class declaration,
542 -- generate any default-method bindings
543 -- (b) From each instance decl
544 -- generate the dfun binding
546 tcInstDecls2 tycl_decls inst_decls
547 = do { -- (a) Default methods from class decls
548 let class_decls = filter (isClassDecl . unLoc) tycl_decls
549 ; dm_binds_s <- mapM tcClassDecl2 class_decls
550 ; let dm_binds = unionManyBags dm_binds_s
552 -- (b) instance declarations
553 ; let dm_ids = collectHsBindsBinders dm_binds
554 -- Add the default method Ids (again)
555 -- See Note [Default methods and instances]
556 ; inst_binds_s <- tcExtendIdEnv dm_ids $
557 mapM tcInstDecl2 inst_decls
560 ; return (dm_binds `unionBags` unionManyBags inst_binds_s) }
563 See Note [Default methods and instances]
564 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
565 The default method Ids are already in the type environment (see Note
566 [Default method Ids and Template Haskell] in TcTyClsDcls), BUT they
567 don't have their InlinePragmas yet. Usually that would not matter,
568 because the simplifier propagates information from binding site to
569 use. But, unusually, when compiling instance decls we *copy* the
570 INLINE pragma from the default method to the method for that
571 particular operation (see Note [INLINE and default methods] below).
573 So right here in tcInstDecl2 we must re-extend the type envt with
574 the default method Ids replete with their INLINE pragmas. Urk.
578 tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
579 -- Returns a binding for the dfun
580 tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
581 = recoverM (return emptyLHsBinds) $
583 addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
584 do { -- Instantiate the instance decl with skolem constants
585 ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolSigType skol_info (idType dfun_id)
586 ; let (clas, inst_tys) = tcSplitDFunHead inst_head
587 (class_tyvars, sc_theta, _, op_items) = classBigSig clas
588 sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta
589 n_ty_args = length inst_tyvars
590 n_silent = dfunNSilent dfun_id
591 (silent_theta, orig_theta) = splitAt n_silent dfun_theta
593 ; silent_ev_vars <- mapM newSilentGiven silent_theta
594 ; orig_ev_vars <- newEvVars orig_theta
595 ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars
597 ; (sc_binds, sc_dicts, sc_args)
598 <- mapAndUnzip3M (tcSuperClass n_ty_args dfun_ev_vars) sc_theta'
600 -- Check that any superclasses gotten from a silent arguemnt
601 -- can be deduced from the originally-specified dfun arguments
602 ; ct_loc <- getCtLoc ScOrigin
603 ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $
604 emitConstraints $ listToBag $
605 [ WcEvVar (WantedEvVar sc ct_loc)
606 | sc <- sc_dicts, isSilentEvVar sc ]
608 -- Deal with 'SPECIALISE instance' pragmas
609 -- See Note [SPECIALISE instance pragmas]
610 ; spec_info <- tcSpecInstPrags dfun_id ibinds
612 -- Typecheck the methods
613 ; (meth_ids, meth_binds)
614 <- tcExtendTyVarEnv inst_tyvars $
615 -- The inst_tyvars scope over the 'where' part
616 -- Those tyvars are inside the dfun_id's type, which is a bit
617 -- bizarre, but OK so long as you realise it!
618 tcInstanceMethods dfun_id clas inst_tyvars dfun_ev_vars
622 -- Create the result bindings
623 ; self_dict <- newEvVar (ClassP clas inst_tys)
624 ; let dict_constr = classDataCon clas
625 dict_bind = mkVarBind self_dict dict_rhs
626 dict_rhs = foldl mk_app inst_constr $
627 map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids
628 inst_constr = L loc $ wrapId (mkWpTyApps inst_tys)
629 (dataConWrapId dict_constr)
630 -- We don't produce a binding for the dict_constr; instead we
631 -- rely on the simplifier to unfold this saturated application
632 -- We do this rather than generate an HsCon directly, because
633 -- it means that the special cases (e.g. dictionary with only one
634 -- member) are dealt with by the common MkId.mkDataConWrapId code rather
635 -- than needing to be repeated here.
637 mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id
638 mk_app fun arg = L loc (HsApp fun (L loc arg))
640 arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars)
642 -- Do not inline the dfun; instead give it a magic DFunFunfolding
643 -- See Note [ClassOp/DFun selection]
644 -- See also note [Single-method classes]
645 dfun_id_w_fun = dfun_id
646 `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args)
647 `setInlinePragma` dfunInlinePragma
648 meth_args = map (DFunPolyArg . Var) meth_ids
650 main_bind = AbsBinds { abs_tvs = inst_tyvars
651 , abs_ev_vars = dfun_ev_vars
652 , abs_exports = [(inst_tyvars, dfun_id_w_fun, self_dict,
653 SpecPrags [] {- spec_inst_prags -})]
654 , abs_ev_binds = emptyTcEvBinds
655 , abs_binds = unitBag dict_bind }
657 ; return (unitBag (L loc main_bind) `unionBags`
658 unionManyBags sc_binds `unionBags`
659 listToBag meth_binds)
662 skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap]
663 dfun_ty = idType dfun_id
664 dfun_id = instanceDFunId ispec
665 loc = getSrcSpan dfun_id
667 ------------------------------
668 tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (LHsBinds Id, Id, DFunArg CoreExpr)
669 tcSuperClass n_ty_args ev_vars pred
670 | Just (ev, i) <- find n_ty_args ev_vars
671 = return (emptyBag, ev, DFunLamArg i)
673 = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred)
674 do { sc_dict <- newWantedEvVar pred
675 ; loc <- getCtLoc ScOrigin
676 ; ev_binds <- simplifyTop (unitBag (WcEvVar (WantedEvVar sc_dict loc)))
677 ; let ev_wrap = WpLet (EvBinds ev_binds)
678 sc_bind = mkVarBind sc_dict (noLoc $ (wrapId ev_wrap sc_dict))
679 ; return (unitBag sc_bind, sc_dict, DFunConstArg (Var sc_dict)) }
680 -- It's very important to solve the superclass constraint *in isolation*
681 -- so that it isn't generated by superclass selection from something else
682 -- We then generate the (also rather degenerate) top-level binding:
683 -- sc_dict = let sc_dict = <blah> in sc_dict
684 -- where <blah> is generated by solving the implication constraint
687 find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i)
688 | otherwise = find (i+1) evs
690 ------------------------------
691 tcSpecInstPrags :: DFunId -> InstBindings Name
692 -> TcM ([Located TcSpecPrag], PragFun)
693 tcSpecInstPrags _ (NewTypeDerived {})
694 = return ([], \_ -> [])
695 tcSpecInstPrags dfun_id (VanillaInst binds uprags _)
696 = do { spec_inst_prags <- mapM (wrapLocM (tcSpecInst dfun_id)) $
697 filter isSpecInstLSig uprags
698 -- The filter removes the pragmas for methods
699 ; return (spec_inst_prags, mkPragFun uprags binds) }
702 Note [Silent Superclass Arguments]
703 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
704 Consider the following (extreme) situation:
705 class C a => D a where ...
706 instance D [a] => D [a] where ...
707 Although this looks wrong (assume D [a] to prove D [a]), it is only a
708 more extreme case of what happens with recursive dictionaries.
710 To implement the dfun we must generate code for the superclass C [a],
711 which we can get by superclass selection from the supplied argument!
713 dfun :: forall a. D [a] -> D [a]
714 dfun = \d::D [a] -> MkD (scsel d) ..
716 However this means that if we later encounter a situation where
717 we have a [Wanted] dw::D [a] we could solve it thus:
719 Although recursive, this binding would pass the TcSMonadisGoodRecEv
720 check because it appears as guarded. But in reality, it will make a
721 bottom superclass. The trouble is that isGoodRecEv can't "see" the
722 superclass-selection inside dfun.
724 Our solution to this problem is to change the way ‘dfuns’ are created
725 for instances, so that we pass as first arguments to the dfun some
726 ``silent superclass arguments’’, which are the immediate superclasses
727 of the dictionary we are trying to construct. In our example:
728 dfun :: forall a. (C [a], D [a] -> D [a]
729 dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ...
733 -----------------------------------------------------------
734 DFun Superclass Invariant
735 ~~~~~~~~~~~~~~~~~~~~~~~~
736 In the body of a DFun, every superclass argument to the
737 returned dictionary is
738 either * one of the arguments of the DFun,
739 or * constant, bound at top level
740 -----------------------------------------------------------
742 This means that no superclass is hidden inside a dfun application, so
743 the counting argument in isGoodRecEv (more dfun calls than superclass
744 selections) works correctly.
746 The extra arguments required to satisfy the DFun Superclass Invariant
747 always come first, and are called the "silent" arguments. DFun types
748 are built (only) by MkId.mkDictFunId, so that is where we decide
749 what silent arguments are to be added.
751 This net effect is that it is safe to treat a dfun application as
752 wrapping a dictionary constructor around its arguments (in particular,
753 a dfun never picks superclasses from the arguments under the dictionary
756 In our example, if we had [Wanted] dw :: D [a] we would get via the instance:
758 [Wanted] (d1 :: C [a])
759 [Wanted] (d2 :: D [a])
760 [Derived] (d :: D [a])
761 [Derived] (scd :: C [a]) scd := scsel d
762 [Derived] (scd2 :: C [a]) scd2 := scsel d2
764 And now, though we *can* solve:
766 we will get an isGoodRecEv failure when we try to solve:
771 Test case SCLoop tests this fix.
773 Note [SPECIALISE instance pragmas]
774 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
777 instance (Ix a, Ix b) => Ix (a,b) where
778 {-# SPECIALISE instance Ix (Int,Int) #-}
781 We do *not* want to make a specialised version of the dictionary
782 function. Rather, we want specialised versions of each method.
783 Thus we should generate something like this:
785 $dfIx :: (Ix a, Ix x) => Ix (a,b)
786 {- DFUN [$crange, ...] -}
787 $dfIx da db = Ix ($crange da db) (...other methods...)
789 $dfIxPair :: (Ix a, Ix x) => Ix (a,b)
790 {- DFUN [$crangePair, ...] -}
791 $dfIxPair = Ix ($crangePair da db) (...other methods...)
793 $crange :: (Ix a, Ix b) -> ((a,b),(a,b)) -> [(a,b)]
794 {-# SPECIALISE $crange :: ((Int,Int),(Int,Int)) -> [(Int,Int)] #-}
795 $crange da db = <blah>
797 {-# RULE range ($dfIx da db) = $crange da db #-}
801 * The RULE is unaffected by the specialisation. We don't want to
802 specialise $dfIx, because then it would need a specialised RULE
803 which is a pain. The single RULE works fine at all specialisations.
804 See Note [How instance declarations are translated] above
806 * Instead, we want to specialise the *method*, $crange
808 In practice, rather than faking up a SPECIALISE pragama for each
809 method (which is painful, since we'd have to figure out its
810 specialised type), we call tcSpecPrag *as if* were going to specialise
811 $dfIx -- you can see that in the call to tcSpecInst. That generates a
812 SpecPrag which, as it turns out, can be used unchanged for each method.
813 The "it turns out" bit is delicate, but it works fine!
816 tcSpecInst :: Id -> Sig Name -> TcM TcSpecPrag
817 tcSpecInst dfun_id prag@(SpecInstSig hs_ty)
818 = addErrCtxt (spec_ctxt prag) $
819 do { let name = idName dfun_id
820 ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty
821 ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys
823 ; co_fn <- tcSubType (SpecPragOrigin name) (SigSkol SpecInstCtxt)
824 (idType dfun_id) spec_dfun_ty
825 ; return (SpecPrag dfun_id co_fn defaultInlinePragma) }
827 spec_ctxt prag = hang (ptext (sLit "In the SPECIALISE pragma")) 2 (ppr prag)
829 tcSpecInst _ _ = panic "tcSpecInst"
832 %************************************************************************
834 Type-checking an instance method
836 %************************************************************************
839 - Make the method bindings, as a [(NonRec, HsBinds)], one per method
840 - Remembering to use fresh Name (the instance method Name) as the binder
841 - Bring the instance method Ids into scope, for the benefit of tcInstSig
842 - Use sig_fn mapping instance method Name -> instance tyvars
844 - Use tcValBinds to do the checking
847 tcInstanceMethods :: DFunId -> Class -> [TcTyVar]
850 -> ([Located TcSpecPrag], PragFun)
853 -> TcM ([Id], [LHsBind Id])
854 -- The returned inst_meth_ids all have types starting
855 -- forall tvs. theta => ...
856 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
857 (spec_inst_prags, prag_fn)
858 op_items (VanillaInst binds _ standalone_deriv)
859 = mapAndUnzipM tc_item op_items
861 ----------------------
862 tc_item :: (Id, DefMeth) -> TcM (Id, LHsBind Id)
863 tc_item (sel_id, dm_info)
864 = case findMethodBind (idName sel_id) binds of
865 Just user_bind -> tc_body sel_id standalone_deriv user_bind
866 Nothing -> tc_default sel_id dm_info
868 ----------------------
869 tc_body :: Id -> Bool -> LHsBind Name -> TcM (TcId, LHsBind Id)
870 tc_body sel_id generated_code rn_bind
871 = add_meth_ctxt sel_id generated_code rn_bind $
872 do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
874 ; let prags = prag_fn (idName sel_id)
875 ; meth_id1 <- addInlinePrags meth_id prags
876 ; spec_prags <- tcSpecPrags meth_id1 prags
877 ; bind <- tcInstanceMethodBody InstSkol
879 meth_id1 local_meth_id meth_sig_fn
880 (mk_meth_spec_prags meth_id1 spec_prags)
882 ; return (meth_id1, bind) }
884 ----------------------
885 tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id)
886 tc_default sel_id GenDefMeth -- Derivable type classes stuff
887 = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id
888 ; tc_body sel_id False {- Not generated code? -} meth_bind }
890 tc_default sel_id NoDefMeth -- No default method at all
891 = do { warnMissingMethod sel_id
892 ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars
894 ; return (meth_id, mkVarBind meth_id $
895 mkLHsWrap lam_wrapper error_rhs) }
897 error_rhs = L loc $ HsApp error_fun error_msg
898 error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
899 error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
900 meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
901 error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
902 lam_wrapper = mkWpTyLams tyvars <.> mkWpLams dfun_ev_vars
904 tc_default sel_id (DefMeth dm_name) -- A polymorphic default method
905 = do { -- Build the typechecked version directly,
906 -- without calling typecheck_method;
907 -- see Note [Default methods in instances]
908 -- Generate /\as.\ds. let self = df as ds
909 -- in $dm inst_tys self
910 -- The 'let' is necessary only because HsSyn doesn't allow
911 -- you to apply a function to a dictionary *expression*.
913 ; self_dict <- newEvVar (ClassP clas inst_tys)
914 ; let self_ev_bind = EvBind self_dict $
915 EvDFunApp dfun_id (mkTyVarTys tyvars) dfun_ev_vars
917 ; (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
919 ; dm_id <- tcLookupId dm_name
920 ; let dm_inline_prag = idInlinePragma dm_id
921 rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $
924 meth_bind = L loc $ VarBind { var_id = local_meth_id
925 , var_rhs = L loc rhs
926 , var_inline = False }
927 meth_id1 = meth_id `setInlinePragma` dm_inline_prag
928 -- Copy the inline pragma (if any) from the default
929 -- method to this version. Note [INLINE and default methods]
931 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
932 , abs_exports = [( tyvars, meth_id1, local_meth_id
933 , mk_meth_spec_prags meth_id1 [])]
934 , abs_ev_binds = EvBinds (unitBag self_ev_bind)
935 , abs_binds = unitBag meth_bind }
936 -- Default methods in an instance declaration can't have their own
937 -- INLINE or SPECIALISE pragmas. It'd be possible to allow them, but
938 -- currently they are rejected with
939 -- "INLINE pragma lacks an accompanying binding"
941 ; return (meth_id1, L loc bind) }
943 ----------------------
944 mk_meth_spec_prags :: Id -> [LTcSpecPrag] -> TcSpecPrags
945 -- Adapt the SPECIALISE pragmas to work for this method Id
946 -- There are two sources:
947 -- * spec_inst_prags: {-# SPECIALISE instance :: <blah> #-}
948 -- These ones have the dfun inside, but [perhaps surprisingly]
949 -- the correct wrapper
950 -- * spec_prags_for_me: {-# SPECIALISE op :: <blah> #-}
951 mk_meth_spec_prags meth_id spec_prags_for_me
952 = SpecPrags (spec_prags_for_me ++
953 [ L loc (SpecPrag meth_id wrap inl)
954 | L loc (SpecPrag _ wrap inl) <- spec_inst_prags])
956 loc = getSrcSpan dfun_id
957 meth_sig_fn _ = Just ([],loc) -- The 'Just' says "yes, there's a type sig"
958 -- But there are no scoped type variables from local_method_id
959 -- Only the ones from the instance decl itself, which are already
960 -- in scope. Example:
961 -- class C a where { op :: forall b. Eq b => ... }
962 -- instance C [c] where { op = <rhs> }
963 -- In <rhs>, 'c' is scope but 'b' is not!
965 -- For instance decls that come from standalone deriving clauses
966 -- we want to print out the full source code if there's an error
967 -- because otherwise the user won't see the code at all
968 add_meth_ctxt sel_id generated_code rn_bind thing
969 | generated_code = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys rn_bind) thing
973 tcInstanceMethods dfun_id clas tyvars dfun_ev_vars inst_tys
974 _ op_items (NewTypeDerived coi _)
977 -- class Show b => Foo a b where
979 -- newtype N a = MkN (Tree [a])
980 -- deriving instance (Show p, Foo Int p) => Foo Int (N p)
981 -- -- NB: standalone deriving clause means
982 -- -- that the contex is user-specified
983 -- Hence op :: forall a b. Foo a b => a -> b -> b
985 -- We're going to make an instance like
986 -- instance (Show p, Foo Int p) => Foo Int (N p)
989 -- $copT :: forall p. (Show p, Foo Int p) => Int -> N p -> N p
990 -- $copT p (d1:Show p) (d2:Foo Int p)
991 -- = op Int (Tree [p]) rep_d |> op_co
993 -- rep_d :: Foo Int (Tree [p]) = ...d1...d2...
994 -- op_co :: (Int -> Tree [p] -> Tree [p]) ~ (Int -> T p -> T p)
995 -- We get op_co by substituting [Int/a] and [co/b] in type for op
996 -- where co : [p] ~ T p
998 -- Notice that the dictionary bindings "..d1..d2.." must be generated
999 -- by the constraint solver, since the <context> may be
1002 = do { rep_d_stuff <- checkConstraints InstSkol tyvars dfun_ev_vars $
1003 emitWanted ScOrigin rep_pred
1005 ; mapAndUnzipM (tc_item rep_d_stuff) op_items }
1007 loc = getSrcSpan dfun_id
1009 inst_tvs = fst (tcSplitForAllTys (idType dfun_id))
1010 Just (init_inst_tys, _) = snocView inst_tys
1011 rep_ty = fst (coercionKind co) -- [p]
1012 rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty])
1015 co = substTyWith inst_tvs (mkTyVarTys tyvars) $
1016 case coi of { IdCo ty -> ty ;
1017 ACo co -> mkSymCoercion co }
1020 tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId)
1021 tc_item (rep_ev_binds, rep_d) (sel_id, _)
1022 = do { (meth_id, local_meth_id) <- mkMethIds clas tyvars dfun_ev_vars
1025 ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id
1026 meth_bind = VarBind { var_id = local_meth_id
1027 , var_rhs = L loc meth_rhs
1028 , var_inline = False }
1030 bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars
1031 , abs_exports = [(tyvars, meth_id,
1032 local_meth_id, noSpecPrags)]
1033 , abs_ev_binds = rep_ev_binds
1034 , abs_binds = unitBag $ L loc meth_bind }
1036 ; return (meth_id, L loc bind) }
1039 mk_op_wrapper :: Id -> EvVar -> HsWrapper
1040 mk_op_wrapper sel_id rep_d
1041 = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty)
1042 <.> WpEvApp (EvId rep_d)
1043 <.> mkWpTyApps (init_inst_tys ++ [rep_ty])
1045 (sel_tvs, sel_rho) = tcSplitForAllTys (idType sel_id)
1046 (_, local_meth_ty) = tcSplitPredFunTy_maybe sel_rho
1047 `orElse` pprPanic "tcInstanceMethods" (ppr sel_id)
1049 ----------------------
1050 mkMethIds :: Class -> [TcTyVar] -> [EvVar] -> [TcType] -> Id -> TcM (TcId, TcId)
1051 mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
1052 = do { uniq <- newUnique
1053 ; let meth_name = mkDerivedInternalName mkClassOpAuxOcc uniq sel_name
1054 ; local_meth_name <- newLocalName sel_name
1055 -- Base the local_meth_name on the selector name, becuase
1056 -- type errors from tcInstanceMethodBody come from here
1058 ; let meth_id = mkLocalId meth_name meth_ty
1059 local_meth_id = mkLocalId local_meth_name local_meth_ty
1060 ; return (meth_id, local_meth_id) }
1062 local_meth_ty = instantiateMethod clas sel_id inst_tys
1063 meth_ty = mkForAllTys tyvars $ mkPiTypes dfun_ev_vars local_meth_ty
1064 sel_name = idName sel_id
1066 ----------------------
1067 wrapId :: HsWrapper -> id -> HsExpr id
1068 wrapId wrapper id = mkHsWrap wrapper (HsVar id)
1070 derivBindCtxt :: Id -> Class -> [Type ] -> LHsBind Name -> SDoc
1071 derivBindCtxt sel_id clas tys _bind
1072 = vcat [ ptext (sLit "When typechecking the code for ") <+> quotes (ppr sel_id)
1073 , nest 2 (ptext (sLit "in a standalone derived instance for")
1074 <+> quotes (pprClassPred clas tys) <> colon)
1075 , nest 2 $ ptext (sLit "To see the code I am typechecking, use -ddump-deriv") ]
1078 -- , nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
1080 warnMissingMethod :: Id -> TcM ()
1081 warnMissingMethod sel_id
1082 = do { warn <- doptM Opt_WarnMissingMethods
1083 ; warnTc (warn -- Warn only if -fwarn-missing-methods
1084 && not (startsWithUnderscore (getOccName sel_id)))
1085 -- Don't warn about _foo methods
1086 (ptext (sLit "No explicit method nor default method for")
1087 <+> quotes (ppr sel_id)) }
1090 Note [Export helper functions]
1091 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1092 We arrange to export the "helper functions" of an instance declaration,
1093 so that they are not subject to preInlineUnconditionally, even if their
1094 RHS is trivial. Reason: they are mentioned in the DFunUnfolding of
1095 the dict fun as Ids, not as CoreExprs, so we can't substitute a
1096 non-variable for them.
1098 We could change this by making DFunUnfoldings have CoreExprs, but it
1099 seems a bit simpler this way.
1101 Note [Default methods in instances]
1102 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1109 instance Baz Int Int
1111 From the class decl we get
1113 $dmfoo :: forall v x. Baz v x => x -> x
1116 Notice that the type is ambiguous. That's fine, though. The instance
1119 $dBazIntInt = MkBaz fooIntInt
1120 fooIntInt = $dmfoo Int Int $dBazIntInt
1122 BUT this does mean we must generate the dictionary translation of
1123 fooIntInt directly, rather than generating source-code and
1124 type-checking it. That was the bug in Trac #1061. In any case it's
1125 less work to generate the translated version!
1127 Note [INLINE and default methods]
1128 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1129 Default methods need special case. They are supposed to behave rather like
1130 macros. For exmample
1133 op1, op2 :: Bool -> a -> a
1136 op1 b x = op2 (not b) x
1138 instance Foo Int where
1139 -- op1 via default method
1142 The instance declaration should behave
1144 just as if 'op1' had been defined with the
1145 code, and INLINE pragma, from its original
1148 That is, just as if you'd written
1150 instance Foo Int where
1154 op1 b x = op2 (not b) x
1156 So for the above example we generate:
1159 {-# INLINE $dmop1 #-}
1160 -- $dmop1 has an InlineCompulsory unfolding
1161 $dmop1 d b x = op2 d (not b) x
1163 $fFooInt = MkD $cop1 $cop2
1165 {-# INLINE $cop1 #-}
1166 $cop1 = $dmop1 $fFooInt
1172 * We *copy* any INLINE pragma from the default method $dmop1 to the
1173 instance $cop1. Otherwise we'll just inline the former in the
1174 latter and stop, which isn't what the user expected
1176 * Regardless of its pragma, we give the default method an
1177 unfolding with an InlineCompulsory source. That means
1178 that it'll be inlined at every use site, notably in
1179 each instance declaration, such as $cop1. This inlining
1180 must happen even though
1181 a) $dmop1 is not saturated in $cop1
1182 b) $cop1 itself has an INLINE pragma
1184 It's vital that $dmop1 *is* inlined in this way, to allow the mutual
1185 recursion between $fooInt and $cop1 to be broken
1187 * To communicate the need for an InlineCompulsory to the desugarer
1188 (which makes the Unfoldings), we use the IsDefaultMethod constructor
1192 %************************************************************************
1194 \subsection{Error messages}
1196 %************************************************************************
1199 instDeclCtxt1 :: LHsType Name -> SDoc
1200 instDeclCtxt1 hs_inst_ty
1201 = inst_decl_ctxt (case unLoc hs_inst_ty of
1202 HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
1203 HsPredTy pred -> ppr pred
1204 _ -> ppr hs_inst_ty) -- Don't expect this
1205 instDeclCtxt2 :: Type -> SDoc
1206 instDeclCtxt2 dfun_ty
1207 = inst_decl_ctxt (ppr (mkClassPred cls tys))
1209 (_,cls,tys) = tcSplitDFunTy dfun_ty
1211 inst_decl_ctxt :: SDoc -> SDoc
1212 inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
1214 atInstCtxt :: Name -> SDoc
1215 atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
1218 mustBeVarArgErr :: Type -> SDoc
1219 mustBeVarArgErr ty =
1220 sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
1221 ptext (sLit "must be variables")
1222 , ptext (sLit "Instead of a variable, found") <+> ppr ty
1225 wrongATArgErr :: Type -> Type -> SDoc
1226 wrongATArgErr ty instTy =
1227 sep [ ptext (sLit "Type indexes must match class instance head")
1228 , ptext (sLit "Found") <+> quotes (ppr ty)
1229 <+> ptext (sLit "but expected") <+> quotes (ppr instTy)