+-- commands for debugger
+foreign import ccall "rts_setStepFlag" setStepFlag :: IO ()
+
+stepCmd :: String -> GHCi Bool
+stepCmd [] = doContinue setStepFlag
+stepCmd expression = do
+ io $ setStepFlag
+ runCommand expression
+
+continueCmd :: String -> GHCi Bool
+continueCmd [] = doContinue $ return ()
+continueCmd other = do
+ io $ putStrLn "The continue command accepts no arguments."
+ return False
+
+doContinue :: IO () -> GHCi Bool
+doContinue actionBeforeCont = do
+ resumeAction <- getResume
+ popResume
+ case resumeAction of
+ Nothing -> do
+ io $ putStrLn "There is no computation running."
+ return False
+ Just action -> do
+ io $ actionBeforeCont
+ runResult <- io action
+ names <- switchOnRunResult runResult
+ finishEvalExpr names
+ return False
+
+deleteCmd :: String -> GHCi Bool
+deleteCmd argLine = do
+ deleteSwitch $ words argLine
+ return False
+ where
+ deleteSwitch :: [String] -> GHCi ()
+ deleteSwitch [] =
+ io $ putStrLn "The delete command requires at least one argument."
+ -- delete all break points
+ deleteSwitch ("*":_rest) = clearActiveBreakPoints
+ deleteSwitch idents = do
+ mapM_ deleteOneBreak idents
+ where
+ deleteOneBreak :: String -> GHCi ()
+ deleteOneBreak str
+ | all isDigit str = deleteBreak (read str)
+ | otherwise = return ()
+
+-- handle the "break" command
+breakCmd :: String -> GHCi Bool
+breakCmd argLine = do
+ session <- getSession
+ breakSwitch session $ words argLine
+
+breakSwitch :: Session -> [String] -> GHCi Bool
+breakSwitch _session [] = do
+ io $ putStrLn "The break command requires at least one argument."
+ return False
+breakSwitch session args@(arg1:rest)
+ | looksLikeModule arg1 = do
+ mod <- lookupModule session arg1
+ breakByModule mod rest
+ return False
+ | otherwise = do
+ (toplevel, _) <- io $ GHC.getContext session
+ case toplevel of
+ (mod : _) -> breakByModule mod args
+ [] -> do
+ io $ putStrLn "Cannot find default module for breakpoint."
+ io $ putStrLn "Perhaps no modules are loaded for debugging?"
+ return False
+ where
+ -- Todo there may be a nicer way to test this
+ looksLikeModule :: String -> Bool
+ looksLikeModule [] = False
+ looksLikeModule (x:_) = isUpper x
+
+breakByModule :: Module -> [String] -> GHCi ()
+breakByModule mod args@(arg1:rest)
+ | all isDigit arg1 = do -- looks like a line number
+ breakByModuleLine mod (read arg1) rest
+ | looksLikeVar arg1 = do
+ -- break by a function definition
+ io $ putStrLn "Break by function definition not implemented."
+ | otherwise = io $ putStrLn "Invalid arguments to break command."
+ where
+ -- Todo there may be a nicer way to test this
+ looksLikeVar :: String -> Bool
+ looksLikeVar [] = False
+ looksLikeVar (x:_) = isLower x || x `elem` "~!@#$%^&*-+"
+
+breakByModuleLine :: Module -> Int -> [String] -> GHCi ()
+breakByModuleLine mod line args
+ | [] <- args = findBreakAndSet mod $ lookupTickTreeLine line
+ | [col] <- args, all isDigit col =
+ findBreakAndSet mod $ lookupTickTreeCoord (line, read col)
+ | otherwise = io $ putStrLn "Invalid arguments to break command."
+
+findBreakAndSet :: Module -> (TickTree -> Maybe (Int, SrcSpan)) -> GHCi ()
+findBreakAndSet mod lookupTickTree = do
+ (breakArray, ticks) <- getModBreak mod
+ let tickTree = tickTreeFromList (assocs ticks)
+ case lookupTickTree tickTree of
+ Nothing -> io $ putStrLn $ "No breakpoints found at that location."
+ Just (tick, span) -> do
+ success <- io $ setBreakFlag True breakArray tick
+ session <- getSession
+ unqual <- io $ GHC.getPrintUnqual session
+ if success
+ then do
+ (alreadySet, nm) <-
+ recordBreak $ BreakLocation
+ { breakModule = mod
+ , breakLoc = span
+ , breakTick = tick
+ }
+ io $ printForUser stdout unqual $
+ text "Breakpoint " <> ppr nm <>
+ if alreadySet
+ then text " was already set at " <> ppr span
+ else text " activated at " <> ppr span
+ else do
+ str <- showForUser $ text "Breakpoint could not be activated at"
+ <+> ppr span
+ io $ putStrLn str
+
+getModBreak :: Module -> GHCi (BreakArray, Array Int SrcSpan)
+getModBreak mod = do
+ session <- getSession
+ Just mod_info <- io $ GHC.getModuleInfo session mod
+ let modBreaks = GHC.modInfoModBreaks mod_info
+ let array = modBreaks_array modBreaks
+ let ticks = modBreaks_ticks modBreaks
+ return (array, ticks)