X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fghci%2FInteractiveUI.hs;h=22dae457c37687a52a0206a48fbed5ce215a1fea;hb=8344b1e4a6e20d289cee53a4b25b18c6c28449bf;hp=719714e3daec4c3045d982e891497b73a6d6f6e8;hpb=ef5b4b146aa172d8ac10f39b5eb3d7a0f948d8f1;p=ghc-hetmet.git diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 719714e..22dae45 100644 --- 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.180 2004/11/26 16:20:36 simonmar Exp $ +-- $Id: InteractiveUI.hs,v 1.189 2005/02/23 12:44:17 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 ) @@ -26,12 +24,12 @@ import DriverState import DriverUtil ( remove_spaces ) import Linker ( showLinkerState, linkPackages ) import Util -import Module ( showModMsg, lookupModuleEnv ) import Name ( Name, NamedThing(..) ) import OccName ( OccName, isSymOcc, occNameUserString ) -import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..) ) +import BasicTypes ( StrictnessMark(..), defaultFixity, SuccessFlag(..), + failed ) import Outputable -import CmdLineOpts ( DynFlag(..), DynFlags(..), dopt_unset ) +import CmdLineOpts ( DynFlags(..) ) import Panic hiding ( showException ) import Config import SrcLoc ( SrcLoc, isGoodSrcLoc ) @@ -53,21 +51,25 @@ 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 import Data.Int ( Int64 ) +import Data.Maybe ( isJust ) import System.Cmd import System.CPUTime import System.Environment +import System.Exit ( exitWith, ExitCode(..) ) import System.Directory -import System.IO as IO +import System.IO +import System.IO.Error as IO import Data.Char import Control.Monad as Monad import Foreign.StablePtr ( newStablePtr ) import GHC.Exts ( unsafeCoerce# ) +import GHC.IOBase ( IOErrorType(InvalidArgument) ) import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) @@ -93,7 +95,7 @@ builtin_commands = [ ("help", keepGoing help), ("?", keepGoing help), ("info", keepGoing info), - ("load", keepGoingPaths loadModule), + ("load", keepGoingPaths loadModule_), ("module", keepGoing setContext), ("reload", keepGoing reloadModule), ("set", keepGoing setCmd), @@ -232,9 +234,13 @@ runGHCi paths dflags 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. @@ -247,7 +253,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 @@ -308,8 +314,14 @@ fileLoop hdl prompt = do when prompt (io (putStr (mkPrompt mod imports))) l <- io (IO.try (hGetLine hdl)) case l of - Left e | isEOFError e -> return () - | otherwise -> io (ioError e) + Left e | isEOFError e -> return () + | InvalidArgument <- etype -> return () + | otherwise -> io (ioError e) + where etype = ioeGetErrorType e + -- treat InvalidArgument in the same way as EOF: + -- this can happen if the user closed stdin, or + -- perhaps did getContents which closes stdin at + -- EOF. Right l -> case remove_spaces l of "" -> fileLoop hdl prompt @@ -351,6 +363,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 @@ -394,7 +415,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 @@ -440,9 +461,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 @@ -491,9 +512,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 @@ -502,15 +522,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. @@ -668,10 +692,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 state <- getGHCiState @@ -693,6 +720,7 @@ loadModule' files = do setContextAfterLoad mods dflags <- getDynFlags modulesLoadedMsg ok mods dflags + return ok reloadModule :: String -> GHCi () @@ -971,22 +999,10 @@ showCmd str = ["linker"] -> io showLinkerState _ -> throwDyn (CmdLineError "syntax: :show [modules|bindings]") -showModules = do - cms <- getCmState - let (mg, hpt) = cmGetModInfo cms - mapM_ (showModule hpt) mg - - -showModule :: HomePackageTable -> ModSummary -> GHCi () -showModule hpt mod_summary - = case lookupModuleEnv hpt mod of - Nothing -> panic "missing linkable" - Just mod_info -> io (putStrLn (showModMsg obj_linkable mod locn)) - where - obj_linkable = isObjectLinkable (hm_linkable mod_info) - where - mod = ms_mod mod_summary - locn = ms_location mod_summary +showModules + = do { cms <- getCmState + ; let show_one ms = io (putStrLn (cmShowModule cms ms)) + ; mapM_ show_one (cmGetModuleGraph cms) } showBindings = do cms <- getCmState