-- (c) The GHC Team 2005-2006
--
-----------------------------------------------------------------------------
+
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
+
+#ifdef USE_READLINE
import Packages
import PackageConfig
import UniqFM
-import PprTyThing
+#endif
+
+import HscTypes ( implicitTyThings )
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.Directory
import System.IO
import System.IO.Error as IO
+import System.IO.Unsafe
import Data.Char
import Data.Dynamic
import Data.Array
import Data.IORef ( IORef, readIORef, writeIORef )
+#ifdef USE_READLINE
import System.Posix.Internals ( setNonBlockingFD )
+#endif
-----------------------------------------------------------------------------
": http://www.haskell.org/ghc/ :? for help"
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
+
+cmdName :: Command -> String
cmdName (n,_,_,_) = n
+commands :: IORef [Command]
GLOBAL_VAR(commands, builtin_commands, [Command])
builtin_commands :: [Command]
("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" ++
" :add <filename> ... add module(s) to the current target set\n" ++
- " :browse [*]<module> display the names defined by <module>\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" ++
" :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"++
" :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
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 ()
+ Left _e -> return ()
Right hdl -> fileLoop hdl 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 ()
+ Left _e -> return ()
Right hdl -> fileLoop hdl False
-- Perform a :load for files given on the GHCi command line
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
-- 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
l -> do quit <- runCommands l
if quit then return () else fileLoop hdl show_prompt
+mkPrompt :: GHCi String
mkPrompt = do
session <- getSession
(toplevs,exports) <- io (GHC.getContext session)
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 =
#ifdef USE_READLINE
readlineLoop :: GHCi ()
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,
-- 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
+ printTypeAndContentOfNames 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 step_here >> return ()
_ -> return ()
flushInterpBuffers
return (case run_result of GHC.RunOk _ -> True; _ -> False)
+ where printTypeAndContentOfNames session names = do
+ let namesSorted = sortBy compareNames names
+ tythings <- catMaybes `liftM`
+ io (mapM (GHC.lookupName session) namesSorted)
+ let ids = [id | AnId id <- tythings]
+ terms <- mapM (io . GHC.obtainTermB session 10 False) ids
+ docs_terms <- mapM (io . showTerm session) terms
+ dflags <- getDynFlags
+ let pefas = dopt Opt_PrintExplicitForalls dflags
+ printForUser $ vcat $ zipWith (\ty cts -> ty <+> equals <+> cts)
+ (map (pprTyThing pefas . AnId) ids)
+ docs_terms
+
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,
+ case [ loc | (_,loc) <- breaks st,
breakModule loc == mod, breakTick loc == nm ] of
[] -> return ()
loc:_ | null cmd -> return ()
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)
; mapM_ (infoThing pefas session) names }
where
infoThing pefas session str = io $ do
- names <- GHC.parseName session str
- let filtered = filterOutChildren names
- mb_stuffs <- mapM (GHC.getInfo session) filtered
+ 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 pefas 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
+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)
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)
return ()
+doLoad :: Session -> LoadHowMuch -> GHCi SuccessFlag
doLoad session howmuch = do
-- turn off breakpoints before we load: we can't turn them off later, because
-- the ModBreaks will have gone away.
afterLoad ok session
return ok
+afterLoad :: SuccessFlag -> Session -> GHCi ()
afterLoad ok session = 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_mods <- getLoadedModules session
+ setContextAfterLoad session loaded_mods
+ modulesLoadedMsg ok (map GHC.ms_mod_name loaded_mods)
+setContextAfterLoad :: Session -> [GHC.ModSummary] -> GHCi ()
setContextAfterLoad session [] = do
prel_mod <- getPrelude
io (GHC.setContext session [] [prel_mod])
= 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
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
browseCmd :: String -> GHCi ()
browseCmd 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 m False
+ [s] | looksLikeModuleName s -> do
+ m <- lookupModule s
+ browseModule 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 (last as) True
+ ([], bs@(_:_)) -> browseModule (last bs) True
+ ([], []) -> throwDyn (CmdLineError ":browse: no current module")
_ -> throwDyn (CmdLineError "syntax: :browse <module>")
-browseModule m exports_only = do
+browseModule :: Module -> Bool -> GHCi ()
+browseModule 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)
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)
+ | 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 pefas = dopt Opt_PrintExplicitForalls dflags
io (putStrLn (showSDocForUser unqual (
- vcat (map (pprTyThingInContext pefas) (catMaybes things))
+ vcat (map (pprTyThingInContext pefas) filtered_things)
)))
-- ToDo: modInfoInstances currently throws an exception for
-- package modules. When it works, we can do this:
-----------------------------------------------------------------------------
-- 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
= 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
= 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, unsetOpt :: String -> GHCi ()
-setOpt ('+':str)
+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
["context"] -> showContext
_ -> 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 ()
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_PrintExplicitForalls 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
-- 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)))
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
-- 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.
+ -- future we should support UTF-8, but for now we set the code
+ -- pages to Latin-1. Doing it this way does lead to problems,
+ -- however: see bug #1649.
--
-- 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()).
--
+ -- This call has been known to hang on some machines, see bug #1483
+ --
setConsoleCP 28591 -- ISO Latin-1
setConsoleOutputCP 28591 -- ISO Latin-1
#endif
-- -----------------------------------------------------------------------------
-- 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
-breakByModule session mod _
+breakByModule _ _
= breakSyntax
breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
| otherwise = breakSyntax
+breakSyntax :: a
breakSyntax = throwDyn (CmdLineError "Syntax: :break [<mod>] <line> [<column>]")
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
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
contents <- BS.readFile (unpackFS file)
let
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)
projects / ghc-hetmet.git / blobdiff