[project @ 2000-12-12 14:35:08 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index 463964b..3d58d8e 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -18,18 +18,19 @@ import HsTypes              ( toHsType )
 import RnHsSyn         ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
 import TcHsSyn         ( TypecheckedMonoBinds, TypecheckedHsExpr,
                          TypecheckedForeignDecl, TypecheckedRuleDecl,
-                         zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet
+                         zonkTopBinds, zonkForeignExports, zonkRules, mkHsLet,
+                         zonkExpr
                        )
 
 
 import TcMonad
-import TcType          ( newTyVarTy )
+import TcType          ( newTyVarTy, zonkTcType )
 import Inst            ( plusLIE )
 import TcBinds         ( tcTopBinds )
 import TcClassDcl      ( tcClassDecls2 )
 import TcDefaults      ( tcDefaults, defaultDefaultTys )
 import TcExpr          ( tcMonoExpr )
-import TcEnv           ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, 
+import TcEnv           ( TcEnv, InstInfo, tcExtendGlobalValEnv, 
                          isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv
                        )
 import TcRules         ( tcIfaceRules, tcSourceRules )
@@ -42,7 +43,7 @@ import TcTyClsDecls   ( tcTyAndClassDecls )
 import CoreUnfold      ( unfoldingTemplate, hasUnfolding )
 import Type            ( funResultTy, splitForAllTys, openTypeKind )
 import Bag             ( isEmptyBag )
-import ErrUtils                ( printErrorsAndWarnings, dumpIfSet_dyn, showPass )
+import ErrUtils                ( printErrorsAndWarnings, errorsFound, dumpIfSet_dyn, showPass )
 import Id              ( idType, idUnfolding )
 import Module           ( Module )
 import Name            ( Name, toRdrName )
@@ -50,10 +51,9 @@ import Name          ( nameEnvElts, lookupNameEnv )
 import TyCon           ( tyConGenInfo )
 import Util
 import BasicTypes       ( EP(..), Fixity )
-import Bag             ( isEmptyBag )
 import Outputable
 import HscTypes                ( PersistentCompilerState(..), HomeSymbolTable, 
-                         PackageTypeEnv, DFunId, ModIface(..),
+                         PackageTypeEnv, ModIface(..),
                          TypeEnv, extendTypeEnvList, 
                          TyThing(..), implicitTyThingIds, 
                          mkTypeEnv
@@ -68,7 +68,6 @@ data TcResults
   = TcResults {
        -- All these fields have info *just for this module*
        tc_env     :: TypeEnv,                  -- The top level TypeEnv
-       tc_insts   :: [DFunId],                 -- Instances
        tc_binds   :: TypecheckedMonoBinds,     -- Bindings
        tc_fords   :: [TypecheckedForeignDecl], -- Foreign import & exports.
        tc_rules   :: [TypecheckedRuleDecl]     -- Transformation rules
@@ -107,7 +106,7 @@ typecheckExpr :: DynFlags
              -> Module
              -> (RenamedHsExpr,        -- The expression itself
                  [RenamedHsDecl])      -- Plus extra decls it sucked in from interface files
-             -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr))
+             -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
 
 typecheckExpr dflags pcs hst unqual this_mod (expr, decls)
   = typecheck dflags pcs hst unqual $
@@ -121,7 +120,10 @@ typecheckExpr dflags pcs hst unqual this_mod (expr, decls)
     newTyVarTy openTypeKind    `thenTc` \ ty ->
     tcMonoExpr expr ty         `thenTc` \ (expr', lie) ->
     tcSimplifyTop lie          `thenTc` \ binds ->
-    returnTc (new_pcs, mkHsLet binds expr') 
+    let all_expr = mkHsLet binds expr' in
+    zonkExpr all_expr          `thenNF_Tc` \ zonked_expr ->
+    zonkTcType ty              `thenNF_Tc` \ zonked_ty ->
+    returnTc (new_pcs, zonked_expr, zonked_ty) 
   where
     get_fixity :: Name -> Maybe Fixity
     get_fixity n = pprPanic "typecheckExpr" (ppr n)
@@ -138,14 +140,14 @@ typecheck dflags pcs hst unqual thing_inside
  = do  { showPass dflags "Typechecker";
        ; env <- initTcEnv hst (pcs_PTE pcs)
 
-       ; (maybe_tc_result, (warns,errs)) <- initTc dflags env thing_inside
+       ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
 
-       ; printErrorsAndWarnings unqual (errs,warns)
+       ; printErrorsAndWarnings unqual errs
 
-       ; if isEmptyBag errs then 
-             return maybe_tc_result
-           else 
+       ; if errorsFound errs then 
              return Nothing 
+           else 
+             return maybe_tc_result
        }
 \end{code}
 
@@ -242,7 +244,6 @@ tcModule pcs hst get_fixity this_mod decls
     returnTc (new_pcs,
              TcResults { tc_env     = local_type_env,
                          tc_binds   = implicit_binds `AndMonoBinds` all_binds', 
-                         tc_insts   = map iDFunId local_inst_info,
                          tc_fords   = foi_decls ++ foe_decls',
                          tc_rules   = all_local_rules
                         }