import qualified GHC
import GHC ( Session, LoadHowMuch(..), Target(..), TargetId(..),
Type, Module, ModuleName, TyThing(..), Phase,
- BreakIndex, Name, SrcSpan, Resume )
+ BreakIndex, Name, SrcSpan, Resume, SingleStep )
import DynFlags
import Packages
import PackageConfig
import Data.Dynamic
import Data.Array
import Control.Monad as Monad
+import Text.Printf
import Foreign.StablePtr ( newStablePtr )
import GHC.Exts ( unsafeCoerce# )
("add", keepGoingPaths addModule, False, completeFilename),
("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),
("edit", keepGoing editFile, False, completeFilename),
("etags", keepGoing createETagsFileCmd, False, completeFilename),
("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),
("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)
]
session = session,
options = [],
prelude = prel_mod,
- 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
- resumes <- io $ GHC.getResumeContext session
- when show_prompt (io (putStr (mkPrompt mod imports resumes (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 resumes prompt
- = showSDoc $ f prompt
- where
- f ('%':'s':xs) = perc_s <> f xs
- f ('%':'%':xs) = char '%' <> f xs
- f (x:xs) = char x <> f xs
- f [] = empty
-
- perc_s
- | eval:rest <- resumes
- = (if not (null rest) then text "... " else empty)
- <> brackets (ppr (GHC.resumeSpan eval)) <+> modules_prompt
- | otherwise
- = modules_prompt
-
- modules_prompt =
+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
+ --
+ st <- getGHCiState
+ return (showSDoc (f (prompt st)))
#ifdef USE_READLINE
io yield
saveSession -- for use by completion
st <- getGHCiState
- resumes <- io $ GHC.getResumeContext session
- l <- io (readline (mkPrompt mod imports resumes (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 $ runStmt stmt
+ = 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 r <- runStmt stmt
+ = 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.
_ -> return True
-runStmt :: String -> GHCi Bool
-runStmt stmt
+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
+ GHC.runStmt session stmt step
afterRunStmt result
- return False
+ 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
return (Just (True,names))
+isRunResultOk :: GHC.RunResult -> Bool
+isRunResultOk (GHC.RunOk _) = True
+isRunResultOk _ = False
+
+
showTypeOfName :: Session -> Name -> GHCi ()
showTypeOfName session n
= do maybe_tything <- io (GHC.lookupName 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)
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
showBkptTable :: GHCi ()
showBkptTable = do
- activeBreaks <- getActiveBreakPoints
- printForUser $ ppr activeBreaks
+ st <- getGHCiState
+ printForUser $ prettyLocations (breaks st)
showContext :: GHCi ()
showContext = do
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
io $ pprintClosureCommand session bind force str
stepCmd :: String -> GHCi Bool
-stepCmd [] = doContinue True
-stepCmd expression = do
- 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 False
+continueCmd [] = doContinue GHC.RunToCompletion
continueCmd other = do
io $ putStrLn "The continue command accepts no arguments."
return False
-doContinue :: Bool -> GHCi Bool
+doContinue :: SingleStep -> GHCi Bool
doContinue step = do
session <- getSession
- let resume | step = GHC.stepResume
- | otherwise = GHC.resume
- runResult <- io $ resume session
+ runResult <- io $ GHC.resume session step
afterRunStmt runResult
return False
abandonCmd :: String -> GHCi ()
-abandonCmd "" = do
+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 ()
-abandonCmd _ = do
- io $ putStrLn "The abandon command accepts no arguments."
deleteCmd :: String -> GHCi ()
deleteCmd argLine = do
| 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 ()
breakCmd argLine = 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 = 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 GHC.isGoodSrcLoc loc
- then findBreakAndSet (GHC.nameModule n) $
+ | 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 $ text "can't find its location: " <>
- ppr loc
- where
- noCanDo why = printForUser $
+ 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
end_bold = BS.pack "\ESC[0m"
listCmd :: String -> GHCi ()
-listCmd str = do
+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
- resumes <- io $ GHC.getResumeContext session
- case resumes of
- [] -> printForUser $ text "not stopped at a breakpoint; nothing to list"
- eval:_ -> io $ listAround (GHC.resumeSpan eval) True
+ 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
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
session <- getSession
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