X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcIfaceSig.lhs;h=e52c8d7d2bdf4882ab261ee911a7d7bacc107b0c;hb=5e392a5623fe7f896389f1b7c3fb3f340bea46a8;hp=ebfd83f19558e0b0d3fc3f3b03d721ac32c03124;hpb=d8af6b8ce9d241a8f8d6878e2400aa8577f552bc;p=ghc-hetmet.git

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index ebfd83f..e52c8d7 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,9 +35,9 @@ 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 )
@@ -81,9 +87,9 @@ tcInterfaceSigs unf_env mod decls
 tcIdInfo unf_env in_scope_vars name ty info_ins
   = foldlTc tcPrag init_info info_ins 
   where
-    -- set the CgInfo to something sensible but uninformative before
-    -- we start, because the default CgInfo is a panic.
-    init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo
+    -- Set the CgInfo to something sensible but uninformative before
+    -- we start; default assumption is that it has CAFs
+    init_info = hasCafIdInfo
 
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`	 NoCafRefs)
 
@@ -142,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)
@@ -218,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)
@@ -330,14 +336,14 @@ 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	    = dropList 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
 		| not (equalLength id_names arg_tys)
@@ -366,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]