-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------
-module InteractiveUI ( interactiveUI ) where
+
+module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
#include "HsVersions.h"
-- The GHC interface
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
- Type, Module, ModuleName, TyThing(..), Phase,
+ Module, ModuleName, TyThing(..), Phase,
BreakIndex, SrcSpan, Resume, SingleStep )
+import PprTyThing
import DynFlags
+
import Packages
+#ifdef USE_READLINE
import PackageConfig
import UniqFM
-import PprTyThing
-import Outputable hiding (printForUser)
+#endif
+
+import HscTypes ( implicitTyThings )
+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 Digraph
import StaticFlags
import Linker
import Util
+import NameSet
+import Maybes ( orElse )
import FastString
+import Encoding
#ifndef mingw32_HOST_OS
import System.Posix hiding (getEnv)
#else
import GHC.ConsoleHandler ( flushConsole )
-import System.Win32 ( setConsoleCP, setConsoleOutputCP )
import qualified System.Win32
#endif
import Data.Array
import Control.Monad as Monad
import Text.Printf
-
-import Foreign.StablePtr ( newStablePtr )
+import Foreign
+import Foreign.C ( withCStringLen )
import GHC.Exts ( unsafeCoerce# )
import GHC.IOBase ( IOErrorType(InvalidArgument) )
import Data.IORef ( IORef, readIORef, writeIORef )
+#ifdef USE_READLINE
import System.Posix.Internals ( setNonBlockingFD )
+#endif
-----------------------------------------------------------------------------
-ghciWelcomeMsg =
- " ___ ___ _\n"++
- " / _ \\ /\\ /\\/ __(_)\n"++
- " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
- "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
- "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
-
-ghciShortWelcomeMsg =
- "GHCi, version " ++ cProjectVersion ++
- ": http://www.haskell.org/ghc/ :? for help"
+ghciWelcomeMsg :: String
+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
+ ": http://www.haskell.org/ghc/ :? for help"
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
+
+cmdName :: Command -> String
cmdName (n,_,_,_) = n
-GLOBAL_VAR(commands, builtin_commands, [Command])
+macros_ref :: IORef [Command]
+GLOBAL_VAR(macros_ref, [], [Command])
builtin_commands :: [Command]
builtin_commands = [
("abandon", keepGoing abandonCmd, False, completeNone),
("break", keepGoing breakCmd, False, completeIdentifier),
("back", keepGoing backCmd, False, completeNone),
- ("browse", keepGoing browseCmd, False, completeModule),
+ ("browse", keepGoing (browseCmd False), False, completeModule),
+ ("browse!", keepGoing (browseCmd True), False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
("continue", keepGoing continueCmd, False, completeNone),
("cmd", keepGoing cmdCmd, False, completeIdentifier),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
- ("def", keepGoing defineMacro, False, completeIdentifier),
+ ("def", keepGoing (defineMacro False), False, completeIdentifier),
+ ("def!", keepGoing (defineMacro True), False, completeIdentifier),
("delete", keepGoing deleteCmd, False, completeNone),
("e", keepGoing editFile, False, completeFilename),
("edit", keepGoing editFile, False, completeFilename),
("show", keepGoing showCmd, False, completeNone),
("sprint", keepGoing sprintCmd, False, completeIdentifier),
("step", keepGoing stepCmd, False, completeIdentifier),
+ ("steplocal", keepGoing stepLocalCmd, False, completeIdentifier),
+ ("stepmodule",keepGoing stepModuleCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
("trace", keepGoing traceCmd, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
keepGoingPaths :: ([FilePath] -> GHCi ()) -> (String -> GHCi Bool)
keepGoingPaths a str = a (toArgs str) >> return False
+shortHelpText :: String
shortHelpText = "use :? for help.\n"
+helpText :: String
helpText =
" Commands available from the prompt:\n" ++
"\n" ++
" <statement> evaluate/run <statement>\n" ++
+ " :{\\n ..lines.. \\n:}\\n multiline command\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
- " :browse [*]<module> display the names defined by <module>\n" ++
+ " :browse[!] [-s] [[*]<mod>] display the names defined by module <mod>\n" ++
+ " (!: more details; -s: sort; *: 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" ++
" :info [<name> ...] display information about the given names\n" ++
" :kind <type> show the kind of <type>\n" ++
" :load <filename> ... load module(s) and their dependents\n" ++
- " :module [+/-] [*]<mod> ... set the context for expression evaluation\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" ++
" :type <expr> show the type of <expr>\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 restricted to the current top level decl.\n"++
+ " :stepmodule single-step restricted to the current module\n"++
" :trace trace after stopping at a breakpoint\n"++
" :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
" +t print type after evaluation\n" ++
" -<flags> most GHC command line flags can also be set here\n" ++
" (eg. -v2, -fglasgow-exts, etc.)\n" ++
+ " for GHCi-specific flags, see User's Guide,\n"++
+ " Flag reference, Interactive-mode options\n" ++
"\n" ++
" -- Commands for displaying information:\n" ++
"\n" ++
" :show breaks show the active breakpoints\n" ++
" :show context show the breakpoint context\n" ++
" :show modules show the currently loaded modules\n" ++
+ " :show packages show the currently active package flags\n" ++
+ " :show languages show the currently active language flags\n" ++
" :show <setting> show anything that can be set with :set (e.g. args)\n" ++
"\n"
+findEditor :: IO String
findEditor = do
getEnv "EDITOR"
`IO.catch` \_ -> do
hSetBuffering stdin NoBuffering
-- initial context is just the Prelude
- prel_mod <- GHC.findModule session prel_name (Just basePackageId)
+ prel_mod <- GHC.findModule session (GHC.mkModuleName "Prelude")
+ (Just basePackageId)
GHC.setContext session [] [prel_mod]
#ifdef USE_READLINE
break_ctr = 0,
breaks = [],
tickarrays = emptyModuleEnv,
- cmdqueue = []
+ cmdqueue = [],
+ remembered_ctx = Nothing
}
#ifdef USE_READLINE
return ()
-prel_name = GHC.mkModuleName "Prelude"
-
runGHCi :: [(FilePath, Maybe Phase)] -> Maybe String -> GHCi ()
runGHCi paths maybe_expr = do
let read_dot_files = not opt_IgnoreDotGhci
when (dir_ok && file_ok) $ do
either_hdl <- io (IO.try (openFile "./.ghci" ReadMode))
case either_hdl of
- Left e -> return ()
- Right hdl -> fileLoop hdl False
+ Left _e -> return ()
+ Right hdl -> runCommands (fileLoop hdl False False)
when (read_dot_files) $ do
-- Read in $HOME/.ghci
- either_dir <- io (IO.try (getEnv "HOME"))
+ either_dir <- io (IO.try getHomeDirectory)
case either_dir of
- Left e -> return ()
+ Left _e -> return ()
Right dir -> do
cwd <- io (getCurrentDirectory)
when (dir /= cwd) $ do
when ok $ do
either_hdl <- io (IO.try (openFile file ReadMode))
case either_hdl of
- Left e -> return ()
- Right hdl -> fileLoop hdl False
+ Left _e -> return ()
+ Right hdl -> runCommands (fileLoop hdl False False)
-- Perform a :load for files given on the GHCi command line
-- When in -e mode, if the load fails then we want to stop
| otherwise -> io (ioError err)
Right () -> return ()
#endif
- -- initialise the console if necessary
- io setUpConsole
-
- let msg = if dopt Opt_ShortGhciBanner dflags
- then ghciShortWelcomeMsg
- else ghciWelcomeMsg
- when (verbosity dflags >= 1) $ io $ putStrLn msg
-
-- enter the interactive loop
interactiveLoop is_tty show_prompt
Just expr -> do
io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
+interactiveLoop :: Bool -> Bool -> GHCi ()
interactiveLoop is_tty show_prompt =
-- Ignore ^C exceptions caught here
ghciHandleDyn (\e -> case e of
-- read commands from stdin
#ifdef USE_READLINE
if (is_tty)
- then readlineLoop
- else fileLoop stdin show_prompt
+ then runCommands readlineLoop
+ else runCommands (fileLoop stdin show_prompt is_tty)
#else
- fileLoop stdin show_prompt
+ runCommands (fileLoop stdin show_prompt is_tty)
#endif
-- the same directory while a process is running.
checkPerms :: String -> IO Bool
-checkPerms name =
#ifdef mingw32_HOST_OS
+checkPerms _ =
return True
#else
+checkPerms name =
Util.handle (\_ -> return False) $ do
st <- getFileStatus name
me <- getRealUserID
else return True
#endif
-fileLoop :: Handle -> Bool -> GHCi ()
-fileLoop hdl show_prompt = do
+fileLoop :: Handle -> Bool -> Bool -> GHCi (Maybe String)
+fileLoop hdl show_prompt is_tty = do
when show_prompt $ do
prompt <- mkPrompt
(io (putStr prompt))
l <- io (IO.try (hGetLine hdl))
case l of
- Left e | isEOFError e -> return ()
- | InvalidArgument <- etype -> return ()
- | otherwise -> io (ioError e)
- where etype = ioeGetErrorType e
- -- treat InvalidArgument in the same way as EOF:
- -- this can happen if the user closed stdin, or
- -- perhaps did getContents which closes stdin at
- -- EOF.
- Right l ->
- case removeSpaces l of
- "" -> fileLoop hdl show_prompt
- l -> do quit <- runCommands l
- if quit then return () else fileLoop hdl show_prompt
+ Left e | isEOFError e -> return Nothing
+ | InvalidArgument <- etype -> return Nothing
+ | otherwise -> io (ioError e)
+ where etype = ioeGetErrorType e
+ -- treat InvalidArgument in the same way as EOF:
+ -- this can happen if the user closed stdin, or
+ -- perhaps did getContents which closes stdin at
+ -- EOF.
+ Right l -> do
+ str <- io $ consoleInputToUnicode is_tty l
+ return (Just str)
+#ifdef mingw32_HOST_OS
+-- Convert the console input into Unicode according to the current code page.
+-- The Windows console stores Unicode characters directly, so this is a
+-- rather roundabout way of doing things... oh well.
+-- See #782, #1483, #1649
+consoleInputToUnicode :: Bool -> String -> IO String
+consoleInputToUnicode is_tty str
+ | is_tty = do
+ cp <- System.Win32.getConsoleCP
+ System.Win32.stringToUnicode cp str
+ | otherwise =
+ decodeStringAsUTF8 str
+#else
+-- for Unix, assume the input is in UTF-8 and decode it to a Unicode String.
+-- See #782.
+consoleInputToUnicode :: Bool -> String -> IO String
+consoleInputToUnicode _is_tty str = decodeStringAsUTF8 str
+#endif
+
+decodeStringAsUTF8 :: String -> IO String
+decodeStringAsUTF8 str =
+ withCStringLen str $ \(cstr,len) ->
+ utf8DecodeString (castPtr cstr :: Ptr Word8) len
+
+mkPrompt :: GHCi String
mkPrompt = do
session <- getSession
(toplevs,exports) <- io (GHC.getContext session)
resumes <- io $ GHC.getResumeContext session
+ -- st <- getGHCiState
context_bit <-
case resumes of
[] -> return empty
- r:rs -> do
+ 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 <- io $ GHC.getHistorySpan session hist
+ span <- io$ GHC.getHistorySpan session hist
return (brackets (ppr (negate ix) <> char ':'
<+> ppr span) <> space)
let
- dots | r:rs <- resumes, not (null rs) = text "... "
+ dots | _:rs <- resumes, not (null rs) = text "... "
| otherwise = empty
+
+
modules_bit =
- hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
+ -- ToDo: maybe...
+ -- let (btoplevs, bexports) = fromMaybe ([],[]) (remembered_ctx st) in
+ -- hsep (map (\m -> text "!*" <> ppr (GHC.moduleName m)) btoplevs) <+>
+ -- hsep (map (\m -> char '!' <> ppr (GHC.moduleName m)) bexports) <+>
+ hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
hsep (map (ppr . GHC.moduleName) exports)
deflt_prompt = dots <> context_bit <> modules_bit
#ifdef USE_READLINE
-readlineLoop :: GHCi ()
+readlineLoop :: GHCi (Maybe String)
readlineLoop = do
- session <- getSession
- (mod,imports) <- io (GHC.getContext session)
io yield
saveSession -- for use by completion
- st <- getGHCiState
- mb_span <- getCurrentBreakSpan
prompt <- mkPrompt
l <- io (readline prompt `finally` setNonBlockingFD 0)
- -- readline sometimes puts stdin into blocking mode,
- -- so we need to put it back for the IO library
+ -- readline sometimes puts stdin into blocking mode,
+ -- so we need to put it back for the IO library
splatSavedSession
case l of
- Nothing -> return ()
- Just l ->
- case removeSpaces l of
- "" -> readlineLoop
- l -> do
- io (addHistory l)
- quit <- runCommands l
- if quit then return () else readlineLoop
+ Nothing -> return Nothing
+ Just l -> do
+ io (addHistory l)
+ str <- io $ consoleInputToUnicode True l
+ return (Just str)
#endif
-runCommands :: String -> GHCi Bool
-runCommands cmd = do
- q <- ghciHandle handler (doCommand cmd)
- if q then return True else runNext
+queryQueue :: GHCi (Maybe String)
+queryQueue = do
+ st <- getGHCiState
+ case cmdqueue st of
+ [] -> return Nothing
+ c:cs -> do setGHCiState st{ cmdqueue = cs }
+ return (Just c)
+
+runCommands :: GHCi (Maybe String) -> GHCi ()
+runCommands getCmd = do
+ mb_cmd <- noSpace queryQueue
+ mb_cmd <- maybe (noSpace getCmd) (return . Just) mb_cmd
+ case mb_cmd of
+ Nothing -> return ()
+ Just c -> do
+ b <- ghciHandle handler (doCommand c)
+ if b then return () else runCommands getCmd
where
- runNext = do
- st <- getGHCiState
- case cmdqueue st of
- [] -> return False
- c:cs -> do setGHCiState st{ cmdqueue = cs }
- runCommands c
-
- doCommand (':' : cmd) = specialCommand cmd
- doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
- return False
+ noSpace q = q >>= maybe (return Nothing)
+ (\c->case removeSpaces c of
+ "" -> noSpace q
+ ":{" -> multiLineCmd q
+ c -> return (Just c) )
+ multiLineCmd q = do
+ st <- getGHCiState
+ let p = prompt st
+ setGHCiState st{ prompt = "%s| " }
+ mb_cmd <- collectCommand q ""
+ getGHCiState >>= \st->setGHCiState st{ prompt = p }
+ return mb_cmd
+ -- we can't use removeSpaces for the sublines here, so
+ -- multiline commands are somewhat more brittle against
+ -- fileformat errors (such as \r in dos input on unix),
+ -- we get rid of any extra spaces for the ":}" test;
+ -- we also avoid silent failure if ":}" is not found;
+ -- and since there is no (?) valid occurrence of \r (as
+ -- opposed to its String representation, "\r") inside a
+ -- ghci command, we replace any such with ' ' (argh:-(
+ collectCommand q c = q >>=
+ maybe (io (ioError collectError))
+ (\l->if removeSpaces l == ":}"
+ then return (Just $ removeSpaces c)
+ else collectCommand q (c++map normSpace l))
+ where normSpace '\r' = ' '
+ normSpace c = c
+ -- QUESTION: is userError the one to use here?
+ collectError = userError "unterminated multiline command :{ .. :}"
+ doCommand (':' : cmd) = specialCommand cmd
+ doCommand stmt = do timeIt $ runStmt stmt GHC.RunToCompletion
+ return False
enqueueCommands :: [String] -> GHCi ()
enqueueCommands cmds = do
-- This version is for the GHC command-line option -e. The only difference
-- from runCommand is that it catches the ExitException exception and
-- exits, rather than printing out the exception.
+runCommandEval :: String -> GHCi Bool
runCommandEval c = ghciHandle handleEval (doCommand c)
where
handleEval (ExitException code) = io (exitWith code)
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt step
- afterRunStmt result
+ afterRunStmt (const True) result
-afterRunStmt :: GHC.RunResult -> GHCi Bool
+--afterRunStmt :: GHC.RunResult -> GHCi Bool
-- False <=> the statement failed to compile
-afterRunStmt (GHC.RunException e) = throw e
-afterRunStmt run_result = do
- session <- getSession
+afterRunStmt :: (SrcSpan -> Bool) -> GHC.RunResult -> GHCi Bool
+afterRunStmt _ (GHC.RunException e) = throw e
+afterRunStmt step_here run_result = do
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
case run_result of
GHC.RunOk names -> do
show_types <- isOptionSet ShowType
when show_types $ printTypeOfNames session names
- GHC.RunBreak _ names mb_info -> do
- resumes <- io $ GHC.getResumeContext session
- printForUser $ ptext SLIT("Stopped at") <+>
- ppr (GHC.resumeSpan (head resumes))
- printTypeOfNames session names
- maybe (return ()) runBreakCmd mb_info
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- enqueueCommands [stop st]
- return ()
+ GHC.RunBreak _ names mb_info
+ | isNothing mb_info ||
+ step_here (GHC.resumeSpan $ head resumes) -> do
+ printForUser $ ptext SLIT("Stopped at") <+>
+ ppr (GHC.resumeSpan $ head resumes)
+-- printTypeOfNames session names
+ let namesSorted = sortBy compareNames names
+ tythings <- catMaybes `liftM`
+ io (mapM (GHC.lookupName session) namesSorted)
+ docs <- io$ pprTypeAndContents session [id | AnId id <- tythings]
+ printForUserPartWay docs
+ maybe (return ()) runBreakCmd mb_info
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ enqueueCommands [stop st]
+ return ()
+ | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
+ afterRunStmt step_here >> return ()
_ -> return ()
flushInterpBuffers
let mod = GHC.breakInfo_module info
nm = GHC.breakInfo_number info
st <- getGHCiState
- case [ loc | (i,loc) <- breaks st,
+ case [ loc | (_,loc) <- breaks st,
breakModule loc == mod, breakTick loc == nm ] of
[] -> return ()
loc:_ | null cmd -> return ()
Nothing -> return ()
Just thing -> printTyThing thing
+
+
+
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
specialCommand str = do
lookupCommand :: String -> IO (Maybe Command)
lookupCommand str = do
- cmds <- readIORef commands
+ macros <- readIORef macros_ref
+ let cmds = builtin_commands ++ macros
-- look for exact match first, then the first prefix match
case [ c | c <- cmds, str == cmdName c ] of
c:_ -> return (Just c)
- [] -> case [ c | c@(s,_,_,_) <- cmds, prefixMatch str s ] of
+ [] -> case [ c | c@(s,_,_,_) <- cmds, str `isPrefixOf` s ] of
[] -> return Nothing
c:_ -> return (Just c)
resumes <- io $ GHC.getResumeContext session
case resumes of
[] -> return Nothing
- (r:rs) -> do
+ (r:_) -> do
let ix = GHC.resumeHistoryIx r
if ix == 0
then return (Just (GHC.resumeSpan r))
span <- io $ GHC.getHistorySpan session hist
return (Just span)
+getCurrentBreakModule :: GHCi (Maybe Module)
+getCurrentBreakModule = do
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
+ 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 m _ = io $ putStrLn "This command takes no arguments"
+noArgs _ _ = io $ putStrLn "This command takes no arguments"
help :: String -> GHCi ()
help _ = io (putStr helpText)
info s = do { let names = words s
; session <- getSession
; dflags <- getDynFlags
- ; let exts = dopt Opt_GlasgowExts dflags
- ; mapM_ (infoThing exts session) names }
+ ; let pefas = dopt Opt_PrintExplicitForalls dflags
+ ; mapM_ (infoThing pefas session) names }
where
- infoThing exts session str = io $ do
- names <- GHC.parseName session str
- let filtered = filterOutChildren names
- mb_stuffs <- mapM (GHC.getInfo session) filtered
+ infoThing pefas session str = io $ do
+ names <- GHC.parseName session str
+ mb_stuffs <- mapM (GHC.getInfo session) names
+ let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)
unqual <- GHC.getPrintUnqual session
putStrLn (showSDocForUser unqual $
vcat (intersperse (text "") $
- [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
+ 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 :: [Name] -> [Name]
-filterOutChildren names = filter (not . parent_is_there) names
- where parent_is_there n
--- | Just p <- GHC.nameParent_maybe n = p `elem` names
--- ToDo!!
- | otherwise = False
-
-pprInfo exts (thing, fixity, insts)
- = pprTyThingInContextLoc exts thing
+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
targets <- mapM (\m -> io (GHC.guessTarget m Nothing)) files
session <- getSession
io (mapM_ (GHC.addTarget session) targets)
+ prev_context <- io $ GHC.getContext session
ok <- io (GHC.load session LoadAllTargets)
- afterLoad ok session
+ afterLoad ok session False prev_context
changeDirectory :: String -> GHCi ()
changeDirectory dir = do
graph <- io (GHC.getModuleGraph session)
when (not (null graph)) $
io $ putStr "Warning: changing directory causes all loaded modules to be unloaded,\nbecause the search path has changed.\n"
+ prev_context <- io $ GHC.getContext session
io (GHC.setTargets session [])
io (GHC.load session LoadAllTargets)
- setContextAfterLoad session []
+ setContextAfterLoad session prev_context []
io (GHC.workingDirectoryChanged session)
dir <- expandPath dir
io (setCurrentDirectory dir)
where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
fromTarget _ = Nothing -- when would we get a module target?
-defineMacro :: String -> GHCi ()
-defineMacro s = do
+defineMacro :: Bool{-overwrite-} -> String -> GHCi ()
+defineMacro overwrite s = do
let (macro_name, definition) = break isSpace s
- cmds <- io (readIORef commands)
+ macros <- io (readIORef macros_ref)
+ let defined = map cmdName macros
if (null macro_name)
- then throwDyn (CmdLineError "invalid macro name")
+ then if null defined
+ then io $ putStrLn "no macros defined"
+ else io $ putStr ("the following macros are defined:\n" ++
+ unlines defined)
else do
- if (macro_name `elem` map cmdName cmds)
+ if (not overwrite && macro_name `elem` defined)
then throwDyn (CmdLineError
- ("command '" ++ macro_name ++ "' is already defined"))
+ ("macro '" ++ macro_name ++ "' is already defined"))
else do
+ let filtered = [ cmd | cmd <- macros, cmdName cmd /= macro_name ]
+
-- give the expression a type signature, so we can be sure we're getting
-- something of the right type.
let new_expr = '(' : definition ++ ") :: String -> IO String"
maybe_hv <- io (GHC.compileExpr cms new_expr)
case maybe_hv of
Nothing -> return ()
- Just hv -> io (writeIORef commands --
- (cmds ++ [(macro_name, runMacro hv, False, completeNone)]))
+ Just hv -> io (writeIORef macros_ref --
+ (filtered ++ [(macro_name, runMacro hv, False, completeNone)]))
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
return False
undefineMacro :: String -> GHCi ()
-undefineMacro macro_name = do
- cmds <- io (readIORef commands)
- if (macro_name `elem` map cmdName builtin_commands)
- then throwDyn (CmdLineError
- ("command '" ++ macro_name ++ "' cannot be undefined"))
- else do
- if (macro_name `notElem` map cmdName cmds)
- then throwDyn (CmdLineError
- ("command '" ++ macro_name ++ "' not defined"))
- else do
- io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
+undefineMacro str = mapM_ undef (words str)
+ where undef macro_name = do
+ cmds <- io (readIORef macros_ref)
+ if (macro_name `notElem` map cmdName cmds)
+ then throwDyn (CmdLineError
+ ("macro '" ++ macro_name ++ "' is not defined"))
+ else do
+ io (writeIORef macros_ref (filter ((/= macro_name) . cmdName) cmds))
cmdCmd :: String -> GHCi ()
cmdCmd str = do
loadModule' :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
loadModule' files = do
session <- getSession
+ prev_context <- io $ GHC.getContext session
-- unload first
discardActiveBreakPoints
-- as a ToDo for now.
io (GHC.setTargets session targets)
- doLoad session LoadAllTargets
+ doLoad session False prev_context LoadAllTargets
checkModule :: String -> GHCi ()
checkModule m = do
let modl = GHC.mkModuleName m
session <- getSession
+ prev_context <- io $ GHC.getContext session
result <- io (GHC.checkModule session modl False)
case result of
Nothing -> io $ putStrLn "Nothing"
(text "global names: " <+> ppr global) $$
(text "local names: " <+> ppr local)
_ -> empty))
- afterLoad (successIf (isJust result)) session
+ afterLoad (successIf (isJust result)) session False prev_context
reloadModule :: String -> GHCi ()
reloadModule m = do
- io (revertCAFs) -- always revert CAFs on reload.
- discardActiveBreakPoints
session <- getSession
- doLoad session $ if null m then LoadAllTargets
- else LoadUpTo (GHC.mkModuleName m)
+ prev_context <- io $ GHC.getContext session
+ doLoad session True prev_context $
+ if null m then LoadAllTargets
+ else LoadUpTo (GHC.mkModuleName m)
return ()
-doLoad session howmuch = do
+doLoad :: Session -> Bool -> ([Module],[Module]) -> LoadHowMuch -> GHCi SuccessFlag
+doLoad session retain_context prev_context howmuch = do
-- turn off breakpoints before we load: we can't turn them off later, because
-- the ModBreaks will have gone away.
discardActiveBreakPoints
ok <- io (GHC.load session howmuch)
- afterLoad ok session
+ afterLoad ok session retain_context prev_context
return ok
-afterLoad ok session = do
+afterLoad :: SuccessFlag -> Session -> Bool -> ([Module],[Module]) -> GHCi ()
+afterLoad ok session retain_context prev_context = do
io (revertCAFs) -- always revert CAFs on load.
discardTickArrays
- graph <- io (GHC.getModuleGraph session)
- graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
- setContextAfterLoad session graph'
- modulesLoadedMsg ok (map GHC.ms_mod_name graph')
+ loaded_mod_summaries <- getLoadedModules session
+ let loaded_mods = map GHC.ms_mod loaded_mod_summaries
+ loaded_mod_names = map GHC.moduleName loaded_mods
+ modulesLoadedMsg ok loaded_mod_names
-setContextAfterLoad session [] = do
+ st <- getGHCiState
+ if not retain_context
+ then do
+ setGHCiState st{ remembered_ctx = Nothing }
+ setContextAfterLoad session prev_context loaded_mod_summaries
+ else do
+ -- figure out which modules we can keep in the context, which we
+ -- have to put back, and which we have to remember because they
+ -- are (temporarily) unavailable. See ghci.prog009, #1873, #1360
+ let (as,bs) = prev_context
+ as1 = filter isHomeModule as -- package modules are kept anyway
+ bs1 = filter isHomeModule bs
+ (as_ok, as_bad) = partition (`elem` loaded_mods) as1
+ (bs_ok, bs_bad) = partition (`elem` loaded_mods) bs1
+ (rem_as, rem_bs) = fromMaybe ([],[]) (remembered_ctx st)
+ (rem_as_ok, rem_as_bad) = partition (`elem` loaded_mods) rem_as
+ (rem_bs_ok, rem_bs_bad) = partition (`elem` loaded_mods) rem_bs
+ as' = nub (as_ok++rem_as_ok)
+ bs' = nub (bs_ok++rem_bs_ok)
+ rem_as' = nub (rem_as_bad ++ as_bad)
+ rem_bs' = nub (rem_bs_bad ++ bs_bad)
+
+ -- Put back into the context any modules that we previously had
+ -- to drop because they weren't available (rem_as_ok, rem_bs_ok).
+ setContextKeepingPackageModules session prev_context (as',bs')
+
+ -- If compilation failed, remember any modules that we are unable
+ -- to load, so that we can put them back in the context in the future.
+ case ok of
+ Succeeded -> setGHCiState st{ remembered_ctx = Nothing }
+ Failed -> setGHCiState st{ remembered_ctx = Just (rem_as',rem_bs') }
+
+
+
+setContextAfterLoad :: Session -> ([Module],[Module]) -> [GHC.ModSummary] -> GHCi ()
+setContextAfterLoad session prev [] = do
prel_mod <- getPrelude
- io (GHC.setContext session [] [prel_mod])
-setContextAfterLoad session ms = do
+ setContextKeepingPackageModules session prev ([], [prel_mod])
+setContextAfterLoad session prev ms = do
-- load a target if one is available, otherwise load the topmost module.
targets <- io (GHC.getTargets session)
case [ m | Just m <- map (findTarget ms) targets ] of
= GHC.ms_mod_name summary == m
summary `matches` Target (TargetFile f _) _
| Just f' <- GHC.ml_hs_file (GHC.ms_location summary) = f == f'
- summary `matches` target
+ _ `matches` _
= False
load_this summary | m <- GHC.ms_mod summary = do
b <- io (GHC.moduleIsInterpreted session m)
- if b then io (GHC.setContext session [m] [])
+ if b then setContextKeepingPackageModules session prev ([m], [])
else do
- prel_mod <- getPrelude
- io (GHC.setContext session [] [prel_mod,m])
+ prel_mod <- getPrelude
+ setContextKeepingPackageModules session prev ([],[prel_mod,m])
+
+-- | Keep any package modules (except Prelude) when changing the context.
+setContextKeepingPackageModules
+ :: Session
+ -> ([Module],[Module]) -- previous context
+ -> ([Module],[Module]) -- new context
+ -> GHCi ()
+setContextKeepingPackageModules session prev_context (as,bs) = do
+ let (_,bs0) = prev_context
+ prel_mod <- getPrelude
+ let pkg_modules = filter (\p -> not (isHomeModule p) && p /= prel_mod) bs0
+ let bs1 = if null as then nub (prel_mod : bs) else bs
+ io $ GHC.setContext session as (nub (bs1 ++ pkg_modules))
+isHomeModule :: Module -> Bool
+isHomeModule mod = GHC.modulePackageId mod == mainPackageId
modulesLoadedMsg :: SuccessFlag -> [ModuleName] -> GHCi ()
modulesLoadedMsg ok mods = do
maybe_ty <- io (GHC.exprType cms str)
case maybe_ty of
Nothing -> return ()
- Just ty -> do ty' <- cleanType ty
- printForUser $ text str <> text " :: " <> ppr ty'
+ Just ty -> do dflags <- getDynFlags
+ let pefas = dopt Opt_PrintExplicitForalls dflags
+ printForUser $ text str <+> dcolon
+ <+> pprTypeForUser pefas ty
kindOfType :: String -> GHCi ()
kindOfType str
maybe_ty <- io (GHC.typeKind cms str)
case maybe_ty of
Nothing -> return ()
- Just ty -> printForUser $ text str <> text " :: " <> ppr ty
+ Just ty -> printForUser $ text str <+> dcolon <+> ppr ty
quit :: String -> GHCi Bool
quit _ = return True
-----------------------------------------------------------------------------
-- Browsing a module's contents
-browseCmd :: String -> GHCi ()
-browseCmd m =
+browseCmd :: Bool -> String -> GHCi ()
+browseCmd bang m =
case words m of
- ['*':m] | looksLikeModuleName m -> browseModule m False
- [m] | looksLikeModuleName m -> browseModule m True
+ ['*':s] | looksLikeModuleName s -> do
+ m <- wantInterpretedModule s
+ browseModule bang m False
+ [s] | looksLikeModuleName s -> do
+ m <- lookupModule s
+ browseModule bang m True
+ [] -> do
+ s <- getSession
+ (as,bs) <- io $ GHC.getContext s
+ -- Guess which module the user wants to browse. Pick
+ -- modules that are interpreted first. The most
+ -- recently-added module occurs last, it seems.
+ case (as,bs) of
+ (as@(_:_), _) -> browseModule bang (last as) True
+ ([], bs@(_:_)) -> browseModule bang (last bs) True
+ ([], []) -> throwDyn (CmdLineError ":browse: no current module")
_ -> throwDyn (CmdLineError "syntax: :browse <module>")
-browseModule m exports_only = do
+-- without bang, show items in context of their parents and omit children
+-- with bang, show class methods and data constructors separately, and
+-- indicate import modules, to aid qualifying unqualified names
+-- with sorted, sort items alphabetically
+browseModule :: Bool -> Module -> Bool -> GHCi ()
+browseModule bang modl exports_only = do
s <- getSession
- modl <- if exports_only then lookupModule m
- else wantInterpretedModule m
-
-- Temporarily set the context to the module we're interested in,
-- just so we can get an appropriate PrintUnqualified
(as,bs) <- io (GHC.getContext s)
prel_mod <- getPrelude
io (if exports_only then GHC.setContext s [] [prel_mod,modl]
- else GHC.setContext s [modl] [])
+ else GHC.setContext s [modl] [])
unqual <- io (GHC.getPrintUnqual s)
io (GHC.setContext s as bs)
mb_mod_info <- io $ GHC.getModuleInfo s modl
case mb_mod_info of
- Nothing -> throwDyn (CmdLineError ("unknown module: " ++ m))
+ Nothing -> throwDyn (CmdLineError ("unknown module: " ++
+ GHC.moduleNameString (GHC.moduleName modl)))
Just mod_info -> do
- let names
- | exports_only = GHC.modInfoExports mod_info
- | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
-
- filtered = filterOutChildren names
-
- things <- io $ mapM (GHC.lookupName s) filtered
-
dflags <- getDynFlags
- let exts = dopt Opt_GlasgowExts dflags
- io (putStrLn (showSDocForUser unqual (
- vcat (map (pprTyThingInContext exts) (catMaybes things))
- )))
- -- ToDo: modInfoInstances currently throws an exception for
- -- package modules. When it works, we can do this:
- -- $$ vcat (map GHC.pprInstance (GHC.modInfoInstances mod_info))
+ let names
+ | exports_only = GHC.modInfoExports mod_info
+ | otherwise = GHC.modInfoTopLevelScope mod_info
+ `orElse` []
+
+ -- sort alphabetically name, but putting
+ -- locally-defined identifiers first.
+ -- We would like to improve this; see #1799.
+ sorted_names = loc_sort local ++ occ_sort external
+ where
+ (local,external) = partition ((==modl) . nameModule) names
+ occ_sort = sortBy (compare `on` nameOccName)
+ -- try to sort by src location. If the first name in
+ -- our list has a good source location, then they all should.
+ loc_sort names
+ | n:_ <- names, isGoodSrcSpan (nameSrcSpan n)
+ = sortBy (compare `on` nameSrcSpan) names
+ | otherwise
+ = occ_sort names
+
+ mb_things <- io $ mapM (GHC.lookupName s) sorted_names
+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
+
+ rdr_env <- io $ GHC.getGRE s
+
+ let pefas = dopt Opt_PrintExplicitForalls dflags
+ things | bang = catMaybes mb_things
+ | otherwise = filtered_things
+ pretty | bang = pprTyThing
+ | otherwise = pprTyThingInContext
+
+ labels [] = text "-- not currently imported"
+ labels l = text $ intercalate "\n" $ map qualifier l
+ qualifier = maybe "-- defined locally"
+ (("-- imported from "++) . 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 mods = fn mods
| otherwise = throwDyn (CmdLineError "syntax: :module [+/-] [*]M1 ... [*]Mn")
separate :: Session -> [String] -> [Module] -> [Module]
-> GHCi ([Module],[Module])
-separate session [] as bs = return (as,bs)
+separate _ [] as bs = return (as,bs)
separate session (('*':str):ms) as bs = do
- m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
- b <- io $ GHC.moduleIsInterpreted session m
- if b then separate session ms (m:as) bs
- else throwDyn (CmdLineError ("module '"
- ++ GHC.moduleNameString (GHC.moduleName m)
- ++ "' is not interpreted"))
+ m <- wantInterpretedModule str
+ separate session ms (m:as) bs
separate session (str:ms) as bs = do
- m <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
+ m <- lookupModule str
separate session ms as (m:bs)
newContext :: [String] -> GHCi ()
then text "none."
else hsep (map (\o -> char '+' <> text (optToStr o)) opts)
))
+ dflags <- getDynFlags
+ io $ putStrLn (showSDoc (
+ vcat (text "GHCi-specific dynamic flag settings:"
+ :map (flagSetting dflags) ghciFlags)
+ ))
+ io $ putStrLn (showSDoc (
+ vcat (text "other dynamic, non-language, flag settings:"
+ :map (flagSetting dflags) nonLanguageDynFlags)
+ ))
+ where flagSetting dflags (str,f)
+ | dopt f dflags = text " " <> text "-f" <> text str
+ | otherwise = text " " <> text "-fno-" <> text str
+ (ghciFlags,others) = partition (\(_,f)->f `elem` flags)
+ DynFlags.fFlags
+ nonLanguageDynFlags = filter (\(_,f)->not $ f `elem` map snd xFlags)
+ others
+ flags = [Opt_PrintExplicitForalls
+ ,Opt_PrintBindResult
+ ,Opt_BreakOnException
+ ,Opt_BreakOnError
+ ,Opt_PrintEvldWithShow
+ ]
setCmd str
= case toArgs str of
("args":args) -> setArgs args
("prog":prog) -> setProg prog
- ("prompt":prompt) -> setPrompt (after 6)
- ("editor":cmd) -> setEditor (after 6)
- ("stop":cmd) -> setStop (after 4)
+ ("prompt":_) -> setPrompt (after 6)
+ ("editor":_) -> setEditor (after 6)
+ ("stop":_) -> setStop (after 4)
wds -> setOptions wds
where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
+setArgs, setProg, setOptions :: [String] -> GHCi ()
+setEditor, setStop, setPrompt :: String -> GHCi ()
+
setArgs args = do
st <- getGHCiState
setGHCiState st{ args = args }
setOptions wds =
do -- first, deal with the GHCi opts (+s, +t, etc.)
- let (plus_opts, minus_opts) = partition isPlus wds
+ 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
io (GHC.setTargets session [])
io (GHC.load session LoadAllTargets)
io (linkPackages dflags new_pkgs)
- setContextAfterLoad session []
+ -- package flags changed, we can't re-use any of the old context
+ setContextAfterLoad session ([],[]) []
return ()
= do -- first, deal with the GHCi opts (+s, +t, etc.)
let opts = words str
(minus_opts, rest1) = partition isMinus opts
- (plus_opts, rest2) = partition isPlus rest1
+ (plus_opts, rest2) = partitionWith isPlus rest1
if (not (null rest2))
then io (putStrLn ("unknown option: '" ++ head rest2 ++ "'"))
no_flags <- mapM no_flag minus_opts
newDynFlags no_flags
-isMinus ('-':s) = True
+isMinus :: String -> Bool
+isMinus ('-':_) = True
isMinus _ = False
-isPlus ('+':s) = True
-isPlus _ = False
+isPlus :: String -> Either String String
+isPlus ('+':opt) = Left opt
+isPlus other = Right other
-setOpt ('+':str)
+setOpt, unsetOpt :: String -> GHCi ()
+
+setOpt str
= case strToGHCiOpt str of
Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
Just o -> setOption o
-unsetOpt ('+':str)
+unsetOpt str
= case strToGHCiOpt str of
Nothing -> io (putStrLn ("unknown option: '" ++ str ++ "'"))
Just o -> unsetOption o
-- ---------------------------------------------------------------------------
-- code for `:show'
+showCmd :: String -> GHCi ()
showCmd str = do
st <- getGHCiState
case words str of
["linker"] -> io showLinkerState
["breaks"] -> showBkptTable
["context"] -> showContext
+ ["packages"] -> showPackages
+ ["languages"] -> showLanguages
_ -> throwDyn (CmdLineError "syntax: :show [args|prog|prompt|editor|stop|modules|bindings|breaks|context]")
+showModules :: GHCi ()
showModules = do
session <- getSession
- let show_one ms = do m <- io (GHC.showModule session ms)
- io (putStrLn m)
+ loaded_mods <- getLoadedModules session
+ -- we want *loaded* modules only, see #1734
+ let show_one ms = do m <- io (GHC.showModule session ms); io (putStrLn m)
+ mapM_ show_one loaded_mods
+
+getLoadedModules :: GHC.Session -> GHCi [GHC.ModSummary]
+getLoadedModules session = do
graph <- io (GHC.getModuleGraph session)
- mapM_ show_one graph
+ filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
+showBindings :: GHCi ()
showBindings = do
s <- getSession
- unqual <- io (GHC.getPrintUnqual s)
bindings <- io (GHC.getBindings s)
- mapM_ printTyThing $ sortBy compareTyThings bindings
- return ()
+ docs <- io$ pprTypeAndContents s
+ [ id | AnId id <- sortBy compareTyThings bindings]
+ printForUserPartWay docs
compareTyThings :: TyThing -> TyThing -> Ordering
t1 `compareTyThings` t2 = getName t1 `compareNames` getName t2
printTyThing :: TyThing -> GHCi ()
-printTyThing (AnId id) = do
- ty' <- cleanType (GHC.idType id)
- printForUser $ ppr id <> text " :: " <> ppr ty'
-printTyThing _ = return ()
-
--- if -fglasgow-exts is on we show the foralls, otherwise we don't.
-cleanType :: Type -> GHCi Type
-cleanType ty = do
- dflags <- getDynFlags
- if dopt Opt_GlasgowExts dflags
- then return ty
- else return $! GHC.dropForAlls ty
+printTyThing tyth = do dflags <- getDynFlags
+ let pefas = dopt Opt_PrintExplicitForalls dflags
+ printForUser (pprTyThing pefas tyth)
showBkptTable :: GHCi ()
showBkptTable = do
ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
$$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
+showPackages :: GHCi ()
+showPackages = do
+ pkg_flags <- fmap packageFlags getDynFlags
+ io $ putStrLn $ showSDoc $ vcat $
+ text ("active package flags:"++if null pkg_flags then " none" else "")
+ : map showFlag pkg_flags
+ pkg_ids <- fmap (preloadPackages . pkgState) getDynFlags
+ io $ putStrLn $ showSDoc $ vcat $
+ text "packages currently loaded:"
+ : map (nest 2 . text . packageIdString) pkg_ids
+ where showFlag (ExposePackage p) = text $ " -package " ++ p
+ showFlag (HidePackage p) = text $ " -hide-package " ++ p
+ showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p
+
+showLanguages :: GHCi ()
+showLanguages = do
+ dflags <- getDynFlags
+ io $ putStrLn $ showSDoc $ vcat $
+ text "active language flags:" :
+ [text (" -X" ++ str) | (str,f) <- DynFlags.xFlags, dopt f dflags]
-- -----------------------------------------------------------------------------
-- Completion
completeNone :: String -> IO [String]
-completeNone w = return []
+completeNone _w = return []
+
+completeMacro, completeIdentifier, completeModule,
+ completeHomeModule, completeSetOptions, completeFilename,
+ completeHomeModuleOrFile
+ :: String -> IO [String]
#ifdef USE_READLINE
completeWord :: String -> Int -> Int -> IO (Maybe (String, [String]))
completeWord w start end = do
line <- Readline.getLineBuffer
- case w of
+ let line_words = words (dropWhile isSpace line)
+ case w of
':':_ | all isSpace (take (start-1) line) -> wrapCompleter completeCmd w
_other
- | Just c <- is_cmd line -> do
+ | ((':':c) : _) <- line_words -> do
maybe_cmd <- lookupCommand c
let (n,w') = selectWord (words' 0 line)
case maybe_cmd of
Just (_,_,True,complete) -> let 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
| offset+length x >= start = (start-offset,take (end-offset) x)
| otherwise = selectWord xs
-is_cmd line
- | ((':':w) : _) <- words (dropWhile isSpace line) = Just w
- | otherwise = Nothing
-
+completeCmd :: String -> IO [String]
completeCmd w = do
- cmds <- readIORef commands
- return (filter (w `isPrefixOf`) (map (':':) (map cmdName cmds)))
+ cmds <- readIORef macros_ref
+ return (filter (w `isPrefixOf`) (map (':':)
+ (map cmdName (builtin_commands ++ cmds))))
completeMacro w = do
- cmds <- readIORef commands
- let cmds' = [ cmd | cmd <- map cmdName cmds, cmd `elem` map cmdName builtin_commands ]
- return (filter (w `isPrefixOf`) cmds')
+ cmds <- readIORef macros_ref
+ return (filter (w `isPrefixOf`) (map cmdName cmds))
completeIdentifier w = do
s <- restoreSession
getCommonPrefix :: [String] -> String
getCommonPrefix [] = ""
getCommonPrefix (s:ss) = foldl common s ss
- where common s "" = ""
- common "" s = ""
+ where common _s "" = ""
+ common "" _s = ""
common (c:cs) (d:ds)
| c == d = c : common cs ds
| otherwise = ""
allExposedModules :: DynFlags -> [ModuleName]
allExposedModules dflags
- = map GHC.mkModuleName (concat (map exposedModules (filter exposed (eltsUFM pkg_db))))
+ = concat (map exposedModules (filter exposed (eltsUFM pkg_db)))
where
pkg_db = pkgIdMap (pkgState dflags)
#else
-completeCmd = completeNone
completeMacro = completeNone
completeIdentifier = completeNone
completeModule = completeNone
completeSetOptions = completeNone
completeFilename = completeNone
completeHomeModuleOrFile=completeNone
-completeBkpt = completeNone
#endif
-- ---------------------------------------------------------------------------
io installSignalHandlers
ghciHandle handler (showException exception >> return False)
+showException :: Exception -> GHCi ()
showException (DynException dyn) =
case fromDynamic dyn of
Nothing -> io (putStrLn ("*** Exception: (unknown)"))
expandPath path =
case dropWhile isSpace path of
('~':d) -> do
- tilde <- io (getEnv "HOME") -- will fail if HOME not defined
+ tilde <- io getHomeDirectory -- will fail if HOME not defined
return (tilde ++ '/':d)
other ->
return other
throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
return modl
+wantNameFromInterpretedModule :: (Name -> SDoc -> GHCi ()) -> String
+ -> (Name -> GHCi ())
+ -> GHCi ()
wantNameFromInterpretedModule noCanDo str and_then = do
session <- getSession
names <- io $ GHC.parseName session str
text " is not interpreted"
else and_then n
--- ----------------------------------------------------------------------------
--- Windows console setup
-
-setUpConsole :: IO ()
-setUpConsole = do
-#ifdef mingw32_HOST_OS
- -- On Windows we need to set a known code page, otherwise the characters
- -- we read from the console will be be in some strange encoding, and
- -- similarly for characters we write to the console.
- --
- -- At the moment, GHCi pretends all input is Latin-1. In the
- -- future we should support UTF-8, but for now we set the code pages
- -- to Latin-1.
- --
- -- It seems you have to set the font in the console window to
- -- a Unicode font in order for output to work properly,
- -- otherwise non-ASCII characters are mapped wrongly. sigh.
- -- (see MSDN for SetConsoleOutputCP()).
- --
- setConsoleCP 28591 -- ISO Latin-1
- setConsoleOutputCP 28591 -- ISO Latin-1
-#endif
- return ()
-
-- -----------------------------------------------------------------------------
-- 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
session <- getSession
io $ pprintClosureCommand session bind force str
stepCmd :: String -> GHCi ()
-stepCmd [] = doContinue GHC.SingleStep
+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 = optSrcSpanFileName span == optSrcSpanFileName 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 GHC.RunAndLogSteps
+traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
continueCmd :: String -> GHCi ()
-continueCmd = noArgs $ doContinue GHC.RunToCompletion
+continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
-doContinue :: SingleStep -> GHCi ()
-doContinue step = do
+-- doContinue :: SingleStep -> GHCi ()
+doContinue :: (SrcSpan -> Bool) -> SingleStep -> GHCi ()
+doContinue pred step = do
session <- getSession
runResult <- io $ GHC.resume session step
- afterRunStmt runResult
+ afterRunStmt pred runResult
return ()
abandonCmd :: String -> GHCi ()
resumes <- io $ GHC.getResumeContext s
case resumes of
[] -> io $ putStrLn "Not stopped at a breakpoint"
- (r:rs) -> do
+ (r:_) -> do
let hist = GHC.resumeHistory r
(took,rest) = splitAt num hist
spans <- mapM (io . GHC.getHistorySpan s) took
- let nums = map (printf "-%-3d:") [(1::Int)..]
- printForUser (vcat (zipWith (<+>) (map text nums) (map ppr spans)))
+ let nums = map (printf "-%-3d:") [(1::Int)..]
+ let names = map GHC.historyEnclosingDecl took
+ printForUser (vcat(zipWith3
+ (\x y z -> x <+> y <+> z)
+ (map text nums)
+ (map (bold . ppr) names)
+ (map (parens . ppr) spans)))
io $ putStrLn $ if null rest then "<end of history>" else "..."
+bold :: SDoc -> SDoc
+bold c | do_bold = text start_bold <> c <> text end_bold
+ | otherwise = c
+
backCmd :: String -> GHCi ()
backCmd = noArgs $ do
s <- getSession
- (names, ix, span) <- io $ GHC.back s
+ (names, _, span) <- io $ GHC.back s
printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
printTypeOfNames s names
-- run the command set with ":set stop <cmd>"
breakSwitch :: Session -> [String] -> GHCi ()
breakSwitch _session [] = do
io $ putStrLn "The break command requires at least one argument."
-breakSwitch session args@(arg1:rest)
+breakSwitch session (arg1:rest)
| looksLikeModuleName arg1 = do
mod <- wantInterpretedModule arg1
- breakByModule session mod rest
+ breakByModule mod rest
| all isDigit arg1 = do
(toplevel, _) <- io $ GHC.getContext session
case toplevel of
noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
-breakByModule :: Session -> Module -> [String] -> GHCi ()
-breakByModule session mod args@(arg1:rest)
+breakByModule :: Module -> [String] -> GHCi ()
+breakByModule mod (arg1:rest)
| all isDigit arg1 = do -- looks like a line number
breakByModuleLine mod (read arg1) rest
- | otherwise = io $ putStrLn "Invalid arguments to :break"
+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 = io $ putStrLn "Invalid arguments to :break"
+ | otherwise = breakSyntax
+
+breakSyntax :: a
+breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
findBreakAndSet mod lookupTickTree = do
Nothing -> io $ putStrLn $ "No breakpoints found at that location."
Just (tick, span) -> do
success <- io $ setBreakFlag True breakArray tick
- session <- getSession
if success
then do
(alreadySet, nm) <-
findBreakByLine line arr
| not (inRange (bounds arr) line) = Nothing
| otherwise =
- listToMaybe (sortBy leftmost_largest complete) `mplus`
- listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
- listToMaybe (sortBy rightmost ticks)
+ 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@(nm,span) <- ticks,
+ starts_here = [ tick | tick@(_,span) <- ticks,
GHC.srcSpanStartLine span == line ]
(complete,incomplete) = partition ends_here starts_here
- where ends_here (nm,span) = GHC.srcSpanEndLine span == line
+ 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 contains) `mplus`
- listToMaybe (sortBy leftmost_smallest after_here)
+ 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@(nm,span) <- ticks, span `spans` (line,col),
+ 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@(nm,span) <- ticks,
+ after_here = [ tick | tick@(_,span) <- ticks,
GHC.srcSpanStartLine span == line,
GHC.srcSpanStartCol span >= col ]
-
-leftmost_smallest (_,a) (_,b) = a `compare` b
-leftmost_largest (_,a) (_,b) = (GHC.srcSpanStart a `compare` GHC.srcSpanStart b)
- `thenCmp`
- (GHC.srcSpanEnd b `compare` GHC.srcSpanEnd a)
-rightmost (_,a) (_,b) = b `compare` a
-
-spans :: SrcSpan -> (Int,Int) -> Bool
-spans span (l,c) = GHC.srcSpanStart span <= loc && loc <= GHC.srcSpanEnd span
- where loc = GHC.mkSrcLoc (GHC.srcSpanFile span) l c
-
--- for now, use ANSI bold on Unixy systems. On Windows, we add a line
--- of carets under the active expression instead. The Windows console
--- doesn't support ANSI escape sequences, and most Unix terminals
--- (including xterm) do, so this is a reasonable guess until we have a
--- proper termcap/terminfo library.
-#if !defined(mingw32_TARGET_OS)
-do_bold = True
-#else
-do_bold = False
-#endif
-
-start_bold = BS.pack "\ESC[1m"
-end_bold = BS.pack "\ESC[0m"
+-- 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"
+ `Exception.catch` \_ -> return "TERM not set"
+
+start_bold :: String
+start_bold = "\ESC[1m"
+end_bold :: String
+end_bold = "\ESC[0m"
listCmd :: String -> GHCi ()
listCmd "" = do
| otherwise -> printForUser $ text "unable to list source for" <+> ppr span
listCmd str = list2 (words str)
+list2 :: [String] -> GHCi ()
list2 [arg] | all isDigit arg = do
session <- getSession
(toplevel, _) <- io $ GHC.getContext session
-- | 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
- pwd <- getEnv "PWD"
- contents <- BS.readFile (pwd `joinFileName` unpackFS file)
+ contents <- BS.readFile (unpackFS file)
let
lines = BS.split '\n' contents
these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
line_nos = [ fst_line .. ]
highlighted | do_highlight = zipWith highlight line_nos these_lines
- | otherwise = these_lines
+ | otherwise = [\p -> BS.concat[p,l] | l <- these_lines]
bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
- prefixed = zipWith BS.append bs_line_nos highlighted
+ prefixed = zipWith ($) highlighted bs_line_nos
--
- BS.putStrLn (BS.join (BS.pack "\n") prefixed)
+ BS.putStrLn (BS.intercalate (BS.pack "\n") prefixed)
where
file = GHC.srcSpanFile span
line1 = GHC.srcSpanStartLine span
highlight | do_bold = highlight_bold
| otherwise = highlight_carets
- highlight_bold no line
+ 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 [a,start_bold,b,end_bold,c]
+ 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 [a, start_bold, b]
+ BS.concat [prefix, a, BS.pack start_bold, b]
| no == line2
= let (a,b) = BS.splitAt col2 line in
- BS.concat [a, end_bold, b]
- | otherwise = line
+ BS.concat [prefix, a, BS.pack end_bold, b]
+ | otherwise = BS.concat [prefix, line]
- highlight_carets no line
+ highlight_carets no line prefix
| no == line1 && no == line2
- = BS.concat [line, nl, indent, BS.replicate col1 ' ',
+ = BS.concat [prefix, line, nl, indent, BS.replicate col1 ' ',
BS.replicate (col2-col1) '^']
| no == line1
- = BS.concat [line, nl, indent, BS.replicate col1 ' ',
- BS.replicate (BS.length line-col1) '^']
+ = BS.concat [indent, BS.replicate (col1 - 2) ' ', BS.pack "vv", nl,
+ prefix, line]
| no == line2
- = BS.concat [line, nl, indent, BS.replicate col2 '^']
- | otherwise = line
+ = BS.concat [prefix, line, nl, indent, BS.replicate col2 ' ',
+ BS.pack "^^"]
+ | otherwise = BS.concat [prefix, line]
where
- indent = BS.pack " "
+ indent = BS.pack (" " ++ replicate (length (show no)) ' ')
nl = BS.singleton '\n'
-- --------------------------------------------------------------------------
case lookupModuleEnv arrmap modl of
Just arr -> return arr
Nothing -> do
- (breakArray, ticks) <- getModBreak modl
+ (_breakArray, ticks) <- getModBreak modl
let arr = mkTickArray (assocs ticks)
setGHCiState st{tickarrays = extendModuleEnv arrmap modl arr}
return arr
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)