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

import Prelude hiding (exp, span)
import System.Exit
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch
import Data.Bits (xor)

import GHC
import GHC.Types.Unique.FM
import GHC.Types.Name.Reader
#if MIN_VERSION_ghc(9,13,20250417)
import GHC.Types.Name.Occurrence (sizeOccEnv)
#endif
import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModDetails
import GHC.Types.FieldLabel
import GHC.Types.TypeEnv
import GHC.Data.Maybe (expectJust)
import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS, mkUnboundName)
import GHC.Data.FastString
import GHC.Utils.Error (logOutput)
import GHC.Driver.DynFlags as GHC
import GHC.Driver.Env as GHC
import GHC.Driver.Monad
import GHC.Driver.Ppr as GHC
import GHC.Runtime.Debugger.Breakpoints as GHC
import GHC.Runtime.Eval.Types as GHC
import GHC.Runtime.Eval
import GHC.Core.DataCon
import GHC.Types.Breakpoint
import GHC.Types.Id as GHC
import GHC.Types.Name.Occurrence (mkVarOcc, mkVarOccFS)
import GHC.Types.Name.Reader as RdrName (mkOrig, globalRdrEnvElts, greName)
import GHC.Types.SrcLoc
import GHC.Tc.Utils.TcType
import GHC.Unit.Module.Env as GHC
import GHC.Utils.Outputable as GHC
import GHC.Utils.Misc (zipEqual)
import qualified GHC.Runtime.Debugger as GHCD
import qualified GHC.Runtime.Heap.Inspect as GHCI
import qualified GHCi.Message as GHCi
import qualified GHC.Unit.Home.Graph as HUG

import Data.Maybe
import Control.Monad.Reader
import Data.IORef

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

--------------------------------------------------------------------------------
-- * Executing commands
--------------------------------------------------------------------------------

-- | Execute the given debugger command in the current 'Debugger' session
execute :: Command -> Debugger Response
execute :: Command -> Debugger Response
execute = \case
  Command
ClearFunctionBreakpoints -> Response
DidClearBreakpoints Response -> Debugger () -> Debugger Response
forall a b. a -> Debugger b -> Debugger a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe FilePath -> Debugger ()
clearBreakpoints Maybe FilePath
forall a. Maybe a
Nothing
  ClearModBreakpoints FilePath
fp -> Response
DidClearBreakpoints Response -> Debugger () -> Debugger Response
forall a b. a -> Debugger b -> Debugger a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe FilePath -> Debugger ()
clearBreakpoints (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
fp)
  SetBreakpoint Breakpoint
bp -> BreakFound -> Response
DidSetBreakpoint (BreakFound -> Response)
-> Debugger BreakFound -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Breakpoint -> BreakpointStatus -> Debugger BreakFound
setBreakpoint Breakpoint
bp BreakpointStatus
BreakpointEnabled
  DelBreakpoint Breakpoint
bp -> BreakFound -> Response
DidRemoveBreakpoint (BreakFound -> Response)
-> Debugger BreakFound -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Breakpoint -> BreakpointStatus -> Debugger BreakFound
setBreakpoint Breakpoint
bp BreakpointStatus
BreakpointDisabled
  GetBreakpointsAt 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} -> do
    mmodl <- FilePath -> Debugger (Either FilePath ModSummary)
getModuleByPath FilePath
path
    case mmodl of
      Left FilePath
e -> do
        [FilePath] -> Debugger ()
displayWarnings [FilePath
e]
        Response -> Debugger Response
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (Response -> Debugger Response) -> Response -> Debugger Response
forall a b. (a -> b) -> a -> b
$ Maybe SourceSpan -> Response
DidGetBreakpoints Maybe SourceSpan
forall a. Maybe a
Nothing
      Right ModSummary
modl -> do
        mbfnd <- ModSummary
-> BreakIndex
-> Maybe BreakIndex
-> Debugger (Maybe (BreakIndex, RealSrcSpan))
getBreakpointsAt ModSummary
modl BreakIndex
lineNum Maybe BreakIndex
columnNum
        return $
          DidGetBreakpoints (realSrcSpanToSourceSpan . snd <$> mbfnd)
  GetBreakpointsAt Breakpoint
_ -> FilePath -> Debugger Response
forall a. HasCallStack => FilePath -> a
error FilePath
"unexpected getbreakpoints without ModuleBreak"
  Command
GetStacktrace -> [StackFrame] -> Response
GotStacktrace ([StackFrame] -> Response)
-> Debugger [StackFrame] -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger [StackFrame]
getStacktrace
  Command
GetScopes -> [ScopeInfo] -> Response
GotScopes ([ScopeInfo] -> Response)
-> Debugger [ScopeInfo] -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger [ScopeInfo]
getScopes
  GetVariables VariableReference
kind -> Either VarInfo [VarInfo] -> Response
GotVariables (Either VarInfo [VarInfo] -> Response)
-> Debugger (Either VarInfo [VarInfo]) -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VariableReference -> Debugger (Either VarInfo [VarInfo])
getVariables VariableReference
kind
  DoEval FilePath
exp_s -> EvalResult -> Response
DidEval (EvalResult -> Response)
-> Debugger EvalResult -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> Debugger EvalResult
doEval FilePath
exp_s
  Command
DoContinue -> EvalResult -> Response
DidContinue (EvalResult -> Response)
-> Debugger EvalResult -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger EvalResult
doContinue
  Command
DoSingleStep -> EvalResult -> Response
DidStep (EvalResult -> Response)
-> Debugger EvalResult -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger EvalResult
doSingleStep
  Command
DoStepLocal -> EvalResult -> Response
DidStep (EvalResult -> Response)
-> Debugger EvalResult -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger EvalResult
doLocalStep
  DebugExecution { EntryPoint
entryPoint :: EntryPoint
entryPoint :: Command -> EntryPoint
entryPoint, [FilePath]
runArgs :: [FilePath]
runArgs :: Command -> [FilePath]
runArgs } -> EvalResult -> Response
DidExec (EvalResult -> Response)
-> Debugger EvalResult -> Debugger Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EntryPoint -> [FilePath] -> Debugger EvalResult
debugExecution EntryPoint
entryPoint [FilePath]
runArgs
  Command
TerminateProcess -> IO Response -> Debugger Response
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Response -> Debugger Response)
-> IO Response -> Debugger Response
forall a b. (a -> b) -> a -> b
$ do
    -- Terminate!
    ExitCode -> IO Response
forall a. ExitCode -> IO a
exitWith ExitCode
ExitSuccess

--------------------------------------------------------------------------------
-- * 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 :: Breakpoint -> FilePath
path :: FilePath
path, BreakIndex
lineNum :: Breakpoint -> BreakIndex
lineNum :: BreakIndex
lineNum, Maybe BreakIndex
columnNum :: Breakpoint -> Maybe BreakIndex
columnNum :: 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
span) -> 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 span
            , 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 :: ModBreaks
modBreaks = ModuleInfo -> ModBreaks
GHC.modInfoModBreaks ModuleInfo
mod_info
          applyBreak :: (BreakIndex, RealSrcSpan) -> Debugger BreakFound
applyBreak (BreakIndex
bix, RealSrcSpan
span) = 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 span
              , breakId = bid
              }
      case FilePath -> ModBreaks -> [(BreakIndex, RealSrcSpan)]
findBreakForBind FilePath
fun_str 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)

--------------------------------------------------------------------------------
-- * Evaluation
--------------------------------------------------------------------------------

-- | Run a program with debugging enabled
debugExecution :: EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult
debugExecution :: EntryPoint -> [FilePath] -> Debugger EvalResult
debugExecution EntryPoint
entry [FilePath]
args = do

  -- consider always using :trace like ghci-dap to always have a stacktrace?
  -- better solution could involve profiling stack traces or from IPE info?

  (entryExp, exOpts) <- case EntryPoint
entry of

    MainEntry Maybe FilePath
nm -> do
      let prog :: FilePath
prog = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe FilePath
"main" Maybe FilePath
nm
      wrapper <- FilePath -> [FilePath] -> Debugger ForeignHValue
forall (m :: * -> *).
GhcMonad m =>
FilePath -> [FilePath] -> m ForeignHValue
mkEvalWrapper FilePath
prog [FilePath]
args -- bit weird that the prog name is the expression but fine
      let execWrap' ForeignHValue
fhv = EvalExpr ForeignHValue
-> EvalExpr ForeignHValue -> EvalExpr ForeignHValue
forall a. EvalExpr a -> EvalExpr a -> EvalExpr a
GHCi.EvalApp (ForeignHValue -> EvalExpr ForeignHValue
forall a. a -> EvalExpr a
GHCi.EvalThis ForeignHValue
wrapper) (ForeignHValue -> EvalExpr ForeignHValue
forall a. a -> EvalExpr a
GHCi.EvalThis ForeignHValue
fhv)
          opts = ExecOptions
GHC.execOptions {execWrap = execWrap'}
      return (prog, opts)

    FunctionEntry FilePath
fn ->
      -- TODO: if "args" is unescaped (e.g. "some", "thing"), then "some" and
      -- "thing" will be interpreted as variables. To pass strings it needs to
      -- be "\"some\"" "\"things\"".
      (FilePath, ExecOptions) -> Debugger (FilePath, ExecOptions)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
fn FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [FilePath] -> FilePath
unwords [FilePath]
args, ExecOptions
GHC.execOptions)

  GHC.execStmt entryExp exOpts >>= handleExecResult

  where
    -- It's not ideal to duplicate these two functions from ghci, but its unclear where they would better live. Perhaps next to compileParsedExprRemote? The issue is run
    mkEvalWrapper :: GhcMonad m => String -> [String] ->  m ForeignHValue
    mkEvalWrapper :: forall (m :: * -> *).
GhcMonad m =>
FilePath -> [FilePath] -> m ForeignHValue
mkEvalWrapper FilePath
progname' [FilePath]
args' =
      m ForeignHValue -> m ForeignHValue
forall (m :: * -> *) a. GhcMonad m => m a -> m a
runInternal (m ForeignHValue -> m ForeignHValue)
-> m ForeignHValue -> m ForeignHValue
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs -> m ForeignHValue
forall (m :: * -> *).
GhcMonad m =>
LHsExpr GhcPs -> m ForeignHValue
GHC.compileParsedExprRemote
      (LHsExpr GhcPs -> m ForeignHValue)
-> LHsExpr GhcPs -> m ForeignHValue
forall a b. (a -> b) -> a -> b
$ LHsExpr GhcPs
GenLocated SrcSpanAnnA (HsExpr GhcPs)
evalWrapper' LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`GHC.mkHsApp` FilePath -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {p :: Pass}.
FilePath -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
nlHsString FilePath
progname'
                     LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
forall (id :: Pass).
LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
`GHC.mkHsApp` [LHsExpr GhcPs] -> LHsExpr GhcPs
nlList ((FilePath -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [FilePath] -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {p :: Pass}.
FilePath -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
nlHsString [FilePath]
args')
      where
        nlHsString :: FilePath -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
nlHsString = HsLit (GhcPass p) -> LHsExpr (GhcPass p)
HsLit (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall (p :: Pass). HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit (HsLit (GhcPass p) -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p)))
-> (FilePath -> HsLit (GhcPass p))
-> FilePath
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> HsLit (GhcPass p)
forall (p :: Pass). FilePath -> HsLit (GhcPass p)
mkHsString
        evalWrapper' :: LHsExpr GhcPs
evalWrapper' =
          IdP GhcPs -> LHsExpr GhcPs
forall (p :: Pass) a.
IsSrcSpanAnn p a =>
IdP (GhcPass p) -> LHsExpr (GhcPass p)
GHC.nlHsVar (IdP GhcPs -> LHsExpr GhcPs) -> IdP GhcPs -> LHsExpr GhcPs
forall a b. (a -> b) -> a -> b
$ Module -> OccName -> RdrName
RdrName.mkOrig Module
gHC_INTERNAL_GHCI_HELPERS (FastString -> OccName
mkVarOccFS (FilePath -> FastString
fsLit FilePath
"evalWrapper"))

    -- run internal here serves to overwrite certain flags while executing the
    -- internal "evalWrapper" computation which is not relevant to the user.
    runInternal :: GhcMonad m => m a -> m a
    runInternal :: forall (m :: * -> *) a. GhcMonad m => m a -> m a
runInternal =
        (HscEnv -> HscEnv) -> m a -> m a
forall (m :: * -> *) a.
GhcMonad m =>
(HscEnv -> HscEnv) -> m a -> m a
withTempSession HscEnv -> HscEnv
mkTempSession
      where
        mkTempSession :: HscEnv -> HscEnv
mkTempSession = (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags (\DynFlags
dflags -> DynFlags
dflags
          { -- Disable dumping of any data during evaluation of GHCi's internal expressions. (#17500)
            dumpFlags = mempty
          }
              -- We depend on -fimplicit-import-qualified to compile expr
              -- with fully qualified names without imports (gHC_INTERNAL_GHCI_HELPERS above).
              DynFlags -> GeneralFlag -> DynFlags
`gopt_set` GeneralFlag
Opt_ImplicitImportQualified
          )


-- | Resume execution of the stopped debuggee program
doContinue :: Debugger EvalResult
doContinue :: Debugger EvalResult
doContinue = do
  Debugger ()
leaveSuspendedState
  SingleStep -> Maybe BreakIndex -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe BreakIndex -> m ExecResult
GHC.resumeExec SingleStep
RunToCompletion Maybe BreakIndex
forall a. Maybe a
Nothing
    Debugger ExecResult
-> (ExecResult -> Debugger EvalResult) -> Debugger EvalResult
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExecResult -> Debugger EvalResult
handleExecResult

-- | Resume execution but only take a single step.
doSingleStep :: Debugger EvalResult
doSingleStep :: Debugger EvalResult
doSingleStep = do
  Debugger ()
leaveSuspendedState
  SingleStep -> Maybe BreakIndex -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe BreakIndex -> m ExecResult
GHC.resumeExec SingleStep
SingleStep Maybe BreakIndex
forall a. Maybe a
Nothing
    Debugger ExecResult
-> (ExecResult -> Debugger EvalResult) -> Debugger EvalResult
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExecResult -> Debugger EvalResult
handleExecResult

-- | Resume execution but stop at the next tick within the same function.
--
-- To do a local step, we get the SrcSpan of the current suspension state and
-- get its 'enclosingTickSpan' to use as a filter for breakpoints in the call
-- to 'resumeExec'. Execution will only stop at breakpoints whose span matches
-- this enclosing span.
doLocalStep :: Debugger EvalResult
doLocalStep :: Debugger EvalResult
doLocalStep = do
  Debugger ()
leaveSuspendedState
  mb_span <- Debugger (Maybe SrcSpan)
forall (m :: * -> *). GhcMonad m => m (Maybe SrcSpan)
getCurrentBreakSpan
  case mb_span of
    Maybe SrcSpan
Nothing -> FilePath -> Debugger EvalResult
forall a. HasCallStack => FilePath -> a
error FilePath
"not stopped at a breakpoint?!"
    Just (UnhelpfulSpan UnhelpfulSpanReason
_) -> 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
$ FilePath -> IO ()
putStrLn FilePath
"Stopped at an exception. Forcing step into..."
      SingleStep -> Maybe BreakIndex -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe BreakIndex -> m ExecResult
GHC.resumeExec SingleStep
SingleStep Maybe BreakIndex
forall a. Maybe a
Nothing Debugger ExecResult
-> (ExecResult -> Debugger EvalResult) -> Debugger EvalResult
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExecResult -> Debugger EvalResult
handleExecResult
    Just SrcSpan
loc -> do
      md <- Module -> Maybe Module -> Module
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Module
forall a. HasCallStack => FilePath -> a
error FilePath
"doLocalStep") (Maybe Module -> Module)
-> Debugger (Maybe Module) -> Debugger Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger (Maybe Module)
forall (m :: * -> *). GhcMonad m => m (Maybe Module)
getCurrentBreakModule
      -- TODO: Cache moduleLineMap.
      ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md
      let current_toplevel_decl = TickArray -> SrcSpan -> RealSrcSpan
enclosingTickSpan TickArray
ticks SrcSpan
loc
      GHC.resumeExec (LocalStep (RealSrcSpan current_toplevel_decl mempty)) Nothing >>= handleExecResult

-- | Evaluate expression. Includes context of breakpoint if stopped at one (the current interactive context).
doEval :: String -> Debugger EvalResult
doEval :: FilePath -> Debugger EvalResult
doEval FilePath
exp = do
  excr <- (ExecResult -> Either FilePath ExecResult
forall a b. b -> Either a b
Right (ExecResult -> Either FilePath ExecResult)
-> Debugger ExecResult -> Debugger (Either FilePath ExecResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> ExecOptions -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
FilePath -> ExecOptions -> m ExecResult
GHC.execStmt FilePath
exp ExecOptions
GHC.execOptions) Debugger (Either FilePath ExecResult)
-> (SomeException -> Debugger (Either FilePath ExecResult))
-> Debugger (Either FilePath ExecResult)
forall e a.
(HasCallStack, Exception e) =>
Debugger a -> (e -> Debugger a) -> Debugger a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(SomeException
e::SomeException) -> Either FilePath ExecResult -> Debugger (Either FilePath ExecResult)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath -> Either FilePath ExecResult
forall a b. a -> Either a b
Left (SomeException -> FilePath
forall e. Exception e => e -> FilePath
displayException SomeException
e))
  case excr of
    Left FilePath
err -> EvalResult -> Debugger EvalResult
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvalResult -> Debugger EvalResult)
-> EvalResult -> Debugger EvalResult
forall a b. (a -> b) -> a -> b
$ FilePath -> EvalResult
EvalAbortedWith FilePath
err
    Right ExecBreak{} -> Debugger ExecResult
continueToCompletion Debugger ExecResult
-> (ExecResult -> Debugger EvalResult) -> Debugger EvalResult
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ExecResult -> Debugger EvalResult
handleExecResult
    Right r :: ExecResult
r@ExecComplete{} -> ExecResult -> Debugger EvalResult
handleExecResult ExecResult
r

-- | Turn a GHC's 'ExecResult' into an 'EvalResult' response
handleExecResult :: GHC.ExecResult -> Debugger EvalResult
handleExecResult :: ExecResult -> Debugger EvalResult
handleExecResult = \case
    ExecComplete {Either SomeException [Name]
execResult :: Either SomeException [Name]
execResult :: ExecResult -> Either SomeException [Name]
execResult} -> do
      case Either SomeException [Name]
execResult of
        Left SomeException
e -> EvalResult -> Debugger EvalResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FilePath -> EvalResult
EvalException (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e) FilePath
"SomeException")
        Right [] -> EvalResult -> Debugger EvalResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FilePath -> EvalResult
EvalCompleted FilePath
"" FilePath
"") -- Evaluation completed without binding any result.
        Right (Name
n:[Name]
_ns) -> Name -> Debugger (Maybe VarInfo)
inspectName Name
n Debugger (Maybe VarInfo)
-> (Maybe VarInfo -> Debugger EvalResult) -> Debugger EvalResult
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just VarInfo{FilePath
varValue :: FilePath
varValue :: VarInfo -> FilePath
varValue, FilePath
varType :: FilePath
varType :: VarInfo -> FilePath
varType} -> EvalResult -> Debugger EvalResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> FilePath -> EvalResult
EvalCompleted FilePath
varValue FilePath
varType)
          Maybe VarInfo
Nothing     -> IO EvalResult -> Debugger EvalResult
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO EvalResult -> Debugger EvalResult)
-> IO EvalResult -> Debugger EvalResult
forall a b. (a -> b) -> a -> b
$ FilePath -> IO EvalResult
forall a. FilePath -> IO a
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail FilePath
"doEval failed"
    ExecBreak {breakNames :: ExecResult -> [Name]
breakNames = [Name]
_, breakPointId :: ExecResult -> Maybe InternalBreakpointId
breakPointId = Maybe InternalBreakpointId
Nothing} ->
      -- Stopped at an exception
      -- TODO: force the exception to display string with Backtrace?
      EvalResult -> Debugger EvalResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return EvalStopped{breakId :: Maybe BreakpointId
breakId = Maybe BreakpointId
forall a. Maybe a
Nothing}
    ExecBreak {breakNames :: ExecResult -> [Name]
breakNames = [Name]
_, Maybe InternalBreakpointId
breakPointId :: ExecResult -> Maybe InternalBreakpointId
breakPointId :: Maybe InternalBreakpointId
breakPointId} ->
      EvalResult -> Debugger EvalResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return EvalStopped{breakId :: Maybe BreakpointId
breakId = InternalBreakpointId -> BreakpointId
toBreakpointId (InternalBreakpointId -> BreakpointId)
-> Maybe InternalBreakpointId -> Maybe BreakpointId
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe InternalBreakpointId
breakPointId}

{-
Note [Don't crash if not stopped]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Requests such as `stacktrace`, `scopes`, or `variables` may end up
coming after the execution of a program has terminated. For instance,
consider this interleaving:

1. SENT Stopped event         <-- we're stopped
2. RECEIVED StackTrace req    <-- client issues after stopped event
3. RECEIVED Next req          <-- user clicks step-next
4. <program execution resumes and fails>
5. SENT Terminate event       <-- execution failed and we report it to exit cleanly
6. RECEIVED Scopes req        <-- happens as a sequence of 2 that wasn't canceled
7. <used to crash! because we're no longer at a breakpoint>

Now, we simply returned empty responses when these requests come in
while we're no longer at a breakpoint. The client will soon come to a halt
because of the termination event we sent.
-}

--------------------------------------------------------------------------------
-- * Stack trace
--------------------------------------------------------------------------------

-- | Get the stack frames at the point we're stopped at
getStacktrace :: Debugger [StackFrame]
getStacktrace :: Debugger [StackFrame]
getStacktrace = Debugger [Resume]
forall (m :: * -> *). GhcMonad m => m [Resume]
GHC.getResumeContext Debugger [Resume]
-> ([Resume] -> Debugger [StackFrame]) -> Debugger [StackFrame]
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  [] ->
    -- See Note [Don't crash if not stopped]
    [StackFrame] -> Debugger [StackFrame]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  Resume
r:[Resume]
_
    | Just RealSrcSpan
ss <- SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan (Resume -> SrcSpan
GHC.resumeSpan Resume
r)
    -> [StackFrame] -> Debugger [StackFrame]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return
        [ StackFrame
          { name :: FilePath
name = Resume -> FilePath
GHC.resumeDecl Resume
r
          , sourceSpan :: SourceSpan
sourceSpan = RealSrcSpan -> SourceSpan
realSrcSpanToSourceSpan RealSrcSpan
ss
          }
        ]
    | Bool
otherwise ->
        -- No resume span; which should mean we're stopped on an exception.
        -- No info for now.
        [StackFrame] -> Debugger [StackFrame]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []

--------------------------------------------------------------------------------
-- * Scopes
--------------------------------------------------------------------------------

-- | Get the stack frames at the point we're stopped at
getScopes :: Debugger [ScopeInfo]
getScopes :: Debugger [ScopeInfo]
getScopes = Debugger (Maybe SrcSpan)
forall (m :: * -> *). GhcMonad m => m (Maybe SrcSpan)
GHC.getCurrentBreakSpan Debugger (Maybe SrcSpan)
-> (Maybe SrcSpan -> Debugger [ScopeInfo]) -> Debugger [ScopeInfo]
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 SrcSpan
Nothing ->
    -- See Note [Don't crash if not stopped]
    [ScopeInfo] -> Debugger [ScopeInfo]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  Just SrcSpan
span
    | Just RealSrcSpan
rss <- SrcSpan -> Maybe RealSrcSpan
srcSpanToRealSrcSpan SrcSpan
span
    , let sourceSpan :: SourceSpan
sourceSpan = RealSrcSpan -> SourceSpan
realSrcSpanToSourceSpan RealSrcSpan
rss
    -> do
      -- It is /very important/ to report a number of variables (numVars) for
      -- larger scopes. If we just say "Nothing", then all variables of all
      -- scopes will be fetched at every stopped event.
      curr_modl <- Maybe Module -> Module
forall a. HasCallStack => Maybe a -> a
expectJust (Maybe Module -> Module)
-> Debugger (Maybe Module) -> Debugger Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger (Maybe Module)
forall (m :: * -> *). GhcMonad m => m (Maybe Module)
getCurrentBreakModule
      hsc_env <- getSession
      in_mod <- getTopEnv curr_modl
      imported <- getTopImported curr_modl
      return
        [ ScopeInfo { kind = LocalVariablesScope
                    , expensive = False
                    , numVars = Nothing
                    , sourceSpan
                    }
        , ScopeInfo { kind = ModuleVariablesScope
                    , expensive = True
                    , numVars = Just (sizeUFM in_mod)
                    , sourceSpan
                    }
        , ScopeInfo { kind = GlobalVariablesScope
                    , expensive = True
#if MIN_VERSION_ghc(9,13,20250417)
                    , numVars = Just (sizeOccEnv imported)
#else
                    , numVars = Nothing
#endif
                    , sourceSpan
                    }
        ]
    | Bool
otherwise ->
      -- No resume span; which should mean we're stopped on an exception
      -- TODO: Use exception context to create source span, or at least
      -- return the source span null to have Scopes at least.
      [ScopeInfo] -> Debugger [ScopeInfo]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []

--------------------------------------------------------------------------------
-- * Variables
--------------------------------------------------------------------------------
-- Note [Variables Requests]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~
-- We can receive a Variables request for three different reasons
--
-- 1. To get the variables in a certain scope
-- 2. To inspect the value of a lazy variable
-- 3. To expand the structure of a variable
--
-- The replies are, respectively:
--
-- (VARR)
-- (a) All the variables in the request scope
-- (b) ONLY the variable requested
-- (c) The fields of the variable requested but NOT the original variable

-- | Get variables using a variable/variables reference
--
-- If the Variable Request ends up being case (VARR)(b), then we signal the
-- request forced the variable and return @Left varInfo@. Otherwise, @Right vis@.
--
-- See Note [Variables Requests]
getVariables :: VariableReference -> Debugger (Either VarInfo [VarInfo])
getVariables :: VariableReference -> Debugger (Either VarInfo [VarInfo])
getVariables VariableReference
vk = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  GHC.getResumeContext >>= \case
    [] ->
      -- See Note [Don't crash if not stopped]
      Either VarInfo [VarInfo] -> Debugger (Either VarInfo [VarInfo])
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return ([VarInfo] -> Either VarInfo [VarInfo]
forall a b. b -> Either a b
Right [])
    Resume
r:[Resume]
_ -> case VariableReference
vk of

      -- Only `seq` the variable when inspecting a specific one (`SpecificVariable`)
      -- (VARR)(b,c)
      SpecificVariable BreakIndex
i -> do
        BreakIndex -> Debugger (Maybe (Name, Term))
lookupVarByReference BreakIndex
i Debugger (Maybe (Name, Term))
-> (Maybe (Name, Term) -> Debugger (Either VarInfo [VarInfo]))
-> Debugger (Either VarInfo [VarInfo])
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 (Name, Term)
Nothing -> FilePath -> Debugger (Either VarInfo [VarInfo])
forall a. HasCallStack => FilePath -> a
error FilePath
"lookupVarByReference failed"
          Just (Name
n, Term
term) -> do
            let ty :: RttiType
ty = Term -> RttiType
GHCI.termType Term
term
            term' <- if RttiType -> Bool
isBoringTy RttiType
ty
                        then Term -> Debugger Term
deepseqTerm Term
term -- deepseq boring types like String, because it is more helpful to print them whole than their structure.
                        else Term -> Debugger Term
seqTerm Term
term
            -- insertVarReference i n term' -- update with evaluated term?
            vi <- termToVarInfo n term'
            case term {- original term -} of

              -- (VARR)(b)
              Suspension{} -> do
                -- Original Term was a suspension:
                -- It is a "lazy" DAP variable, so our reply can ONLY include
                -- this single variable. So we erase the @varFields@ after the fact.
                Either VarInfo [VarInfo] -> Debugger (Either VarInfo [VarInfo])
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarInfo -> Either VarInfo [VarInfo]
forall a b. a -> Either a b
Left VarInfo
vi{varFields = NoFields})

              -- (VARR)(c)
              Term
_ -> [VarInfo] -> Either VarInfo [VarInfo]
forall a b. b -> Either a b
Right ([VarInfo] -> Either VarInfo [VarInfo])
-> Debugger [VarInfo] -> Debugger (Either VarInfo [VarInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                -- Original Term was already something other than a Suspension;
                -- Meaning the @SpecificVariable@ request means to inspect the structure.
                -- Return ONLY the fields
                case VarInfo -> VarFields
varFields VarInfo
vi of
                  VarFields
NoFields -> [VarInfo] -> Debugger [VarInfo]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                  LabeledFields [VarInfo]
xs -> [VarInfo] -> Debugger [VarInfo]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return [VarInfo]
xs
                  IndexedFields [VarInfo]
xs -> [VarInfo] -> Debugger [VarInfo]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return [VarInfo]
xs

      -- (VARR)(a) from here onwards

      VariableReference
LocalVariables -> ([VarInfo] -> Either VarInfo [VarInfo])
-> Debugger [VarInfo] -> Debugger (Either VarInfo [VarInfo])
forall a b. (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [VarInfo] -> Either VarInfo [VarInfo]
forall a b. b -> Either a b
Right (Debugger [VarInfo] -> Debugger (Either VarInfo [VarInfo]))
-> Debugger [VarInfo] -> Debugger (Either VarInfo [VarInfo])
forall a b. (a -> b) -> a -> b
$
        -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r)
        (TyThing -> Debugger VarInfo) -> [TyThing] -> Debugger [VarInfo]
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 -> TyThing -> Debugger VarInfo
tyThingToVarInfo BreakIndex
defaultDepth) ([TyThing] -> Debugger [VarInfo])
-> Debugger [TyThing] -> Debugger [VarInfo]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Debugger [TyThing]
forall (m :: * -> *). GhcMonad m => m [TyThing]
GHC.getBindings

      VariableReference
ModuleVariables -> [VarInfo] -> Either VarInfo [VarInfo]
forall a b. b -> Either a b
Right ([VarInfo] -> Either VarInfo [VarInfo])
-> Debugger [VarInfo] -> Debugger (Either VarInfo [VarInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        case InternalBreakpointId -> Module
ibi_tick_mod (InternalBreakpointId -> Module)
-> Maybe InternalBreakpointId -> Maybe Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Resume -> Maybe InternalBreakpointId
GHC.resumeBreakpointId Resume
r of
          Maybe Module
Nothing -> [VarInfo] -> Debugger [VarInfo]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          Just Module
curr_modl -> do
            things <- TypeEnv -> [TyThing]
typeEnvElts (TypeEnv -> [TyThing]) -> Debugger TypeEnv -> Debugger [TyThing]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> Debugger TypeEnv
getTopEnv Module
curr_modl
            mapM (\TyThing
tt -> do
              nameStr <- Name -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display (TyThing -> Name
forall a. NamedThing a => a -> Name
getName TyThing
tt)
              vi <- tyThingToVarInfo 1 tt
              return vi{varName = nameStr}) things

      VariableReference
GlobalVariables -> [VarInfo] -> Either VarInfo [VarInfo]
forall a b. b -> Either a b
Right ([VarInfo] -> Either VarInfo [VarInfo])
-> Debugger [VarInfo] -> Debugger (Either VarInfo [VarInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        case InternalBreakpointId -> Module
ibi_tick_mod (InternalBreakpointId -> Module)
-> Maybe InternalBreakpointId -> Maybe Module
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Resume -> Maybe InternalBreakpointId
GHC.resumeBreakpointId Resume
r of
          Maybe Module
Nothing -> [VarInfo] -> Debugger [VarInfo]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []
          Just Module
curr_modl -> do
            hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
            names <- map greName . globalRdrEnvElts <$> getTopImported curr_modl
            mapM (\Name
n-> do
              nameStr <- Name -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display Name
n
              liftIO (GHC.lookupType hsc_env n) >>= \case
                Maybe TyThing
Nothing ->
                  VarInfo -> Debugger VarInfo
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return VarInfo
                    { varName :: FilePath
varName = FilePath
nameStr
                    , varType :: FilePath
varType = FilePath
""
                    , varValue :: FilePath
varValue = FilePath
""
                    , isThunk :: Bool
isThunk = Bool
False
                    , varRef :: VariableReference
varRef = VariableReference
NoVariables
                    , varFields :: VarFields
varFields = VarFields
NoFields
                    }
                Just TyThing
tt -> do
                  vi <- BreakIndex -> TyThing -> Debugger VarInfo
tyThingToVarInfo BreakIndex
1 TyThing
tt {- don't look deep for global and mod vars -}
                  return vi{varName = nameStr}
              ) names

      VariableReference
NoVariables -> [VarInfo] -> Either VarInfo [VarInfo]
forall a b. b -> Either a b
Right ([VarInfo] -> Either VarInfo [VarInfo])
-> Debugger [VarInfo] -> Debugger (Either VarInfo [VarInfo])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        [VarInfo] -> Debugger [VarInfo]
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return []

defaultDepth :: BreakIndex
defaultDepth =  BreakIndex
5 -- the depth determines how much of the structure is traversed.
                  -- using a small value like 5 here is what causes the
                  -- structure to be improperly rendered inline with many underscores.
                  -- Note: GHCi uses depth=100
                  -- TODO: Investigate why this isn't fast enough to use 100.
                  -- TODO: We need a new metric to determine how much we force.
                  -- Depth is not good enough because e.g for a very broad
                  -- recursive type it will be exponentially many nodes to
                  -- visit
                  -- For now, try depth=5

--------------------------------------------------------------------------------
-- * GHC Utilities
--------------------------------------------------------------------------------

-- | All top-level things from a module, including unexported ones.
getTopEnv :: Module -> Debugger TypeEnv
getTopEnv :: Module -> Debugger TypeEnv
getTopEnv Module
modl = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case
    Maybe HomeModInfo
Nothing -> TypeEnv -> IO TypeEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TypeEnv
emptyTypeEnv
    Just HomeModInfo
      { hm_details :: HomeModInfo -> ModDetails
hm_details = ModDetails
        { md_types :: ModDetails -> TypeEnv
md_types = TypeEnv
things
        }
      } -> TypeEnv -> IO TypeEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return TypeEnv
things

-- | All bindings imported at a given module
getTopImported :: Module -> Debugger GlobalRdrEnv
getTopImported :: Module -> Debugger GlobalRdrEnv
getTopImported Module
modl = do
  hsc_env <- Debugger HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession
  liftIO $ HUG.lookupHugByModule modl (hsc_HUG hsc_env) >>= \case
    Maybe HomeModInfo
Nothing -> GlobalRdrEnv -> IO GlobalRdrEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GlobalRdrEnv
forall info. GlobalRdrEnvX info
emptyGlobalRdrEnv
#if MIN_VERSION_ghc(9,13,20250417)
    Just hmi -> mkTopLevImportedEnv hsc_env hmi
#else
    Just HomeModInfo
hmi -> GlobalRdrEnv -> IO GlobalRdrEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GlobalRdrEnv
forall info. GlobalRdrEnvX info
emptyGlobalRdrEnv
#endif

-- | Get the value and type of a given 'Name' as rendered strings in 'VarInfo'.
inspectName :: Name -> Debugger (Maybe VarInfo)
inspectName :: Name -> Debugger (Maybe VarInfo)
inspectName Name
n = do
  Name -> Debugger (Maybe TyThing)
forall (m :: * -> *). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupName Name
n Debugger (Maybe TyThing)
-> (Maybe TyThing -> Debugger (Maybe VarInfo))
-> Debugger (Maybe VarInfo)
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 TyThing
Nothing -> do
      IO () -> Debugger ()
forall a. IO a -> Debugger a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Debugger ())
-> (FilePath -> IO ()) -> FilePath -> Debugger ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO ()
putStrLn (FilePath -> Debugger ()) -> Debugger FilePath -> Debugger ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SDoc -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"Failed to lookup name: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
n)
      Maybe VarInfo -> Debugger (Maybe VarInfo)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe VarInfo
forall a. Maybe a
Nothing
    Just TyThing
tt -> VarInfo -> Maybe VarInfo
forall a. a -> Maybe a
Just (VarInfo -> Maybe VarInfo)
-> Debugger VarInfo -> Debugger (Maybe VarInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BreakIndex -> TyThing -> Debugger VarInfo
tyThingToVarInfo BreakIndex
defaultDepth TyThing
tt

-- | 'TyThing' to 'VarInfo'. The 'Bool' argument indicates whether to force the
-- value of the thing (as in @True = :force@, @False = :print@)
tyThingToVarInfo :: Int {-^ Depth -} -> TyThing -> Debugger VarInfo
tyThingToVarInfo :: BreakIndex -> TyThing -> Debugger VarInfo
tyThingToVarInfo BreakIndex
depth0 = \case
  t :: TyThing
t@(AConLike ConLike
c) -> FilePath
-> FilePath
-> FilePath
-> Bool
-> VariableReference
-> VarFields
-> VarInfo
VarInfo (FilePath
 -> FilePath
 -> FilePath
 -> Bool
 -> VariableReference
 -> VarFields
 -> VarInfo)
-> Debugger FilePath
-> Debugger
     (FilePath
      -> FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConLike -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display ConLike
c Debugger
  (FilePath
   -> FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
-> Debugger FilePath
-> Debugger
     (FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display TyThing
t Debugger
  (FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
-> Debugger FilePath
-> Debugger (Bool -> VariableReference -> VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display TyThing
t Debugger (Bool -> VariableReference -> VarFields -> VarInfo)
-> Debugger Bool
-> Debugger (VariableReference -> VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Debugger Bool
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False Debugger (VariableReference -> VarFields -> VarInfo)
-> Debugger VariableReference -> Debugger (VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VariableReference -> Debugger VariableReference
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VariableReference
NoVariables Debugger (VarFields -> VarInfo)
-> Debugger VarFields -> Debugger VarInfo
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VarFields -> Debugger VarFields
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VarFields
NoFields
  t :: TyThing
t@(ATyCon TyCon
c)   -> FilePath
-> FilePath
-> FilePath
-> Bool
-> VariableReference
-> VarFields
-> VarInfo
VarInfo (FilePath
 -> FilePath
 -> FilePath
 -> Bool
 -> VariableReference
 -> VarFields
 -> VarInfo)
-> Debugger FilePath
-> Debugger
     (FilePath
      -> FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TyCon -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display TyCon
c Debugger
  (FilePath
   -> FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
-> Debugger FilePath
-> Debugger
     (FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display TyThing
t Debugger
  (FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
-> Debugger FilePath
-> Debugger (Bool -> VariableReference -> VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display TyThing
t Debugger (Bool -> VariableReference -> VarFields -> VarInfo)
-> Debugger Bool
-> Debugger (VariableReference -> VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Debugger Bool
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False Debugger (VariableReference -> VarFields -> VarInfo)
-> Debugger VariableReference -> Debugger (VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VariableReference -> Debugger VariableReference
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VariableReference
NoVariables Debugger (VarFields -> VarInfo)
-> Debugger VarFields -> Debugger VarInfo
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VarFields -> Debugger VarFields
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VarFields
NoFields
  t :: TyThing
t@(ACoAxiom CoAxiom Branched
c) -> FilePath
-> FilePath
-> FilePath
-> Bool
-> VariableReference
-> VarFields
-> VarInfo
VarInfo (FilePath
 -> FilePath
 -> FilePath
 -> Bool
 -> VariableReference
 -> VarFields
 -> VarInfo)
-> Debugger FilePath
-> Debugger
     (FilePath
      -> FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CoAxiom Branched -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display CoAxiom Branched
c Debugger
  (FilePath
   -> FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
-> Debugger FilePath
-> Debugger
     (FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display TyThing
t Debugger
  (FilePath -> Bool -> VariableReference -> VarFields -> VarInfo)
-> Debugger FilePath
-> Debugger (Bool -> VariableReference -> VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TyThing -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display TyThing
t Debugger (Bool -> VariableReference -> VarFields -> VarInfo)
-> Debugger Bool
-> Debugger (VariableReference -> VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Debugger Bool
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False Debugger (VariableReference -> VarFields -> VarInfo)
-> Debugger VariableReference -> Debugger (VarFields -> VarInfo)
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VariableReference -> Debugger VariableReference
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VariableReference
NoVariables Debugger (VarFields -> VarInfo)
-> Debugger VarFields -> Debugger VarInfo
forall a b. Debugger (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> VarFields -> Debugger VarFields
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure VarFields
NoFields
  AnId Id
i -> do
    -- For boring types we want to get the value as it is (by traversing it to
    -- the end), rather than stopping short and returning a suspension (e.g.
    -- for the string tail), because boring types are printed whole rather than
    -- being represented by an expandable structure.
    let depth1 :: BreakIndex
depth1 = if RttiType -> Bool
isBoringTy (Id -> RttiType
GHC.idType Id
i) then BreakIndex
forall a. Bounded a => a
maxBound else BreakIndex
depth0
    term <- BreakIndex -> Bool -> Id -> Debugger Term
forall (m :: * -> *).
GhcMonad m =>
BreakIndex -> Bool -> Id -> m Term
GHC.obtainTermFromId BreakIndex
depth1 Bool
False{-don't force-} Id
i
    termToVarInfo (GHC.idName i) term

-- | Construct a 'VarInfo' from the given 'Name' of the variable and the 'Term' it binds
termToVarInfo :: Name -> Term -> Debugger VarInfo
termToVarInfo :: Name -> Term -> Debugger VarInfo
termToVarInfo Name
top_name Term
top_term = do

  -- Make a VarInfo for the top term.
  top_vi <- Name -> Term -> Debugger VarInfo
go Name
top_name Term
top_term

  sub_vis <- case top_term of
      -- Boring types don't get subfields
      Term
_ | RttiType -> Bool
isBoringTy (Term -> RttiType
GHCI.termType Term
top_term) ->
        VarFields -> Debugger VarFields
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return VarFields
NoFields

      -- Make 'VarInfo's for the first layer of subTerms only.
      Term{dc :: Term -> Either FilePath DataCon
dc=Right DataCon
dc, [Term]
subTerms :: [Term]
subTerms :: Term -> [Term]
subTerms} -> do
        case DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc of
          -- Not a record type,
          -- Use indexed fields
          [] -> do
            let names :: [Name]
names = (BreakIndex -> Scaled RttiType -> Name)
-> [BreakIndex] -> [Scaled RttiType] -> [Name]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\BreakIndex
ix Scaled RttiType
_ -> BreakIndex -> Name
mkIndexVar BreakIndex
ix) [BreakIndex
1..] (DataCon -> [Scaled RttiType]
dataConOrigArgTys DataCon
dc)
            [VarInfo] -> VarFields
IndexedFields ([VarInfo] -> VarFields)
-> Debugger [VarInfo] -> Debugger VarFields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Term) -> Debugger VarInfo)
-> [(Name, Term)] -> Debugger [VarInfo]
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 ((Name -> Term -> Debugger VarInfo)
-> (Name, Term) -> Debugger VarInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Term -> Debugger VarInfo
go) ([Name] -> [Term] -> [(Name, Term)]
forall a b. HasDebugCallStack => [a] -> [b] -> [(a, b)]
zipEqual [Name]
names [Term]
subTerms)
          -- Is a record type,
          -- Use field labels
          [FieldLabel]
dataConFields -> do
            let names :: [Name]
names = (FieldLabel -> Name) -> [FieldLabel] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldLabel -> Name
flSelector [FieldLabel]
dataConFields
            [VarInfo] -> VarFields
LabeledFields ([VarInfo] -> VarFields)
-> Debugger [VarInfo] -> Debugger VarFields
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Name, Term) -> Debugger VarInfo)
-> [(Name, Term)] -> Debugger [VarInfo]
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 ((Name -> Term -> Debugger VarInfo)
-> (Name, Term) -> Debugger VarInfo
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Name -> Term -> Debugger VarInfo
go) ([Name] -> [Term] -> [(Name, Term)]
forall a b. HasDebugCallStack => [a] -> [b] -> [(a, b)]
zipEqual [Name]
names [Term]
subTerms)
      NewtypeWrap{dc :: Term -> Either FilePath DataCon
dc=Right DataCon
dc, Term
wrapped_term :: Term
wrapped_term :: Term -> Term
wrapped_term} -> do
        case DataCon -> [FieldLabel]
dataConFieldLabels DataCon
dc of
          [] -> do
            let name :: Name
name = BreakIndex -> Name
mkIndexVar BreakIndex
1
            wvi <- Name -> Term -> Debugger VarInfo
go Name
name Term
wrapped_term
            return (IndexedFields [wvi])
          [FieldLabel
fld] -> do
            let name :: Name
name = FieldLabel -> Name
flSelector FieldLabel
fld
            wvi <- Name -> Term -> Debugger VarInfo
go Name
name Term
wrapped_term
            return (LabeledFields [wvi])
          [FieldLabel]
_ -> FilePath -> Debugger VarFields
forall a. HasCallStack => FilePath -> a
error FilePath
"unexpected number of Newtype fields: larger than 1"
      Term
_ -> VarFields -> Debugger VarFields
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return VarFields
NoFields

  return top_vi{varFields = sub_vis}

  where
    -- Make a VarInfo for a term, but don't recurse into the fields and return
    -- @NoFields@ for 'varFields'.
    --
    -- We do this because we don't want to recursively return all sub-fields --
    -- only the first layer of fields for the top term.
    go :: Name -> Term -> Debugger VarInfo
go Name
n Term
term = do
      let
        varFields :: VarFields
varFields = VarFields
NoFields
        isThunk :: Bool
isThunk
          -- to have more information we could match further on @Heap.ClosureType@
         | Suspension{} <- Term
term = Bool
True
         | Bool
otherwise = Bool
False
        ty :: RttiType
ty = Term -> RttiType
GHCI.termType Term
term

        -- We scrape the subterms to display as the var's value. The structure is
        -- displayed in the editor itself by expanding the variable sub-fields
        -- (`varFields`). 
        termHead :: Term -> Term
termHead Term
t
          -- But show strings and lits in full
          | RttiType -> Bool
isBoringTy RttiType
ty = Term
t
          | Bool
otherwise     = case Term
t of
             Term{}                    -> Term
t{subTerms = []}
             NewtypeWrap{Term
wrapped_term :: Term -> Term
wrapped_term :: Term
wrapped_term} -> Term
t{wrapped_term = termHead wrapped_term}
             Term
_                         -> Term
t
      varName <- Name -> Debugger FilePath
forall a. Outputable a => a -> Debugger FilePath
display Name
n
      varType <- display ty
      varValue <- display =<< GHCD.showTerm (termHead term)
      -- liftIO $ print (varName, varType, varValue, GHCI.isFullyEvaluatedTerm term)

      -- The VarReference allows user to expand variable structure and inspect its value.
      -- Here, we do not want to allow expanding a term that is fully evaluated.
      -- We only want to return @SpecificVariable@ (which allows expansion) for
      -- values with sub-fields or thunks.
      varRef <- do
        if GHCI.isFullyEvaluatedTerm term
           -- Even if it is already evaluated, we do want to display a
           -- structure as long if it is not a "boring type" (one that does not
           -- provide useful information from being expanded)
           -- (e.g. consider how awkward it is to expand Char# 10 and I# 20)
           && (isBoringTy ty || not (hasDirectSubTerms term))
         then
            return NoVariables
         else do
            ir <- freshInt
            insertVarReference ir n term
            return (SpecificVariable ir)

      return VarInfo{..}

    hasDirectSubTerms :: Term -> Bool
hasDirectSubTerms = \case
      Suspension{}   -> Bool
False
      Prim{}         -> Bool
False
      NewtypeWrap{}  -> Bool
True
      RefWrap{}      -> Bool
True
      Term{[Term]
subTerms :: Term -> [Term]
subTerms :: [Term]
subTerms} -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Term] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Term]
subTerms

    mkIndexVar :: BreakIndex -> Name
mkIndexVar BreakIndex
ix = OccName -> Name
mkUnboundName (FilePath -> OccName
mkVarOcc (FilePath
"_" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show @Int BreakIndex
ix))

-- | A boring type is one for which we don't care about the structure and would
-- rather see "whole" when being inspected. Strings and literals are a good
-- example, because it's more useful to see the string value than it is to see
-- a linked list of characters where each has to be forced individually.
isBoringTy :: Type -> Bool
isBoringTy :: RttiType -> Bool
isBoringTy RttiType
t = RttiType -> Bool
isDoubleTy RttiType
t Bool -> Bool -> Bool
|| RttiType -> Bool
isFloatTy RttiType
t Bool -> Bool -> Bool
|| RttiType -> Bool
isIntTy RttiType
t Bool -> Bool -> Bool
|| RttiType -> Bool
isWordTy RttiType
t Bool -> Bool -> Bool
|| RttiType -> Bool
isStringTy RttiType
t
                Bool -> Bool -> Bool
|| RttiType -> Bool
isIntegerTy RttiType
t Bool -> Bool -> Bool
|| RttiType -> Bool
isNaturalTy RttiType
t Bool -> Bool -> Bool
|| RttiType -> Bool
isCharTy RttiType
t

-- | Whenever we run a request that continues execution from the current
-- suspended state, such as Next,Step,Continue, this function should be called
-- to delete the variable references that become invalid as we leave the
-- suspended state.
--
-- In particular, @'varReferences'@ is reset.
--
-- See also section "Lifetime of Objects References" in the DAP specification.
leaveSuspendedState :: Debugger ()
leaveSuspendedState :: Debugger ()
leaveSuspendedState = do
  -- TODO:
  --  [ ] Preserve bindings introduced by evaluate requests
  ioref <- (DebuggerState -> IORef (IntMap (Name, Term)))
-> Debugger (IORef (IntMap (Name, Term)))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks DebuggerState -> IORef (IntMap (Name, Term))
varReferences
  liftIO $ writeIORef ioref mempty

-- | Convert a GHC's src span into an interface one
realSrcSpanToSourceSpan :: RealSrcSpan -> SourceSpan
realSrcSpanToSourceSpan :: RealSrcSpan -> SourceSpan
realSrcSpanToSourceSpan RealSrcSpan
ss = SourceSpan
  { file :: FilePath
file = FastString -> FilePath
unpackFS (FastString -> FilePath) -> FastString -> FilePath
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
ss
  , startLine :: BreakIndex
startLine = RealSrcSpan -> BreakIndex
srcSpanStartLine RealSrcSpan
ss
  , startCol :: BreakIndex
startCol = RealSrcSpan -> BreakIndex
srcSpanStartCol RealSrcSpan
ss
  , endLine :: BreakIndex
endLine = RealSrcSpan -> BreakIndex
srcSpanEndLine RealSrcSpan
ss
  , endCol :: BreakIndex
endCol = RealSrcSpan -> BreakIndex
srcSpanEndCol RealSrcSpan
ss
  }

--------------------------------------------------------------------------------
-- * General utilities
--------------------------------------------------------------------------------

-- | Display an Outputable value as a String
display :: Outputable a => a -> Debugger String
display :: forall a. Outputable a => a -> Debugger FilePath
display a
x = do
  dflags <- Debugger DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  return $ showSDoc dflags (ppr x)
{-# INLINE display #-}