{-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,
   DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,
   TypeApplications, ScopedTypeVariables, BangPatterns #-}
module GHC.Debugger.Breakpoint where

import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.IORef
import Data.Bits (xor)

import GHC
#if MIN_VERSION_ghc(9,13,20250417)
import GHC.Types.Name.Occurrence (sizeOccEnv)
#endif
import GHC.Utils.Error (logOutput)
import GHC.Driver.DynFlags as GHC
import GHC.Driver.Ppr as GHC
import GHC.Runtime.Debugger.Breakpoints as GHC
import GHC.Unit.Module.Env as GHC
import GHC.Utils.Outputable as GHC

import GHC.Debugger.Monad
import GHC.Debugger.Utils
import GHC.Debugger.Interface.Messages

--------------------------------------------------------------------------------
-- * Breakpoints
--------------------------------------------------------------------------------

-- | Remove all module breakpoints set on the given loaded module by path
--
-- If the argument is @Nothing@, clear all function breakpoints instead.
clearBreakpoints :: Maybe FilePath -> Debugger ()
clearBreakpoints :: Maybe FilePath -> Debugger ()
clearBreakpoints Maybe FilePath
mfile = do
  -- It would be simpler to go to all loaded modules and disable all
  -- breakpoints for that module rather than keeping track,
  -- but much less efficient at scale.
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  bids <- getActiveBreakpoints mfile
  forM_ bids $ \BreakpointId
bid -> do
    HscEnv -> BreakpointId -> BreakIndex -> Debugger ()
forall (m :: * -> *).
GhcMonad m =>
HscEnv -> BreakpointId -> BreakIndex -> m ()
GHC.setupBreakpoint HscEnv
hsc_env BreakpointId
bid (BreakpointStatus -> BreakIndex
breakpointStatusInt BreakpointStatus
BreakpointDisabled)

  -- Clear out the state
  bpsRef <- asks activeBreakpoints
  liftIO $ writeIORef bpsRef emptyModuleEnv

-- | Find a 'BreakpointId' and its span from a module + line + column.
--
-- Used by 'setBreakpoints' and 'GetBreakpointsAt' requests
getBreakpointsAt :: ModSummary {-^ module -} -> Int {-^ line num -} -> Maybe Int {-^ column num -} -> Debugger (Maybe (BreakIndex, RealSrcSpan))
getBreakpointsAt :: ModSummary
-> BreakIndex
-> Maybe BreakIndex
-> Debugger (Maybe (BreakIndex, RealSrcSpan))
getBreakpointsAt ModSummary
modl BreakIndex
lineNum Maybe BreakIndex
columnNum = do
  -- TODO: Cache moduleLineMap.
  mticks <- Module -> Debugger (Maybe TickArray)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe TickArray)
makeModuleLineMap (ModSummary -> Module
ms_mod ModSummary
modl)
  let mbid = do
        ticks <- Maybe TickArray
mticks
        case columnNum of
          Maybe BreakIndex
Nothing -> BreakIndex -> TickArray -> Maybe (BreakIndex, RealSrcSpan)
findBreakByLine BreakIndex
lineNum TickArray
ticks
          Just BreakIndex
col -> (BreakIndex, BreakIndex)
-> TickArray -> Maybe (BreakIndex, RealSrcSpan)
findBreakByCoord (BreakIndex
lineNum, BreakIndex
col) TickArray
ticks
  return mbid

-- | Set a breakpoint in this session
setBreakpoint :: Breakpoint -> BreakpointStatus -> Debugger BreakFound
setBreakpoint :: Breakpoint -> BreakpointStatus -> Debugger BreakFound
setBreakpoint ModuleBreak{FilePath
path :: FilePath
path :: Breakpoint -> FilePath
path, BreakIndex
lineNum :: BreakIndex
lineNum :: Breakpoint -> BreakIndex
lineNum, Maybe BreakIndex
columnNum :: Maybe BreakIndex
columnNum :: Breakpoint -> Maybe BreakIndex
columnNum} BreakpointStatus
bp_status = do
  mmodl <- FilePath -> Debugger (Either FilePath ModSummary)
getModuleByPath FilePath
path
  case mmodl of
    Left FilePath
e -> do
      [FilePath] -> Debugger ()
displayWarnings [FilePath
e]
      BreakFound -> Debugger BreakFound
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return BreakFound
BreakNotFound
    Right ModSummary
modl -> do
      mbid <- ModSummary
-> BreakIndex
-> Maybe BreakIndex
-> Debugger (Maybe (BreakIndex, RealSrcSpan))
getBreakpointsAt ModSummary
modl BreakIndex
lineNum Maybe BreakIndex
columnNum

      case mbid of
        Maybe (BreakIndex, RealSrcSpan)
Nothing -> BreakFound -> Debugger BreakFound
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return BreakFound
BreakNotFound
        Just (BreakIndex
bix, RealSrcSpan
spn) -> do
          let bid :: BreakpointId
bid = BreakpointId { bi_tick_mod :: Module
bi_tick_mod = ModSummary -> Module
ms_mod ModSummary
modl
                                 , bi_tick_index :: BreakIndex
bi_tick_index = BreakIndex
bix }
          changed <- BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool
registerBreakpoint BreakpointId
bid BreakpointStatus
bp_status BreakpointKind
ModuleBreakpointKind
          return $ BreakFound
            { changed = changed
            , sourceSpan = realSrcSpanToSourceSpan spn
            , breakId = bid
            }
setBreakpoint FunctionBreak{FilePath
function :: FilePath
function :: Breakpoint -> FilePath
function} BreakpointStatus
bp_status = do
  logger <- Debugger Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  resolveFunctionBreakpoint function >>= \case
    Left SDoc
e -> FilePath -> Debugger BreakFound
forall a. HasCallStack => FilePath -> a
error (SDoc -> FilePath
forall a. Outputable a => a -> FilePath
showPprUnsafe SDoc
e)
    Right (Module
modl, ModuleInfo
mod_info, FilePath
fun_str) -> do
      let modBreaks :: Maybe ModBreaks
modBreaks = ModuleInfo -> Maybe ModBreaks
GHC.modInfoModBreaks ModuleInfo
mod_info
          applyBreak :: (BreakIndex, RealSrcSpan) -> Debugger BreakFound
applyBreak (BreakIndex
bix, RealSrcSpan
spn) = do
            let bid :: BreakpointId
bid = BreakpointId { bi_tick_mod :: Module
bi_tick_mod = Module
modl
                                   , bi_tick_index :: BreakIndex
bi_tick_index = BreakIndex
bix }
            changed <- BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool
registerBreakpoint BreakpointId
bid BreakpointStatus
bp_status BreakpointKind
FunctionBreakpointKind
            return $ BreakFound
              { changed = changed
              , sourceSpan = realSrcSpanToSourceSpan spn
              , breakId = bid
              }
      case [(BreakIndex, RealSrcSpan)]
-> (ModBreaks -> [(BreakIndex, RealSrcSpan)])
-> Maybe ModBreaks
-> [(BreakIndex, RealSrcSpan)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (FilePath -> ModBreaks -> [(BreakIndex, RealSrcSpan)]
findBreakForBind FilePath
fun_str) Maybe ModBreaks
modBreaks of
        []  -> do
          IO () -> Debugger ()
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Debugger ()) -> IO () -> Debugger ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
logOutput Logger
logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> SDoc) -> FilePath -> SDoc
forall a b. (a -> b) -> a -> b
$ FilePath
"No breakpoint found by name " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
function FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". Ignoring...")
          BreakFound -> Debugger BreakFound
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return BreakFound
BreakNotFound
        [(BreakIndex, RealSrcSpan)
b] -> (BreakIndex, RealSrcSpan) -> Debugger BreakFound
applyBreak (BreakIndex, RealSrcSpan)
b
        [(BreakIndex, RealSrcSpan)]
bs  -> do
          IO () -> Debugger ()
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Debugger ()) -> IO () -> Debugger ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
logOutput Logger
logger (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> SDoc) -> FilePath -> SDoc
forall a b. (a -> b) -> a -> b
$ FilePath
"Ambiguous breakpoint found by name " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
function FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [(BreakIndex, RealSrcSpan)] -> FilePath
forall a. Show a => a -> FilePath
show [(BreakIndex, RealSrcSpan)]
bs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". Setting breakpoints in all...")
          [BreakFound] -> BreakFound
ManyBreaksFound ([BreakFound] -> BreakFound)
-> Debugger [BreakFound] -> Debugger BreakFound
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((BreakIndex, RealSrcSpan) -> Debugger BreakFound)
-> [(BreakIndex, RealSrcSpan)] -> Debugger [BreakFound]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (BreakIndex, RealSrcSpan) -> Debugger BreakFound
applyBreak [(BreakIndex, RealSrcSpan)]
bs
setBreakpoint Breakpoint
exception_bp BreakpointStatus
bp_status = do
  let ch_opt :: DynFlags -> GeneralFlag -> DynFlags
ch_opt | BreakpointStatus
BreakpointDisabled <- BreakpointStatus
bp_status
             = DynFlags -> GeneralFlag -> DynFlags
gopt_unset
             | Bool
otherwise
             = DynFlags -> GeneralFlag -> DynFlags
gopt_set
      opt :: GeneralFlag
opt | Breakpoint
OnUncaughtExceptionsBreak <- Breakpoint
exception_bp
          = GeneralFlag
Opt_BreakOnError
          | Breakpoint
OnExceptionsBreak <- Breakpoint
exception_bp
          = GeneralFlag
Opt_BreakOnException
  dflags <- Debugger DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
GHC.getInteractiveDynFlags
  let
    -- changed if option is ON and bp is OFF (breakpoint disabled), or if
    -- option is OFF and bp is ON (i.e. XOR)
    breakOn = BreakpointStatus
bp_status BreakpointStatus -> BreakpointStatus -> Bool
forall a. Eq a => a -> a -> Bool
/= BreakpointStatus
BreakpointDisabled
    didChange = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
opt DynFlags
dflags Bool -> Bool -> Bool
forall a. Bits a => a -> a -> a
`xor` Bool
breakOn
  GHC.setInteractiveDynFlags $ dflags `ch_opt` opt
  return (BreakFoundNoLoc didChange)