-- (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 UniqFM
+import HscTypes ( implicitTyThings )
import PprTyThing
import Outputable hiding (printForUser)
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
#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
("browse", keepGoing browseCmd, False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
- ("continue", continueCmd, False, completeNone),
+ ("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),
("set", keepGoing setCmd, True, completeSetOptions),
("show", keepGoing showCmd, False, completeNone),
("sprint", keepGoing sprintCmd, False, completeIdentifier),
- ("step", stepCmd, False, completeIdentifier),
+ ("step", keepGoing stepCmd, False, completeIdentifier),
+ ("stepover", keepGoing stepOverCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
- ("trace", traceCmd, False, completeIdentifier),
+ ("trace", keepGoing traceCmd, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
("unset", keepGoing unsetOptions, True, completeSetOptions)
]
" :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" ++
" :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" ++
" :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"++
+ " :stepover (locally) single-step over function applications"++
" :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]
prelude = prel_mod,
break_ctr = 0,
breaks = [],
- tickarrays = emptyModuleEnv
+ tickarrays = emptyModuleEnv,
+ cmdqueue = []
}
#ifdef USE_READLINE
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."
Right l ->
case removeSpaces l of
"" -> fileLoop hdl show_prompt
- l -> do quit <- runCommand l
+ l -> do quit <- runCommands l
if quit then return () else fileLoop hdl show_prompt
-stringLoop :: [String] -> GHCi Bool{-True: we quit-}
-stringLoop [] = return False
-stringLoop (s:ss) = do
- case removeSpaces s of
- "" -> stringLoop ss
- l -> do quit <- runCommand l
- if quit then return True else stringLoop ss
-
mkPrompt = do
session <- getSession
(toplevs,exports) <- io (GHC.getContext session)
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
"" -> readlineLoop
l -> do
io (addHistory l)
- quit <- runCommand l
+ quit <- runCommands l
if quit then return () else readlineLoop
#endif
-runCommand :: String -> GHCi Bool
-runCommand c = ghciHandle handler (doCommand c)
- where
- doCommand (':' : command) = specialCommand command
- doCommand stmt
- = do timeIt $ runStmt stmt GHC.RunToCompletion
- return False
+runCommands :: String -> GHCi Bool
+runCommands cmd = do
+ q <- ghciHandle handler (doCommand cmd)
+ if q then return True else runNext
+ 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
+
+enqueueCommands :: [String] -> GHCi ()
+enqueueCommands cmds = do
+ st <- getGHCiState
+ setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
+
-- This version is for the GHC command-line option -e. The only difference
-- from runCommand is that it catches the ExitException exception and
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
result <- io $ withProgName (progname st) $ withArgs (args st) $
GHC.runStmt session stmt step
- afterRunStmt result
- return (isRunResultOk result)
+ afterRunStmt (const True) result
-afterRunStmt :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
-afterRunStmt run_result = do
- mb_result <- switchOnRunResult run_result
- -- possibly print the type and revert CAFs after evaluating an expression
- show_types <- isOptionSet ShowType
- session <- getSession
- case mb_result of
- Nothing -> return ()
- Just (is_break,names) ->
- when (is_break || show_types) $
- mapM_ (showTypeOfName session) names
-
+--afterRunStmt :: GHC.RunResult -> GHCi Bool
+ -- False <=> the statement failed to compile
+afterRunStmt _ (GHC.RunException e) = throw e
+afterRunStmt pred 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
+ | isNothing mb_info ||
+ pred (GHC.resumeSpan $ head resumes) -> do
+ 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 ()
+ | otherwise -> io(GHC.resume session GHC.SingleStep) >>=
+ afterRunStmt pred >> return ()
+ _ -> return ()
+
flushInterpBuffers
io installSignalHandlers
b <- isOptionSet RevertCAFs
io (when b revertCAFs)
- return mb_result
-
-
-switchOnRunResult :: GHC.RunResult -> GHCi (Maybe (Bool,[Name]))
-switchOnRunResult GHC.RunFailed = return Nothing
-switchOnRunResult (GHC.RunException e) = throw e
-switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
-switchOnRunResult (GHC.RunBreak threadId names info) = do
- session <- getSession
- Just mod_info <- io $ GHC.getModuleInfo session (GHC.breakInfo_module info)
- let modBreaks = GHC.modInfoModBreaks mod_info
- let ticks = GHC.modBreaks_locs modBreaks
-
- -- display information about the breakpoint
- let location = ticks ! GHC.breakInfo_number info
- printForUser $ ptext SLIT("Stopped at") <+> ppr location
-
- -- run the command set with ":set stop <cmd>"
- st <- getGHCiState
- runCommand (stop st)
+ return (case run_result of GHC.RunOk _ -> True; _ -> False)
- return (Just (True,names))
-
-
-isRunResultOk :: GHC.RunResult -> Bool
-isRunResultOk (GHC.RunOk _) = True
-isRunResultOk _ = False
-
-
-showTypeOfName :: Session -> Name -> GHCi ()
-showTypeOfName session n
+runBreakCmd :: GHC.BreakInfo -> GHCi ()
+runBreakCmd info = do
+ let mod = GHC.breakInfo_module info
+ nm = GHC.breakInfo_number info
+ st <- getGHCiState
+ case [ loc | (i,loc) <- breaks st,
+ breakModule loc == mod, breakTick loc == nm ] of
+ [] -> return ()
+ loc:_ | null cmd -> return ()
+ | otherwise -> do enqueueCommands [cmd]; return ()
+ where cmd = onBreakCmd loc
+
+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)
+getCurrentBreakTick :: GHCi (Maybe BreakIndex)
+getCurrentBreakTick = do
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
+ case resumes of
+ [] -> return Nothing
+ (r:rs) -> do
+ let ix = GHC.resumeHistoryIx r
+ if ix == 0
+ then return (GHC.breakInfo_number `fmap` GHC.resumeBreakInfo r)
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ let tick = GHC.getHistoryTick hist
+ return (Just tick)
+
getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
getCurrentBreakSpan = do
session <- getSession
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:rs) -> 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
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
runMain :: String -> GHCi ()
runMain args = do
let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
- runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
- return ()
+ enqueueCommands ['[': ss ++ "] `System.Environment.withArgs` main"]
addModule :: [FilePath] -> GHCi ()
addModule files = do
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
runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
runMacro fun s = do
str <- io ((unsafeCoerce# fun :: String -> IO String) s)
- stringLoop (lines str)
+ enqueueCommands (lines str)
+ return False
undefineMacro :: String -> GHCi ()
undefineMacro macro_name = 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)
session <- getSession
-- unload first
+ discardActiveBreakPoints
io (GHC.setTargets session [])
io (GHC.load session LoadAllTargets)
-- as a ToDo for now.
io (GHC.setTargets session targets)
- ok <- io (GHC.load session LoadAllTargets)
- afterLoad ok session
- return ok
+ doLoad session LoadAllTargets
checkModule :: String -> GHCi ()
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.
- session <- getSession
- ok <- io (GHC.load session LoadAllTargets)
- afterLoad ok session
reloadModule m = do
- io (revertCAFs) -- always revert CAFs on reload.
session <- getSession
- ok <- io (GHC.load session (LoadUpTo (GHC.mkModuleName m)))
+ doLoad session $ if null m then LoadAllTargets
+ else LoadUpTo (GHC.mkModuleName m)
+ return ()
+
+doLoad session 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
+ return ok
afterLoad ok session = do
io (revertCAFs) -- always revert CAFs on load.
discardTickArrays
- discardActiveBreakPoints
graph <- io (GHC.getModuleGraph session)
graph' <- filterM (io . GHC.isLoaded session . GHC.ms_mod_name) graph
setContextAfterLoad session graph'
Just mod_info -> do
let names
| exports_only = GHC.modInfoExports mod_info
- | otherwise = fromMaybe [] (GHC.modInfoTopLevelScope mod_info)
+ | otherwise = GHC.modInfoTopLevelScope mod_info
+ `orElse` []
- filtered = filterOutChildren names
-
- things <- io $ mapM (GHC.lookupName s) filtered
+ mb_things <- io $ mapM (GHC.lookupName s) names
+ let filtered_things = filterOutChildren (\t -> t) (catMaybes mb_things)
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) filtered_things)
)))
-- ToDo: modInfoInstances currently throws an exception for
-- package modules. When it works, we can do this:
st <- getGHCiState
setGHCiState st{ editor = cmd }
+setStop str@(c:_) | isDigit c
+ = do let (nm_str,rest) = break (not.isDigit) str
+ nm = read nm_str
+ st <- getGHCiState
+ let old_breaks = breaks st
+ if all ((/= nm) . fst) old_breaks
+ then printForUser (text "Breakpoint" <+> ppr nm <+>
+ text "does not exist")
+ else do
+ let new_breaks = map fn old_breaks
+ fn (i,loc) | i == nm = (i,loc { onBreakCmd = dropWhile isSpace rest })
+ | otherwise = (i,loc)
+ setGHCiState st{ breaks = new_breaks }
setStop cmd = do
st <- getGHCiState
setGHCiState st{ stop = cmd }
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 <>
session <- getSession
io $ pprintClosureCommand session bind force str
-stepCmd :: String -> GHCi Bool
-stepCmd [] = doContinue GHC.SingleStep
-stepCmd expression = runStmt expression GHC.SingleStep
+stepCmd :: String -> GHCi ()
+stepCmd [] = doContinue (const True) GHC.SingleStep
+stepCmd expression = do runStmt expression GHC.SingleStep; return ()
-traceCmd :: String -> GHCi Bool
-traceCmd [] = doContinue GHC.RunAndLogSteps
-traceCmd expression = runStmt expression GHC.RunAndLogSteps
-
-continueCmd :: String -> GHCi Bool
-continueCmd [] = doContinue GHC.RunToCompletion
-continueCmd other = do
- io $ putStrLn "The continue command accepts no arguments."
- return False
-
-doContinue :: SingleStep -> GHCi Bool
-doContinue step = do
+stepOverCmd [] = do
+ mb_span <- getCurrentBreakSpan
+ session <- getSession
+ case mb_span of
+ Nothing -> stepCmd []
+ Just curr_loc -> do
+ Just tick <- getCurrentBreakTick
+ Just mod <- getCurrentBreakModule
+ parent <- io$ GHC.findEnclosingDeclSpanByTick session mod tick
+ allTicksRightmost <- (sortBy rightmost . map snd) `fmap`
+ ticksIn mod parent
+ let lastTick = null allTicksRightmost ||
+ head allTicksRightmost == curr_loc
+ if not lastTick
+ then let f t = t `isSubspanOf` parent &&
+ (curr_loc `leftmost_largest` t == LT)
+ in doContinue f GHC.SingleStep
+ else printForUser (text "Warning: no more breakpoints in this function body, switching to :step") >>
+ doContinue (const True) GHC.SingleStep
+
+stepOverCmd expression = stepCmd expression
+
+{-
+ The first tricky bit in stepOver is detecting that we have
+ arrived to the last tick in an expression, in which case we must
+ step normally to the next tick.
+ What we do is:
+ 1. Retrieve the enclosing expression block (with a tick)
+ 2. Retrieve all the ticks there and sort them out by 'rightness'
+ 3. See if the current tick turned out the first one in the list
+
+ The second tricky bit is how to step over recursive calls.
+
+-}
+
+--ticksIn :: Module -> SrcSpan -> GHCi [Tick]
+ticksIn mod src = do
+ ticks <- getTickArray mod
+ let lines = [srcSpanStartLine src .. srcSpanEndLine src]
+ return [ t | line <- lines
+ , t@(_,span) <- ticks ! line
+ , srcSpanStart src <= srcSpanStart span
+ , srcSpanEnd src >= srcSpanEnd span
+ ]
+
+traceCmd :: String -> GHCi ()
+traceCmd [] = doContinue (const True) GHC.RunAndLogSteps
+traceCmd expression = do runStmt expression GHC.RunAndLogSteps; return ()
+
+continueCmd :: String -> GHCi ()
+continueCmd = noArgs $ doContinue (const True) GHC.RunToCompletion
+
+-- doContinue :: SingleStep -> GHCi ()
+doContinue pred step = do
session <- getSession
runResult <- io $ GHC.resume session step
- afterRunStmt runResult
- return False
+ afterRunStmt pred runResult
+ return ()
abandonCmd :: String -> GHCi ()
abandonCmd = noArgs $ 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 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
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
- runCommand (stop st)
- return ()
+ enqueueCommands [stop st]
forwardCmd :: String -> GHCi ()
forwardCmd = noArgs $ do
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
- runCommand (stop st)
- return ()
+ enqueueCommands [stop st]
-- handle the "break" command
breakCmd :: String -> GHCi ()
io $ putStrLn "Perhaps no modules are loaded for debugging?"
| otherwise = do -- try parsing it as an identifier
wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
- let loc = GHC.nameSrcLoc name
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
if GHC.isGoodSrcLoc loc
then findBreakAndSet (GHC.nameModule name) $
findBreakByCoord (Just (GHC.srcLocFile loc))
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
{ breakModule = mod
, breakLoc = span
, breakTick = tick
+ , onBreakCmd = ""
}
printForUser $
text "Breakpoint " <> ppr 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
findBreakByCoord mb_file (line, col) arr
| not (inRange (bounds arr) line) = Nothing
| otherwise =
- listToMaybe (sortBy rightmost contains)
+ listToMaybe (sortBy (rightmost `on` snd) contains ++
+ sortBy (leftmost_smallest `on` snd) 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 ]
+
+-- 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
-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
-
-start_bold = BS.pack "\ESC[1m"
-end_bold = BS.pack "\ESC[0m"
+start_bold = "\ESC[1m"
+end_bold = "\ESC[0m"
listCmd :: String -> GHCi ()
listCmd "" = do
mb_span <- getCurrentBreakSpan
case mb_span of
Nothing -> printForUser $ text "not stopped at a breakpoint; nothing to list"
- Just span -> io $ listAround span True
+ Just span | GHC.isGoodSrcSpan span -> io $ listAround span True
+ | otherwise -> printForUser $ text "unable to list source for" <+> ppr span
listCmd str = list2 (words str)
list2 [arg] | all isDigit arg = do
listModuleLine mod (read arg2)
list2 [arg] = do
wantNameFromInterpretedModule noCanDo arg $ \name -> do
- let loc = GHC.nameSrcLoc name
+ let loc = GHC.srcSpanStart (GHC.nameSrcSpan name)
if GHC.isGoodSrcLoc loc
then do
tickArray <- getTickArray (GHC.nameModule name)
| 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
in
- BS.concat [a,start_bold,b,end_bold,c]
+ BS.concat [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 [a, BS.pack start_bold, b]
| no == line2
= let (a,b) = BS.splitAt col2 line in
- BS.concat [a, end_bold, b]
+ BS.concat [a, BS.pack 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
[ (line, (nm,span)) | (nm,span) <- ticks,
line <- srcSpanLines span ]
where
- max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
+ max_line = foldr max 0 (map GHC.srcSpanEndLine (map snd ticks))
srcSpanLines span = [ GHC.srcSpanStartLine span ..
GHC.srcSpanEndLine span ]