X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=f83b337f3e35218aa679f4ab28c5295705c5e97b;hb=d8a9b534050f62f65d9db0d69aad9733f687ef8b;hp=d6aefcd6bf6f27b9d48071332e3e8224b33d6d5c;hpb=6858f7c15fcf9efe9e6fdf22de34d0791b0f0c08;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index d6aefcd..f83b337 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -4,11 +4,17 @@
 \section[TcIfaceSig]{Type checking of type signatures in interface files}
 
 \begin{code}
-module TcIfaceSig ( tcInterfaceSigs, tcDelay, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
+module TcIfaceSig ( tcInterfaceSigs,
+                    tcDelay,
+		    tcVar,
+		    tcCoreExpr,
+		    tcCoreLamBndrs,
+		    tcCoreBinds ) where
 
 #include "HsVersions.h"
 
 import HsSyn		( TyClDecl(..), HsTupCon(..) )
+import TcHsSyn		( TypecheckedCoreBind )
 import TcMonad
 import TcMonoType	( tcIfaceType )
 import TcEnv		( RecTcEnv, tcExtendTyVarEnv, 
@@ -29,15 +35,15 @@ import Id		( Id, mkVanillaGlobal, mkLocalId, idName, isDataConWrapId_maybe )
 import Module		( Module )
 import MkId		( mkFCallId )
 import IdInfo
-import TyCon		( tyConDataCons )
-import DataCon		( DataCon, dataConId, dataConSig, dataConArgTys )
-import Type		( mkTyVarTys, splitTyConApp )
+import TyCon		( tyConDataCons, tyConTyVars )
+import DataCon		( DataCon, dataConWorkId, dataConExistentialTyVars, dataConArgTys )
+import Type		( Type, mkTyVarTys, splitTyConApp )
 import TysWiredIn	( tupleCon )
 import Var		( mkTyVar, tyVarKind )
 import Name		( Name, nameIsLocalOrFrom )
 import ErrUtils		( pprBagOfErrors )
 import Outputable	
-import Util		( zipWithEqual )
+import Util		( zipWithEqual, dropList, equalLength )
 import HscTypes		( TyThing(..) )
 \end{code}
 
@@ -88,8 +94,7 @@ tcIdInfo unf_env in_scope_vars name ty info_ins
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`	 NoCafRefs)
 
     tcPrag info (HsArity arity) = 
-	returnTc (info `setArityInfo` arity
-	 	       `setCgArity`   arity)
+	returnTc (info `setArityInfo` arity)
 
     tcPrag info (HsUnfold inline_prag expr)
 	= tcPragExpr unf_env name in_scope_vars expr 	`thenNF_Tc` \ maybe_expr' ->
@@ -105,7 +110,7 @@ tcIdInfo unf_env in_scope_vars name ty info_ins
 	  returnTc info2
 
     tcPrag info (HsStrictness strict_info)
-	= returnTc (info `setNewStrictnessInfo` Just strict_info)
+	= returnTc (info `setAllStrictnessInfo` Just strict_info)
 
     tcPrag info (HsWorker nm arity)
 	= tcWorkerInfo unf_env ty info nm arity
@@ -143,7 +148,7 @@ tcPragExpr unf_env name in_scope_vars expr
 
 		-- Check for type consistency in the unfolding
 	tcGetSrcLoc		`thenNF_Tc` \ src_loc -> 
-	getDOptsTc		`thenTc` \ dflags ->
+	getDOptsTc		`thenNF_Tc` \ dflags ->
 	case lintUnfolding dflags src_loc in_scope_vars core_expr' of
 	  (Nothing,_)       -> returnTc (Just core_expr')  -- ignore warnings
 	  (Just fail_msg,_) -> failWithTc ((doc <+> text "failed Lint") $$ fail_msg)
@@ -219,7 +224,7 @@ tcCoreExpr (UfTuple (HsTupCon _ boxity arity) args)
     in
     returnTc (mkApps (Var con_id) con_args)
   where
-    con_id = dataConId (tupleCon boxity arity)
+    con_id = dataConWorkId (tupleCon boxity arity)
     
 
 tcCoreExpr (UfLam bndr body)
@@ -331,17 +336,17 @@ tcCoreAlt scrut_ty (UfLitLitAlt str ty, names, rhs)
 tcCoreAlt scrut_ty alt@(con, names, rhs)
   = tcConAlt con	`thenTc` \ con ->
     let
-	(main_tyvars, _, ex_tyvars, _, _, _) = dataConSig con
-
-	(tycon, inst_tys)   = splitTyConApp scrut_ty	-- NB: not tcSplitTyConApp
+	ex_tyvars  	  = dataConExistentialTyVars con
+	(tycon, inst_tys) = splitTyConApp scrut_ty	-- NB: not tcSplitTyConApp
 							-- We are looking at Core here
-	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
+	main_tyvars	  = tyConTyVars tycon
+	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	  = dropList ex_tyvars names
 	arg_ids
 #ifdef DEBUG
-		| length id_names /= length arg_tys
+		| not (equalLength id_names arg_tys)
 		= pprPanic "tcCoreAlts" (ppr (con, names, rhs) $$
 					 (ppr main_tyvars <+> ppr ex_tyvars) $$
 					 ppr arg_tys)
@@ -349,7 +354,7 @@ tcCoreAlt scrut_ty alt@(con, names, rhs)
 #endif
 		= zipWithEqual "tcCoreAlts" mkLocalId id_names arg_tys
     in
-    ASSERT( con `elem` tyConDataCons tycon && length inst_tys == length main_tyvars )
+    ASSERT( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars )
     tcExtendTyVarEnv ex_tyvars'			$
     tcExtendGlobalValEnv arg_ids		$
     tcCoreExpr rhs					`thenTc` \ rhs' ->
@@ -367,6 +372,32 @@ tcConAlt (UfDataAlt con_name)
 		    Nothing  -> pprPanic "tcCoreAlt" (ppr con_id))
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Core decls}
+%*									*
+%************************************************************************
+
+
+\begin{code}
+tcCoreBinds :: [RenamedTyClDecl] -> TcM [TypecheckedCoreBind]
+-- We don't assume the bindings are in dependency order
+-- So first build the environment, then check the RHSs
+tcCoreBinds ls = mapTc tcCoreBinder ls		`thenTc` \ bndrs ->
+		 tcExtendGlobalValEnv bndrs	$
+		 mapTc tcCoreBind ls
+
+tcCoreBinder (CoreDecl { tcdName = nm, tcdType = ty })
+ = tcIfaceType ty   `thenTc` \ ty' ->
+   returnTc (mkLocalId nm ty')
+
+tcCoreBind (CoreDecl { tcdName = nm, tcdRhs = rhs })
+ = tcVar nm		`thenTc` \ id ->
+   tcCoreExpr rhs	`thenTc` \ rhs' ->
+   returnTc (id, rhs')
+\end{code}
+
+
 \begin{code}
 ifaceSigCtxt sig_name
   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]