#include "HsVersions.h"
import GhciMonad
+import GhciTags
+import Debugger
-- The GHC interface
import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
Type, Module, ModuleName, TyThing(..), Phase,
- BreakIndex )
-import Debugger
+ BreakIndex, Name, SrcSpan )
import DynFlags
import Packages
import PackageConfig
import Outputable hiding (printForUser)
import Module -- for ModuleEnv
--- for createtags
-import Name
-import OccName
-import SrcLoc
-
-- Other random utilities
import Digraph
import BasicTypes hiding (isTopLevel)
import Panic hiding (showException)
+import FastString ( unpackFS )
import Config
import StaticFlags
import Linker
import Control.Exception as Exception
-- import Control.Concurrent
+import qualified Data.ByteString.Char8 as BS
import Data.List
import Data.Maybe
import System.Cmd
import System.Posix.Internals ( setNonBlockingFD )
--- these are needed by the new ghci debugger
-import ByteCodeLink (HValue)
-import ByteCodeInstr (BreakInfo (..))
-import BreakArray
-
-----------------------------------------------------------------------------
ghciWelcomeMsg =
-- Hugs users are accustomed to :e, so make sure it doesn't overlap
("?", keepGoing help, False, completeNone),
("add", keepGoingPaths addModule, False, completeFilename),
- ("break", breakCmd, False, completeIdentifier),
+ ("abandon", keepGoing abandonCmd, False, completeNone),
+ ("break", keepGoing breakCmd, False, completeIdentifier),
("browse", keepGoing browseCmd, False, completeModule),
("cd", keepGoing changeDirectory, False, completeFilename),
("check", keepGoing checkModule, False, completeHomeModule),
("continue", continueCmd, False, completeNone),
("ctags", keepGoing createCTagsFileCmd, False, completeFilename),
("def", keepGoing defineMacro, False, completeIdentifier),
- ("delete", deleteCmd, False, completeNone),
+ ("delete", keepGoing deleteCmd, False, completeNone),
("e", keepGoing editFile, False, completeFilename),
("edit", keepGoing editFile, False, completeFilename),
("etags", keepGoing createETagsFileCmd, False, completeFilename),
- ("force", keepGoing (pprintClosureCommand False True), False, completeIdentifier),
+ ("force", keepGoing forceCmd, False, completeIdentifier),
("help", keepGoing help, False, completeNone),
("info", keepGoing info, False, completeIdentifier),
("kind", keepGoing kindOfType, False, completeIdentifier),
("load", keepGoingPaths loadModule_, False, completeHomeModuleOrFile),
+ ("list", keepGoing listCmd, False, completeNone),
("module", keepGoing setContext, False, completeModule),
("main", keepGoing runMain, False, completeIdentifier),
- ("print", keepGoing (pprintClosureCommand True False), False, completeIdentifier),
+ ("print", keepGoing printCmd, False, completeIdentifier),
("quit", quit, False, completeNone),
("reload", keepGoing reloadModule, False, completeNone),
("set", keepGoing setCmd, True, completeSetOptions),
("show", keepGoing showCmd, False, completeNone),
- ("sprint", keepGoing (pprintClosureCommand False False),False, completeIdentifier),
+ ("sprint", keepGoing sprintCmd, False, completeIdentifier),
("step", stepCmd, False, completeIdentifier),
("type", keepGoing typeOfExpr, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
shortHelpText = "use :? for help.\n"
--- NOTE: spaces at the end of each line to workaround CPP/string gap bug.
helpText =
" Commands available from the prompt:\n" ++
"\n" ++
" <stmt> evaluate/run <stmt>\n" ++
" :add <filename> ... add module(s) to the current target set\n" ++
+ " :abandon at a breakpoint, abandon current computation\n" ++
+ " :break [<mod>] <l> [<col>] set a breakpoint at the specified location\n" ++
+ " :break <name> set a breakpoint on the specified function\n" ++
" :browse [*]<module> display the names defined by <module>\n" ++
" :cd <dir> change directory to <dir>\n" ++
+ " :continue resume after a breakpoint\n" ++
+ " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
" :def <cmd> <expr> define a command :<cmd>\n" ++
+ " :delete <number> delete the specified breakpoint\n" ++
+ " :delete * delete all breakpoints\n" ++
" :edit <file> edit file\n" ++
" :edit edit last module\n" ++
+ " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
+-- " :force <expr> print <expr>, forcing unevaluated parts\n" ++
" :help, :? display this list of commands\n" ++
" :info [<name> ...] display information about the given names\n" ++
- " :print [<name> ...] prints a value without forcing its computation\n" ++
- " :sprint [<name> ...] simplified version of :print\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" ++
+ " :print [<name> ...] prints a value without forcing its computation\n" ++
+ " :quit exit GHCi\n" ++
" :reload reload the current module set\n" ++
"\n" ++
" :set <option> ... set options\n" ++
" :set prog <progname> set the value returned by System.getProgName\n" ++
" :set prompt <prompt> set the prompt used in GHCi\n" ++
" :set editor <cmd> set the command used for :edit\n" ++
+ " :set stop <cmd> set the command to run when a breakpoint is hit\n" ++
"\n" ++
+ " :show breaks show active breakpoints\n" ++
+ " :show context show the breakpoint context\n" ++
" :show modules show the currently loaded modules\n" ++
" :show bindings show the current bindings made at the prompt\n" ++
"\n" ++
- " :ctags [<file>] create tags file for Vi (default: \"tags\")\n" ++
- " :etags [<file>] create tags file for Emacs (default: \"TAGS\")\n" ++
+ " :sprint [<name> ...] simplifed version of :print\n" ++
+ " :step single-step after stopping at a breakpoint\n"++
+ " :step <expr> single-step into <expr>\n"++
" :type <expr> show the type of <expr>\n" ++
- " :kind <type> show the kind of <type>\n" ++
" :undef <cmd> undefine user-defined command :<cmd>\n" ++
" :unset <option> ... unset options\n" ++
- " :quit exit GHCi\n" ++
" :!<command> run the shell command <command>\n" ++
"\n" ++
" Options for ':set' and ':unset':\n" ++
GHCiState{ progname = "<interactive>",
args = [],
prompt = "%s> ",
+ stop = "",
editor = default_editor,
session = session,
options = [],
session <- getSession
(mod,imports) <- io (GHC.getContext session)
st <- getGHCiState
- when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
+ when show_prompt (io (putStr (mkPrompt mod imports (resume st) (prompt st))))
l <- io (IO.try (hGetLine hdl))
case l of
Left e | isEOFError e -> return ()
l -> do quit <- runCommand l
if quit then return True else stringLoop ss
-mkPrompt toplevs exports prompt
+mkPrompt toplevs exports resumes prompt
= showSDoc $ f prompt
where
f ('%':'s':xs) = perc_s <> f xs
f (x:xs) = char x <> f xs
f [] = empty
- perc_s = hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
- hsep (map (ppr . GHC.moduleName) exports)
+ perc_s
+ | (span,_,_):rest <- resumes
+ = (if not (null rest) then text "... " else empty)
+ <> brackets (ppr span) <+> modules_prompt
+ | otherwise
+ = modules_prompt
+
+ modules_prompt =
+ hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
+ hsep (map (ppr . GHC.moduleName) exports)
+
#ifdef USE_READLINE
io yield
saveSession -- for use by completion
st <- getGHCiState
- l <- io (readline (mkPrompt mod imports (prompt st))
+ l <- io (readline (mkPrompt mod imports (resume st) (prompt st))
`finally` setNonBlockingFD 0)
-- readline sometimes puts stdin into blocking mode,
-- so we need to put it back for the IO library
case nms of
Nothing -> io (exitWith (ExitFailure 1))
-- failure to run the command causes exit(1) for ghc -e.
- _ -> finishEvalExpr nms
+ _ -> do finishEvalExpr nms
+ return True
runStmt :: String -> GHCi (Maybe (Bool,[Name]))
runStmt stmt
switchOnRunResult (GHC.RunOk names) = return $ Just (False,names)
switchOnRunResult (GHC.RunBreak threadId names info resume) = do
session <- getSession
- Just mod_info <- io $ GHC.getModuleInfo session (breakInfo_module info)
+ 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 ! breakInfo_number info
+ let location = ticks ! GHC.breakInfo_number info
printForUser $ ptext SLIT("Stopped at") <+> ppr location
pushResume location threadId resume
+
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ runCommand (stop st)
+
return (Just (True,names))
-- possibly print the type and revert CAFs after evaluating an expression
io installSignalHandlers
b <- isOptionSet RevertCAFs
io (when b revertCAFs)
- return True
showTypeOfName :: Session -> Name -> GHCi ()
showTypeOfName session n
| fix == GHC.defaultFixity = empty
| otherwise = ppr fix <+> ppr (GHC.getName thing)
------------------------------------------------------------------------------
--- Commands
-
runMain :: String -> GHCi ()
runMain args = do
let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
shellEscape str = io (system str >> return False)
-----------------------------------------------------------------------------
--- create tags file for currently loaded modules.
-
-createETagsFileCmd, createCTagsFileCmd :: String -> GHCi ()
-
-createCTagsFileCmd "" = ghciCreateTagsFile CTags "tags"
-createCTagsFileCmd file = ghciCreateTagsFile CTags file
-
-createETagsFileCmd "" = ghciCreateTagsFile ETags "TAGS"
-createETagsFileCmd file = ghciCreateTagsFile ETags file
-
-data TagsKind = ETags | CTags
-
-ghciCreateTagsFile :: TagsKind -> FilePath -> GHCi ()
-ghciCreateTagsFile kind file = do
- session <- getSession
- io $ createTagsFile session kind file
-
--- ToDo:
--- - remove restriction that all modules must be interpreted
--- (problem: we don't know source locations for entities unless
--- we compiled the module.
---
--- - extract createTagsFile so it can be used from the command-line
--- (probably need to fix first problem before this is useful).
---
-createTagsFile :: Session -> TagsKind -> FilePath -> IO ()
-createTagsFile session tagskind tagFile = do
- graph <- GHC.getModuleGraph session
- let ms = map GHC.ms_mod graph
- tagModule m = do
- is_interpreted <- GHC.moduleIsInterpreted session m
- -- should we just skip these?
- when (not is_interpreted) $
- throwDyn (CmdLineError ("module '"
- ++ GHC.moduleNameString (GHC.moduleName m)
- ++ "' is not interpreted"))
- mbModInfo <- GHC.getModuleInfo session m
- let unqual
- | Just modinfo <- mbModInfo,
- Just unqual <- GHC.modInfoPrintUnqualified modinfo = unqual
- | otherwise = GHC.alwaysQualify
-
- case mbModInfo of
- Just modInfo -> return $! listTags unqual modInfo
- _ -> return []
-
- mtags <- mapM tagModule ms
- either_res <- collateAndWriteTags tagskind tagFile $ concat mtags
- case either_res of
- Left e -> hPutStrLn stderr $ ioeGetErrorString e
- Right _ -> return ()
-
-listTags :: PrintUnqualified -> GHC.ModuleInfo -> [TagInfo]
-listTags unqual modInfo =
- [ tagInfo unqual name loc
- | name <- GHC.modInfoExports modInfo
- , let loc = nameSrcLoc name
- , isGoodSrcLoc loc
- ]
-
-type TagInfo = (String -- tag name
- ,String -- file name
- ,Int -- line number
- ,Int -- column number
- )
-
--- get tag info, for later translation into Vim or Emacs style
-tagInfo :: PrintUnqualified -> Name -> SrcLoc -> TagInfo
-tagInfo unqual name loc
- = ( showSDocForUser unqual $ pprOccName (nameOccName name)
- , showSDocForUser unqual $ ftext (srcLocFile loc)
- , srcLocLine loc
- , srcLocCol loc
- )
-
-collateAndWriteTags :: TagsKind -> FilePath -> [TagInfo] -> IO (Either IOError ())
-collateAndWriteTags CTags file tagInfos = do -- ctags style, Vim et al
- let tags = unlines $ sortLe (<=) $ nub $ map showTag tagInfos
- IO.try (writeFile file tags)
-collateAndWriteTags ETags file tagInfos = do -- etags style, Emacs/XEmacs
- let byFile op (_,f1,_,_) (_,f2,_,_) = f1 `op` f2
- groups = groupBy (byFile (==)) $ sortLe (byFile (<=)) tagInfos
- tagGroups <- mapM tagFileGroup groups
- IO.try (writeFile file $ concat tagGroups)
- where
- tagFileGroup group@[] = throwDyn (CmdLineError "empty tag file group??")
- tagFileGroup group@((_,fileName,_,_):_) = do
- file <- readFile fileName -- need to get additional info from sources..
- let byLine (_,_,l1,_) (_,_,l2,_) = l1 <= l2
- sortedGroup = sortLe byLine group
- tags = unlines $ perFile sortedGroup 1 0 $ lines file
- return $ "\x0c\n" ++ fileName ++ "," ++ show (length tags) ++ "\n" ++ tags
- perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos (line:lines) | lNo>count =
- perFile (tagInfo:tags) (count+1) (pos+length line) lines
- perFile (tagInfo@(tag,file,lNo,colNo):tags) count pos lines@(line:_) | lNo==count =
- showETag tagInfo line pos : perFile tags count pos lines
- perFile tags count pos lines = []
-
--- simple ctags format, for Vim et al
-showTag :: TagInfo -> String
-showTag (tag,file,lineNo,colNo)
- = tag ++ "\t" ++ file ++ "\t" ++ show lineNo
-
--- etags format, for Emacs/XEmacs
-showETag :: TagInfo -> String -> Int -> String
-showETag (tag,file,lineNo,colNo) line charPos
- = take colNo line ++ tag
- ++ "\x7f" ++ tag
- ++ "\x01" ++ show lineNo
- ++ "," ++ show charPos
-
------------------------------------------------------------------------------
-- Browsing a module's contents
browseCmd :: String -> GHCi ()
("prog":prog) -> setProg prog
("prompt":prompt) -> setPrompt (after 6)
("editor":cmd) -> setEditor (after 6)
+ ("stop":cmd) -> setStop (after 4)
wds -> setOptions wds
where after n = dropWhile isSpace $ drop n $ dropWhile isSpace str
st <- getGHCiState
setGHCiState st{ editor = cmd }
+setStop cmd = do
+ st <- getGHCiState
+ setGHCiState st{ stop = cmd }
+
setPrompt value = do
st <- getGHCiState
if null value
#endif
return ()
+-- -----------------------------------------------------------------------------
-- commands for debugger
+
+sprintCmd = pprintCommand False False
+printCmd = pprintCommand True False
+forceCmd = pprintCommand False True
+
+pprintCommand bind force str = do
+ session <- getSession
+ io $ pprintClosureCommand session bind force str
+
foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
stepCmd :: String -> GHCi Bool
runResult <- io $ GHC.resume session handle
names <- switchOnRunResult runResult
finishEvalExpr names
- return False
+ return False
+
+abandonCmd :: String -> GHCi ()
+abandonCmd "" = do
+ mb_res <- popResume
+ case mb_res of
+ Nothing -> do
+ io $ putStrLn "There is no computation running."
+ Just (span,_,_) ->
+ return ()
+ -- the prompt will change to indicate the new context
-deleteCmd :: String -> GHCi Bool
+deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
deleteSwitch $ words argLine
- return False
where
deleteSwitch :: [String] -> GHCi ()
deleteSwitch [] =
| otherwise = return ()
-- handle the "break" command
-breakCmd :: String -> GHCi Bool
+breakCmd :: String -> GHCi ()
breakCmd argLine = do
session <- getSession
breakSwitch session $ words argLine
- return False
breakSwitch :: Session -> [String] -> GHCi ()
breakSwitch _session [] = do
case names of
[] -> return ()
(n:_) -> do
- let loc = nameSrcLoc n
- modl = nameModule n
+ let loc = GHC.nameSrcLoc n
+ modl = GHC.nameModule n
is_interpreted <- io (GHC.moduleIsInterpreted session modl)
if not is_interpreted
then noCanDo $ text "module " <> ppr modl <>
text " is not interpreted"
else do
- if isGoodSrcLoc loc
- then findBreakAndSet (nameModule n) $
- findBreakByCoord (srcLocLine loc, srcLocCol loc)
+ if GHC.isGoodSrcLoc loc
+ then findBreakAndSet (GHC.nameModule n) $
+ findBreakByCoord (GHC.srcLocLine loc,
+ GHC.srcLocCol loc)
else noCanDo $ text "can't find its location: " <>
ppr loc
where
findBreakByLine line arr
| not (inRange (bounds arr) line) = Nothing
| otherwise =
- listToMaybe (sortBy leftmost complete) `mplus`
- listToMaybe (sortBy leftmost incomplete) `mplus`
+ listToMaybe (sortBy leftmost_largest complete) `mplus`
+ listToMaybe (sortBy leftmost_smallest incomplete) `mplus`
listToMaybe (sortBy rightmost ticks)
where
ticks = arr ! line
starts_here = [ tick | tick@(nm,span) <- ticks,
- srcSpanStartLine span == line ]
+ GHC.srcSpanStartLine span == line ]
(complete,incomplete) = partition ends_here starts_here
- where ends_here (nm,span) = srcSpanEndLine span == line
+ where ends_here (nm,span) = GHC.srcSpanEndLine span == line
findBreakByCoord :: (Int,Int) -> TickArray -> Maybe (BreakIndex,SrcSpan)
findBreakByCoord (line, col) arr
-- the ticks that span this coordinate
contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
-leftmost (_,a) (_,b) = a `compare` b
+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) = srcSpanStart span <= loc && loc <= srcSpanEnd span
- where loc = mkSrcLoc (srcSpanFile span) l c
+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"
+
+listCmd :: String -> GHCi ()
+listCmd str = do
+ st <- getGHCiState
+ case resume st of
+ [] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
+ (span,_,_):_ -> io $ listAround span True
+
+-- | 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 span do_highlight = do
+ contents <- BS.readFile (unpackFS file)
+ let
+ lines = BS.split '\n' contents
+ these_lines = take (line2 - line1 + 1 + pad_before + pad_after) $
+ drop (line1 - 1 - pad_before) $ lines
+ fst_line = max 1 (line1 - pad_before)
+ line_nos = [ fst_line .. ]
+
+ highlighted | do_highlight = zipWith highlight line_nos these_lines
+ | otherwise = these_lines
+
+ bs_line_nos = [ BS.pack (show l ++ " ") | l <- line_nos ]
+ prefixed = zipWith BS.append bs_line_nos highlighted
+ --
+ BS.putStrLn (BS.join (BS.pack "\n") prefixed)
+ where
+ file = GHC.srcSpanFile span
+ line1 = GHC.srcSpanStartLine span
+ col1 = GHC.srcSpanStartCol span
+ line2 = GHC.srcSpanEndLine span
+ col2 = GHC.srcSpanEndCol span
+
+ pad_before | line1 == 1 = 0
+ | otherwise = 1
+ pad_after = 1
+
+ highlight 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]
+ | no == line1
+ = let (a,b) = BS.splitAt col1 line in
+ BS.concat [a, start_bold, b]
+ | no == line2
+ = let (a,b) = BS.splitAt col2 line in
+ BS.concat [a, end_bold, b]
+ | otherwise = line
-- --------------------------------------------------------------------------
-- Tick arrays
[ (line, (nm,span)) | (nm,span) <- ticks,
line <- srcSpanLines span ]
where
- max_line = maximum (map srcSpanEndLine (map snd ticks))
- srcSpanLines span = [ srcSpanStartLine span .. srcSpanEndLine span ]
+ max_line = maximum (map GHC.srcSpanEndLine (map snd ticks))
+ srcSpanLines span = [ GHC.srcSpanStartLine span ..
+ GHC.srcSpanEndLine span ]
-getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
+getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
getModBreak mod = do
session <- getSession
Just mod_info <- io $ GHC.getModuleInfo session mod
lookupModule session modName
= io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
-setBreakFlag :: Bool -> BreakArray -> Int -> IO Bool
+setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
setBreakFlag toggle array index
- | toggle = setBreakOn array index
- | otherwise = setBreakOff array index
+ | toggle = GHC.setBreakOn array index
+ | otherwise = GHC.setBreakOff array index
{- these should probably go to the GHC API at some point -}
projects / ghc-hetmet.git / blobdiff