[project @ 2000-11-14 10:46:39 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 41ca4f7..6acef37 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -39,21 +39,21 @@ module TcHsSyn (
 import HsSyn   -- oodles of it
 
 -- others:
-import Id      ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id )
+import Id      ( idName, idType, isLocalId, idUnfolding, setIdType, isIP, Id )
 import DataCon ( dataConWrapId )       
-import TcEnv   ( tcLookupValueMaybe, tcExtendGlobalValEnv, tcGetValueEnv,
-                 ValueEnv, TcId, tcInstId
+import TcEnv   ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
+                 TcEnv, TcId, tcInstId
                )
 
 import TcMonad
 import TcType  ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
                )
-import Name    ( isLocallyDefined )
 import CoreSyn  ( Expr )
 import CoreUnfold( unfoldingTemplate )
 import BasicTypes ( RecFlag(..) )
 import Bag
 import Outputable
+import HscTypes        ( TyThing(..) )
 \end{code}
 
 
@@ -164,9 +164,8 @@ zonkIdBndr id
 
 zonkIdOcc :: TcId -> NF_TcM Id
 zonkIdOcc id 
-  | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id
-       -- The omitIfaceSigForId thing may look wierd but it's quite
-       -- sensible really.  We're avoiding looking up superclass selectors
+  | not (isLocalId id) || isIP id
+       -- We're avoiding looking up superclass selectors
        -- and constructors; zonking them is a no-op anyway, and the
        -- superclass selectors aren't in the environment anyway.
   = returnNF_Tc id
@@ -175,19 +174,19 @@ zonkIdOcc id
     let
        new_id = case maybe_id' of
                    Just (AnId id') -> id'
-                   other  -> pprTrace "zonkIdOcc: " (ppr id) id
+                   other  -> pprTrace "zonkIdOcc:" (ppr id) id
     in
     returnNF_Tc new_id
 \end{code}
 
 
 \begin{code}
-zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, ValueEnv)
+zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, TcEnv)
 zonkTopBinds binds     -- Top level is implicitly recursive
   = fixNF_Tc (\ ~(_, new_ids) ->
        tcExtendGlobalValEnv (bagToList new_ids)        $
        zonkMonoBinds binds                     `thenNF_Tc` \ (binds', new_ids) ->
-       tcGetValueEnv                           `thenNF_Tc` \ env ->
+       tcGetEnv                                `thenNF_Tc` \ env ->
        returnNF_Tc ((binds', env), new_ids)
     )                                  `thenNF_Tc` \ (stuff, _) ->
     returnNF_Tc stuff
@@ -509,6 +508,15 @@ zonkStmts :: [TcStmt]
 
 zonkStmts [] = returnNF_Tc []
 
+zonkStmts (ParStmtOut bndrstmtss : stmts)
+  = mapNF_Tc (mapNF_Tc zonkId) bndrss  `thenNF_Tc` \ new_bndrss ->
+    let new_binders = concat new_bndrss in
+    mapNF_Tc zonkStmts stmtss          `thenNF_Tc` \ new_stmtss ->
+    tcExtendGlobalValEnv new_binders   $ 
+    zonkStmts stmts                    `thenNF_Tc` \ new_stmts ->
+    returnNF_Tc (ParStmtOut (zip new_bndrss new_stmtss) : new_stmts)
+  where (bndrss, stmtss) = unzip bndrstmtss
+
 zonkStmts [ReturnStmt expr]
   = zonkExpr expr              `thenNF_Tc` \ new_expr ->
     returnNF_Tc [ReturnStmt new_expr]