[project @ 2002-07-30 11:49:17 by simonpj]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcIfaceSig.lhs

diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs
index ebfd83f..e52c8d7 100644 (file)
--- 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]