-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------
-module InteractiveUI (
- interactiveUI,
- ghciWelcomeMsg
- ) where
+module InteractiveUI ( interactiveUI, ghciWelcomeMsg ) where
#include "HsVersions.h"
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
Type, Module, ModuleName, TyThing(..), Phase,
- BreakIndex, Name, SrcSpan, Resume, SingleStep )
+ BreakIndex, SrcSpan, Resume, SingleStep )
import DynFlags
import Packages
import PackageConfig
import PprTyThing
import Outputable hiding (printForUser)
import Module -- for ModuleEnv
+import Name
-- Other random utilities
import Digraph
import FastString
#ifndef mingw32_HOST_OS
-import System.Posix
-#if __GLASGOW_HASKELL__ > 504
- hiding (getEnv)
-#endif
+import System.Posix hiding (getEnv)
#else
import GHC.ConsoleHandler ( flushConsole )
import System.Win32 ( setConsoleCP, setConsoleOutputCP )
-----------------------------------------------------------------------------
-ghciWelcomeMsg =
- " ___ ___ _\n"++
- " / _ \\ /\\ /\\/ __(_)\n"++
- " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
- "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
- "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
+ghciWelcomeMsg :: String
+ghciWelcomeMsg = "GHCi, version " ++ cProjectVersion ++
+ ": http://www.haskell.org/ghc/ :? for help"
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
cmdName (n,_,_,_) = n
("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
("continue", keepGoing continueCmd, False, completeNone),
+ ("cmd", keepGoing cmdCmd, False, completeIdentifier),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
("delete", keepGoing deleteCmd, False, completeNone),
" :add <filename> ... add module(s) to the current target set\n" ++
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
+ " :cmd <expr> run the commands returned by <expr>::IO String\n" ++
" :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
" :edit <file> edit file\n" ++
" :forward go forward in the history (after :back)\n" ++
" :history [<n>] show the last <n> items in the history (after :trace)\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"++
" :trace trace after stopping at a breakpoint\n"++
" :trace <expr> trace into <expr> (remembers breakpoints for :history)\n"++
- " :sprint [<name> ...] simplifed version of :print\n" ++
"\n" ++
" -- Commands for changing settings:\n" ++
newStablePtr stdout
newStablePtr stderr
- -- Initialise buffering for the *interpreted* I/O system
+ -- Initialise buffering for the *interpreted* I/O system
initInterpBuffering session
when (isNothing maybe_expr) $ 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
-
- -- initial context is just the Prelude
+ -- 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
+
+ -- initial context is just the Prelude
prel_mod <- GHC.findModule session prel_name (Just basePackageId)
GHC.setContext session [] [prel_mod]
let show_prompt = verbosity dflags > 0 || is_tty
case maybe_expr of
- Nothing ->
+ Nothing ->
do
#if defined(mingw32_HOST_OS)
- -- The win32 Console API mutates the first character of
+ -- The win32 Console API mutates the first character of
-- type-ahead when reading from it in a non-buffered manner. Work
-- around this by flushing the input buffer of type-ahead characters,
-- but only if stdin is available.
flushed <- io (IO.try (GHC.ConsoleHandler.flushConsole stdin))
- case flushed of
- Left err | isDoesNotExistError err -> return ()
- | otherwise -> io (ioError err)
- Right () -> return ()
+ case flushed of
+ Left err | isDoesNotExistError err -> return ()
+ | otherwise -> io (ioError err)
+ Right () -> return ()
#endif
- -- initialise the console if necessary
- io setUpConsole
+ -- initialise the console if necessary
+ io setUpConsole
- -- enter the interactive loop
- interactiveLoop is_tty show_prompt
- Just expr -> do
- -- just evaluate the expression we were given
- runCommandEval expr
- return ()
+ -- enter the interactive loop
+ interactiveLoop is_tty show_prompt
+ Just expr -> do
+ -- just evaluate the expression we were given
+ runCommandEval expr
+ return ()
-- and finally, exit
io $ do when (verbosity dflags > 0) $ putStrLn "Leaving GHCi."
runStmt :: String -> SingleStep -> GHCi Bool
runStmt stmt step
| null (filter (not.isSpace) stmt) = return False
+ | ["import", mod] <- words stmt = keepGoing setContext ('+':mod)
| otherwise
= do st <- getGHCiState
session <- getSession
case run_result of
GHC.RunOk names -> do
show_types <- isOptionSet ShowType
- when show_types $ mapM_ (showTypeOfName session) names
+ 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))
- mapM_ (showTypeOfName session) names
+ printTypeOfNames session names
maybe (return ()) runBreakCmd mb_info
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
| otherwise -> do enqueueCommands [cmd]; return ()
where cmd = onBreakCmd loc
-showTypeOfName :: Session -> Name -> GHCi ()
-showTypeOfName session n
+printTypeOfNames :: Session -> [Name] -> GHCi ()
+printTypeOfNames session names
+ = mapM_ (printTypeOfName session) $ sortBy compareNames names
+
+compareNames :: Name -> Name -> Ordering
+n1 `compareNames` n2 = compareWith n1 `compare` compareWith n2
+ where compareWith n = (getOccString n, getSrcSpan n)
+
+printTypeOfName :: Session -> Name -> GHCi ()
+printTypeOfName session n
= do maybe_tything <- io (GHC.lookupName session n)
- case maybe_tything of
- Nothing -> return ()
- Just thing -> showTyThing thing
+ case maybe_tything of
+ Nothing -> return ()
+ Just thing -> printTyThing thing
specialCommand :: String -> GHCi Bool
specialCommand ('!':str) = shellEscape (dropWhile isSpace str)
-- 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)
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
+ infoThing pefas session str = io $ do
names <- GHC.parseName session str
let filtered = filterOutChildren names
mb_stuffs <- mapM (GHC.getInfo session) filtered
unqual <- GHC.getPrintUnqual session
putStrLn (showSDocForUser unqual $
vcat (intersperse (text "") $
- [ pprInfo exts stuff | Just stuff <- mb_stuffs ]))
+ [ pprInfo pefas stuff | Just stuff <- mb_stuffs ]))
-- Filter out names whose parent is also there Good
-- example is '[]', which is both a type and data
-- ToDo!!
| otherwise = False
-pprInfo exts (thing, fixity, insts)
- = pprTyThingInContextLoc exts thing
+pprInfo :: PrintExplicitForalls -> (TyThing, Fixity, [GHC.Instance]) -> SDoc
+pprInfo pefas (thing, fixity, insts)
+ = pprTyThingInContextLoc pefas thing
$$ show_fixity fixity
$$ vcat (map GHC.pprInstance insts)
where
io (setCurrentDirectory dir)
editFile :: String -> GHCi ()
-editFile str
- | null str = do
- -- find the name of the "topmost" file loaded
- session <- getSession
- graph0 <- io (GHC.getModuleGraph session)
- graph1 <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph0
- let graph2 = flattenSCCs (GHC.topSortModuleGraph True graph1 Nothing)
- case GHC.ml_hs_file (GHC.ms_location (last graph2)) of
- Just file -> do_edit file
- Nothing -> throwDyn (CmdLineError "unknown file name")
- | otherwise = do_edit str
- where
- do_edit file = do
- st <- getGHCiState
- let cmd = editor st
- when (null cmd) $
- throwDyn (CmdLineError "editor not set, use :set editor")
- io $ system (cmd ++ ' ':file)
- return ()
+editFile str =
+ do file <- if null str then chooseEditFile else return str
+ st <- getGHCiState
+ let cmd = editor st
+ when (null cmd)
+ $ throwDyn (CmdLineError "editor not set, use :set editor")
+ io $ system (cmd ++ ' ':file)
+ return ()
+
+-- The user didn't specify a file so we pick one for them.
+-- Our strategy is to pick the first module that failed to load,
+-- or otherwise the first target.
+--
+-- XXX: Can we figure out what happened if the depndecy analysis fails
+-- (e.g., because the porgrammeer mistyped the name of a module)?
+-- XXX: Can we figure out the location of an error to pass to the editor?
+-- XXX: if we could figure out the list of errors that occured during the
+-- last load/reaload, then we could start the editor focused on the first
+-- of those.
+chooseEditFile :: GHCi String
+chooseEditFile =
+ do session <- getSession
+ let hasFailed x = io $ fmap not $ GHC.isLoaded session $ GHC.ms_mod_name x
+
+ graph <- io (GHC.getModuleGraph session)
+ 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 <- io (GHC.getTargets session)
+ case msum (map fromTarget targets) of
+ Just file -> return file
+ Nothing -> throwDyn (CmdLineError "No files to edit.")
+
+ where fromTarget (GHC.Target (GHC.TargetFile f _) _) = Just f
+ fromTarget _ = Nothing -- when would we get a module target?
defineMacro :: String -> GHCi ()
defineMacro s = do
else do
io (writeIORef commands (filter ((/= macro_name) . cmdName) cmds))
+cmdCmd :: String -> GHCi ()
+cmdCmd str = do
+ let expr = '(' : str ++ ") :: IO String"
+ session <- getSession
+ maybe_hv <- io (GHC.compileExpr session expr)
+ case maybe_hv of
+ Nothing -> return ()
+ Just hv -> do
+ cmds <- io $ (unsafeCoerce# hv :: IO String)
+ enqueueCommands (lines cmds)
+ return ()
loadModule :: [(FilePath, Maybe Phase)] -> GHCi SuccessFlag
loadModule fs = timeIt (loadModule' fs)
checkModule m = do
let modl = GHC.mkModuleName m
session <- getSession
- result <- io (GHC.checkModule session modl)
+ result <- io (GHC.checkModule session modl False)
case result of
Nothing -> io $ putStrLn "Nothing"
Just r -> io $ putStrLn (showSDoc (
afterLoad (successIf (isJust result)) session
reloadModule :: String -> GHCi ()
-reloadModule "" = do
- io (revertCAFs) -- always revert CAFs on reload.
- discardActiveBreakPoints
- session <- getSession
- doLoad session LoadAllTargets
- return ()
reloadModule m = do
io (revertCAFs) -- always revert CAFs on reload.
discardActiveBreakPoints
session <- getSession
- doLoad session (LoadUpTo (GHC.mkModuleName m))
+ doLoad session $ if null m then LoadAllTargets
+ else LoadUpTo (GHC.mkModuleName m)
return ()
doLoad session howmuch = do
things <- io $ mapM (GHC.lookupName s) filtered
dflags <- getDynFlags
- let exts = dopt Opt_GlasgowExts dflags
+ let pefas = dopt Opt_PrintExplicitForalls dflags
io (putStrLn (showSDocForUser unqual (
- vcat (map (pprTyThingInContext exts) (catMaybes things))
+ vcat (map (pprTyThingInContext pefas) (catMaybes things))
)))
-- ToDo: modInfoInstances currently throws an exception for
-- package modules. When it works, we can do this:
s <- getSession
unqual <- io (GHC.getPrintUnqual s)
bindings <- io (GHC.getBindings s)
- mapM_ showTyThing bindings
+ mapM_ printTyThing $ sortBy compareTyThings bindings
return ()
-showTyThing (AnId id) = do
+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'
-showTyThing _ = return ()
+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
+ if dopt Opt_PrintExplicitForalls dflags
then return ty
else return $! GHC.dropForAlls ty
[] -> return ()
(n:_) -> do
let modl = GHC.nameModule n
+ if not (GHC.isExternalName n)
+ then noCanDo n $ ppr n <>
+ text " is not defined in an interpreted module"
+ else do
is_interpreted <- io (GHC.moduleIsInterpreted session modl)
if not is_interpreted
then noCanDo n $ text "module " <> ppr modl <>
s <- getSession
(names, ix, span) <- io $ GHC.back s
printForUser $ ptext SLIT("Logged breakpoint at") <+> ppr span
- mapM_ (showTypeOfName s) names
+ printTypeOfNames s names
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
enqueueCommands [stop st]
printForUser $ (if (ix == 0)
then ptext SLIT("Stopped at")
else ptext SLIT("Logged breakpoint at")) <+> ppr span
- mapM_ (showTypeOfName s) names
+ printTypeOfNames s names
-- run the command set with ":set stop <cmd>"
st <- getGHCiState
enqueueCommands [stop st]
breakByModule session mod args@(arg1:rest)
| all isDigit arg1 = do -- looks like a line number
breakByModuleLine mod (read arg1) rest
- | otherwise = io $ putStrLn "Invalid arguments to :break"
+breakByModule session mod _
+ = 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 = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
findBreakAndSet mod lookupTickTree = do
findBreakByCoord mb_file (line, col) arr
| not (inRange (bounds arr) line) = Nothing
| otherwise =
- listToMaybe (sortBy rightmost contains)
+ listToMaybe (sortBy rightmost contains) `mplus`
+ listToMaybe (sortBy leftmost_smallest after_here)
where
ticks = arr ! line
| Just f <- mb_file = GHC.srcSpanFile span == f
| otherwise = True
+ after_here = [ tick | tick@(nm,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)
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"
| otherwise = 1
pad_after = 1
- highlight no line
+ highlight | do_bold = highlight_bold
+ | otherwise = highlight_carets
+
+ highlight_bold no line
| no == line1 && no == line2
= let (a,r) = BS.splitAt col1 line
(b,c) = BS.splitAt (col2-col1) r
BS.concat [a, end_bold, b]
| otherwise = line
+ highlight_carets no line
+ | no == line1 && no == line2
+ = BS.concat [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) '^']
+ | no == line2
+ = BS.concat [line, nl, indent, BS.replicate col2 '^']
+ | otherwise = line
+ where
+ indent = BS.pack " "
+ nl = BS.singleton '\n'
+
-- --------------------------------------------------------------------------
-- Tick arrays