[project @ 2001-03-06 15:00:25 by rrt]

[ghc-hetmet.git] / ghc / compiler / main / HscMain.lhs

diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 141af7a..ab8730c 100644 (file)
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -16,6 +16,9 @@ module HscMain ( HscResult(..), hscMain,
 import RdrHsSyn                ( RdrNameStmt )
 import Rename          ( renameStmt )
 import ByteCodeGen     ( byteCodeGen )
+import Id              ( Id, idName, idFlavour, modifyIdInfo )
+import IdInfo          ( setFlavourInfo, makeConstantFlavour )
+import HscTypes                ( InteractiveContext(..), TyThing(..) )
 #endif
 
 import HsSyn
@@ -28,9 +31,10 @@ import SrcLoc                ( mkSrcLoc )
 import Rename          ( checkOldIface, renameModule, closeIfaceDecls )
 import Rules           ( emptyRuleBase )
 import PrelInfo                ( wiredInThingEnv, wiredInThings )
-import PrelNames       ( vanillaSyntaxMap, knownKeyNames )
+import PrelNames       ( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE )
 import MkIface         ( completeIface, mkModDetailsFromIface, mkModDetails,
                          writeIface, pprIface )
+import Type            ( Type )
 import TcModule
 import InstEnv         ( emptyInstEnv )
 import Desugar
@@ -38,13 +42,12 @@ import SimplCore
 import CoreUtils       ( coreBindsSize )
 import CoreTidy                ( tidyCorePgm )
 import CoreSat
+import CoreTidy                ( tidyCoreExpr )
 import CoreToStg       ( coreToStg )
 import SimplStg                ( stg2stg )
 import CodeGen         ( codeGen )
 import CodeOutput      ( codeOutput )
 
-import Id              ( Id, idName, idFlavour, modifyIdInfo )
-import IdInfo          ( setFlavourInfo, makeConstantFlavour )
 import Module          ( ModuleName, moduleName, mkHomeModule, 
                          moduleUserString )
 import CmdLineOpts
@@ -59,15 +62,14 @@ import CmStaticInfo ( GhciMode(..) )
 import HscStats                ( ppSourceStats )
 import HscTypes                ( ModDetails, ModIface(..), PersistentCompilerState(..),
                          PersistentRenamerState(..), ModuleLocation(..),
-                         HomeSymbolTable, InteractiveContext(..), TyThing(..),
+                         HomeSymbolTable, 
                          NameSupply(..), PackageRuleBase, HomeIfaceTable, 
-                         typeEnvClasses, typeEnvTyCons, emptyIfaceTable,
-                         extendLocalRdrEnv
+                         typeEnvClasses, typeEnvTyCons, emptyIfaceTable
                        )
 import FiniteMap       ( FiniteMap, plusFM, emptyFM, addToFM )
 import OccName         ( OccName )
 import Name            ( Name, nameModule, nameOccName, getName, isGlobalName,
-                         emptyNameEnv, extendNameEnvList
+                         emptyNameEnv
                        )
 import Module          ( Module, lookupModuleEnvByName )
 
@@ -95,8 +97,8 @@ data HscResult
    | HscRecomp   PersistentCompilerState -- updated PCS
                  ModDetails             -- new details (HomeSymbolTable additions)
                  ModIface               -- new iface (if any compilation was done)
-                (Maybe String)          -- generated stub_h filename (in /tmp)
-                (Maybe String)          -- generated stub_c filename (in /tmp)
+                (Maybe String)          -- generated stub_h filename (in TMPDIR)
+                (Maybe String)          -- generated stub_c filename (in TMPDIR)
                 (Maybe ([UnlinkedBCO],ItblEnv)) -- interpreted code, if any
              
 
@@ -416,9 +418,11 @@ hscStmt
   -> PersistentCompilerState    -- IN: persistent compiler state
   -> InteractiveContext                -- Context for compiling
   -> String                    -- The statement
+  -> Bool                      -- just treat it as an expression
   -> IO ( PersistentCompilerState, 
          Maybe ( [Id], 
-                UnlinkedBCOExpr) )
+                 Type, 
+                 UnlinkedBCOExpr) )
 \end{code}
 
 When the UnlinkedBCOExpr is linked you get an HValue of type
@@ -448,40 +452,60 @@ A naked expression returns a singleton Name [it].
          result not showable)  ==>     error
 
 \begin{code}
-hscStmt dflags hst hit pcs0 icontext stmt
+hscStmt dflags hst hit pcs0 icontext stmt just_expr
    = let 
        InteractiveContext { 
-            ic_rn_env = rn_env, 
+            ic_rn_env   = rn_env, 
             ic_type_env = type_env,
-            ic_module   = this_mod } = icontext
+            ic_module   = scope_mod } = icontext
      in
      do { maybe_stmt <- hscParseStmt dflags stmt
        ; case maybe_stmt of
             Nothing -> return (pcs0, Nothing)
             Just parsed_stmt -> do {
 
+          let { notExprStmt (ExprStmt _ _) = False;
+                notExprStmt _              = True 
+              };
+
+          if (just_expr && notExprStmt parsed_stmt)
+               then do hPutStrLn stderr ("not an expression: `" ++ stmt ++ "'")
+                       return (pcs0, Nothing)
+               else do {
+
                -- Rename it
          (pcs1, print_unqual, maybe_renamed_stmt)
-                <- renameStmt dflags hit hst pcs0 this_mod rn_env parsed_stmt
+                <- renameStmt dflags hit hst pcs0 scope_mod 
+                               iNTERACTIVE rn_env parsed_stmt
+
        ; case maybe_renamed_stmt of
                Nothing -> return (pcs0, Nothing)
                Just (bound_names, rn_stmt) -> do {
 
                -- Typecheck it
-         maybe_tc_return <- typecheckStmt dflags pcs1 hst type_env
-                                          print_unqual this_mod bound_names rn_stmt
-       ; case maybe_tc_return of {
-               Nothing -> return (pcs0, Nothing) ;
-               Just (pcs2, tc_expr, bound_ids) -> do {
+         maybe_tc_return <- 
+           if just_expr 
+               then case rn_stmt of { (syn, ExprStmt e _, decls) -> 
+                    typecheckExpr dflags pcs1 hst type_env
+                          print_unqual iNTERACTIVE (syn,e,decls) }
+               else typecheckStmt dflags pcs1 hst type_env
+                          print_unqual iNTERACTIVE bound_names rn_stmt
+
+       ; case maybe_tc_return of
+               Nothing -> return (pcs0, Nothing)
+               Just (pcs2, tc_expr, bound_ids, ty) ->  do {
 
                -- Desugar it
-         ds_expr <- deSugarExpr dflags pcs2 hst this_mod print_unqual tc_expr
+         ds_expr <- deSugarExpr dflags pcs2 hst iNTERACTIVE print_unqual tc_expr
        
                -- Simplify it
        ; simpl_expr <- simplifyExpr dflags pcs2 hst ds_expr
 
+               -- Tidy it (temporary, until coreSat does cloning)
+       ; tidy_expr <- tidyCoreExpr simpl_expr
+
                -- Saturate it
-       ; sat_expr <- coreSatExpr dflags simpl_expr
+       ; sat_expr <- coreSatExpr dflags tidy_expr
 
                -- Convert to BCOs
        ; bcos <- coreExprToBCOs dflags sat_expr
@@ -498,7 +522,8 @@ hscStmt dflags hst hit pcs0 icontext stmt
                 = modifyIdInfo (`setFlavourInfo` makeConstantFlavour 
                                        (idFlavour id)) id
 
-       ; return (pcs2, Just (constant_bound_ids, bcos))
+       ; return (pcs2, Just (constant_bound_ids, ty, bcos))
+
      }}}}}
 
 hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt)