summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/main/GHC.hs3
-rw-r--r--compiler/main/HscMain.lhs34
-rw-r--r--compiler/main/InteractiveEval.hs13
-rw-r--r--docs/users_guide/ghci.xml13
-rw-r--r--ghc/GhciMonad.hs3
-rw-r--r--ghc/InteractiveUI.hs59
6 files changed, 106 insertions, 19 deletions
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index ce9b688a1b..0d94ade469 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -92,7 +92,8 @@ module GHC (
typeKind,
parseName,
RunResult(..),
- runStmt, parseImportDecl, SingleStep(..),
+ runStmt, runStmtWithLocation,
+ parseImportDecl, SingleStep(..),
resume,
Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan,
resumeHistory, resumeHistoryIx),
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 582b80da6c..47bde9659d 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -62,7 +62,8 @@ module HscMain
#ifdef GHCI
, hscGetModuleExports
, hscTcRnLookupRdrName
- , hscStmt, hscTcExpr, hscImport, hscKcType
+ , hscStmt, hscStmtWithLocation
+ , hscTcExpr, hscImport, hscKcType
, hscCompileCoreExpr
#endif
@@ -1075,8 +1076,17 @@ hscStmt -- Compile a stmt all the way to an HValue, but don't run it
-> String -- The statement
-> IO (Maybe ([Id], HValue))
-- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
-hscStmt hsc_env stmt = runHsc hsc_env $ do
- maybe_stmt <- hscParseStmt stmt
+hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
+
+hscStmtWithLocation -- Compile a stmt all the way to an HValue, but don't run it
+ :: HscEnv
+ -> String -- The statement
+ -> String -- the source
+ -> Int -- ^ starting line
+ -> IO (Maybe ([Id], HValue))
+ -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error
+hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do
+ maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
case maybe_stmt of
Nothing -> return Nothing
Just parsed_stmt -> do -- The real stuff
@@ -1142,6 +1152,11 @@ hscKcType hsc_env str = runHsc hsc_env $ do
hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName))
hscParseStmt = hscParseThing parseStmt
+hscParseStmtWithLocation :: String -> Int
+ -> String -> Hsc (Maybe (LStmt RdrName))
+hscParseStmtWithLocation source linenumber stmt =
+ hscParseThingWithLocation source linenumber parseStmt stmt
+
hscParseType :: String -> Hsc (LHsType RdrName)
hscParseType = hscParseThing parseType
#endif
@@ -1150,19 +1165,24 @@ hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
hscParseIdentifier hsc_env str = runHsc hsc_env $
hscParseThing parseIdentifier str
-
hscParseThing :: (Outputable thing)
=> Lexer.P thing
-> String
-> Hsc thing
+hscParseThing = hscParseThingWithLocation "<interactive>" 1
-hscParseThing parser str
+hscParseThingWithLocation :: (Outputable thing)
+ => String -> Int
+ -> Lexer.P thing
+ -> String
+ -> Hsc thing
+hscParseThingWithLocation source linenumber parser str
= {-# SCC "Parser" #-} do
dflags <- getDynFlags
liftIO $ showPass dflags "Parser"
-
+
let buf = stringToStringBuffer str
- loc = mkSrcLoc (fsLit "<interactive>") 1 1
+ loc = mkSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
diff --git a/compiler/main/InteractiveEval.hs b/compiler/main/InteractiveEval.hs
index 43f6aa2c0e..e0a30b46dc 100644
--- a/compiler/main/InteractiveEval.hs
+++ b/compiler/main/InteractiveEval.hs
@@ -9,7 +9,8 @@
module InteractiveEval (
#ifdef GHCI
RunResult(..), Status(..), Resume(..), History(..),
- runStmt, parseImportDecl, SingleStep(..),
+ runStmt, runStmtWithLocation,
+ parseImportDecl, SingleStep(..),
resume,
abandon, abandonAll,
getResumeContext,
@@ -180,7 +181,13 @@ findEnclosingDecls hsc_env inf =
-- | Run a statement in the current interactive context. Statement
-- may bind multple values.
runStmt :: GhcMonad m => String -> SingleStep -> m RunResult
-runStmt expr step =
+runStmt = runStmtWithLocation "<interactive>" 1
+
+-- | Run a statement in the current interactive context. Passing debug information
+-- Statement may bind multple values.
+runStmtWithLocation :: GhcMonad m => String -> Int ->
+ String -> SingleStep -> m RunResult
+runStmtWithLocation source linenumber expr step =
do
hsc_env <- getSession
@@ -192,7 +199,7 @@ runStmt expr step =
let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds
hsc_env' = hsc_env{ hsc_dflags = dflags' }
- r <- liftIO $ hscStmt hsc_env' expr
+ r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber
case r of
Nothing -> return RunFailed -- empty statement / comment
diff --git a/docs/users_guide/ghci.xml b/docs/users_guide/ghci.xml
index a675cca885..7c3fed2e8b 100644
--- a/docs/users_guide/ghci.xml
+++ b/docs/users_guide/ghci.xml
@@ -2389,6 +2389,19 @@ bar
<varlistentry>
<term>
+ <literal>:script</literal> <optional><replaceable>n</replaceable></optional>
+ <literal>filename</literal>
+ <indexterm><primary><literal>:script</literal></primary></indexterm>
+ </term>
+ <listitem>
+ <para>Executes the lines of a file as a series of GHCi commands. This command
+ is compatible with multiline statements as set by <literal>:set +m</literal>
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
<literal>:set</literal> <optional><replaceable>option</replaceable>...</optional>
<indexterm><primary><literal>:set</literal></primary></indexterm>
</term>
diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs
index 779fad23e9..2aff48385e 100644
--- a/ghc/GhciMonad.hs
+++ b/ghc/GhciMonad.hs
@@ -57,6 +57,7 @@ data GHCiState = GHCiState
stop :: String,
options :: [GHCiOption],
prelude :: GHC.Module,
+ line_number :: !Int, -- input line
break_ctr :: !Int,
breaks :: ![(Int, BreakLocation)],
tickarrays :: ModuleEnv TickArray,
@@ -254,7 +255,7 @@ runStmt expr step = do
reflectGHCi x $ do
GHC.handleSourceError (\e -> do GHC.printException e
return GHC.RunFailed) $ do
- GHC.runStmt expr step
+ GHC.runStmtWithLocation (progname st) (line_number st) expr step
resume :: (SrcSpan -> Bool) -> GHC.SingleStep -> GHCi GHC.RunResult
resume canLogSpan step = do
diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs
index eaf2d2d559..534709fa59 100644
--- a/ghc/InteractiveUI.hs
+++ b/ghc/InteractiveUI.hs
@@ -143,6 +143,7 @@ builtin_commands = [
("quit", quit, noCompletion),
("reload", keepGoing' reloadModule, noCompletion),
("run", keepGoing runRun, completeFilename),
+ ("script", keepGoing' scriptCmd, completeFilename),
("set", keepGoing setCmd, completeSetOptions),
("show", keepGoing showCmd, completeShowOptions),
("sprint", keepGoing sprintCmd, completeExpression),
@@ -217,6 +218,7 @@ helpText =
" :quit exit GHCi\n" ++
" :reload reload the current module set\n" ++
" :run function [<arguments> ...] run the function with the given arguments\n" ++
+ " :script <filename> run the script <filename>" ++
" :type <expr> show the type of <expr>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
" :!<command> run the shell command <command>\n" ++
@@ -358,6 +360,7 @@ interactiveUI srcs maybe_exprs = do
-- session = session,
options = [],
prelude = prel_mod,
+ line_number = 1,
break_ctr = 0,
breaks = [],
tickarrays = emptyModuleEnv,
@@ -517,7 +520,13 @@ checkPerms name =
else return True
#endif
-fileLoop :: MonadIO m => Handle -> InputT m (Maybe String)
+incrementLines :: InputT GHCi ()
+incrementLines = do
+ st <- lift $ getGHCiState
+ let ln = 1+(line_number st)
+ lift $ setGHCiState st{line_number=ln}
+
+fileLoop :: Handle -> InputT GHCi (Maybe String)
fileLoop hdl = do
l <- liftIO $ tryIO $ hGetLine hdl
case l of
@@ -529,7 +538,9 @@ fileLoop hdl = do
-- this can happen if the user closed stdin, or
-- perhaps did getContents which closes stdin at
-- EOF.
- Right l -> return (Just l)
+ Right l -> do
+ incrementLines
+ return (Just l)
mkPrompt :: GHCi String
mkPrompt = do
@@ -654,7 +665,7 @@ runOneCommand eh getCmd = do
ml <- lift $ isOptionSet Multiline
if ml
then do
- mb_stmt <- checkInputForLayout stmt 1 getCmd
+ mb_stmt <- checkInputForLayout stmt getCmd
case mb_stmt of
Nothing -> return $ Just True
Just ml_stmt -> do
@@ -666,14 +677,14 @@ runOneCommand eh getCmd = do
-- #4316
-- lex the input. If there is an unclosed layout context, request input
-checkInputForLayout :: String -> Int -> InputT GHCi (Maybe String)
+checkInputForLayout :: String -> InputT GHCi (Maybe String)
-> InputT GHCi (Maybe String)
-checkInputForLayout stmt line_number getStmt = do
+checkInputForLayout stmt getStmt = do
dflags' <- lift $ getDynFlags
let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
st <- lift $ getGHCiState
let buf = stringToStringBuffer stmt
- loc = mkSrcLoc (fsLit (progname st)) line_number 1
+ loc = mkSrcLoc (fsLit (progname st)) (line_number st) 1
pstate = Lexer.mkPState dflags buf loc
case Lexer.unP goToEnd pstate of
(Lexer.POk _ False) -> return $ Just stmt
@@ -696,7 +707,8 @@ checkInputForLayout stmt line_number getStmt = do
Nothing -> return Nothing
Just str -> if str == ""
then return $ Just stmt
- else checkInputForLayout (stmt++"\n"++str) (line_number+1) getStmt
+ else do
+ checkInputForLayout (stmt++"\n"++str) getStmt
where goToEnd = do
eof <- Lexer.nextIsEOF
if eof
@@ -1252,6 +1264,39 @@ shellEscape :: String -> GHCi Bool
shellEscape str = liftIO (system str >> return False)
-----------------------------------------------------------------------------
+-- running a script file #1363
+
+scriptCmd :: String -> InputT GHCi ()
+scriptCmd s = do
+ case words s of
+ [s] -> runScript s
+ _ -> ghcError (CmdLineError "syntax: :script <filename>")
+
+runScript :: String -- ^ filename
+ -> InputT GHCi ()
+runScript filename = do
+ either_script <- liftIO $ tryIO (openFile filename ReadMode)
+ case either_script of
+ Left _err -> ghcError (CmdLineError $ "IO error: \""++filename++"\" "
+ ++(ioeGetErrorString _err))
+ Right script -> do
+ st <- lift $ getGHCiState
+ let prog = progname st
+ line = line_number st
+ lift $ setGHCiState st{progname=filename,line_number=0}
+ scriptLoop script
+ liftIO $ hClose script
+ new_st <- lift $ getGHCiState
+ lift $ setGHCiState new_st{progname=prog,line_number=line}
+ where scriptLoop script = do
+ res <- runOneCommand handler $ fileLoop script
+ case res of
+ Nothing -> return ()
+ Just succ -> if succ
+ then scriptLoop script
+ else return ()
+
+-----------------------------------------------------------------------------
-- Browsing a module's contents
browseCmd :: Bool -> String -> InputT GHCi ()
View Lorry Controller Status