/ghc-patch/InteractiveUI.hs
Haskell | 2423 lines | 1894 code | 290 blank | 239 comment | 131 complexity | 0bb25cf8760ee4d689493e7b9cb0abcf MD5 | raw file
Possible License(s): BSD-3-Clause
- {-# OPTIONS -fno-cse #-}
- -- -fno-cse is needed for GLOBAL_VAR's to behave properly
- {-# OPTIONS -#include "Linker.h" #-}
- -----------------------------------------------------------------------------
- --
- -- GHC Interactive User Interface
- --
- -- (c) The GHC Team 2005-2006
- --
- -----------------------------------------------------------------------------
- module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
- #include "HsVersions.h"
- import qualified GhciMonad
- import GhciMonad hiding (runStmt)
- import GhciTags
- import Debugger
- -- The GHC interface
- import qualified GHC hiding (resume, runStmt)
- import GHC ( LoadHowMuch(..), Target(..), TargetId(..),
- Module, ModuleName, TyThing(..), Phase,
- BreakIndex, SrcSpan, Resume, SingleStep,
- Ghc, handleSourceError )
- import GoalCollector
- import PprTyThing
- import DynFlags
- import Packages
- #ifdef USE_EDITLINE
- import PackageConfig
- import UniqFM
- #endif
- import HscTypes ( implicitTyThings, reflectGhc, reifyGhc
- , handleFlagWarnings )
- import qualified RdrName ( getGRE_NameQualifier_maybes ) -- should this come via GHC?
- import Outputable hiding (printForUser, printForUserPartWay)
- import Module -- for ModuleEnv
- import Name
- import SrcLoc
- -- Other random utilities
- import CmdLineParser
- import Digraph
- import BasicTypes hiding (isTopLevel)
- import Panic hiding (showException)
- import Config
- import StaticFlags
- import Linker
- import Util
- import NameSet
- import Maybes ( orElse, expectJust )
- import FastString
- import Encoding
- import MonadUtils ( liftIO )
- #ifndef mingw32_HOST_OS
- import System.Posix hiding (getEnv)
- #else
- import GHC.ConsoleHandler ( flushConsole )
- import qualified System.Win32
- #endif
- #ifdef USE_EDITLINE
- import Control.Concurrent ( yield ) -- Used in readline loop
- import System.Console.Editline.Readline as Readline
- #endif
- --import SystemExts
- import Exception
- -- import Control.Concurrent
- import System.FilePath
- import qualified Data.ByteString.Char8 as BS
- import Data.List
- import Data.Maybe
- import System.Cmd
- import System.Environment
- import System.Exit ( exitWith, ExitCode(..) )
- import System.Directory
- import System.IO
- import System.IO.Error as IO
- import Data.Char
- import Data.Array
- import Control.Monad as Monad
- import Text.Printf
- import Foreign
- import Foreign.C
- import GHC.Exts ( unsafeCoerce# )
- import GHC.IOBase ( IOErrorType(InvalidArgument) )
- import GHC.TopHandler
- import Data.IORef ( IORef, readIORef, writeIORef )
- -----------------------------------------------------------------------------
- ghciWelcomeMsg :: String
- ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
- ": http://www.haskell.org/ghc/ :? for help"
- cmdName :: Command -> String
- cmdName (n,_,_,_) = n
- 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, 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),
- ("goals", keepGoing goalsCmd, Nothing, completeIdentifier),
- ("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, completeShowOptions),
- ("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
- = do case toArgs str of
- Left err -> io (hPutStrLn stderr err)
- Right args -> a args
- return False
- shortHelpText :: String
- shortHelpText = "use :? for help.\n"
- helpText :: String
- helpText =
- " Commands available from the prompt:\n" ++
- "\n" ++
- " <statement> evaluate/run <statement>\n" ++
- " : repeat last command\n" ++
- " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
- " :add [*]<module> ... add module(s) to the current target set\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" ++
- " :def <cmd> <expr> define a command :<cmd>\n" ++
- " :edit <file> edit file\n" ++
- " :edit edit last module\n" ++
- " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
- " :help, :? display this list of commands\n" ++
- " :info [<name> ...] display information about the given names\n" ++
- " :kind <type> show the kind of <type>\n" ++
- " :load [*]<module> ... load module(s) and their dependents\n" ++
- " :main [<arguments> ...] run the main function with the given arguments\n" ++
- " :module [+/-] [*]<mod> ... set the context for expression evaluation\n" ++
- " :quit exit GHCi\n" ++
- " :reload reload the current module set\n" ++
- " :run function [<arguments> ...] run the function with the given arguments\n" ++
- " :type <expr> show the type of <expr>\n" ++
- " :undef <cmd> undefine user-defined command :<cmd>\n" ++
- " :!<command> run the shell command <command>\n" ++
- "\n" ++
- " -- Commands for debugging:\n" ++
- "\n" ++
- " :abandon at a breakpoint, abandon current computation\n" ++
- " :back go back in the history (after :trace)\n" ++
- " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
- " :break <name> set a breakpoint on the specified function\n" ++
- " :continue resume after a breakpoint\n" ++
- " :delete <number> delete the specified breakpoint\n" ++
- " :delete * delete all breakpoints\n" ++
- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
- " :forward go forward in the history (after :back)\n" ++
- " :history [<n>] after :trace, show the execution history\n" ++
- " :list show the source code around current breakpoint\n" ++
- " :list identifier show the source code for <identifier>\n" ++
- " :list [<module>] <line> show the source code around line number <line>\n" ++
- " :print [<name> ...] prints a value without forcing its computation\n" ++
- " :sprint [<name> ...] simplifed version of :print\n" ++
- " :step single-step after stopping at a breakpoint\n"++
- " :step <expr> single-step into <expr>\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 <expr> evaluate <expr> with tracing on (see :history)\n"++
- "\n" ++
- " -- Commands for changing settings:\n" ++
- "\n" ++
- " :set <option> ... set options\n" ++
- " :set args <arg> ... set the arguments returned by System.getArgs\n" ++
- " :set prog <progname> set the value returned by System.getProgName\n" ++
- " :set prompt <prompt> set the prompt used in GHCi\n" ++
- " :set editor <cmd> set the command used for :edit\n" ++
- " :set stop [<n>] <cmd> set the command to run when a breakpoint is hit\n" ++
- " :unset <option> ... unset options\n" ++
- "\n" ++
- " Options for ':set' and ':unset':\n" ++
- "\n" ++
- " +r revert top-level expressions after each evaluation\n" ++
- " +s print timing/memory stats after each evaluation\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 bindings show the current bindings made at the prompt\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 value of <setting>, which is one of\n" ++
- " [args, prog, prompt, editor, stop]\n" ++
- "\n"
- findEditor :: IO String
- findEditor = do
- getEnv "EDITOR"
- `IO.catch` \_ -> do
- #if mingw32_HOST_OS
- win <- System.Win32.getWindowsDirectory
- return (win </> "notepad.exe")
- #else
- return ""
- #endif
- interactiveUI :: [(FilePath, Maybe Phase)] -> Maybe [String]
- -> Ghc ()
- interactiveUI srcs maybe_exprs = withTerminalReset $ 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
- -- detect that it is unreachable and send it the NonTermination
- -- exception. However, since the thread is unreachable, everything
- -- it refers to might be finalized, including the standard Handles.
- -- This sounds like a bug, but we don't have a good solution right
- -- now.
- liftIO $ newStablePtr stdin
- liftIO $ newStablePtr stdout
- liftIO $ newStablePtr stderr
- -- Initialise buffering for the *interpreted* I/O system
- initInterpBuffering
- liftIO $ when (isNothing maybe_exprs) $ do
- -- Only for GHCi (not runghc and ghc -e):
- -- Turn buffering off for the compiled program's stdout/stderr
- turnOffBuffering
- -- Turn buffering off for GHCi's stdout
- hFlush stdout
- hSetBuffering stdout NoBuffering
- -- We don't want the cmd line to buffer any input that might be
- -- intended for the program, so unbuffer stdin.
- hSetBuffering stdin NoBuffering
- #ifdef USE_EDITLINE
- is_tty <- hIsTerminalDevice stdin
- when is_tty $ withReadline $ 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 (GHC.mkModuleName "Prelude") Nothing
- GHC.setContext [] [prel_mod]
- default_editor <- liftIO $ findEditor
- startGHCi (runGHCi srcs maybe_exprs)
- GHCiState{ progname = "<interactive>",
- args = [],
- prompt = "%s> ",
- stop = "",
- editor = default_editor,
- -- session = session,
- options = [],
- prelude = prel_mod,
- break_ctr = 0,
- breaks = [],
- tickarrays = emptyModuleEnv,
- last_command = Nothing,
- cmdqueue = [],
- remembered_ctx = [],
- ghc_e = isJust maybe_exprs
- }
- #ifdef USE_EDITLINE
- liftIO $ do
- Readline.stifleHistory 100
- withGhcAppData (\dir -> Readline.writeHistory (dir </> "ghci_history"))
- (return True)
- Readline.resetTerminal Nothing
- #endif
- return ()
- 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
- -- libedit doesn't always restore the terminal settings correctly (as of at
- -- least 07/12/2008); see trac #2691. Work around this by manually resetting
- -- the terminal outselves.
- withTerminalReset :: Ghc () -> Ghc ()
- #ifdef mingw32_HOST_OS
- withTerminalReset = id
- #else
- withTerminalReset f = do
- isTTY <- liftIO $ hIsTerminalDevice stdout
- if not isTTY
- then f
- else gbracket (liftIO $ getTerminalAttributes stdOutput)
- (\attrs -> liftIO $ setTerminalAttributes stdOutput attrs Immediately)
- (const f)
- #endif
- 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 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
- 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_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.
- is_tty <- io (hIsTerminalDevice stdin)
- dflags <- getDynFlags
- let show_prompt = verbosity dflags > 0 || is_tty
- case maybe_exprs of
- Nothing ->
- do
- #if defined(mingw32_HOST_OS)
- -- The win32 Console API mutates the first character of
- -- type-ahead when reading from it in a non-buffered manner. Work
- -- around this by flushing the input buffer of type-ahead characters,
- -- but only if stdin is available.
- flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
- case flushed of
- Left err | isDoesNotExistError err -> return ()
- | otherwise -> io (ioError err)
- Right () -> return ()
- #endif
- -- enter the interactive loop
- interactiveLoop is_tty show_prompt
- Just exprs -> do
- -- just evaluate the expression we were given
- enqueueCommands exprs
- let handle e = do st <- getGHCiState
- -- Jump through some hoops to get the
- -- current progname in the exception text:
- -- <progname>: <exception>
- 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
- ghciHandleGhcException (\e -> case e of
- Interrupted -> do
- #if defined(mingw32_HOST_OS)
- io (putStrLn "")
- #endif
- interactiveLoop is_tty show_prompt
- _other -> return ()) $
- ghciUnblock $ do -- unblock necessary if we recursed from the
- -- exception handler above.
- -- read commands from stdin
- #ifdef USE_EDITLINE
- if (is_tty)
- then runCommands readlineLoop
- else runCommands (fileLoop stdin show_prompt is_tty)
- #else
- runCommands (fileLoop stdin show_prompt is_tty)
- #endif
- -- NOTE: We only read .ghci files if they are owned by the current user,
- -- and aren't world writable. Otherwise, we could be accidentally
- -- running code planted by a malicious third party.
- -- Furthermore, We only read ./.ghci if . is owned by the current user
- -- and isn't writable by anyone else. I think this is sufficient: we
- -- don't need to check .. and ../.. etc. because "." always refers to
- -- the same directory while a process is running.
- checkPerms :: String -> IO Bool
- #ifdef mingw32_HOST_OS
- checkPerms _ =
- return True
- #else
- checkPerms name =
- handleIO (\_ -> return False) $ do
- st <- getFileStatus name
- me <- getRealUserID
- if fileOwner st /= me then do
- putStrLn $ "WARNING: " ++ name ++ " is owned by someone else, IGNORING!"
- return False
- else do
- let mode = fileMode st
- if (groupWriteMode == (mode `intersectFileModes` groupWriteMode))
- || (otherWriteMode == (mode `intersectFileModes` otherWriteMode))
- then do
- putStrLn $ "*** WARNING: " ++ name ++
- " is writable by someone else, IGNORING!"
- return False
- else return True
- #endif
- 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 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
- (toplevs,exports) <- GHC.getContext
- resumes <- GHC.getResumeContext
- -- st <- getGHCiState
- context_bit <-
- case resumes of
- [] -> return empty
- r:_ -> do
- let ix = GHC.resumeHistoryIx r
- if ix == 0
- then return (brackets (ppr (GHC.resumeSpan r)) <> space)
- else do
- let hist = GHC.resumeHistory r !! (ix-1)
- span <- GHC.getHistorySpan hist
- return (brackets (ppr (negate ix) <> char ':'
- <+> ppr span) <> space)
- let
- dots | _:rs <- resumes, not (null rs) = text "... "
- | otherwise = empty
-
- modules_bit =
- -- 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
- f ('%':'s':xs) = deflt_prompt <> f xs
- f ('%':'%':xs) = char '%' <> f xs
- f (x:xs) = char x <> f xs
- f [] = empty
- --
- st <- getGHCiState
- return (showSDoc (f (prompt st)))
- #ifdef USE_EDITLINE
- readlineLoop :: GHCi (Maybe String)
- readlineLoop = do
- io yield
- saveSession -- for use by completion
- prompt <- mkPrompt
- l <- io $ withReadline (readline prompt)
- 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
- return (Just str)
- withReadline :: IO a -> IO a
- withReadline = bracket_ stopTimer startTimer
- -- editline doesn't handle some of its system calls returning
- -- EINTR, so our timer signal confuses it, hence we turn off
- -- the timer signal when making calls to editline. (#2277)
- -- If editline is ever fixed, we can remove this.
- -- These come from the RTS
- foreign import ccall unsafe startTimer :: IO ()
- foreign import ccall unsafe stopTimer :: IO ()
- #endif
- 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 = runCommands' handler
- runCommands' :: (SomeException -> 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 eh $
- handleSourceError printErrorAndKeepGoing
- (doCommand c)
- if b then return () else runCommands' eh getCmd
- where
- printErrorAndKeepGoing err = do
- GHC.printExceptionAndWarnings err
- 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
- st <- getGHCiState
- setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
- runStmt :: String -> SingleStep -> GHCi Bool
- runStmt stmt step
- | null (filter (not.isSpace) stmt) = return False
- | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
- | otherwise
- = 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
- afterRunStmt _ (GHC.RunException e) = throw e
- afterRunStmt step_here run_result = do
- resumes <- GHC.getResumeContext
- case run_result of
- GHC.RunOk names -> do
- show_types <- isOptionSet ShowType
- when show_types $ printTypeOfNames names
- GHC.RunBreak _ names mb_info
- | isNothing mb_info ||
- step_here (GHC.resumeSpan $ head resumes) -> do
- mb_id_loc <- toBreakIdAndLocation mb_info
- let breakCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
- if (null breakCmd)
- then printStoppedAtBreakInfo (head resumes) names
- else enqueueCommands [breakCmd]
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- enqueueCommands [stop st]
- return ()
- | otherwise -> resume step_here GHC.SingleStep >>=
- afterRunStmt step_here >> return ()
- _ -> return ()
- flushInterpBuffers
- io installSignalHandlers
- b <- isOptionSet RevertCAFs
- when b revertCAFs
- return (case run_result of GHC.RunOk _ -> True; _ -> False)
- toBreakIdAndLocation ::
- Maybe GHC.BreakInfo -> GHCi (Maybe (Int, BreakLocation))
- toBreakIdAndLocation Nothing = return Nothing
- toBreakIdAndLocation (Just info) = do
- let mod = GHC.breakInfo_module info
- nm = GHC.breakInfo_number info
- st <- getGHCiState
- return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
- breakModule loc == mod,
- breakTick loc == nm ]
- printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
- printStoppedAtBreakInfo resume names = do
- printForUser $ ptext (sLit "Stopped at") <+>
- ppr (GHC.resumeSpan resume)
- -- printTypeOfNames session names
- let namesSorted = sortBy compareNames names
- tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
- docs <- pprTypeAndContents [id | AnId id <- tythings]
- printForUserPartWay docs
- printTypeOfNames :: [Name] -> GHCi ()
- printTypeOfNames names
- = mapM_ (printTypeOfName ) $ sortBy compareNames names
- compareNames :: Name -> Name -> Ordering
- n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
- where compareWith n = (getOccString n, getSrcSpan n)
- printTypeOfName :: Name -> GHCi ()
- printTypeOfName n
- = do maybe_tything <- GHC.lookupName n
- case maybe_tything of
- 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 <- lookupCommand cmd
- case maybe_cmd of
- 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
- 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
- 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
- resumes <- GHC.getResumeContext
- case resumes of
- [] -> return Nothing
- (r:_) -> do
- let ix = GHC.resumeHistoryIx r
- if ix == 0
- then return (Just (GHC.resumeSpan r))
- else do
- let hist = GHC.resumeHistory r !! (ix-1)
- span <- GHC.getHistorySpan hist
- return (Just span)
- getCurrentBreakModule :: GHCi (Maybe Module)
- getCurrentBreakModule = do
- resumes <- GHC.getResumeContext
- case resumes of
- [] -> return Nothing
- (r:_) -> do
- let ix = GHC.resumeHistoryIx r
- if ix == 0
- then return (GHC.breakInfo_module `liftM` GHC.resumeBreakInfo r)
- else do
- let hist = GHC.resumeHistory r !! (ix-1)
- return $ Just $ GHC.getHistoryModule hist
- -----------------------------------------------------------------------------
- -- Commands
- noArgs :: GHCi () -> String -> GHCi ()
- noArgs m "" = m
- noArgs _ _ = io $ putStrLn "This command takes no arguments"
- help :: String -> GHCi ()
- help _ = io (putStr helpText)
- info :: String -> GHCi ()
- info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
- info s = handleSourceError GHC.printExceptionAndWarnings $ do
- { let names = words s
- ; dflags <- getDynFlags
- ; let pefas = dopt Opt_PrintExplicitForalls dflags
- ; mapM_ (infoThing pefas) names }
- where
- infoThing pefas str = do
- names <- GHC.parseName str
- mb_stuffs <- mapM GHC.getInfo names
- let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
- unqual <- GHC.getPrintUnqual
- liftIO $
- putStrLn (showSDocForUser unqual $
- vcat (intersperse (text "") $
- map (pprInfo pefas) filtered))
- -- Filter out names whose parent is also there Good
- -- example is '[]', which is both a type and data
- -- constructor in the same type
- filterOutChildren :: (a -> TyThing) -> [a] -> [a]
- filterOutChildren get_thing xs
- = [x | x <- xs, not (getName (get_thing x) `elemNameSet` implicits)]
- where
- implicits = mkNameSet [getName t | x <- xs, t <- implicitTyThings (get_thing x)]
- pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
- pprInfo pefas (thing, fixity, insts)
- = pprTyThingInContextLoc pefas thing
- $$ show_fixity fixity
- $$ vcat (map GHC.pprInstance insts)
- where
- show_fixity fix
- | fix == GHC.defaultFixity = empty
- | otherwise = ppr fix <+> ppr (GHC.getName thing)
- runMain :: String -> GHCi ()
- 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
- revertCAFs -- always revert CAFs on load/add.
- files <- mapM expandPath files
- targets <- mapM (\m -> GHC.guessTarget m Nothing) files
- -- remove old targets with the same id; e.g. for :add *M
- mapM_ GHC.removeTarget [ tid | Target tid _ _ <- targets ]
- mapM_ GHC.addTarget targets
- prev_context <- GHC.getContext
- ok <- trySuccess $ GHC.load LoadAllTargets
- afterLoad ok 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
- graph <- GHC.getModuleGraph
- 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 <- GHC.getContext
- GHC.setTargets []
- GHC.load LoadAllTargets
- setContextAfterLoad prev_context False []
- GHC.workingDirectoryChanged
- dir <- expandPath dir
- io (setCurrentDirectory dir)
- trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
- trySuccess act =
- handleSourceError (\e -> do GHC.printExceptionAndWarnings e
- return Failed) $ do
- act
- editFile :: String -> GHCi ()
- editFile str =
- do file <- if null str then chooseEditFile else return str
- st <- getGHCiState
- let cmd = editor st
- when (null cmd)
- $ ghcError (CmdLineError "editor not set, use :set editor")
- io $ system (cmd ++ ' ':file)
- return ()
- -- The user didn't specify a file so we pick one for them.
- -- Our strategy is to pick the first module that failed to load,
- -- or otherwise the first target.
- --
- -- XXX: Can we figure out what happened if the depndecy analysis fails
- -- (e.g., because the porgrammeer mistyped the name of a module)?
- -- XXX: Can we figure out the location of an error to pass to the editor?
- -- XXX: if we could figure out the list of errors that occured during the
- -- last load/reaload, then we could start the editor focused on the first
- -- of those.
- chooseEditFile :: GHCi String
- chooseEditFile =
- do let hasFailed x = fmap not $ GHC.isLoaded $ GHC.ms_mod_name x
- graph <- GHC.getModuleGraph
- failed_graph <- filterM hasFailed graph
- let order g = flattenSCCs $ GHC.topSortModuleGraph True g Nothing
- pick xs = case xs of
- x : _ -> GHC.ml_hs_file (GHC.ms_location x)
- _ -> Nothing
- case pick (order failed_graph) of
- Just file -> return file
- Nothing ->
- do targets <- GHC.getTargets
- case msum (map fromTarget targets) of
- Just file -> return file
- Nothing -> ghcError (CmdLineError "No files to edit.")
-
- where fromTarget (GHC.Target (GHC.TargetFile f _) _ _) = Just f
- fromTarget _ = Nothing -- when would we get a module target?
- defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
- defineMacro overwrite s = do
- let (macro_name, definition) = break isSpace s
- macros <- io (readIORef macros_ref)
- let defined = map cmdName macros
- if (null 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 (not overwrite && macro_name `elem` defined)
- then ghcError (CmdLineError
- ("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"
- -- compile the expression
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
- hv <- GHC.compileExpr new_expr
- io (writeIORef macros_ref --
- (filtered ++ [(macro_name, runMacro hv, Nothing, completeNone)]))
- runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
- runMacro fun s = do
- str <- io ((unsafeCoerce# fun :: String -> IO String) s)
- -- make sure we force any exceptions in the result, while we are still
- -- inside the exception handler for commands:
- seqList str (return ())
- enqueueCommands (lines str)
- return False
- undefineMacro :: String -> GHCi ()
- undefineMacro str = mapM_ undef (words str)
- where undef macro_name = do
- cmds <- io (readIORef macros_ref)
- if (macro_name `notElem` map cmdName cmds)
- then ghcError (CmdLineError
- ("macro '" ++ macro_name ++ "' is not defined"))
- else do
- io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
- cmdCmd :: String -> GHCi ()
- cmdCmd str = do
- let expr = '(' : str ++ ") :: IO String"
- handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
- hv <- GHC.compileExpr expr
- cmds <- io $ (unsafeCoerce# hv :: IO String)
- enqueueCommands (lines cmds)
- return ()
- loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
- loadModule fs = timeIt (loadModule' fs)
- loadModule_ :: [FilePath] -> GHCi ()
- loadModule_ fs = do loadModule (zip fs (repeat Nothing)); return ()
- loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
- loadModule' files = do
- prev_context <- GHC.getContext
- -- unload first
- GHC.abandonAll
- discardActiveBreakPoints
- GHC.setTargets []
- GHC.load LoadAllTargets
- -- expand tildes
- let (filenames, phases) = unzip files
- exp_filenames <- mapM expandPath filenames
- let files' = zip exp_filenames phases
- targets <- mapM (uncurry GHC.guessTarget) files'
- -- NOTE: we used to do the dependency anal first, so that if it
- -- fails we didn't throw away the current set of modules. This would
- -- require some re-working of the GHC interface, so we'll leave it
- -- as a ToDo for now.
- GHC.setTargets targets
- doLoad False prev_context LoadAllTargets
- checkModule :: String -> GHCi ()
- checkModule m = do
- let modl = GHC.mkModuleName m
- prev_context <- GHC.getContext
- ok <- handleSourceError (\e -> GHC.printExceptionAndWarnings e >> return False) $ do
- r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
- io $ putStrLn (showSDoc (
- case GHC.moduleInfo r of
- cm | Just scope <- GHC.modInfoTopLevelScope cm ->
- let
- (local,global) = ASSERT( all isExternalName scope )
- partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
- in
- (text "global names: " <+> ppr global) $$
- (text "local names: " <+> ppr local)
- _ -> empty))
- return True
- afterLoad (successIf ok) False prev_context
- reloadModule :: String -> GHCi ()
- reloadModule m = do
- prev_context <- GHC.getContext
- doLoad True prev_context $
- if null m then LoadAllTargets
- else LoadUpTo (GHC.mkModuleName m)
- return ()
- doLoad :: Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
- doLoad 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 <- trySuccess $ GHC.load howmuch
- afterLoad ok retain_context prev_context
- return ok
- afterLoad :: SuccessFlag -> Bool -> ([Module],[Module]) -> GHCi ()
- afterLoad ok retain_context prev_context = do
- revertCAFs -- always revert CAFs on load.
- discardTickArrays
- loaded_mod_summaries <- getLoadedModules
- let loaded_mods = map GHC.ms_mod loaded_mod_summaries
- loaded_mod_names = map GHC.moduleName loaded_mods
- modulesLoadedMsg ok loaded_mod_names
- setContextAfterLoad prev_context retain_context loaded_mod_summaries
- setContextAfterLoad :: ([Module],[Module]) -> Bool -> [GHC.ModSummary] -> GHCi ()
- setContextAfterLoad prev keep_ctxt [] = do
- prel_mod <- getPrelude
- setContextKeepingPackageModules prev keep_ctxt ([], [prel_mod])
- setContextAfterLoad prev keep_ctxt ms = do
- -- load a target if one is available, otherwise load the topmost module.
- targets <- GHC.getTargets
- case [ m | Just m <- map (findTarget ms) targets ] of
- [] ->
- let graph' = flattenSCCs (GHC.topSortModuleGraph True ms Nothing) in
- load_this (last graph')
- (m:_) ->
- load_this m
- where
- findTarget ms t
- = case filter (`matches` t) ms of
- [] -> Nothing
- (m:_) -> Just m
- summary `matches` Target (TargetModule m) _ _
- = GHC.ms_mod_name summary == m
- summary `matches` Target (TargetFile f _) _ _
- | Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
- _ `matches` _
- = False
- load_this summary | m <- GHC.ms_mod summary = do
- b <- GHC.moduleIsInterpreted m
- if b then setContextKeepingPackageModules prev keep_ctxt ([m], [])
- else do
- prel_mod <- getPrelude
- setContextKeepingPackageModules prev keep_ctxt ([],[prel_mod,m])
- -- | Keep any package modules (except Prelude) when changing the context.
- setContextKeepingPackageModules
- :: ([Module],[Module]) -- previous context
- -> Bool -- re-execute :module commands
- -> ([Module],[Module]) -- new context
- -> GHCi ()
- setContextKeepingPackageModules 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
- GHC.setContext 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
- modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
- modulesLoadedMsg ok mods = do
- dflags <- getDynFlags
- when (verbosity dflags > 0) $ do
- let mod_commas
- | null mods = text "none."
- | otherwise = hsep (
- punctuate comma (map ppr mods)) <> text "."
- case ok of
- Failed ->
- io (putStrLn (showSDoc (text "Failed, modules loaded: " <> mod_commas)))
- Succeeded ->
- io (putStrLn (showSDoc (text "Ok, modules loaded: " <> mod_commas)))
- goalsCmd :: String -> GHCi ()
- goalsCmd s
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
- let strs = words s
- dflags <- getDynFlags
- let pefas = dopt Opt_PrintExplicitForalls dflags
- case strs of
- [] -> contextAll dflags ["undefined"]
- _ -> contextAll dflags strs
- where
- contextAll dflags strs = do
- mods <- getLoadedModules
- case mods of
- [] -> io (putStrLn (showSDoc (text "Failed, no loaded modules to query for goals.")))
- mod:_ ->
- do prev_context <- GHC.getContext
- r <- GHC.typecheckModule =<< GHC.parseModule mod
- let types = goalsFor r strs
- pefas = dopt Opt_PrintExplicitForalls dflags
- mapM_ (\(n, s, ts) -> printForUser $ sep [text n, nest 2 (dcolon <+> pprTypeSpecForUser pefas ts), text " -- Used in", ppr s]) types
- pprTypeSpecForUser pefas (ts, ty) =
- (if null ts
- then empty
- else parens (pprWithCommas (pprTypeForUser pefas) ts) <+> text "=>")
- <+> pprTypeForUser pefas ty
- typeOfExpr :: String -> GHCi ()
- typeOfExpr str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
- ty <- GHC.exprType str
- dflags <- getDynFlags
- let pefas = dopt Opt_PrintExplicitForalls dflags
- printForUser $ sep [utext str, nest 2 (dcolon <+> pprTypeForUser pefas ty)]
- kindOfType :: String -> GHCi ()
- kindOfType str
- = handleSourceError (\e -> GHC.printExceptionAndWarnings e) $ do
- ty <- GHC.typeKind str
- printForUser $ utext str <+> dcolon <+> ppr ty
-
- -- HACK for printing unicode text. We assume the output device
- -- understands UTF-8, and go via FastString which converts to UTF-8.
- -- ToDo: fix properly when we have encoding support in Handles.
- utext :: String -> SDoc
- utext str = ftext (mkFastString str)
- quit :: String -> GHCi Bool
- quit _ = return True
- shellEscape :: String -> GHCi Bool
- shellEscape str = io (system str >> return False)
- -----------------------------------------------------------------------------
- -- Browsing a module's contents
- browseCmd :: Bool -> String -> GHCi ()
- browseCmd bang m =
- case words m of
- ['*':s] | looksLikeModuleName s -> do
- m <- wantInterpretedModule s
- browseModule bang m False
- [s] | looksLikeModuleName s -> do
- m <- lookupModule s
- browseModule bang m True
- [] -> do
- (as,bs) <- GHC.getContext
- -- 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
- ([], []) -> ghcError (CmdLineError ":browse: no current module")
- _ -> ghcError (CmdLineError "syntax: :browse <module>")
- -- 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
- -- :browse! reports qualifiers wrt current context
- current_unqual <- GHC.getPrintUnqual
- -- Temporarily set the context to the module we're interested in,
- -- just so we can get an appropriate PrintUnqualified
- (as,bs) <- GHC.getContext
- prel_mod <- getPrelude
- if exports_only then GHC.setContext [] [prel_mod,modl]
- else GHC.setContext [modl] []
- target_unqual <- GHC.getPrintUnqual
- GHC.setContext as bs
- let unqual = if bang then current_unqual else target_unqual
- mb_mod_info <- GHC.getModuleInfo modl
- case mb_mod_info of
- Nothing -> ghcError (CmdLineError ("unknown module: " ++
- GHC.moduleNameString (GHC.moduleName modl)))
- Just mod_info -> do
- dflags <- getDynFlags
- 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) = ASSERT( all isExternalName names )
- 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 <- mapM GHC.lookupName sorted_names
- let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
- rdr_env <- GHC.getGRE
- 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
- setContext :: String -> GHCi ()
- setContext str
- | all sensible strs = do
- playCtxtCmd True (cmd, as, bs)
- st <- getGHCiState
- setGHCiState st{ remembered_ctx = remembered_ctx st ++ [(cmd,as,bs)] }
- | otherwise = ghcError (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
- where
- (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
- starred ('*':m) = Left m
- starred m = Right m
- playCtxtCmd :: Bool -> (CtxtCmd, [String], [String]) -> GHCi ()
- playCtxtCmd fail (cmd, as, bs)
- = do
- (as',bs') <- do_checks fail
- (prev_as,prev_bs) <- GHC.getContext
- (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)
- GHC.setContext 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'
- -- set options in the interpreter. Syntax is exactly the same as the
- -- ghc command line, except that certain options aren't available (-C,
- -- -E etc.)
- --
- -- This is pretty fragile: most options won't work as expected. ToDo:
- -- figure out which ones & disallow them.
- setCmd :: String -> GHCi ()
- setCmd ""
- = do st <- getGHCiState
- let opts = options st
- io $ putStrLn (showSDoc (
- text "options currently set: " <>
- if null opts
- 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 = filterOut (\(_, f, _) -> f `elem` languageOptions)
- others
- flags = [Opt_PrintExplicitForalls
- ,Opt_PrintBindResult
- ,Opt_BreakOnException
- ,Opt_BreakOnError
- ,Opt_PrintEvldWithShow
- ]
- setCmd str
- = 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 <progname>")
- 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
- st <- getGHCiState
- setGHCiState st{ progname = prog }
- setEditor cmd = do
- st <- getGHCiState
- setGHCiState st{ editor = cmd }
- setStop str@(c:_) | isDigit c
- = do let (nm_str,rest) = break (not.isDigit) str
- nm = read nm_str
- st <- getGHCiState
- let old_breaks = breaks st
- if all ((/= nm) . fst) old_breaks
- then printForUser (text "Breakpoint" <+> ppr nm <+>
- text "does not exist")
- else do
- let new_breaks = map fn old_breaks
- fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
- | otherwise = (i,loc)
- setGHCiState st{ breaks = new_breaks }
- setStop cmd = do
- st <- getGHCiState
- setGHCiState st{ stop = cmd }
- setPrompt value = do
- st <- getGHCiState
- if null value
- then io $ hPutStrLn stderr $ "syntax: :set prompt <prompt>, currently \"" ++ prompt st ++ "\""
- else case value of
- '\"' : _ -> case reads value of
- [(value', xs)] | all isSpace xs ->
- setGHCiState (st { prompt = value' })
- _ ->
- io $ hPutStrLn stderr "Can't parse prompt string. Use Haskell syntax."
- _ -> setGHCiState (st { prompt = value })
- setOptions wds =
- do -- first, deal with the GHCi opts (+s, +t, etc.)
- let (plus_opts, minus_opts) = partitionWith isPlus wds
- mapM_ setOpt plus_opts
- -- then, dynamic flags
- newDynFlags minus_opts
- newDynFlags :: [String] -> GHCi ()
- newDynFlags minus_opts = do
- dflags <- getDynFlags
- let pkg_flags = packageFlags dflags
- (dflags', leftovers, warns) <- io $ GHC.parseDynamicFlags dflags $ map noLoc minus_opts
- handleFlagWarnings dflags' warns
- if (not (null leftovers))
- then ghcError $ errorsToGhcException leftovers
- else return ()
- new_pkgs <- setDynFlags dflags'
- -- if the package flags changed, we should reset the context
- -- and link the new packages.
- dflags <- getDynFlags
- when (packageFlags dflags /= pkg_flags) $ do
- io $ hPutStrLn stderr "package flags have changed, resetting and loading new packages..."
- GHC.setTargets []
- GHC.load LoadAllTargets
- io (linkPackages dflags new_pkgs)
- -- package flags changed, we can't re-use any of the old context
- setContextAfterLoad ([],[]) False []
- return ()
- unsetOptions :: String -> GHCi ()
- unsetOptions str
- = do -- first, deal with the GHCi opts (+s, +t, etc.)
- let opts = words str
- (minus_opts, rest1) = partition isMinus opts
- (plus_opts, rest2) = partitionWith isPlus rest1
- if (not (null rest2))
- then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
- else do
- mapM_ unsetOpt plus_opts
-
- let no_flag ('-':'f':rest) = return ("-fno-" ++ rest)
- no_flag f = ghcError (ProgramError ("don't know how to reverse " ++ f))
- no_flags <- mapM no_flag minus_opts
- newDynFlags no_flags
- isMinus :: String -> Bool
- isMinus ('-':_) = True
- isMinus _ = False
- isPlus :: String -> Either String String
- isPlus ('+':opt) = Left opt
- isPlus other = Right other
- setOpt, unsetOpt :: String -> GHCi ()
- setOpt str
- = case strToGHCiOpt str of
- Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
- Just o -> setOption o
- unsetOpt str
- = case strToGHCiOpt str of
- Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
- Just o -> unsetOption o
- strToGHCiOpt :: String -> (Maybe GHCiOption)
- strToGHCiOpt "s" = Just ShowTiming
- strToGHCiOpt "t" = Just ShowType
- strToGHCiOpt "r" = Just RevertCAFs
- strToGHCiOpt _ = Nothing
- optToStr :: GHCiOption -> String
- optToStr ShowTiming = "s"
- optToStr ShowType = "t"
- optToStr RevertCAFs = "r"
- -- ---------------------------------------------------------------------------
- -- code for `:show'
- showCmd :: String -> GHCi ()
- showCmd str = do
- st <- getGHCiState
- case words str of
- ["args"] -> io $ putStrLn (show (args st))
- ["prog"] -> io $ putStrLn (show (progname st))
- ["prompt"] -> io $ putStrLn (show (prompt st))
- ["editor"] -> io $ putStrLn (show (editor st))
- ["stop"] -> io $ putStrLn (show (stop st))
- ["modules" ] -> showModules
- ["bindings"] -> showBindings
- ["linker"] -> io showLinkerState
- ["breaks"] -> showBkptTable
- ["context"] -> showContext
- ["packages"] -> showPackages
- ["languages"] -> showLanguages
- _ -> ghcError (CmdLineError ("syntax: :show [ args | prog | prompt | editor | stop | modules | bindings\n"++
- " | breaks | context | packages | languages ]"))
- showModules :: GHCi ()
- showModules = do
- loaded_mods <- getLoadedModules
- -- we want *loaded* modules only, see #1734
- let show_one ms = do m <- GHC.showModule ms; io (putStrLn m)
- mapM_ show_one loaded_mods
- getLoadedModules :: GHCi [GHC.ModSummary]
- getLoadedModules = do
- graph <- GHC.getModuleGraph
- filterM (GHC.isLoaded . GHC.ms_mod_name) graph
- showBindings :: GHCi ()
- showBindings = do
- bindings <- GHC.getBindings
- docs <- pprTypeAndContents
- [ id | AnId id <- sortBy compareTyThings bindings]
- printForUserPartWay docs
- compareTyThings :: TyThing -> TyThing -> Ordering
- t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
- printTyThing :: TyThing -> GHCi ()
- printTyThing tyth = do dflags <- getDynFlags
- let pefas = dopt Opt_PrintExplicitForalls dflags
- printForUser (pprTyThing pefas tyth)
- showBkptTable :: GHCi ()
- showBkptTable = do
- st <- getGHCiState
- printForUser $ prettyLocations (breaks st)
- showContext :: GHCi ()
- showContext = do
- resumes <- GHC.getResumeContext
- 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))
- 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)
- (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
- 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, completeShowOptions,
- completeFilename, completeHomeModuleOrFile
- :: String -> IO [String]
- #ifdef USE_EDITLINE
- completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
- completeWord w start end = do
- line <- Readline.getLineBuffer
- let line_words = words (dropWhile isSpace line)
- case w of
- ':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
- _other
- | ((':':c) : _) <- line_words -> do
- 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' 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 (e.g. -ddump-simpl) should
- -- only be a single word.
- selectWord [] = (0,w)
- 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
- cmds <- readIORef macros_ref
- return (filter (w `isPrefixOf`) (map (':':)
- (map cmdName (builtin_commands ++ cmds))))
- completeMacro w = do
- cmds <- readIORef macros_ref
- return (filter (w `isPrefixOf`) (map cmdName cmds))
- completeIdentifier w = do
- rdrs <- withRestoredSession GHC.getRdrNamesInScope
- return (filter (w `isPrefixOf`) (map (showSDoc.ppr) rdrs))
- completeModule w = do
- dflags <- withRestoredSession GHC.getSessionDynFlags
- let pkg_mods = allExposedModules dflags
- return (filter (w `isPrefixOf`) (map (showSDoc.ppr) pkg_mods))
- completeHomeModule w = do
- g <- withRestoredSession GHC.getModuleGraph
- let home_mods = map GHC.ms_mod_name g
- return (filter (w `isPrefixOf`) (map (showSDoc.ppr) home_mods))
- completeSetOptions w = do
- return (filter (w `isPrefixOf`) options)
- where options = "args":"prog":"prompt":"editor":"stop":flagList
- flagList = map head $ group $ sort allFlags
- completeShowOptions w = do
- return (filter (w `isPrefixOf`) options)
- where options = ["args", "prog", "prompt", "editor", "stop",
- "modules", "bindings", "linker", "breaks",
- "context", "packages", "languages"]
- 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
- unionComplete :: (String -> IO [String]) -> (String -> IO [String]) -> String -> IO [String]
- unionComplete f1 f2 w = do
- s1 <- f1 w
- s2 <- f2 w
- return (s1 ++ s2)
- wrapCompleter :: (String -> IO [String]) -> String -> IO (Maybe (String,[String]))
- wrapCompleter fun w = do
- strs <- fun w
- case strs of
- [] -> 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))
- getCommonPrefix :: [String] -> String
- getCommonPrefix [] = ""
- getCommonPrefix (s:ss) = foldl common s ss
- where common _s "" = ""
- common "" _s = ""
- common (c:cs) (d:ds)
- | c == d = c : common cs ds
- | otherwise = ""
- allExposedModules :: DynFlags -> [ModuleName]
- allExposedModules dflags
- = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
- where
- pkg_db = pkgIdMap (pkgState dflags)
- #else
- completeMacro = completeNone
- completeIdentifier = completeNone
- completeModule = completeNone
- completeHomeModule = completeNone
- completeSetOptions = completeNone
- completeShowOptions = completeNone
- completeFilename = completeNone
- completeHomeModuleOrFile=completeNone
- #endif
- -- ---------------------------------------------------------------------------
- -- User code exception handling
- -- This is the exception handler for exceptions generated by the
- -- user's code and exceptions coming from children sessions;
- -- it normally just prints out the exception. The
- -- handler must be recursive, in case showing the exception causes
- -- more exceptions to be raised.
- --
- -- Bugfix: if the user closed stdout or stderr, the flushing will fail,
- -- raising another exception. We therefore don't put the recursive
- -- handler arond the flushing operation, so if stderr is closed
- -- GHCi will just die gracefully rather than going into an infinite loop.
- handler :: SomeException -> GHCi Bool
- handler exception = do
- flushInterpBuffers
- io installSignalHandlers
- ghciHandle handler (showException exception >> return False)
- showException :: SomeException -> GHCi ()
- showException se =
- io $ case fromException se of
- Just Interrupted -> putStrLn "Interrupted."
- -- omit the location for CmdLineError:
- Just (CmdLineError s) -> putStrLn s
- -- ditto:
- Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
- Just other_ghc_ex -> print other_ghc_ex
- Nothing -> putStrLn ("*** Exception: " ++ show se)
- -----------------------------------------------------------------------------
- -- recursive exception handlers
- -- Don't forget to unblock async exceptions in the handler, or if we're
- -- in an exception loop (eg. let a = error a in a) the ^C exception
- -- may never be delivered. Thanks to Marcin for pointing out the bug.
- ghciHandle :: (SomeException -> GHCi a) -> GHCi a -> GHCi a
- ghciHandle h (GHCi m) = GHCi $ \s ->
- gcatch (m s)
- (\e -> unGHCi (ghciUnblock (h e)) s)
- ghciUnblock :: GHCi a -> GHCi a
- ghciUnblock (GHCi a) =
- GHCi $ \s -> reifyGhc $ \gs ->
- Exception.unblock (reflectGhc (a s) gs)
- ghciTry :: GHCi a -> GHCi (Either SomeException a)
- ghciTry (GHCi m) = GHCi $ \s -> gtry (m s)
- -- ----------------------------------------------------------------------------
- -- Utils
- expandPath :: String -> GHCi String
- expandPath path = io (expandPathIO path)
- expandPathIO :: String -> IO String
- expandPathIO path =
- case dropWhile isSpace path of
- ('~':d) -> do
- tilde <- getHomeDirectory -- will fail if HOME not defined
- return (tilde ++ '/':d)
- other ->
- return other
- wantInterpretedModule :: String -> GHCi Module
- wantInterpretedModule str = do
- modl <- lookupModule str
- dflags <- getDynFlags
- when (GHC.modulePackageId modl /= thisPackage dflags) $
- ghcError (CmdLineError ("module '" ++ str ++ "' is from another package;\nthis command requires an interpreted module"))
- is_interpreted <- GHC.moduleIsInterpreted modl
- when (not is_interpreted) $
- ghcError (CmdLineError ("module '" ++ str ++ "' is not interpreted; try \':add *" ++ str ++ "' first"))
- return modl
- wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
- -> (Name -> GHCi ())
- -> GHCi ()
- wantNameFromInterpretedModule noCanDo str and_then =
- handleSourceError (GHC.printExceptionAndWarnings) $ do
- names <- GHC.parseName str
- case names of
- [] -> return ()
- (n:_) -> do
- let modl = ASSERT( isExternalName n ) GHC.nameModule n
- if not (GHC.isExternalName n)
- then noCanDo n $ ppr n <>
- text " is not defined in an interpreted module"
- else do
- is_interpreted <- GHC.moduleIsInterpreted modl
- if not is_interpreted
- then noCanDo n $ text "module " <> ppr modl <>
- text " is not interpreted"
- else and_then n
- -- -----------------------------------------------------------------------------
- -- commands for debugger
- sprintCmd, printCmd, forceCmd :: String -> GHCi ()
- sprintCmd = pprintCommand False False
- printCmd = pprintCommand True False
- forceCmd = pprintCommand False True
- pprintCommand :: Bool -> Bool -> String -> GHCi ()
- pprintCommand bind force str = do
- pprintClosureCommand bind force str
- stepCmd :: String -> GHCi ()
- stepCmd [] = doContinue (const True) GHC.SingleStep
- stepCmd expression = do runStmt expression GHC.SingleStep; return ()
- stepLocalCmd :: String -> GHCi ()
- stepLocalCmd [] = do
- mb_span <- getCurrentBreakSpan
- case mb_span of
- Nothing -> stepCmd []
- Just loc -> do
- Just mod <- getCurrentBreakModule
- current_toplevel_decl <- enclosingTickSpan mod loc
- doContinue (`isSubspanOf` current_toplevel_decl) GHC.SingleStep
- stepLocalCmd expression = stepCmd expression
- stepModuleCmd :: String -> GHCi ()
- stepModuleCmd [] = do
- mb_span <- getCurrentBreakSpan
- case mb_span of
- Nothing -> stepCmd []
- Just _ -> do
- Just span <- getCurrentBreakSpan
- let f some_span = srcSpanFileName_maybe span == srcSpanFileName_maybe some_span
- doContinue f GHC.SingleStep
- stepModuleCmd expression = stepCmd expression
- -- | Returns the span of the largest tick containing the srcspan given
- enclosingTickSpan :: Module -> SrcSpan -> GHCi SrcSpan
- enclosingTickSpan mod src = do
- ticks <- getTickArray mod
- let line = srcSpanStartLine src
- ASSERT (inRange (bounds ticks) line) do
- let enclosing_spans = [ span | (_,span) <- ticks ! line
- , srcSpanEnd span >= srcSpanEnd src]
- return . head . sortBy leftmost_largest $ enclosing_spans
- traceCmd :: String -> GHCi ()
- traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
- traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
- continueCmd :: String -> GHCi ()
- continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
- -- doContinue :: SingleStep -> GHCi ()
- doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
- doContinue pred step = do
- runResult <- resume pred step
- afterRunStmt pred runResult
- return ()
- abandonCmd :: String -> GHCi ()
- abandonCmd = noArgs $ do
- b <- GHC.abandon -- the prompt will change to indicate the new context
- when (not b) $ io $ putStrLn "There is no computation running."
- return ()
- deleteCmd :: String -> GHCi ()
- deleteCmd argLine = do
- deleteSwitch $ words argLine
- where
- deleteSwitch :: [String] -> GHCi ()
- deleteSwitch [] =
- io $ putStrLn "The delete command requires at least one argument."
- -- delete all break points
- deleteSwitch ("*":_rest) = discardActiveBreakPoints
- deleteSwitch idents = do
- mapM_ deleteOneBreak idents
- where
- deleteOneBreak :: String -> GHCi ()
- deleteOneBreak str
- | all isDigit str = deleteBreak (read str)
- | otherwise = return ()
- historyCmd :: String -> GHCi ()
- historyCmd arg
- | null arg = history 20
- | all isDigit arg = history (read arg)
- | otherwise = io $ putStrLn "Syntax: :history [num]"
- where
- history num = do
- resumes <- GHC.getResumeContext
- case resumes of
- [] -> io $ putStrLn "Not stopped at a breakpoint"
- (r:_) -> do
- let hist = GHC.resumeHistory r
- (took,rest) = splitAt num hist
- case hist of
- [] -> io $ putStrLn $
- "Empty history. Perhaps you forgot to use :trace?"
- _ -> do
- spans <- mapM GHC.getHistorySpan 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
- | otherwise = c
- backCmd :: String -> GHCi ()
- backCmd = noArgs $ do
- (names, _, span) <- GHC.back
- printForUser $ ptext (sLit "Logged breakpoint at") <+> ppr span
- printTypeOfNames names
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- enqueueCommands [stop st]
- forwardCmd :: String -> GHCi ()
- forwardCmd = noArgs $ do
- (names, ix, span) <- GHC.forward
- printForUser $ (if (ix == 0)
- then ptext (sLit "Stopped at")
- else ptext (sLit "Logged breakpoint at")) <+> ppr span
- printTypeOfNames names
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- enqueueCommands [stop st]
- -- handle the "break" command
- breakCmd :: String -> GHCi ()
- breakCmd argLine = do
- breakSwitch $ words argLine
- breakSwitch :: [String] -> GHCi ()
- breakSwitch [] = do
- io $ putStrLn "The break command requires at least one argument."
- breakSwitch (arg1:rest)
- | looksLikeModuleName arg1 && not (null rest) = do
- mod <- wantInterpretedModule arg1
- breakByModule mod rest
- | all isDigit arg1 = do
- (toplevel, _) <- GHC.getContext
- case toplevel of
- (mod : _) -> breakByModuleLine mod (read arg1) rest
- [] -> do
- io $ putStrLn "Cannot find default module for breakpoint."
- io $ putStrLn "Perhaps no modules are loaded for debugging?"
- | otherwise = do -- try parsing it as an identifier
- wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
- let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
- if GHC.isGoodSrcLoc loc
- then ASSERT( isExternalName name )
- findBreakAndSet (GHC.nameModule name) $
- findBreakByCoord (Just (GHC.srcLocFile loc))
- (GHC.srcLocLine loc,
- GHC.srcLocCol loc)
- else noCanDo name $ text "can't find its location: " <> ppr loc
- where
- noCanDo n why = printForUser $
- text "cannot set breakpoint on " <> ppr n <> text ": " <> why
- breakByModule :: Module -> [String] -> GHCi ()
- breakByModule mod (arg1:rest)
- | all isDigit arg1 = do -- looks like a line number
- breakByModuleLine mod (read arg1) rest
- breakByModule _ _
- = breakSyntax
- breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
- breakByModuleLine mod line args
- | [] <- args = findBreakAndSet mod $ findBreakByLine line
- | [col] <- args, all isDigit col =
- findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
- | otherwise = breakSyntax
- breakSyntax :: a
- breakSyntax = ghcError (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
- findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
- findBreakAndSet mod lookupTickTree = do
- tickArray <- getTickArray mod
- (breakArray, _) <- getModBreak mod
- case lookupTickTree tickArray of
- Nothing -> io $ putStrLn $ "No breakpoints found at that location."
- Just (tick, span) -> do
- success <- io $ setBreakFlag True breakArray tick
- if success
- then do
- (alreadySet, nm) <-
- recordBreak $ BreakLocation
- { breakModule = mod
- , breakLoc = span
- , breakTick = tick
- , onBreakCmd = ""
- }
- printForUser $
- text "Breakpoint " <> ppr nm <>
- if alreadySet
- then text " was already set at " <> ppr span
- else text " activated at " <> ppr span
- else do
- printForUser $ text "Breakpoint could not be activated at"
- <+> ppr span
- -- When a line number is specified, the current policy for choosing
- -- the best breakpoint is this:
- -- - the leftmost complete subexpression on the specified line, or
- -- - the leftmost subexpression starting on the specified line, or
- -- - the rightmost subexpression enclosing the specified line
- --
- findBreakByLine :: Int -> TickArray -> Maybe (BreakIndex,SrcSpan)
- findBreakByLine line arr
- | not (inRange (bounds arr) line) = Nothing
- | otherwise =
- listToMaybe (sortBy (leftmost_largest `on` snd) complete) `mplus`
- listToMaybe (sortBy (leftmost_smallest `on` snd) incomplete) `mplus`
- listToMaybe (sortBy (rightmost `on` snd) ticks)
- where
- ticks = arr ! line
- starts_here = [ tick | tick@(_,span) <- ticks,
- GHC.srcSpanStartLine span == line ]
- (complete,incomplete) = partition ends_here starts_here
- where ends_here (_,span) = GHC.srcSpanEndLine span == line
- findBreakByCoord :: Maybe FastString -> (Int,Int) -> TickArray
- -> Maybe (BreakIndex,SrcSpan)
- findBreakByCoord mb_file (line, col) arr
- | not (inRange (bounds arr) line) = Nothing
- | otherwise =
- listToMaybe (sortBy (rightmost `on` snd) contains ++
- sortBy (leftmost_smallest `on` snd) after_here)
- where
- ticks = arr ! line
- -- the ticks that span this coordinate
- contains = [ tick | tick@(_,span) <- ticks, span `spans` (line,col),
- is_correct_file span ]
- is_correct_file span
- | Just f <- mb_file = GHC.srcSpanFile span == f
- | otherwise = True
- after_here = [ tick | tick@(_,span) <- ticks,
- GHC.srcSpanStartLine span == line,
- GHC.srcSpanStartCol span >= col ]
- -- For now, use ANSI bold on terminals that we know support it.
- -- Otherwise, we add a line of carets under the active expression instead.
- -- In particular, on Windows and when running the testsuite (which sets
- -- TERM to vt100 for other reasons) we get carets.
- -- We really ought to use a proper termcap/terminfo library.
- do_bold :: Bool
- do_bold = (`isPrefixOf` unsafePerformIO mTerm) `any` ["xterm", "linux"]
- where mTerm = System.Environment.getEnv "TERM"
- `catchIO` \_ -> return "TERM not set"
- start_bold :: String
- start_bold = "\ESC[1m"
- end_bold :: String
- end_bold = "\ESC[0m"
- 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 ->
- do resumes <- GHC.getResumeContext
- 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 ()
- list2 [arg] | all isDigit arg = do
- (toplevel, _) <- GHC.getContext
- case toplevel of
- [] -> io $ putStrLn "No module to list"
- (mod : _) -> listModuleLine mod (read arg)
- list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
- mod <- wantInterpretedModule arg1
- listModuleLine mod (read arg2)
- list2 [arg] = do
- wantNameFromInterpretedModule noCanDo arg $ \name -> do
- let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
- if GHC.isGoodSrcLoc loc
- then do
- tickArray <- ASSERT( isExternalName name )
- getTickArray (GHC.nameModule name)
- let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
- (GHC.srcLocLine loc, GHC.srcLocCol loc)
- tickArray
- case mb_span of
- Nothing -> io $ listAround (GHC.srcLocSpan loc) False
- Just (_,span) -> io $ listAround span False
- else
- noCanDo name $ text "can't find its location: " <>
- ppr loc
- where
- noCanDo n why = printForUser $
- text "cannot list source code for " <> ppr n <> text ": " <> why
- list2 _other =
- io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
- listModuleLine :: Module -> Int -> GHCi ()
- listModuleLine modl line = do
- graph <- GHC.getModuleGraph
- let this = filter ((== modl) . GHC.ms_mod) graph
- case this of
- [] -> panic "listModuleLine"
- summ:_ -> do
- let filename = expectJust "listModuleLine" (ml_hs_file (GHC.ms_location summ))
- loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
- io $ listAround (GHC.srcLocSpan loc) False
- -- | list a section of a source file around a particular SrcSpan.
- -- If the highlight flag is True, also highlight the span using
- -- start_bold\/end_bold.
- listAround :: SrcSpan -> Bool -> IO ()
- listAround span do_highlight = do
- contents <- BS.readFile (unpackFS file)
- let
- lines = BS.split '\n' contents
- these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
- drop (line1 - 1 - pad_before) $ lines
- fst_line = max 1 (line1 - pad_before)
- line_nos = [ fst_line .. ]
- highlighted | do_highlight = zipWith highlight line_nos these_lines
- | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
- bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
- prefixed = zipWith ($) highlighted bs_line_nos
- --
- BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
- where
- file = GHC.srcSpanFile span
- line1 = GHC.srcSpanStartLine span
- col1 = GHC.srcSpanStartCol span
- line2 = GHC.srcSpanEndLine span
- col2 = GHC.srcSpanEndCol span
- pad_before | line1 == 1 = 0
- | otherwise = 1
- pad_after = 1
- highlight | do_bold = highlight_bold
- | otherwise = highlight_carets
- highlight_bold no line prefix
- | no == line1 && no == line2
- = let (a,r) = BS.splitAt col1 line
- (b,c) = BS.splitAt (col2-col1) r
- in
- BS.concat [prefix, a,BS.pack start_bold,b,BS.pack end_bold,c]
- | no == line1
- = let (a,b) = BS.splitAt col1 line in
- BS.concat [prefix, a, BS.pack start_bold, b]
- | no == line2
- = let (a,b) = BS.splitAt col2 line in
- BS.concat [prefix, a, BS.pack end_bold, b]
- | otherwise = BS.concat [prefix, line]
- highlight_carets no line prefix
- | no == line1 && no == line2
- = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
- BS.replicate (col2-col1) '^']
- | no == line1
- = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
- prefix, line]
- | no == line2
- = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
- BS.pack "^^"]
- | otherwise = BS.concat [prefix, line]
- where
- indent = BS.pack (" " ++ replicate (length (show no)) ' ')
- nl = BS.singleton '\n'
- -- --------------------------------------------------------------------------
- -- Tick arrays
- getTickArray :: Module -> GHCi TickArray
- getTickArray modl = do
- st <- getGHCiState
- let arrmap = tickarrays st
- case lookupModuleEnv arrmap modl of
- Just arr -> return arr
- Nothing -> do
- (_breakArray, ticks) <- getModBreak modl
- let arr = mkTickArray (assocs ticks)
- setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
- return arr
- discardTickArrays :: GHCi ()
- discardTickArrays = do
- st <- getGHCiState
- setGHCiState st{tickarrays = emptyModuleEnv}
- mkTickArray :: [(BreakIndex,SrcSpan)] -> TickArray
- mkTickArray ticks
- = accumArray (flip (:)) [] (1, max_line)
- [ (line, (nm,span)) | (nm,span) <- ticks,
- line <- srcSpanLines span ]
- where
- max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
- srcSpanLines span = [ GHC.srcSpanStartLine span ..
- GHC.srcSpanEndLine span ]
- lookupModule :: String -> GHCi Module
- lookupModule modName
- = GHC.findModule (GHC.mkModuleName modName) Nothing
- -- don't reset the counter back to zero?
- discardActiveBreakPoints :: GHCi ()
- discardActiveBreakPoints = do
- st <- getGHCiState
- mapM (turnOffBreak.snd) (breaks st)
- setGHCiState $ st { breaks = [] }
- deleteBreak :: Int -> GHCi ()
- deleteBreak identity = do
- st <- getGHCiState
- let oldLocations = breaks st
- (this,rest) = partition (\loc -> fst loc == identity) oldLocations
- if null this
- then printForUser (text "Breakpoint" <+> ppr identity <+>
- text "does not exist")
- else do
- mapM (turnOffBreak.snd) this
- setGHCiState $ st { breaks = rest }
- turnOffBreak :: BreakLocation -> GHCi Bool
- turnOffBreak loc = do
- (arr, _) <- getModBreak (breakModule loc)
- io $ setBreakFlag False arr (breakTick loc)
- getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
- getModBreak mod = do
- Just mod_info <- GHC.getModuleInfo mod
- let modBreaks = GHC.modInfoModBreaks mod_info
- let array = GHC.modBreaks_flags modBreaks
- let ticks = GHC.modBreaks_locs modBreaks
- return (array, ticks)
- setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
- setBreakFlag toggle array index
- | toggle = GHC.setBreakOn array index
- | otherwise = GHC.setBreakOff array index