%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 19921998
%
TcInstDecls: Typechecking instance declarations
\begin{code}
module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
import HsSyn
import TcBinds
import TcTyClsDecls
import TcClassDcl
import TcRnMonad
import TcMType
import TcType
import Inst
import InstEnv
import FamInst
import FamInstEnv
import TcDeriv
import TcEnv
import RnEnv ( lookupGlobalOccRn )
import RnSource ( addTcgDUs )
import TcHsType
import TcUnify
import TcSimplify
import Type
import Coercion
import TyCon
import DataCon
import Class
import Var
import Id
import MkId
import Name
import NameSet
import DynFlags
import SrcLoc
import Util
import Outputable
import Bag
import BasicTypes
import HscTypes
import FastString
import Data.Maybe
import Control.Monad
import Data.List
#include "HsVersions.h"
\end{code}
Typechecking instance declarations is done in two passes. The first
pass, made by @tcInstDecls1@, collects information to be used in the
second pass.
This preprocessed info includes the asyetunprocessed bindings
inside the instance declaration. These are typechecked in the second
pass, when the classinstance envs and GVE contain all the info from
all the instance and value decls. Indeed that's the reason we need
two passes over the instance decls.
Note [How instance declarations are translated]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Here is how we translation instance declarations into Core
Running example:
class C a where
op1, op2 :: Ix b => a -> b -> b
op2 = <dmrhs>
instance C a => C [a]
op1 = <rhs>
===>
op1,op2 :: forall a. C a => forall b. Ix b => a -> b -> b
op1 = ...
op2 = ...
$dmop2 :: forall a. C a => forall b. Ix b => a -> b -> b
$dmop2 = /\a. \(d:C a). /\b. \(d2: Ix b). <dmrhs>
op1_i, op2_i :: forall a. C a => forall b. Ix b => [a] -> b -> b
op1_i = /\a. \(d:C a).
let this :: C [a]
this = df_i a d
local_op1 :: forall b. Ix b => [a] -> b -> b
local_op1 = <rhs>
in local_op1 a d
op2_i = /\a \d:C a. $dmop2 [a] (df_i a d)
df_i :: forall a. C a -> C [a]
df_i = /\a. \d:C a. letrec d' = MkC (op1_i a d)
($dmop2 [a] d')
in d'
* The dictionary function itself is inlined as vigorously as we
possibly can, so that we expose that dictionary constructor to
selectors as much as poss. That is why the op_i stuff is in
*separate* bindings, so that the df_i binding is small enough
to inline. See Note [Inline dfuns unconditionally].
* Note that df_i may be mutually recursive with both op1_i and op2_i.
It's crucial that df_i is not chosen as the loop breaker, even
though op1_i has a (userspecified) INLINE pragma.
Not even once! Else op1_i, op2_i may be inlined into df_i.
* Instead the idea is to inline df_i into op1_i, which may then select
methods from the MkC record, and thereby break the recursion with
df_i, leaving a *self*-recurisve op1_i. (If op1_i doesn't call op at
the same type, it won't mention df_i, so there won't be recursion in
the first place.)
* If op1_i is marked INLINE by the user there's a danger that we won't
inline df_i in it, and that in turn means that (since it'll be a
loopbreaker because df_i isn't), op1_i will ironically never be
inlined. We need to fix this somehow
of INLINE functions inside other INLINE functions.
Note [Subtle interaction of recursion and overlap]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Consider this
class C a where { op1,op2 :: a -> a }
instance C a => C [a] where
op1 x = op2 x ++ op2 x
op2 x = ...
intance C [Int] where
...
When typechecking the C [a] instance, we need a C [a] dictionary (for
the call of op2). If we look up in the instance environment, we find
an overlap. And in *general* the right thing is to complain (see Note
[Overlapping instances] in InstEnv). But in *this* case it's wrong to
complain, because we just want to delegate to the op2 of this same
instance.
Why is this justified? Because we generate a (C [a]) constraint in
a context in which 'a' cannot be instantiated to anything that matches
other overlapping instances, or else we would not be excecuting this
version of op1 in the first place.
It might even be a bit disguised:
nullFail :: C [a] => [a] -> [a]
nullFail x = op2 x ++ op2 x
instance C a => C [a] where
op1 x = nullFail x
Precisely this is used in package 'regexbase', module Context.hs.
See the overlapping instances for RegexContext, and the fact that they
call 'nullFail' just like the example above. The DoCon package also
does the same thing; it shows up in module Fraction.hs
Conclusion: when typechecking the methods in a C [a] instance, we want
to have C [a] available. That is why we have the strange local
definition for 'this' in the definition of op1_i in the example above.
We can typecheck the defintion of local_op1, and when doing tcSimplifyCheck
we supply 'this' as a given dictionary. Only needed, though, if there
are some type variales involved; otherwise there can be no overlap and
none of this arises.
Note [Tricky type variable scoping]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
In our example
class C a where
op1, op2 :: Ix b => a -> b -> b
op2 = <dmrhs>
instance C a => C [a]
op1 = <rhs>
note that 'a' and 'b' are *both* in scope in <dmrhs>, but only 'a' is
in scope in <rhs>. In particular, we must make sure that 'b' is in
scope when typechecking <dmrhs>. This is achieved by subFunTys,
which brings appropriate tyvars into scope. This happens for both
<dmrhs> and for <rhs>, but that doesn't matter: the *renamer* will have
complained if 'b' is mentioned in <rhs>.
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
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
= \ @ a :: * @ b :: *
zddEq _Ks :: {PrelBase.Eq a}
zddEq1 _Ks :: {PrelBase.Eq b} ->
let {
zeze _Kl :: (b -> b -> PrelBase.Bool)
zeze = PrelBase.zeze@ b zddEq1 } in
let {
zeze1 _Kl :: (a -> a -> PrelBase.Bool)
zeze1 = PrelBase.zeze @ a zddEq } in
let {
zeze2 :: ((a, b) -> (a, b)-> PrelBase.Bool)
zeze2 = \ ds _Ks :: (a, b)
ds1 _Ks :: (a, b) ->
case ds
of wild _Kd { (a1 _Ks, a2 _Ks) ->
case ds1
of wild1 _Kd { (b1 _Ks, b2 _Ks) ->
PrelBase.zaza
(zeze1 a1 b1)
(zeze a2 b2)
}
} } in
let {
a1 :: ((a, b)-> (a, b)-> PrelBase.Bool)
a1 = \ a2 _Ks :: (a, b)
b1 _Ks :: (a, b) ->
PrelBase.not (zeze2 a2 b1)
} in
PrelBase.zdwZCDEq @ (a, b) a1 zeze2)
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}
%************************************************************************
%* *
Typechecking 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.
%************************************************************************
%* *
Typechecking 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 sourcecode and typechecking 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}