Added error checks & fixed bugs

Thu Aug  3 19:29:38 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Added error checks & fixed bugs

2 files changed, 33 insertions, 15 deletions

diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index d1967c8464..6b98283afd 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -17,7 +17,7 @@ import DynFlags		( DynFlag(..), GhcMode(..), DynFlags(..) )
 import HsSyn		( IE(..), ieName, ImportDecl(..), LImportDecl,
 			  ForeignDecl(..), HsGroup(..), HsValBinds(..),
 			  Sig(..), collectHsBindLocatedBinders, tyClDeclNames,
-			  instDeclATs,
+			  instDeclATs, isIdxTyDecl,
 			  LIE )
 import RnEnv
 import IfaceEnv		( ifaceExportNames )
@@ -446,13 +446,14 @@ getLocalDeclBinders gbl_env (HsGroup {hs_valds = ValBindsIn val_decls val_sigs,
     new_tc tc_decl 
 	= do { main_name <- newTopSrcBinder mod Nothing main_rdr
 	     ; sub_names <- mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs
-	     ; return (main_name : sub_names) }
+	     ; if isIdxTyDecl (unLoc tc_decl)	   -- index type definitions
+	       then return (            sub_names) -- are usage occurences
+	       else return (main_name : sub_names) }
 	where
 	  (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
 
     inst_ats inst_decl 
-	= mappM (liftM tail . new_tc) (instDeclATs (unLoc inst_decl))
-		       -- drop main_rdr (already declared in class)
+	= mappM new_tc (instDeclATs (unLoc inst_decl))
 \end{code}
 
 
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 9a92f84b59..5083044a6f 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -333,20 +333,32 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	     --     to remove the context).
 \end{code}
 
-Renaming of the associated data definitions requires adding the instance
-context, as the rhs of an AT declaration may use ATs from classes in the
-context.
+Renaming of the associated type definitions in instances.  
+
+* In the case of associated data and newtype definitions we add the instance
+  context.
+* We raise an error if we encounter a kind signature in an instance.
 
 \begin{code}
 rnATDefs :: HsContext RdrName -> [LTyClDecl RdrName] 
 	  -> RnM ([LTyClDecl Name], FreeVars)
 rnATDefs ctxt atDecls = 
-  mapFvRn (wrapLocFstM addCtxtAndRename) atDecls
+  mapFvRn (wrapLocFstM rnAtDef) atDecls
   where
-    -- The parser won't accept anything, but a data declaration
-    addCtxtAndRename ty@TyData {tcdCtxt = L l tyCtxt} = 
-      rnTyClDecl (ty {tcdCtxt = L l (ctxt ++ tyCtxt)})
-      -- The source loc is somewhat half hearted... -=chak
+    rnAtDef tydecl@TyFunction {}                 = 
+      do
+        addErr noKindSig
+	rnTyClDecl tydecl
+    rnAtDef tydecl@TySynonym  {}                 = rnTyClDecl tydecl
+    rnAtDef tydecl@TyData {tcdCtxt = L l tyCtxt} = 
+      do
+        checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig
+        rnTyClDecl (tydecl {tcdCtxt = L l (ctxt ++ tyCtxt)})
+          -- The source loc is somewhat half hearted... -=chak
+    rnAtDef _ =
+      panic "RnSource.rnATDefs: not a type declaration"
+
+noKindSig = text "Instances cannot have kind signatures"
 \end{code}
 
 For the method bindings in class and instance decls, we extend the 
@@ -769,15 +781,17 @@ needOneIdx = text "Kind signature requires at least one type index"
 
 -- Rename associated type declarations (in classes)
 --
--- * This can be data declarations, type function signatures, and (default)
---   type function equations.
+-- * This can be kind signatures and (default) type function equations.
 --
 rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars)
 rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
   where
     rn_at (tydecl@TyData     {}) = rnTySig tydecl lookupIdxVars
     rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars
-    rn_at (tydecl@TySynonym  {}) = rnTyClDecl tydecl
+    rn_at (tydecl@TySynonym  {}) = 
+      do
+        checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns
+        rnTyClDecl tydecl
     rn_at _                      = panic "RnSource.rnATs: invalid TyClDecl"
 
     lookupIdxVars _ tyvars cont = mappM lookupIdxVar tyvars >>= cont
@@ -789,6 +803,9 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats
 	name' <- lookupOccRn (hsTyVarName tyvar)
 	return $ L l (replaceTyVarName tyvar name')
 
+noPatterns = text "Default definition for an associated synonym cannot have"
+	     <+> text "type pattern"
+
 -- This data decl will parse OK
 --	data T = a Int
 -- treating "a" as the constructor.