X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=f1a747f9fa3730f0f4f58dcb94a5870b6b7a2126;hb=05446f0f1e826cd95c8bbcc355015a02ec8595ca;hp=7f803d52c6a5f6408e9e99d33a3678964a6fffa1;hpb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 7f803d5..f1a747f 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -10,18 +10,15 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
 
 import HsSyn		( HsDecl(..), IfaceSig(..), HsTupCon(..) )
 import TcMonad
-import TcMonoType	( tcHsType, tcHsTypeKind, 
+import TcMonoType	( tcHsType )
 				-- NB: all the tyars in interface files are kinded,
 				-- so tcHsType will do the Right Thing without
 				-- having to mess about with zonking
-			  tcExtendTyVarScope
-			)
-import TcEnv		( ValueEnv, tcExtendTyVarEnv, 
-			  tcExtendGlobalValEnv, tcSetValueEnv,
-			  tcLookupValueMaybe,
-			  explicitLookupValue, badCon, badPrimOp, valueEnvIds
+
+import TcEnv		( TcEnv, tcExtendTyVarEnv, 
+			  tcExtendGlobalValEnv, tcSetEnv,
+			  tcLookupGlobal_maybe, explicitLookupId, tcEnvIds
 			)
-import TcType		( TcKind, kindToTcKind )
 
 import RnHsSyn		( RenamedHsDecl )
 import HsCore
@@ -31,24 +28,19 @@ import CoreUtils	( exprType )
 import CoreUnfold
 import CoreLint		( lintUnfolding )
 import WorkWrap		( mkWrapper )
-import PrimOp		( PrimOp(..) )
 
-import Id		( Id, mkId, mkVanillaId,
-			  isDataConWrapId_maybe
-			)
+import Id		( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
 import MkId		( mkCCallOpId )
 import IdInfo
 import DataCon		( dataConSig, dataConArgTys )
-import Type		( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitAlgTyConApp_maybe, splitFunTys, unUsgTy )
+import Type		( mkTyVarTys, splitAlgTyConApp_maybe, unUsgTy )
 import Var		( mkTyVar, tyVarKind )
-import VarEnv
-import Name		( Name, NamedThing(..), isLocallyDefined )
-import TysWiredIn	( integerTy, stringTy )
+import Name		( Name, isLocallyDefined )
 import Demand		( wwLazy )
 import ErrUtils		( pprBagOfErrors )
-import Maybes		( maybeToBool, MaybeErr(..) )
 import Outputable	
 import Util		( zipWithEqual )
+import HscTypes		( TyThing(..) )
 \end{code}
 
 Ultimately, type signatures in interfaces will have pragmatic
@@ -59,16 +51,16 @@ As always, we do not have to worry about user-pragmas in interface
 signatures.
 
 \begin{code}
-tcInterfaceSigs :: ValueEnv		-- Envt to use when checking unfoldings
+tcInterfaceSigs :: TcEnv		-- Envt to use when checking unfoldings
 		-> [RenamedHsDecl]	-- Ignore non-sig-decls in these decls
-		-> TcM s [Id]
+		-> TcM [Id]
 		
 
 tcInterfaceSigs unf_env decls
   = listTc [ do_one name ty id_infos src_loc
 	   | SigD (IfaceSig name ty id_infos src_loc) <- decls]
   where
-    in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
+    in_scope_vars = filter isLocallyDefined (tcEnvIds unf_env)
 
     do_one name ty id_infos src_loc
       = tcAddSrcLoc src_loc 		 		$	
@@ -84,7 +76,6 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins
   = foldlTc tcPrag vanillaIdInfo info_ins
   where
     tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
-    tcPrag info (HsUpdate upd)  = returnTc (info `setUpdateInfo` upd)
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`	 NoCafRefs)
     tcPrag info HsCprInfo       = returnTc (info `setCprInfo`	 ReturnsCPR)
 
@@ -117,7 +108,7 @@ tcWorkerInfo unf_env ty info worker_name
   = uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
     let
 	-- Watch out! We can't pull on unf_env too eagerly!
-	info' = case explicitLookupValue unf_env worker_name of
+	info' = case explicitLookupId unf_env worker_name of
 			Just worker_id -> info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
                                                `setWorkerInfo`     HasWorker worker_id arity
 
@@ -145,17 +136,18 @@ tcPragExpr unf_env name in_scope_vars expr
 
 		-- Check for type consistency in the unfolding
 	tcGetSrcLoc		`thenNF_Tc` \ src_loc -> 
-	case lintUnfolding src_loc in_scope_vars core_expr' of
-	  Nothing       -> returnTc core_expr'
-	  Just fail_msg -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
+	getDOptsTc		`thenTc` \ dflags ->
+	case lintUnfolding dflags src_loc in_scope_vars core_expr' of
+	  (Nothing,_)       -> returnTc core_expr'  -- ignore warnings
+	  (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
   where
     doc = text "unfolding of" <+> ppr name
 
-tcDelay :: ValueEnv -> SDoc -> TcM s a -> NF_TcM s (Maybe a)
+tcDelay :: TcEnv -> SDoc -> TcM a -> NF_TcM (Maybe a)
 tcDelay unf_env doc thing_inside
   = forkNF_Tc (
 	recoverNF_Tc bad_value (
-		tcSetValueEnv unf_env thing_inside	`thenTc` \ r ->
+		tcSetEnv unf_env thing_inside	`thenTc` \ r ->
 		returnTc (Just r)
     ))			
   where
@@ -174,12 +166,12 @@ Variables in unfoldings
 ****** Why? Because we know all the types and want to bind them to real Ids.
 
 \begin{code}
-tcVar :: Name -> TcM s Id
+tcVar :: Name -> TcM Id
 tcVar name
-  = tcLookupValueMaybe name	`thenNF_Tc` \ maybe_id ->
+  = tcLookupGlobal_maybe name	`thenNF_Tc` \ maybe_id ->
     case maybe_id of {
-	Just id -> returnTc id;
-	Nothing -> failWithTc (noDecl name)
+	Just (AnId id)	-> returnTc id;
+	Nothing		-> failWithTc (noDecl name)
     }
 
 noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
@@ -188,10 +180,10 @@ noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name]
 UfCore expressions.
 
 \begin{code}
-tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
+tcCoreExpr :: UfExpr Name -> TcM CoreExpr
 
 tcCoreExpr (UfType ty)
-  = tcHsTypeKind ty	`thenTc` \ (_, ty') ->
+  = tcHsType ty		`thenTc` \ ty' ->
 	-- It might not be of kind type
     returnTc (Type ty')