module TcClassDcl ( tcClassSigs, tcClassDecl2,
getGenericInstances,
MethodSpec, tcMethodBind, mkMethodBind,
- tcAddDeclCtxt, badMethodErr
+ tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
#include "HsVersions.h"
= hsep [ptext SLIT("Class"), quotes (ppr clas),
ptext SLIT("does not have a method"), quotes (ppr op)]
+badATErr clas at
+ = hsep [ptext SLIT("Class"), quotes (ppr clas),
+ ptext SLIT("does not have an associated type"), quotes (ppr at)]
+
omittedMethodWarn sel_id
= ptext SLIT("No explicit method nor default method for") <+> quotes (ppr sel_id)
+omittedATWarn at
+ = ptext SLIT("No explicit AT declaration for") <+> quotes (ppr at)
+
badGenericInstance sel_id because
= sep [ptext SLIT("Can't derive generic code for") <+> quotes (ppr sel_id),
because]
import HsSyn
import TcBinds ( mkPragFun, tcPrags, badBootDeclErr )
import TcTyClsDecls ( tcIdxTyInstDecl )
-import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr,
- tcClassDecl2, getGenericInstances )
+import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, badATErr,
+ omittedATWarn, tcClassDecl2, getGenericInstances )
import TcRnMonad
import TcMType ( tcSkolSigType, checkValidInstance, checkValidInstHead )
import TcType ( mkClassPred, tcSplitSigmaTy, tcSplitDFunHead,
import TyCon ( TyCon, tyConName, newTyConCo, tyConTyVars,
isAssocTyCon, tyConFamInst_maybe )
import DataCon ( classDataCon, dataConTyCon, dataConInstArgTys )
-import Class ( classBigSig )
+import Class ( classBigSig, classATs )
import Var ( TyVar, Id, idName, idType, tyVarKind )
import Id ( mkSysLocal )
import UniqSupply ( uniqsFromSupply, splitUniqSupply )
import MkId ( mkDictFunId )
import Name ( Name, getSrcLoc )
+import NameSet ( NameSet, addListToNameSet, emptyNameSet,
+ minusNameSet, nameSetToList )
import Maybe ( isNothing, fromJust, catMaybes )
import Monad ( when )
+import DynFlags ( DynFlag(Opt_WarnMissingMethods) )
import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart )
import ListSetOps ( minusList )
import Outputable
; poly_ty' <- tcHsKindedType kinded_ty
; let (tyvars, theta, tau) = tcSplitSigmaTy poly_ty'
+ -- Next, process any associated types.
+ ; idxty_info_tycons <- mappM tcIdxTyInstDecl ats
+
-- Now, check the validity of the instance.
; (clas, inst_tys) <- checkValidInstHead tau
; checkValidInstance tyvars theta clas inst_tys
-
- -- Next, process any associated types.
- ; idxty_info_tycons <- mappM tcIdxTyInstDecl ats
+ ; checkValidOrMissingAT clas
-- Finally, construct the Core representation of the instance.
-- (This no longer includes the associated types.)
catMaybes idxty_infos,
catMaybes idxty_tycons)
}
+ where
+ checkValidOrMissingAT clas
+ = do { let classDefATs = addListToNameSet emptyNameSet
+ . map tyConName
+ . classATs
+ $ clas
+ definedATs = addListToNameSet emptyNameSet
+ . map (tcdName . unLoc)
+ $ ats
+ omitted = classDefATs `minusNameSet` definedATs
+ excess = definedATs `minusNameSet` classDefATs
+ ; mapM_ (addErrTc . badATErr clas) (nameSetToList excess)
+ ; warn <- doptM Opt_WarnMissingMethods
+ ; mapM_ (warnTc warn . omittedATWarn) (nameSetToList omitted)
+ }
\end{code}