[project @ 2001-06-27 11:39:54 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 1108042..3ebbc7e 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -13,7 +13,7 @@ module TcModule (
 
 import CmdLineOpts     ( DynFlag(..), DynFlags, dopt )
 import HsSyn           ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
-                         Stmt(..), InPat(..), HsMatchContext(..), RuleDecl(..),
+                         Stmt(..), InPat(..), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
                          isIfaceRuleDecl, nullBinds, andMonoBindList, mkSimpleMatch
                        )
 import PrelNames       ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName,
@@ -32,9 +32,12 @@ import TcHsSyn               ( TypecheckedMonoBinds, TypecheckedHsExpr,
 import MkIface         ( pprModDetails )
 import TcExpr          ( tcMonoExpr )
 import TcMonad
-import TcType          ( newTyVarTy, zonkTcType, tcInstType )
+import TcMType         ( unifyTauTy, newTyVarTy, zonkTcType, tcInstType )
+import TcType          ( Type, liftedTypeKind, openTypeKind,
+                         tyVarsOfType, tidyType, tcFunResultTy,
+                         mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
+                       )
 import TcMatches       ( tcStmtsAndThen )
-import TcUnify         ( unifyTauTy )
 import Inst            ( emptyLIE, plusLIE )
 import TcBinds         ( tcTopBinds )
 import TcClassDcl      ( tcClassDecls2 )
@@ -50,10 +53,8 @@ import TcIfaceSig    ( tcInterfaceSigs )
 import TcInstDcls      ( tcInstDecls1, tcInstDecls2 )
 import TcSimplify      ( tcSimplifyTop, tcSimplifyInfer )
 import TcTyClsDecls    ( tcTyAndClassDecls )
-
 import CoreUnfold      ( unfoldingTemplate, hasUnfolding )
 import TysWiredIn      ( mkListTy, unitTy )
-import Type
 import ErrUtils                ( printErrorsAndWarnings, errorsFound, 
                          dumpIfSet_dyn, dumpIfSet_dyn_or, showPass )
 import Id              ( Id, idType, idUnfolding )
@@ -72,7 +73,6 @@ import HscTypes               ( PersistentCompilerState(..), HomeSymbolTable,
                          TyThing(..), implicitTyThingIds, 
                          mkTypeEnv
                        )
-import VarSet
 \end{code}
 
 
@@ -196,11 +196,11 @@ tc_stmts names stmts
     in
 
     traceTc (text "tcs 2") `thenNF_Tc_`
-    tcStmtsAndThen combine DoExpr io_ty stmts  (
+    tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts (
        -- Look up the names right in the middle,
        -- where they will all be in scope
        mapNF_Tc tcLookupId names                       `thenNF_Tc` \ ids ->
-       returnTc ((ids, [ExprStmt (mk_return ids) noSrcLoc]), emptyLIE)
+       returnTc ((ids, [ResultStmt (mk_return ids) noSrcLoc]), emptyLIE)
     )                                                  `thenTc` \ ((ids, tc_stmts), lie) ->
 
        -- Simplify the context right here, so that we fail
@@ -261,8 +261,8 @@ typecheckExpr dflags pcs hst ic_type_env unqual this_mod (syn_map, expr, decls)
 
     newTyVarTy openTypeKind            `thenTc` \ ty ->
     tcMonoExpr expr ty                         `thenTc` \ (e', lie) ->
-    tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie 
-                       `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
+    tcSimplifyInfer smpl_doc (tyVarsOfType ty) lie 
+                                       `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
     tcSimplifyTop lie_free             `thenTc` \ const_binds ->
 
     let all_expr = mkHsLet const_binds $
@@ -340,7 +340,7 @@ tcModule :: PersistentCompilerState
 
 tcModule pcs hst get_fixity this_mod decls
   = fixTc (\ ~(unf_env, _, _) ->
-               -- Loop back the final environment, including the fully zonkec
+               -- Loop back the final environment, including the fully zonked
                -- versions of bindings from this module.  In the presence of mutual
                -- recursion, interface type signatures may mention variables defined
                -- in this module, which is why the knot is so big
@@ -400,6 +400,7 @@ tcModule pcs hst get_fixity this_mod decls
                           lie_rules
        in
        tcSimplifyTop lie_alldecls      `thenTc` \ const_inst_binds ->
+        traceTc (text "endsimpltop") `thenTc_`
        
            -- Backsubstitution.    This must be done last.
            -- Even tcSimplifyTop may do some unification.
@@ -719,11 +720,10 @@ ppr_gen_tycon tycon
   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
 
 ppr_ep (EP from to)
-  = vcat [ ptext SLIT("Rep type:") <+> ppr (funResultTy from_tau),
+  = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
           ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
           ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
     ]
   where
-    (_,from_tau) = splitForAllTys (idType from)
-
+    (_,from_tau) = tcSplitForAllTys (idType from)
 \end{code}