/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
Large files files are truncated, but you can click here to view the full file
- {-# 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 …
Large files files are truncated, but you can click here to view the full file