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

compiler/hsSyn/HsDecls.lhs

@@ -451,7 +451,9 @@ isKindSigDecl (TyData     {tcdKindSig = Just _,
 isKindSigDecl other                              = False
 
 -- definition of an instance of an indexed type
-isIdxTyDecl = isJust . tcdTyPats
+isIdxTyDecl tydecl
+   | isSynDecl tydecl || isDataDecl tydecl = isJust (tcdTyPats tydecl)
+   | otherwise				   = False
 \end{code}
 
 Dealing with names
@@ -467,9 +469,7 @@ tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
 -- We use the equality to filter out duplicate field names
 
 tyClDeclNames (TyFunction  {tcdLName = name})    = [name]
-tyClDeclNames (TySynonym   {tcdLName = name,
-			    tcdTyPats= Nothing}) = [name]
-tyClDeclNames (TySynonym   {}                  ) = []     -- type equation
+tyClDeclNames (TySynonym   {tcdLName = name})    = [name]
 tyClDeclNames (ForeignType {tcdLName = name})    = [name]
 
 tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})

compiler/parser/Parser.y.pp

@@ -470,6 +470,7 @@ cl_decl :: { LTyClDecl RdrName }
 			        cvBindsAndSigs (unLoc $4)
 		            ; (ctxt, tc, tvs, tparms) = unLoc $2}
                       ; checkTyVars tparms False  -- only type vars allowed
+		      ; checkKindSigs ats
 		      ; return $ L (comb4 $1 $2 $3 $4) 
 				   (mkClassDecl (ctxt, tc, tvs) 
 					        (unLoc $3) sigs binds ats) } }

compiler/parser/RdrHsSyn.lhs

@@ -38,6 +38,7 @@ module RdrHsSyn (
 	checkTyClHdr,         -- LHsContext RdrName -> LHsType RdrName -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName], [LHsType RdrName])
 	checkTyVars,          -- [LHsType RdrName] -> Bool -> P ()
 	checkSynHdr,	      -- LHsType RdrName -> P (Located RdrName, [LHsTyVarBndr RdrName], Maybe [LHsType RdrName])
+	checkKindSigs,	      -- [LTyClDecl RdrName] -> P ()
 	checkTopTypeD,	      -- LTyClDecl RdrName -> P (HsDecl RdrName)
 	checkInstType,	      -- HsType -> P HsType
 	checkPattern,	      -- HsExp -> P HsPat
@@ -213,7 +214,7 @@ cvBindsAndSigs :: OrdList (LHsDecl RdrName)
   -> (Bag (LHsBind RdrName), [LSig RdrName], [LTyClDecl RdrName])
 -- Input decls contain just value bindings and signatures
 -- and in case of class or instance declarations also
+-- associated type declarations
 cvBindsAndSigs  fb = go (fromOL fb)
   where
     go [] 		   = (emptyBag, [], [])
@@ -506,6 +507,17 @@ extractTyVars tvs = collects [] tvs
 			    tvs' <- collects tvs ts
 			    collect tvs' t
 
+-- Check that associated type declarations of a class are all kind signatures.
+--
+checkKindSigs :: [LTyClDecl RdrName] -> P ()
+checkKindSigs = mapM_ check
+  where
+    check (L l tydecl) 
+      | isKindSigDecl tydecl
+        || isSynDecl tydecl  = return ()
+      | otherwise	     = 
+	parseError l "Type declaration in a class must be a kind signature or synonym default"
+
 -- Wrap a toplevel type or data declaration into 'TyClD' and ensure for 
 -- data declarations that all type parameters are variables only (which is in
 -- contrast to type functions and associated type declarations).

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}
 
 

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.