Commit 0600a65d authored by simonpj's avatar simonpj

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

Check for illegal declarations in hs-boot files
parent 407228a0
......@@ -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]
......
......@@ -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"))
......
......@@ -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}
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment