[project @ 2000-11-14 10:46:39 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 eceff0e..c947fab 100644 (file)
--- a/ghc/compiler/typecheck/TcIfaceSig.lhs
+++ b/ghc/compiler/typecheck/TcIfaceSig.lhs
@@ -8,17 +8,16 @@ module TcIfaceSig ( tcInterfaceSigs, tcVar, tcCoreExpr, tcCoreLamBndrs ) where
 
 #include "HsVersions.h"
 
-import HsSyn           ( HsDecl(..), IfaceSig(..), HsTupCon(..) )
+import HsSyn           ( HsDecl(..), TyClDecl(..), HsTupCon(..) )
 import TcMonad
 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
 
-import TcEnv           ( ValueEnv, tcExtendTyVarEnv, 
-                         tcExtendGlobalValEnv, tcSetValueEnv,
-                         tcLookupValueMaybe,
-                         explicitLookupValue, badCon, badPrimOp, valueEnvIds
+import TcEnv           ( TcEnv, RecTcEnv, tcExtendTyVarEnv, 
+                         tcExtendGlobalValEnv, tcSetEnv,
+                         tcLookupGlobal_maybe, tcLookupRecId, tcEnvIds
                        )
 
 import RnHsSyn         ( RenamedHsDecl )
@@ -30,19 +29,18 @@ import CoreUnfold
 import CoreLint                ( lintUnfolding )
 import WorkWrap                ( mkWrapper )
 
-import Id              ( Id, mkId, mkVanillaId,
-                         isDataConWrapId_maybe
-                       )
+import Id              ( Id, mkId, mkVanillaId, isDataConWrapId_maybe )
 import MkId            ( mkCCallOpId )
 import IdInfo
 import DataCon         ( dataConSig, dataConArgTys )
-import Type            ( mkSynTy, mkTyVarTys, splitAlgTyConApp, splitAlgTyConApp_maybe, splitFunTys, unUsgTy )
+import Type            ( mkTyVarTys, splitAlgTyConApp_maybe )
 import Var             ( mkTyVar, tyVarKind )
-import Name            ( Name, NamedThing(..), isLocallyDefined )
+import Name            ( Name )
 import Demand          ( wwLazy )
 import ErrUtils                ( pprBagOfErrors )
 import Outputable      
 import Util            ( zipWithEqual )
+import HscTypes                ( TyThing(..) )
 \end{code}
 
 Ultimately, type signatures in interfaces will have pragmatic
@@ -53,16 +51,16 @@ 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 :: RecTcEnv            -- Envt to use when checking unfoldings
                -> [RenamedHsDecl]      -- Ignore non-sig-decls in these decls
-               -> TcM s [Id]
+               -> TcM [Id]
                
 
 tcInterfaceSigs unf_env decls
   = listTc [ do_one name ty id_infos src_loc
-          | SigD (IfaceSig name ty id_infos src_loc) <- decls]
+          | TyClD (IfaceSig name ty id_infos src_loc) <- decls]
   where
-    in_scope_vars = filter isLocallyDefined (valueEnvIds unf_env)
+    in_scope_vars = [] -- I think this will be OK
 
     do_one name ty id_infos src_loc
       = tcAddSrcLoc src_loc                            $       
@@ -75,7 +73,7 @@ tcInterfaceSigs unf_env decls
 
 \begin{code}
 tcIdInfo unf_env in_scope_vars name ty info info_ins
-  = foldlTc tcPrag vanillaIdInfo info_ins
+  = foldlTc tcPrag constantIdInfo info_ins
   where
     tcPrag info (HsArity arity) = returnTc (info `setArityInfo`  arity)
     tcPrag info (HsNoCafRefs)   = returnTc (info `setCafInfo`   NoCafRefs)
@@ -110,11 +108,11 @@ 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
-                       Just worker_id -> info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
-                                               `setWorkerInfo`     HasWorker worker_id arity
+       info' = case tcLookupRecId unf_env worker_name of
+                 Just worker_id -> info `setUnfoldingInfo`  mkTopUnfolding (wrap_fn worker_id)
+                                         `setWorkerInfo`     HasWorker worker_id arity
 
-                       Nothing        -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
+                 Nothing        -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
     in
     returnTc info'
   where
@@ -138,17 +136,18 @@ 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
+       getDOptsTc              `thenTc` \ dflags ->
+       case lintUnfolding dflags src_loc in_scope_vars core_expr' of
          (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 :: RecTcEnv -> 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
@@ -167,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]
@@ -181,7 +180,7 @@ 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)
   = tcHsType ty                `thenTc` \ ty' ->
@@ -211,7 +210,7 @@ tcCoreExpr (UfTuple (HsTupCon name _) args)
     mapTc tcCoreExpr args      `thenTc` \ args' ->
     let
        -- Put the missing type arguments back in
-       con_args = map (Type . unUsgTy . exprType) args' ++ args'
+       con_args = map (Type . exprType) args' ++ args'
     in
     returnTc (mkApps (Var con_id) con_args)
 
@@ -253,14 +252,11 @@ tcCoreExpr (UfNote note expr)
   = tcCoreExpr expr            `thenTc` \ expr' ->
     case note of
        UfCoerce to_ty -> tcHsType to_ty        `thenTc` \ to_ty' ->
-                         returnTc (Note (Coerce (unUsgTy to_ty')
-                                                 (unUsgTy (exprType expr'))) expr')
+                         returnTc (Note (Coerce to_ty'
+                                                 (exprType expr')) expr')
        UfInlineCall   -> returnTc (Note InlineCall expr')
        UfInlineMe     -> returnTc (Note InlineMe   expr')
        UfSCC cc       -> returnTc (Note (SCC cc)   expr')
-
-tcCoreNote (UfSCC cc)   = returnTc (SCC cc)
-tcCoreNote UfInlineCall = returnTc InlineCall 
 \end{code}
 
 \begin{code}