[project @ 2001-05-23 10:26:14 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index a9a89e4..755c68b 100644 (file)
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -24,12 +24,11 @@ module TcHsSyn (
 
        mkHsTyApp, mkHsDictApp, mkHsConApp,
        mkHsTyLam, mkHsDictLam, mkHsLet,
-       idsToMonoBinds,
 
        -- re-exported from TcEnv
-       TcId, tcInstId,
+       TcId, 
 
-       zonkTopBinds, zonkId, zonkIdOcc,
+       zonkTopBinds, zonkId, zonkIdBndr, zonkIdOcc, zonkExpr,
        zonkForeignExports, zonkRules
   ) where
 
@@ -39,18 +38,16 @@ module TcHsSyn (
 import HsSyn   -- oodles of it
 
 -- others:
-import Id      ( idName, idType, idUnfolding, setIdType, omitIfaceSigForId, isIP, Id )
+import Id      ( idName, idType, setIdType, Id )
 import DataCon ( dataConWrapId )       
 import TcEnv   ( tcLookupGlobal_maybe, tcExtendGlobalValEnv,
-                 TcEnv, TcId, tcInstId
+                 TcEnv, TcId
                )
 
 import TcMonad
 import TcType  ( zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcType, zonkTcSigTyVars
                )
-import Name    ( isLocallyDefined )
 import CoreSyn  ( Expr )
-import CoreUnfold( unfoldingTemplate )
 import BasicTypes ( RecFlag(..) )
 import Bag
 import Outputable
@@ -119,12 +116,6 @@ mkHsLet EmptyMonoBinds expr = expr
 mkHsLet mbinds        expr = HsLet (MonoBind mbinds [] Recursive) expr
 
 mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args
-
-idsToMonoBinds :: [Id] -> TcMonoBinds 
-idsToMonoBinds ids
-  = andMonoBindList [ CoreMonoBind id (unfoldingTemplate (idUnfolding id))
-                   | id <- ids
-                   ]
 \end{code}
 
 %************************************************************************
@@ -165,18 +156,20 @@ 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
-       -- and constructors; zonking them is a no-op anyway, and the
-       -- superclass selectors aren't in the environment anyway.
-  = returnNF_Tc id
-  | otherwise 
   = tcLookupGlobal_maybe (idName id)   `thenNF_Tc` \ maybe_id' ->
+       -- We're even look up up superclass selectors and constructors; 
+       -- even though zonking them is a no-op anyway, and the
+       -- superclass selectors aren't in the environment anyway.
+       -- But we don't want to call isLocalId to find out whether
+       -- it's a superclass selector (for example) because that looks
+       -- at the IdInfo field, which in turn be in a knot because of
+       -- the big knot in typecheckModule
     let
        new_id = case maybe_id' of
                    Just (AnId id') -> id'
-                   other  -> pprTrace "zonkIdOcc: " (ppr id) id
+                   other           -> id -- WARN( isLocalId id, ppr id ) id
+                                       -- Oops: the warning can give a black hole
+                                       -- because it looks at the idinfo
     in
     returnNF_Tc new_id
 \end{code}
@@ -361,8 +354,8 @@ zonkExpr (OpApp e1 op fixity e2)
     zonkExpr e2        `thenNF_Tc` \ new_e2 ->
     returnNF_Tc (OpApp new_e1 new_op fixity new_e2)
 
-zonkExpr (NegApp _ _) = panic "zonkExpr: NegApp"
-zonkExpr (HsPar _)    = panic "zonkExpr: HsPar"
+zonkExpr (NegApp _) = panic "zonkExpr: NegApp"
+zonkExpr (HsPar _)  = panic "zonkExpr: HsPar"
 
 zonkExpr (SectionL expr op)
   = zonkExpr expr      `thenNF_Tc` \ new_expr ->
@@ -519,19 +512,15 @@ zonkStmts (ParStmtOut bndrstmtss : 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]
-
-zonkStmts (ExprStmt expr locn : stmts)
+zonkStmts (ResultStmt expr locn : stmts)
   = zonkExpr expr      `thenNF_Tc` \ new_expr ->
     zonkStmts stmts    `thenNF_Tc` \ new_stmts ->
-    returnNF_Tc (ExprStmt new_expr locn : new_stmts)
+    returnNF_Tc (ResultStmt new_expr locn : new_stmts)
 
-zonkStmts (GuardStmt expr locn : stmts)
+zonkStmts (ExprStmt expr locn : stmts)
   = zonkExpr expr      `thenNF_Tc` \ new_expr ->
     zonkStmts stmts    `thenNF_Tc` \ new_stmts ->
-    returnNF_Tc (GuardStmt new_expr locn : new_stmts)
+    returnNF_Tc (ExprStmt new_expr locn : new_stmts)
 
 zonkStmts (LetStmt binds : stmts)
   = zonkBinds binds            `thenNF_Tc` \ (new_binds, new_env) ->