From eccb2d89eb4b34f31e8ea337d5f8673605f71665 Mon Sep 17 00:00:00 2001 From: Vivian McPhail Date: Sat, 26 Feb 2011 07:31:33 +0000 Subject: [PATCH] :script file scripts in GHCi #1363 This patch adds the script command in GHCi A file is read and executed as a series of GHCi commands. Execution terminates on the first error. The filename and line number are included in the error. --- compiler/main/GHC.hs | 3 +- compiler/main/HscMain.lhs | 34 +++++++++++++++++----- compiler/main/InteractiveEval.hs | 13 +++++++-- docs/users_guide/ghci.xml | 13 +++++++++ ghc/GhciMonad.hs | 3 +- ghc/InteractiveUI.hs | 59 +++++++++++++++++++++++++++++++++----- 6 files changed, 106 insertions(+), 19 deletions(-) diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index ce9b688..0d94ade 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 582b80d..47bde96 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 "" 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 "" 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 "") 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 43f6aa2..e0a30b4 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 "" 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 a675cca..7c3fed2 100644 --- a/docs/users_guide/ghci.xml +++ b/docs/users_guide/ghci.xml @@ -2389,6 +2389,19 @@ bar + :script n + filename + :script + + + Executes the lines of a file as a series of GHCi commands. This command + is compatible with multiline statements as set by :set +m + + + + + + :set option... :set diff --git a/ghc/GhciMonad.hs b/ghc/GhciMonad.hs index 779fad2..2aff483 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 eaf2d2d..534709f 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 [ ...] run the function with the given arguments\n" ++ + " :script run the script " ++ " :type show the type of \n" ++ " :undef undefine user-defined command :\n" ++ " :! run the shell 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 ") + +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 () -- 1.7.10.4