From: Manuel M T Chakravarty <chak@cse.unsw.edu.au>
Date: Wed, 20 Sep 2006 18:38:51 +0000 (+0000)
Subject: Warn of missing ATs and complain about bad ATs
X-Git-Tag: After_FC_branch_merge~23
X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=b2376468bde082d9b2018f1d5e1fc084955e8853

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
---

diff --git a/compiler/typecheck/TcClassDcl.lhs b/compiler/typecheck/TcClassDcl.lhs
index 9fb530d..e9e5843 100644
--- a/compiler/typecheck/TcClassDcl.lhs
+++ b/compiler/typecheck/TcClassDcl.lhs
@@ -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]
diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs
index e12f234..7ee5284 100644
--- a/compiler/typecheck/TcInstDcls.lhs
+++ b/compiler/typecheck/TcInstDcls.lhs
@@ -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}