{-# 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
import GHC.Types.Name.Occurrence (sizeOccEnv)
import GHC.ByteCode.Breakpoints
import GHC.Utils.Error (logOutput)
import GHC.Driver.DynFlags as GHC
import GHC.Driver.Env
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.Session
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
    Interp -> BreakpointId -> BreakTickIndex -> Debugger ()
forall (m :: * -> *).
GhcMonad m =>
Interp -> BreakpointId -> BreakTickIndex -> m ()
GHC.setupBreakpoint (HscEnv -> Interp
hscInterp HscEnv
hsc_env) BreakpointId
bid (BreakpointStatus -> BreakTickIndex
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 (Int, RealSrcSpan))
getBreakpointsAt :: ModSummary
-> BreakTickIndex
-> Maybe BreakTickIndex
-> Debugger (Maybe (BreakTickIndex, RealSrcSpan))
getBreakpointsAt ModSummary
modl BreakTickIndex
lineNum Maybe BreakTickIndex
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 BreakTickIndex
Nothing -> BreakTickIndex -> TickArray -> Maybe (BreakTickIndex, RealSrcSpan)
findBreakByLine BreakTickIndex
lineNum TickArray
ticks
          Just BreakTickIndex
col -> (BreakTickIndex, BreakTickIndex)
-> TickArray -> Maybe (BreakTickIndex, RealSrcSpan)
findBreakByCoord (BreakTickIndex
lineNum, BreakTickIndex
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, BreakTickIndex
lineNum :: BreakTickIndex
lineNum :: Breakpoint -> BreakTickIndex
lineNum, Maybe BreakTickIndex
columnNum :: Maybe BreakTickIndex
columnNum :: Breakpoint -> Maybe BreakTickIndex
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
-> BreakTickIndex
-> Maybe BreakTickIndex
-> Debugger (Maybe (BreakTickIndex, RealSrcSpan))
getBreakpointsAt ModSummary
modl BreakTickIndex
lineNum Maybe BreakTickIndex
columnNum

      case mbid of
        Maybe (BreakTickIndex, RealSrcSpan)
Nothing -> BreakFound -> Debugger BreakFound
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return BreakFound
BreakNotFound
        Just (BreakTickIndex
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 :: BreakTickIndex
bi_tick_index = BreakTickIndex
bix }
#if MIN_VERSION_ghc(9,14,2)
          (changed, ibis) <- registerBreakpoint bid bp_status ModuleBreakpointKind
#else
          changed <- BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool
registerBreakpoint BreakpointId
bid BreakpointStatus
bp_status BreakpointKind
ModuleBreakpointKind
#endif
          return $ BreakFound
            { changed = changed
            , sourceSpan = realSrcSpanToSourceSpan spn
#if MIN_VERSION_ghc(9,14,2)
            , breakId = ibis
#else
            , breakId = bid
#endif
            }
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 InternalModBreaks
modBreaks = ModuleInfo -> Maybe InternalModBreaks
GHC.modInfoModBreaks ModuleInfo
mod_info
          applyBreak :: (BreakTickIndex, RealSrcSpan) -> Debugger BreakFound
applyBreak (BreakTickIndex
bix, RealSrcSpan
spn) = do
            let bid :: BreakpointId
bid = BreakpointId { bi_tick_mod :: Module
bi_tick_mod = Module
modl
                                   , bi_tick_index :: BreakTickIndex
bi_tick_index = BreakTickIndex
bix }
#if MIN_VERSION_ghc(9,14,2)
            (changed, ibis) <- registerBreakpoint bid bp_status FunctionBreakpointKind
#else
            changed <- BreakpointId -> BreakpointStatus -> BreakpointKind -> Debugger Bool
registerBreakpoint BreakpointId
bid BreakpointStatus
bp_status BreakpointKind
FunctionBreakpointKind
#endif
            return $ BreakFound
              { changed = changed
              , sourceSpan = realSrcSpanToSourceSpan spn
#if MIN_VERSION_ghc(9,14,2)
              , breakId = ibis
#else
              , breakId = bid
#endif
              }
      case [(BreakTickIndex, RealSrcSpan)]
-> (InternalModBreaks -> [(BreakTickIndex, RealSrcSpan)])
-> Maybe InternalModBreaks
-> [(BreakTickIndex, RealSrcSpan)]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (FilePath -> ModBreaks -> [(BreakTickIndex, RealSrcSpan)]
findBreakForBind FilePath
fun_str (ModBreaks -> [(BreakTickIndex, RealSrcSpan)])
-> (InternalModBreaks -> ModBreaks)
-> InternalModBreaks
-> [(BreakTickIndex, RealSrcSpan)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalModBreaks -> ModBreaks
imodBreaks_modBreaks) Maybe InternalModBreaks
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
        [(BreakTickIndex, RealSrcSpan)
b] -> (BreakTickIndex, RealSrcSpan) -> Debugger BreakFound
applyBreak (BreakTickIndex, RealSrcSpan)
b
        [(BreakTickIndex, 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]
++ [(BreakTickIndex, RealSrcSpan)] -> FilePath
forall a. Show a => a -> FilePath
show [(BreakTickIndex, 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
<$> ((BreakTickIndex, RealSrcSpan) -> Debugger BreakFound)
-> [(BreakTickIndex, 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 (BreakTickIndex, RealSrcSpan) -> Debugger BreakFound
applyBreak [(BreakTickIndex, 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
  setInteractiveDebuggerDynFlags $ dflags `ch_opt` opt
  return (BreakFoundNoLoc didChange)