Commit b2376468 authored by chak@cse.unsw.edu.au.'s avatar chak@cse.unsw.edu.au.
Browse files

Warn of missing ATs and complain about bad ATs

Mon Sep 18 19:17:18 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Warn of missing ATs and complain about bad ATs
  Mon Aug 28 22:26:22 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Warn of missing ATs and complain about bad ATs
parent feb584b7
......@@ -7,7 +7,7 @@
module TcClassDcl ( tcClassSigs, tcClassDecl2,
getGenericInstances,
MethodSpec, tcMethodBind, mkMethodBind,
tcAddDeclCtxt, badMethodErr
tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn
) where
#include "HsVersions.h"
......@@ -759,9 +759,16 @@ badMethodErr clas op
= 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]
......
......@@ -11,8 +11,8 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
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,
......@@ -33,14 +33,17 @@ import Coercion ( mkSymCoercion )
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
......@@ -238,12 +241,13 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
; 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.)
......@@ -259,6 +263,21 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags ats))
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}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment