[project @ 2003-07-02 14:59:00 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs
index bd65fc4..ade0e60 100644 (file)
--- a/ghc/compiler/typecheck/TcRnDriver.lhs
+++ b/ghc/compiler/typecheck/TcRnDriver.lhs
@@ -22,7 +22,6 @@ import                      DsMeta   ( templateHaskellNames )
 
 import CmdLineOpts     ( DynFlag(..), opt_PprStyle_Debug, dopt )
 import DriverState     ( v_MainModIs, v_MainFunIs )
-import DriverUtil      ( split_longest_prefix )
 import HsSyn           ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
                          Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
                          HsGroup(..), SpliceDecl(..),
@@ -32,11 +31,10 @@ import HsSyn                ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
 import RdrHsSyn                ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
                          emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual )
 
-import PrelNames       ( iNTERACTIVE, ioTyConName, printName,
-                         returnIOName, bindIOName, failIOName, thenIOName, runIOName, 
+import PrelNames       ( iNTERACTIVE, ioTyConName, printName, monadNames,
+                         returnIOName, runIOName, 
                          dollarMainName, itName, mAIN_Name, unsafeCoerceName
                        )
-import MkId            ( unsafeCoerceId )
 import RdrName         ( RdrName, getRdrName, mkRdrUnqual, 
                          lookupRdrEnv, elemRdrEnv )
 
@@ -49,13 +47,11 @@ import TcHsSyn              ( TypecheckedHsExpr, TypecheckedRuleDecl,
 
 import TcExpr          ( tcInferRho, tcCheckRho )
 import TcRnMonad
-import TcMType         ( newTyVarTy, zonkTcType )
-import TcType          ( Type, liftedTypeKind, 
+import TcType          ( Type, 
                          tyVarsOfType, tcFunResultTy, tidyTopType,
                          mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
                        )
-import TcMatches       ( tcStmtsAndThen, TcStmtCtxt(..) )
-import Inst            ( showLIE )
+import Inst            ( showLIE, tcStdSyntaxName )
 import TcBinds         ( tcTopBinds )
 import TcClassDcl      ( tcClassDecls2 )
 import TcDefaults      ( tcDefaults )
@@ -77,21 +73,17 @@ import RnIfaces             ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
 import RnHiFiles       ( readIface, loadOldIface )
 import RnEnv           ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
                          ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
-import RnExpr          ( rnStmts, rnExpr )
 import RnSource                ( rnSrcDecls, checkModDeprec, rnStats )
 
 import CoreUnfold      ( unfoldingTemplate )
 import CoreSyn         ( IdCoreRule, Bind(..) )
 import PprCore         ( pprIdRules, pprCoreBindings )
-import TysWiredIn      ( mkListTy, unitTy )
 import ErrUtils                ( mkDumpDoc, showPass, pprBagOfErrors )
 import Id              ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
-import IdInfo          ( GlobalIdDetails(..) )
 import Var             ( Var, setGlobalIdDetails )
-import Module           ( Module, ModuleName, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts )
+import Module           ( Module, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts )
 import OccName         ( mkVarOcc )
 import Name            ( Name, isExternalName, getSrcLoc, nameOccName )
-import NameEnv         ( delListFromNameEnv )
 import NameSet
 import TyCon           ( tyConGenInfo )
 import BasicTypes       ( EP(..), RecFlag(..) )
@@ -111,9 +103,15 @@ import HscTypes            ( PersistentCompilerState(..), InteractiveContext(..),
                          extendLocalRdrEnv, emptyFixityEnv
                        )
 #ifdef GHCI
+import TcMType         ( zonkTcType )
+import TcMatches       ( tcStmtsAndThen, TcStmtCtxt(..) )
 import RdrName         ( rdrEnvElts )
+import RnExpr          ( rnStmts, rnExpr )
 import RnHiFiles       ( loadInterface )
 import RnEnv           ( mkGlobalRdrEnv )
+import TysWiredIn      ( mkListTy, unitTy )
+import IdInfo          ( GlobalIdDetails(..) )
+import NameEnv         ( delListFromNameEnv )
 import HscTypes                ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..), 
                          isLocalGRE )
 #endif
@@ -297,7 +295,7 @@ tcRnStmt hsc_env pcs ictxt rdr_stmt
     setGblEnv tcg_env $ do {
     
     -- The real work is done here
-    ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
+    (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
     
     traceTc (text "tcs 1") ;
     let {      -- Make all the bound ids "global" ids, now that
@@ -402,20 +400,24 @@ tc_stmts stmts
                             (ExplicitList placeHolderType (map mk_item names)) ;
            mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ;
 
-           all_stmts = stmts ++ [ret_stmt]
+           all_stmts = stmts ++ [ret_stmt] ;
+
+           io_ty = mkTyConApp ioTyCon []
         } ;
 
        -- OK, we're ready to typecheck the stmts
        traceTc (text "tcs 2") ;
-       ((ids, tc_stmts), lie) <- 
-               getLIE                                  $ 
-               tcStmtsAndThen combine stmt_ctxt stmts  $ 
-               do {
-                   -- Look up the names right in the middle,
-                   -- where they will all be in scope
-                   ids <- mappM tcLookupId names ;
-                   return (ids, [])
-               } ;
+       ((ids, tc_expr), lie) <- getLIE $ do {
+           (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt all_stmts       $ 
+                       do {
+                           -- Look up the names right in the middle,
+                           -- where they will all be in scope
+                           ids <- mappM tcLookupId names ;
+                           return (ids, []) } ;
+           io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
+           return (ids, HsDo DoExpr tc_stmts io_ids
+                             (mkTyConApp ioTyCon [ret_ty]) noSrcLoc) 
+       } ;
 
        -- Simplify the context right here, so that we fail
        -- if there aren't enough instances.  Notably, when we see
@@ -427,11 +429,7 @@ tc_stmts stmts
        const_binds <- tcSimplifyTop lie ;
 
        -- Build result expression and zonk it
-       io_ids <- mappM mk_rebound
-                       [returnIOName, failIOName, bindIOName, thenIOName] ;
-       let { expr = mkHsLet const_binds $
-                    HsDo DoExpr tc_stmts io_ids
-                         (mkTyConApp ioTyCon [ret_ty]) noSrcLoc } ;
+       let { expr = mkHsLet const_binds tc_expr } ;
        zonked_expr <- zonkTopExpr expr ;
        zonked_ids  <- zonkTopBndrs ids ;
 
@@ -439,8 +437,6 @@ tc_stmts stmts
        }
   where
     combine stmt (ids, stmts) = (ids, stmt:stmts)
-    mk_rebound n = do { id <- tcLookupId n; return (n, HsVar id) }
-       -- A bit hackoid
 \end{code}
 
 
@@ -534,7 +530,7 @@ initRnInteractive ictxt rn_thing
   = initRn CmdLineMode $
     setLocalRdrEnv (ic_rn_local_env ictxt) $
     rn_thing
-#endif
+#endif /* GHCI */
 \end{code}
 
 %************************************************************************