X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=afdf82f7cefc1d7dba3950f352f8a85c3d8370d3;hb=40dfb7ac2b32f5ed38249f77c416e413b358df1c;hp=1778c8e6ca75767e86659751a7b23a6f4032e0e4;hpb=b822aa0e9411a1909988c0367d342671806a0f75;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index 1778c8e..afdf82f 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -8,20 +8,17 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
 
 #include "HsVersions.h"
 
-import HsSyn		( HsDecl(..), IfaceSig(..) )
+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, valueEnvIds
 			)
-import TcType		( TcKind, kindToTcKind )
 
 import RnHsSyn		( RenamedHsDecl )
 import HsCore
@@ -31,7 +28,6 @@ import CoreUtils	( exprType )
 import CoreUnfold
 import CoreLint		( lintUnfolding )
 import WorkWrap		( mkWrapper )
-import PrimOp		( PrimOp(..), CCall(..), CCallTarget(..) )
 
 import Id		( Id, mkId, mkVanillaId,
 			  isDataConWrapId_maybe
@@ -39,15 +35,11 @@ import Id		( Id, mkId, mkVanillaId,
 import MkId		( mkCCallOpId )
 import IdInfo
 import DataCon		( dataConSig, dataConArgTys )
-import Type		( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitFunTys, unUsgTy )
+import Type		( mkTyVarTys, splitAlgTyConApp_maybe, unUsgTy )
 import Var		( mkTyVar, tyVarKind )
-import VarEnv
-import Name		( Name, NamedThing(..), isLocallyDefined )
-import Unique		( rationalTyConKey )
-import TysWiredIn	( integerTy, stringTy )
+import Name		( Name, isLocallyDefined )
 import Demand		( wwLazy )
 import ErrUtils		( pprBagOfErrors )
-import Maybes		( maybeToBool, MaybeErr(..) )
 import Outputable	
 import Util		( zipWithEqual )
 \end{code}
@@ -60,9 +52,9 @@ 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
@@ -85,7 +77,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)
 
@@ -102,8 +93,8 @@ tcIdInfo unf_env in_scope_vars name ty info info_ins
 	  in
 	  returnTc info2
 
-    tcPrag info (HsStrictness (HsStrictnessInfo (demands,bot_result)))
-	= returnTc (info `setStrictnessInfo` StrictnessInfo demands bot_result)
+    tcPrag info (HsStrictness strict_info)
+	= returnTc (info `setStrictnessInfo` strict_info)
 
     tcPrag info (HsWorker nm)
 	= tcWorkerInfo unf_env ty info nm
@@ -118,7 +109,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
 
@@ -147,16 +138,16 @@ 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)
+	  (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
@@ -175,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]
@@ -189,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')
 
@@ -214,7 +205,7 @@ tcCoreExpr (UfCCall cc ty)
     tcGetUnique		`thenNF_Tc` \ u ->
     returnTc (Var (mkCCallOpId u cc ty'))
 
-tcCoreExpr (UfTuple name args) 
+tcCoreExpr (UfTuple (HsTupCon name _) args) 
   = tcVar name			`thenTc` \ con_id ->
     mapTc tcCoreExpr args	`thenTc` \ args' ->
     let
@@ -332,20 +323,22 @@ tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
 -- A case alternative is made quite a bit more complicated
 -- by the fact that we omit type annotations because we can
 -- work them out.  True enough, but its not that easy!
-tcCoreAlt scrut_ty (UfDataAlt con_name, names, rhs)
+tcCoreAlt scrut_ty alt@(UfDataAlt con_name, names, rhs)
   = tcVar con_name		`thenTc` \ con_id ->
     let
-	con			= case isDataConWrapId_maybe con_id of
-					Just con -> con
-					Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
+	con = case isDataConWrapId_maybe con_id of
+		Just con -> con
+		Nothing  -> pprPanic "tcCoreAlt" (ppr con_id)
 
 	(main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
 
-	(tycon, inst_tys, cons) = splitAlgTyConApp scrut_ty
-	ex_tyvars'		= [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] 
-	ex_tys'			= mkTyVarTys ex_tyvars'
-	arg_tys			= dataConArgTys con (inst_tys ++ ex_tys')
-	id_names		= drop (length ex_tyvars) names
+	(_, inst_tys, cons) = case splitAlgTyConApp_maybe scrut_ty of
+				    Just stuff -> stuff
+				    Nothing -> pprPanic "tcCoreAlt" (ppr alt)
+	ex_tyvars'	    = [mkTyVar name (tyVarKind tv) | (name,tv) <- names `zip` ex_tyvars] 
+	ex_tys'		    = mkTyVarTys ex_tyvars'
+	arg_tys		    = dataConArgTys con (inst_tys ++ ex_tys')
+	id_names	    = drop (length ex_tyvars) names
 	arg_ids
 #ifdef DEBUG
 		| length id_names /= length arg_tys