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

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index ebfd83f..956096d 100644
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -4,7 +4,12 @@
 \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"
 
@@ -29,9 +34,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 )
@@ -142,7 +147,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 +223,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 +335,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 +371,28 @@ tcConAlt (UfDataAlt con_name)
 		    Nothing  -> pprPanic "tcCoreAlt" (ppr con_id))
 \end{code}
 
+%************************************************************************
+%*									*
+\subsection{Core decls}
+%*									*
+%************************************************************************
+
+
+\begin{code}
+tcCoreBinds :: [RenamedTyClDecl]
+            -> TcM [(Id, Type, CoreExpr)]
+tcCoreBinds ls = mapTc tcOne ls
+ where
+  tcOne (CoreDecl { tcdName = nm, tcdType = ty, tcdRhs = rhs }) =
+   tcVar nm         `thenTc` \ i ->
+   tcIfaceType ty   `thenTc` \ ty' ->
+   tcCoreExpr  rhs  `thenTc` \ rhs' ->
+   returnTc (i,ty',rhs')
+
+\end{code}
+
+
+
 \begin{code}
 ifaceSigCtxt sig_name
   = hsep [ptext SLIT("In an interface-file signature for"), ppr sig_name]