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
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
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
-----------------------------------------------------------------------------
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
" Commands available from the prompt:\n" ++
"\n" ++
" <statement> evaluate/run <statement>\n" ++
+ " : repeat last command\n" ++
+ " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
- " :browse [*]<module> display the names defined by <module>\n" ++
+ " :browse[!] [[*]<mod>] display the names defined by module <mod>\n" ++
+ " (!: more details; *: all top-level names)\n" ++
" :cd <dir> change directory to <dir>\n" ++
" :cmd <expr> run the commands returned by <expr>::IO String\n" ++
" :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
" +t print type after evaluation\n" ++
" -<flags> 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" ++
" :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 <setting> show anything that can be set with :set (e.g. args)\n" ++
"\n"
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
break_ctr = 0,
breaks = [],
tickarrays = emptyModuleEnv,
- cmdqueue = []
+ last_command = Nothing,
+ cmdqueue = [],
+ remembered_ctx = Nothing
}
#ifdef USE_READLINE
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
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
| 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
-- 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
-- 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
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
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
#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
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 <cmd>"
st <- getGHCiState
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
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
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)
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"
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
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
loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
loadModule' files = do
session <- getSession
+ prev_context <- io $ GHC.getContext session
-- unload first
discardActiveBreakPoints
-- 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"
(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
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
-----------------------------------------------------------------------------
-- 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 <module>")
-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
-> 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 ()
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
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 ()
["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 ()
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
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
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
':':_ | 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.
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
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
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))
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
completeSetOptions = completeNone
completeFilename = completeNone
completeHomeModuleOrFile=completeNone
-completeBkpt = completeNone
#endif
-- ---------------------------------------------------------------------------
-- 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
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
(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 "<end of history>" 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 "<end of history>" else "..."
bold :: SDoc -> SDoc
bold c | do_bold = text start_bold <> c <> text end_bold
projects / ghc-hetmet.git / blobdiff