[project @ 2005-05-14 09:59:32 by panne]

[ghc-hetmet.git] / ghc / compiler / ghci / InteractiveUI.hs

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index eac04fe..282ad93 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -18,7 +18,8 @@ import qualified GHC
 import GHC             ( Session, verbosity, dopt, DynFlag(..),
                          mkModule, pprModule, Type, Module, SuccessFlag(..),
                          TyThing(..), Name, LoadHowMuch(..),
-                         GhcException(..), showGhcException )
+                         GhcException(..), showGhcException,
+                         CheckedModule(..) )
 import Outputable
 
 -- following all needed for :info... ToDo: remove
@@ -27,9 +28,9 @@ import IfaceSyn               ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..),
                          pprIfaceDeclHead, pprParendIfaceType,
                          pprIfaceForAllPart, pprIfaceType )
 import FunDeps         ( pprFundeps )
-import SrcLoc          ( SrcLoc, isGoodSrcLoc )
+import SrcLoc          ( SrcLoc, pprDefnLoc )
 import OccName         ( OccName, parenSymOcc, occNameUserString )
-import BasicTypes      ( StrictnessMark(..), defaultFixity )
+import BasicTypes      ( StrictnessMark(..), defaultFixity, failed, successIf )
 
 -- Other random utilities
 import Panic           ( panic, installSignalHandlers )
@@ -38,6 +39,7 @@ import StaticFlags    ( opt_IgnoreDotGhci )
 import Linker          ( showLinkerState )
 import Util            ( removeSpaces, handle, global, toArgs,
                          looksLikeModuleName, prefixMatch )
+import ErrUtils                ( printErrorsAndWarnings )
 
 #ifndef mingw32_HOST_OS
 import Util            ( handle )
@@ -45,6 +47,8 @@ import System.Posix
 #if __GLASGOW_HASKELL__ > 504
        hiding (getEnv)
 #endif
+#else
+import GHC.ConsoleHandler ( flushConsole )
 #endif
 
 #ifdef USE_READLINE
@@ -61,6 +65,7 @@ import Data.Dynamic
 import Numeric
 import Data.List
 import Data.Int                ( Int64 )
+import Data.Maybe      ( isJust )
 import System.Cmd
 import System.CPUTime
 import System.Environment
@@ -99,9 +104,10 @@ builtin_commands = [
   ("help",     keepGoing help),
   ("?",                keepGoing help),
   ("info",      keepGoing info),
-  ("load",     keepGoingPaths loadModule),
+  ("load",     keepGoingPaths loadModule_),
   ("module",   keepGoing setContext),
   ("reload",   keepGoing reloadModule),
+  ("check",    keepGoing checkModule),
   ("set",      keepGoing setCmd),
   ("show",     keepGoing showCmd),
   ("type",     keepGoing typeOfExpr),
@@ -189,6 +195,13 @@ interactiveUI session srcs maybe_expr = do
    Readline.initialize
 #endif
 
+#if defined(mingw32_HOST_OS)
+    -- The win32 Console API mutates the first character of 
+    -- type-ahead when reading from it in a non-buffered manner. Work
+    -- around this by flushing the input buffer of type-ahead characters.
+    -- 
+   GHC.ConsoleHandler.flushConsole stdin
+#endif
    startGHCi (runGHCi srcs maybe_expr)
        GHCiState{ progname = "<interactive>",
                   args = [],
@@ -235,9 +248,13 @@ runGHCi paths maybe_expr = do
                  Right hdl -> fileLoop hdl False
 
   -- Perform a :load for files given on the GHCi command line
-  when (not (null paths)) $
-     ghciHandle showException $
-       loadModule paths
+  -- When in -e mode, if the load fails then we want to stop
+  -- immediately rather than going on to evaluate the expression.
+  when (not (null paths)) $ do
+     ok <- ghciHandle (\e -> do showException e; return Failed) $ 
+               loadModule paths
+     when (isJust maybe_expr && failed ok) $
+       io (exitWith (ExitFailure 1))
 
   -- if verbosity is greater than 0, or we are connected to a
   -- terminal, display the prompt in the interactive loop.
@@ -538,12 +555,9 @@ showThing exts (wanted_str, thing, fixity, src_loc, insts)
 
 showWithLoc :: SrcLoc -> SDoc -> SDoc
 showWithLoc loc doc 
-    = hang doc 2 (char '\t' <> show_loc loc)
+    = hang doc 2 (char '\t' <> comment <+> pprDefnLoc loc)
                -- The tab tries to make them line up a bit
   where
-    show_loc loc       -- The ppr function for SrcLocs is a bit wonky
-       | isGoodSrcLoc loc = comment <+> ptext SLIT("Defined at") <+> ppr loc
-       | otherwise        = comment <+> ppr loc
     comment = ptext SLIT("--")
 
 
@@ -708,10 +722,13 @@ undefineMacro macro_name = do
   io (writeIORef commands (filter ((/= macro_name) . fst) cmds))
 
 
-loadModule :: [FilePath] -> GHCi ()
+loadModule :: [FilePath] -> GHCi SuccessFlag
 loadModule fs = timeIt (loadModule' fs)
 
-loadModule' :: [FilePath] -> GHCi ()
+loadModule_ :: [FilePath] -> GHCi ()
+loadModule_ fs = do loadModule fs; return ()
+
+loadModule' :: [FilePath] -> GHCi SuccessFlag
 loadModule' files = do
   session <- getSession
 
@@ -731,7 +748,25 @@ loadModule' files = do
   io (GHC.setTargets session targets)
   ok <- io (GHC.load session LoadAllTargets)
   afterLoad ok session
+  return ok
 
+checkModule :: String -> GHCi ()
+checkModule m = do
+  let modl = mkModule m
+  session <- getSession
+  result <- io (GHC.checkModule session modl printErrorsAndWarnings)
+  case result of
+    Nothing -> io $ putStrLn "Nothing"
+    Just r  -> io $ putStrLn (showSDoc (
+       case checkedModuleInfo r of
+          Just cm | Just scope <- GHC.modInfoTopLevelScope cm -> 
+               let
+                   (local,global) = partition ((== modl) . GHC.nameModule) scope
+               in
+                       (text "global names: " <+> ppr global) $$
+                       (text "local  names: " <+> ppr local)
+          _ -> empty))
+  afterLoad (successIf (isJust result)) session
 
 reloadModule :: String -> GHCi ()
 reloadModule "" = do