Add disable/enable commands to ghci debugger #2215

This patch adds two new commands `:enable` and `:disable` to the GHCi debugger.
Opposite to `:set stop <n> :continue` a breakpoint disabled with `:disable` will
not loose its previously set stop command.
A new field breakEnabled is added to the BreakLocation data structure to
track the enable/disable state. When a breakpoint is disabled with a `:disable`
command, the following happens:

The corresponding BreakLocation data element is searched dictionary of the
`breaks` field of the GHCiStateMonad. If the break point is found and not
already in the disabled state, the breakpoint is removed from bytecode.
The BreakLocation data structure is kept in the breaks list and the new
breakEnabled field is set to false.

The `:enable` command works similar.

The breaks field in the GHCiStateMonad was changed from an association list
to int `IntMap`.

2 files changed, 101 insertions, 32 deletions

diff --git a/ghc/GHCi/UI.hs b/ghc/GHCi/UI.hs
index 7b64644526..ab3992ccd0 100644
--- a/ghc/GHCi/UI.hs
+++ b/ghc/GHCi/UI.hs
@@ -108,6 +108,7 @@ import qualified Data.Set as S
 import Data.Maybe
 import Data.Map (Map)
 import qualified Data.Map as M
+import qualified Data.IntMap.Strict as IntMap
 import Data.Time.LocalTime ( getZonedTime )
 import Data.Time.Format ( formatTime, defaultTimeLocale )
 import Data.Version ( showVersion )
@@ -187,8 +188,10 @@ ghciCommands = map mkCmd [
   ("def",       keepGoing (defineMacro False),  completeExpression),
   ("def!",      keepGoing (defineMacro True),   completeExpression),
   ("delete",    keepGoing deleteCmd,            noCompletion),
+  ("disable",   keepGoing disableCmd,           noCompletion),
   ("doc",       keepGoing' docCmd,              completeIdentifier),
   ("edit",      keepGoing' editFile,            completeFilename),
+  ("enable",    keepGoing enableCmd,            noCompletion),
   ("etags",     keepGoing createETagsFileCmd,   completeFilename),
   ("force",     keepGoing forceCmd,             completeExpression),
   ("forward",   keepGoing forwardCmd,           noCompletion),
@@ -331,8 +334,12 @@ defFullHelpText =
   "   :break [<mod>] <l> [<col>]  set a breakpoint at the specified location\n" ++
   "   :break <name>               set a breakpoint on the specified function\n" ++
   "   :continue                   resume after a breakpoint\n" ++
-  "   :delete <number>            delete the specified breakpoint\n" ++
+  "   :delete <number> ...        delete the specified breakpoints\n" ++
   "   :delete *                   delete all breakpoints\n" ++
+  "   :disable <number> ...       disable the specified breakpoints\n" ++
+  "   :disable *                  disable all breakpoints\n" ++
+  "   :enable <number> ...        enable the specified breakpoints\n" ++
+  "   :enable *                   enable all breakpoints\n" ++
   "   :force <expr>               print <expr>, forcing unevaluated parts\n" ++
   "   :forward [<n>]              go forward in the history N step s(after :back)\n" ++
   "   :history [<n>]              after :trace, show the execution history\n" ++
@@ -493,7 +500,7 @@ interactiveUI config srcs maybe_exprs = do
                    -- incremented after reading a line.
                    line_number        = 0,
                    break_ctr          = 0,
-                   breaks             = [],
+                   breaks             = IntMap.empty,
                    tickarrays         = emptyModuleEnv,
                    ghci_commands      = availableCommands config,
                    ghci_macros        = [],
@@ -1300,7 +1307,7 @@ toBreakIdAndLocation (Just inf) = do
   let md = GHC.breakInfo_module inf
       nm = GHC.breakInfo_number inf
   st <- getGHCiState
-  return $ listToMaybe [ id_loc | id_loc@(_,loc) <- breaks st,
+  return $ listToMaybe [ id_loc | id_loc@(_,loc) <- IntMap.assocs (breaks st),
                                   breakModule loc == md,
                                   breakTick loc == nm ]
 
@@ -2813,14 +2820,14 @@ setStop str@(c:_) | isDigit c
            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 }
+       case IntMap.lookup nm old_breaks of
+         Nothing ->  printForUser (text "Breakpoint" <+> ppr nm <+>
+                                   text "does not exist")
+         Just loc -> do
+            let new_breaks = IntMap.insert nm
+                                loc { onBreakCmd = dropWhile isSpace rest }
+                                old_breaks
+            setGHCiState st{ breaks = new_breaks }
 setStop cmd = modifyGHCiState (\st -> st { stop = cmd })
 
 setPrompt :: GhciMonad m => PromptFunction -> m ()
@@ -3521,6 +3528,56 @@ deleteCmd argLine = withSandboxOnly ":delete" $ do
          | all isDigit str = deleteBreak (read str)
          | otherwise = return ()
 
+enableCmd :: GhciMonad m => String -> m ()
+enableCmd argLine = withSandboxOnly ":enable" $ do
+    enaDisaSwitch True $ words argLine
+
+disableCmd :: GhciMonad m => String -> m ()
+disableCmd argLine = withSandboxOnly ":disable" $ do
+    enaDisaSwitch False $ words argLine
+
+enaDisaSwitch :: GhciMonad m => Bool -> [String] -> m ()
+enaDisaSwitch enaDisa [] =
+    printForUser (text "The" <+> text strCmd <+>
+                  text "command requires at least one argument.")
+  where
+    strCmd = if enaDisa then ":enable" else ":disable"
+enaDisaSwitch enaDisa ("*" : _) = enaDisaAllBreaks enaDisa
+enaDisaSwitch enaDisa idents = do
+    mapM_ (enaDisaOneBreak enaDisa) idents
+  where
+    enaDisaOneBreak :: GhciMonad m => Bool -> String -> m ()
+    enaDisaOneBreak enaDisa strId = do
+      sdoc_loc <- getBreakLoc enaDisa strId
+      case sdoc_loc of
+        Left sdoc -> printForUser sdoc
+        Right loc -> enaDisaAssoc enaDisa (read strId, loc)
+
+getBreakLoc :: GhciMonad m => Bool -> String -> m (Either SDoc BreakLocation)
+getBreakLoc enaDisa strId = do
+    st <- getGHCiState
+    case readMaybe strId >>= flip IntMap.lookup (breaks st) of
+      Nothing -> return $ Left (text "Breakpoint" <+> text strId <+>
+                                text "not found")
+      Just loc ->
+        if breakEnabled loc == enaDisa
+           then return $ Left
+               (text "Breakpoint" <+> text strId <+>
+                text "already in desired state")
+           else return $ Right loc
+
+enaDisaAssoc :: GhciMonad m => Bool -> (Int, BreakLocation) -> m ()
+enaDisaAssoc enaDisa (intId, loc) = do
+    st <- getGHCiState
+    newLoc <- turnBreakOnOff enaDisa loc
+    let new_breaks = IntMap.insert intId newLoc (breaks st)
+    setGHCiState $ st { breaks = new_breaks }
+
+enaDisaAllBreaks :: GhciMonad m => Bool -> m()
+enaDisaAllBreaks enaDisa = do
+    st <- getGHCiState
+    mapM_ (enaDisaAssoc enaDisa) $ IntMap.assocs $ breaks st
+
 historyCmd :: GHC.GhcMonad m => String -> m ()
 historyCmd arg
   | null arg        = history 20
@@ -3648,6 +3705,7 @@ findBreakAndSet md lookupTickTree = do
                        , breakLoc = RealSrcSpan pan
                        , breakTick = tick
                        , onBreakCmd = ""
+                       , breakEnabled = True
                        }
          printForUser $
             text "Breakpoint " <> ppr nm <>
@@ -3913,26 +3971,29 @@ mkTickArray ticks
 discardActiveBreakPoints :: GhciMonad m => m ()
 discardActiveBreakPoints = do
    st <- getGHCiState
-   mapM_ (turnOffBreak.snd) (breaks st)
-   setGHCiState $ st { breaks = [] }
+   mapM_ (turnBreakOnOff False) $ breaks st
+   setGHCiState $ st { breaks = IntMap.empty }
 
 deleteBreak :: GhciMonad m => Int -> m ()
 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
+   let oldLocations = breaks st
+   case IntMap.lookup identity oldLocations of
+       Nothing -> printForUser (text "Breakpoint" <+> ppr identity <+>
+                                text "does not exist")
+       Just loc -> do
+           _ <- (turnBreakOnOff False) loc
+           let rest = IntMap.delete identity oldLocations
            setGHCiState $ st { breaks = rest }
 
-turnOffBreak :: GHC.GhcMonad m => BreakLocation -> m ()
-turnOffBreak loc = do
-  (arr, _) <- getModBreak (breakModule loc)
-  hsc_env <- GHC.getSession
-  liftIO $ enableBreakpoint hsc_env arr (breakTick loc) False
+turnBreakOnOff :: GHC.GhcMonad m => Bool -> BreakLocation -> m BreakLocation
+turnBreakOnOff onOff loc
+  | onOff == breakEnabled loc = return loc
+  | otherwise = do
+      (arr, _) <- getModBreak (breakModule loc)
+      hsc_env <- GHC.getSession
+      liftIO $ enableBreakpoint hsc_env arr (breakTick loc) onOff
+      return loc { breakEnabled = onOff }
 
 getModBreak :: GHC.GhcMonad m
             => Module -> m (ForeignRef BreakArray, Array Int SrcSpan)
diff --git a/ghc/GHCi/UI/Monad.hs b/ghc/GHCi/UI/Monad.hs
index 696303b949..6ecb079ea0 100644
--- a/ghc/GHCi/UI/Monad.hs
+++ b/ghc/GHCi/UI/Monad.hs
@@ -66,6 +66,7 @@ import qualified System.Console.Haskeline as Haskeline
 import Control.Monad.Trans.Class
 import Control.Monad.IO.Class
 import Data.Map.Strict (Map)
+import qualified Data.IntMap.Strict as IntMap
 import qualified GHC.LanguageExtensions as LangExt
 
 -----------------------------------------------------------------------------
@@ -84,7 +85,7 @@ data GHCiState = GHCiState
         options        :: [GHCiOption],
         line_number    :: !Int,         -- ^ input line
         break_ctr      :: !Int,
-        breaks         :: ![(Int, BreakLocation)],
+        breaks         :: !(IntMap.IntMap BreakLocation),
         tickarrays     :: ModuleEnv TickArray,
             -- ^ 'tickarrays' caches the 'TickArray' for loaded modules,
             -- so that we don't rebuild it each time the user sets
@@ -213,6 +214,7 @@ data BreakLocation
    { breakModule :: !GHC.Module
    , breakLoc    :: !SrcSpan
    , breakTick   :: {-# UNPACK #-} !Int
+   , breakEnabled:: !Bool
    , onBreakCmd  :: String
    }
 
@@ -220,21 +222,27 @@ 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
+prettyLocations :: IntMap.IntMap BreakLocation -> SDoc
+prettyLocations  locs =
+    case  IntMap.null locs of
+      True  -> text "No active breakpoints."
+      False -> vcat $ map (\(i, loc) -> brackets (int i) <+> ppr loc) $ IntMap.toAscList locs
 
 instance Outputable BreakLocation where
-   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+>
+   ppr loc = (ppr $ breakModule loc) <+> ppr (breakLoc loc) <+> pprEnaDisa <+>
                 if null (onBreakCmd loc)
                    then Outputable.empty
                    else doubleQuotes (text (onBreakCmd loc))
+      where pprEnaDisa = case breakEnabled loc of
+                True  -> text "enabled"
+                False -> text "disabled"
 
 recordBreak
   :: GhciMonad m => BreakLocation -> m (Bool{- was already present -}, Int)
 recordBreak brkLoc = do
    st <- getGHCiState
-   let oldActiveBreaks = breaks st
+   let oldmap = breaks st
+       oldActiveBreaks = IntMap.assocs oldmap
    -- don't store the same break point twice
    case [ nm | (nm, loc) <- oldActiveBreaks, loc == brkLoc ] of
      (nm:_) -> return (True, nm)
@@ -242,7 +250,7 @@ recordBreak brkLoc = do
       let oldCounter = break_ctr st
           newCounter = oldCounter + 1
       setGHCiState $ st { break_ctr = newCounter,
-                          breaks = (oldCounter, brkLoc) : oldActiveBreaks
+                          breaks = IntMap.insert oldCounter brkLoc oldmap
                         }
       return (False, oldCounter)