X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcBinds.lhs;h=395744d7c0bdc6f605bf78cb5ade89b37ec1bf44;hb=508a505e9853984bfdaa3ad855ae3fcbc6d31787;hp=723466489196c7b7d7b59cc492ed2f8270265da0;hpb=f9d8c8e0ab44b24d06b654d98543e8b39d4ebeca;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 7234664..395744d 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -4,7 +4,7 @@
 \section[TcBinds]{TcBinds}
 
 \begin{code}
-module TcBinds ( tcBindsAndThen, tcTopBinds, tcMonoBinds, tcSpecSigs ) where
+module TcBinds ( tcBindsAndThen, tcTopBinds, tcHsBootSigs, tcMonoBinds, tcSpecSigs ) where
 
 #include "HsVersions.h"
 
@@ -14,7 +14,7 @@ import {-# SOURCE #-} TcExpr  ( tcCheckSigma, tcCheckRho )
 import CmdLineOpts	( DynFlag(Opt_MonomorphismRestriction) )
 import HsSyn		( HsExpr(..), HsBind(..), LHsBinds, Sig(..),
 			  LSig, Match(..), HsBindGroup(..), IPBind(..), 
-			  HsType(..), hsLTyVarNames,
+			  HsType(..), hsLTyVarNames, isVanillaLSig,
 			  LPat, GRHSs, MatchGroup(..), emptyLHsBinds, isEmptyLHsBinds,
 			  collectHsBindBinders, collectPatBinders, pprPatBind
 			)
@@ -95,15 +95,28 @@ tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
 	--       want.  The bit we care about is the local bindings
 	--	 and the free type variables thereof
 tcTopBinds binds
-  = tc_binds_and_then TopLevel glue binds	$
-    getLclEnv					`thenM` \ env ->
-    returnM (emptyLHsBinds, env)
+  = tc_binds_and_then TopLevel glue binds $
+	    do  { env <- getLclEnv
+		; return (emptyLHsBinds, env) }
   where
 	-- The top level bindings are flattened into a giant 
 	-- implicitly-mutually-recursive MonoBinds
     glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env)
+    glue (HsIPBinds _) 		  _		= panic "Top-level HsIpBinds"
 	-- Can't have a HsIPBinds at top level
 
+tcHsBootSigs :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv)
+-- A hs-boot file has only one BindGroup, and it only has type
+-- signatures in it.  The renamer checked all this
+tcHsBootSigs [HsBindGroup _ sigs _]
+  = do	{ ids <- mapM (addLocM tc_sig) (filter isVanillaLSig sigs)
+	; tcExtendIdEnv ids $ do 
+	{ env <- getLclEnv
+	; return (emptyLHsBinds, env) }}
+  where
+    tc_sig (Sig (L _ name) ty)
+      = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty
+	   ; return (mkLocalId name sigma_ty) }
 
 tcBindsAndThen
 	:: (HsBindGroup TcId -> thing -> thing)		-- Combinator
@@ -243,7 +256,7 @@ tcBindWithSigs	:: TopLevelFlag
 tcBindWithSigs top_lvl mbind sigs is_rec = do	
   {	-- TYPECHECK THE SIGNATURES
     tc_ty_sigs <- recoverM (returnM []) $
-		  tcTySigs [sig | sig@(L _(Sig name _)) <- sigs]
+		  tcTySigs (filter isVanillaLSig sigs)
   ; let lookup_sig = lookupSig tc_ty_sigs
 
 	-- SET UP THE MAIN RECOVERY; take advantage of any type sigs