X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fghci%2FInteractiveUI.hs;h=a0c76ec52ef8f3279536d00221f101941eeef1fc;hb=b70f35afc1c606dc85e6feb7da74be72411f58c1;hp=2be47c312e321114659f280cf5e362808ab87803;hpb=7afefbd79dc573b5d36bbd949b52badcf5ba4cab;p=ghc-hetmet.git diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs index 2be47c3..a0c76ec 100644 --- a/compiler/ghci/InteractiveUI.hs +++ b/compiler/ghci/InteractiveUI.hs @@ -22,11 +22,16 @@ import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..), BreakIndex, SrcSpan, Resume, SingleStep ) import PprTyThing import DynFlags + import Packages +#ifdef USE_READLINE import PackageConfig import UniqFM +#endif + import HscTypes ( implicitTyThings ) -import Outputable hiding (printForUser) +import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC? +import Outputable hiding (printForUser, printForUserPartWay) import Module -- for ModuleEnv import Name import SrcLoc @@ -42,12 +47,12 @@ import Util import NameSet import Maybes ( orElse ) import FastString +import Encoding #ifndef mingw32_HOST_OS import System.Posix hiding (getEnv) #else import GHC.ConsoleHandler ( flushConsole ) -import System.Win32 ( setConsoleCP, setConsoleOutputCP ) import qualified System.Win32 #endif @@ -70,20 +75,21 @@ import System.Exit ( exitWith, ExitCode(..) ) import System.Directory import System.IO import System.IO.Error as IO -import System.IO.Unsafe import Data.Char import Data.Dynamic import Data.Array import Control.Monad as Monad import Text.Printf - -import Foreign.StablePtr ( newStablePtr ) +import Foreign +import Foreign.C ( withCStringLen ) import GHC.Exts ( unsafeCoerce# ) import GHC.IOBase ( IOErrorType(InvalidArgument) ) import Data.IORef ( IORef, readIORef, writeIORef ) +#ifdef USE_READLINE import System.Posix.Internals ( setNonBlockingFD ) +#endif ----------------------------------------------------------------------------- @@ -91,58 +97,76 @@ ghciWelcomeMsg :: String ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++ ": http://www.haskell.org/ghc/ :? for help" -type Command = (String, String -> GHCi Bool, Bool, String -> IO [String]) - cmdName :: Command -> String cmdName (n,_,_,_) = n -commands :: IORef [Command] -GLOBAL_VAR(commands, builtin_commands, [Command]) +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, 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, 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), + ("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. +word_break_chars, flagWordBreakChars, filenameWordBreakChars :: String +word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~" + specials = "(),;[]`{}" + spaces = " \t\n" + in spaces ++ specials ++ symbols +flagWordBreakChars = " \t\n" +filenameWordBreakChars = " \t\n\\`@$><=;|&{(" -- bash defaults + + keepGoing :: (String -> GHCi ()) -> (String -> GHCi Bool) keepGoing a str = a str >> return False @@ -157,8 +181,11 @@ helpText = " Commands available from the prompt:\n" ++ "\n" ++ " evaluate/run \n" ++ + " : repeat last command\n" ++ + " :{\\n ..lines.. \\n:}\\n multiline command\n" ++ " :add ... add module(s) to the current target set\n" ++ - " :browse [*] display the names defined by \n" ++ + " :browse[!] [[*]] display the names defined by module \n" ++ + " (!: more details; *: all top-level names)\n" ++ " :cd change directory to \n" ++ " :cmd run the commands returned by ::IO String\n" ++ " :ctags [] create tags file for Vi (default: \"tags\")\n" ++ @@ -217,6 +244,8 @@ helpText = " +t print type after evaluation\n" ++ " - most GHC command line flags can also be set here\n" ++ " (eg. -v2, -fglasgow-exts, etc.)\n" ++ + " for GHCi-specific flags, see User's Guide,\n"++ + " Flag reference, Interactive-mode options\n" ++ "\n" ++ " -- Commands for displaying information:\n" ++ "\n" ++ @@ -224,6 +253,8 @@ helpText = " :show breaks show the active breakpoints\n" ++ " :show context show the breakpoint context\n" ++ " :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" ++ "\n" @@ -277,13 +308,9 @@ interactiveUI session srcs maybe_expr = do 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 + Readline.setCompletionAppendCharacter Nothing #endif default_editor <- findEditor @@ -300,7 +327,9 @@ interactiveUI session srcs maybe_expr = do break_ctr = 0, breaks = [], tickarrays = emptyModuleEnv, - cmdqueue = [] + last_command = Nothing, + cmdqueue = [], + remembered_ctx = Nothing } #ifdef USE_READLINE @@ -324,11 +353,11 @@ runGHCi paths maybe_expr = do either_hdl <- io (IO.try (openFile "./.ghci" ReadMode)) case either_hdl of Left _e -> return () - Right hdl -> fileLoop hdl False + Right hdl -> runCommands (fileLoop hdl False False) when (read_dot_files) $ do -- Read in $HOME/.ghci - either_dir <- io (IO.try (getEnv "HOME")) + either_dir <- io (IO.try getHomeDirectory) case either_dir of Left _e -> return () Right dir -> do @@ -340,7 +369,7 @@ runGHCi paths maybe_expr = do either_hdl <- io (IO.try (openFile file ReadMode)) case either_hdl of Left _e -> return () - Right hdl -> fileLoop hdl False + Right hdl -> runCommands (fileLoop hdl False False) -- Perform a :load for files given on the GHCi command line -- When in -e mode, if the load fails then we want to stop @@ -371,9 +400,6 @@ runGHCi paths maybe_expr = do | otherwise -> io (ioError err) Right () -> return () #endif - -- initialise the console if necessary - io setUpConsole - -- enter the interactive loop interactiveLoop is_tty show_prompt Just expr -> do @@ -402,10 +428,10 @@ interactiveLoop is_tty show_prompt = -- read commands from stdin #ifdef USE_READLINE if (is_tty) - then readlineLoop - else fileLoop stdin show_prompt + then runCommands readlineLoop + else runCommands (fileLoop stdin show_prompt is_tty) #else - fileLoop stdin show_prompt + runCommands (fileLoop stdin show_prompt is_tty) #endif @@ -419,10 +445,11 @@ interactiveLoop is_tty show_prompt = -- the same directory while a process is running. checkPerms :: String -> IO Bool -checkPerms name = #ifdef mingw32_HOST_OS +checkPerms _ = return True #else +checkPerms name = Util.handle (\_ -> return False) $ do st <- getFileStatus name me <- getRealUserID @@ -440,32 +467,55 @@ checkPerms name = else return True #endif -fileLoop :: Handle -> Bool -> GHCi () -fileLoop hdl show_prompt = do +fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String) +fileLoop hdl show_prompt is_tty = do when show_prompt $ do prompt <- mkPrompt (io (putStr prompt)) l <- io (IO.try (hGetLine hdl)) case l of - 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 removeSpaces l of - "" -> fileLoop hdl show_prompt - l -> do quit <- runCommands l - if quit then return () else fileLoop hdl show_prompt + Left e | isEOFError e -> return Nothing + | InvalidArgument <- etype -> return Nothing + | 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 -> do + str <- io $ consoleInputToUnicode is_tty l + return (Just str) + +#ifdef mingw32_HOST_OS +-- Convert the console input into Unicode according to the current code page. +-- The Windows console stores Unicode characters directly, so this is a +-- rather roundabout way of doing things... oh well. +-- See #782, #1483, #1649 +consoleInputToUnicode :: Bool -> String -> IO String +consoleInputToUnicode is_tty str + | is_tty = do + cp <- System.Win32.getConsoleCP + System.Win32.stringToUnicode cp str + | otherwise = + decodeStringAsUTF8 str +#else +-- for Unix, assume the input is in UTF-8 and decode it to a Unicode String. +-- See #782. +consoleInputToUnicode :: Bool -> String -> IO String +consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str +#endif + +decodeStringAsUTF8 :: String -> IO String +decodeStringAsUTF8 str = + withCStringLen str $ \(cstr,len) -> + utf8DecodeString (castPtr cstr :: Ptr Word8) len mkPrompt :: GHCi String mkPrompt = do session <- getSession (toplevs,exports) <- io (GHC.getContext session) resumes <- io $ GHC.getResumeContext session + -- st <- getGHCiState context_bit <- case resumes of @@ -483,8 +533,14 @@ mkPrompt = do dots | _:rs <- resumes, not (null rs) = text "... " | otherwise = empty + + modules_bit = - hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> + -- ToDo: maybe... + -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in + -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+> + -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+> + hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+> hsep (map (ppr . GHC.moduleName) exports) deflt_prompt = dots <> context_bit <> modules_bit @@ -499,41 +555,73 @@ mkPrompt = do #ifdef USE_READLINE -readlineLoop :: GHCi () +readlineLoop :: GHCi (Maybe String) readlineLoop = do io yield saveSession -- for use by completion prompt <- mkPrompt l <- io (readline prompt `finally` setNonBlockingFD 0) - -- readline sometimes puts stdin into blocking mode, - -- so we need to put it back for the IO library + -- readline sometimes puts stdin into blocking mode, + -- so we need to put it back for the IO library splatSavedSession case l of - Nothing -> return () - Just l -> - case removeSpaces l of - "" -> readlineLoop - l -> do - io (addHistory l) - quit <- runCommands l - if quit then return () else readlineLoop + Nothing -> return Nothing + Just l -> do + io (addHistory l) + str <- io $ consoleInputToUnicode True l + return (Just str) #endif -runCommands :: String -> GHCi Bool -runCommands cmd = do - q <- ghciHandle handler (doCommand cmd) - if q then return True else runNext +queryQueue :: GHCi (Maybe String) +queryQueue = do + st <- getGHCiState + case cmdqueue st of + [] -> return Nothing + c:cs -> do setGHCiState st{ cmdqueue = cs } + return (Just c) + +runCommands :: GHCi (Maybe String) -> GHCi () +runCommands 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 where - runNext = do - st <- getGHCiState - case cmdqueue st of - [] -> return False - c:cs -> do setGHCiState st{ cmdqueue = cs } - runCommands c - - doCommand (':' : cmd) = specialCommand cmd - doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion - return False + noSpace q = q >>= maybe (return Nothing) + (\c->case removeSpaces c of + "" -> noSpace q + ":{" -> multiLineCmd q + c -> return (Just c) ) + multiLineCmd q = do + st <- getGHCiState + let p = prompt st + setGHCiState st{ prompt = "%s| " } + mb_cmd <- collectCommand q "" + getGHCiState >>= \st->setGHCiState st{ prompt = p } + return mb_cmd + -- we can't use removeSpaces for the sublines here, so + -- multiline commands are somewhat more brittle against + -- fileformat errors (such as \r in dos input on unix), + -- we get rid of any extra spaces for the ":}" test; + -- we also avoid silent failure if ":}" is not found; + -- and since there is no (?) valid occurrence of \r (as + -- opposed to its String representation, "\r") inside a + -- ghci command, we replace any such with ' ' (argh:-( + collectCommand q c = q >>= + maybe (io (ioError collectError)) + (\l->if removeSpaces l == ":}" + then return (Just $ removeSpaces c) + else collectCommand q (c++map normSpace l)) + where normSpace '\r' = ' ' + normSpace c = c + -- QUESTION: is userError the one to use here? + collectError = userError "unterminated multiline command :{ .. :}" + doCommand (':' : cmd) = specialCommand cmd + doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion + return False enqueueCommands :: [String] -> GHCi () enqueueCommands cmds = do @@ -588,7 +676,11 @@ afterRunStmt step_here run_result = do printForUser $ ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan $ head resumes) -- printTypeOfNames session names - printTypeAndContentOfNames session names + let namesSorted = sortBy compareNames names + tythings <- catMaybes `liftM` + io (mapM (GHC.lookupName session) namesSorted) + docs <- io$ pprTypeAndContents session [id | AnId id <- tythings] + printForUserPartWay docs maybe (return ()) runBreakCmd mb_info -- run the command set with ":set stop " st <- getGHCiState @@ -605,19 +697,6 @@ afterRunStmt step_here run_result = do return (case run_result of GHC.RunOk _ -> True; _ -> False) - where printTypeAndContentOfNames session names = do - let namesSorted = sortBy compareNames names - tythings <- catMaybes `liftM` - io (mapM (GHC.lookupName session) namesSorted) - let ids = [id | AnId id <- tythings] - terms <- mapM (io . GHC.obtainTermB session 10 False) ids - docs_terms <- mapM (io . showTerm session) terms - dflags <- getDynFlags - let pefas = dopt Opt_PrintExplicitForalls dflags - printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts) - (map (pprTyThing pefas . AnId) ids) - docs_terms - runBreakCmd :: GHC.BreakInfo -> GHCi () runBreakCmd info = do let mod = GHC.breakInfo_module info @@ -645,26 +724,49 @@ printTypeOfName session n Nothing -> return () Just thing -> printTyThing thing + +data MaybeCommand = GotCommand Command | BadCommand | NoLastCommand + specialCommand :: String -> GHCi Bool specialCommand ('!':str) = shellEscape (dropWhile isSpace str) specialCommand str = do let (cmd,rest) = break isSpace str - maybe_cmd <- io (lookupCommand cmd) + maybe_cmd <- lookupCommand cmd case maybe_cmd of - Nothing -> io (hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" - ++ shortHelpText) >> return False) - Just (_,f,_,_) -> f (dropWhile isSpace rest) - -lookupCommand :: String -> IO (Maybe Command) + GotCommand (_,f,_,_) -> f (dropWhile isSpace rest) + BadCommand -> + do io $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n" + ++ shortHelpText) + return False + NoLastCommand -> + do io $ hPutStr stdout ("there is no last command to perform\n" + ++ shortHelpText) + return False + +lookupCommand :: String -> GHCi (MaybeCommand) +lookupCommand "" = do + st <- getGHCiState + case last_command st of + Just c -> return $ GotCommand c + Nothing -> return NoLastCommand lookupCommand str = do - cmds <- readIORef commands + mc <- io $ lookupCommand' str + st <- getGHCiState + setGHCiState st{ last_command = mc } + return $ case mc of + Just c -> GotCommand c + Nothing -> BadCommand + +lookupCommand' :: String -> IO (Maybe Command) +lookupCommand' str = do + macros <- readIORef macros_ref + let cmds = builtin_commands ++ macros -- look for exact match first, then the first prefix match - case [ c | c <- cmds, str == cmdName c ] of - c:_ -> return (Just c) - [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of - [] -> return Nothing - c:_ -> return (Just c) - + return $ case [ c | c <- cmds, str == cmdName c ] of + c:_ -> Just c + [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of + [] -> Nothing + c:_ -> Just c getCurrentBreakSpan :: GHCi (Maybe SrcSpan) getCurrentBreakSpan = do @@ -753,18 +855,26 @@ addModule files = do targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files session <- getSession io (mapM_ (GHC.addTarget session) targets) + prev_context <- io $ GHC.getContext session ok <- io (GHC.load session LoadAllTargets) - afterLoad ok session + 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) when (not (null graph)) $ io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n" + prev_context <- io $ GHC.getContext session io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) - setContextAfterLoad session [] + setContextAfterLoad session prev_context [] io (GHC.workingDirectoryChanged session) dir <- expandPath dir io (setCurrentDirectory dir) @@ -812,18 +922,24 @@ chooseEditFile = where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f fromTarget _ = Nothing -- when would we get a module target? -defineMacro :: String -> GHCi () -defineMacro s = do +defineMacro :: Bool{-overwrite-} -> String -> GHCi () +defineMacro overwrite s = do let (macro_name, definition) = break isSpace s - cmds <- io (readIORef commands) + macros <- io (readIORef macros_ref) + let defined = map cmdName macros if (null macro_name) - then throwDyn (CmdLineError "invalid macro name") + then if null defined + then io $ putStrLn "no macros defined" + else io $ putStr ("the following macros are defined:\n" ++ + unlines defined) else do - if (macro_name `elem` map cmdName cmds) + if (not overwrite && macro_name `elem` defined) then throwDyn (CmdLineError - ("command '" ++ macro_name ++ "' is already defined")) + ("macro '" ++ macro_name ++ "' is already defined")) else do + let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ] + -- give the expression a type signature, so we can be sure we're getting -- something of the right type. let new_expr = '(' : definition ++ ") :: String -> IO String" @@ -833,8 +949,8 @@ defineMacro s = do maybe_hv <- io (GHC.compileExpr cms new_expr) case maybe_hv of Nothing -> return () - Just hv -> io (writeIORef commands -- - (cmds ++ [(macro_name, runMacro hv, False, completeNone)])) + Just hv -> io (writeIORef macros_ref -- + (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)])) runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool runMacro fun s = do @@ -843,17 +959,14 @@ runMacro fun s = do return False undefineMacro :: String -> GHCi () -undefineMacro macro_name = do - cmds <- io (readIORef commands) - if (macro_name `elem` map cmdName builtin_commands) - then throwDyn (CmdLineError - ("command '" ++ macro_name ++ "' cannot be undefined")) - else do - if (macro_name `notElem` map cmdName cmds) - then throwDyn (CmdLineError - ("command '" ++ macro_name ++ "' not defined")) - else do - io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds)) +undefineMacro str = mapM_ undef (words str) + where undef macro_name = do + cmds <- io (readIORef macros_ref) + if (macro_name `notElem` map cmdName cmds) + then throwDyn (CmdLineError + ("macro '" ++ macro_name ++ "' is not defined")) + else do + io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds)) cmdCmd :: String -> GHCi () cmdCmd str = do @@ -876,6 +989,7 @@ loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return () loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag loadModule' files = do session <- getSession + prev_context <- io $ GHC.getContext session -- unload first discardActiveBreakPoints @@ -894,12 +1008,13 @@ loadModule' files = do -- as a ToDo for now. io (GHC.setTargets session targets) - doLoad session LoadAllTargets + doLoad session False prev_context LoadAllTargets checkModule :: String -> GHCi () checkModule m = do let modl = GHC.mkModuleName m session <- getSession + prev_context <- io $ GHC.getContext session result <- io (GHC.checkModule session modl False) case result of Nothing -> io $ putStrLn "Nothing" @@ -912,37 +1027,74 @@ checkModule m = do (text "global names: " <+> ppr global) $$ (text "local names: " <+> ppr local) _ -> empty)) - afterLoad (successIf (isJust result)) session + afterLoad (successIf (isJust result)) session False prev_context reloadModule :: String -> GHCi () reloadModule m = do session <- getSession - doLoad session $ if null m then LoadAllTargets - else LoadUpTo (GHC.mkModuleName m) + prev_context <- io $ GHC.getContext session + doLoad session True prev_context $ + if null m then LoadAllTargets + else LoadUpTo (GHC.mkModuleName m) return () -doLoad :: Session -> LoadHowMuch -> GHCi SuccessFlag -doLoad session howmuch = do +doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag +doLoad session retain_context prev_context howmuch = do -- turn off breakpoints before we load: we can't turn them off later, because -- the ModBreaks will have gone away. discardActiveBreakPoints ok <- io (GHC.load session howmuch) - afterLoad ok session + afterLoad ok session retain_context prev_context return ok -afterLoad :: SuccessFlag -> Session -> GHCi () -afterLoad ok session = do +afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi () +afterLoad ok session retain_context prev_context = do io (revertCAFs) -- always revert CAFs on load. discardTickArrays - loaded_mods <- getLoadedModules session - setContextAfterLoad session loaded_mods - modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods) + 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 -setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi () -setContextAfterLoad session [] = do + 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 prel_mod <- getPrelude - io (GHC.setContext session [] [prel_mod]) -setContextAfterLoad session ms = do + setContextKeepingPackageModules session prev ([], [prel_mod]) +setContextAfterLoad session prev 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 @@ -966,11 +1118,26 @@ setContextAfterLoad session ms = do load_this summary | m <- GHC.ms_mod summary = do b <- io (GHC.moduleIsInterpreted session m) - if b then io (GHC.setContext session [m] []) + if b then setContextKeepingPackageModules session prev ([m], []) else do - prel_mod <- getPrelude - io (GHC.setContext session [] [prel_mod,m]) + prel_mod <- getPrelude + setContextKeepingPackageModules session prev ([],[prel_mod,m]) + +-- | Keep any package modules (except Prelude) when changing the context. +setContextKeepingPackageModules + :: Session + -> ([Module],[Module]) -- previous context + -> ([Module],[Module]) -- new context + -> GHCi () +setContextKeepingPackageModules session prev_context (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)) +isHomeModule :: Module -> Bool +isHomeModule mod = GHC.modulePackageId mod == mainPackageId modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi () modulesLoadedMsg ok mods = do @@ -1015,48 +1182,111 @@ shellEscape str = io (system str >> return False) ----------------------------------------------------------------------------- -- Browsing a module's contents -browseCmd :: String -> GHCi () -browseCmd m = +browseCmd :: Bool -> String -> GHCi () +browseCmd bang m = case words m of - ['*':m] | looksLikeModuleName m -> browseModule m False - [m] | looksLikeModuleName m -> browseModule m True + ['*':s] | looksLikeModuleName s -> do + m <- wantInterpretedModule s + browseModule bang m False + [s] | looksLikeModuleName s -> do + m <- lookupModule s + browseModule bang m True + [] -> do + s <- getSession + (as,bs) <- io $ GHC.getContext s + -- Guess which module the user wants to browse. Pick + -- modules that are interpreted first. The most + -- recently-added module occurs last, it seems. + case (as,bs) of + (as@(_:_), _) -> browseModule bang (last as) True + ([], bs@(_:_)) -> browseModule bang (last bs) True + ([], []) -> throwDyn (CmdLineError ":browse: no current module") _ -> throwDyn (CmdLineError "syntax: :browse ") -browseModule :: String -> Bool -> GHCi () -browseModule m exports_only = do +-- without bang, show items in context of their parents and omit children +-- with bang, show class methods and data constructors separately, and +-- indicate import modules, to aid qualifying unqualified names +-- with sorted, sort items alphabetically +browseModule :: Bool -> Module -> Bool -> GHCi () +browseModule bang modl exports_only = do s <- getSession - modl <- if exports_only then lookupModule m - else wantInterpretedModule m - + -- :browse! reports qualifiers wrt current context + current_unqual <- io (GHC.getPrintUnqual s) -- Temporarily set the context to the module we're interested in, -- just so we can get an appropriate PrintUnqualified (as,bs) <- io (GHC.getContext s) prel_mod <- getPrelude io (if exports_only then GHC.setContext s [] [prel_mod,modl] - else GHC.setContext s [modl] []) - unqual <- io (GHC.getPrintUnqual s) + else GHC.setContext s [modl] []) + target_unqual <- io (GHC.getPrintUnqual s) io (GHC.setContext s as bs) + let unqual = if bang then current_unqual else target_unqual + mb_mod_info <- io $ GHC.getModuleInfo s modl case mb_mod_info of - Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m)) + Nothing -> throwDyn (CmdLineError ("unknown module: " ++ + GHC.moduleNameString (GHC.moduleName modl))) Just mod_info -> do - let names - | exports_only = GHC.modInfoExports mod_info - | otherwise = GHC.modInfoTopLevelScope mod_info - `orElse` [] - - mb_things <- io $ mapM (GHC.lookupName s) names - let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) - dflags <- getDynFlags - let pefas = dopt Opt_PrintExplicitForalls dflags - io (putStrLn (showSDocForUser unqual ( - vcat (map (pprTyThingInContext pefas) filtered_things) - ))) - -- ToDo: modInfoInstances currently throws an exception for - -- package modules. When it works, we can do this: - -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) + let names + | exports_only = GHC.modInfoExports mod_info + | otherwise = GHC.modInfoTopLevelScope mod_info + `orElse` [] + + -- sort alphabetically name, but putting + -- locally-defined identifiers first. + -- We would like to improve this; see #1799. + sorted_names = loc_sort local ++ occ_sort external + where + (local,external) = partition ((==modl) . nameModule) names + occ_sort = sortBy (compare `on` nameOccName) + -- try to sort by src location. If the first name in + -- our list has a good source location, then they all should. + loc_sort names + | n:_ <- names, isGoodSrcSpan (nameSrcSpan n) + = sortBy (compare `on` nameSrcSpan) names + | otherwise + = occ_sort names + + mb_things <- io $ mapM (GHC.lookupName s) sorted_names + let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things) + + rdr_env <- io $ GHC.getGRE s + + let pefas = dopt Opt_PrintExplicitForalls dflags + things | bang = catMaybes mb_things + | otherwise = filtered_things + pretty | bang = pprTyThing + | otherwise = pprTyThingInContext + + labels [] = text "-- not currently imported" + labels l = text $ intercalate "\n" $ map qualifier l + qualifier = maybe "-- defined locally" + (("-- imported via "++) . intercalate ", " + . map GHC.moduleNameString) + importInfo = RdrName.getGRE_NameQualifier_maybes rdr_env + modNames = map (importInfo . GHC.getName) things + + -- annotate groups of imports with their import modules + -- the default ordering is somewhat arbitrary, so we group + -- by header and sort groups; the names themselves should + -- really come in order of source appearance.. (trac #1799) + annotate mts = concatMap (\(m,ts)->labels m:ts) + $ sortBy cmpQualifiers $ group mts + where cmpQualifiers = + compare `on` (map (fmap (map moduleNameFS)) . fst) + group [] = [] + group mts@((m,_):_) = (m,map snd g) : group ng + where (g,ng) = partition ((==m).fst) mts + + let prettyThings = map (pretty pefas) things + prettyThings' | bang = annotate $ zip modNames prettyThings + | otherwise = prettyThings + io (putStrLn $ showSDocForUser unqual (vcat prettyThings')) + -- ToDo: modInfoInstances currently throws an exception for + -- package modules. When it works, we can do this: + -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info)) ----------------------------------------------------------------------------- -- Setting the module context @@ -1078,14 +1308,10 @@ separate :: Session -> [String] -> [Module] -> [Module] -> GHCi ([Module],[Module]) separate _ [] as bs = return (as,bs) separate session (('*':str):ms) as bs = do - m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing - b <- io $ GHC.moduleIsInterpreted session m - if b then separate session ms (m:as) bs - else throwDyn (CmdLineError ("module '" - ++ GHC.moduleNameString (GHC.moduleName m) - ++ "' is not interpreted")) + m <- wantInterpretedModule str + separate session ms (m:as) bs separate session (str:ms) as bs = do - m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing + m <- lookupModule str separate session ms as (m:bs) newContext :: [String] -> GHCi () @@ -1142,6 +1368,28 @@ setCmd "" then text "none." else hsep (map (\o -> char '+' <> text (optToStr o)) opts) )) + dflags <- getDynFlags + io $ putStrLn (showSDoc ( + vcat (text "GHCi-specific dynamic flag settings:" + :map (flagSetting dflags) ghciFlags) + )) + io $ putStrLn (showSDoc ( + vcat (text "other dynamic, non-language, flag settings:" + :map (flagSetting dflags) nonLanguageDynFlags) + )) + where flagSetting dflags (str,f) + | dopt f dflags = text " " <> text "-f" <> text str + | otherwise = text " " <> text "-fno-" <> text str + (ghciFlags,others) = partition (\(_,f)->f `elem` flags) + DynFlags.fFlags + nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags) + others + flags = [Opt_PrintExplicitForalls + ,Opt_PrintBindResult + ,Opt_BreakOnException + ,Opt_BreakOnError + ,Opt_PrintEvldWithShow + ] setCmd str = case toArgs str of ("args":args) -> setArgs args @@ -1224,7 +1472,8 @@ newDynFlags minus_opts = do io (GHC.setTargets session []) io (GHC.load session LoadAllTargets) io (linkPackages dflags new_pkgs) - setContextAfterLoad session [] + -- package flags changed, we can't re-use any of the old context + setContextAfterLoad session ([],[]) [] return () @@ -1295,6 +1544,8 @@ showCmd str = do ["linker"] -> io showLinkerState ["breaks"] -> showBkptTable ["context"] -> showContext + ["packages"] -> showPackages + ["languages"] -> showLanguages _ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]") showModules :: GHCi () @@ -1314,8 +1565,9 @@ showBindings :: GHCi () showBindings = do s <- getSession bindings <- io (GHC.getBindings s) - mapM_ printTyThing $ sortBy compareTyThings bindings - return () + docs <- io$ pprTypeAndContents s + [ id | AnId id <- sortBy compareTyThings bindings] + printForUserPartWay docs compareTyThings :: TyThing -> TyThing -> Ordering t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2 @@ -1340,6 +1592,26 @@ showContext = do ptext SLIT("--> ") <> text (GHC.resumeStmt resume) $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume)) +showPackages :: GHCi () +showPackages = do + pkg_flags <- fmap packageFlags getDynFlags + io $ putStrLn $ showSDoc $ vcat $ + text ("active package flags:"++if null pkg_flags then " none" else "") + : map showFlag pkg_flags + pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags + io $ putStrLn $ showSDoc $ vcat $ + text "packages currently loaded:" + : map (nest 2 . text . packageIdString) pkg_ids + where showFlag (ExposePackage p) = text $ " -package " ++ p + showFlag (HidePackage p) = text $ " -hide-package " ++ p + showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p + +showLanguages :: GHCi () +showLanguages = do + dflags <- getDynFlags + io $ putStrLn $ showSDoc $ vcat $ + text "active language flags:" : + [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags] -- ----------------------------------------------------------------------------- -- Completion @@ -1347,6 +1619,11 @@ showContext = do completeNone :: String -> IO [String] completeNone _w = return [] +completeMacro, completeIdentifier, completeModule, + completeHomeModule, completeSetOptions, completeFilename, + completeHomeModuleOrFile + :: String -> IO [String] + #ifdef USE_READLINE completeWord :: String -> Int -> Int -> IO (Maybe (String, [String])) completeWord w start end = do @@ -1356,23 +1633,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. @@ -1380,21 +1658,26 @@ 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, completeMacro, completeIdentifier, completeModule, - completeHomeModule, completeSetOptions, completeFilename, - completeHomeModuleOrFile - :: String -> IO [String] - +completeCmd :: String -> IO [String] completeCmd w = do - cmds <- readIORef commands - return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds))) + cmds <- readIORef macros_ref + return (filter (w `isPrefixOf`) (map (':':) + (map cmdName (builtin_commands ++ cmds)))) completeMacro w = do - cmds <- readIORef commands - let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ] - return (filter (w `isPrefixOf`) cmds') + cmds <- readIORef macros_ref + return (filter (w `isPrefixOf`) (map cmdName cmds)) completeIdentifier w = do s <- restoreSession @@ -1417,7 +1700,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 @@ -1431,8 +1725,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)) @@ -1448,11 +1744,10 @@ getCommonPrefix (s:ss) = foldl common s ss allExposedModules :: DynFlags -> [ModuleName] allExposedModules dflags - = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db)))) + = concat (map exposedModules (filter exposed (eltsUFM pkg_db))) where pkg_db = pkgIdMap (pkgState dflags) #else -completeCmd = completeNone completeMacro = completeNone completeIdentifier = completeNone completeModule = completeNone @@ -1460,7 +1755,6 @@ completeHomeModule = completeNone completeSetOptions = completeNone completeFilename = completeNone completeHomeModuleOrFile=completeNone -completeBkpt = completeNone #endif -- --------------------------------------------------------------------------- @@ -1515,10 +1809,13 @@ ghciUnblock (GHCi a) = GHCi $ \s -> Exception.unblock (a 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 (getEnv "HOME") -- will fail if HOME not defined + tilde <- getHomeDirectory -- will fail if HOME not defined return (tilde ++ '/':d) other -> return other @@ -1552,33 +1849,6 @@ wantNameFromInterpretedModule noCanDo str and_then = do text " is not interpreted" else and_then n --- ---------------------------------------------------------------------------- --- Windows console setup - -setUpConsole :: IO () -setUpConsole = do -#ifdef mingw32_HOST_OS - -- On Windows we need to set a known code page, otherwise the characters - -- we read from the console will be be in some strange encoding, and - -- similarly for characters we write to the console. - -- - -- At the moment, GHCi pretends all input is Latin-1. In the - -- future we should support UTF-8, but for now we set the code - -- pages to Latin-1. Doing it this way does lead to problems, - -- however: see bug #1649. - -- - -- It seems you have to set the font in the console window to - -- a Unicode font in order for output to work properly, - -- otherwise non-ASCII characters are mapped wrongly. sigh. - -- (see MSDN for SetConsoleOutputCP()). - -- - -- This call has been known to hang on some machines, see bug #1483 - -- - setConsoleCP 28591 -- ISO Latin-1 - setConsoleOutputCP 28591 -- ISO Latin-1 -#endif - return () - -- ----------------------------------------------------------------------------- -- commands for debugger @@ -1683,15 +1953,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