{-# 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
--
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 )
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 )
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 )
("help", keepGoing help),
("?", keepGoing help),
("info", keepGoing info),
- ("load", keepGoingPaths loadModule),
+ ("load", keepGoingPaths loadModule_),
("module", keepGoing setContext),
("reload", keepGoing reloadModule),
("set", keepGoing setCmd),
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.
interactiveLoop is_tty show_prompt
Just expr -> do
-- just evaluate the expression we were given
- runCommand expr
+ runCommandEval expr
return ()
-- and finally, exit
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
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
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
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
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
| 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.
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
setContextAfterLoad mods
dflags <- getDynFlags
modulesLoadedMsg ok mods dflags
+ return ok
reloadModule :: String -> GHCi ()
["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
projects / ghc-hetmet.git / blobdiff