[project @ 2005-05-03 13:41:01 by simonpj]

Check for illegal declarations in hs-boot files

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 021655b..6243fc6 100644 (file)
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -4,7 +4,9 @@
 \section[TcBinds]{TcBinds}
 
 \begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcSpecSigs ) where
+module TcBinds ( tcBindsAndThen, tcTopBinds, 
+                tcHsBootSigs, tcMonoBinds, tcSpecSigs,
+                badBootDeclErr ) where
 
 #include "HsVersions.h"
 
@@ -52,6 +54,7 @@ import NameSet
 import VarSet
 import SrcLoc          ( Located(..), unLoc, noLoc, getLoc )
 import Bag
+import ErrUtils                ( Message )
 import Util            ( isIn )
 import BasicTypes      ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec, 
                          isNotTopLevel, isAlwaysActive )
@@ -110,14 +113,18 @@ tcTopBinds binds
 tcHsBootSigs :: [HsBindGroup Name] -> TcM [Id]
 -- A hs-boot file has only one BindGroup, and it only has type
 -- signatures in it.  The renamer checked all this
-tcHsBootSigs [HsBindGroup _ sigs _]
-  = mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs)
+tcHsBootSigs [HsBindGroup binds sigs _]
+  = do { checkTc (isEmptyLHsBinds binds) badBootDeclErr
+       ; mapM (addLocM tc_boot_sig) (filter isVanillaLSig sigs) }
   where
     tc_boot_sig (Sig (L _ name) ty)
       = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
           ; return (mkVanillaGlobal name sigma_ty vanillaIdInfo) }
        -- Notice that we make GlobalIds, not LocalIds
 
+badBootDeclErr :: Message
+badBootDeclErr = ptext SLIT("Illegal declarations in an hs-boot file")
+
 tcBindsAndThen
        :: (HsBindGroup TcId -> thing -> thing)         -- Combinator
        -> [HsBindGroup Name]

diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index 6fdc327..dcf8986 100644 (file)
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -9,7 +9,7 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where
 #include "HsVersions.h"
 
 import HsSyn
-import TcBinds         ( tcSpecSigs )
+import TcBinds         ( tcSpecSigs, badBootDeclErr )
 import TcClassDcl      ( tcMethodBind, mkMethodBind, badMethodErr, 
                          tcClassDecl2, getGenericInstances )
 import TcRnMonad       
@@ -208,6 +208,11 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags))
     let dfun  = mkDictFunId dfun_name tyvars theta clas inst_tys
        ispec = mkLocalInstance dfun overlap_flag
     in
+
+    tcIsHsBoot                                         `thenM` \ is_boot ->
+    checkTc (not is_boot || (isEmptyLHsBinds binds && null uprags))
+           badBootDeclErr                              `thenM_`
+
     returnM (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags }))
   where
     msg  = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class"))

diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 120b213..2628afc 100644 (file)
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -316,7 +316,9 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})
 
 kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt,  tcdSigs = sigs})
   = kcTyClDeclBody decl        $ \ tvs' ->
-    do { ctxt' <- kcHsContext ctxt     
+    do { is_boot <- tcIsHsBoot
+       ; checkTc (not is_boot) badBootClassDeclErr
+       ; ctxt' <- kcHsContext ctxt     
        ; sigs' <- mappM (wrapLocM kc_sig) sigs
        ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) }
   where
@@ -770,4 +772,6 @@ badGadtDecl tc_name
 emptyConDeclsErr tycon
   = sep [quotes (ppr tycon) <+> ptext SLIT("has no constructors"),
         nest 4 (ptext SLIT("(-fglasgow-exts permits this)"))]
+
+badBootClassDeclErr = ptext SLIT("Illegal class declaration in hs-boot file")
 \end{code}