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

import Control.Monad.IO.Class
import Control.Monad.Catch
import Data.Maybe

import GHC
#if MIN_VERSION_ghc(9,13,20250417)
import GHC.Types.Name.Occurrence (sizeOccEnv)
#endif
import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)
import GHC.Data.FastString
import GHC.Driver.DynFlags as GHC
import GHC.Driver.Env as GHC
import GHC.Driver.Monad
import GHC.Runtime.Debugger.Breakpoints as GHC
import GHC.Types.Breakpoint
import GHC.Types.Name.Occurrence (mkVarOccFS)
import GHC.Types.Name.Reader as RdrName (mkOrig)
import GHC.Utils.Outputable as GHC
import qualified GHCi.Message as GHCi

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

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

-- | Run a program with debugging enabled
debugExecution :: EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult
debugExecution :: EntryPoint -> [String] -> Debugger EvalResult
debugExecution EntryPoint
entry [String]
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 String
nm -> do
      let prog :: String
prog = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"main" Maybe String
nm
      wrapper <- String -> [String] -> Debugger ForeignHValue
forall (m :: * -> *).
GhcMonad m =>
String -> [String] -> m ForeignHValue
mkEvalWrapper String
prog [String]
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 String
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\"".
      (String, ExecOptions) -> Debugger (String, ExecOptions)
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
fn String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String]
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 =>
String -> [String] -> m ForeignHValue
mkEvalWrapper String
progname' [String]
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` String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {p :: Pass}.
String -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
nlHsString String
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 ((String -> GenLocated SrcSpanAnnA (HsExpr GhcPs))
-> [String] -> [GenLocated SrcSpanAnnA (HsExpr GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
map String -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
forall {p :: Pass}.
String -> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
nlHsString [String]
args')
      where
        nlHsString :: String -> 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)))
-> (String -> HsLit (GhcPass p))
-> String
-> GenLocated SrcSpanAnnA (HsExpr (GhcPass p))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HsLit (GhcPass p)
forall (p :: Pass). String -> 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 (String -> FastString
fsLit String
"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 Int -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
GHC.resumeExec SingleStep
RunToCompletion Maybe Int
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 Int -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
GHC.resumeExec SingleStep
SingleStep Maybe Int
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 -> String -> Debugger EvalResult
forall a. HasCallStack => String -> a
error String
"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
$ String -> IO ()
putStrLn String
"Stopped at an exception. Forcing step into..."
      SingleStep -> Maybe Int -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
GHC.resumeExec SingleStep
SingleStep Maybe Int
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 (String -> Module
forall a. HasCallStack => String -> a
error String
"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 :: String -> Debugger EvalResult
doEval String
expr = do
  excr <- (ExecResult -> Either String ExecResult
forall a b. b -> Either a b
Right (ExecResult -> Either String ExecResult)
-> Debugger ExecResult -> Debugger (Either String ExecResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExecOptions -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
String -> ExecOptions -> m ExecResult
GHC.execStmt String
expr ExecOptions
GHC.execOptions) Debugger (Either String ExecResult)
-> (SomeException -> Debugger (Either String ExecResult))
-> Debugger (Either String 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 String ExecResult -> Debugger (Either String ExecResult)
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String ExecResult
forall a b. a -> Either a b
Left (SomeException -> String
forall e. Exception e => e -> String
displayException SomeException
e))
  case excr of
    Left String
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
$ String -> EvalResult
EvalAbortedWith String
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 (String -> String -> EvalResult
EvalException (SomeException -> String
forall a. Show a => a -> String
show SomeException
e) String
"SomeException")
        Right [] -> EvalResult -> Debugger EvalResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> EvalResult
EvalCompleted String
"" String
"") -- 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{String
varValue :: String
varValue :: VarInfo -> String
varValue, String
varType :: String
varType :: VarInfo -> String
varType} -> EvalResult -> Debugger EvalResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> String -> EvalResult
EvalCompleted String
varValue String
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
$ String -> IO EvalResult
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"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}

-- | 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 ())
-> (String -> IO ()) -> String -> Debugger ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> IO ()
putStrLn (String -> Debugger ()) -> Debugger String -> Debugger ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< SDoc -> Debugger String
forall a. Outputable a => a -> Debugger String
display (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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
<$> TyThing -> Debugger VarInfo
tyThingToVarInfo TyThing
tt