X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=a49109abfbeb6012f7617a376d26d6d86d847218;hp=3ae37f53d04c805a7d708e182e67e0d34dbef544;hb=526c3af1dc98987b6949f4df73c0debccf9875bd;hpb=d2b3daa3cc474e6ab010fb6af5c21ddb852b8b5b diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 3ae37f5..a49109a 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -11,12 +11,13 @@ module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where #include "HsVersions.h" -import GhciMonad +import qualified GhciMonad +import GhciMonad hiding (runStmt) import GhciTags import Debugger -- The GHC interface -import qualified GHC +import qualified GHC hiding (resume, runStmt) import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), Module, ModuleName, TyThing(..), Phase, BreakIndex, SrcSpan, Resume, SingleStep ) @@ -24,7 +25,7 @@ import PprTyThing import DynFlags import Packages -#ifdef USE_READLINE +#ifdef USE_EDITLINE import PackageConfig import UniqFM #endif @@ -56,9 +57,9 @@ import GHC.ConsoleHandler ( flushConsole ) import qualified System.Win32 #endif -#ifdef USE_READLINE +#ifdef USE_EDITLINE import Control.Concurrent ( yield ) -- Used in readline loop -import System.Console.Readline as Readline +import System.Console.Editline.Readline as Readline #endif --import SystemExts @@ -66,6 +67,7 @@ import System.Console.Readline as Readline import Control.Exception as Exception -- import Control.Concurrent +import System.FilePath import qualified Data.ByteString.Char8 as BS import Data.List import Data.Maybe @@ -81,13 +83,14 @@ import Data.Array import Control.Monad as Monad import Text.Printf import Foreign -import Foreign.C ( withCStringLen ) +import Foreign.C import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) +import GHC.TopHandler import Data.IORef ( IORef, readIORef, writeIORef ) -#ifdef USE_READLINE +#ifdef USE_EDITLINE import System.Posix.Internals ( setNonBlockingFD ) #endif @@ -100,60 +103,86 @@ ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ cmdName :: Command -> String cmdName (n,_,_,_) = n -macros_ref :: IORef [Command] GLOBAL_VAR(macros_ref, [], [Command]) builtin_commands :: [Command] builtin_commands = [ -- Hugs users are accustomed to :e, so make sure it doesn't overlap - ("?", keepGoing help, False, completeNone), - ("add", keepGoingPaths addModule, False, completeFilename), - ("abandon", keepGoing abandonCmd, False, completeNone), - ("break", keepGoing breakCmd, False, completeIdentifier), - ("back", keepGoing backCmd, False, completeNone), - ("browse", keepGoing (browseCmd False), False, completeModule), - ("browse!", keepGoing (browseCmd True), False, completeModule), - ("cd", keepGoing changeDirectory, False, completeFilename), - ("check", keepGoing checkModule, False, completeHomeModule), - ("continue", keepGoing continueCmd, False, completeNone), - ("cmd", keepGoing cmdCmd, False, completeIdentifier), - ("ctags", keepGoing createCTagsFileCmd, False, completeFilename), - ("def", keepGoing (defineMacro False), False, completeIdentifier), - ("def!", keepGoing (defineMacro True), False, completeIdentifier), - ("delete", keepGoing deleteCmd, False, completeNone), - ("e", keepGoing editFile, False, completeFilename), - ("edit", keepGoing editFile, False, completeFilename), - ("etags", keepGoing createETagsFileCmd, False, completeFilename), - ("force", keepGoing forceCmd, False, completeIdentifier), - ("forward", keepGoing forwardCmd, False, completeNone), - ("help", keepGoing help, False, completeNone), - ("history", keepGoing historyCmd, False, completeNone), - ("info", keepGoing info, False, completeIdentifier), - ("kind", keepGoing kindOfType, False, completeIdentifier), - ("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile), - ("list", keepGoing listCmd, False, completeNone), - ("module", keepGoing setContext, False, completeModule), - ("main", keepGoing runMain, False, completeIdentifier), - ("print", keepGoing printCmd, False, completeIdentifier), - ("quit", quit, False, completeNone), - ("reload", keepGoing reloadModule, False, completeNone), - ("set", keepGoing setCmd, True, completeSetOptions), - ("show", keepGoing showCmd, False, completeNone), - ("sprint", keepGoing sprintCmd, False, completeIdentifier), - ("step", keepGoing stepCmd, False, completeIdentifier), - ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier), - ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier), - ("type", keepGoing typeOfExpr, False, completeIdentifier), - ("trace", keepGoing traceCmd, False, completeIdentifier), - ("undef", keepGoing undefineMacro, False, completeMacro), - ("unset", keepGoing unsetOptions, True, completeSetOptions) + ("?", keepGoing help, Nothing, completeNone), + ("add", keepGoingPaths addModule, Just filenameWordBreakChars, completeFilename), + ("abandon", keepGoing abandonCmd, Nothing, completeNone), + ("break", keepGoing breakCmd, Nothing, completeIdentifier), + ("back", keepGoing backCmd, Nothing, completeNone), + ("browse", keepGoing (browseCmd False), Nothing, completeModule), + ("browse!", keepGoing (browseCmd True), Nothing, completeModule), + ("cd", keepGoing changeDirectory, Just filenameWordBreakChars, completeFilename), + ("check", keepGoing checkModule, Nothing, completeHomeModule), + ("continue", keepGoing continueCmd, Nothing, completeNone), + ("cmd", keepGoing cmdCmd, Nothing, completeIdentifier), + ("ctags", keepGoing createCTagsFileCmd, Just filenameWordBreakChars, completeFilename), + ("def", keepGoing (defineMacro False), Nothing, completeIdentifier), + ("def!", keepGoing (defineMacro True), Nothing, completeIdentifier), + ("delete", keepGoing deleteCmd, Nothing, completeNone), + ("e", keepGoing editFile, Just filenameWordBreakChars, completeFilename), + ("edit", keepGoing editFile, Just filenameWordBreakChars, completeFilename), + ("etags", keepGoing createETagsFileCmd, Just filenameWordBreakChars, completeFilename), + ("force", keepGoing forceCmd, Nothing, completeIdentifier), + ("forward", keepGoing forwardCmd, Nothing, completeNone), + ("help", keepGoing help, Nothing, completeNone), + ("history", keepGoing historyCmd, Nothing, completeNone), + ("info", keepGoing info, Nothing, completeIdentifier), + ("kind", keepGoing kindOfType, Nothing, completeIdentifier), + ("load", keepGoingPaths loadModule_, Just filenameWordBreakChars, completeHomeModuleOrFile), + ("list", keepGoing listCmd, Nothing, completeNone), + ("module", keepGoing setContext, Nothing, completeModule), + ("main", keepGoing runMain, Nothing, completeIdentifier), + ("print", keepGoing printCmd, Nothing, completeIdentifier), + ("quit", quit, Nothing, completeNone), + ("reload", keepGoing reloadModule, Nothing, completeNone), + ("run", keepGoing runRun, Nothing, completeIdentifier), + ("set", keepGoing setCmd, Just flagWordBreakChars, completeSetOptions), + ("show", keepGoing showCmd, Nothing, completeNone), + ("sprint", keepGoing sprintCmd, Nothing, completeIdentifier), + ("step", keepGoing stepCmd, Nothing, completeIdentifier), + ("steplocal", keepGoing stepLocalCmd, Nothing, completeIdentifier), + ("stepmodule",keepGoing stepModuleCmd, Nothing, completeIdentifier), + ("type", keepGoing typeOfExpr, Nothing, completeIdentifier), + ("trace", keepGoing traceCmd, Nothing, completeIdentifier), + ("undef", keepGoing undefineMacro, Nothing, completeMacro), + ("unset", keepGoing unsetOptions, Just flagWordBreakChars, completeSetOptions) ] + +-- We initialize readline (in the interactiveUI function) to use +-- word_break_chars as the default set of completion word break characters. +-- This can be overridden for a particular command (for example, filename +-- expansion shouldn't consider '/' to be a word break) by setting the third +-- entry in the Command tuple above. +-- +-- NOTE: in order for us to override the default correctly, any custom entry +-- must be a SUBSET of word_break_chars. +#ifdef USE_EDITLINE +word_break_chars :: String +word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" + specials = "(),;[]`{}" + spaces = " \t\n" + in spaces ++ specials ++ symbols +#endif + +flagWordBreakChars, filenameWordBreakChars :: String +flagWordBreakChars = " \t\n" +filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults + + keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) keepGoing a str = a str >> return False keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool) -keepGoingPaths a str = a (toArgs str) >> return False +keepGoingPaths a str + = do case toArgs str of + Left err -> io (hPutStrLn stderr err) + Right args -> a args + return False shortHelpText :: String shortHelpText = "use :? for help.\n" @@ -183,6 +212,7 @@ helpText = " :module [+/-] [*] ... set the context for expression evaluation\n" ++ " :quit exit GHCi\n" ++ " :reload reload the current module set\n" ++ + " :run function [ ...] run the function with the given arguments\n" ++ " :type show the type of \n" ++ " :undef undefine user-defined command :\n" ++ " :! run the shell command \n" ++ @@ -198,15 +228,18 @@ helpText = " :delete * delete all breakpoints\n" ++ " :force print , forcing unevaluated parts\n" ++ " :forward go forward in the history (after :back)\n" ++ - " :history [] show the last items in the history (after :trace)\n" ++ + " :history [] after :trace, show the execution history\n" ++ + " :list show the source code around current breakpoint\n" ++ + " :list identifier show the source code for \n" ++ + " :list [] show the source code around line number \n" ++ " :print [ ...] prints a value without forcing its computation\n" ++ " :sprint [ ...] simplifed version of :print\n" ++ " :step single-step after stopping at a breakpoint\n"++ " :step single-step into \n"++ - " :steplocal single-step restricted to the current top level decl.\n"++ + " :steplocal single-step within the current top-level binding\n"++ " :stepmodule single-step restricted to the current module\n"++ " :trace trace after stopping at a breakpoint\n"++ - " :trace trace into (remembers breakpoints for :history)\n"++ + " :trace evaluate with tracing on (see :history)\n"++ "\n" ++ " -- Commands for changing settings:\n" ++ @@ -237,7 +270,8 @@ helpText = " :show modules show the currently loaded modules\n" ++ " :show packages show the currently active package flags\n" ++ " :show languages show the currently active language flags\n" ++ - " :show show anything that can be set with :set (e.g. args)\n" ++ + " :show show value of , which is one of\n" ++ + " [args, prog, prompt, editor, stop]\n" ++ "\n" findEditor :: IO String @@ -245,14 +279,15 @@ findEditor = do getEnv "EDITOR" `IO.catch` \_ -> do #if mingw32_HOST_OS - win <- System.Win32.getWindowsDirectory - return (win `joinFileName` "notepad.exe") + win <- System.Win32.getWindowsDirectory + return (win "notepad.exe") #else - return "" + return "" #endif -interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe String -> IO () -interactiveUI session srcs maybe_expr = do +interactiveUI :: Session -> [(FilePath, Maybe Phase)] -> Maybe [String] + -> IO () +interactiveUI session srcs maybe_exprs = do -- HACK! If we happen to get into an infinite loop (eg the user -- types 'let x=x in x' at the prompt), then the thread will block -- on a blackhole, and become unreachable during GC. The GC will @@ -268,7 +303,7 @@ interactiveUI session srcs maybe_expr = do -- Initialise buffering for the *interpreted* I/O system initInterpBuffering session - when (isNothing maybe_expr) $ do + when (isNothing maybe_exprs) $ do -- Only for GHCi (not runghc and ghc -e): -- Turn buffering off for the compiled program's stdout/stderr @@ -280,91 +315,114 @@ interactiveUI session srcs maybe_expr = do -- intended for the program, so unbuffer stdin. hSetBuffering stdin NoBuffering - -- initial context is just the Prelude +#ifdef USE_EDITLINE + is_tty <- hIsTerminalDevice stdin + when is_tty $ do + Readline.initialize + + withGhcAppData + (\dir -> Readline.readHistory (dir "ghci_history")) + (return True) + + Readline.setAttemptedCompletionFunction (Just completeWord) + --Readline.parseAndBind "set show-all-if-ambiguous 1" + + Readline.setBasicWordBreakCharacters word_break_chars + Readline.setCompleterWordBreakCharacters word_break_chars + Readline.setCompletionAppendCharacter Nothing +#endif + + -- initial context is just the Prelude prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude") (Just basePackageId) GHC.setContext session [] [prel_mod] -#ifdef USE_READLINE - Readline.initialize - Readline.setAttemptedCompletionFunction (Just completeWord) - --Readline.parseAndBind "set show-all-if-ambiguous 1" - - let symbols = "!#$%&*+/<=>?@\\^|-~" - specials = "(),;[]`{}" - spaces = " \t\n" - word_break_chars = spaces ++ specials ++ symbols - - Readline.setBasicWordBreakCharacters word_break_chars - Readline.setCompleterWordBreakCharacters word_break_chars -#endif - default_editor <- findEditor - startGHCi (runGHCi srcs maybe_expr) - GHCiState{ progname = "", - args = [], + cwd <- getCurrentDirectory + + startGHCi (runGHCi srcs maybe_exprs) + GHCiState{ progname = "", + args = [], prompt = "%s> ", stop = "", - editor = default_editor, - session = session, - options = [], + editor = default_editor, + session = session, + options = [], prelude = prel_mod, break_ctr = 0, breaks = [], tickarrays = emptyModuleEnv, last_command = Nothing, cmdqueue = [], - remembered_ctx = Nothing + remembered_ctx = [], + virtual_path = cwd, + ghc_e = isJust maybe_exprs } -#ifdef USE_READLINE +#ifdef USE_EDITLINE + Readline.stifleHistory 100 + withGhcAppData (\dir -> Readline.writeHistory (dir "ghci_history")) + (return True) Readline.resetTerminal Nothing #endif return () -runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi () -runGHCi paths maybe_expr = do - let read_dot_files = not opt_IgnoreDotGhci +withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a +withGhcAppData right left = do + either_dir <- IO.try (getAppUserDataDirectory "ghc") + case either_dir of + Right dir -> right dir + _ -> left - when (read_dot_files) $ do - -- Read in ./.ghci. - let file = "./.ghci" - exists <- io (doesFileExist file) - when exists $ do - dir_ok <- io (checkPerms ".") - file_ok <- io (checkPerms file) + +runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi () +runGHCi paths maybe_exprs = do + let + read_dot_files = not opt_IgnoreDotGhci + + current_dir = return (Just ".ghci") + + app_user_dir = io $ withGhcAppData + (\dir -> return (Just (dir "ghci.conf"))) + (return Nothing) + + home_dir = do + either_dir <- io $ IO.try (getEnv "HOME") + case either_dir of + Right home -> return (Just (home ".ghci")) + _ -> return Nothing + + sourceConfigFile :: FilePath -> GHCi () + sourceConfigFile file = do + exists <- io $ doesFileExist file + when exists $ do + dir_ok <- io $ checkPerms (getDirectory file) + file_ok <- io $ checkPerms file when (dir_ok && file_ok) $ do - either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) - case either_hdl of - Left _e -> return () - Right hdl -> runCommands (fileLoop hdl False False) - + either_hdl <- io $ IO.try (openFile file ReadMode) + case either_hdl of + Left _e -> return () + Right hdl -> runCommands (fileLoop hdl False False) + where + getDirectory f = case takeDirectory f of "" -> "."; d -> d + when (read_dot_files) $ do - -- Read in $HOME/.ghci - either_dir <- io (IO.try getHomeDirectory) - case either_dir of - Left _e -> return () - Right dir -> do - cwd <- io (getCurrentDirectory) - when (dir /= cwd) $ do - let file = dir ++ "/.ghci" - ok <- io (checkPerms file) - when ok $ do - either_hdl <- io (IO.try (openFile file ReadMode)) - case either_hdl of - Left _e -> return () - Right hdl -> runCommands (fileLoop hdl False False) + cfgs0 <- sequence [ current_dir, app_user_dir, home_dir ] + cfgs <- io $ mapM canonicalizePath (catMaybes cfgs0) + mapM_ sourceConfigFile (nub cfgs) + -- nub, because we don't want to read .ghci twice if the + -- CWD is $HOME. -- Perform a :load for files given on the GHCi command line -- 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)) + ok <- ghciHandle (\e -> do showException e; return Failed) $ + loadModule paths + when (isJust maybe_exprs && 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. @@ -372,7 +430,7 @@ runGHCi paths maybe_expr = do dflags <- getDynFlags let show_prompt = verbosity dflags > 0 || is_tty - case maybe_expr of + case maybe_exprs of Nothing -> do #if defined(mingw32_HOST_OS) @@ -388,15 +446,21 @@ runGHCi paths maybe_expr = do #endif -- enter the interactive loop interactiveLoop is_tty show_prompt - Just expr -> do + Just exprs -> do -- just evaluate the expression we were given - runCommandEval expr - return () + enqueueCommands exprs + let handle e = do st <- getGHCiState + -- Jump through some hoops to get the + -- current progname in the exception text: + -- : + io $ withProgName (progname st) + -- this used to be topHandlerFastExit, see #2228 + $ topHandler e + runCommands' handle (return Nothing) -- and finally, exit io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi." - interactiveLoop :: Bool -> Bool -> GHCi () interactiveLoop is_tty show_prompt = -- Ignore ^C exceptions caught here @@ -412,7 +476,7 @@ interactiveLoop is_tty show_prompt = -- exception handler above. -- read commands from stdin -#ifdef USE_READLINE +#ifdef USE_EDITLINE if (is_tty) then runCommands readlineLoop else runCommands (fileLoop stdin show_prompt is_tty) @@ -540,7 +604,7 @@ mkPrompt = do return (showSDoc (f (prompt st))) -#ifdef USE_READLINE +#ifdef USE_EDITLINE readlineLoop :: GHCi (Maybe String) readlineLoop = do io yield @@ -552,6 +616,7 @@ readlineLoop = do splatSavedSession case l of Nothing -> return Nothing + Just "" -> return (Just "") -- Don't put empty lines in the history Just l -> do io (addHistory l) str <- io $ consoleInputToUnicode True l @@ -567,14 +632,18 @@ queryQueue = do return (Just c) runCommands :: GHCi (Maybe String) -> GHCi () -runCommands getCmd = do +runCommands = runCommands' handler + +runCommands' :: (Exception -> GHCi Bool) -- Exception handler + -> GHCi (Maybe String) -> GHCi () +runCommands' eh getCmd = do mb_cmd <- noSpace queryQueue mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd case mb_cmd of Nothing -> return () Just c -> do - b <- ghciHandle handler (doCommand c) - if b then return () else runCommands getCmd + b <- ghciHandle eh (doCommand c) + if b then return () else runCommands' eh getCmd where noSpace q = q >>= maybe (return Nothing) (\c->case removeSpaces c of @@ -615,36 +684,14 @@ enqueueCommands cmds = do setGHCiState st{ cmdqueue = cmds ++ cmdqueue st } --- 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 :: String -> GHCi Bool -runCommandEval c = ghciHandle handleEval (doCommand c) - where - handleEval (ExitException code) = io (exitWith code) - handleEval e = do handler e - io (exitWith (ExitFailure 1)) - - doCommand (':' : command) = specialCommand command - doCommand stmt - = do r <- runStmt stmt GHC.RunToCompletion - case r of - False -> io (exitWith (ExitFailure 1)) - -- failure to run the command causes exit(1) for ghc -e. - _ -> return True - runStmt :: String -> SingleStep -> GHCi Bool runStmt stmt step | null (filter (not.isSpace) stmt) = return False | ["import", mod] <- words stmt = keepGoing setContext ('+':mod) | otherwise - = do st <- getGHCiState - session <- getSession - result <- io $ withProgName (progname st) $ withArgs (args st) $ - GHC.runStmt session stmt step + = do result <- GhciMonad.runStmt stmt step afterRunStmt (const True) result - --afterRunStmt :: GHC.RunResult -> GHCi Bool -- False <=> the statement failed to compile afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool @@ -659,7 +706,7 @@ afterRunStmt step_here run_result = do GHC.RunBreak _ names mb_info | isNothing mb_info || step_here (GHC.resumeSpan $ head resumes) -> do - printForUser $ ptext SLIT("Stopped at") <+> + printForUser $ ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan $ head resumes) -- printTypeOfNames session names let namesSorted = sortBy compareNames names @@ -672,14 +719,14 @@ afterRunStmt step_here run_result = do st <- getGHCiState enqueueCommands [stop st] return () - | otherwise -> io(GHC.resume session GHC.SingleStep) >>= + | otherwise -> resume GHC.SingleStep >>= afterRunStmt step_here >> return () _ -> return () flushInterpBuffers io installSignalHandlers b <- isOptionSet RevertCAFs - io (when b revertCAFs) + when b revertCAFs return (case run_result of GHC.RunOk _ -> True; _ -> False) @@ -830,13 +877,26 @@ pprInfo pefas (thing, fixity, insts) | otherwise = ppr fix <+> ppr (GHC.getName thing) runMain :: String -> GHCi () -runMain args = do - let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args)) - enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"] +runMain s = case toArgs s of + Left err -> io (hPutStrLn stderr err) + Right args -> + do dflags <- getDynFlags + case mainFunIs dflags of + Nothing -> doWithArgs args "main" + Just f -> doWithArgs args f + +runRun :: String -> GHCi () +runRun s = case toCmdArgs s of + Left err -> io (hPutStrLn stderr err) + Right (cmd, args) -> doWithArgs args cmd + +doWithArgs :: [String] -> String -> GHCi () +doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++ + show args ++ " (" ++ cmd ++ ")"] addModule :: [FilePath] -> GHCi () addModule files = do - io (revertCAFs) -- always revert CAFs on load/add. + revertCAFs -- always revert CAFs on load/add. files <- mapM expandPath files targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files session <- getSession @@ -846,6 +906,12 @@ addModule files = do afterLoad ok session False prev_context changeDirectory :: String -> GHCi () +changeDirectory "" = do + -- :cd on its own changes to the user's home directory + either_dir <- io (IO.try getHomeDirectory) + case either_dir of + Left _e -> return () + Right dir -> changeDirectory dir changeDirectory dir = do session <- getSession graph <- io (GHC.getModuleGraph session) @@ -854,7 +920,7 @@ changeDirectory dir = do prev_context <- io $ GHC.getContext session io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) - setContextAfterLoad session prev_context [] + setContextAfterLoad session prev_context False [] io (GHC.workingDirectoryChanged session) dir <- expandPath dir io (setCurrentDirectory dir) @@ -930,7 +996,7 @@ defineMacro overwrite s = do case maybe_hv of Nothing -> return () Just hv -> io (writeIORef macros_ref -- - (filtered ++ [(macro_name, runMacro hv, False, completeNone)])) + (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)])) runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do @@ -1029,52 +1095,21 @@ doLoad session retain_context prev_context howmuch = do afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi () afterLoad ok session retain_context prev_context = do - io (revertCAFs) -- always revert CAFs on load. + revertCAFs -- always revert CAFs on load. discardTickArrays loaded_mod_summaries <- getLoadedModules session let loaded_mods = map GHC.ms_mod loaded_mod_summaries loaded_mod_names = map GHC.moduleName loaded_mods modulesLoadedMsg ok loaded_mod_names - st <- getGHCiState - if not retain_context - then do - setGHCiState st{ remembered_ctx = Nothing } - setContextAfterLoad session prev_context loaded_mod_summaries - else do - -- figure out which modules we can keep in the context, which we - -- have to put back, and which we have to remember because they - -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360 - let (as,bs) = prev_context - as1 = filter isHomeModule as -- package modules are kept anyway - bs1 = filter isHomeModule bs - (as_ok, as_bad) = partition (`elem` loaded_mods) as1 - (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1 - (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st) - (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as - (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs - as' = nub (as_ok++rem_as_ok) - bs' = nub (bs_ok++rem_bs_ok) - rem_as' = nub (rem_as_bad ++ as_bad) - rem_bs' = nub (rem_bs_bad ++ bs_bad) - - -- Put back into the context any modules that we previously had - -- to drop because they weren't available (rem_as_ok, rem_bs_ok). - setContextKeepingPackageModules session prev_context (as',bs') - - -- If compilation failed, remember any modules that we are unable - -- to load, so that we can put them back in the context in the future. - case ok of - Succeeded -> setGHCiState st{ remembered_ctx = Nothing } - Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') } - - - -setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi () -setContextAfterLoad session prev [] = do + setContextAfterLoad session prev_context retain_context loaded_mod_summaries + + +setContextAfterLoad :: Session -> ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi () +setContextAfterLoad session prev keep_ctxt [] = do prel_mod <- getPrelude - setContextKeepingPackageModules session prev ([], [prel_mod]) -setContextAfterLoad session prev ms = do + setContextKeepingPackageModules session prev keep_ctxt ([], [prel_mod]) +setContextAfterLoad session prev keep_ctxt ms = do -- load a target if one is available, otherwise load the topmost module. targets <- io (GHC.getTargets session) case [ m | Just m <- map (findTarget ms) targets ] of @@ -1098,23 +1133,31 @@ setContextAfterLoad session prev ms = do load_this summary | m <- GHC.ms_mod summary = do b <- io (GHC.moduleIsInterpreted session m) - if b then setContextKeepingPackageModules session prev ([m], []) + if b then setContextKeepingPackageModules session prev keep_ctxt ([m], []) else do prel_mod <- getPrelude - setContextKeepingPackageModules session prev ([],[prel_mod,m]) + setContextKeepingPackageModules session prev keep_ctxt ([],[prel_mod,m]) -- | Keep any package modules (except Prelude) when changing the context. setContextKeepingPackageModules :: Session -> ([Module],[Module]) -- previous context + -> Bool -- re-execute :module commands -> ([Module],[Module]) -- new context -> GHCi () -setContextKeepingPackageModules session prev_context (as,bs) = do +setContextKeepingPackageModules session prev_context keep_ctxt (as,bs) = do let (_,bs0) = prev_context prel_mod <- getPrelude let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0 let bs1 = if null as then nub (prel_mod : bs) else bs io $ GHC.setContext session as (nub (bs1 ++ pkg_modules)) + if keep_ctxt + then do + st <- getGHCiState + mapM_ (playCtxtCmd False) (remembered_ctx st) + else do + st <- getGHCiState + setGHCiState st{ remembered_ctx = [] } isHomeModule :: Module -> Bool isHomeModule mod = GHC.modulePackageId mod == mainPackageId @@ -1273,60 +1316,65 @@ browseModule bang modl exports_only = do setContext :: String -> GHCi () setContext str - | all sensible mods = fn mods + | all sensible strs = do + playCtxtCmd True (cmd, as, bs) + st <- getGHCiState + setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] } | otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn") where - (fn, mods) = case str of - '+':stuff -> (addToContext, words stuff) - '-':stuff -> (removeFromContext, words stuff) - stuff -> (newContext, words stuff) + (cmd, strs, as, bs) = + case str of + '+':stuff -> rest AddModules stuff + '-':stuff -> rest RemModules stuff + stuff -> rest SetContext stuff + + rest cmd stuff = (cmd, strs, as, bs) + where strs = words stuff + (as,bs) = partitionWith starred strs sensible ('*':m) = looksLikeModuleName m sensible m = looksLikeModuleName m -separate :: Session -> [String] -> [Module] -> [Module] - -> GHCi ([Module],[Module]) -separate _ [] as bs = return (as,bs) -separate session (('*':str):ms) as bs = do - m <- wantInterpretedModule str - separate session ms (m:as) bs -separate session (str:ms) as bs = do - m <- lookupModule str - separate session ms as (m:bs) - -newContext :: [String] -> GHCi () -newContext strs = do - s <- getSession - (as,bs) <- separate s strs [] [] - prel_mod <- getPrelude - let bs' = if null as && prel_mod `notElem` bs then prel_mod:bs else bs - io $ GHC.setContext s as bs' - - -addToContext :: [String] -> GHCi () -addToContext strs = do - s <- getSession - (as,bs) <- io $ GHC.getContext s - - (new_as,new_bs) <- separate s strs [] [] - - let as_to_add = new_as \\ (as ++ bs) - bs_to_add = new_bs \\ (as ++ bs) - - io $ GHC.setContext s (as ++ as_to_add) (bs ++ bs_to_add) + starred ('*':m) = Left m + starred m = Right m - -removeFromContext :: [String] -> GHCi () -removeFromContext strs = do - s <- getSession - (as,bs) <- io $ GHC.getContext s - - (as_to_remove,bs_to_remove) <- separate s strs [] [] - - let as' = as \\ (as_to_remove ++ bs_to_remove) - bs' = bs \\ (as_to_remove ++ bs_to_remove) - - io $ GHC.setContext s as' bs' +playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi () +playCtxtCmd fail (cmd, as, bs) + = do + s <- getSession + (as',bs') <- do_checks fail + (prev_as,prev_bs) <- io $ GHC.getContext s + (new_as, new_bs) <- + case cmd of + SetContext -> do + prel_mod <- getPrelude + let bs'' = if null as && prel_mod `notElem` bs' then prel_mod:bs' + else bs' + return (as',bs'') + AddModules -> do + let as_to_add = as' \\ (prev_as ++ prev_bs) + bs_to_add = bs' \\ (prev_as ++ prev_bs) + return (prev_as ++ as_to_add, prev_bs ++ bs_to_add) + RemModules -> do + let new_as = prev_as \\ (as' ++ bs') + new_bs = prev_bs \\ (as' ++ bs') + return (new_as, new_bs) + io $ GHC.setContext s new_as new_bs + where + do_checks True = do + as' <- mapM wantInterpretedModule as + bs' <- mapM lookupModule bs + return (as',bs') + do_checks False = do + as' <- mapM (trymaybe . wantInterpretedModule) as + bs' <- mapM (trymaybe . lookupModule) bs + return (catMaybes as', catMaybes bs') + + trymaybe m = do + r <- ghciTry m + case r of + Left _ -> return Nothing + Right a -> return (Just a) ---------------------------------------------------------------------------- -- Code for `:set' @@ -1371,27 +1419,32 @@ setCmd "" ,Opt_PrintEvldWithShow ] setCmd str - = case toArgs str of - ("args":args) -> setArgs args - ("prog":prog) -> setProg prog - ("prompt":_) -> setPrompt (after 6) - ("editor":_) -> setEditor (after 6) - ("stop":_) -> setStop (after 4) - wds -> setOptions wds - where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str - -setArgs, setProg, setOptions :: [String] -> GHCi () -setEditor, setStop, setPrompt :: String -> GHCi () + = case getCmd str of + Right ("args", rest) -> + case toArgs rest of + Left err -> io (hPutStrLn stderr err) + Right args -> setArgs args + Right ("prog", rest) -> + case toArgs rest of + Right [prog] -> setProg prog + _ -> io (hPutStrLn stderr "syntax: :set prog ") + Right ("prompt", rest) -> setPrompt $ dropWhile isSpace rest + Right ("editor", rest) -> setEditor $ dropWhile isSpace rest + Right ("stop", rest) -> setStop $ dropWhile isSpace rest + _ -> case toArgs str of + Left err -> io (hPutStrLn stderr err) + Right wds -> setOptions wds + +setArgs, setOptions :: [String] -> GHCi () +setProg, setEditor, setStop, setPrompt :: String -> GHCi () setArgs args = do st <- getGHCiState setGHCiState st{ args = args } -setProg [prog] = do +setProg prog = do st <- getGHCiState setGHCiState st{ progname = prog } -setProg _ = do - io (hPutStrLn stderr "syntax: :set prog ") setEditor cmd = do st <- getGHCiState @@ -1453,7 +1506,7 @@ newDynFlags minus_opts = do io (GHC.load session LoadAllTargets) io (linkPackages dflags new_pkgs) -- package flags changed, we can't re-use any of the old context - setContextAfterLoad session ([],[]) [] + setContextAfterLoad session ([],[]) False [] return () @@ -1526,7 +1579,8 @@ showCmd str = do ["context"] -> showContext ["packages"] -> showPackages ["languages"] -> showLanguages - _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]") + _ -> throwDyn (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++ + " | breaks | context | packages | languages ]")) showModules :: GHCi () showModules = do @@ -1569,8 +1623,8 @@ showContext = do printForUser $ vcat (map pp_resume (reverse resumes)) where pp_resume resume = - ptext SLIT("--> ") <> text (GHC.resumeStmt resume) - $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume)) + ptext (sLit "--> ") <> text (GHC.resumeStmt resume) + $$ nest 2 (ptext (sLit "Stopped at") <+> ppr (GHC.resumeSpan resume)) showPackages :: GHCi () showPackages = do @@ -1581,7 +1635,8 @@ showPackages = do pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags io $ putStrLn $ showSDoc $ vcat $ text "packages currently loaded:" - : map (nest 2 . text . packageIdString) pkg_ids + : map (nest 2 . text . packageIdString) + (sortBy (compare `on` packageIdFS) pkg_ids) where showFlag (ExposePackage p) = text $ " -package " ++ p showFlag (HidePackage p) = text $ " -hide-package " ++ p showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p @@ -1604,7 +1659,7 @@ completeMacro, completeIdentifier, completeModule, completeHomeModuleOrFile :: String -> IO [String] -#ifdef USE_READLINE +#ifdef USE_EDITLINE completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) completeWord w start end = do line <- Readline.getLineBuffer @@ -1613,23 +1668,24 @@ completeWord w start end = do ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w _other | ((':':c) : _) <- line_words -> do - maybe_cmd <- lookupCommand' c - let (n,w') = selectWord (words' 0 line) - case maybe_cmd of - Nothing -> return Nothing - Just (_,_,False,complete) -> wrapCompleter complete w - Just (_,_,True,complete) -> let complete' w = do rets <- complete w - return (map (drop n) rets) - in wrapCompleter complete' w' + completionVars <- lookupCompletionVars c + case completionVars of + (Nothing,complete) -> wrapCompleter complete w + (Just breakChars,complete) + -> let (n,w') = selectWord + (words' (`elem` breakChars) 0 line) + complete' w = do rets <- complete w + return (map (drop n) rets) + in wrapCompleter complete' w' | ("import" : _) <- line_words -> wrapCompleter completeModule w | otherwise -> do --printf "complete %s, start = %d, end = %d\n" w start end wrapCompleter completeIdentifier w - where words' _ [] = [] - words' n str = let (w,r) = break isSpace str - (s,r') = span isSpace r - in (n,w):words' (n+length w+length s) r' + where words' _ _ [] = [] + words' isBreak n str = let (w,r) = break isBreak str + (s,r') = span isBreak r + in (n,w):words' isBreak (n+length w+length s) r' -- In a Haskell expression we want to parse 'a-b' as three words -- where a compiler flag (ie. -fno-monomorphism-restriction) should -- only be a single word. @@ -1637,6 +1693,16 @@ completeWord w start end = do selectWord ((offset,x):xs) | offset+length x >= start = (start-offset,take (end-offset) x) | otherwise = selectWord xs + + lookupCompletionVars ('!':_) = return (Just filenameWordBreakChars, + completeFilename) + lookupCompletionVars c = do + maybe_cmd <- lookupCommand' c + case maybe_cmd of + Just (_,_,ws,f) -> return (ws,f) + Nothing -> return (Just filenameWordBreakChars, + completeFilename) + completeCmd :: String -> IO [String] completeCmd w = do @@ -1669,7 +1735,18 @@ completeSetOptions w = do return (filter (w `isPrefixOf`) options) where options = "args":"prog":allFlags -completeFilename = Readline.filenameCompletionFunction +completeFilename w = do + ws <- Readline.filenameCompletionFunction w + case ws of + -- If we only found one result, and it's a directory, + -- add a trailing slash. + [file] -> do + isDir <- expandPathIO file >>= doesDirectoryExist + if isDir && last file /= '/' + then return [file ++ "/"] + else return [file] + _ -> return ws + completeHomeModuleOrFile = unionComplete completeHomeModule completeFilename @@ -1683,8 +1760,10 @@ wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String] wrapCompleter fun w = do strs <- fun w case strs of - [] -> return Nothing - [x] -> return (Just (x,[])) + [] -> Readline.setAttemptedCompletionOver True >> return Nothing + [x] -> -- Add a trailing space, unless it already has an appended slash. + let appended = if last x == '/' then x else x ++ " " + in return (Just (appended,[])) xs -> case getCommonPrefix xs of "" -> return (Just ("",xs)) pref -> return (Just (pref,xs)) @@ -1760,15 +1839,20 @@ ghciHandle h (GHCi m) = GHCi $ \s -> ghciUnblock :: GHCi a -> GHCi a ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a s) +ghciTry :: GHCi a -> GHCi (Either Exception a) +ghciTry (GHCi m) = GHCi $ \s -> Exception.try (m s) -- ---------------------------------------------------------------------------- -- Utils expandPath :: String -> GHCi String -expandPath path = +expandPath path = io (expandPathIO path) + +expandPathIO :: String -> IO String +expandPathIO path = case dropWhile isSpace path of ('~':d) -> do - tilde <- io getHomeDirectory -- will fail if HOME not defined + tilde <- getHomeDirectory -- will fail if HOME not defined return (tilde ++ '/':d) other -> return other @@ -1863,8 +1947,7 @@ continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion -- doContinue :: SingleStep -> GHCi () doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi () doContinue pred step = do - session <- getSession - runResult <- io $ GHC.resume session step + runResult <- resume step afterRunStmt pred runResult return () @@ -1906,15 +1989,19 @@ historyCmd arg (r:_) -> do let hist = GHC.resumeHistory r (took,rest) = splitAt num hist - spans <- mapM (io . GHC.getHistorySpan s) took - let nums = map (printf "-%-3d:") [(1::Int)..] - let names = map GHC.historyEnclosingDecl took - printForUser (vcat(zipWith3 - (\x y z -> x <+> y <+> z) - (map text nums) - (map (bold . ppr) names) - (map (parens . ppr) spans))) - io $ putStrLn $ if null rest then "" else "..." + case hist of + [] -> io $ putStrLn $ + "Empty history. Perhaps you forgot to use :trace?" + _ -> do + spans <- mapM (io . GHC.getHistorySpan s) took + let nums = map (printf "-%-3d:") [(1::Int)..] + names = map GHC.historyEnclosingDecl took + printForUser (vcat(zipWith3 + (\x y z -> x <+> y <+> z) + (map text nums) + (map (bold . ppr) names) + (map (parens . ppr) spans))) + io $ putStrLn $ if null rest then "" else "..." bold :: SDoc -> SDoc bold c | do_bold = text start_bold <> c <> text end_bold @@ -1924,7 +2011,7 @@ backCmd :: String -> GHCi () backCmd = noArgs $ do s <- getSession (names, _, span) <- io $ GHC.back s - printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span + printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState @@ -1935,8 +2022,8 @@ forwardCmd = noArgs $ do s <- getSession (names, ix, span) <- io $ GHC.forward s printForUser $ (if (ix == 0) - then ptext SLIT("Stopped at") - else ptext SLIT("Logged breakpoint at")) <+> ppr span + then ptext (sLit "Stopped at") + else ptext (sLit "Logged breakpoint at")) <+> ppr span printTypeOfNames s names -- run the command set with ":set stop " st <- getGHCiState @@ -1952,7 +2039,7 @@ breakSwitch :: Session -> [String] -> GHCi () breakSwitch _session [] = do io $ putStrLn "The break command requires at least one argument." breakSwitch session (arg1:rest) - | looksLikeModuleName arg1 = do + | looksLikeModuleName arg1 && not (null rest) = do mod <- wantInterpretedModule arg1 breakByModule mod rest | all isDigit arg1 = do @@ -2081,9 +2168,23 @@ listCmd :: String -> GHCi () listCmd "" = do mb_span <- getCurrentBreakSpan case mb_span of - Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list" - Just span | GHC.isGoodSrcSpan span -> io $ listAround span True - | otherwise -> printForUser $ text "unable to list source for" <+> ppr span + Nothing -> + printForUser $ text "Not stopped at a breakpoint; nothing to list" + Just span + | GHC.isGoodSrcSpan span -> io $ listAround span True + | otherwise -> + do s <- getSession + resumes <- io $ GHC.getResumeContext s + case resumes of + [] -> panic "No resumes" + (r:_) -> + do let traceIt = case GHC.resumeHistory r of + [] -> text "rerunning with :trace," + _ -> empty + doWhat = traceIt <+> text ":back then :list" + printForUser (text "Unable to list source for" <+> + ppr span + $$ text "Try" <+> doWhat) listCmd str = list2 (words str) list2 :: [String] -> GHCi () @@ -2264,4 +2365,3 @@ setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool setBreakFlag toggle array index | toggle = GHC.setBreakOn array index | otherwise = GHC.setBreakOff array index -