[project @ 2005-02-15 12:15:25 by simonmar]

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

diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 35f9814..f711bd1 100644 (file)
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -#include "Linker.h" #-}
 -----------------------------------------------------------------------------
--- $Id: InteractiveUI.hs,v 1.184 2005/01/26 12:58:09 simonmar Exp $
+-- $Id: InteractiveUI.hs,v 1.188 2005/02/15 12:15:25 simonmar Exp $
 --
 -- GHC Interactive User Interface
 --
@@ -12,12 +12,10 @@ module InteractiveUI (
        ghciWelcomeMsg
    ) where
 
-#include "../includes/ghcconfig.h"
 #include "HsVersions.h"
 
 import CompManager
-import HscTypes                ( HomeModInfo(hm_linkable), HomePackageTable,
-                         isObjectLinkable, GhciMode(..) )
+import HscTypes                ( GhciMode(..) )
 import IfaceSyn                ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecls(..), IfaceConDecl(..), 
                          IfaceInst(..), pprIfaceDeclHead, pprParendIfaceType, pprIfaceForAllPart )
 import FunDeps         ( pprFundeps )
@@ -30,7 +28,7 @@ import Name           ( Name, NamedThing(..) )
 import OccName         ( OccName, isSymOcc, occNameUserString )
 import BasicTypes      ( StrictnessMark(..), defaultFixity, SuccessFlag(..) )
 import Outputable
-import CmdLineOpts     ( DynFlag(..), DynFlags(..), dopt_unset )
+import CmdLineOpts     ( DynFlags(..) )
 import Panic           hiding ( showException )
 import Config
 import SrcLoc          ( SrcLoc, isGoodSrcLoc )
@@ -52,7 +50,7 @@ import System.Console.Readline as Readline
 
 import Control.Exception as Exception
 import Data.Dynamic
-import Control.Concurrent
+-- import Control.Concurrent
 
 import Numeric
 import Data.List
@@ -60,6 +58,7 @@ import Data.Int               ( Int64 )
 import System.Cmd
 import System.CPUTime
 import System.Environment
+import System.Exit     ( exitWith, ExitCode(..) )
 import System.Directory
 import System.IO
 import System.IO.Error as IO
@@ -248,7 +247,7 @@ runGHCi paths dflags maybe_expr = do
            interactiveLoop is_tty show_prompt
        Just expr -> do
            -- just evaluate the expression we were given
-           runCommand expr
+           runCommandEval expr
            return ()
 
   -- and finally, exit
@@ -358,6 +357,15 @@ readlineLoop = do
 runCommand :: String -> GHCi Bool
 runCommand c = ghciHandle handler (doCommand c)
 
+-- This version is for the GHC command-line option -e.  The only difference
+-- from runCommand is that it catches the ExitException exception and
+-- exits, rather than printing out the exception.
+runCommandEval c = ghciHandle handleEval (doCommand c)
+  where 
+    handleEval (ExitException code) = io (exitWith code)
+    handleEval e                    = do showException e
+                                        io (exitWith (ExitFailure 1))
+
 -- This is the exception handler for exceptions generated by the
 -- user's code; it normally just prints out the exception.  The
 -- handler must be recursive, in case showing the exception causes
@@ -401,7 +409,7 @@ runStmt stmt
       setGHCiState st{cmstate = new_cmstate}
       case result of
        CmRunFailed      -> return []
-       CmRunException e -> showException e >> return []
+       CmRunException e -> throw e  -- this is caught by runCommand(Eval)
        CmRunOk names    -> return names
 
 -- possibly print the type and revert CAFs after evaluating an expression
@@ -447,9 +455,9 @@ noArgs c = throwDyn (CmdLineError ("command '" ++ c ++ "' takes no arguments"))
 GLOBAL_VAR(flush_interp,       error "no flush_interp", IO ())
 GLOBAL_VAR(turn_off_buffering, error "no flush_stdout", IO ())
 
-no_buf_cmd = "IO.hSetBuffering IO.stdout IO.NoBuffering" ++
-            " Prelude.>> IO.hSetBuffering IO.stderr IO.NoBuffering"
-flush_cmd  = "IO.hFlush IO.stdout Prelude.>> IO.hFlush IO.stderr"
+no_buf_cmd = "System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering" ++
+            " Prelude.>> System.IO.hSetBuffering System.IO.stderr System.IO.NoBuffering"
+flush_cmd  = "System.IO.hFlush System.IO.stdout Prelude.>> System.IO.hFlush IO.stderr"
 
 initInterpBuffering :: CmState -> IO ()
 initInterpBuffering cmstate
@@ -498,9 +506,8 @@ info s  = do { let names = words s
 
 showThing :: GetInfoResult -> SDoc
 showThing  (wanted_str, (thing, fixity, src_loc, insts)) 
-    = vcat [ showDecl want_name thing, 
+    = vcat [ showWithLoc src_loc (showDecl want_name thing),
             show_fixity fixity,
-            show_loc src_loc,
             vcat (map show_inst insts)]
   where
     want_name occ = wanted_str == occNameUserString occ
@@ -509,15 +516,19 @@ showThing  (wanted_str, (thing, fixity, src_loc, insts))
        | fix == defaultFixity = empty
        | otherwise            = ppr fix <+> text wanted_str
 
+    show_inst (iface_inst, loc)
+       = showWithLoc loc (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
+
+showWithLoc :: SrcLoc -> SDoc -> SDoc
+showWithLoc loc doc 
+    = hang doc 2 (char '\t' <> show_loc 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("--")
 
-    show_inst (iface_inst, loc)
-       = hang (ptext SLIT("instance") <+> ppr (ifInstHead iface_inst))
-            2 (char '\t' <> show_loc loc)
-               -- The tab tries to make them line up a bit
 
 -- Now there is rather a lot of goop just to print declarations in a
 -- civilised way with "..." for the parts we are less interested in.