#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, Resume, SingleStep )
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 StaticFlags
import Linker
import Util
+import FastString
#ifndef mingw32_HOST_OS
import System.Posix
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 Data.Dynamic
import Data.Array
import Control.Monad as Monad
+import Text.Printf
import Foreign.StablePtr ( newStablePtr )
import GHC.Exts ( unsafeCoerce# )
ghciWelcomeMsg =
" ___ ___ _\n"++
" / _ \\ /\\ /\\/ __(_)\n"++
- " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
- "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
- "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
+ " / /_\\// /_/ / / | | GHC Interactive, version " ++ cProjectVersion ++ ", for Haskell 98.\n"++
+ "/ /_\\\\/ __ / /___| | http://www.haskell.org/ghc/\n"++
+ "\\____/\\/ /_/\\____/|_| Type :? for help.\n"
type Command = (String, String -> GHCi Bool, Bool, String -> IO [String])
cmdName (n,_,_,_) = n
-- 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),
+ ("back", keepGoing backCmd, False, completeNone),
("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),
+ ("forward", keepGoing forwardCmd, False, completeNone),
("help", keepGoing help, False, completeNone),
+ ("history", keepGoing historyCmd, 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),
+ ("trace", traceCmd, False, completeIdentifier),
("undef", keepGoing undefineMacro, False, completeMacro),
("unset", keepGoing unsetOptions, True, completeSetOptions)
]
"\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" ++
" :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" ++
GHCiState{ progname = "<interactive>",
args = [],
prompt = "%s> ",
+ stop = "",
editor = default_editor,
session = session,
options = [],
prelude = prel_mod,
- resume = [],
- breaks = emptyActiveBreakPoints,
+ break_ctr = 0,
+ breaks = [],
tickarrays = emptyModuleEnv
}
fileLoop :: Handle -> Bool -> GHCi ()
fileLoop hdl show_prompt = do
- session <- getSession
- (mod,imports) <- io (GHC.getContext session)
- st <- getGHCiState
- when show_prompt (io (putStr (mkPrompt mod imports (prompt st))))
+ when show_prompt $ do
+ prompt <- mkPrompt
+ (io (putStr prompt))
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
- = showSDoc $ f prompt
- where
- f ('%':'s':xs) = perc_s <> f xs
+mkPrompt = do
+ session <- getSession
+ (toplevs,exports) <- io (GHC.getContext session)
+ resumes <- io $ GHC.getResumeContext session
+
+ context_bit <-
+ case resumes of
+ [] -> return empty
+ r:rs -> 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
+ return (brackets (ppr (negate ix) <> char ':'
+ <+> ppr span) <> space)
+ let
+ dots | r:rs <- resumes, not (null rs) = text "... "
+ | otherwise = empty
+
+ modules_bit =
+ hsep (map (\m -> char '*' <> ppr (GHC.moduleName m)) toplevs) <+>
+ hsep (map (ppr . GHC.moduleName) exports)
+
+ deflt_prompt = dots <> context_bit <> modules_bit
+
+ f ('%':'s':xs) = deflt_prompt <> f xs
f ('%':'%':xs) = char '%' <> 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)
+ --
+ st <- getGHCiState
+ return (showSDoc (f (prompt st)))
#ifdef USE_READLINE
io yield
saveSession -- for use by completion
st <- getGHCiState
- l <- io (readline (mkPrompt mod imports (prompt st))
- `finally` setNonBlockingFD 0)
+ mb_span <- getCurrentBreakSpan
+ prompt <- mkPrompt
+ l <- io (readline prompt `finally` setNonBlockingFD 0)
-- readline sometimes puts stdin into blocking mode,
-- so we need to put it back for the IO library
splatSavedSession
where
doCommand (':' : command) = specialCommand command
doCommand stmt
- = do timeIt (do nms <- runStmt stmt; finishEvalExpr nms)
+ = do timeIt $ runStmt stmt GHC.RunToCompletion
return False
-- This version is for the GHC command-line option -e. The only difference
doCommand (':' : command) = specialCommand command
doCommand stmt
- = do nms <- runStmt stmt
- case nms of
- Nothing -> io (exitWith (ExitFailure 1))
+ = do r <- runStmt stmt GHC.RunToCompletion
+ case r of
+ False -> io (exitWith (ExitFailure 1))
-- failure to run the command causes exit(1) for ghc -e.
- _ -> finishEvalExpr nms
+ _ -> return True
-runStmt :: String -> GHCi (Maybe (Bool,[Name]))
-runStmt stmt
- | null (filter (not.isSpace) stmt) = return (Just (False,[]))
+runStmt :: String -> SingleStep -> GHCi Bool
+runStmt stmt step
+ | null (filter (not.isSpace) stmt) = return False
| otherwise
= do st <- getGHCiState
session <- getSession
result <- io $ withProgName (progname st) $ withArgs (args st) $
- GHC.runStmt session stmt
- switchOnRunResult result
+ GHC.runStmt session stmt step
+ afterRunStmt result
+ return (isRunResultOk 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
+
+ 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 resume) = do
+switchOnRunResult (GHC.RunBreak threadId names info) = 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
-finishEvalExpr mb_names
- = do show_types <- isOptionSet ShowType
- session <- getSession
- case mb_names of
- Nothing -> return ()
- Just (is_break,names) ->
- when (is_break || show_types) $
- mapM_ (showTypeOfName session) names
-
- flushInterpBuffers
- io installSignalHandlers
- b <- isOptionSet RevertCAFs
- io (when b revertCAFs)
- return True
+
+isRunResultOk :: GHC.RunResult -> Bool
+isRunResultOk (GHC.RunOk _) = True
+isRunResultOk _ = False
+
showTypeOfName :: Session -> Name -> GHCi ()
showTypeOfName session n
[] -> return Nothing
c:_ -> return (Just c)
+
+getCurrentBreakSpan :: GHCi (Maybe SrcSpan)
+getCurrentBreakSpan = 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 (Just (GHC.resumeSpan r))
+ else do
+ let hist = GHC.resumeHistory r !! (ix-1)
+ span <- io $ GHC.getHistorySpan session hist
+ return (Just span)
+
-----------------------------------------------------------------------------
-- Commands
+noArgs :: GHCi () -> String -> GHCi ()
+noArgs m "" = m
+noArgs m _ = io $ putStrLn "This command takes no arguments"
+
help :: String -> GHCi ()
help _ = io (putStr helpText)
| 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))
afterLoad ok session = do
io (revertCAFs) -- always revert CAFs on load.
- discardResumeContext
discardTickArrays
discardActiveBreakPoints
graph <- io (GHC.getModuleGraph session)
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 ()
browseModule m exports_only = do
s <- getSession
- modl <- if exports_only then lookupModule s m
- else wantInterpretedModule s m
+ 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
("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
showBkptTable :: GHCi ()
showBkptTable = do
- activeBreaks <- getActiveBreakPoints
- printForUser $ ppr activeBreaks
+ st <- getGHCiState
+ printForUser $ prettyLocations (breaks st)
showContext :: GHCi ()
showContext = do
- st <- getGHCiState
- printForUser $ vcat (map pp_resume (resume st))
+ session <- getSession
+ resumes <- io $ GHC.getResumeContext session
+ printForUser $ vcat (map pp_resume (reverse resumes))
where
- pp_resume (span, _, _) = ptext SLIT("Stopped at") <+> ppr span
+ pp_resume resume =
+ ptext SLIT("--> ") <> text (GHC.resumeStmt resume)
+ $$ nest 2 (ptext SLIT("Stopped at") <+> ppr (GHC.resumeSpan resume))
+
-- -----------------------------------------------------------------------------
-- Completion
other ->
return other
+wantInterpretedModule :: String -> GHCi Module
+wantInterpretedModule str = do
+ session <- getSession
+ modl <- lookupModule str
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ when (not is_interpreted) $
+ throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
+ return modl
+
+wantNameFromInterpretedModule noCanDo str and_then = do
+ session <- getSession
+ names <- io $ GHC.parseName session str
+ case names of
+ [] -> return ()
+ (n:_) -> do
+ let modl = GHC.nameModule n
+ is_interpreted <- io (GHC.moduleIsInterpreted session modl)
+ if not is_interpreted
+ then noCanDo n $ text "module " <> ppr modl <>
+ text " is not interpreted"
+ else and_then n
+
-- ----------------------------------------------------------------------------
-- Windows console setup
#endif
return ()
+-- -----------------------------------------------------------------------------
-- commands for debugger
-foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
+
+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
stepCmd :: String -> GHCi Bool
-stepCmd [] = doContinue setStepFlag
-stepCmd expression = do
- io $ setStepFlag
- runCommand expression
+stepCmd [] = doContinue GHC.SingleStep
+stepCmd expression = runStmt expression GHC.SingleStep
+
+traceCmd :: String -> GHCi Bool
+traceCmd [] = doContinue GHC.RunAndLogSteps
+traceCmd expression = runStmt expression GHC.RunAndLogSteps
continueCmd :: String -> GHCi Bool
-continueCmd [] = doContinue $ return ()
+continueCmd [] = doContinue GHC.RunToCompletion
continueCmd other = do
io $ putStrLn "The continue command accepts no arguments."
return False
-doContinue :: IO () -> GHCi Bool
-doContinue actionBeforeCont = do
- resumeAction <- popResume
- case resumeAction of
- Nothing -> do
- io $ putStrLn "There is no computation running."
- return False
- Just (_,_,handle) -> do
- io $ actionBeforeCont
- session <- getSession
- runResult <- io $ GHC.resume session handle
- names <- switchOnRunResult runResult
- finishEvalExpr names
- return False
+doContinue :: SingleStep -> GHCi Bool
+doContinue step = do
+ session <- getSession
+ runResult <- io $ GHC.resume session step
+ afterRunStmt runResult
+ return False
-deleteCmd :: String -> GHCi Bool
+abandonCmd :: String -> GHCi ()
+abandonCmd = noArgs $ do
+ s <- getSession
+ b <- io $ GHC.abandon s -- the prompt will change to indicate the new context
+ when (not b) $ io $ putStrLn "There is no computation running."
+ return ()
+
+deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
deleteSwitch $ words argLine
- return False
where
deleteSwitch :: [String] -> GHCi ()
deleteSwitch [] =
| all isDigit str = deleteBreak (read str)
| otherwise = return ()
+historyCmd :: String -> GHCi ()
+historyCmd arg
+ | null arg = history 20
+ | all isDigit arg = history (read arg)
+ | otherwise = io $ putStrLn "Syntax: :history [num]"
+ where
+ history num = do
+ s <- getSession
+ resumes <- io $ GHC.getResumeContext s
+ case resumes of
+ [] -> io $ putStrLn "Not stopped at a breakpoint"
+ (r:rs) -> 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)))
+ io $ putStrLn $ if null rest then "<end of history>" else "..."
+
+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
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ runCommand (stop st)
+ return ()
+
+forwardCmd :: String -> GHCi ()
+forwardCmd = noArgs $ do
+ s <- getSession
+ (names, ix, span) <- io $ GHC.forward s
+ printForUser $ (if (ix == 0)
+ then ptext SLIT("Stopped at")
+ else ptext SLIT("Logged breakpoint at")) <+> ppr span
+ mapM_ (showTypeOfName s) names
+ -- run the command set with ":set stop <cmd>"
+ st <- getGHCiState
+ runCommand (stop st)
+ 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
io $ putStrLn "The break command requires at least one argument."
breakSwitch session args@(arg1:rest)
| looksLikeModuleName arg1 = do
- mod <- wantInterpretedModule session arg1
+ mod <- wantInterpretedModule arg1
breakByModule session mod rest
| all isDigit arg1 = do
(toplevel, _) <- io $ GHC.getContext session
[] -> do
io $ putStrLn "Cannot find default module for breakpoint."
io $ putStrLn "Perhaps no modules are loaded for debugging?"
- | otherwise = do -- assume it's a name
- names <- io $ GHC.parseName session arg1
- case names of
- [] -> return ()
- (n:_) -> do
- let loc = nameSrcLoc n
- modl = 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)
- else noCanDo $ text "can't find its location: " <>
- ppr loc
- where
- noCanDo why = printForUser $
+ | otherwise = do -- try parsing it as an identifier
+ wantNameFromInterpretedModule noCanDo arg1 $ \name -> do
+ let loc = GHC.nameSrcLoc name
+ if GHC.isGoodSrcLoc loc
+ then findBreakAndSet (GHC.nameModule name) $
+ findBreakByCoord (Just (GHC.srcLocFile loc))
+ (GHC.srcLocLine loc,
+ GHC.srcLocCol loc)
+ else noCanDo name $ text "can't find its location: " <> ppr loc
+ where
+ noCanDo n why = printForUser $
text "cannot set breakpoint on " <> ppr n <> text ": " <> why
-
-wantInterpretedModule :: Session -> String -> GHCi Module
-wantInterpretedModule session str = do
- modl <- io $ GHC.findModule session (GHC.mkModuleName str) Nothing
- is_interpreted <- io (GHC.moduleIsInterpreted session modl)
- when (not is_interpreted) $
- throwDyn (CmdLineError ("module '" ++ str ++ "' is not interpreted"))
- return modl
-
breakByModule :: Session -> Module -> [String] -> GHCi ()
breakByModule session mod args@(arg1:rest)
| all isDigit arg1 = do -- looks like a line number
breakByModuleLine mod line args
| [] <- args = findBreakAndSet mod $ findBreakByLine line
| [col] <- args, all isDigit col =
- findBreakAndSet mod $ findBreakByCoord (line, read col)
+ findBreakAndSet mod $ findBreakByCoord Nothing (line, read col)
| otherwise = io $ putStrLn "Invalid arguments to :break"
findBreakAndSet :: Module -> (TickArray -> Maybe (Int, SrcSpan)) -> GHCi ()
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
+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)
ticks = arr ! line
-- the ticks that span this coordinate
- contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col) ]
+ contains = [ tick | tick@(nm,span) <- ticks, span `spans` (line,col),
+ is_correct_file span ]
+
+ is_correct_file span
+ | Just f <- mb_file = GHC.srcSpanFile span == f
+ | otherwise = True
-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 "" = 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
+listCmd str = list2 (words str)
+
+list2 [arg] | all isDigit arg = do
+ session <- getSession
+ (toplevel, _) <- io $ GHC.getContext session
+ case toplevel of
+ [] -> io $ putStrLn "No module to list"
+ (mod : _) -> listModuleLine mod (read arg)
+list2 [arg1,arg2] | looksLikeModuleName arg1, all isDigit arg2 = do
+ mod <- wantInterpretedModule arg1
+ listModuleLine mod (read arg2)
+list2 [arg] = do
+ wantNameFromInterpretedModule noCanDo arg $ \name -> do
+ let loc = GHC.nameSrcLoc name
+ if GHC.isGoodSrcLoc loc
+ then do
+ tickArray <- getTickArray (GHC.nameModule name)
+ let mb_span = findBreakByCoord (Just (GHC.srcLocFile loc))
+ (GHC.srcLocLine loc, GHC.srcLocCol loc)
+ tickArray
+ case mb_span of
+ Nothing -> io $ listAround (GHC.srcLocSpan loc) False
+ Just (_,span) -> io $ listAround span False
+ else
+ noCanDo name $ text "can't find its location: " <>
+ ppr loc
+ where
+ noCanDo n why = printForUser $
+ text "cannot list source code for " <> ppr n <> text ": " <> why
+list2 _other =
+ io $ putStrLn "syntax: :list [<line> | <module> <line> | <identifier>]"
+listModuleLine :: Module -> Int -> GHCi ()
+listModuleLine modl line = do
+ session <- getSession
+ graph <- io (GHC.getModuleGraph session)
+ let this = filter ((== modl) . GHC.ms_mod) graph
+ case this of
+ [] -> panic "listModuleLine"
+ summ:_ -> do
+ let filename = fromJust (ml_hs_file (GHC.ms_location summ))
+ loc = GHC.mkSrcLoc (mkFastString (filename)) line 0
+ io $ listAround (GHC.srcLocSpan loc) False
+
+-- | 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 ]
+
+lookupModule :: String -> GHCi Module
+lookupModule modName
+ = do session <- getSession
+ io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
+
+-- don't reset the counter back to zero?
+discardActiveBreakPoints :: GHCi ()
+discardActiveBreakPoints = do
+ st <- getGHCiState
+ mapM (turnOffBreak.snd) (breaks st)
+ setGHCiState $ st { breaks = [] }
+
+deleteBreak :: Int -> GHCi ()
+deleteBreak identity = do
+ st <- getGHCiState
+ let oldLocations = breaks st
+ (this,rest) = partition (\loc -> fst loc == identity) oldLocations
+ if null this
+ then printForUser (text "Breakpoint" <+> ppr identity <+>
+ text "does not exist")
+ else do
+ mapM (turnOffBreak.snd) this
+ setGHCiState $ st { breaks = rest }
+
+turnOffBreak loc = do
+ (arr, _) <- getModBreak (breakModule loc)
+ io $ setBreakFlag False arr (breakTick loc)
getModBreak :: Module -> GHCi (GHC.BreakArray, Array Int SrcSpan)
getModBreak mod = do
let ticks = GHC.modBreaks_locs modBreaks
return (array, ticks)
-lookupModule :: Session -> String -> GHCi Module
-lookupModule session modName
- = io (GHC.findModule session (GHC.mkModuleName modName) Nothing)
-
setBreakFlag :: Bool -> GHC.BreakArray -> Int -> IO Bool
setBreakFlag toggle array index
| toggle = GHC.setBreakOn array index
| otherwise = GHC.setBreakOff array index
-
-{- these should probably go to the GHC API at some point -}
-enableBreakPoint :: Session -> Module -> Int -> IO ()
-enableBreakPoint session mod index = return ()
-
-disableBreakPoint :: Session -> Module -> Int -> IO ()
-disableBreakPoint session mod index = return ()
-
-activeBreakPoints :: Session -> IO [(Module,Int)]
-activeBreakPoints session = return []
-
-enableSingleStep :: Session -> IO ()
-enableSingleStep session = return ()
-
-disableSingleStep :: Session -> IO ()
-disableSingleStep session = return ()
projects / ghc-hetmet.git / blobdiff