.
Note [Inline dfuns unconditionally]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The code above unconditionally inlines dict funs. Here's why.
Consider this program:
test :: Int -> Int -> Bool
test x y = (x,y) == (y,x) || test y x
-- Recursive to avoid making it inline.
This needs the (Eq (Int,Int)) instance. If we inline that dfun
the code we end up with is good:
Test.$wtest =
\r -> case ==# [ww ww1] of wild {
PrelBase.False -> Test.$wtest ww1 ww;
PrelBase.True ->
case ==# [ww1 ww] of wild1 {
PrelBase.False -> Test.$wtest ww1 ww;
PrelBase.True -> PrelBase.True [];
};
};
Test.test = \r [w w1]
case w of w2 {
PrelBase.I# ww ->
case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
};
If we don't inline the dfun, the code is not nearly as good:
(==) = case PrelTup.$fEq(,) PrelBase.$fEqInt PrelBase.$fEqInt of tpl {
PrelBase.:DEq tpl1 tpl2 -> tpl2;
};
Test.$wtest =
\r [ww ww1]
let { y = PrelBase.I#! [ww1]; } in
let { x = PrelBase.I#! [ww]; } in
let { sat_slx = PrelTup.(,)! [y x]; } in
let { sat_sly = PrelTup.(,)! [x y];
} in
case == sat_sly sat_slx of wild {
PrelBase.False -> Test.$wtest ww1 ww;
PrelBase.True -> PrelBase.True [];
};
Test.test =
\r [w w1]
case w of w2 {
PrelBase.I# ww ->
case w1 of w3 { PrelBase.I# ww1 -> Test.$wtest ww ww1; };
};
Why didn't GHC inline $fEq in those days? Because it looked big:
PrelTup.zdfEqZ1T{-rcX-}
= \ @ a{-reT-} :: * @ b{-reS-} :: *
zddEq{-rf6-} _Ks :: {PrelBase.Eq{-23-} a{-reT-}}
zddEq1{-rf7-} _Ks :: {PrelBase.Eq{-23-} b{-reS-}} ->
let {
zeze{-rf0-} _Kl :: (b{-reS-} -> b{-reS-} -> PrelBase.Bool{-3c-})
zeze{-rf0-} = PrelBase.zeze{-01L-}@ b{-reS-} zddEq1{-rf7-} } in
let {
zeze1{-rf3-} _Kl :: (a{-reT-} -> a{-reT-} -> PrelBase.Bool{-3c-})
zeze1{-rf3-} = PrelBase.zeze{-01L-} @ a{-reT-} zddEq{-rf6-} } in
let {
zeze2{-reN-} :: ((a{-reT-}, b{-reS-}) -> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
zeze2{-reN-} = \ ds{-rf5-} _Ks :: (a{-reT-}, b{-reS-})
ds1{-rf4-} _Ks :: (a{-reT-}, b{-reS-}) ->
case ds{-rf5-}
of wild{-reW-} _Kd { (a1{-rf2-} _Ks, a2{-reZ-} _Ks) ->
case ds1{-rf4-}
of wild1{-reX-} _Kd { (b1{-rf1-} _Ks, b2{-reY-} _Ks) ->
PrelBase.zaza{-r4e-}
(zeze1{-rf3-} a1{-rf2-} b1{-rf1-})
(zeze{-rf0-} a2{-reZ-} b2{-reY-})
}
} } in
let {
a1{-reR-} :: ((a{-reT-}, b{-reS-})-> (a{-reT-}, b{-reS-})-> PrelBase.Bool{-3c-})
a1{-reR-} = \ a2{-reV-} _Ks :: (a{-reT-}, b{-reS-})
b1{-reU-} _Ks :: (a{-reT-}, b{-reS-}) ->
PrelBase.not{-r6I-} (zeze2{-reN-} a2{-reV-} b1{-reU-})
} in
PrelBase.zdwZCDEq{-r8J-} @ (a{-reT-}, b{-reS-}) a1{-reR-} zeze2{-reN-})
and it's not as bad as it seems, because it's further dramatically
simplified: only zeze2 is extracted and its body is simplified.
%************************************************************************
%* *
\subsection{Extracting instance decls}
%* *
%************************************************************************
Gather up the instance declarations from their various sources
\begin{code}
tcInstDecls1
:: [LTyClDecl Name]
-> [LInstDecl Name]
-> [LDerivDecl Name]
-> TcM (TcGblEnv,
[InstInfo Name],
HsValBinds Name)
tcInstDecls1 tycl_decls inst_decls deriv_decls
= checkNoErrs $
do {
; let { idxty_decls = filter (isFamInstDecl . unLoc) tycl_decls }
; local_info_tycons <- mapAndRecoverM tcLocalInstDecl1 inst_decls
; idx_tycons <- mapAndRecoverM tcIdxTyInstDeclTL idxty_decls
; let { (local_info,
at_tycons_s) = unzip local_info_tycons
; at_idx_tycons = concat at_tycons_s ++ idx_tycons
; clas_decls = filter (isClassDecl.unLoc) tycl_decls
; implicit_things = concatMap implicitTyThings at_idx_tycons
; aux_binds = mkAuxBinds at_idx_tycons
}
; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do {
; generic_inst_info <- getGenericInstances clas_decls
; addInsts local_info $
addInsts generic_inst_info $
addFamInsts at_idx_tycons $ do {
failIfErrsM
; (deriv_inst_info, deriv_binds, deriv_dus)
<- tcDeriving tycl_decls inst_decls deriv_decls
; gbl_env <- addInsts deriv_inst_info getGblEnv
; return ( addTcgDUs gbl_env deriv_dus,
generic_inst_info ++ deriv_inst_info ++ local_info,
aux_binds `plusHsValBinds` deriv_binds)
}}}
where
tcIdxTyInstDeclTL ldecl@(L loc decl) =
do { tything <- tcFamInstDecl ldecl
; setSrcSpan loc $
when (isAssocFamily tything) $
addErr $ assocInClassErr (tcdName decl)
; return tything
}
isAssocFamily (ATyCon tycon) =
case tyConFamInst_maybe tycon of
Nothing -> panic "isAssocFamily: no family?!?"
Just (fam, _) -> isTyConAssoc fam
isAssocFamily _ = panic "isAssocFamily: no tycon?!?"
assocInClassErr :: Name -> SDoc
assocInClassErr name =
ptext (sLit "Associated type") <+> quotes (ppr name) <+>
ptext (sLit "must be inside a class instance")
addInsts :: [InstInfo Name] -> TcM a -> TcM a
addInsts infos thing_inside
= tcExtendLocalInstEnv (map iSpec infos) thing_inside
addFamInsts :: [TyThing] -> TcM a -> TcM a
addFamInsts tycons thing_inside
= tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside
where
mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon
mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts"
(ppr tything)
\end{code}
\begin{code}
tcLocalInstDecl1 :: LInstDecl Name
-> TcM (InstInfo Name, [TyThing])
tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats))
= setSrcSpan loc $
addErrCtxt (instDeclCtxt1 poly_ty) $
do { is_boot <- tcIsHsBoot
; checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
badBootDeclErr
; (tyvars, theta, tau) <- tcHsInstHead poly_ty
; (clas, inst_tys) <- checkValidInstHead tau
; checkValidInstance tyvars theta clas inst_tys
; idx_tycons <- recoverM (return []) $
do { idx_tycons <- checkNoErrs $ mapAndRecoverM tcFamInstDecl ats
; checkValidAndMissingATs clas (tyvars, inst_tys)
(zip ats idx_tycons)
; return idx_tycons }
; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty)
; overlap_flag <- getOverlapFlag
; let (eq_theta,dict_theta) = partition isEqPred theta
theta' = eq_theta ++ dict_theta
dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys
ispec = mkLocalInstance dfun overlap_flag
; return (InstInfo { iSpec = ispec,
iBinds = VanillaInst binds uprags False },
idx_tycons)
}
where
checkValidAndMissingATs :: Class
-> ([TyVar], [TcType])
-> [(LTyClDecl Name,
TyThing)]
-> TcM ()
checkValidAndMissingATs clas inst_tys ats
= do {
; let class_ats = map tyConName (classATs clas)
defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats
omitted = filterOut (`elemNameSet` defined_ats) class_ats
; warn <- doptM Opt_WarnMissingMethods
; mapM_ (warnTc warn . omittedATWarn) omitted
; mapM_ (checkIndexes clas inst_tys) ats
}
checkIndexes clas inst_tys (hsAT, ATyCon tycon)
= checkIndexes' clas inst_tys hsAT
(tyConTyVars tycon,
snd . fromJust . tyConFamInst_maybe $ tycon)
checkIndexes _ _ _ = panic "checkIndexes"
checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys)
= let atName = tcdName . unLoc $ hsAT
in
setSrcSpan (getLoc hsAT) $
addErrCtxt (atInstCtxt atName) $
case find ((atName ==) . tyConName) (classATs clas) of
Nothing -> addErrTc $ badATErr clas atName
Just atycon ->
case assocTyConArgPoss_maybe atycon of
Nothing -> panic "checkIndexes': AT has no args poss?!?"
Just poss ->
let relevantInstTys = map (instTys !!) poss
instArgs = map Just relevantInstTys ++
repeat Nothing
renaming = substSameTyVar atTvs instTvs
in
zipWithM_ checkIndex (substTys renaming atTys) instArgs
checkIndex ty Nothing
| isTyVarTy ty = return ()
| otherwise = addErrTc $ mustBeVarArgErr ty
checkIndex ty (Just instTy)
| ty `tcEqType` instTy = return ()
| otherwise = addErrTc $ wrongATArgErr ty instTy
listToNameSet = addListToNameSet emptyNameSet
substSameTyVar [] _ = emptyTvSubst
substSameTyVar (tv:tvs) replacingTvs =
let replacement = case find (tv `sameLexeme`) replacingTvs of
Nothing -> mkTyVarTy tv
Just rtv -> mkTyVarTy rtv
tv1 `sameLexeme` tv2 =
nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2)
in
extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement
\end{code}
%************************************************************************
%* *
Type-checking instance declarations, pass 2
%* *
%************************************************************************
\begin{code}
tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo Name]
-> TcM (LHsBinds Id, TcLclEnv)
tcInstDecls2 tycl_decls inst_decls
= do {
(dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $
filter (isClassDecl.unLoc) tycl_decls
; tcExtendIdEnv (concat dm_ids_s) $ do
; inst_binds_s <- mapM tcInstDecl2 inst_decls
; let binds = unionManyBags dm_binds_s `unionBags`
unionManyBags inst_binds_s
; tcl_env <- getLclEnv
; return (binds, tcl_env) }
tcInstDecl2 :: InstInfo Name -> TcM (LHsBinds Id)
tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = ibinds })
= recoverM (return emptyLHsBinds) $
setSrcSpan loc $
addErrCtxt (instDeclCtxt2 (idType dfun_id)) $
tc_inst_decl2 dfun_id ibinds
where
dfun_id = instanceDFunId ispec
loc = getSrcSpan dfun_id
\end{code}
\begin{code}
tc_inst_decl2 :: Id -> InstBindings Name -> TcM (LHsBinds Id)
tc_inst_decl2 dfun_id (NewTypeDerived coi _)
= do { let rigid_info = InstSkol
origin = SigOrigin rigid_info
inst_ty = idType dfun_id
inst_tvs = fst (tcSplitForAllTys inst_ty)
; (inst_tvs', theta, inst_head_ty) <- tcSkolSigType rigid_info inst_ty
; let (cls, cls_inst_tys) = tcSplitDFunHead inst_head_ty
(class_tyvars, sc_theta, _, _) = classBigSig cls
cls_tycon = classTyCon cls
sc_theta' = substTheta (zipOpenTvSubst class_tyvars cls_inst_tys) sc_theta
Just (initial_cls_inst_tys, last_ty) = snocView cls_inst_tys
(rep_ty, wrapper)
= case coi of
IdCo -> (last_ty, idHsWrapper)
ACo co -> (snd (coercionKind co'), WpCast (mk_full_coercion co'))
where
co' = substTyWith inst_tvs (mkTyVarTys inst_tvs') co
mk_full_coercion co = mkTyConApp cls_tycon
(initial_cls_inst_tys ++ [mkSymCoercion co])
rep_pred = mkClassPred cls (initial_cls_inst_tys ++ [rep_ty])
; sc_loc <- getInstLoc InstScOrigin
; sc_dicts <- newDictBndrs sc_loc sc_theta'
; inst_loc <- getInstLoc origin
; dfun_dicts <- newDictBndrs inst_loc theta
; rep_dict <- newDictBndr inst_loc rep_pred
; this_dict <- newDictBndr inst_loc (mkClassPred cls cls_inst_tys)
; sc_binds <- addErrCtxt superClassCtxt $
tcSimplifySuperClasses inst_loc this_dict dfun_dicts
(rep_dict:sc_dicts)
; checkSigTyVars inst_tvs'
; let coerced_rep_dict = wrapId wrapper (instToId rep_dict)
; body <- make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
; let dict_bind = noLoc $ VarBind (instToId this_dict) (noLoc body)
; return (unitBag $ noLoc $
AbsBinds inst_tvs' (map instToVar dfun_dicts)
[(inst_tvs', dfun_id, instToId this_dict, [])]
(dict_bind `consBag` sc_binds)) }
where
make_body cls_tycon cls_inst_tys sc_dicts coerced_rep_dict
| null sc_dicts
= return coerced_rep_dict
| otherwise
= do { op_ids <- newSysLocalIds (fsLit "op") op_tys
; dummy_sc_dict_ids <- newSysLocalIds (fsLit "sc") (map idType sc_dict_ids)
; let the_pat = ConPatOut { pat_con = noLoc cls_data_con, pat_tvs = [],
pat_dicts = dummy_sc_dict_ids,
pat_binds = emptyLHsBinds,
pat_args = PrefixCon (map nlVarPat op_ids),
pat_ty = pat_ty}
the_match = mkSimpleMatch [noLoc the_pat] the_rhs
the_rhs = mkHsConApp cls_data_con cls_inst_tys $
map HsVar (sc_dict_ids ++ op_ids)
; return (HsCase (noLoc coerced_rep_dict) $
MatchGroup [the_match] (mkFunTy pat_ty pat_ty)) }
where
sc_dict_ids = map instToId sc_dicts
pat_ty = mkTyConApp cls_tycon cls_inst_tys
cls_data_con = head (tyConDataCons cls_tycon)
cls_arg_tys = dataConInstArgTys cls_data_con cls_inst_tys
op_tys = dropList sc_dict_ids cls_arg_tys
tc_inst_decl2 dfun_id (VanillaInst monobinds uprags standalone_deriv)
= do { let rigid_info = InstSkol
inst_ty = idType dfun_id
; (inst_tyvars', dfun_theta', inst_head') <- tcSkolSigType rigid_info inst_ty
; let
(clas, inst_tys') = tcSplitDFunHead inst_head'
(class_tyvars, sc_theta, _, op_items) = classBigSig clas
sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys') sc_theta
origin = SigOrigin rigid_info
; sc_loc <- getInstLoc InstScOrigin
; sc_dicts <- newDictOccs sc_loc sc_theta'
; inst_loc <- getInstLoc origin
; dfun_dicts <- newDictBndrs inst_loc dfun_theta'
; this_dict <- newDictBndr inst_loc (mkClassPred clas inst_tys')
; let this_dict_id = instToId this_dict
dfun_lam_vars = map instToVar dfun_dicts
prag_fn = mkPragFun uprags
loc = getSrcSpan dfun_id
tc_meth = tcInstanceMethod loc standalone_deriv
clas inst_tyvars' dfun_dicts
dfun_theta' inst_tys'
this_dict dfun_id
prag_fn monobinds
; (meth_exprs, meth_binds) <- tcExtendTyVarEnv inst_tyvars' $
mapAndUnzipM tc_meth op_items
; sc_binds <- addErrCtxt superClassCtxt $
tcSimplifySuperClasses inst_loc this_dict dfun_dicts sc_dicts
; checkSigTyVars inst_tyvars'
; prags <- tcPrags dfun_id (filter isSpecInstLSig uprags)
; let dict_constr = classDataCon clas
inline_prag | null dfun_dicts = []
| otherwise = [L loc (InlinePrag (alwaysInlineSpec FunLike))]
sc_dict_vars = map instToVar sc_dicts
dict_bind = L loc (VarBind this_dict_id dict_rhs)
dict_rhs = foldl (\ f a -> L loc (HsApp f (L loc a))) inst_constr meth_exprs
inst_constr = L loc $ wrapId (mkWpApps sc_dict_vars <.> mkWpTyApps inst_tys')
(dataConWrapId dict_constr)
main_bind = noLoc $ AbsBinds
inst_tyvars'
dfun_lam_vars
[(inst_tyvars', dfun_id, this_dict_id, inline_prag ++ prags)]
(dict_bind `consBag` sc_binds)
; showLIE (text "instance")
; return (main_bind `consBag` unionManyBags meth_binds) }
\end{code}
Note [Recursive superclasses]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
See Trac #1470 for why we would *like* to add "this_dict" to the
available instances here. But we can't do so because then the superclases
get satisfied by selection from this_dict, and that leads to an immediate
loop. What we need is to add this_dict to Avails without adding its
superclasses, and we currently have no way to do that.
%************************************************************************
%* *
Type-checking an instance method
%* *
%************************************************************************
tcInstanceMethod
- Make the method bindings, as a [(NonRec, HsBinds)], one per method
- Remembering to use fresh Name (the instance method Name) as the binder
- Bring the instance method Ids into scope, for the benefit of tcInstSig
- Use sig_fn mapping instance method Name -> instance tyvars
- Ditto prag_fn
- Use tcValBinds to do the checking
\begin{code}
tcInstanceMethod :: SrcSpan -> Bool -> Class -> [TcTyVar] -> [Inst]
-> TcThetaType -> [TcType]
-> Inst -> Id
-> TcPragFun -> LHsBinds Name
-> (Id, DefMeth)
-> TcM (HsExpr Id, LHsBinds Id)
tcInstanceMethod loc standalone_deriv clas tyvars dfun_dicts theta inst_tys
this_dict dfun_id prag_fn binds_in (sel_id, dm_info)
= do { cloned_this <- cloneDict this_dict
; uniq1 <- newUnique
; let local_meth_name = mkInternalName uniq1 sel_occ loc
this_dict_bind = L loc $ VarBind (instToId cloned_this) $
L loc $ wrapId meth_wrapper dfun_id
mb_this_bind | null tyvars = Nothing
| otherwise = Just (cloned_this, this_dict_bind)
tc_body rn_bind
= add_meth_ctxt rn_bind $
do { (meth_id, tc_binds) <- tcInstanceMethodBody
InstSkol clas tyvars dfun_dicts theta inst_tys
mb_this_bind sel_id
local_meth_name
meth_sig_fn meth_prag_fn rn_bind
; return (wrapId meth_wrapper meth_id, tc_binds) }
; case (findMethodBind sel_name local_meth_name binds_in, dm_info) of
(Just user_bind, _) -> tc_body user_bind
(Nothing, GenDefMeth) -> do
{ meth_bind <- mkGenericDefMethBind clas inst_tys sel_id local_meth_name
; tc_body meth_bind }
(Nothing, NoDefMeth) -> do
{ warn <- doptM Opt_WarnMissingMethods
; warnTc (warn
&& not (startsWithUnderscore (getOccName sel_id)))
omitted_meth_warn
; return (error_rhs, emptyBag) }
(Nothing, DefMeth) -> do
{
dm_name <- lookupGlobalOccRn (mkDefMethRdrName sel_name)
; dm_id <- tcLookupId dm_name
; return (wrapId dm_wrapper dm_id, emptyBag) } }
where
sel_name = idName sel_id
sel_occ = nameOccName sel_name
this_dict_id = instToId this_dict
meth_prag_fn _ = prag_fn sel_name
meth_sig_fn _ = Just []
error_rhs = HsApp error_fun error_msg
error_fun = L loc $ wrapId (WpTyApp meth_tau) nO_METHOD_BINDING_ERROR_ID
error_msg = L loc (HsLit (HsStringPrim (mkFastString error_string)))
meth_tau = funResultTy (applyTys (idType sel_id) inst_tys)
error_string = showSDoc (hcat [ppr loc, text "|", ppr sel_id ])
dm_wrapper = WpApp this_dict_id <.> mkWpTyApps inst_tys
omitted_meth_warn :: SDoc
omitted_meth_warn = ptext (sLit "No explicit method nor default method for")
<+> quotes (ppr sel_id)
dfun_lam_vars = map instToVar dfun_dicts
meth_wrapper = mkWpApps dfun_lam_vars <.> mkWpTyApps (mkTyVarTys tyvars)
add_meth_ctxt rn_bind thing
| standalone_deriv = addLandmarkErrCtxt (derivBindCtxt clas inst_tys rn_bind) thing
| otherwise = thing
wrapId :: HsWrapper -> id -> HsExpr id
wrapId wrapper id = mkHsWrap wrapper (HsVar id)
derivBindCtxt :: Class -> [Type ] -> LHsBind Name -> SDoc
derivBindCtxt clas tys bind
= vcat [ ptext (sLit "When typechecking a standalone-derived method for")
<+> quotes (pprClassPred clas tys) <> colon
, nest 2 $ pprSetDepth AllTheWay $ ppr bind ]
\end{code}
Note [Default methods in instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
class Baz v x where
foo :: x -> x
foo y = y
instance Baz Int Int
From the class decl we get
$dmfoo :: forall v x. Baz v x => x -> x
Notice that the type is ambiguous. That's fine, though. The instance decl generates
$dBazIntInt = MkBaz ($dmfoo Int Int $dBazIntInt)
BUT this does mean we must generate the dictionary translation directly, rather
than generating source-code and type-checking it. That was the bug ing
Trac #1061. In any case it's less work to generate the translated version!
%************************************************************************
%* *
\subsection{Error messages}
%* *
%************************************************************************
\begin{code}
instDeclCtxt1 :: LHsType Name -> SDoc
instDeclCtxt1 hs_inst_ty
= inst_decl_ctxt (case unLoc hs_inst_ty of
HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred
HsPredTy pred -> ppr pred
_ -> ppr hs_inst_ty)
instDeclCtxt2 :: Type -> SDoc
instDeclCtxt2 dfun_ty
= inst_decl_ctxt (ppr (mkClassPred cls tys))
where
(_,_,cls,tys) = tcSplitDFunTy dfun_ty
inst_decl_ctxt :: SDoc -> SDoc
inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc
superClassCtxt :: SDoc
superClassCtxt = ptext (sLit "When checking the super-classes of an instance declaration")
atInstCtxt :: Name -> SDoc
atInstCtxt name = ptext (sLit "In the associated type instance for") <+>
quotes (ppr name)
mustBeVarArgErr :: Type -> SDoc
mustBeVarArgErr ty =
sep [ ptext (sLit "Arguments that do not correspond to a class parameter") <+>
ptext (sLit "must be variables")
, ptext (sLit "Instead of a variable, found") <+> ppr ty
]
wrongATArgErr :: Type -> Type -> SDoc
wrongATArgErr ty instTy =
sep [ ptext (sLit "Type indexes must match class instance head")
, ptext (sLit "Found") <+> quotes (ppr ty)
<+> ptext (sLit "but expected") <+> quotes (ppr instTy)
]
\end{code}