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

import GHC.Utils.Outputable
import Control.Monad.IO.Class
import Control.Monad.Catch
import Control.Monad.Reader
import Data.IORef
import Data.Maybe

import GHC qualified
import GHC (
  ExecOptions (..),
  ExecResult (..),
  execStmt',
  ForeignHValue,
  GhciLStmt,
  GhcPs,
  InteractiveImport (..),
  ModSummary (..),
  Name,
  parseImportDecl,
  SingleStep (..),
  SrcSpan (..),
  StmtLR (..),
  unLoc,
  mkHsString,
  nlList,
  nlHsLit,
  )
import GHC.Plugins (SourceError)
import qualified GHC.Plugins as GHC
import GHC.Unit.Types
import GHC.Driver.DynFlags as GHC
import GHC.Driver.Main (hscParseStmtWithLocation)
import GHC.Driver.Monad as GHC
import GHC.Driver.Env as GHC
import qualified GHC.Driver.Config.Parser as GHC
import GHC.Runtime.Debugger.Breakpoints as GHC
import qualified GHCi.Message as GHCi
import qualified GHC.Data.Strict as Strict

import GHC.Debugger.Stopped.Variables
import GHC.Debugger.Monad
import GHC.Debugger.Utils
import GHC.Debugger.Interface.Messages
import Colog.Core as Logger
import qualified GHC.Debugger.Breakpoint.Map as BM
import GHC.Debugger.Runtime.Thread
import GHC.Debugger.Session (setInteractiveDebuggerDynFlags, getInteractiveDebuggerDynFlags, resumeExec)
import Data.List (find)
import GHC.Unit.Module.Graph as GHC
import GHC.Debugger.Session.Builtin (runInternal, debuggerRuntimeInternalModName)


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

-- | Run a program with debugging enabled
debugExecution :: AbsFilePath -> EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult
debugExecution :: AbsFilePath -> EntryPoint -> [String] -> Debugger EvalResult
debugExecution AbsFilePath
entryFile 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?
  modSummaryOfEntryFile <- AbsFilePath -> Debugger ModuleNodeInfo
forall (m :: * -> *). GhcMonad m => AbsFilePath -> m ModuleNodeInfo
findUnitIdOfEntryFile AbsFilePath
entryFile
  let modOfEntryFile = ModuleNodeInfo -> GenModule (GenUnit UnitId)
GHC.moduleNodeInfoModule ModuleNodeInfo
modSummaryOfEntryFile
      unitIdOfEntryFile = ModuleNodeInfo -> UnitId
GHC.moduleNodeInfoUnitId ModuleNodeInfo
modSummaryOfEntryFile

  let
    evalModule = GenUnit UnitId -> ModuleName -> GenModule (GenUnit UnitId)
forall u. u -> ModuleName -> GenModule u
mkModule (Definite UnitId -> GenUnit UnitId
forall uid. Definite uid -> GenUnit uid
RealUnit (UnitId -> Definite UnitId
forall unit. unit -> Definite unit
Definite UnitId
unitIdOfEntryFile))
                                         (GenModule (GenUnit UnitId) -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName GenModule (GenUnit UnitId)
modOfEntryFile)

  logSDoc Logger.Debug $ "Eval inputs: " <+> text (show (entryFile,entry,args))
  logSDoc Logger.Debug $ "Eval Module Context:" <+> withPprStyle (PprDump reallyAlwaysQualify) (ppr evalModule) <+> ppr (moduleNodeInfoLocation modSummaryOfEntryFile)

  old_context <- GHC.getContext
  GHC.setContext [IIModule evalModule]

  (entryExp, exOpts) <- case 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
      -- the wrapper is equivalent to GHCi's `:main arg1 arg2 arg3`
      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 -> [String] -> String
apply String
fn [String]
args, ExecOptions
GHC.execOptions)

  logSDoc Logger.Debug "Compiled wrapper."

  exec_res <- GHC.execStmt entryExp exOpts

  logSDoc Logger.Debug $ "Executed entryExp: " <+> text entryExp

  GHC.setContext old_context

  res <- handleExecResult exec_res
  logSDoc Logger.Debug $ "Computed EvalResult."
  pure res
  where
    apply :: String -> [String] -> String
apply String
x [String]
xs = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
x String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ String
a -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") [String]
xs

    -- mkEvalWrapper is mostly duplicating ghci's implementation, except we
    -- reference `evalWrapper` from GHC.Debugger.Runtime.Internal (See Note [debuggerInternal unit]).
    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
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' :: GHC.LHsExpr GhcPs
        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
$ ModuleName -> OccName -> RdrName
GHC.mkRdrQual ModuleName
debuggerRuntimeInternalModName (String -> OccName
GHC.mkVarOcc String
"evalWrapper")

    findUnitIdOfEntryFile :: GhcMonad m => AbsFilePath -> m GHC.ModuleNodeInfo
    findUnitIdOfEntryFile :: forall (m :: * -> *). GhcMonad m => AbsFilePath -> m ModuleNodeInfo
findUnitIdOfEntryFile AbsFilePath
afp = do
      modSums <- m [(AbsFilePath, ModuleNodeInfo)]
forall (m :: * -> *).
GhcMonad m =>
m [(AbsFilePath, ModuleNodeInfo)]
getAllLoadedModulesWithPaths
      case find ((== unAbs afp) . unAbs . fst) modSums of
        Maybe (AbsFilePath, ModuleNodeInfo)
Nothing -> do
          let norms :: [AbsFilePath]
norms = ((AbsFilePath, ModuleNodeInfo) -> AbsFilePath)
-> [(AbsFilePath, ModuleNodeInfo)] -> [AbsFilePath]
forall a b. (a -> b) -> [a] -> [b]
map (AbsFilePath, ModuleNodeInfo) -> AbsFilePath
forall a b. (a, b) -> a
fst [(AbsFilePath, ModuleNodeInfo)]
modSums
          String -> m ModuleNodeInfo
forall a. HasCallStack => String -> a
error (String -> m ModuleNodeInfo) -> String -> m ModuleNodeInfo
forall a b. (a -> b) -> a -> b
$ String
"findUnitIdOfEntryFile: no unit id found for: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ AbsFilePath -> String
unAbs AbsFilePath
afp String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nCandidates were:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines ((AbsFilePath -> String) -> [AbsFilePath] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map AbsFilePath -> String
forall a. Show a => a -> String
show [AbsFilePath]
norms)
        Just (AbsFilePath
_,ModuleNodeInfo
summary) -> ModuleNodeInfo -> m ModuleNodeInfo
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleNodeInfo
summary

-- | Resume execution of the stopped debuggee program
doContinue :: Debugger EvalResult
doContinue :: Debugger EvalResult
doContinue = do
  SingleStep -> Maybe Int -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
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
  SingleStep -> Maybe Int -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
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

doStepOut :: Debugger EvalResult
doStepOut :: Debugger EvalResult
doStepOut = do
  mb_span <- Debugger (Maybe SrcSpan)
forall (m :: * -> *). GhcMonad m => m (Maybe SrcSpan)
getCurrentBreakSpan
  case mb_span of
    Maybe SrcSpan
Nothing ->
      SingleStep -> Maybe Int -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
resumeExec (Maybe SrcSpan -> SingleStep
GHC.StepOut Maybe SrcSpan
forall a. Maybe a
Nothing) 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 <- GenModule (GenUnit UnitId)
-> Maybe (GenModule (GenUnit UnitId)) -> GenModule (GenUnit UnitId)
forall a. a -> Maybe a -> a
fromMaybe (String -> GenModule (GenUnit UnitId)
forall a. HasCallStack => String -> a
error String
"doStepOut") (Maybe (GenModule (GenUnit UnitId)) -> GenModule (GenUnit UnitId))
-> Debugger (Maybe (GenModule (GenUnit UnitId)))
-> Debugger (GenModule (GenUnit UnitId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger (Maybe (GenModule (GenUnit UnitId)))
forall (m :: * -> *).
GhcMonad m =>
m (Maybe (GenModule (GenUnit UnitId)))
getCurrentBreakModule
      ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md
      let current_toplevel_decl = TickArray -> SrcSpan -> RealSrcSpan
enclosingTickSpan TickArray
ticks SrcSpan
loc
      resumeExec (GHC.StepOut (Just (RealSrcSpan current_toplevel_decl Strict.Nothing))) Nothing
        >>= 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
  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
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 <- GenModule (GenUnit UnitId)
-> Maybe (GenModule (GenUnit UnitId)) -> GenModule (GenUnit UnitId)
forall a. a -> Maybe a -> a
fromMaybe (String -> GenModule (GenUnit UnitId)
forall a. HasCallStack => String -> a
error String
"doLocalStep") (Maybe (GenModule (GenUnit UnitId)) -> GenModule (GenUnit UnitId))
-> Debugger (Maybe (GenModule (GenUnit UnitId)))
-> Debugger (GenModule (GenUnit UnitId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Debugger (Maybe (GenModule (GenUnit UnitId)))
forall (m :: * -> *).
GhcMonad m =>
m (Maybe (GenModule (GenUnit UnitId)))
getCurrentBreakModule
      -- TODO: Cache moduleLineMap?
      ticks <- fromMaybe (error "doLocalStep:getTicks") <$> makeModuleLineMap md
      let current_toplevel_decl = TickArray -> SrcSpan -> RealSrcSpan
enclosingTickSpan TickArray
ticks SrcSpan
loc
      resumeExec (LocalStep (RealSrcSpan current_toplevel_decl mempty)) Nothing >>= handleExecResult

-- | Generalized `doEval` that also handles `imports`
doEvalCommand :: String -> Debugger EvalResult
doEvalCommand :: String -> Debugger EvalResult
doEvalCommand String
expr = do
  dflags <- Debugger DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getInteractiveDebuggerDynFlags
  let pflags = DynFlags -> ParserOpts
GHC.initParserOpts DynFlags
dflags
  if GHC.isStmt pflags expr
    then doEval expr
    else addImport expr

-- | Parses input as an import declaration and applies it to the interactive context.
addImport :: String -> Debugger EvalResult
addImport :: String -> Debugger EvalResult
addImport String
s = Debugger EvalResult -> Debugger EvalResult
forall {m :: * -> *}. MonadCatch m => m EvalResult -> m EvalResult
handleError (Debugger EvalResult -> Debugger EvalResult)
-> Debugger EvalResult -> Debugger EvalResult
forall a b. (a -> b) -> a -> b
$ do
  cxt <- Debugger [InteractiveImport]
forall (m :: * -> *). GhcMonad m => m [InteractiveImport]
GHC.getContext
  idecl <- parseImportDecl s
  GHC.setContext $ IIDecl idecl : cxt
  pure $ EvalCompleted "" "" Nothing NoVariables
  where
    handleError :: m EvalResult -> m EvalResult
handleError m EvalResult
m = m EvalResult
m m EvalResult -> (SourceError -> m EvalResult) -> m EvalResult
forall e a. (HasCallStack, Exception e) => m a -> (e -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, HasCallStack, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \ (SourceError
e::SourceError) -> do
      EvalResult -> m EvalResult
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EvalResult -> m EvalResult) -> EvalResult -> m EvalResult
forall a b. (a -> b) -> a -> b
$ String -> EvalResult
EvalAbortedWith (String -> EvalResult) -> String -> EvalResult
forall a b. (a -> b) -> a -> b
$ SourceError -> String
forall e. Exception e => e -> String
displayException SourceError
e

-- | 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 = Debugger EvalResult -> Debugger EvalResult
forall a. Debugger a -> Debugger a
withCurrentBreakEnv (Debugger EvalResult -> Debugger EvalResult)
-> Debugger EvalResult -> Debugger EvalResult
forall a b. (a -> b) -> a -> b
$ do
  excr <- ((SourceKind, ExecResult) -> Either String (SourceKind, ExecResult)
forall a b. b -> Either a b
Right ((SourceKind, ExecResult)
 -> Either String (SourceKind, ExecResult))
-> Debugger (SourceKind, ExecResult)
-> Debugger (Either String (SourceKind, ExecResult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> ExecOptions -> Debugger (SourceKind, ExecResult)
forall {m :: * -> *}.
GhcMonad m =>
String -> ExecOptions -> m (SourceKind, ExecResult)
exec String
expr ExecOptions
GHC.execOptions) Debugger (Either String (SourceKind, ExecResult))
-> (SomeException
    -> Debugger (Either String (SourceKind, ExecResult)))
-> Debugger (Either String (SourceKind, 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 (SourceKind, ExecResult)
-> Debugger (Either String (SourceKind, ExecResult))
forall a. a -> Debugger a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> Either String (SourceKind, 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 (SourceKind
k, ExecBreak{}) -> (EvalResult -> EvalResult)
-> Debugger EvalResult -> Debugger EvalResult
forall a b. (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceKind -> EvalResult -> EvalResult
addSourceKind SourceKind
k) (Debugger EvalResult -> Debugger EvalResult)
-> Debugger EvalResult -> Debugger EvalResult
forall a b. (a -> b) -> a -> b
$ 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 (SourceKind
k, r :: ExecResult
r@ExecComplete{}) -> (EvalResult -> EvalResult)
-> Debugger EvalResult -> Debugger EvalResult
forall a b. (a -> b) -> Debugger a -> Debugger b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SourceKind -> EvalResult -> EvalResult
addSourceKind SourceKind
k) (Debugger EvalResult -> Debugger EvalResult)
-> Debugger EvalResult -> Debugger EvalResult
forall a b. (a -> b) -> a -> b
$ ExecResult -> Debugger EvalResult
handleExecResult ExecResult
r
  where
    exec :: String -> ExecOptions -> m (SourceKind, ExecResult)
exec String
input exec_opts :: ExecOptions
exec_opts@ExecOptions{Int
String
SingleStep
ForeignHValue -> EvalExpr ForeignHValue
execWrap :: ExecOptions -> ForeignHValue -> EvalExpr ForeignHValue
execSingleStep :: SingleStep
execSourceFile :: String
execLineNumber :: Int
execWrap :: ForeignHValue -> EvalExpr ForeignHValue
execLineNumber :: ExecOptions -> Int
execSourceFile :: ExecOptions -> String
execSingleStep :: ExecOptions -> SingleStep
..} = do
      hsc_env <- m HscEnv
forall (m :: * -> *). GhcMonad m => m HscEnv
getSession

      mb_stmt <-
        liftIO $
        runInteractiveHsc hsc_env $
        hscParseStmtWithLocation execSourceFile execLineNumber input

      case mb_stmt of
        -- empty statement / comment
        Maybe (GhciLStmt GhcPs)
Nothing -> (SourceKind, ExecResult) -> m (SourceKind, ExecResult)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (SourceKind
IsStmt, Either SomeException [Name] -> Word64 -> ExecResult
ExecComplete ([Name] -> Either SomeException [Name]
forall a b. b -> Either a b
Right []) Word64
0)
        Just GhciLStmt GhcPs
stmt -> (,) (SourceKind -> ExecResult -> (SourceKind, ExecResult))
-> m SourceKind -> m (ExecResult -> (SourceKind, ExecResult))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> m SourceKind
forall {f :: * -> *}.
Applicative f =>
GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> f SourceKind
stmtKind GhciLStmt GhcPs
GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt m (ExecResult -> (SourceKind, ExecResult))
-> m ExecResult -> m (SourceKind, ExecResult)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
forall (m :: * -> *).
GhcMonad m =>
GhciLStmt GhcPs -> String -> ExecOptions -> m ExecResult
execStmt' GhciLStmt GhcPs
stmt String
input ExecOptions
exec_opts

    stmtKind :: GhciLStmt GhcPs -> f SourceKind
stmtKind (GhciLStmt GhcPs
stmt :: GhciLStmt GhcPs) = do
      SourceKind -> f SourceKind
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SourceKind -> f SourceKind) -> SourceKind -> f SourceKind
forall a b. (a -> b) -> a -> b
$ case GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall l e. GenLocated l e -> e
unLoc GhciLStmt GhcPs
GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
stmt of
        BodyStmt{} -> SourceKind
IsExpr
        StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ -> SourceKind
IsStmt

    addSourceKind :: SourceKind -> EvalResult -> EvalResult
    addSourceKind :: SourceKind -> EvalResult -> EvalResult
addSourceKind SourceKind
k EvalCompleted{String
Maybe SourceKind
VariableReference
resultVal :: String
resultType :: String
resultSourceKind :: Maybe SourceKind
resultStructureRef :: VariableReference
resultStructureRef :: EvalResult -> VariableReference
resultSourceKind :: EvalResult -> Maybe SourceKind
resultType :: EvalResult -> String
resultVal :: EvalResult -> String
..} = EvalCompleted{resultSourceKind :: Maybe SourceKind
resultSourceKind = SourceKind -> Maybe SourceKind
forall a. a -> Maybe a
Just SourceKind
k, String
VariableReference
resultVal :: String
resultType :: String
resultStructureRef :: VariableReference
resultStructureRef :: VariableReference
resultType :: String
resultVal :: String
..}
    addSourceKind SourceKind
_ EvalResult
r = EvalResult
r

-- | Resume execution with single step mode 'RunToCompletion', skipping all breakpoints we hit, until we reach 'ExecComplete'.
--
-- We use this in 'doEval' because we want to ignore breakpoints in expressions given at the prompt.
continueToCompletion :: Debugger GHC.ExecResult
continueToCompletion :: Debugger ExecResult
continueToCompletion = do
  execr <- SingleStep -> Maybe Int -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
resumeExec SingleStep
GHC.RunToCompletion Maybe Int
forall a. Maybe a
Nothing
  case execr of
    GHC.ExecBreak{} -> Debugger ExecResult
continueToCompletion
    GHC.ExecComplete{} -> ExecResult -> Debugger ExecResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return ExecResult
execr

-- | @withCurrentBreakEnv m@ executes @m@ with the imports, language, and language
--  extensions of the current breakpoint source module.
--
--  If we are not stopped at a breakpoint @m@ is executed with no change.
withCurrentBreakEnv :: Debugger a -> Debugger a
withCurrentBreakEnv :: forall a. Debugger a -> Debugger a
withCurrentBreakEnv Debugger a
m = do
  mmodl <- Debugger (Maybe (GenModule (GenUnit UnitId)))
forall (m :: * -> *).
GhcMonad m =>
m (Maybe (GenModule (GenUnit UnitId)))
getCurrentBreakModule
  case mmodl of
    Maybe (GenModule (GenUnit UnitId))
Nothing          -> Debugger a
m
    Just GenModule (GenUnit UnitId)
breakModule -> do
      ic_dyn_flags <- Debugger DynFlags
forall (m :: * -> *). GhcMonad m => m DynFlags
getInteractiveDebuggerDynFlags
      break_dyn_flags <- ms_hspp_opts <$> GHC.getModSummary breakModule
      old_context <- GHC.getContext
      setInteractiveDebuggerDynFlags $ adjustFlags ic_dyn_flags break_dyn_flags
      GHC.setContext (IIModule breakModule : old_context)
      x <- m
      GHC.setContext old_context
      setInteractiveDebuggerDynFlags ic_dyn_flags
      return x
  where
    -- Possibly we might want to include more from the module's DynFlags.
    -- However some are likely to mess with the REPL, e.g. Opt_WarnTypeDefaults,
    -- Opt_HideAllPackages, Opt_NoIt. See discussion at
    -- https://github.com/well-typed/haskell-debugger/pull/230#discussion_r2986758826
    adjustFlags :: DynFlags -> DynFlags -> DynFlags
    adjustFlags :: DynFlags -> DynFlags -> DynFlags
adjustFlags DynFlags
ic DynFlags
modl = DynFlags
ic
      { extensions = extensions modl
      , extensionFlags = extensionFlags modl
      , language = language modl
      }

-- | 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 -> Maybe SourceKind -> VariableReference -> EvalResult
EvalCompleted String
"" String
"" Maybe SourceKind
forall a. Maybe a
Nothing VariableReference
NoVariables) -- 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, VariableReference
varRef :: VariableReference
varRef :: VarInfo -> VariableReference
varRef} -> do
            EvalResult -> Debugger EvalResult
forall a. a -> Debugger a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
-> String -> Maybe SourceKind -> VariableReference -> EvalResult
EvalCompleted String
varValue String
varType Maybe SourceKind
forall a. Maybe a
Nothing VariableReference
varRef)
          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. HasCallStack => String -> IO a
forall (m :: * -> *) a.
(MonadFail m, HasCallStack) =>
String -> m a
fail String
"doEval failed"
    ExecBreak {breakNames :: ExecResult -> [Name]
breakNames = [Name]
_, breakPointId :: ExecResult -> Maybe InternalBreakpointId
breakPointId = Maybe InternalBreakpointId
Nothing} -> do
      -- Stopped at an exception
      -- TODO: force the exception to display string with Backtrace?
      rt_id <- Debugger RemoteThreadId
getRemoteThreadIdFromContext
      return EvalStopped{ breakId = Nothing
                        , breakThread = rt_id }
    ExecBreak {breakNames :: ExecResult -> [Name]
breakNames = [Name]
_, breakPointId :: ExecResult -> Maybe InternalBreakpointId
breakPointId = Just InternalBreakpointId
bid} -> do
      let performAction :: BreakpointAction -> Debugger EvalResult
performAction BreakpointAction
BreakpointStop = do

                rt_id <- Debugger RemoteThreadId
getRemoteThreadIdFromContext
                return EvalStopped{ breakId = Just bid
                                  , breakThread = rt_id }
          performAction (BreakpointLogAndResume String
logExpr) = do
            let evalFailedMsg :: String -> b
evalFailedMsg String
e = String -> b
forall doc. IsLine doc => String -> doc
text (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines [String
"Evaluation of log message expression failed with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e
                  , String
"Expr: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
logExpr
                  , String
"Ignoring..."]
            String
-> (String -> SDoc)
-> (String -> String -> Debugger EvalResult)
-> Debugger EvalResult
doEval' String
logExpr String -> SDoc
forall doc. IsLine doc => String -> doc
evalFailedMsg ((String -> String -> Debugger EvalResult) -> Debugger EvalResult)
-> (String -> String -> Debugger EvalResult) -> Debugger EvalResult
forall a b. (a -> b) -> a -> b
$ \ String
_ String
_ -> Debugger EvalResult
resume

      bm <- 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 (IORef (BreakpointMap BreakpointInfo)
 -> Debugger (BreakpointMap BreakpointInfo))
-> Debugger (IORef (BreakpointMap BreakpointInfo))
-> Debugger (BreakpointMap BreakpointInfo)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (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
      case BM.lookup bid bm of
        -- When stepping (`GHC.resumeExec SingleStep` or similar), we will typically stop at locations not explicitly enabled by the user (i.e. not registered in `activeBreakpoints`).
        Maybe BreakpointInfo
Nothing -> BreakpointAction -> Debugger EvalResult
performAction BreakpointAction
BreakpointStop
        Just BreakpointInfo{bpInfoStatus :: BreakpointInfo -> BreakpointStatus
bpInfoStatus = BreakpointStatus
status, bpInfoAction :: BreakpointInfo -> BreakpointAction
bpInfoAction = BreakpointAction
action} -> do
          case BreakpointStatus
status of
           -- todo: BreakpointAfterCountCond is not handled yet.
            BreakpointAfterCountCond{} -> BreakpointAction -> Debugger EvalResult
performAction BreakpointAction
action
            BreakpointWhenCond String
cond -> do
              let evalFailedMsg :: String -> b
evalFailedMsg String
e = String -> b
forall doc. IsLine doc => String -> doc
text (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$ String
"Evaluation of conditional breakpoint expression failed with " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
e String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nIgnoring..."

              String
-> (String -> SDoc)
-> (String -> String -> Debugger EvalResult)
-> Debugger EvalResult
doEval' String
cond String -> SDoc
forall doc. IsLine doc => String -> doc
evalFailedMsg ((String -> String -> Debugger EvalResult) -> Debugger EvalResult)
-> (String -> String -> Debugger EvalResult) -> Debugger EvalResult
forall a b. (a -> b) -> a -> b
$ \ String
resultVal String
resultType -> do
                if String
resultType String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"Bool" then do
                  if String
resultVal String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"True" then do
                    BreakpointAction -> Debugger EvalResult
performAction BreakpointAction
action
                  else
                    Debugger EvalResult
resume
                else do
                  Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning (String -> SDoc
forall doc. IsLine doc => String -> doc
evalFailedMsg String
"\"expression resultType is != Bool\"")
                  Debugger EvalResult
resume
            BreakpointStatus
BreakpointDisabled -> Debugger EvalResult
resume
            -- The counting is handled by @GHC.setupBreakpoint@
            BreakpointAfterCount Int
_ -> BreakpointAction -> Debugger EvalResult
performAction BreakpointAction
action
            BreakpointStatus
BreakpointEnabled -> BreakpointAction -> Debugger EvalResult
performAction BreakpointAction
action
  where
    doEval' :: String
-> (String -> SDoc)
-> (String -> String -> Debugger EvalResult)
-> Debugger EvalResult
doEval' String
expr String -> SDoc
evalFailedMsg String -> String -> Debugger EvalResult
k = String -> Debugger EvalResult
doEval String
expr Debugger EvalResult
-> (EvalResult -> 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
            EvalStopped{} -> String -> Debugger EvalResult
forall a. HasCallStack => String -> a
error String
"impossible for doEval"
            EvalCompleted { String
resultVal :: EvalResult -> String
resultVal :: String
resultVal, String
resultType :: EvalResult -> String
resultType :: String
resultType } ->
              String -> String -> Debugger EvalResult
k String
resultVal String
resultType
            EvalException { String
resultVal :: EvalResult -> String
resultVal :: String
resultVal } -> do
              Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning (String -> SDoc
evalFailedMsg String
resultVal)
              Debugger EvalResult
resume
            EvalAbortedWith String
e -> do
              Severity -> SDoc -> Debugger ()
logSDoc Severity
Logger.Warning (String -> SDoc
evalFailedMsg String
e)
              Debugger EvalResult
resume
    resume :: Debugger EvalResult
resume = SingleStep -> Maybe Int -> Debugger ExecResult
forall (m :: * -> *).
GhcMonad m =>
SingleStep -> Maybe Int -> m ExecResult
resumeExec SingleStep
GHC.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

-- | 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 (m :: * -> *) a. (GhcMonad m, Outputable a) => a -> m 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
<$> do
      fam_envs <- Debugger FamInstEnvs
getFamInstEnvs'
      tyThingToVarInfo fam_envs tt

getRemoteThreadIdFromContext :: Debugger RemoteThreadId
getRemoteThreadIdFromContext :: Debugger RemoteThreadId
getRemoteThreadIdFromContext = do
  Debugger [Resume]
forall (m :: * -> *). GhcMonad m => m [Resume]
GHC.getResumeContext Debugger [Resume]
-> ([Resume] -> Debugger RemoteThreadId) -> Debugger RemoteThreadId
forall a b. Debugger a -> (a -> Debugger b) -> Debugger b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Resume
resume1:[Resume]
_ ->
      ForeignRef (ResumeContext [HValueRef]) -> Debugger RemoteThreadId
getRemoteThreadIdFromRemoteContext (ForeignRef (ResumeContext [HValueRef]) -> Debugger RemoteThreadId)
-> ForeignRef (ResumeContext [HValueRef])
-> Debugger RemoteThreadId
forall a b. (a -> b) -> a -> b
$ Resume -> ForeignRef (ResumeContext [HValueRef])
GHC.resumeContext Resume
resume1
    [Resume]
_ -> String -> Debugger RemoteThreadId
forall a. HasCallStack => String -> a
error String
"No resumes but stopped?!?"