Support for adding custom commands to an individual breakpoint

  :set stop N <cmd>

runs <cmd> when breakpoint N is hit.  Note that the command to run
might be a macro (defined with :def), and the macro can invoke
:continue, so it is now possible to do clever things like conditional
breakpoints, or ignoring the next K hits of a breakpoint.

diff --git a/compiler/ghci/GhciMonad.hs b/compiler/ghci/GhciMonad.hs
index 9e31376..f68da83 100644 (file)
--- a/compiler/ghci/GhciMonad.hs
+++ b/compiler/ghci/GhciMonad.hs
@@ -50,10 +50,11 @@ data GHCiState = GHCiState
         prelude        :: GHC.Module,
         break_ctr      :: !Int,
         breaks         :: ![(Int, BreakLocation)],
-        tickarrays     :: ModuleEnv TickArray
+        tickarrays     :: ModuleEnv TickArray,
                 -- tickarrays caches the TickArray for loaded modules,
                 -- so that we don't rebuild it each time the user sets
                 -- a breakpoint.
+        cmdqueue       :: [String]
      }
 
 type TickArray = Array Int [(BreakIndex,SrcSpan)]
@@ -69,15 +70,22 @@ data BreakLocation
    { breakModule :: !GHC.Module
    , breakLoc    :: !SrcSpan
    , breakTick   :: {-# UNPACK #-} !Int
+   , onBreakCmd  :: String
    } 
-   deriving Eq
+
+instance Eq BreakLocation where
+  loc1 == loc2 = breakModule loc1 == breakModule loc2 &&
+                 breakTick loc1   == breakTick loc2
 
 prettyLocations :: [(Int, BreakLocation)] -> SDoc
 prettyLocations []   = text "No active breakpoints." 
 prettyLocations locs = vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ reverse $ locs
 
 instance Outputable BreakLocation where
-   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc)
+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
+                if null (onBreakCmd loc)
+                   then empty
+                   else doubleQuotes (text (onBreakCmd loc))
 
 recordBreak :: BreakLocation -> GHCi (Bool{- was already present -}, Int)
 recordBreak brkLoc = do

diff --git a/compiler/ghci/InteractiveUI.hs b/compiler/ghci/InteractiveUI.hs
index bc0b3bc..6d0a870 100644 (file)
--- a/compiler/ghci/InteractiveUI.hs
+++ b/compiler/ghci/InteractiveUI.hs
@@ -287,7 +287,8 @@ interactiveUI session srcs maybe_expr = do
                    prelude = prel_mod,
                    break_ctr = 0,
                    breaks = [],
-                   tickarrays = emptyModuleEnv
+                   tickarrays = emptyModuleEnv,
+                   cmdqueue = []
                  }
 
 #ifdef USE_READLINE
@@ -446,17 +447,9 @@ fileLoop hdl show_prompt = do
        Right l -> 
          case removeSpaces l of
             "" -> fileLoop hdl show_prompt
-           l  -> do quit <- runCommand l
+           l  -> do quit <- runCommands l
                      if quit then return () else fileLoop hdl show_prompt
 
-stringLoop :: [String] -> GHCi Bool{-True: we quit-}
-stringLoop [] = return False
-stringLoop (s:ss) = do
-   case removeSpaces s of
-       "" -> stringLoop ss
-       l  -> do quit <- runCommand l
-                 if quit then return True else stringLoop ss
-
 mkPrompt = do
   session <- getSession
   (toplevs,exports) <- io (GHC.getContext session)
@@ -514,17 +507,31 @@ readlineLoop = do
            "" -> readlineLoop
            l  -> do
                  io (addHistory l)
-                 quit <- runCommand l
+                 quit <- runCommands l
                  if quit then return () else readlineLoop
 #endif
 
-runCommand :: String -> GHCi Bool
-runCommand c = ghciHandle handler (doCommand c)
-  where 
-    doCommand (':' : command) = specialCommand command
-    doCommand stmt
-       = do timeIt $ runStmt stmt GHC.RunToCompletion
-            return False
+runCommands :: String -> GHCi Bool
+runCommands cmd = do
+        q <- ghciHandle handler (doCommand cmd)
+        if q then return True else runNext
+  where
+       runNext = do
+          st <- getGHCiState
+          case cmdqueue st of
+            []   -> return False
+            c:cs -> do setGHCiState st{ cmdqueue = cs }
+                       runCommands c
+
+       doCommand (':' : cmd) = specialCommand cmd
+       doCommand stmt        = do timeIt $ runStmt stmt GHC.RunToCompletion
+                                  return False
+
+enqueueCommands :: [String] -> GHCi ()
+enqueueCommands cmds = do
+  st <- getGHCiState
+  setGHCiState st{ cmdqueue = cmds ++ cmdqueue st }
+
 
 -- This version is for the GHC command-line option -e.  The only difference
 -- from runCommand is that it catches the ExitException exception and
@@ -563,14 +570,15 @@ afterRunStmt run_result = do
      GHC.RunOk names -> do
         show_types <- isOptionSet ShowType
         when show_types $ mapM_ (showTypeOfName session) names
-     GHC.RunBreak _ names _ -> do
+     GHC.RunBreak _ names info -> do
         resumes <- io $ GHC.getResumeContext session
         printForUser $ ptext SLIT("Stopped at") <+> 
                        ppr (GHC.resumeSpan (head resumes))
         mapM_ (showTypeOfName session) names
+        runBreakCmd info
         -- run the command set with ":set stop <cmd>"
         st <- getGHCiState
-        runCommand (stop st)
+        enqueueCommands [stop st]
         return ()
      _ -> return ()
 
@@ -581,6 +589,17 @@ afterRunStmt run_result = do
 
   return (case run_result of GHC.RunOk _ -> True; _ -> False)
 
+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,
+                breakModule loc == mod, breakTick loc == nm ] of
+        []  -> return ()
+        loc:_ | null cmd  -> return ()
+              | otherwise -> do enqueueCommands [cmd]; return ()
+              where cmd = onBreakCmd loc
 
 showTypeOfName :: Session -> Name -> GHCi ()
 showTypeOfName session n
@@ -674,8 +693,7 @@ pprInfo exts (thing, fixity, insts)
 runMain :: String -> GHCi ()
 runMain args = do
   let ss = concat $ intersperse "," (map (\ s -> ('"':s)++"\"") (toArgs args))
-  runCommand $ '[': ss ++ "] `System.Environment.withArgs` main"
-  return ()
+  enqueueCommands  ['[': ss ++ "] `System.Environment.withArgs` main"]
 
 addModule :: [FilePath] -> GHCi ()
 addModule files = do
@@ -748,7 +766,8 @@ defineMacro s = do
 runMacro :: GHC.HValue{-String -> IO String-} -> String -> GHCi Bool
 runMacro fun s = do
   str <- io ((unsafeCoerce# fun :: String -> IO String) s)
-  stringLoop (lines str)
+  enqueueCommands (lines str)
+  return False
 
 undefineMacro :: String -> GHCi ()
 undefineMacro macro_name = do
@@ -1064,6 +1083,19 @@ setEditor cmd = do
   st <- getGHCiState
   setGHCiState st{ editor = cmd }
 
+setStop str@(c:_) | isDigit c
+  = do let (nm_str,rest) = break (not.isDigit) str
+           nm = read nm_str
+       st <- getGHCiState
+       let old_breaks = breaks st
+       if all ((/= nm) . fst) old_breaks
+              then printForUser (text "Breakpoint" <+> ppr nm <+>
+                                 text "does not exist")
+              else do
+       let new_breaks = map fn old_breaks
+           fn (i,loc) | i == nm   = (i,loc { onBreakCmd = dropWhile isSpace rest })
+                      | otherwise = (i,loc)
+       setGHCiState st{ breaks = new_breaks }
 setStop cmd = do
   st <- getGHCiState
   setGHCiState st{ stop = cmd }
@@ -1518,8 +1550,7 @@ backCmd = noArgs $ do
   mapM_ (showTypeOfName s) names
    -- run the command set with ":set stop <cmd>"
   st <- getGHCiState
-  runCommand (stop st)
-  return ()
+  enqueueCommands [stop st]
 
 forwardCmd :: String -> GHCi ()
 forwardCmd = noArgs $ do
@@ -1531,8 +1562,7 @@ forwardCmd = noArgs $ do
   mapM_ (showTypeOfName s) names
    -- run the command set with ":set stop <cmd>"
   st <- getGHCiState
-  runCommand (stop st)
-  return ()
+  enqueueCommands [stop st]
 
 -- handle the "break" command
 breakCmd :: String -> GHCi ()
@@ -1596,6 +1626,7 @@ findBreakAndSet mod lookupTickTree = do
                              { breakModule = mod
                              , breakLoc = span
                              , breakTick = tick
+                             , onBreakCmd = ""
                              }
                printForUser $
                   text "Breakpoint " <> ppr nm <>