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

import Prelude hiding ((<>))
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.Bits (xor)
import Data.IORef
import qualified Colog.Core as Logger

import GHC
import GHC.ByteCode.Breakpoints
import GHC.Data.Maybe
import GHC.Driver.DynFlags as GHC
import GHC.Driver.Env
import GHC.Driver.Ppr as GHC
import GHC.Unit.Module.Graph as GHC
import GHC.Runtime.Interpreter
import GHC.Runtime.Debugger.Breakpoints as GHC
import GHC.Utils.Error (logOutput)
import GHC.Utils.Outputable as GHC
import qualified GHCi.BreakArray as BA

import GHC.Debugger.Monad
import GHC.Debugger.Session
import GHC.Debugger.Utils
import GHC.Debugger.Interface.Messages
import qualified GHC.Debugger.Breakpoint.Map as BM
import Data.Function
import System.Directory (getCurrentDirectory)
import GHC.Debugger.Session.Builtin (debuggerRuntimeInternalModName)

--------------------------------------------------------------------------------
-- * 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 AbsFilePath -> Debugger ()
clearBreakpoints :: Maybe AbsFilePath -> Debugger ()
clearBreakpoints Maybe AbsFilePath
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
  bpsRef <- asks activeBreakpoints
  bids <- getActiveBreakpoints mfile
  forM_ bids $ \InternalBreakpointId
bid -> do
    Interp -> InternalBreakpointId -> BreakTickIndex -> Debugger ()
forall (m :: * -> *).
GhcMonad m =>
Interp -> InternalBreakpointId -> BreakTickIndex -> m ()
GHC.setupBreakpoint (HscEnv -> Interp
hscInterp HscEnv
hsc_env) InternalBreakpointId
bid (BreakpointStatus -> BreakTickIndex
breakpointStatusInt BreakpointStatus
BreakpointDisabled)
    -- Clear out from the state
    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
$ IORef (BreakpointMap BreakpointInfo)
-> (BreakpointMap BreakpointInfo -> BreakpointMap BreakpointInfo)
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef (BreakpointMap BreakpointInfo)
bpsRef (InternalBreakpointId
-> BreakpointMap BreakpointInfo -> BreakpointMap BreakpointInfo
forall a.
InternalBreakpointId -> BreakpointMap a -> BreakpointMap a
BM.delete InternalBreakpointId
bid)

getBreakpointsAt :: Breakpoint -> Debugger (Maybe SourceSpan)
getBreakpointsAt :: Breakpoint -> Debugger (Maybe SourceSpan)
getBreakpointsAt ModuleBreak{AbsFilePath
path :: AbsFilePath
path :: Breakpoint -> AbsFilePath
path, BreakTickIndex
lineNum :: BreakTickIndex
lineNum :: Breakpoint -> BreakTickIndex
lineNum, Maybe BreakTickIndex
columnNum :: Maybe BreakTickIndex
columnNum :: Breakpoint -> Maybe BreakTickIndex
columnNum} = do
  mmodl <- AbsFilePath -> Debugger (Either SDoc ModuleNodeInfo)
getModuleByPath AbsFilePath
path
  case mmodl of
    Left SDoc
e -> do
      Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning SDoc
e
      Maybe SourceSpan -> Debugger (Maybe SourceSpan)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SourceSpan
forall a. Maybe a
Nothing
    Right ModuleNodeInfo
modl -> do
      mbfnd <- Module
-> BreakTickIndex
-> Maybe BreakTickIndex
-> Debugger (Maybe (BreakTickIndex, RealSrcSpan))
findBreakpoint (ModuleNodeInfo -> Module
GHC.moduleNodeInfoModule ModuleNodeInfo
modl) BreakTickIndex
lineNum Maybe BreakTickIndex
columnNum
      cwd <- mkAbsolute <$> liftIO getCurrentDirectory
      return $ realSrcSpanToSourceSpan cwd . snd <$> mbfnd
getBreakpointsAt Breakpoint
_ = FilePath -> Debugger (Maybe SourceSpan)
forall a. (?callStack::CallStack) => FilePath -> a
error FilePath
"unexpected getbreakpoints without ModuleBreak"

-- | Set a breakpoint in this session
setBreakpoint :: Breakpoint -> BreakpointStatus -> BreakpointAction -> Debugger BreakFound
setBreakpoint :: Breakpoint
-> BreakpointStatus -> BreakpointAction -> Debugger BreakFound
setBreakpoint Breakpoint
bp BreakpointAfterCountCond{} BreakpointAction
_action = do
  Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning (SDoc -> Debugger ()) -> SDoc -> Debugger ()
forall a b. (a -> b) -> a -> b
$
    FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> SDoc) -> FilePath -> SDoc
forall a b. (a -> b) -> a -> b
$ FilePath
"Setting a hit count condition on a conditional breakpoint is not yet supported. Ignoring breakpoint " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Breakpoint -> FilePath
forall a. Show a => a -> FilePath
show Breakpoint
bp
  BreakFound -> Debugger BreakFound
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return BreakFound
BreakNotFound
setBreakpoint ModuleBreak{AbsFilePath
path :: Breakpoint -> AbsFilePath
path :: AbsFilePath
path, BreakTickIndex
lineNum :: Breakpoint -> BreakTickIndex
lineNum :: BreakTickIndex
lineNum, Maybe BreakTickIndex
columnNum :: Breakpoint -> Maybe BreakTickIndex
columnNum :: Maybe BreakTickIndex
columnNum} BreakpointStatus
bp_status BreakpointAction
action = do
  mmodl <- AbsFilePath -> Debugger (Either SDoc ModuleNodeInfo)
getModuleByPath AbsFilePath
path
  case mmodl of
    Left SDoc
e -> do
      Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning SDoc
e
      BreakFound -> Debugger BreakFound
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return BreakFound
BreakNotFound
    Right ModuleNodeInfo
modl -> do
      Module
-> BreakTickIndex
-> Maybe BreakTickIndex
-> Debugger (Maybe (BreakTickIndex, RealSrcSpan))
findBreakpoint (ModuleNodeInfo -> Module
GHC.moduleNodeInfoModule ModuleNodeInfo
modl) BreakTickIndex
lineNum Maybe BreakTickIndex
columnNum Debugger (Maybe (BreakTickIndex, RealSrcSpan))
-> (Maybe (BreakTickIndex, RealSrcSpan) -> Debugger BreakFound)
-> Debugger BreakFound
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        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 = ModuleNodeInfo -> Module
GHC.moduleNodeInfoModule ModuleNodeInfo
modl
                                 , bi_tick_index :: BreakTickIndex
bi_tick_index = BreakTickIndex
bix }
              binfo :: BreakpointInfo
binfo = BreakpointInfo
                        { bpInfoStatus :: BreakpointStatus
bpInfoStatus = BreakpointStatus
bp_status
                        , bpInfoKind :: BreakpointKind
bpInfoKind = BreakpointKind
ModuleBreakpointKind
                        , bpInfoAction :: BreakpointAction
bpInfoAction = BreakpointAction
action}
          (changed, ibis) <- BreakpointId
-> BreakpointInfo -> Debugger (Bool, [InternalBreakpointId])
registerBreakpoint BreakpointId
bid BreakpointInfo
binfo
          cwd <- mkAbsolute <$> liftIO getCurrentDirectory
          return $ BreakFound
            { changed = changed
            , sourceSpan = realSrcSpanToSourceSpan cwd spn
            , breakId = ibis
            }
setBreakpoint FunctionBreak{FilePath
function :: FilePath
function :: Breakpoint -> FilePath
function} BreakpointStatus
bp_status BreakpointAction
action = do
  logger <- Debugger Logger
forall (m :: * -> *). HasLogger m => m Logger
getLogger
  resolveFunctionBreakpoint function >>= \case
    Left SDoc
e -> 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 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> SDoc) -> FilePath -> SDoc
forall a b. (a -> b) -> a -> b
$
        FilePath
"Failed to resolve function breakpoint " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
function FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
".\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SDoc -> FilePath
forall a. Outputable a => a -> FilePath
showPprUnsafe SDoc
e FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\nIgnoring..."
      BreakFound -> Debugger BreakFound
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return BreakFound
BreakNotFound
    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 }
                binfo :: BreakpointInfo
binfo = BreakpointInfo
                        { bpInfoStatus :: BreakpointStatus
bpInfoStatus = BreakpointStatus
bp_status
                        , bpInfoKind :: BreakpointKind
bpInfoKind = BreakpointKind
FunctionBreakpointKind
                        , bpInfoAction :: BreakpointAction
bpInfoAction = BreakpointAction
action}
            (changed, ibis) <- BreakpointId
-> BreakpointInfo -> Debugger (Bool, [InternalBreakpointId])
registerBreakpoint BreakpointId
bid BreakpointInfo
binfo
            cwd <- mkAbsolute <$> liftIO getCurrentDirectory
            return $ BreakFound
              { changed = changed
              , sourceSpan = realSrcSpanToSourceSpan cwd spn
              , breakId = ibis
              }
      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
-- The assert can be removed once we have a way to register actions for exception breakpoints.
setBreakpoint Breakpoint
exception_bp BreakpointStatus
bp_status BreakpointAction
action = Bool -> Debugger BreakFound -> Debugger BreakFound
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (BreakpointAction
action BreakpointAction -> BreakpointAction -> Bool
forall a. Eq a => a -> a -> Bool
== BreakpointAction
BreakpointStop) (Debugger BreakFound -> Debugger BreakFound)
-> Debugger BreakFound -> Debugger BreakFound
forall a b. (a -> b) -> a -> b
$ 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
getInteractiveDebuggerDynFlags
  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)

--------------------------------------------------------------------------------
-- * Lower-level interface
--------------------------------------------------------------------------------

-- | Registers or deletes a breakpoint in the GHC session and from the list of
-- active breakpoints that is kept in 'DebuggerState', depending on the
-- 'BreakpointStatus' being set.
--
-- Returns @True@ when the breakpoint status is changed.
registerBreakpoint :: GHC.BreakpointId -> BreakpointInfo -> Debugger (Bool, [GHC.InternalBreakpointId])
registerBreakpoint :: BreakpointId
-> BreakpointInfo -> Debugger (Bool, [InternalBreakpointId])
registerBreakpoint BreakpointId
bp info :: BreakpointInfo
info@BreakpointInfo{bpInfoStatus :: BreakpointInfo -> BreakpointStatus
bpInfoStatus = BreakpointStatus
status} = do

  -- Set breakpoint in GHC session
  let breakpoint_count :: BreakTickIndex
breakpoint_count = BreakpointStatus -> BreakTickIndex
breakpointStatusInt BreakpointStatus
status
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
GHC.getSession
  internal_break_ids <- getInternalBreaksOf bp
  changed <- forM internal_break_ids $ \InternalBreakpointId
ibi -> do
    Interp -> InternalBreakpointId -> BreakTickIndex -> Debugger ()
forall (m :: * -> *).
GhcMonad m =>
Interp -> InternalBreakpointId -> BreakTickIndex -> m ()
GHC.setupBreakpoint (HscEnv -> Interp
hscInterp HscEnv
hsc_env) InternalBreakpointId
ibi BreakTickIndex
breakpoint_count

    -- Register breakpoint in Debugger state for every internal breakpoint
    brksMapRef <- (DebuggerState -> IORef (BreakpointMap BreakpointInfo))
-> Debugger (IORef (BreakpointMap BreakpointInfo))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef (BreakpointMap BreakpointInfo)
activeBreakpoints
    liftIO $ atomicModifyIORef' brksMapRef $ \BreakpointMap BreakpointInfo
brksMap ->
      case BreakpointStatus
status of
        -- Disabling the breakpoint:
        BreakpointStatus
BreakpointDisabled ->
          (InternalBreakpointId
-> BreakpointMap BreakpointInfo -> BreakpointMap BreakpointInfo
forall a.
InternalBreakpointId -> BreakpointMap a -> BreakpointMap a
BM.delete InternalBreakpointId
ibi BreakpointMap BreakpointInfo
brksMap, Bool
True{-assume map always contains BP, thus changes on deletion-})

        -- Enabling the breakpoint:
        BreakpointStatus
_ -> case InternalBreakpointId
-> BreakpointMap BreakpointInfo -> Maybe BreakpointInfo
forall a. InternalBreakpointId -> BreakpointMap a -> Maybe a
BM.lookup InternalBreakpointId
ibi BreakpointMap BreakpointInfo
brksMap of
          Just BreakpointInfo
info'
            | BreakpointInfo
info' BreakpointInfo -> BreakpointInfo -> Bool
forall a. Eq a => a -> a -> Bool
== BreakpointInfo
info
            -> -- Nothing changed, OK
               (BreakpointMap BreakpointInfo
brksMap, Bool
False)
          Maybe BreakpointInfo
_ -> -- Else, insert
            (InternalBreakpointId
-> BreakpointInfo
-> BreakpointMap BreakpointInfo
-> BreakpointMap BreakpointInfo
forall a.
InternalBreakpointId -> a -> BreakpointMap a -> BreakpointMap a
BM.insert InternalBreakpointId
ibi BreakpointInfo
info BreakpointMap BreakpointInfo
brksMap, Bool
True)

  return (any id changed, internal_break_ids)

-- | Get a list with all currently active breakpoints on the given module (by path)
--
-- If the path argument is @Nothing@, get all active function breakpoints instead
getActiveBreakpoints :: Maybe AbsFilePath -> Debugger [GHC.InternalBreakpointId]
getActiveBreakpoints :: Maybe AbsFilePath -> Debugger [InternalBreakpointId]
getActiveBreakpoints Maybe AbsFilePath
mfile = do
  bm <- (DebuggerState -> IORef (BreakpointMap BreakpointInfo))
-> Debugger (IORef (BreakpointMap BreakpointInfo))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef (BreakpointMap BreakpointInfo)
activeBreakpoints Debugger (IORef (BreakpointMap BreakpointInfo))
-> (IORef (BreakpointMap BreakpointInfo)
    -> Debugger (BreakpointMap BreakpointInfo))
-> Debugger (BreakpointMap BreakpointInfo)
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO (BreakpointMap BreakpointInfo)
-> Debugger (BreakpointMap BreakpointInfo)
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (BreakpointMap BreakpointInfo)
 -> Debugger (BreakpointMap BreakpointInfo))
-> (IORef (BreakpointMap BreakpointInfo)
    -> IO (BreakpointMap BreakpointInfo))
-> IORef (BreakpointMap BreakpointInfo)
-> Debugger (BreakpointMap BreakpointInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef (BreakpointMap BreakpointInfo)
-> IO (BreakpointMap BreakpointInfo)
forall a. IORef a -> IO a
readIORef
  case mfile of
    Just AbsFilePath
file -> do
      mms <- AbsFilePath -> Debugger (Either SDoc ModuleNodeInfo)
getModuleByPath AbsFilePath
file
      case mms of
        Right ModuleNodeInfo
ms -> do
          hug <- HscEnv -> HomeUnitGraph
hsc_HUG (HscEnv -> HomeUnitGraph)
-> Debugger HscEnv -> Debugger HomeUnitGraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
          -- Return all active IBIs whose occurrence (source) module
          -- matches the argument source module.
          map fst <$> filterM (\(InternalBreakpointId
ibi, BreakpointInfo
info)  -> do
            ibi_occ_mod <- InternalBreakpointId -> InternalModBreaks -> Module
getBreakSourceMod InternalBreakpointId
ibi (InternalModBreaks -> Module) -> IO InternalModBreaks -> IO Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HomeUnitGraph -> InternalBreakpointId -> IO InternalModBreaks
readIModBreaks HomeUnitGraph
hug InternalBreakpointId
ibi IO Module -> (IO Module -> Debugger Module) -> Debugger Module
forall a b. a -> (a -> b) -> b
& IO Module -> Debugger Module
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
            assert (bpInfoStatus info /= BreakpointDisabled) $
              return (ibi_occ_mod == GHC.moduleNodeInfoModule ms)
            ) (BM.toList bm)
        Left SDoc
e -> do
          Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning SDoc
e
          [InternalBreakpointId] -> Debugger [InternalBreakpointId]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    Maybe AbsFilePath
Nothing -> do
      [InternalBreakpointId] -> Debugger [InternalBreakpointId]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ InternalBreakpointId
ibi
        | (InternalBreakpointId
ibi, BreakpointInfo{bpInfoStatus :: BreakpointInfo -> BreakpointStatus
bpInfoStatus=BreakpointStatus
status, bpInfoKind :: BreakpointInfo -> BreakpointKind
bpInfoKind=BreakpointKind
kind}) <- BreakpointMap BreakpointInfo
-> [(InternalBreakpointId, BreakpointInfo)]
forall a. BreakpointMap a -> [(InternalBreakpointId, a)]
BM.toList BreakpointMap BreakpointInfo
bm
        -- Keep only function breakpoints in this case
        , BreakpointKind
FunctionBreakpointKind BreakpointKind -> BreakpointKind -> Bool
forall a. Eq a => a -> a -> Bool
== BreakpointKind
kind
        , Bool -> Bool -> Bool
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (BreakpointStatus
status BreakpointStatus -> BreakpointStatus -> Bool
forall a. Ord a => a -> a -> Bool
> BreakpointStatus
BreakpointDisabled) Bool
True
        ]

-- | Turn a 'BreakpointStatus' into its 'Int' representation for 'BreakArray'
breakpointStatusInt :: BreakpointStatus -> Int
breakpointStatusInt :: BreakpointStatus -> BreakTickIndex
breakpointStatusInt = \case
  BreakpointStatus
BreakpointEnabled          -> BreakTickIndex
BA.breakOn  -- 0
  BreakpointStatus
BreakpointDisabled         -> BreakTickIndex
BA.breakOff -- -1
  BreakpointAfterCount BreakTickIndex
n     -> BreakTickIndex
n           -- n
  BreakpointWhenCond{}       -> BreakTickIndex
BA.breakOn  -- always stop, cond evaluated after
  BreakpointAfterCountCond{} -> BreakTickIndex
BA.breakOn  -- ditto, decrease only when cond is true

-- | Find all the internal breakpoints that use the given source-level breakpoint id
getInternalBreaksOf :: BreakpointId -> Debugger [InternalBreakpointId]
getInternalBreaksOf :: BreakpointId -> Debugger [InternalBreakpointId]
getInternalBreaksOf BreakpointId
bi = do
  bs <- Debugger BreakpointOccurrences
forall (m :: * -> *). GhcMonad m => m BreakpointOccurrences
mkBreakpointOccurrences
  return $
    fromMaybe [] {- still not found after refresh -} $
      lookupBreakpointOccurrences bs bi

--------------------------------------------------------------------------------
-- * Utils
--------------------------------------------------------------------------------

-- | Turn a @hitCount :: Maybe Int@ and @condition :: Maybe Text@ into an enabled @BreakpointStatus@.
condBreakEnableStatus :: Maybe Int {-^ hitCount -} -> Maybe String {-^ condition -} -> BreakpointStatus
condBreakEnableStatus :: Maybe BreakTickIndex -> Maybe FilePath -> BreakpointStatus
condBreakEnableStatus Maybe BreakTickIndex
hitCount Maybe FilePath
condition = do
  case (Maybe BreakTickIndex
hitCount, Maybe FilePath
condition) of
    (Maybe BreakTickIndex
Nothing, Maybe FilePath
Nothing) -> BreakpointStatus
BreakpointEnabled
    (Just BreakTickIndex
i,  Maybe FilePath
Nothing) -> BreakTickIndex -> BreakpointStatus
BreakpointAfterCount BreakTickIndex
i
    (Maybe BreakTickIndex
Nothing, Just FilePath
c)  -> FilePath -> BreakpointStatus
BreakpointWhenCond FilePath
c
    (Just BreakTickIndex
i,  Just FilePath
c)  -> BreakTickIndex -> FilePath -> BreakpointStatus
BreakpointAfterCountCond BreakTickIndex
i FilePath
c


-- | @logMessageExpression "foo = {show foo}" = "putStrLn (concat [\"foo = \", show foo])"@
--
--   Braces are preserved if escaped with a backslash. Some unescaped braces are
--   fine: opening braces in antiquotations and closing braces outside of them.
logMessageExpression :: String -> String
logMessageExpression :: FilePath -> FilePath
logMessageExpression FilePath
tmpl = FilePath -> [FilePath] -> FilePath
apply (FilePath -> FilePath
internal FilePath
"putStrLn") [ FilePath -> [FilePath] -> FilePath
apply (FilePath -> FilePath
internal FilePath
"concat") [ FilePath
parts ]]
  where
    parts :: FilePath
parts = [FilePath] -> FilePath
forall {t :: * -> *}. Foldable t => t FilePath -> FilePath
mkList ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ (StringPart -> FilePath) -> [StringPart] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map StringPart -> FilePath
renderPart (FilePath -> FilePath -> [StringPart]
parseQC [] FilePath
tmpl)
    renderPart :: StringPart -> FilePath
renderPart (Literal FilePath
s) = FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
s
    renderPart (AntiQuote FilePath
e) = FilePath
e
    mkList :: t FilePath -> FilePath
mkList t FilePath
ys = (FilePath -> FilePath -> FilePath)
-> FilePath -> t FilePath -> FilePath
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ FilePath
x FilePath
xs -> FilePath -> [FilePath] -> FilePath
apply (FilePath -> FilePath
internal FilePath
"cons") [FilePath
x,FilePath
xs]) (FilePath -> FilePath
internal FilePath
"nil") t FilePath
ys
    internal :: FilePath -> FilePath
internal FilePath
x = ModuleName -> FilePath
GHC.moduleNameString ModuleName
debuggerRuntimeInternalModName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"." FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x
    apply :: FilePath -> [FilePath] -> FilePath
apply FilePath
f [FilePath]
xs = [FilePath] -> FilePath
unwords ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
f FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: (FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
x -> FilePath
"(" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")") [FilePath]
xs

-- Taken from interpolatedstring-perl6 package
data StringPart = Literal String | AntiQuote String deriving BreakTickIndex -> StringPart -> FilePath -> FilePath
[StringPart] -> FilePath -> FilePath
StringPart -> FilePath
(BreakTickIndex -> StringPart -> FilePath -> FilePath)
-> (StringPart -> FilePath)
-> ([StringPart] -> FilePath -> FilePath)
-> Show StringPart
forall a.
(BreakTickIndex -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
$cshowsPrec :: BreakTickIndex -> StringPart -> FilePath -> FilePath
showsPrec :: BreakTickIndex -> StringPart -> FilePath -> FilePath
$cshow :: StringPart -> FilePath
show :: StringPart -> FilePath
$cshowList :: [StringPart] -> FilePath -> FilePath
showList :: [StringPart] -> FilePath -> FilePath
Show

unQC :: String -> String -> [StringPart]
unQC :: FilePath -> FilePath -> [StringPart]
unQC FilePath
a []          = [FilePath -> StringPart
Literal (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
a)]
unQC FilePath
a (Char
'\\':Char
x:FilePath
xs) = FilePath -> FilePath -> [StringPart]
unQC (Char
xChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
a) FilePath
xs
unQC FilePath
a (Char
'\\':[])   = FilePath -> FilePath -> [StringPart]
unQC (Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
a) []
unQC FilePath
a (Char
'}':FilePath
xs)    = FilePath -> StringPart
AntiQuote (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
a) StringPart -> [StringPart] -> [StringPart]
forall a. a -> [a] -> [a]
: FilePath -> FilePath -> [StringPart]
parseQC [] FilePath
xs
unQC FilePath
a (Char
x:FilePath
xs)      = FilePath -> FilePath -> [StringPart]
unQC (Char
xChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
a) FilePath
xs

parseQC :: String -> String -> [StringPart]
parseQC :: FilePath -> FilePath -> [StringPart]
parseQC FilePath
a []           = [FilePath -> StringPart
Literal (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
a)]
parseQC FilePath
a (Char
'\\':Char
'\\':FilePath
xs) = FilePath -> FilePath -> [StringPart]
parseQC (Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
a) FilePath
xs
parseQC FilePath
a (Char
'\\':Char
'{':FilePath
xs) = FilePath -> FilePath -> [StringPart]
parseQC (Char
'{'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
a) FilePath
xs
parseQC FilePath
a (Char
'\\':[])    = FilePath -> FilePath -> [StringPart]
parseQC (Char
'\\'Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
a) []
parseQC FilePath
a (Char
'{':FilePath
xs)     = FilePath -> StringPart
Literal (FilePath -> FilePath
forall a. [a] -> [a]
reverse FilePath
a) StringPart -> [StringPart] -> [StringPart]
forall a. a -> [a] -> [a]
: FilePath -> FilePath -> [StringPart]
unQC [] FilePath
xs
parseQC FilePath
a (Char
x:FilePath
xs)       = FilePath -> FilePath -> [StringPart]
parseQC (Char
xChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
a) FilePath
xs

-- | Get a 'ModSummary' of a loaded module given its 'FilePath'
getModuleByPath :: AbsFilePath -> Debugger (Either SDoc GHC.ModuleNodeInfo)
getModuleByPath :: AbsFilePath -> Debugger (Either SDoc ModuleNodeInfo)
getModuleByPath AbsFilePath
path = do
  -- TODO (bytecode libraries): getAllLoadedModules skips any ModuleNodeFixed, and only includes modules from home units.
  -- get all loaded modules every time as the loaded modules may have changed
  lms <- Debugger [(AbsFilePath, ModuleNodeInfo)]
forall (m :: * -> *).
GhcMonad m =>
m [(AbsFilePath, ModuleNodeInfo)]
getAllLoadedModulesWithPaths

  return $ case filter ((== unAbs path) . unAbs . fst) lms of
    [(AbsFilePath, ModuleNodeInfo)
x] -> ModuleNodeInfo -> Either SDoc ModuleNodeInfo
forall a b. b -> Either a b
Right ((AbsFilePath, ModuleNodeInfo) -> ModuleNodeInfo
forall a b. (a, b) -> b
snd (AbsFilePath, ModuleNodeInfo)
x)
    [] -> SDoc -> Either SDoc ModuleNodeInfo
forall a b. a -> Either a b
Left (SDoc -> Either SDoc ModuleNodeInfo)
-> SDoc -> Either SDoc ModuleNodeInfo
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"No module matched" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (AbsFilePath -> FilePath
unAbs AbsFilePath
path) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"."
               SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Loaded modules:"
               SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat (((AbsFilePath, ModuleNodeInfo) -> SDoc)
-> [(AbsFilePath, ModuleNodeInfo)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (FilePath -> SDoc)
-> ((AbsFilePath, ModuleNodeInfo) -> FilePath)
-> (AbsFilePath, ModuleNodeInfo)
-> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AbsFilePath -> FilePath
unAbs (AbsFilePath -> FilePath)
-> ((AbsFilePath, ModuleNodeInfo) -> AbsFilePath)
-> (AbsFilePath, ModuleNodeInfo)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbsFilePath, ModuleNodeInfo) -> AbsFilePath
forall a b. (a, b) -> a
fst) [(AbsFilePath, ModuleNodeInfo)]
lms)
               SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Perhaps you've set a breakpoint on a module that isn't loaded into the session?"
    [(AbsFilePath, ModuleNodeInfo)]
xs -> SDoc -> Either SDoc ModuleNodeInfo
forall a b. a -> Either a b
Left (SDoc -> Either SDoc ModuleNodeInfo)
-> SDoc -> Either SDoc ModuleNodeInfo
forall a b. (a -> b) -> a -> b
$ FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Too many modules (" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Module] -> SDoc
forall a. Outputable a => a -> SDoc
ppr (((AbsFilePath, ModuleNodeInfo) -> Module)
-> [(AbsFilePath, ModuleNodeInfo)] -> [Module]
forall a b. (a -> b) -> [a] -> [b]
map (ModuleNodeInfo -> Module
GHC.moduleNodeInfoModule (ModuleNodeInfo -> Module)
-> ((AbsFilePath, ModuleNodeInfo) -> ModuleNodeInfo)
-> (AbsFilePath, ModuleNodeInfo)
-> Module
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbsFilePath, ModuleNodeInfo) -> ModuleNodeInfo
forall a b. (a, b) -> b
snd) [(AbsFilePath, ModuleNodeInfo)]
xs) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
") matched" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text (AbsFilePath -> FilePath
unAbs AbsFilePath
path)
              SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
". Please report a bug at https://github.com/well-typed/haskell-debugger."

-- | Find a 'BreakpointId' index and its span from a module + line + column.
--
-- Used by 'setBreakpoints' and 'GetBreakpointsAt' requests
findBreakpoint :: Module {-^ module -} -> Int {-^ line num -} -> Maybe Int {-^ column num -} -> Debugger (Maybe (Int, RealSrcSpan))
findBreakpoint :: Module
-> BreakTickIndex
-> Maybe BreakTickIndex
-> Debugger (Maybe (BreakTickIndex, RealSrcSpan))
findBreakpoint Module
modl BreakTickIndex
lineNum Maybe BreakTickIndex
columnNum = do
  -- TODO: Cache moduleLineMap?
  mticks <- Module -> Debugger (Maybe TickArray)
forall (m :: * -> *). GhcMonad m => Module -> m (Maybe TickArray)
makeModuleLineMap Module
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