From: simonpj <unknown>
Date: Tue, 3 May 2005 13:41:01 +0000 (+0000)
Subject: [project @ 2005-05-03 13:41:01 by simonpj]
X-Git-Tag: Initial_conversion_from_CVS_complete~615
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=0600a65decbd51ded35b950073caafa645405de0;p=ghc-hetmet.git

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