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

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 54075d4..99d58ea 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/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})

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 3951128..4548221 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/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) } }

diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs
index 980c7f7..a8449ae 100644 (file)
--- a/compiler/parser/RdrHsSyn.lhs
+++ b/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 data or synonym definitions
+-- 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).

diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index d1967c8..6b98283 100644 (file)
--- 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 9a92f84..5083044 100644 (file)
--- 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.