/ghc/InteractiveUI.hs
Haskell | 3016 lines | 2251 code | 407 blank | 358 comment | 142 complexity | b7714f5823fba1ba12d62e7bd3fda900 MD5 | raw file
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
- -----------------------------------------------------------------------------
- --
- -- GHC Interactive User Interface
- --
- -- (c) The GHC Team 2005-2006
- --
- -----------------------------------------------------------------------------
- module InteractiveUI (
- interactiveUI,
- GhciSettings(..),
- defaultGhciSettings,
- ghciCommands,
- ghciWelcomeMsg
- ) where
- #include "HsVersions.h"
- -- GHCi
- import qualified GhciMonad ( args, runStmt )
- import GhciMonad hiding ( args, runStmt )
- import GhciTags
- import Debugger
- -- The GHC interface
- import DynFlags
- import GhcMonad ( modifySession )
- import qualified GHC
- import GHC ( LoadHowMuch(..), Target(..), TargetId(..), InteractiveImport(..),
- TyThing(..), Phase, BreakIndex, Resume, SingleStep, Ghc,
- handleSourceError )
- import HsImpExp
- import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC,
- setInteractivePrintName )
- import Module
- import Name
- import Packages ( trusted, getPackageDetails, exposed, exposedModules, pkgIdMap )
- import PprTyThing
- import RdrName ( getGRE_NameQualifier_maybes )
- import SrcLoc
- import qualified Lexer
- import StringBuffer
- import UniqFM ( eltsUFM )
- import Outputable hiding ( printForUser, printForUserPartWay, bold )
- -- Other random utilities
- import BasicTypes hiding ( isTopLevel )
- import Config
- import Digraph
- import Encoding
- import FastString
- import Linker
- import Maybes ( orElse, expectJust )
- import NameSet
- import Panic hiding ( showException )
- import Util
- -- Haskell Libraries
- import System.Console.Haskeline as Haskeline
- import Control.Applicative hiding (empty)
- import Control.Monad as Monad
- import Control.Monad.Trans.Class
- import Control.Monad.IO.Class
- import Data.Array
- import qualified Data.ByteString.Char8 as BS
- import Data.Char
- import Data.Function
- import Data.IORef ( IORef, readIORef, writeIORef )
- import Data.List ( find, group, intercalate, intersperse, isPrefixOf, nub,
- partition, sort, sortBy )
- import Data.Maybe
- import Exception hiding (catch)
- import Foreign.C
- import Foreign.Safe
- import System.Cmd
- import System.Directory
- import System.Environment
- import System.Exit ( exitWith, ExitCode(..) )
- import System.FilePath
- import System.IO
- import System.IO.Error
- import System.IO.Unsafe ( unsafePerformIO )
- import Text.Printf
- #ifndef mingw32_HOST_OS
- import System.Posix hiding ( getEnv )
- #else
- import qualified System.Win32
- #endif
- import GHC.Exts ( unsafeCoerce# )
- import GHC.IO.Exception ( IOErrorType(InvalidArgument) )
- import GHC.IO.Handle ( hFlushAll )
- import GHC.TopHandler ( topHandler )
- -----------------------------------------------------------------------------
- data GhciSettings = GhciSettings {
- availableCommands :: [Command],
- shortHelpText :: String,
- fullHelpText :: String,
- defPrompt :: String
- }
- defaultGhciSettings :: GhciSettings
- defaultGhciSettings =
- GhciSettings {
- availableCommands = ghciCommands,
- shortHelpText = defShortHelpText,
- fullHelpText = defFullHelpText,
- defPrompt = default_prompt
- }
- ghciWelcomeMsg :: String
- ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
- ": http://www.haskell.org/ghc/ :? for help"
- cmdName :: Command -> String
- cmdName (n,_,_) = n
- GLOBAL_VAR(macros_ref, [], [Command])
- ghciCommands :: [Command]
- ghciCommands = [
- -- Hugs users are accustomed to :e, so make sure it doesn't overlap
- ("?", keepGoing help, noCompletion),
- ("add", keepGoingPaths addModule, completeFilename),
- ("abandon", keepGoing abandonCmd, noCompletion),
- ("break", keepGoing breakCmd, completeIdentifier),
- ("back", keepGoing backCmd, noCompletion),
- ("browse", keepGoing' (browseCmd False), completeModule),
- ("browse!", keepGoing' (browseCmd True), completeModule),
- ("cd", keepGoing' changeDirectory, completeFilename),
- ("check", keepGoing' checkModule, completeHomeModule),
- ("continue", keepGoing continueCmd, noCompletion),
- ("cmd", keepGoing cmdCmd, completeExpression),
- ("ctags", keepGoing createCTagsWithLineNumbersCmd, completeFilename),
- ("ctags!", keepGoing createCTagsWithRegExesCmd, completeFilename),
- ("def", keepGoing (defineMacro False), completeExpression),
- ("def!", keepGoing (defineMacro True), completeExpression),
- ("delete", keepGoing deleteCmd, noCompletion),
- ("edit", keepGoing' editFile, completeFilename),
- ("etags", keepGoing createETagsFileCmd, completeFilename),
- ("force", keepGoing forceCmd, completeExpression),
- ("forward", keepGoing forwardCmd, noCompletion),
- ("help", keepGoing help, noCompletion),
- ("history", keepGoing historyCmd, noCompletion),
- ("info", keepGoing' info, completeIdentifier),
- ("issafe", keepGoing' isSafeCmd, completeModule),
- ("kind", keepGoing' (kindOfType False), completeIdentifier),
- ("kind!", keepGoing' (kindOfType True), completeIdentifier),
- ("load", keepGoingPaths loadModule_, completeHomeModuleOrFile),
- ("list", keepGoing' listCmd, noCompletion),
- ("module", keepGoing moduleCmd, completeSetModule),
- ("main", keepGoing runMain, completeFilename),
- ("print", keepGoing printCmd, completeExpression),
- ("quit", quit, noCompletion),
- ("reload", keepGoing' reloadModule, noCompletion),
- ("run", keepGoing runRun, completeFilename),
- ("script", keepGoing' scriptCmd, completeFilename),
- ("set", keepGoing setCmd, completeSetOptions),
- ("seti", keepGoing setiCmd, completeSeti),
- ("show", keepGoing showCmd, completeShowOptions),
- ("showi", keepGoing showiCmd, completeShowiOptions),
- ("sprint", keepGoing sprintCmd, completeExpression),
- ("step", keepGoing stepCmd, completeIdentifier),
- ("steplocal", keepGoing stepLocalCmd, completeIdentifier),
- ("stepmodule",keepGoing stepModuleCmd, completeIdentifier),
- ("type", keepGoing' typeOfExpr, completeExpression),
- ("trace", keepGoing traceCmd, completeExpression),
- ("undef", keepGoing undefineMacro, completeMacro),
- ("unset", keepGoing unsetOptions, completeSetOptions)
- ]
- -- We initialize readline (in the interactiveUI function) to use
- -- word_break_chars as the default set of completion word break characters.
- -- This can be overridden for a particular command (for example, filename
- -- expansion shouldn't consider '/' to be a word break) by setting the third
- -- entry in the Command tuple above.
- --
- -- NOTE: in order for us to override the default correctly, any custom entry
- -- must be a SUBSET of word_break_chars.
- word_break_chars :: String
- word_break_chars = let symbols = "!#$%&*+/<=>?@\\^|-~"
- specials = "(),;[]`{}"
- spaces = " \t\n"
- in spaces ++ specials ++ symbols
- flagWordBreakChars :: String
- flagWordBreakChars = " \t\n"
- keepGoing :: (String -> GHCi ()) -> (String -> InputT GHCi Bool)
- keepGoing a str = keepGoing' (lift . a) str
- keepGoing' :: Monad m => (String -> m ()) -> String -> m Bool
- keepGoing' a str = a str >> return False
- keepGoingPaths :: ([FilePath] -> InputT GHCi ()) -> (String -> InputT GHCi Bool)
- keepGoingPaths a str
- = do case toArgs str of
- Left err -> liftIO $ hPutStrLn stderr err
- Right args -> a args
- return False
- defShortHelpText :: String
- defShortHelpText = "use :? for help.\n"
- defFullHelpText :: String
- defFullHelpText =
- " 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" ++
- " (!: use regex instead of line number)\n" ++
- " :def <cmd> <expr> define command :<cmd> (later defined command has\n" ++
- " precedence, ::<cmd> is always a builtin command)\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" ++
- " :issafe [<mod>] display safe haskell information of module <mod>\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" ++
- " :script <filename> run the script <filename>\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" ++
- " :seti <option> ... set options for interactive evaluation only\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" ++
- " +m allow multiline commands\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 imports show the current imports\n" ++
- " :show modules show the currently loaded modules\n" ++
- " :show packages show the currently active package flags\n" ++
- " :show language show the currently active language flags\n" ++
- " :show <setting> show value of <setting>, which is one of\n" ++
- " [args, prog, prompt, editor, stop]\n" ++
- " :showi language show language flags for interactive evaluation\n" ++
- "\n"
- findEditor :: IO String
- findEditor = do
- getEnv "EDITOR"
- `catchIO` \_ -> do
- #if mingw32_HOST_OS
- win <- System.Win32.getWindowsDirectory
- return (win </> "notepad.exe")
- #else
- return ""
- #endif
- foreign import ccall unsafe "rts_isProfiled" isProfiled :: IO CInt
- default_progname, default_prompt, default_stop :: String
- default_progname = "<interactive>"
- default_prompt = "%s> "
- default_stop = ""
- default_args :: [String]
- default_args = []
- interactiveUI :: GhciSettings -> [(FilePath, Maybe Phase)] -> Maybe [String]
- -> Ghc ()
- interactiveUI config srcs maybe_exprs = do
- -- although GHCi compiles with -prof, it is not usable: the byte-code
- -- compiler and interpreter don't work with profiling. So we check for
- -- this up front and emit a helpful error message (#2197)
- i <- liftIO $ isProfiled
- when (i /= 0) $
- ghcError (InstallationError "GHCi cannot be used when compiled with -prof")
- -- 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
- -- The initial set of DynFlags used for interactive evaluation is the same
- -- as the global DynFlags, plus -XExtendedDefaultRules and
- -- -XNoMonomorphismRestriction.
- dflags <- getDynFlags
- let dflags' = (`xopt_set` Opt_ExtendedDefaultRules)
- . (`xopt_unset` Opt_MonomorphismRestriction)
- $ dflags
- GHC.setInteractiveDynFlags dflags'
- 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
- #if defined(mingw32_HOST_OS)
- -- On Unix, stdin will use the locale encoding. The IO library
- -- doesn't do this on Windows (yet), so for now we use UTF-8,
- -- for consistency with GHC 6.10 and to make the tests work.
- hSetEncoding stdin utf8
- #endif
- default_editor <- liftIO $ findEditor
- startGHCi (runGHCi srcs maybe_exprs)
- GHCiState{ progname = default_progname,
- GhciMonad.args = default_args,
- prompt = defPrompt config,
- def_prompt = defPrompt config,
- stop = default_stop,
- editor = default_editor,
- options = [],
- line_number = 1,
- break_ctr = 0,
- breaks = [],
- tickarrays = emptyModuleEnv,
- ghci_commands = availableCommands config,
- last_command = Nothing,
- cmdqueue = [],
- remembered_ctx = [],
- transient_ctx = [],
- ghc_e = isJust maybe_exprs,
- short_help = shortHelpText config,
- long_help = fullHelpText config
- }
- return ()
- withGhcAppData :: (FilePath -> IO a) -> IO a -> IO a
- withGhcAppData right left = do
- either_dir <- tryIO (getAppUserDataDirectory "ghc")
- case either_dir of
- Right dir ->
- do createDirectoryIfMissing False dir `catchIO` \_ -> return ()
- right dir
- _ -> left
- runGHCi :: [(FilePath, Maybe Phase)] -> Maybe [String] -> GHCi ()
- runGHCi paths maybe_exprs = do
- dflags <- getDynFlags
- let
- read_dot_files = not (dopt Opt_IgnoreDotGhci dflags)
- current_dir = return (Just ".ghci")
- app_user_dir = liftIO $ withGhcAppData
- (\dir -> return (Just (dir </> "ghci.conf")))
- (return Nothing)
- home_dir = do
- either_dir <- liftIO $ tryIO (getEnv "HOME")
- case either_dir of
- Right home -> return (Just (home </> ".ghci"))
- _ -> return Nothing
- canonicalizePath' :: FilePath -> IO (Maybe FilePath)
- canonicalizePath' fp = liftM Just (canonicalizePath fp)
- `catchIO` \_ -> return Nothing
- sourceConfigFile :: FilePath -> GHCi ()
- sourceConfigFile file = do
- exists <- liftIO $ doesFileExist file
- when exists $ do
- dir_ok <- liftIO $ checkPerms (getDirectory file)
- file_ok <- liftIO $ checkPerms file
- when (dir_ok && file_ok) $ do
- either_hdl <- liftIO $ tryIO (openFile file ReadMode)
- case either_hdl of
- Left _e -> return ()
- -- NOTE: this assumes that runInputT won't affect the terminal;
- -- can we assume this will always be the case?
- -- This would be a good place for runFileInputT.
- Right hdl ->
- do runInputTWithPrefs defaultPrefs defaultSettings $
- runCommands $ fileLoop hdl
- liftIO (hClose hdl `catchIO` \_ -> return ())
- where
- getDirectory f = case takeDirectory f of "" -> "."; d -> d
- --
- setGHCContextFromGHCiState
- when (read_dot_files) $ do
- mcfgs0 <- sequence $ [ current_dir, app_user_dir, home_dir ] ++ map (return . Just ) (ghciScripts dflags)
- mcfgs <- liftIO $ mapM canonicalizePath' (catMaybes mcfgs0)
- mapM_ sourceConfigFile $ nub $ catMaybes mcfgs
- -- 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) $
- -- TODO: this is a hack.
- runInputTWithPrefs defaultPrefs defaultSettings $
- loadModule paths
- when (isJust maybe_exprs && failed ok) $
- liftIO (exitWith (ExitFailure 1))
- installInteractivePrint (interactivePrint dflags) (isJust maybe_exprs)
- -- if verbosity is greater than 0, or we are connected to a
- -- terminal, display the prompt in the interactive loop.
- is_tty <- liftIO (hIsTerminalDevice stdin)
- let show_prompt = verbosity dflags > 0 || is_tty
- -- reset line number
- getGHCiState >>= \st -> setGHCiState st{line_number=1}
- case maybe_exprs of
- Nothing ->
- do
- -- enter the interactive loop
- runGHCiInput $ runCommands $ nextInputLine show_prompt is_tty
- Just exprs -> do
- -- just evaluate the expression we were given
- enqueueCommands exprs
- let hdle e = do st <- getGHCiState
- -- flush the interpreter's stdout/stderr on exit (#3890)
- flushInterpBuffers
- -- Jump through some hoops to get the
- -- current progname in the exception text:
- -- <progname>: <exception>
- liftIO $ withProgName (progname st)
- $ topHandler e
- -- this used to be topHandlerFastExit, see #2228
- runInputTWithPrefs defaultPrefs defaultSettings $ do
- runCommands' hdle (return Nothing)
- -- and finally, exit
- liftIO $ when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
- runGHCiInput :: InputT GHCi a -> GHCi a
- runGHCiInput f = do
- dflags <- getDynFlags
- histFile <- if dopt Opt_GhciHistory dflags
- then liftIO $ withGhcAppData (\dir -> return (Just (dir </> "ghci_history")))
- (return Nothing)
- else return Nothing
- runInputT
- (setComplete ghciCompleteWord $ defaultSettings {historyFile = histFile})
- f
- -- | How to get the next input line from the user
- nextInputLine :: Bool -> Bool -> InputT GHCi (Maybe String)
- nextInputLine show_prompt is_tty
- | is_tty = do
- prmpt <- if show_prompt then lift mkPrompt else return ""
- r <- getInputLine prmpt
- incrementLineNo
- return r
- | otherwise = do
- when show_prompt $ lift mkPrompt >>= liftIO . putStr
- fileLoop stdin
- -- 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 = System.Posix.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
- incrementLineNo :: InputT GHCi ()
- incrementLineNo = do
- st <- lift $ getGHCiState
- let ln = 1+(line_number st)
- lift $ setGHCiState st{line_number=ln}
- fileLoop :: Handle -> InputT GHCi (Maybe String)
- fileLoop hdl = do
- l <- liftIO $ tryIO $ hGetLine hdl
- case l of
- Left e | isEOFError e -> return Nothing
- | InvalidArgument <- etype -> return Nothing
- | otherwise -> liftIO $ 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
- incrementLineNo
- return (Just l')
- mkPrompt :: GHCi String
- mkPrompt = do
- imports <- GHC.getContext
- resumes <- GHC.getResumeContext
- 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)
- pan <- GHC.getHistorySpan hist
- return (brackets (ppr (negate ix) <> char ':'
- <+> ppr pan) <> space)
- let
- dots | _:rs <- resumes, not (null rs) = text "... "
- | otherwise = empty
- rev_imports = reverse imports -- rightmost are the most recent
- modules_bit =
- hsep [ char '*' <> ppr m | IIModule m <- rev_imports ] <+>
- hsep (map ppr [ myIdeclName d | IIDecl d <- rev_imports ])
- -- use the 'as' name if there is one
- myIdeclName d | Just m <- ideclAs d = m
- | otherwise = unLoc (ideclName d)
- 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
- dflags <- getDynFlags
- return (showSDoc dflags (f (prompt st)))
- queryQueue :: GHCi (Maybe String)
- queryQueue = do
- st <- getGHCiState
- case cmdqueue st of
- [] -> return Nothing
- c:cs -> do setGHCiState st{ cmdqueue = cs }
- return (Just c)
- -- Reconfigurable pretty-printing Ticket #5461
- installInteractivePrint :: Maybe String -> Bool -> GHCi ()
- installInteractivePrint Nothing _ = return ()
- installInteractivePrint (Just ipFun) exprmode = do
- ok <- trySuccess $ do
- (name:_) <- GHC.parseName ipFun
- modifySession (\he -> let new_ic = setInteractivePrintName (hsc_IC he) name
- in he{hsc_IC = new_ic})
- return Succeeded
- when (failed ok && exprmode) $ liftIO (exitWith (ExitFailure 1))
- -- | The main read-eval-print loop
- runCommands :: InputT GHCi (Maybe String) -> InputT GHCi ()
- runCommands = runCommands' handler
- runCommands' :: (SomeException -> GHCi Bool) -- ^ Exception handler
- -> InputT GHCi (Maybe String) -> InputT GHCi ()
- runCommands' eh gCmd = do
- b <- ghandle (\e -> case fromException e of
- Just UserInterrupt -> return $ Just False
- _ -> case fromException e of
- Just ghce ->
- do liftIO (print (ghce :: GhcException))
- return Nothing
- _other ->
- liftIO (Exception.throwIO e))
- (runOneCommand eh gCmd)
- case b of
- Nothing -> return ()
- Just _ -> runCommands' eh gCmd
- -- | Evaluate a single line of user input (either :<command> or Haskell code)
- runOneCommand :: (SomeException -> GHCi Bool) -> InputT GHCi (Maybe String)
- -> InputT GHCi (Maybe Bool)
- runOneCommand eh gCmd = do
- -- run a previously queued command if there is one, otherwise get new
- -- input from user
- mb_cmd0 <- noSpace (lift queryQueue)
- mb_cmd1 <- maybe (noSpace gCmd) (return . Just) mb_cmd0
- case mb_cmd1 of
- Nothing -> return Nothing
- Just c -> ghciHandle (\e -> lift $ eh e >>= return . Just) $
- handleSourceError printErrorAndKeepGoing
- (doCommand c)
- -- source error's are handled by runStmt
- -- is the handler necessary here?
- where
- printErrorAndKeepGoing err = do
- GHC.printException err
- return $ Just True
- noSpace q = q >>= maybe (return Nothing)
- (\c -> case removeSpaces c of
- "" -> noSpace q
- ":{" -> multiLineCmd q
- c' -> return (Just c') )
- multiLineCmd q = do
- st <- lift getGHCiState
- let p = prompt st
- lift $ setGHCiState st{ prompt = "%s| " }
- mb_cmd <- collectCommand q ""
- lift $ 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 (liftIO (ioError collectError))
- (\l->if removeSpaces l == ":}"
- then return (Just $ removeSpaces c)
- else collectCommand q (c ++ "\n" ++ map normSpace l))
- where normSpace '\r' = ' '
- normSpace x = x
- -- SDM (2007-11-07): is userError the one to use here?
- collectError = userError "unterminated multiline command :{ .. :}"
- -- | Handle a line of input
- doCommand :: String -> InputT GHCi (Maybe Bool)
- -- command
- doCommand (':' : cmd) = do
- result <- specialCommand cmd
- case result of
- True -> return Nothing
- _ -> return $ Just True
- -- haskell
- doCommand stmt = do
- ml <- lift $ isOptionSet Multiline
- if ml
- then do
- mb_stmt <- checkInputForLayout stmt gCmd
- case mb_stmt of
- Nothing -> return $ Just True
- Just ml_stmt -> do
- result <- timeIt $ lift $ runStmt ml_stmt GHC.RunToCompletion
- return $ Just result
- else do
- result <- timeIt $ lift $ runStmt stmt GHC.RunToCompletion
- return $ Just result
- -- #4316
- -- lex the input. If there is an unclosed layout context, request input
- checkInputForLayout :: String -> InputT GHCi (Maybe String)
- -> InputT GHCi (Maybe String)
- checkInputForLayout stmt getStmt = do
- dflags' <- lift $ getDynFlags
- let dflags = xopt_set dflags' Opt_AlternativeLayoutRule
- st0 <- lift $ getGHCiState
- let buf' = stringToStringBuffer stmt
- loc = mkRealSrcLoc (fsLit (progname st0)) (line_number st0) 1
- pstate = Lexer.mkPState dflags buf' loc
- case Lexer.unP goToEnd pstate of
- (Lexer.POk _ False) -> return $ Just stmt
- _other -> do
- st1 <- lift getGHCiState
- let p = prompt st1
- lift $ setGHCiState st1{ prompt = "%s| " }
- mb_stmt <- ghciHandle (\ex -> case fromException ex of
- Just UserInterrupt -> return Nothing
- _ -> case fromException ex of
- Just ghce ->
- do liftIO (print (ghce :: GhcException))
- return Nothing
- _other -> liftIO (Exception.throwIO ex))
- getStmt
- lift $ getGHCiState >>= \st' -> setGHCiState st'{ prompt = p }
- -- the recursive call does not recycle parser state
- -- as we use a new string buffer
- case mb_stmt of
- Nothing -> return Nothing
- Just str -> if str == ""
- then return $ Just stmt
- else do
- checkInputForLayout (stmt++"\n"++str) getStmt
- where goToEnd = do
- eof <- Lexer.nextIsEOF
- if eof
- then Lexer.activeContext
- else Lexer.lexer return >> goToEnd
- enqueueCommands :: [String] -> GHCi ()
- enqueueCommands cmds = do
- st <- getGHCiState
- setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
- -- | If we one of these strings prefixes a command, then we treat it as a decl
- -- rather than a stmt.
- declPrefixes :: [String]
- declPrefixes = ["class ","data ","newtype ","type ","instance ", "deriving ",
- "foreign ", "default ", "default("]
- -- | Entry point to execute some haskell code from user
- runStmt :: String -> SingleStep -> GHCi Bool
- runStmt stmt step
- -- empty
- | null (filter (not.isSpace) stmt)
- = return False
- -- import
- | "import " `isPrefixOf` stmt
- = do addImportToContext stmt; return False
- -- data, class, newtype...
- | any (flip isPrefixOf stmt) declPrefixes
- = do _ <- liftIO $ tryIO $ hFlushAll stdin
- result <- GhciMonad.runDecls stmt
- afterRunStmt (const True) (GHC.RunOk result)
- | otherwise
- = do -- In the new IO library, read handles buffer data even if the Handle
- -- is set to NoBuffering. This causes problems for GHCi where there
- -- are really two stdin Handles. So we flush any bufferred data in
- -- GHCi's stdin Handle here (only relevant if stdin is attached to
- -- a file, otherwise the read buffer can't be flushed).
- _ <- liftIO $ tryIO $ hFlushAll stdin
- m_result <- GhciMonad.runStmt stmt step
- case m_result of
- Nothing -> return False
- Just result -> afterRunStmt (const True) result
- -- | Clean up the GHCi environment after a statement has run
- 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 bCmd = maybe "" ( \(_,l) -> onBreakCmd l ) mb_id_loc
- if (null bCmd)
- then printStoppedAtBreakInfo (head resumes) names
- else enqueueCommands [bCmd]
- -- 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
- liftIO 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 inf) = do
- let md = GHC.breakInfo_module inf
- nm = GHC.breakInfo_number inf
- st <- getGHCiState
- return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
- breakModule loc == md,
- breakTick loc == nm ]
- printStoppedAtBreakInfo :: Resume -> [Name] -> GHCi ()
- printStoppedAtBreakInfo res names = do
- printForUser $ ptext (sLit "Stopped at") <+>
- ppr (GHC.resumeSpan res)
- -- printTypeOfNames session names
- let namesSorted = sortBy compareNames names
- tythings <- catMaybes `liftM` mapM GHC.lookupName namesSorted
- docs <- mapM pprTypeAndContents [i | AnId i <- tythings]
- printForUserPartWay $ vcat 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
- -- | Entry point for execution a ':<command>' input from user
- specialCommand :: String -> InputT GHCi Bool
- specialCommand ('!':str) = lift $ shellEscape (dropWhile isSpace str)
- specialCommand str = do
- let (cmd,rest) = break isSpace str
- maybe_cmd <- lift $ lookupCommand cmd
- htxt <- lift $ short_help `fmap` getGHCiState
- case maybe_cmd of
- GotCommand (_,f,_) -> f (dropWhile isSpace rest)
- BadCommand ->
- do liftIO $ hPutStr stdout ("unknown command ':" ++ cmd ++ "'\n"
- ++ htxt)
- return False
- NoLastCommand ->
- do liftIO $ hPutStr stdout ("there is no last command to perform\n"
- ++ htxt)
- return False
- shellEscape :: String -> GHCi Bool
- shellEscape str = liftIO (system str >> 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 <- lookupCommand' str
- st <- getGHCiState
- setGHCiState st{ last_command = mc }
- return $ case mc of
- Just c -> GotCommand c
- Nothing -> BadCommand
- lookupCommand' :: String -> GHCi (Maybe Command)
- lookupCommand' ":" = return Nothing
- lookupCommand' str' = do
- macros <- liftIO $ readIORef macros_ref
- ghci_cmds <- ghci_commands `fmap` getGHCiState
- let{ (str, cmds) = case str' of
- ':' : rest -> (rest, ghci_cmds) -- "::" selects a builtin command
- _ -> (str', ghci_cmds ++ macros) } -- otherwise prefer 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)
- pan <- GHC.getHistorySpan hist
- return (Just pan)
- 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 _ _ = liftIO $ putStrLn "This command takes no arguments"
- withSandboxOnly :: String -> GHCi () -> GHCi ()
- withSandboxOnly cmd this = do
- dflags <- getDynFlags
- if not (dopt Opt_GhciSandbox dflags)
- then printForUser (text cmd <+>
- ptext (sLit "is not supported with -fno-ghci-sandbox"))
- else this
- -----------------------------------------------------------------------------
- -- :help
- help :: String -> GHCi ()
- help _ = do
- txt <- long_help `fmap` getGHCiState
- liftIO $ putStr txt
- -----------------------------------------------------------------------------
- -- :info
- info :: String -> InputT GHCi ()
- info "" = ghcError (CmdLineError "syntax: ':i <thing-you-want-info-about>'")
- info s = handleSourceError GHC.printException $ do
- unqual <- GHC.getPrintUnqual
- dflags <- getDynFlags
- sdocs <- mapM infoThing (words s)
- mapM_ (liftIO . putStrLn . showSDocForUser dflags unqual) sdocs
- infoThing :: GHC.GhcMonad m => String -> m SDoc
- infoThing str = do
- dflags <- getDynFlags
- let pefas = dopt Opt_PrintExplicitForalls dflags
- names <- GHC.parseName str
- mb_stuffs <- mapM GHC.getInfo names
- let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
- return $ 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
- = filterOut has_parent xs
- where
- all_names = mkNameSet (map (getName . get_thing) xs)
- has_parent x = case tyThingParent_maybe (get_thing x) of
- Just p -> getName p `elemNameSet` all_names
- Nothing -> False
- pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.ClsInst]) -> SDoc
- pprInfo pefas (thing, fixity, insts)
- = pprTyThingInContextLoc pefas thing
- $$ show_fixity
- $$ vcat (map GHC.pprInstance insts)
- where
- show_fixity
- | fixity == GHC.defaultFixity = empty
- | otherwise = ppr fixity <+> pprInfixName (GHC.getName thing)
- -----------------------------------------------------------------------------
- -- :main
- runMain :: String -> GHCi ()
- runMain s = case toArgs s of
- Left err -> liftIO (hPutStrLn stderr err)
- Right args ->
- do dflags <- getDynFlags
- case mainFunIs dflags of
- Nothing -> doWithArgs args "main"
- Just f -> doWithArgs args f
- -----------------------------------------------------------------------------
- -- :run
- runRun :: String -> GHCi ()
- runRun s = case toCmdArgs s of
- Left err -> liftIO (hPutStrLn stderr err)
- Right (cmd, args) -> doWithArgs args cmd
- doWithArgs :: [String] -> String -> GHCi ()
- doWithArgs args cmd = enqueueCommands ["System.Environment.withArgs " ++
- show args ++ " (" ++ cmd ++ ")"]
- -----------------------------------------------------------------------------
- -- :cd
- changeDirectory :: String -> InputT GHCi ()
- changeDirectory "" = do
- -- :cd on its own changes to the user's home directory
- either_dir <- liftIO $ tryIO getHomeDirectory
- case either_dir of
- Left _e -> return ()
- Right dir -> changeDirectory dir
- changeDirectory dir = do
- graph <- GHC.getModuleGraph
- when (not (null graph)) $
- liftIO $ putStrLn "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed."
- GHC.setTargets []
- _ <- GHC.load LoadAllTargets
- lift $ setContextAfterLoad False []
- GHC.workingDirectoryChanged
- dir' <- expandPath dir
- liftIO $ setCurrentDirectory dir'
- trySuccess :: GHC.GhcMonad m => m SuccessFlag -> m SuccessFlag
- trySuccess act =
- handleSourceError (\e -> do GHC.printException e
- return Failed) $ do
- act
- -----------------------------------------------------------------------------
- -- :edit
- editFile :: String -> InputT GHCi ()
- editFile str =
- do file <- if null str then lift chooseEditFile else return str
- st <- lift getGHCiState
- let cmd = editor st
- when (null cmd)
- $ ghcError (CmdLineError "editor not set, use :set editor")
- code <- liftIO $ system (cmd ++ ' ':file)
- when (code == ExitSuccess)
- $ reloadModule ""
- -- 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?
- -----------------------------------------------------------------------------
- -- :def
- defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
- defineMacro _ (':':_) =
- liftIO $ putStrLn "macro name cannot start with a colon"
- defineMacro overwrite s = do
- let (macro_name, definition) = break isSpace s
- macros <- liftIO (readIORef macros_ref)
- let defined = map cmdName macros
- if (null macro_name)
- then if null defined
- then liftIO $ putStrLn "no macros defined"
- else liftIO $ 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.printException e) $
- do
- hv <- GHC.compileExpr new_expr
- liftIO (writeIORef macros_ref -- later defined macros have precedence
- ((macro_name, lift . runMacro hv, noCompletion) : filtered))
- runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
- runMacro fun s = do
- str <- liftIO ((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
- -----------------------------------------------------------------------------
- -- :undef
- undefineMacro :: String -> GHCi ()
- undefineMacro str = mapM_ undef (words str)
- where undef macro_name = do
- cmds <- liftIO (readIORef macros_ref)
- if (macro_name `notElem` map cmdName cmds)
- then ghcError (CmdLineError
- ("macro '" ++ macro_name ++ "' is not defined"))
- else do
- liftIO (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
- -----------------------------------------------------------------------------
- -- :cmd
- cmdCmd :: String -> GHCi ()
- cmdCmd str = do
- let expr = '(' : str ++ ") :: IO String"
- handleSourceError (\e -> GHC.printException e) $
- do
- hv <- GHC.compileExpr expr
- cmds <- liftIO $ (unsafeCoerce# hv :: IO String)
- enqueueCommands (lines cmds)
- return ()
- -----------------------------------------------------------------------------
- -- :check
- checkModule :: String -> InputT GHCi ()
- checkModule m = do
- let modl = GHC.mkModuleName m
- ok <- handleSourceError (\e -> GHC.printException e >> return False) $ do
- r <- GHC.typecheckModule =<< GHC.parseModule =<< GHC.getModSummary modl
- dflags <- getDynFlags
- liftIO $ putStrLn $ showSDoc dflags $
- case GHC.moduleInfo r of
- cm | Just scope <- GHC.modInfoTopLevelScope cm ->
- let
- (loc, glob) = ASSERT( all isExternalName scope )
- partition ((== modl) . GHC.moduleName . GHC.nameModule) scope
- in
- (text "global names: " <+> ppr glob) $$
- (text "local names: " <+> ppr loc)
- _ -> empty
- return True
- afterLoad (successIf ok) False
- -----------------------------------------------------------------------------
- -- :load, :add, :reload
- loadModule :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
- loadModule fs = timeIt (loadModule' fs)
- loadModule_ :: [FilePath] -> InputT GHCi ()
- loadModule_ fs = loadModule (zip fs (repeat Nothing)) >> return ()
- loadModule' :: [(FilePath, Maybe Phase)] -> InputT GHCi SuccessFlag
- loadModule' files = do
- 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.
- -- unload first
- _ <- GHC.abandonAll
- lift discardActiveBreakPoints
- GHC.setTargets []
- _ <- GHC.load LoadAllTargets
- GHC.setTargets targets
- doLoad False LoadAllTargets
- -- :add
- addModule :: [FilePath]…
Large files files are truncated, but you can click here to view the full file