haskell-debugger 0.11.0.0 → 0.12.0.0

raw patch · 45 files changed

+1896/−1090 lines, 45 filesdep +ghc-experimentaldep −prettyprinterdep ~asyncdep ~dapdep ~ghciPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc-experimental

Dependencies removed: prettyprinter

Dependency ranges changed: async, dap, ghci, time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• LICENSE +1/−1
• README.md +25/−6
• haskell-debugger-view/src/GHC/Debugger/View/Class.hs +11/−2
• haskell-debugger.cabal +10/−9
• haskell-debugger/GHC/Debugger.hs +7/−14
• haskell-debugger/GHC/Debugger/Breakpoint.hs +1/−1
• haskell-debugger/GHC/Debugger/Interface/Messages.hs +57/−35
• haskell-debugger/GHC/Debugger/Logger.hs +0/−130
• haskell-debugger/GHC/Debugger/Monad.hs +228/−132
• haskell-debugger/GHC/Debugger/Run.hs +4/−17
• haskell-debugger/GHC/Debugger/Runtime.hs +2/−8
• haskell-debugger/GHC/Debugger/Runtime/Compile.hs +1/−3
• haskell-debugger/GHC/Debugger/Runtime/Eval.hs +17/−10
• haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs +3/−11
• haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs +10/−0
• haskell-debugger/GHC/Debugger/Runtime/Instances.hs +1/−1
• haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs +1/−1
• haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs +0/−35
• haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs +4/−14
• haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs +5/−6
• haskell-debugger/GHC/Debugger/Runtime/Thread.hs +1/−2
• haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs +90/−62
• haskell-debugger/GHC/Debugger/Session.hs +60/−0
• haskell-debugger/GHC/Debugger/Session/Builtin.hs +0/−1
• haskell-debugger/GHC/Debugger/Stopped.hs +176/−167
• haskell-debugger/GHC/Debugger/Stopped/Exception.hs +219/−0
• haskell-debugger/GHC/Debugger/Stopped/Variables.hs +10/−10
• haskell-debugger/GHC/Debugger/Utils.hs +27/−16
• hdb/Development/Debug/Adapter.hs +15/−2
• hdb/Development/Debug/Adapter/Breakpoints.hs +2/−9
• hdb/Development/Debug/Adapter/Evaluation.hs +18/−2
• hdb/Development/Debug/Adapter/ExceptionInfo.hs +65/−0
• hdb/Development/Debug/Adapter/Handles.hs +0/−11
• hdb/Development/Debug/Adapter/Init.hs +170/−117
• hdb/Development/Debug/Adapter/Proxy.hs +13/−19
• hdb/Development/Debug/Adapter/Stepping.hs +14/−0
• hdb/Development/Debug/Adapter/Stopped.hs +80/−57
• hdb/Development/Debug/Interactive.hs +184/−62
• hdb/Development/Debug/Options.hs +29/−6
• hdb/Development/Debug/Options/Parser.hs +56/−7
• hdb/Development/Debug/Session/Setup.hs +22/−29
• hdb/Main.hs +159/−53
• test/haskell/Main.hs +74/−18
• test/haskell/Test/DAP/RunInTerminal.hs +8/−4

@@ -1,5 +1,21 @@ # Revision history for haskell-debugger +## 0.12.0.0 -- 2026-02-11++* Improved exceptions support!+    * Break-on-exception breakpoints now provide source locations+    * And exception callstacks based on the ExceptionAnnotation mechanism.+* Introduced stacktraces support!+    * Stack frames decoded from interpreter frames with breakpoints are displayed+    * Stack frames decoded from IPE information available for compiled code frames too+    * Custom stack annotations will also be displayed+* Use the external interpreter by default!+    * Paves the way for separating debugger threads vs debuggee threads in multi-threaded debugging+    * Allows debuggee vs debugger output to be separated by construction+* Windows is now supported when using the external interpreter (default)+* Fixed bug where existential constraints weren't displayed in the variables pane+* Plus more bug fixes, refactors, test improvements, and documentation updates.+ ## 0.11.0.0 -- 2026-01-05  * Introduce but don't yet expose infrastructure for debugging multi-threaded

@@ -1,4 +1,4 @@-Copyright (c) 2025, Rodrigo Mesquita+Copyright (c) 2025, Well-Typed   Redistribution and use in source and binary forms, with or without

@@ -10,7 +10,7 @@ [project homepage](https://well-typed.github.io/haskell-debugger/)!  > [!WARNING]-> `hdb` can currently be compiled with the 9.14 alpha pre-releases or with a nightly version+> `hdb` can currently be compiled with GHC 9.14 > The first release it will be compatible with is GHC 9.14.  To install and use the debugger, you need the executable `hdb`@@ -47,6 +47,9 @@  Change them accordingly. +You can also run the debugger as a server on a specific port by executing `hdb server --port 12345`.+To connect VSCode to this server, add the field `"debugServer": 12345` to your `launch.json` configuration.+ To run the debugger, simply hit the green run button. See the Features section below for what is currently supported. @@ -76,7 +79,7 @@  We have been doing custom work on GHC to support debugging in a predictable, robust, and more performant way. That is why `hdb` is only-compatible with the latest and greatest GHC. If you want to debug using an older+compatible with GHC 9.14. If you want to debug using an older GHC version (9.12 and older), please check out `haskell-debug-adapter`.  To implement the Debug Adapter Protocol (DAP) server part, we are using the@@ -149,13 +152,29 @@  # Building from source -To build `hdb`:+## Build `hdb` (using Cabal)+ ```-cabal build -w /path/to/recent/ghc exe:hdb+cabal build -w /path/to/ghc-9.14 exe:hdb ``` -To build the VSCode extension+## Build and install `hdb` (using Stack)++On non-Windows operating systems:+ ```+stack install haskell-debugger+```++On Windows:++```+stack -w stack-windows.yaml install haskell-debugger+```++## Build VS Code extension (using Nix)++``` cd vscode-extension nix-build ```@@ -165,5 +184,5 @@ ``` cd test/integration-tests make GHC=/path/to/recent/ghc \-     DEBUGGER=$(cd ../.. && cabal list-bin -w /path/to/recent/ghc exe:hdb)+     DEBUGGER=$(cd ../.. && cabal list-bin -w /path/to/ghc-9.14 exe:hdb) ```

@@ -51,6 +51,7 @@  import Data.Int import Data.Word+import Control.Exception  -- | Custom handling of debug terms (e.g. in the variables pane, or when -- inspecting a lazy variable)@@ -75,7 +76,7 @@   debugFields :: a -> Program VarFields  -- | The 'Program' abstraction allows more complicated 'DebugView' instances--- to be constructed. The debugger will interpreter a 'Program' lazily when+-- to be constructed. The debugger will interpret a 'Program' lazily when -- determining how to display a variable. -- -- At the moment the only interesting query when constructing a program is determining@@ -180,6 +181,15 @@     [ ("fst", VarFieldValue x)     , ("snd", VarFieldValue y) ] +instance DebugView SomeException where+  debugValue e = simpleValue (displayException e) True+  debugFields e@(SomeException exc) =+    let !ctx = someExceptionContext e+    in pure $ VarFields+    [ ("exception", VarFieldValue exc)+    , ("context", VarFieldValue ctx)+    ]+ -- | This instance will display up to the first 50 forced elements of a list. instance {-# OVERLAPPABLE #-} DebugView [a] where   debugValue [] = simpleValue "[]" False@@ -219,4 +229,3 @@ toVarFieldsIO x =   case x of     VarFields fls -> [ (pure fl_s, b) | (fl_s, b) <- fls]-

@@ -1,6 +1,6 @@ cabal-version:      3.12 name:               haskell-debugger-version:            0.11.0.0+version:            0.12.0.0 synopsis:     A step-through debugger for GHC Haskell @@ -58,9 +58,9 @@     exposed-modules:  GHC.Debugger,                       GHC.Debugger.Breakpoint,                       GHC.Debugger.Breakpoint.Map,-                      GHC.Debugger.Logger,                       GHC.Debugger.Run,                       GHC.Debugger.Stopped,+                      GHC.Debugger.Stopped.Exception,                       GHC.Debugger.Stopped.Variables,                        GHC.Debugger.Runtime,@@ -77,7 +77,6 @@                        GHC.Debugger.Runtime.Term.Parser,                       GHC.Debugger.Runtime.Term.Key,-                      GHC.Debugger.Runtime.Term.Cache,                        GHC.Debugger.Runtime.Thread,                       GHC.Debugger.Runtime.Thread.Stack,@@ -95,6 +94,7 @@                       ghc >= 9.14 && < 9.16, ghci >= 9.14 && < 9.16,                       ghc-boot-th >= 9.14 && < 9.16,                       ghc-boot >= 9.14 && < 9.16,+                      ghc-experimental >= 9.1401 && < 9.1600,                       ghc-heap >= 9.14 && < 9.16,                       array >= 0.5.8 && < 0.6,                       containers >= 0.7 && < 0.9,@@ -105,15 +105,14 @@                       directory >= 1.3.9.0 && < 1.4,                       exceptions >= 0.10.9 && < 0.11,                       bytestring >= 0.12.1 && < 0.13,+                      async >= 2.2.6 && < 2.3,                       cryptohash-sha1 >= 0.11.101.0 && < 0.12,                       base16-bytestring >= 1.0.2.0 && < 1.1,                       aeson >= 2.2.3 && < 2.3,                       hie-bios >= 0.15 && < 0.18,                       file-embed >= 0.0.16 && < 0.1,                       attoparsec >= 0.13 && < 0.15,-                      -- Logger dependencies                       time >= 1.14 && < 2,-                      prettyprinter >= 1.7.1 && < 2,                       text >= 2.1 && < 2.3,                       co-log-core >= 0.3.2.5 && < 0.4, @@ -132,6 +131,7 @@                       Development.Debug.Adapter.Stepping,                       Development.Debug.Adapter.Stopped,                       Development.Debug.Adapter.Evaluation,+                      Development.Debug.Adapter.ExceptionInfo,                       Development.Debug.Adapter.Init,                       Development.Debug.Adapter.Interface,                       Development.Debug.Adapter.Output,@@ -151,7 +151,7 @@                       Paths_haskell_debugger     autogen-modules:  Paths_haskell_debugger     build-depends:-        base, ghc,+        base, ghc, ghci,         exceptions, aeson, bytestring,         containers, filepath,         process, mtl,@@ -162,15 +162,14 @@         co-log-core >= 0.3.2.5 && < 0.4,         implicit-hie ^>=0.1.4.0,         transformers >= 0.6 && < 0.7,-        -- Logger dependencies-        prettyprinter,+        time,          directory >= 1.3.9 && < 1.4,         network >= 3.2.8,         network-run >= 0.4.4,         async >= 2.2.5 && < 2.3,         text >= 2.1 && < 2.3,-        dap >= 0.3.1 && < 0.4,+        dap >= 0.4 && < 0.5,          haskeline >= 0.8 && < 1,         optparse-applicative >= 0.18 && < 0.20@@ -178,6 +177,8 @@     default-language: GHC2021     default-extensions: CPP     ghc-options: -threaded+    -- See Note [Custom external interpreter]+    ghc-options: -fkeep-cafs  test-suite haskell-debugger-test     import:           warnings

@@ -9,17 +9,17 @@ import GHC.Debugger.Breakpoint import GHC.Debugger.Run import GHC.Debugger.Stopped+import GHC.Debugger.Stopped.Exception (getExceptionInfo) import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages-import GHC.Debugger.Logger  -------------------------------------------------------------------------------- -- * Executing commands --------------------------------------------------------------------------------  -- | Execute the given debugger command in the current 'Debugger' session-execute :: Recorder (WithSeverity DebuggerLog) -> Command -> Debugger Response-execute recorder = \case+execute :: Command -> Debugger Response+execute = \case   ClearFunctionBreakpoints -> DidClearBreakpoints <$ clearBreakpoints Nothing   ClearModBreakpoints fp -> DidClearBreakpoints <$ clearBreakpoints (Just fp)   SetBreakpoint{brk, hitCount, condition} ->@@ -28,22 +28,15 @@   GetBreakpointsAt bp -> DidGetBreakpoints <$> getBreakpointsAt bp   GetThreads -> GotThreads <$> getThreads   GetStacktrace i -> GotStacktrace <$> getStacktrace i-  GetScopes -> GotScopes <$> getScopes-  GetVariables kind -> GotVariables <$> getVariables kind+  GetScopes threadId frameIx -> GotScopes <$> getScopes threadId frameIx+  GetVariables threadId frameIx varRef -> GotVariables <$> getVariables threadId frameIx varRef+  GetExceptionInfo threadId -> GotExceptionInfo <$> getExceptionInfo threadId   DoEval exp_s -> DidEval <$> doEval exp_s   DoContinue -> DidContinue <$> doContinue   DoSingleStep -> DidStep <$> doSingleStep   DoStepOut -> DidStep <$> doStepOut   DoStepLocal -> DidStep <$> doLocalStep-  DebugExecution { entryPoint, entryFile, runArgs } -> DidExec <$> debugExecution (cmapWithSev EvalLog recorder) entryFile entryPoint runArgs+  DebugExecution { entryPoint, entryFile, runArgs } -> DidExec <$> debugExecution entryFile entryPoint runArgs   TerminateProcess -> liftIO $ do     -- Terminate!     exitWith ExitSuccess--data DebuggerLog-  = EvalLog EvalLog--instance Pretty DebuggerLog where-  pretty = \ case-    EvalLog msg -> pretty msg-

@@ -12,6 +12,7 @@ import Data.IORef import System.Directory import System.FilePath+import qualified Colog.Core as Logger  import GHC import GHC.ByteCode.Breakpoints@@ -28,7 +29,6 @@  import GHC.Debugger.Monad import GHC.Debugger.Session-import GHC.Debugger.Logger as Logger import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages import qualified GHC.Debugger.Breakpoint.Map as BM

@@ -1,6 +1,7 @@ {-# OPTIONS_GHC -Wno-orphans #-} -- TODO: drop this and Show GHC.InternalBreakpointId... {-# LANGUAGE LambdaCase,              StandaloneDeriving,+             DataKinds,              OverloadedStrings,              DuplicateRecordFields,              TypeApplications@@ -12,6 +13,8 @@ import qualified GHC import qualified GHC.Utils.Outputable as GHC +import GHC.Debugger.Runtime.Term.Key+ -------------------------------------------------------------------------------- -- Commands --------------------------------------------------------------------------------@@ -20,7 +23,7 @@ data Command    -- | Set a breakpoint on a given function, or module by line number-  = SetBreakpoint { brk       :: Breakpoint +  = SetBreakpoint { brk       :: Breakpoint                   , hitCount  :: Maybe Int                   -- ^ Stop after N hits (if @isJust condition@, count down only when @eval condition == True@)                   , condition :: Maybe String@@ -47,17 +50,20 @@   | GetStacktrace RemoteThreadId    -- | Get the list of available scopes at the current breakpoint-  | GetScopes+  | GetScopes RemoteThreadId Int    -- | Get the variables in scope for the current breakpoint.   --   -- Note: for GHCs <9.16 this only reports the variables free in the expression   -- we're stopped at rather than all variables in scope.-  | GetVariables VariableReference+  | GetVariables RemoteThreadId Int{-stack frame positional ix-} VariableReference    -- | Evaluate an expression at the current breakpoint.   | DoEval String +  -- | Get information about the current exception (if any) on a thread.+  | GetExceptionInfo RemoteThreadId+   -- | Continue executing from the current breakpoint   | DoContinue @@ -104,7 +110,6 @@   deriving (Show)  newtype VarFields = VarFields [VarInfo]-  deriving (Show, Eq)  -- | Information about a variable data VarInfo = VarInfo@@ -118,8 +123,23 @@       -- TODO:       --  memory reference using ghc-debug.       }-      deriving (Show, Eq) +-- | Result of requesting variables.+--+-- If the variable you requested is a thunk then `ForcedVariable` is returned, which+-- is the variable you requested but forced.+--+-- If the variable you requested is not a thunk, then 'VariableFields` is returned which+-- contains the subfields of the variable.+data VariableResult+  = ForcedVariable VarInfo+  | VariableFields [VarInfo]++variableResultToList :: VariableResult -> [VarInfo]+variableResultToList = \case+  ForcedVariable vi -> [vi]+  VariableFields vis -> vis+ -- | What kind of breakpoint are we referring to, module or function breakpoints? -- Used e.g. in the 'ClearBreakpoints' request data BreakpointKind@@ -154,35 +174,14 @@    -- | A reference to a specific variable.   -- Used to force its result or get its structured children-  | SpecificVariable Int--  deriving (Show, Eq, Ord)+  | SpecificVariable TermKey --- | From 'ScopeVariablesReference' to a 'VariableReference' that can be used in @"variable"@ requests scopeToVarRef :: ScopeVariablesReference -> VariableReference scopeToVarRef = \case   LocalVariablesScope -> LocalVariables   ModuleVariablesScope -> ModuleVariables   GlobalVariablesScope -> GlobalVariables --instance Bounded VariableReference where-  minBound = NoVariables-  maxBound = SpecificVariable maxBound--instance Enum VariableReference where-  toEnum 0 = NoVariables-  toEnum 1 = LocalVariables-  toEnum 2 = ModuleVariables-  toEnum 3 = GlobalVariables-  toEnum n = SpecificVariable (n - 4)--  fromEnum NoVariables          = 0-  fromEnum LocalVariables       = 1-  fromEnum ModuleVariables      = 2-  fromEnum GlobalVariables      = 3-  fromEnum (SpecificVariable n) = 4 + n- -- | A source span type for the interface. Like 'RealSrcSpan'. data SourceSpan = SourceSpan       { file :: !FilePath@@ -196,8 +195,22 @@       , endCol :: {-# UNPACK #-} !Int       -- ^ RealSrcSpan end col       }-      deriving (Show)+      deriving (Show, Eq) +-- | This is a completely unhelpful source span!+-- It doesn't point to anything and is of no help to the user+-- whatsoever.+--+-- Use this only as a last resort if no other source span can be provided.+unhelpfulSourceSpan :: SourceSpan+unhelpfulSourceSpan = SourceSpan+  { file = ""+  , startLine = 0+  , endLine = 0+  , startCol = 0+  , endCol = 0+  }+ -------------------------------------------------------------------------------- -- Responses --------------------------------------------------------------------------------@@ -215,7 +228,8 @@   | GotThreads [DebuggeeThread]   | GotStacktrace [DbgStackFrame]   | GotScopes [ScopeInfo]-  | GotVariables (Either VarInfo [VarInfo])+  | GotVariables VariableResult+  | GotExceptionInfo ExceptionInfo   | Aborted String   | Initialised @@ -255,7 +269,8 @@                   , resultStructureRef :: VariableReference                   -- ^ A structured representation of the result of evaluating                   -- the expression given as a "virtual" 'VariableReference'-                  -- that the user can expand as a normal variable.+                  -- that the user can use to refer to the result and inspect+                  -- interactively and expand it.                   }   | EvalException { resultVal :: String, resultType :: String }   | EvalStopped   { breakId :: Maybe GHC.InternalBreakpointId@@ -265,7 +280,6 @@                   }   -- | Evaluation failed for some reason other than completed/completed-with-exception/stopped.   | EvalAbortedWith String-  deriving (Show)  data DebuggeeThread   = DebuggeeThread@@ -282,16 +296,24 @@     -- ^ Title of stack frame     , sourceSpan :: SourceSpan     -- ^ Source span for this stack frame+    , breakId :: Maybe GHC.InternalBreakpointId+    -- ^ Is this a BCO continuation frame with a breakpoint?+    -- If yes, we can leverage the breakpoint info to report scopes.     }   deriving (Show) +data ExceptionInfo = ExceptionInfo+  { exceptionInfoTypeName     :: String+  , exceptionInfoFullTypeName :: String+  , exceptionInfoMessage      :: String+  , exceptionInfoContext      :: Maybe String+  , exceptionInfoInner        :: [ExceptionInfo]+  }+  deriving (Show)+ -------------------------------------------------------------------------------- -- Instances -------------------------------------------------------------------------------- -deriving instance Show Command-deriving instance Show Response- instance Show GHC.InternalBreakpointId where   show (GHC.InternalBreakpointId m ix) = "InternalBreakpointId " ++ GHC.showPprUnsafe m ++ " " ++ show ix-

@@ -1,130 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE RankNTypes #-}---- | Simple Logger API using co-log style loggers-module GHC.Debugger.Logger (-  -- * The core Logger type-  Recorder,-  logWith,-  -- * Log messages-  Pretty(..),-  -- * For simpler usage-  Colog.LogAction (..),-  toCologAction,-  fromCologAction,-  -- * Severity-  Severity (..),-  WithSeverity (..),-  cmap,-  cmapIO,-  cmapWithSev,-  -- * Verbosity-  Verbosity(..),-  applyVerbosity,--  -- * Pretty printing of logs-  renderPrettyWithSeverity,-  renderWithSeverity,-  renderPretty,-  renderSeverity,-  renderWithTimestamp,--  -- Re-exports-  module Data.Functor.Contravariant,-) where--import GHC.Stack--import Control.Monad.IO.Class-import Control.Monad ((>=>))--import Colog.Core (Severity(..), WithSeverity(..), filterBySeverity)-import qualified Colog.Core as Colog-import Data.Functor.Contravariant (Contravariant (contramap))-import Data.Text (Text)-import qualified Data.Text as T-import Prettyprinter-import Prettyprinter.Render.Text (renderStrict)-import Data.Time (defaultTimeLocale, formatTime, getCurrentTime)--newtype Recorder msg = Recorder-  { logger_ :: forall m. (MonadIO m) => msg -> m () }--instance Contravariant Recorder where-  contramap f Recorder{ logger_ } =-    Recorder-      { logger_ = logger_ . f }--instance Semigroup (Recorder msg) where-  (<>) Recorder{ logger_ = logger_1 } Recorder{ logger_ = logger_2 } =-    Recorder-      { logger_ = \msg -> logger_1 msg >> logger_2 msg }--instance Monoid (Recorder msg) where-  mempty =-    Recorder-      { logger_ = \_ -> pure () }---- | Logging verbosity, where all Severities matching or exceeding the threshold are printed-newtype Verbosity = Verbosity { threshold :: Severity }---- | Make this logger never report messages whose severity is below the given verbosity severity.-applyVerbosity :: Verbosity -> Recorder (WithSeverity a) -> Recorder (WithSeverity a)-applyVerbosity Verbosity{threshold} rc-  = fromCologAction $ filterBySeverity threshold getSeverity (toCologAction rc)--logWith :: (HasCallStack, MonadIO m) => Recorder (WithSeverity msg) -> Severity -> msg -> m ()-logWith Recorder{logger_} sev msg = logger_ $ WithSeverity msg sev--cmap :: (a -> b) -> Recorder b -> Recorder a-cmap = contramap--cmapWithSev :: (a -> b) -> Recorder (WithSeverity b) -> Recorder (WithSeverity a)-cmapWithSev f = contramap (fmap f)--cmapIO :: (a -> IO b) -> Recorder b -> Recorder a-cmapIO f Recorder{ logger_ } =-  Recorder-    { logger_ = (liftIO . f) >=> logger_ }--renderPrettyWithSeverity :: Pretty a => WithSeverity a -> Text-renderPrettyWithSeverity =-  renderWithSeverity renderPretty--renderWithSeverity :: (a -> Text) -> WithSeverity a -> Text-renderWithSeverity f msgWithSev =-  renderSeverity (getSeverity msgWithSev) <> " " <> f (getMsg msgWithSev)--renderPretty :: Pretty a => a -> Text-renderPretty a =-  let-    docToText = renderStrict . layoutPretty defaultLayoutOptions-  in-    docToText (pretty a)--renderWithTimestamp :: Text -> IO Text-renderWithTimestamp msg = do-  t <- getCurrentTime-  let timeStamp = utcTimeToText t-  pure $ "[" <> timeStamp <> "]" <> msg-  where-    utcTimeToText utcTime = T.pack $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime--renderSeverity :: Severity -> Text-renderSeverity = \ case-  Debug -> "[DEBUG]"-  Info -> "[INFO]"-  Warning -> "[WARNING]"-  Error -> "[ERROR]"--toCologAction :: (MonadIO m, HasCallStack) => Recorder msg -> Colog.LogAction m msg-toCologAction (Recorder logger_) = Colog.LogAction $ \msg -> do-    logger_ msg--fromCologAction :: (HasCallStack) => Colog.LogAction IO msg -> Recorder msg-fromCologAction (Colog.LogAction logger_) = Recorder $ \msg -> do-    liftIO $ logger_ msg

@@ -1,4 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE MultilineStrings #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -11,20 +13,25 @@  module GHC.Debugger.Monad where +import System.Environment+import System.Process+import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception import Control.Monad import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Reader import Data.Function+import Data.Functor.Contravariant import Data.IORef import Data.Maybe import Data.Version (makeVersion, showVersion) import Prelude hiding (mod)-import System.IO #ifdef MIN_VERSION_unix import System.Posix.Signals #endif-import qualified Data.IntMap as IM+import Data.Text (Text) import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty @@ -34,6 +41,8 @@ import GHC.Driver.Config.Diagnostic import GHC.Driver.DynFlags as GHC import GHC.Driver.Env+import GHC.Driver.Monad+import GHC.Driver.Hooks import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Main@@ -52,20 +61,20 @@ import GHC.Unit.State import GHC.Unit.Module.ModSummary as GHC import GHC.Unit.Types-import GHC.Utils.Logger as GHC+import qualified GHC.Utils.Logger as GHC import GHC.Utils.Outputable as GHC import qualified GHC.LanguageExtensions as LangExt  import GHC.Debugger.Interface.Messages-import GHC.Debugger.Logger as Logger-import GHC.Debugger.Runtime.Term.Cache-import GHC.Debugger.Runtime.Term.Key import GHC.Debugger.Session import GHC.Debugger.Session.Builtin import GHC.Debugger.Runtime.Compile.Cache+import GHC.Debugger.Utils import qualified GHC.Debugger.Breakpoint.Map as BM import qualified GHC.Debugger.Runtime.Thread.Map as TM +import Colog.Core as Logger+ import {-# SOURCE #-} GHC.Debugger.Runtime.Instances.Discover (RuntimeInstancesCache, emptyRuntimeInstancesCache)  -- | A debugger action.@@ -82,18 +91,7 @@         -- ^ Maps a 'InternalBreakpointId' in Trie representation (map of Module to map of Int) to the         -- 'BreakpointStatus' it was activated with. -      , varReferences     :: IORef (IM.IntMap TermKey, TermKeyMap Int)-      -- ^ When we're stopped at a breakpoint, this maps variable reference to-      -- Terms to allow further inspection and forcing by reference.-      ---      -- This map is only valid while stopped in this context. After stepping-      -- or resuming evaluation in any available way, this map becomes invalid-      -- and should therefore be cleaned.-      ---      -- The TermKeyMap map is a reverse lookup map to find which references-      -- already exist for given names--      , rtinstancesCache :: IORef RuntimeInstancesCache+      , rtinstancesCache  :: IORef RuntimeInstancesCache       -- ^ RuntimeInstancesCache        , threadMap         :: IORef TM.ThreadMap@@ -102,9 +100,6 @@       , compCache         :: IORef CompCache       -- ^ Cache loaded and compiled expressions. -      , genUniq           :: IORef Int-      -- ^ Generates unique ints-       , hsDbgViewUnitId   :: Maybe UnitId       -- ^ The unit-id of the companion @haskell-debugger-view@ unit, used for       -- user-defined and built-in custom debug visualisations of values (e.g.@@ -124,9 +119,17 @@       --       -- If the user explicitly disabled custom views, use @Nothing@. -      , dbgLogger :: Recorder (WithSeverity DebuggerMonadLog)+      , dbgLogger :: LogAction Debugger DebuggerLog+      -- ^ See Note [Debugger, debuggee, and DAP logs]       } +instance GHC.HasLogger Debugger where+  getLogger = liftGhc GHC.getLogger++instance GHC.GhcMonad Debugger where+  getSession = liftGhc GHC.getSession+  setSession s = liftGhc $ GHC.setSession s+ -- | Enabling/Disabling a breakpoint data BreakpointStatus       -- | Breakpoint is disabled@@ -155,11 +158,14 @@ data RunDebuggerSettings = RunDebuggerSettings       { supportsANSIStyling :: Bool       , supportsANSIHyperlinks :: Bool+      , preferInternalInterpreter :: Bool+      , externalInterpreterStdinStream :: StdStream+      -- ^ How to determine the stdin of the external interpreter running the+      -- debuggee. If not using the external interpreter this field is unused.       }  -- | Run a 'Debugger' action on a session constructed from a given GHC invocation.-runDebugger :: Recorder (WithSeverity DebuggerMonadLog)-            -> Handle     -- ^ The handle to which GHC's output is logged. The debuggee output is not affected by this parameter.+runDebugger :: LogAction IO DebuggerLog             -> FilePath   -- ^ Cradle root directory             -> FilePath   -- ^ Component root directory             -> FilePath   -- ^ The libdir (given with -B as an arg)@@ -170,7 +176,10 @@             -> RunDebuggerSettings -- ^ Other debugger run settings             -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation             -> IO a-runDebugger l dbg_out rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = do+runDebugger l rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = do+  let ghcLog = liftLogIO l :: LogAction Ghc DebuggerLog+  let dbgLog = liftLogIO l :: LogAction Debugger DebuggerLog+  thisProg <- getExecutablePath   let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation'   GHC.runGhc (Just libdir) $ do #ifdef MIN_VERSION_unix@@ -194,12 +203,28 @@           `GHC.gopt_set` GHC.Opt_IgnoreHpcChanges           `GHC.gopt_set` GHC.Opt_UseBytecodeRatherThanObjects           `GHC.gopt_set` GHC.Opt_InsertBreakpoints++          -- Enable the external interpreter by default! See #169+          -- See Note [Custom external interpreter]+          & enableExternalInterpreter conf.preferInternalInterpreter+          -- Ext interp is the same program as this, with "--external-interpreter"+          -- (this is ignored on GHC 9.14, see Note [Custom external interpreter])+          & setPgmI thisProg+          -- ideally, we'd set "external-interpreter" *before* the file+          -- descriptors. since there's no way to do that yet, we just have+          -- some logic in main to detect [writefd, readfd, --external-interpreter]+          & addOptI "--external-interpreter"++          -- Really important to force -dynamic if host is dynamic+          -- See Note [Dynamic Debuggee for dynamic debugger]+          & enableDynamicDebuggee+           & setBytecodeBackend           & enableByteCodeGeneration      GHC.modifyLogger $       -- Override the logger to output to the given handle-      GHC.pushLogHook $ const $ debuggerLoggerAction dbg_out+      GHC.pushLogHook $ const $ ghcLogAction l      dflags2 <- getLogger >>= \logger -> do       -- Set the extra GHC arguments for ALL units by setting them early in@@ -212,13 +237,48 @@       (dflags2, fileish_args, warns)         <- parseDynamicFlags logger dflags1 (map noLoc extraGhcArgs)       liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)-      -- todo: consider fileish_args?       forM_ fileish_args $ \fish_arg -> liftIO $ do-        logMsg logger MCOutput noSrcSpan $ text "Ignoring extraGhcArg which isn't a recognized flag:" <+> text (unLoc fish_arg)+        GHC.logMsg logger MCOutput noSrcSpan $ text "Ignoring extraGhcArg which isn't a recognized flag:" <+> text (unLoc fish_arg)         printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns)       return dflags2 -    -- Set the session dynflags now to initialise the hsc_interp.+    -- Make sure to override the function which creates the external+    -- interpreter, because we need to keep track of the standard handles+    iserv_handles <- liftIO newEmptyMVar+    modifySession $ \h -> h+      { hsc_hooks = (hsc_hooks h)+          { createIservProcessHook = Just $ \cp -> do+              -- See Note [External interpreter buffering]+              (_, Just o, Just e, ph) <-+                createProcess cp+                  { std_in  = conf.externalInterpreterStdinStream+                  , std_out = CreatePipe+                  , std_err = CreatePipe+                  -- Override executable path+                  -- See Note [Custom external interpreter]+#if MIN_VERSION_ghc(9,15,0)+#else+                  , cmdspec = case cmdspec cp of+                      ShellCommand (words -> ws) -> ShellCommand $ unwords $ thisProg : drop 1 ws+                      RawCommand _fp args -> RawCommand thisProg args+#endif+                  }+              putMVar iserv_handles (o, e)+              return ph+          }+      }++    when (GHC.gopt GHC.Opt_ExternalInterpreter dflags2) $ liftIO $ void $ do+      -- The external interpreter is spawned lazily, so we block waiting for+      -- the handles to be available in a new thread.+      forkIO $ do+        withAsync (takeMVar iserv_handles) $ \async_handles -> do+          (serv_out, serv_err) <- wait async_handles+          concurrently_+            (forwardHandleToLogger serv_err (contramap LogDebuggeeErr l))+            (forwardHandleToLogger serv_out (contramap LogDebuggeeOut l))++    -- Initializes interpreter!     _ <- GHC.setSessionDynFlags dflags2      -- Initialise plugins here because the plugin author might already expect this@@ -230,6 +290,7 @@      -- Discover the user-given flags and targets     flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags2 rootDir+    buildWays       <- liftIO $ validateUnitsWays flagsAndTargets      -- Setup base HomeUnitGraph     setupHomeUnitGraph (NonEmpty.toList flagsAndTargets)@@ -247,13 +308,14 @@          -- Add the custom unit to the HUG         let base_dep_uids = [uid | UnitNode _ uid <- mg_mss mod_graph_base]-        addInMemoryHsDebuggerViewUnit base_dep_uids =<< getDynFlags+        addInMemoryHsDebuggerViewUnit base_dep_uids . setDynFlagWays buildWays =<< getDynFlags          tryLoadHsDebuggerViewModule l if_cache (const False) debuggerViewClassModName debuggerViewClassContents           >>= \case             Failed -> do               -- Failed to load base debugger-view module!-              logWith l Debug $ LogFailedToCompileDebugViewModule debuggerViewClassModName+              ghcLog <& DebuggerLog Logger.Debug+                (LogFailedToCompileDebugViewModule debuggerViewClassModName)               return []             Succeeded -> (debuggerViewClassModName:) . concat <$> do @@ -269,12 +331,14 @@                           _ -> False) . GHC.targetId)                       modName modContent >>= \case                     Failed -> do-                      logWith l Info $ LogFailedToCompileDebugViewModule modName+                      ghcLog <& DebuggerLog Logger.Info+                        (LogFailedToCompileDebugViewModule modName)                       return []                     Succeeded -> do                       return [modName]                 else do-                  logWith l Debug $ LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids)+                  ghcLog <& DebuggerLog Logger.Debug+                    (LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids))                   return []        Just uid ->@@ -320,8 +384,100 @@         dbgViewImps ++         map (GHC.IIModule . GHC.ms_mod) mss) -    runReaderT action =<< initialDebuggerState l (if loadedBuiltinModNames == [] then Nothing else Just hdv_uid)+    -- See Note [External interpreter buffering]+    setBufferings <- compileExprRemote """+      do { System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering+         ; System.IO.hSetBuffering System.IO.stderr System.IO.LineBuffering }+      """+    hscInterp <$> GHC.getSession >>= \interp ->+      liftIO $ evalIO interp setBufferings +    runReaderT action+      =<< initialDebuggerState dbgLog+          (if loadedBuiltinModNames == []+            then Nothing+            else Just hdv_uid)++{-+Note [Custom external interpreter]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We compile a custom external interpreter server with custom commands which make+certain debugger operations possible in the remote process directly.+This allows us to avoid excessive `Term` parsing and remote execution.+(Note: we don't have custom commands just yet, but that is the vision)++The custom external interpreter is the same executable as the debugger but invoked as:++  hdb <write-fd> <read-fd> --external-interpreter++(Note: external-interpreter is not the first argument because all `-opti`s are+always inserted after the write-fd and read-fd.)++When setting up the debugger session, we essentially set by default:+  - Enable -fexternal-interpreter+  - Set -pgmi=hdb and -opti=--external-interpreter+This can be switched off by toggling `--internal-interpreter`++With GHC 9.14, we have to override the `createProcess` executable call because+of ghc's c94aaacd4c4 (GHC looks for a `-dyn` suffixed version of the custom+external `-pgmi`, in this case `hdb` (but we do not have an `hdb-dyn`).+In GHC 9.16 it is sufficient to specify the -pgmi.++We can't use the on-the-fly external interpreter from GHC 9.14 because it is+not compiled with -threaded (with 9.16 in principle could, but we really want+the custom commands)++Note: The custom external interpreter must be compiled with -fkeep-cafs!+Why that is necessary is described in the GHC source code.++Note [Dynamic Debuggee for dynamic debugger]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A really really important point is that the debuggee MUST be linked dynamically+if the debugger was compiled dynamically (checked with `hostIsDynamic`).++Not doing this resulted in days upon days of suffering caused by a SIGILL fault.++The bug surfaces when we load a non-PIC static object of the debuggee into a+debugger that was linked dynamically with PIC. The runtime object linker does+not handle this correctly and something goes very wrong with the relocated+debuggee code.++Notably, this bug didn't surface on macOS because the static objects are also+compiled with -fPIC, and it didn't show up when using the distributed iserv+executables because that has very few dyn-link-time dependencies and for some+reason that doesn't trigger the bug. Adding more unused package dependencies+was sufficient to re-trigger it on windows.++Therefore, we always use -dynamic for compiling and loading the debuggee if the+debugger is dynamic (`hostIsDynamic`).++On Windows, the debugger will be static and we'll resort to statically linking+the debuggee too. There won't be a PIC mismatch so this should work fine.++Note [External interpreter buffering]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we launch the external interpreter process, we create pipes for+stdin/stdout/stderr instead of inheriting the current process' handles.+This allows us to cleanly separate the debuggee output from the debugger+output, without needing to redirect handles or the like.++However, using a pipe instead of a handle connected to a TTY means that, by+default, the line buffering will be block based rather than line buffered.++> Newly opened streams are normally fully buffered, with one exception: a+  stream connected to an interactive device such as a terminal is initially+  line buffered.^[1]++We depend on line buffering to forward output from these handles to the+debugger output (see `forwardHandleToLogger`).++Therefore, after loading the modules, we evaluate on the remote process:++  hSetBuffering stdout LineBuffering+  hSetBuffering stderr LineBuffering++[1] https://ftp.gnu.org/old-gnu/Manuals/glibc-2.2.5/html_node/Buffering-Concepts.html+-} --------------------------------------------------------------------------------  -- | Run downsweep on the currently set targets (see @hsc_targets@)@@ -357,7 +513,7 @@ -- | Returns @Just modName@ if the given module was successfully loaded tryLoadHsDebuggerViewModule   :: GhcMonad m-  => Recorder (WithSeverity DebuggerMonadLog)+  => LogAction IO DebuggerLog   -> Maybe ModIfaceCache   -> (GHC.Target -> Bool)   -- ^ Predicate to determine which of the existing@@ -375,9 +531,9 @@   -- modules we're trying to load and compile.   restore_logger <- GHC.getLogger   GHC.modifyLogger $-    -- Emit it all as Debug-level logs+    -- Emit it all as Debug-level debugger logs     GHC.pushLogHook $ const $ \_ _ _ sdoc ->-      logWith l Logger.Debug $ LogSDoc dflags sdoc+      l <& DebuggerLog Logger.Debug (LogSDoc dflags sdoc)    -- Make the target   dvcT <- liftIO $ makeInMemoryHsDebuggerViewTarget modName modContents@@ -394,7 +550,7 @@    -- Restore logger   GHC.modifyLogger $-    GHC.pushLogHook (const $ putLogMsg restore_logger)+    GHC.pushLogHook (const $ GHC.putLogMsg restore_logger)     return result@@ -426,6 +582,7 @@         | UnitNode _deps uid <- mg_mss mod_graph         , "haskell-debugger-view" `L.isPrefixOf` unitIdString uid             || "hskll-dbggr-vw" `L.isPrefixOf` unitIdString uid+            || "haskell-debug_" `L.isPrefixOf` unitIdString uid         ]        -- If the haskell-debugger-view is in the dependency graph, it must have@@ -451,68 +608,16 @@       error "Multiple unit-ids found for haskell-debugger-view in the transitive closure?!"  ----------------------------------------------------------------------------------- Variable references------------------------------------------------------------------------------------- | Find a variable's associated Term and Name by reference ('Int')-lookupVarByReference :: Int -> Debugger (Maybe TermKey)-lookupVarByReference i = do-  ioref <- asks varReferences-  (rm, _) <- readIORef ioref & liftIO-  return $ IM.lookup i rm---- | Finds or creates an integer var reference for the given 'TermKey'.--- TODO: Arguably, this mapping should be part of the debug-adapter, and--- haskell-debugger should deal in 'TermKey' terms only.-getVarReference :: TermKey -> Debugger Int-getVarReference key = do-  ioref     <- asks varReferences-  (rm, tkm) <- readIORef ioref & liftIO-  (i, tkm') <- case lookupTermKeyMap key tkm of-    Nothing -> do-      new_i <- freshInt-      return (new_i, insertTermKeyMap key new_i tkm)-    Just existing_i ->-      return (existing_i, tkm)-  let rm' = IM.insert i key rm-  writeIORef ioref (rm', tkm') & liftIO-  return i---- | 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 = do-  ioref <- asks varReferences-  liftIO $ writeIORef ioref mempty---------------------------------------------------------------------------------- -- Utilities -------------------------------------------------------------------------------- --- | Generate a new unique 'Int'-freshInt :: Debugger Int-freshInt = do-  ioref <- asks genUniq-  i <- readIORef ioref & liftIO-  let !i' = i+1-  writeIORef ioref i'  & liftIO-  return i- -- | Initialize a 'DebuggerState'-initialDebuggerState :: Recorder (WithSeverity DebuggerMonadLog) -> Maybe UnitId -> GHC.Ghc DebuggerState+initialDebuggerState :: LogAction Debugger DebuggerLog -> Maybe UnitId -> GHC.Ghc DebuggerState initialDebuggerState l hsDbgViewUid =   DebuggerState <$> liftIO (newIORef BM.empty)-                <*> liftIO (newIORef mempty)                 <*> liftIO (newIORef emptyRuntimeInstancesCache)                 <*> liftIO (newIORef TM.emptyThreadMap)                 <*> liftIO (newIORef emptyCompCache)-                <*> liftIO (newIORef 0)                 <*> pure hsDbgViewUid                 <*> pure l @@ -520,8 +625,6 @@ liftGhc :: GHC.Ghc a -> Debugger a liftGhc = Debugger . ReaderT . const ---------------------------------------------------------------------------------- data DebuggerFailedToLoad = DebuggerFailedToLoad instance Exception DebuggerFailedToLoad instance Show DebuggerFailedToLoad where@@ -537,6 +640,14 @@     "Cannot use unsupported haskell-debugger-view version found in the transitive closure: " ++ showVersion actual ++     " (supported: " ++ L.intercalate ", " (map showVersion supported) ++ ")" +expectRight :: Exception e => Either e a -> Debugger a+expectRight s = case s of+  Left e -> do+    logSDoc Logger.Error (text $ displayException e)+    liftIO $ throwIO e+  Right a -> do+    pure a+ -------------------------------------------------------------------------------- -- * Modules --------------------------------------------------------------------------------@@ -591,51 +702,40 @@   _              -> do seqTerm hsc_env t  ----------------------------------------------------------------------------------- * Instances-----------------------------------------------------------------------------------instance GHC.HasLogger Debugger where-  getLogger = liftGhc GHC.getLogger--instance GHC.GhcMonad Debugger where-  getSession = liftGhc GHC.getSession-  setSession s = liftGhc $ GHC.setSession s---------------------------------------------------------------------------------- -- * Logging -------------------------------------------------------------------------------- --- | The logger action used to log GHC output-debuggerLoggerAction :: Handle -> GHC.LogAction-debuggerLoggerAction h a b c d = do-  hSetEncoding h utf8 -- GHC output uses utf8-  -- potentially use the `Recorder` here?-  defaultLogActionWithHandles h h a b c d+-- | A debugger log. May include debuggee ouput.+data DebuggerLog+  = DebuggerLog !Logger.Severity !DebuggerMessage+  | GHCLog !GHC.LogFlags !MessageClass !SrcSpan !SDoc+  | LogDebuggeeOut !Text+  | LogDebuggeeErr !Text -data DebuggerMonadLog-  = LogFailedToCompileDebugViewModule GHC.ModuleName-  | LogSkippingViewModuleNoPkg GHC.ModuleName String [String]-  | LogSDoc DynFlags SDoc+-- | A debugger log message+data DebuggerMessage+  = LogSDoc !DynFlags !SDoc+  | LogFailedToCompileDebugViewModule !GHC.ModuleName+  | LogSkippingViewModuleNoPkg !GHC.ModuleName String [String] -instance Pretty DebuggerMonadLog where-  pretty = \ case+instance Show DebuggerMessage where+  show = \ case     LogFailedToCompileDebugViewModule mn ->-      pretty $ "Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views."+      "Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views."     LogSkippingViewModuleNoPkg mn pkg uids ->-      pretty $ "Skipping compilation of built-in " ++ moduleNameString mn ++ " module because package "-                ++ show pkg ++ " wasn't found in dependencies " ++ show uids-    LogSDoc dflags doc ->-      pretty $ showSDoc dflags doc+      "Skipping compilation of built-in " ++ moduleNameString mn ++ " module because package "+          ++ show pkg ++ " wasn't found in dependencies " ++ show uids+    LogSDoc dflags doc -> showSDoc dflags doc  logSDoc :: Logger.Severity -> SDoc -> Debugger () logSDoc sev doc = do   dflags <- getDynFlags   l <- asks dbgLogger-  logWith l sev (LogSDoc dflags doc)+  l <& DebuggerLog sev (LogSDoc dflags doc) -logAction :: Recorder (WithSeverity DebuggerMonadLog) -> DynFlags -> GHC.LogAction-logAction l dflags = \_ msg_class _ sdoc -> do-    logWith l (msgClassSeverity msg_class) $ LogSDoc dflags sdoc+ghcLogAction :: LogAction IO DebuggerLog -> GHC.LogAction+ghcLogAction l = \logflags mclass srcSpan sdoc -> do+    liftLogIO l <& GHCLog logflags mclass srcSpan sdoc  msgClassSeverity :: MessageClass -> Logger.Severity msgClassSeverity = \case@@ -644,10 +744,6 @@   MCInteractive -> Info   MCDump -> Debug   MCInfo -> Info-  MCDiagnostic sev _ _ -> ghcSevSeverity sev--ghcSevSeverity :: GHC.Severity -> Logger.Severity-ghcSevSeverity = \case-  SevIgnore -> Debug -- ?-  SevWarning -> Logger.Warning-  SevError -> Logger.Error+  MCDiagnostic SevIgnore _ _ -> Debug -- ?+  MCDiagnostic SevWarning _ _ -> Logger.Warning+  MCDiagnostic SevError _ _ -> Logger.Error

@@ -20,7 +20,6 @@ import Data.Maybe import System.FilePath import System.Directory-import qualified Prettyprinter as Pretty  import GHC import GHC.Builtin.Names (gHC_INTERNAL_GHCI_HELPERS)@@ -33,7 +32,6 @@ import qualified GHC.Unit.Module.ModSummary as GHC 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 qualified GHC.Data.Strict as Strict @@ -41,24 +39,17 @@ import GHC.Debugger.Monad import GHC.Debugger.Utils import GHC.Debugger.Interface.Messages-import GHC.Debugger.Logger as Logger+import Colog.Core as Logger import qualified GHC.Debugger.Breakpoint.Map as BM import GHC.Debugger.Runtime.Thread -data EvalLog-  = LogEvalModule GHC.Module--instance Pretty EvalLog where-  pretty = \ case-    LogEvalModule modl -> "Eval Module Context:" Pretty.<+> pretty (GHC.showSDocUnsafe (ppr modl))- -------------------------------------------------------------------------------- -- * Evaluation --------------------------------------------------------------------------------  -- | Run a program with debugging enabled-debugExecution :: Recorder (WithSeverity EvalLog) -> FilePath -> EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult-debugExecution recorder entryFile entry args = do+debugExecution :: FilePath -> EntryPoint -> [String] {-^ Args -} -> Debugger EvalResult+debugExecution entryFile entry 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 <- findUnitIdOfEntryFile entryFile@@ -69,7 +60,7 @@     evalModule = mkModule (RealUnit (Definite unitIdOfEntryFile))                                          (moduleName modOfEntryFile) -  logWith recorder Info $ LogEvalModule evalModule+  logSDoc Logger.Debug $ "Eval Module Context:" <+> ppr evalModule   old_context <- GHC.getContext   GHC.setContext [GHC.IIModule evalModule] @@ -130,20 +121,17 @@ -- | Resume execution of the stopped debuggee program doContinue :: Debugger EvalResult doContinue = do-  leaveSuspendedState   GHC.resumeExec RunToCompletion Nothing     >>= handleExecResult  -- | Resume execution but only take a single step. doSingleStep :: Debugger EvalResult doSingleStep = do-  leaveSuspendedState   GHC.resumeExec SingleStep Nothing     >>= handleExecResult  doStepOut :: Debugger EvalResult doStepOut = do-  leaveSuspendedState   mb_span <- getCurrentBreakSpan   case mb_span of     Nothing ->@@ -164,7 +152,6 @@ -- this enclosing span. doLocalStep :: Debugger EvalResult doLocalStep = do-  leaveSuspendedState   mb_span <- getCurrentBreakSpan   case mb_span of     Nothing -> error "not stopped at a breakpoint?!"

@@ -2,11 +2,9 @@ module GHC.Debugger.Runtime where  import Control.Monad.Reader-import qualified Data.List as L  import GHC import GHC.Utils.Outputable-import GHC.Types.FieldLabel import GHC.Runtime.Eval import GHC.Runtime.Heap.Inspect @@ -27,12 +25,9 @@      FromPath k pf -> do        term <- obtainTerm k        liftIO $ expandTerm hsc_env $ case term of-         Term{dc=Right dc, subTerms} -> case pf of+         Term{dc=Right _, subTerms} -> case pf of            PositionalIndex ix -> subTerms !! (ix-1)-           LabeledField fl    ->-             case L.findIndex (== fl) (map flSelector $ dataConFieldLabels dc) of-               Just ix -> subTerms !! ix-               Nothing -> error "Couldn't find labeled field in dataConFieldLabels"+           LabeledField n _ -> subTerms !! (n-1)          NewtypeWrap{wrapped_term} ->            wrapped_term -- regardless of PathFragment          RefWrap{wrapped_term} ->@@ -58,4 +53,3 @@     return term{wrapped_term=wt'}   Suspension{val, ty} -> cvObtainTerm hsc_env defaultDepth False ty val   Prim{} -> return term-

@@ -20,9 +20,7 @@ import GHC  import GHC.Debugger.Monad-import GHC.Debugger.Utils import GHC.Debugger.Runtime.Compile.Cache-import GHC.Debugger.Logger as Logger  -- | Compile and load a fully qualified external variable, potentially applied -- to a few type arguments (i.e. by specializing it). E.g. @"GHC.Base" "pure" ["IO"]@@ -57,7 +55,7 @@    case lookupCompRaw raw_expr compCacheVal of     Just fhv -> do-      logSDoc Logger.Debug (text "Cache hit! on" <+> text raw_expr)+      -- logSDoc Logger.Debug (text "Cache hit! on" <+> text raw_expr)       return fhv     Nothing  -> do       fhv <- compileExprRemote raw_expr

@@ -2,38 +2,45 @@  -- | Higher-level interface to evaluating things in the (possibly remote) debuggee process module GHC.Debugger.Runtime.Eval-  ( evalExpr+  (+    -- * Raw evaluation+    evalExpr, evalString++    -- ** Error handling   , handleSingStatus   , BadEvalStatus(..)++    -- ** Re-exports+  , EvalExpr(..)   ) where  import GHC-import GHC.Runtime.Interpreter as Interp import GHCi.RemoteTypes import GHCi.Message import Control.Exception import GHC.Driver.Env import GHC.Driver.Config import Control.Monad.IO.Class+import qualified GHC.Runtime.Interpreter as Interp -import GHC.Debugger.Utils import GHC.Debugger.Monad-import GHC.Debugger.Logger as Logger  -- * Evaluating things on debuggee ---------------------------------------------  -- | Evaluate a raw 'EvalExpr' which represents a debuggee expression of type @IO [a]@ evalExpr :: EvalExpr ForeignHValue -> Debugger (Either BadEvalStatus [ForeignHValue]) evalExpr eval_expr = do-  logSDoc Logger.Debug (text "evalExpr:" <+> (text (show (mkUnit eval_expr))))   hsc_env <- getSession   let eval_opts = initEvalOpts (hsc_dflags hsc_env) EvalStepNone   handleMultiStatus <$>-    liftIO (evalStmt (hscInterp hsc_env) eval_opts eval_expr)-  where-    mkUnit :: EvalExpr a -> EvalExpr ()-    mkUnit EvalThis{} = EvalThis ()-    mkUnit (EvalApp a b) = mkUnit a `EvalApp` mkUnit b+    liftIO (Interp.evalStmt (hscInterp hsc_env) eval_opts eval_expr)++-- | Evaluate a foreign value of type @IO String@ to a @String@+evalString :: ForeignRef (IO String) -> Debugger String+evalString string_fhv = do+  hsc_env <- getSession+  liftIO $+    Interp.evalString (hscInterp hsc_env) (castForeignRef string_fhv)  -- ** Handling evaluation results ---------------------------------------------- 

@@ -29,16 +29,12 @@ import Control.Monad.Except import GHC.Exts import GHC-import GHC.Driver.Env-import GHC.Runtime.Interpreter as Interp hiding (evalIO, evalString)-import qualified GHC.Runtime.Interpreter as Interp import Control.Monad.Reader import GHCi.RemoteTypes -import GHC.Debugger.Logger as Logger import GHC.Debugger.Monad-import GHC.Debugger.Utils-import GHC.Debugger.Runtime.Eval as Raw+import GHC.Debugger.Runtime.Eval (handleSingStatus, BadEvalStatus(..), EvalExpr(..))+import qualified GHC.Debugger.Runtime.Eval as Raw import GHC.Debugger.Runtime.Compile  --------------------------------------------------------------------------------@@ -181,8 +177,6 @@ -} evalIOList :: RemoteExpr (IO [a]) -> Debugger (Either BadEvalStatus [ForeignRef a]) evalIOList expr = runExceptT $ do-  lift $ logSDoc Logger.Debug (text "evalIOList" <+> text (show expr))-   res_fv <- debuggeeEval expr    r <- lift $ Raw.evalExpr (EvalThis (castForeignRef res_fv))@@ -191,10 +185,8 @@ -- | Execute an @IO String@ on the remote process and serialize the string back to the debugger. evalIOString :: RemoteExpr (IO String) -> Debugger (Either BadEvalStatus String) evalIOString expr = runExceptT $ do-  lift $ logSDoc Logger.Debug (text "evalIOString" <+> text (show expr))   res_fv <- debuggeeEval expr-  hsc_env <- lift getSession-  liftIO (Interp.evalString (hscInterp hsc_env) (castForeignRef res_fv))+  lift $ Raw.evalString res_fv  -------------------------------------------------------------------------------- -- ** Recursive evaluation of 'RemoteExpr' (lower-level)

@@ -19,12 +19,14 @@ import Data.Word import Foreign.C.String import GHC.Conc.Sync+import GHC.InfoProv import GHC.Unit.Module import GHC.Stack.CloneStack import GHC.Exts.Heap import GHC.Exts.Heap.Closures import GHC.Debugger.Runtime.Eval.RemoteExpr (RemoteExpr) import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote+import GHC.Stack.Annotation.Experimental  -- | Remote 'GHC.Stack.CloneStack.cloneThreadStack' cloneThreadStack :: RemoteExpr ThreadId -> RemoteExpr (IO StackSnapshot)@@ -42,6 +44,10 @@ ssc_stack :: RemoteExpr StgStackClosure -> RemoteExpr [StackFrame] ssc_stack = Remote.app $ Remote.var (mkModuleName "GHC.Exts.Heap.Closures") "ssc_stack" [] +-- | Remote 'GHC.Internal.Stack.Decode.decodeStackWithIpe"+decodeStackWithIpe :: RemoteExpr StackSnapshot -> RemoteExpr (IO [(StackFrame, Maybe InfoProv)])+decodeStackWithIpe = Remote.app $ Remote.var (mkModuleName "GHC.Internal.Stack.Decode") "decodeStackWithIpe" []+ -- | Remote 'GHC.Exts.Heap.getClosureData' getClosureData :: RemoteExpr StgStackClosure -> RemoteExpr (IO Closure) getClosureData = Remote.app $ Remote.var (mkModuleName "GHC.Exts.Heap") "getClosureData" ["GHC.Exts.LiftedRep", "_"]@@ -80,3 +86,7 @@ f `compose` g = Remote.app (Remote.app composeVar f) g where   composeVar :: RemoteExpr ((b -> c) -> (a -> b) -> (a -> c))   composeVar = Remote.var (mkModuleName "GHC.Base") "." []++displayStackAnnotation :: RemoteExpr SomeStackAnnotation -> RemoteExpr String+displayStackAnnotation = Remote.app $+  Remote.var (mkModuleName "GHC.Stack.Annotation.Experimental") "displayStackAnnotation" ["SomeStackAnnotation"]

@@ -10,7 +10,7 @@ import Control.Monad.Reader  import GHC.Debugger.Monad-import GHC.Debugger.Logger as Logger+import Colog.Core as Logger import GHC.Debugger.Runtime.Instances.Discover import GHC.Debugger.Runtime.Term.Parser 

@@ -42,7 +42,7 @@  import GHC.Debugger.Monad import GHC.Debugger.Session.Builtin-import GHC.Debugger.Logger as Logger+import Colog.Core as Logger  -------------------------------------------------------------------------------- -- * The Cache-level interface for runtime 'DebugView' instances

@@ -1,35 +0,0 @@-{-# LANGUAGE GADTs, DataKinds #-}-module GHC.Debugger.Runtime.Term.Cache where--import GHC.Types.Var.Env--import GHC.Debugger.Runtime.Term.Key--import Data.Map (Map)-import qualified Data.Map as M------------------------------------------------------------------------------------- * TermKeyMap------------------------------------------------------------------------------------- | Mapping from 'TermKey' to @a@. Backs 'TermCache', but is more general.-type TermKeyMap a = IdEnv (Map [PathFragment True] a)---- | Lookup a 'TermKey' in a 'TermKeyMap'.-lookupTermKeyMap :: TermKey -> TermKeyMap a -> Maybe a-lookupTermKeyMap key tc = do-  let (i, path) = unconsTermKey key-  path_map <- lookupVarEnv tc i-  M.lookup path path_map---- | Inserts a 'Term' for the given 'TermKey' in the 'TermKeyMap'.------ Overwrites existing values.-insertTermKeyMap :: TermKey -> a -> TermKeyMap a -> TermKeyMap a-insertTermKeyMap key term tc =-  let-    (i, path) = unconsTermKey key-    new_map = case lookupVarEnv tc i of-      Nothing           -> M.singleton path term-      Just existing_map -> M.insert path term existing_map-  in extendVarEnv tc i new_map

@@ -27,10 +27,9 @@   -- | A positional index is an index from 1 to inf   PositionalIndex :: Int -> PathFragment b   -- | A labeled field indexes a datacon fields by name-  LabeledField    :: Name -> PathFragment b-  -- | Similar to LabeledField, but originates from a custom 'DebugView'-  -- instance rather than a proper data con label (hence why we don't have a name).-  CustomField     :: String -> PathFragment True+  -- The position is given by the 'Int'+  -- The name is cosmetic.+  LabeledField    :: Int -> Name -> PathFragment b deriving instance Eq (PathFragment b) deriving instance Ord (PathFragment b) @@ -41,14 +40,5 @@  instance Outputable (PathFragment b) where   ppr (PositionalIndex i) = text "_" <> ppr i-  ppr (LabeledField n)    = ppr n-  ppr (CustomField s)     = text s+  ppr (LabeledField _ n)    = ppr n --- | >>> unconsTermKey (FromPath (FromPath (FromId hi) (Pos 1)) (Pos 2))--- (hi, [1, 2])-unconsTermKey :: TermKey -> (Id, [PathFragment True])-unconsTermKey = go [] where-  go acc (FromId i)                       = (i, reverse acc)-  go acc (FromPath k (PositionalIndex i)) = go (PositionalIndex i:acc) k-  go acc (FromPath k (LabeledField n))    = go (LabeledField n:acc) k-  go acc (FromCustomTerm k s _)           = go (CustomField s:acc) k

@@ -16,14 +16,13 @@ import GHC.Runtime.Interpreter as Interp import GHC.Types.Name (nameOccName) import GHC.Types.Name.Occurrence (occNameString)-import qualified GHC.Debugger.Logger as Logger+import qualified Colog.Core as Logger import GHC.Utils.Outputable (text, (<+>), ppr) import Control.Monad.Reader import GHC.Core.TyCo.Compare import GHC.Stack  import GHC.Debugger.Monad-import GHC.Debugger.Utils (expectRight)  import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import qualified GHC.Debugger.Runtime.Compile as Comp@@ -162,7 +161,7 @@   case t of     Term{subTerms}       | idx < length subTerms -> do-          liftDebugger $ logSDoc Logger.Debug (ppr subTerms)+          -- liftDebugger $ logSDoc Logger.Debug (ppr subTerms)           focus (pure (subTerms !! idx)) refreshTerm       | otherwise -> parseError (TermParseError $ "missing subterm index " <> show idx)     other -> parseError (TermParseError $ "expected Term with subterms, got " <> termTag other)@@ -224,11 +223,11 @@ isSuspension :: TermParser Bool isSuspension = focus refreshTerm $ do   t <- anyTerm-  traceTerm+  -- traceTerm   case t of     Suspension{} -> pure True-    other -> do-      liftDebugger $ logSDoc Logger.Debug (text $ termTag other)+    _other -> do+      -- liftDebugger $ logSDoc Logger.Debug (text $ termTag other)       return False  -- | Obtain a Term from a ForeignHValue

@@ -30,8 +30,7 @@ import GHCi.Message import GHCi.RemoteTypes -import GHC.Debugger.Utils-import GHC.Debugger.Logger as Logger+import Colog.Core as Logger import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages import GHC.Debugger.Runtime.Term.Parser

@@ -1,5 +1,6 @@ {-# LANGUAGE OrPatterns #-} {-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultilineStrings #-} {-# LANGUAGE QualifiedDo #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE LambdaCase #-}@@ -7,23 +8,24 @@  -- | Decoding the stack of a thread at runtime module GHC.Debugger.Runtime.Thread.Stack-  ( getRemoteThreadStackCopy-  , getRemoteThreadIPEStack+  ( StackFrameInfo(..)+  , getRemoteThreadStackCopy   ) where  import Data.Bits import Data.Maybe-import Control.Applicative import Control.Concurrent+import Control.Applicative import Control.Monad import Control.Monad.IO.Class-import GHC.Stack.CloneStack import GHC.Exts.Heap.ClosureTypes import GHC.Utils.Encoding.UTF8+import GHC.InfoProv  import GHC import GHC.Builtin.Types import GHC.Runtime.Heap.Inspect+import qualified GHC.Stack.Types as Stack  import GHC.Driver.Env import GHC.Runtime.Interpreter as Interp@@ -32,22 +34,34 @@ import GHCi.Message import GHCi.RemoteTypes -import GHC.Debugger.Utils-import GHC.Debugger.Logger as Logger+import Colog.Core as Logger import GHC.Debugger.Monad import GHC.Debugger.Runtime.Term.Parser import GHC.Debugger.Runtime.Eval import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote import qualified GHC.Debugger.Runtime.Eval.RemoteExpr.Builtin as Remote +--------------------------------------------------------------------------------+-- * Thread stack frames+--------------------------------------------------------------------------------++-- | Information about a stack frame+data StackFrameInfo+  -- | Information derived from an IPE entry+  = StackFrameIPEInfo !InfoProv+  -- | User-defined Stack Frame annotation+  | StackFrameAnnotation !(Maybe Stack.SrcLoc) !String+  -- | Information derived from a continuation BCO breakpoint info.+  | StackFrameBreakpointInfo !InternalBreakpointId+ -- | Clone the stack of the given remote thread and get the breakpoint ids of available frames-getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger [InternalBreakpointId]+getRemoteThreadStackCopy :: ForeignRef ThreadId -> Debugger [StackFrameInfo] getRemoteThreadStackCopy threadIdRef = do    l <- Remote.evalIOList $ Remote.do     clonedStack <- Remote.cloneThreadStack (Remote.ref threadIdRef)-    frames      <- Remote.decodeStack      clonedStack-    Remote.return (Remote.ssc_stack frames)+    frames      <- Remote.decodeStackWithIpe clonedStack+    Remote.return frames    case l of     Left (EvalRaisedException e) -> do@@ -56,73 +70,87 @@     Left e -> do       logSDoc Logger.Warning (text "Failed to decode the stack with" <+> text (show e) $$ text "No StackTrace will be returned...")       return []-    Right stack_frames_fvs -> fmap (catMaybes . catMaybes) $-      forM stack_frames_fvs $ \stack_frame_fv ->+    Right stack_frames_fvs -> fmap catMaybes $+      forM stack_frames_fvs $ \ stack_frame_fv -> do         obtainParsedTerm "ghc-heap:StackFrame" 2 True anyTy{-todo:stackframety?-} (castForeignRef stack_frame_fv)-          ((Just <$> retBCOParser) <|> pure Nothing) >>= \case+          stackFrameInfoParser >>= \case             Left errs -> do               logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))               return Nothing             Right tm ->               return tm --- | Try to get an IPE stacktrace.------ At the moment, we assume IPE stacktraces are always empty @[]@ for threads--- with interpreter frames.------ Really, as long as there is IPE information, this function should return--- StackEntries for all frames, including the interpreter ones, since these are--- typically be interleaved with "normal" frames.----getRemoteThreadIPEStack :: ForeignRef ThreadId -> Debugger [StackEntry]-getRemoteThreadIPEStack threadIdRef = do-  l <- Remote.evalIOList $ Remote.do-    clonedStack <- Remote.cloneThreadStack (Remote.ref threadIdRef)-    Remote.decode clonedStack-  case l of-    Left (EvalRaisedException e) -> do-      logSDoc Logger.Info (text "Failed to decode the stack with" <+> text (show e) $$ text "This is likely bug #26640 in the decoder, which has been fixed for 9.14.2 and forward. No StackTrace could be produced...")-      return []-    Left e -> do-      logSDoc Logger.Warning (text "Failed to decode the stack with" <+> text (show e) $$ text "No StackTrace will be returned...")-      return []-    Right entries_fvs -> do-      mapM (\entry_fv -> do-          stack_entry <- obtainParsedTerm "StackEntry" 2 True anyTy{-stackentry, but we won't look at the ty...-} entry_fv stackEntryParser-          case stack_entry of-            Left errs -> do-              logSDoc Logger.Error (vcat (map (text . getTermErrorMessage) errs))-              liftIO $ fail "Failed to parse @StackEntry@ from decoding thread stack!"-            Right se ->-              pure se-        ) (map castForeignRef entries_fvs)- -------------------------------------------------------------------------------- -- ** Decoding Stack Frames ---------------------------------------------------- -------------------------------------------------------------------------------- -stackEntryParser :: TermParser StackEntry-stackEntryParser = do-    StackEntry <$> subtermWith 0 stringParser <*> subtermWith 1 stringParser <*> subtermWith 2 stringParser <*> pure INVALID_OBJECT{-this is a stub-}+-- | Try to decode a 'StackFrameInfo' from a @(StackFrame, Maybe InfoProv)@ term+stackFrameInfoParser :: TermParser (Maybe StackFrameInfo)+stackFrameInfoParser = do+  -- Try a stack annotation first+  stackAnno <- subtermWith 0 stackAnnoParser+  case stackAnno of+    Nothing -> do+      -- Try IPE next+      mipe <- subtermWith 1 (maybeParser infoProvParser)+      case mipe of+        Nothing -> do+          -- Try decoding a continuation BCO with a breakpoint next+          fmap StackFrameBreakpointInfo+            <$> subtermWith 0 retBCOParser+        Just ipe -> pure $+          Just (StackFrameIPEInfo ipe)+    Just (srcLoc, ann) -> pure $+      Just (StackFrameAnnotation srcLoc ann) +-- | Decode an 'InfoProv' from an @InfoProv@ term+infoProvParser :: TermParser InfoProv+infoProvParser = InfoProv+  <$> subtermWith 0 stringParser -- ipName+  <*> pure INVALID_OBJECT -- ipDesc (this is a stub)+  <*> subtermWith 2 stringParser -- ipTyDesc+  <*> subtermWith 3 stringParser -- ipLabel+  <*> subtermWith 4 stringParser -- ipUnitId+  <*> subtermWith 5 stringParser -- ipMod+  <*> subtermWith 6 stringParser -- ipSrcFile+  <*> subtermWith 7 stringParser -- ipSrcSpan++-- | Try to decode an 'InternalBreakpointId' from a @StackFrame@ term retBCOParser :: TermParser (Maybe InternalBreakpointId) retBCOParser = do   -- Match against "RetBCO" frames and extract the BCOClosure information-  Suspension{val, ctype=BCO}-    {-"the otherwise case: Unknown closure", hence Suspension-}-      <- matchConstructorTerm "RetBCO" *> subtermWith 1 (subtermWith 0{-take from Box-} anyTerm)-  liftDebugger $ do+  (matchConstructorTerm "RetBCO" *> subtermWith 1 (subtermWith 0{-take from Box-} (Just <$> anyTerm)) <|> pure Nothing)+    >>= \case+      Just Suspension{val, ctype=BCO} -> do+        {-"the otherwise case: Unknown closure", hence Suspension-} -    -- Decode the BCO closure using 'getClosureData' on the foreign heap-    bco_closure_fv <- expectRight =<< Remote.evalIO-      (Remote.getClosureData (Remote.ref (castForeignRef val)))+        -- Decode the BCO closure using 'getClosureData' on the foreign heap+        bco_closure_fv <- liftDebugger $+          expectRight =<< Remote.evalIO+            (Remote.getClosureData (Remote.ref (castForeignRef val))) -    r <- obtainParsedTerm "BCO BRK_FUN info" 2 True anyTy (castForeignRef bco_closure_fv) bcoInternalBreakpointId-    case r of-      Left err -> liftIO $ fail (show err)-      Right t  -> return t+        r <- liftDebugger $+          obtainParsedTerm "BCO BRK_FUN info" 2 True anyTy (castForeignRef bco_closure_fv) bcoInternalBreakpointId+        case r of+          Left err -> fail (show err)+          Right t  -> return t+      _ -> pure Nothing +-- | Try to decode an 'StackAnnotation' from a @StackFrame@ term+stackAnnoParser :: TermParser (Maybe (Maybe Stack.SrcLoc, String))+stackAnnoParser = do+  -- Match against "AnnFrame" frames and extract the 'SomeStackAnnotation'+  (matchConstructorTerm "AnnFrame" *> subtermWith 1 (subtermWith 0{-take from Box-} (Just <$> anyTerm)) <|> pure Nothing)+    >>= \case+      Just Term{val} -> do+        stack_anno <- liftDebugger $+          expectRight =<< Remote.evalString+            (Remote.displayStackAnnotation (Remote.ref (castForeignRef val)))++        pure $ Just (Nothing {- No source locations yet :( -}, stack_anno)+      _ ->+        pure Nothing+ -- | Parse an 'InternalBreakpointId' out of a 'BCOClosure' term. bcoInternalBreakpointId :: TermParser (Maybe InternalBreakpointId) bcoInternalBreakpointId = do@@ -181,10 +209,10 @@           | otherwise = 0 :: Int      let find_ixs_fv = Remote.raw $-          "\\x -> let index_at n = GHC.Word.W16# (GHC.Base.indexWord16Array# x (n GHC.Exts.+# " ++ show bRK_FUN_offset ++ "#)) " ++-                   "in if (index_at 0# Data.Bits..&. 0xFF) == 66{-bci_BRK_FUN-} then \-                        Just (index_at 1#, index_at 2#, index_at 3#, index_at 4#, index_at 5#) \-                      else Nothing"+          "\\x -> let index_at n = GHC.Word.W16# (GHC.Base.indexWord16Array# x (n GHC.Exts.+# " ++ show bRK_FUN_offset ++ """#))+                    in if (index_at 0# Data.Bits..&. 0xFF) == 66{-bci_BRK_FUN-} then+                        Just (index_at 1#, index_at 2#, index_at 3#, index_at 4#, index_at 5#)+                      else Nothing"""     rs_fv <- expectRight =<< Remote.eval       (find_ixs_fv `Remote.app` Remote.untypedRef instrs_array_fv) 

@@ -7,6 +7,7 @@ module GHC.Debugger.Session (   parseHomeUnitArguments,   setupHomeUnitGraph,+  validateUnitsWays,   TargetDetails(..),   Target(..),   toGhcTarget,@@ -21,6 +22,10 @@   setCacheDirs,   setBytecodeBackend,   enableByteCodeGeneration,+  enableExternalInterpreter,+  enableDynamicDebuggee,+  setPgmI, addOptI,+  setDynFlagWays   )   where @@ -41,6 +46,7 @@ import qualified System.Environment as Env  import qualified GHC+import GHC.Platform.Ways import GHC.Driver.DynFlags as GHC import GHC.Driver.Monad import qualified GHC.Driver.Session as GHC@@ -52,9 +58,11 @@ import qualified GHC.Unit.State                        as State import GHC.Driver.Env import GHC.Types.SrcLoc+import GHC.Settings (ToolSettings(..)) import Language.Haskell.Syntax.Module.Name import qualified Data.Foldable as Foldable import qualified GHC.Unit.Home.Graph as HUG+import qualified Data.Set as Set import Data.Maybe import GHC.Types.Target (InputFileBuffer) @@ -229,6 +237,17 @@       return (L.nubOrdOn targetTarget ctargets)     pure (hscEnv', concat ts) +-- | Find and return the ways in which the home units are built.+-- INVARIANT: All home units are built with the same 'Ways'+validateUnitsWays :: NonEmpty.NonEmpty (DynFlags, [GHC.Target]) -> IO Ways+validateUnitsWays flagsAndTargets = do+    let unitWays  = NonEmpty.map (ways . fst) flagsAndTargets+        firstWays = NonEmpty.head unitWays+        restWays  = NonEmpty.tail unitWays+    if all (== firstWays) restWays+        then return firstWays+        else error "Unexpected: the home units have different ways! Not supported, see GHC#26765"+ data TargetDetails = TargetDetails   { targetTarget :: Target   -- ^ Simplified version of 'TargetId', storing enough information@@ -404,6 +423,47 @@   backend = GHC.interpreterBackend #endif   }++-- | Enable the external interpreter by default unless the user sets+-- @preferInternalInterpreter=True@ (with @--internal-interpreter@)+enableExternalInterpreter :: Bool -> DynFlags -> DynFlags+enableExternalInterpreter preferInternalInterpreter dflags+  | preferInternalInterpreter+  = dflags `GHC.gopt_unset` GHC.Opt_ExternalInterpreter+  | otherwise+  = dflags `GHC.gopt_set` GHC.Opt_ExternalInterpreter++-- | Force -dynamic on the debuggee if the debugger (which is also the external+-- interpreter) was compiled with -dynamic. On Windows the debugger can't be+-- built dynamic, so we won't enable it there.+--+-- See Note [Dynamic Debuggee for dynamic debugger]+enableDynamicDebuggee :: DynFlags -> DynFlags+enableDynamicDebuggee dflags+  | hostIsDynamic+  = addWay' WayDyn dflags+  | otherwise+  = dflags++setPgmI, addOptI :: String -> DynFlags -> DynFlags+setPgmI f = alterToolSettings $ \s -> s { toolSettings_pgm_i = f }+addOptI f = alterToolSettings $ \s -> s { toolSettings_opt_i = f : toolSettings_opt_i s }++alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags+alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) }++setDynFlagWays :: Ways -> DynFlags -> DynFlags+setDynFlagWays ws dyn = Set.foldr addWay' dyn ws++addWay' :: Way -> DynFlags -> DynFlags+addWay' w dflags0 =+   let platform = targetPlatform dflags0+       dflags1 = dflags0 { targetWays_ = addWay w (targetWays_ dflags0) }+       dflags2 = foldr GHC.setGeneralFlag' dflags1+                       (wayGeneralFlags platform w)+       dflags3 = foldr GHC.unSetGeneralFlag' dflags2+                       (wayUnsetGeneralFlags platform w)+   in dflags3  -- ---------------------------------------------------------------------------- -- Utils that we need, but don't want to incur an additional dependency for.

@@ -160,4 +160,3 @@ -- | GHC.Debugger.View.ByteString debuggerViewByteStringContents :: StringBuffer debuggerViewByteStringContents = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs")-

@@ -1,12 +1,12 @@ {-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,    DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,-   TypeApplications, ScopedTypeVariables, BangPatterns #-}+   TypeApplications, ScopedTypeVariables, BangPatterns, MultiWayIf #-} module GHC.Debugger.Stopped where  import Control.Monad import Control.Monad.Reader import Data.IORef-import GHC.Stack.CloneStack as Stack+import qualified Data.List as L  import GHC import GHC.Types.Unique.FM@@ -18,12 +18,13 @@ import GHC.Types.TypeEnv import GHC.Data.Maybe import GHC.Driver.Env as GHC-import GHC.Runtime.Debugger.Breakpoints as GHC import GHC.Runtime.Eval import GHC.Types.SrcLoc+import GHC.InfoProv import GHC.Utils.Outputable as Ppr import qualified GHC.Unit.Home.Graph as HUG +import GHC.Debugger.Stopped.Exception import GHC.Debugger.Stopped.Variables import GHC.Debugger.Runtime import GHC.Debugger.Runtime.Thread@@ -31,8 +32,10 @@ import GHC.Debugger.Runtime.Thread.Map import GHC.Debugger.Monad import GHC.Debugger.Interface.Messages+import qualified GHC.Debugger.Interface.Messages as DbgStackFrame (DbgStackFrame(..)) import GHC.Debugger.Utils-import qualified GHC.Debugger.Logger as Logger+import qualified Colog.Core as Logger+import qualified GHC.Stack.Types as Stack  {- Note [Don't crash if not stopped]@@ -87,6 +90,7 @@       = zipWith _mkDebuggeeThread t_ids t_labels    -- TODO: We ignore _all_threads and report only the main execution thread for now.+  -- See #138 for progress on Multi-threaded debugging.   GHC.getResumeContext >>= \case     [] ->       -- See Note [Don't crash if not stopped]@@ -110,109 +114,126 @@    tm <- liftIO . readIORef =<< asks threadMap   let m_f_tid = lookupThreadMap (remoteThreadIntRef req_tid) tm-  ipe_stack <- case m_f_tid of++  hsc_env <- getSession+  let hug = hsc_HUG hsc_env+  decoded_frames <- catMaybes <$> case m_f_tid of     Nothing -> pure []     Just f_tid -> do-      -- For now, assume that if we can get an IPE backtrace then this thread-      -- is compiled and doesn't have any interpreter frames.-      -- Of course, this isn't true since we should also be able to get an IPE-      -- backtrace for interpreter threads. Just not yet.-      ---      -- If IPE is empty => it's not an interpreter thread => the IPE backtrace-      --  is the best we can do, so just return that.-      getRemoteThreadIPEStack f_tid--  case ipe_stack of-    [] -> do-      _decoded_frames <- case m_f_tid of-        Nothing -> pure []-        Just f_tid -> do-          hsc_env <- getSession-          ibis <- getRemoteThreadStackCopy f_tid-          let hug = hsc_HUG hsc_env-          forM ibis $ \ibi -> do-            info_brks <- liftIO $ readIModBreaks hug ibi-            let modl  = getBreakSourceMod ibi info_brks-            srcSpan   <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks--            -- Find function name-            -- TODO: Cache moduleLineMap?-            ticks <- fromMaybe (error "getStacktrace:getTicks") <$> makeModuleLineMap modl-            let current_toplevel_decl = enclosingTickSpan ticks srcSpan+      -- Try decoding a stack with interpreter continuation frames (RetBCOs)+      -- and use the BRK_FUN src locations.+      stack_frames <- getRemoteThreadStackCopy f_tid+      forM stack_frames $ \case+        StackFrameBreakpointInfo ibi -> do+          info_brks <- liftIO $ readIModBreaks hug ibi+          let modl  = getBreakSourceMod ibi info_brks+          srcSpan   <- liftIO $ getBreakLoc (readIModModBreaks hug) ibi info_brks+          decl <- liftIO $ L.intercalate "." <$> getBreakDecls (readIModModBreaks hug) ibi info_brks -            modl_str  <- display modl-            return DbgStackFrame-              { name = modl_str ++ "." -- ++ Stack.functionName stack_entry-              , sourceSpan = realSrcSpanToSourceSpan $ current_toplevel_decl -- realSrcSpan srcSpan+          modl_str  <- display modl+          return $ Just DbgStackFrame+            { name = modl_str ++ "." ++ decl+            , sourceSpan = realSrcSpanToSourceSpan $ realSrcSpan srcSpan+            , breakId = Just ibi+            }+        StackFrameIPEInfo ipe -> do+          case srcSpanStringToSourceSpan (ipLoc ipe) of+            Left err -> do+              -- Couldn't parse. The srcLoc may be invalid so just keep this as info, not warning.+              logSDoc Logger.Info $+                text "Couldn't parse StackEntry srcLoc \"" Ppr.<> text (ipLoc ipe)+                                                           Ppr.<> text "\":" <+> text err+              return Nothing+            Right sourceSpan ->+              return $ Just DbgStackFrame+                { name = ipMod ipe ++ "." ++ ipLabel ipe+                , sourceSpan = sourceSpan+                , breakId = Nothing+                }+        StackFrameAnnotation srcLoc ann -> do+            return $ Just DbgStackFrame+              { name = ann+              , sourceSpan = maybe unhelpfulSourceSpan srcLocToSourceSpan srcLoc+              , breakId = Nothing               } -      -- Try decoding a stack with interpreter continuation frames (RetBCOs) and use the BRK_FUN src locations.-      -- Add the latest resume context at the head.-      head_frame <- GHC.getResumeContext >>= \case-        [] ->-          -- See Note [Don't crash if not stopped]-          return Nothing-        r:_-          | Just ss <- srcSpanToRealSrcSpan (GHC.resumeSpan r)-          -> do-            r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r)-            if r_tid == req_tid then+  -- Add the latest resume context at the head.+  head_frame <- GHC.getResumeContext >>= \case+    [] ->+      -- See Note [Don't crash if not stopped]+      return Nothing+    r:_ -> do+      let resumeSpanR = GHC.resumeSpan r+          mRealSpan   = realSrcSpanToSourceSpan <$> srcSpanToRealSrcSpan resumeSpanR+          firstSpan   = DbgStackFrame.sourceSpan <$> listToMaybe decoded_frames+      r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r)+      if r_tid /= req_tid then+        return Nothing+      else case GHC.resumeBreakpointId r of+        Just ibi+          | Just ss <- mRealSpan+          , Just ss /= firstSpan -> do               -- We're getting the stacktrace for the thread we're stopped at.+              info_brks <- liftIO $ readIModBreaks hug ibi+              let modl  = getBreakSourceMod ibi info_brks+              modl_str  <- display modl               return $                 Just DbgStackFrame-                  { name = GHC.resumeDecl r-                  , sourceSpan = realSrcSpanToSourceSpan ss+                  { name = modl_str ++ "." ++ GHC.resumeDecl r+                  , sourceSpan = ss+                  , breakId = Just ibi                   }-            else-             return Nothing-          | otherwise ->-              -- No resume span; which should mean we're stopped on an exception.-              -- No info for now.-              return Nothing-      -- TODO: Currently, only display head_frame-      -- return (maybe id (:) head_frame $ decoded_frames)-      return (maybe [] (:[]) head_frame)-    ipe_frames -> catMaybes <$> do-      forM ipe_frames $ \stack_entry -> do-        case srcSpanStringToSourceSpan (Stack.srcLoc stack_entry) of-          Left err -> do-            -- Couldn't parse. The srcLoc may be invalid so just keep this as info, not warning.-            logSDoc Logger.Info $-              text "Couldn't parse StackEntry srcLoc \"" Ppr.<> text (Stack.srcLoc stack_entry)-                                                         Ppr.<> text "\":" <+> text err-            return Nothing-          Right sourceSpan ->-            return $ Just DbgStackFrame-              { name = Stack.moduleName stack_entry ++ "." ++ Stack.functionName stack_entry-              , sourceSpan = sourceSpan-              }+        _ -> do+          mExcSpan <- exceptionSourceSpanFromContext+          case mExcSpan of+            Just sourceSpan ->  return $ Just DbgStackFrame+                                  { name = GHC.resumeDecl r+                                  , sourceSpan+                                  , breakId = Nothing+                                  }+            Nothing -> return Nothing+  return (maybe id (:) head_frame $ decoded_frames) +srcLocToSourceSpan :: Stack.SrcLoc -> SourceSpan+srcLocToSourceSpan srcLoc =+  SourceSpan+    { file = Stack.srcLocFile srcLoc+    , startLine = Stack.srcLocStartLine srcLoc+    , endLine = Stack.srcLocEndLine srcLoc+    , startCol = Stack.srcLocStartCol srcLoc+    , endCol = Stack.srcLocEndCol srcLoc+    }+ -------------------------------------------------------------------------------- -- * Scopes --------------------------------------------------------------------------------  -- | Get the stack frames at the point we're stopped at-getScopes :: Debugger [ScopeInfo]-getScopes = GHC.getCurrentBreakSpan >>= \case-  Nothing ->-    -- See Note [Don't crash if not stopped]-    return []-  Just span'-    | Just rss <- srcSpanToRealSrcSpan span'-    , let sourceSpan = realSrcSpanToSourceSpan rss+getScopes :: RemoteThreadId -> Int -> Debugger [ScopeInfo]+getScopes threadId frameIx = do+  frames <- getStacktrace threadId+  let frame = frames !! frameIx+  let sourceSpan = DbgStackFrame.sourceSpan frame+      localsScope = ScopeInfo+        { kind = LocalVariablesScope+        , expensive = False+        , numVars = Nothing+        , sourceSpan+        }+  if+    | frameIx < length frames+    , Just ibi <- DbgStackFrame.breakId frame     -> do+      hsc_env   <- getSession+      info_brks <- liftIO $ readIModBreaks (hsc_HUG hsc_env) ibi+      let brk_modl = getBreakSourceMod ibi info_brks       -- 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 <- expectJust <$> getCurrentBreakModule-      in_mod <- getTopEnv curr_modl-      imported <- getTopImported curr_modl+      in_mod   <- getTopEnv brk_modl+      imported <- getTopImported brk_modl       return-        [ ScopeInfo { kind = LocalVariablesScope-                    , expensive = False-                    , numVars = Nothing-                    , sourceSpan-                    }+        [ localsScope         , ScopeInfo { kind = ModuleVariablesScope                     , expensive = True                     , numVars = Just (sizeUFM in_mod)@@ -225,10 +246,7 @@                     }         ]     | 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.-      return []+      return [localsScope]  -------------------------------------------------------------------------------- -- * Variables@@ -248,102 +266,93 @@ -- (b) ONLY the variable requested -- (c) The fields of the variable requested but NOT the original variable --- | Get variables using a variable/variables reference+-- | 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@.+-- When the request forces a variable, return 'ForcedVariable'. Otherwise return+-- the resulting variables/fields. -- -- See Note [Variables Requests]-getVariables :: VariableReference -> Debugger (Either VarInfo [VarInfo])-getVariables vk = do+getVariables :: RemoteThreadId -> Int{-stack frame index-} -> VariableReference -> Debugger VariableResult+getVariables threadId frameIx vk = do+  frames <- getStacktrace threadId+  let frame = frames !! frameIx   hsc_env <- getSession-  GHC.getResumeContext >>= \case-    [] ->-      -- See Note [Don't crash if not stopped]-      return (Right [])-    r:_ -> case vk of+  case vk of+    -- Only `seq` the variable when inspecting a specific one (`SpecificVariable`)+    -- (VARR)(b,c)+    SpecificVariable key -> do+      term <- obtainTerm key -      -- Only `seq` the variable when inspecting a specific one (`SpecificVariable`)-      -- (VARR)(b,c)-      SpecificVariable i -> do-        lookupVarByReference i >>= \case-          Nothing -> do-            -- lookupVarByReference failed.-            -- This may happen if, in a race, we change scope while asking for-            -- variables of the previous scope.-            -- Somewhat similar to the race in Note [Don't crash if not stopped]-            return (Right [])-          Just key -> do-            term <- obtainTerm key+      case term of -            case term of+        -- (VARR)(b)+        Suspension{} -> do -              -- (VARR)(b)-              Suspension{} -> do+          -- Original Term was a suspension:+          -- It is a "lazy" DAP variable: our reply can ONLY include+          -- this single variable. -                -- Original Term was a suspension:-                -- It is a "lazy" DAP variable: our reply can ONLY include-                -- this single variable.+          term' <- forceTerm term -                term' <- forceTerm term+          vi <- termToVarInfo key term' -                vi <- termToVarInfo key term'+          return (ForcedVariable vi) -                return (Left vi)+        -- (VARR)(c)+        _ -> do -              -- (VARR)(c)-              _ -> Right <$> do+          -- Original Term was already something other than a Suspension;+          -- Meaning the @SpecificVariable@ request means to inspect the structure.+          -- Return ONLY the fields -                -- Original Term was already something other than a Suspension;-                -- Meaning the @SpecificVariable@ request means to inspect the structure.-                -- Return ONLY the fields+          termVarFields key term >>= \case+            VarFields vfs -> pure (VariableFields vfs) -                termVarFields key term >>= \case-                  VarFields vfs -> return vfs+    -- (VARR)(a) from here onwards -      -- (VARR)(a) from here onwards+    LocalVariables -> fmap VariableFields $ do+      -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r)+      mapM tyThingToVarInfo =<< GHC.getBindings -      LocalVariables -> fmap Right $ do-        -- bindLocalsAtBreakpoint hsc_env (GHC.resumeApStack r) (GHC.resumeSpan r) (GHC.resumeBreakpointId r)-        mapM tyThingToVarInfo =<< GHC.getBindings+    ModuleVariables+      | frameIx < length frames+      , Just ibi <- DbgStackFrame.breakId frame+      -> fmap VariableFields $ do+        curr_modl <- liftIO $ getBreakSourceMod ibi <$>+                      readIModBreaks (hsc_HUG hsc_env) ibi+        things <- typeEnvElts <$> getTopEnv curr_modl+        mapM (\tt -> do+          nameStr <- display (getName tt)+          vi <- tyThingToVarInfo tt+          return vi{varName = nameStr}) things -      ModuleVariables -> Right <$> do-        case GHC.resumeBreakpointId r of-          Nothing -> return []-          Just ibi -> do-            curr_modl <- liftIO $ getBreakSourceMod ibi <$>-                          readIModBreaks (hsc_HUG hsc_env) ibi-            things <- typeEnvElts <$> getTopEnv curr_modl-            mapM (\tt -> do-              nameStr <- display (getName tt)+    GlobalVariables+      | frameIx < length frames+      , Just ibi <- DbgStackFrame.breakId frame+      -> fmap VariableFields $ do+        curr_modl <- liftIO $ getBreakSourceMod ibi <$>+                      readIModBreaks (hsc_HUG hsc_env) ibi+        names <- map greName . globalRdrEnvElts <$> getTopImported curr_modl+        mapM (\n-> do+          nameStr <- display n+          liftIO (GHC.lookupType hsc_env n) >>= \case+            Nothing ->+              return VarInfo+                { varName = nameStr+                , varType = ""+                , varValue = ""+                , isThunk = False+                , varRef = NoVariables+                }+            Just tt -> do               vi <- tyThingToVarInfo tt-              return vi{varName = nameStr}) things+              return vi{varName = nameStr}+          ) names -      GlobalVariables -> Right <$> do-        case GHC.resumeBreakpointId r of-          Nothing -> return []-          Just ibi -> do-            curr_modl <- liftIO $ getBreakSourceMod ibi <$>-                          readIModBreaks (hsc_HUG hsc_env) ibi-            names <- map greName . globalRdrEnvElts <$> getTopImported curr_modl-            mapM (\n-> do-              nameStr <- display n-              liftIO (GHC.lookupType hsc_env n) >>= \case-                Nothing ->-                  return VarInfo-                    { varName = nameStr-                    , varType = ""-                    , varValue = ""-                    , isThunk = False-                    , varRef = NoVariables-                    }-                Just tt -> do-                  vi <- tyThingToVarInfo tt-                  return vi{varName = nameStr}-              ) names+    NoVariables -> pure (VariableFields []) -      NoVariables -> Right <$> do-        return []+    -- Couldn't find ibi or frame+    _otherwise -> pure (VariableFields [])  -------------------------------------------------------------------------------- -- Inspect

@@ -0,0 +1,219 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultilineStrings #-}++-- | Helpers used when the debugger is stopped due to an exception.+-- These helpers execute code on the remote process which teach us information+-- about the exception we are stopped at.+module GHC.Debugger.Stopped.Exception+  ( exceptionSourceSpanFromContext+  , getExceptionInfo+  , fallbackExceptionSourceSpan+  , defaultExceptionInfo+  , currentlyStoppedOnException+  ) where++import Data.Maybe (fromMaybe, isNothing)++import GHC+import GHC.Types.SrcLoc+import GHC.Data.FastString (unpackFS)+import GHC.Utils.Outputable as Ppr++import GHC.Debugger.Monad+import GHC.Debugger.Interface.Messages+  ( SourceSpan(..)+  , ExceptionInfo(..)+  , RemoteThreadId(..)+  )+import qualified Colog.Core as Logger+import GHC.Debugger.Runtime.Thread+import qualified GHC.Debugger.Runtime.Eval.RemoteExpr as Remote+import GHC.Debugger.Runtime.Term.Parser+import GHCi.RemoteTypes (castForeignRef)+import GHC.Builtin.Types (anyTy)++-- | Attempt to obtain a more precise 'SourceSpan' for the exception we stopped+-- on by consulting its context, if available.+exceptionSourceSpanFromContext :: Debugger (Maybe SourceSpan)+exceptionSourceSpanFromContext = do+  GHC.getResumeContext >>= \case+    r:_ | Nothing <- GHC.resumeBreakpointId r -> do+      let excRef = resumeApStack r+      evalRes <- Remote.eval+        (Remote.raw exceptionLocationExpr `Remote.app` Remote.untypedRef excRef)+      case evalRes of+        Left err -> do+          logSDoc Logger.Debug $+            Ppr.text "Failed to evaluate exception context:" Ppr.<+> Ppr.text (show err)+          return Nothing+        Right fhv -> do+          parsed <- obtainParsedTerm "Exception context location" 4 True anyTy (castForeignRef fhv)+            (maybeParser exceptionLocationTupleParser)+          case parsed of+            Left errs -> do+              logSDoc Logger.Debug $+                Ppr.text "Failed to parse exception context location:"+                  Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs)+              return Nothing+            Right Nothing -> return Nothing+            Right (Just (file, srcLine, col)) ->+              return $ Just SourceSpan+                { file = file+                , startLine = srcLine+                , startCol = col+                , endLine = srcLine+                , endCol = col+                }+    _ -> return Nothing++exceptionLocationTupleParser :: TermParser (String, Int, Int)+exceptionLocationTupleParser =+  (,,) <$> subtermWith 0 stringParser+       <*> subtermWith 1 intParser+       <*> subtermWith 2 intParser++-- | This helper looks at the exception context for an exception, and retrieves+-- the last entry of the HasCallStack backtrace.+exceptionLocationExpr :: String+exceptionLocationExpr ="""+  let+    fromCallStack cs = case Data.Maybe.listToMaybe (GHC.Exception.getCallStack cs) of+      Just (_, loc) -> Just ( GHC.Exception.srcLocFile loc+                            , GHC.Exception.srcLocStartLine loc+                            , GHC.Exception.srcLocStartCol loc)+    go exc =+      let ctx = Control.Exception.someExceptionContext exc+          bts :: [Control.Exception.Backtrace.Backtraces]+          bts = Control.Exception.Context.getExceptionAnnotations ctx+      in case bts of+           bt : _ -> case GHC.Internal.Exception.Backtrace.btrHasCallStack bt of+             Just cs -> fromCallStack cs+             Nothing -> Nothing+           [] -> Nothing+  in go+"""++-- | Retrieve structured exception information for the requested thread when+-- the debugger is currently stopped on an exception.+getExceptionInfo :: RemoteThreadId -> Debugger ExceptionInfo+getExceptionInfo req_tid = GHC.getResumeContext >>= \case+  [] -> return defaultExceptionInfo+  r:_ -> do+    r_tid <- getRemoteThreadIdFromRemoteContext (GHC.resumeContext r)+    case (r_tid == req_tid, GHC.resumeBreakpointId r) of+      (True, Nothing) -> do+        let excRef = resumeApStack r+        fromMaybe defaultExceptionInfo <$> exceptionInfoFromContext excRef+      _ -> return defaultExceptionInfo++-- | Evaluate helper code inside the debuggee that turns the exception context+-- into our 'ExceptionInfo' structure.+exceptionInfoFromContext :: ForeignHValue -> Debugger (Maybe ExceptionInfo)+exceptionInfoFromContext excRef = do+  -- 1. Add a "data" declaration for the datatype the expression will return+  _ <- runDecls exceptionInfoData+  -- 2. Gather information about the exception.+  evalRes <- Remote.eval+    (Remote.raw exceptionInfoExpr `Remote.app` Remote.untypedRef excRef)+  case evalRes of+    Left err -> do+      logSDoc Logger.Debug $+        Ppr.text "Failed to evaluate exception info:" Ppr.<+> Ppr.text (show err)+      return Nothing+    Right fhv -> do+      parsed <- obtainParsedTerm "Exception info" 4 True anyTy (castForeignRef fhv)+        exceptionInfoParser+      case parsed of+        Left errs -> do+          logSDoc Logger.Debug $+            Ppr.text "Failed to parse exception info:"+              Ppr.<+> Ppr.vcat (map (Ppr.text . getTermErrorMessage) errs)+          return Nothing+        Right info -> return (Just info)++-- | Parse the helper 'ExceptionInfoNode' structure produced inside the+-- debuggee into our externally facing 'ExceptionInfo'.+exceptionInfoParser :: TermParser ExceptionInfo+exceptionInfoParser = do+  ExceptionInfo+    <$> subtermWith 0 stringParser+    <*> subtermWith 1 stringParser+    <*> subtermWith 2 stringParser+    <*> subtermWith 3 (maybeParser stringParser)+    <*> subtermWith 4 (parseList exceptionInfoParser)++-- | Definition for the helper 'ExceptionInfoNode' data type compiled into the+-- debuggee to aid in transporting nested exception information.+-- We need a specific datatype because ExceptionInfoNode is recursive.+exceptionInfoData :: String+exceptionInfoData =+  "data ExceptionInfoNode = ExceptionInfoNode String String String (Maybe String) [ExceptionInfoNode]"++-- | Helper expression run in the debuggee that walks the exception context and+-- populates the 'ExceptionInfoNode' structure.+exceptionInfoExpr :: String+exceptionInfoExpr = """+  let collectExceptionInfo :: SomeException -> ExceptionInfoNode+      collectExceptionInfo se' =+        case se' of+          SomeException exc ->+            let ctx = Control.Exception.someExceptionContext se'+                rendered = Control.Exception.Context.displayExceptionContext ctx+                whileHandling = Control.Exception.Context.getExceptionAnnotations ctx+                innerNodes = map (collectExceptionInfo . unwrap) whileHandling+                simpleTypeName = Data.Typeable.tyConName tc+                modulePrefix = case Data.Typeable.tyConModule tc of+                  mdl | null mdl -> \"\"+                      | otherwise -> mdl ++ \".\"+                packagePrefix = case Data.Typeable.tyConPackage tc of+                  pkg | null pkg -> \"\"+                      | otherwise -> pkg ++ \":\"+                tc = Data.Typeable.typeRepTyCon (Data.Typeable.typeOf exc)+                fullTypeName = packagePrefix ++ modulePrefix ++ simpleTypeName+                unwrap (Control.Exception.WhileHandling inner) = inner+                contextText = if null rendered then Nothing else Just rendered+            in ExceptionInfoNode+                 simpleTypeName+                 fullTypeName+                 (Control.Exception.displayException se')+                 contextText+                 innerNodes+  in collectExceptionInfo+  """+++-- | When no precise exception location is available, fall back to displaying a+-- label derived from the provided 'SrcSpan'.+fallbackExceptionSourceSpan :: Maybe SrcSpan -> SourceSpan+fallbackExceptionSourceSpan mspan =+  let fileLabel = maybe "<exception>" spanLabel mspan+  in SourceSpan+       { file = fileLabel+       , startLine = 0+       , startCol = 0+       , endLine = 0+       , endCol = 0+       }+  where+    spanLabel (RealSrcSpan rss _) = unpackFS (srcSpanFile rss)+    spanLabel (UnhelpfulSpan reason) = unpackFS (unhelpfulSpanFS reason)++-- | Placeholder exception info returned when the context could not be+-- inspected.+defaultExceptionInfo :: ExceptionInfo+defaultExceptionInfo = ExceptionInfo+  { exceptionInfoTypeName = "Exception"+  , exceptionInfoFullTypeName = "Exception"+  , exceptionInfoMessage = "Exception information not available"+  , exceptionInfoContext = Nothing+  , exceptionInfoInner = []+  }++-- | Determine whether the debugger is currently stopped because of an+-- exception (as opposed to a breakpoint).+currentlyStoppedOnException :: Debugger Bool+currentlyStoppedOnException = do+  resumes <- GHC.getResumeContext+  return $ case resumes of+    [] -> False+    r:_ -> isNothing (GHC.resumeBreakpointId r)

@@ -1,6 +1,7 @@ {-# LANGUAGE CPP, NamedFieldPuns, TupleSections, LambdaCase,    DuplicateRecordFields, RecordWildCards, TupleSections, ViewPatterns,-   TypeApplications, ScopedTypeVariables, BangPatterns, DerivingVia, TypeAbstractions #-}+   TypeApplications, ScopedTypeVariables, BangPatterns, DerivingVia,+   TypeAbstractions, DataKinds #-} module GHC.Debugger.Stopped.Variables where  import Control.Monad.Reader@@ -65,12 +66,14 @@           -- Not a record type,           -- Use indexed fields           [] -> do-            let keys = zipWith (\ix _ -> FromPath top_key (PositionalIndex ix)) [1..] (dataConOrigArgTys dc)+            let keys = zipWith (\ix _ -> FromPath top_key (PositionalIndex ix)) [1..] (dataConRepArgTys dc)             VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys           -- Is a record data con,           -- Use field labels           dataConFields -> do-            let keys = map (FromPath top_key . LabeledField . flSelector) dataConFields+            let mkPath ix Nothing = FromPath top_key (PositionalIndex ix)+                mkPath ix (Just fld) = FromPath top_key (LabeledField ix (flSelector fld))+                keys = zipWith mkPath [1..] ((Nothing <$ dataConOtherTheta dc) ++ (map Just dataConFields))             VarFields <$> mapM (\k -> obtainTerm k >>= termToVarInfo k) keys       NewtypeWrap{dc=Right dc, wrapped_term=_{- don't use directly! go through @obtainTerm@ -}} -> do         case dataConFieldLabels dc of@@ -79,7 +82,7 @@             wvi <- obtainTerm key >>= termToVarInfo key             return (VarFields [wvi])           [fld] -> do-            let key = FromPath top_key (LabeledField (flSelector fld))+            let key = FromPath top_key (LabeledField 1 (flSelector fld))             wvi <- obtainTerm key >>= termToVarInfo key             return (VarFields [wvi])           _ -> error "unexpected number of Newtype fields: larger than 1"@@ -109,7 +112,6 @@   case term0 of     -- The simple case: The term is a a thunk...     Suspension{} -> do-      ir <- getVarReference key       return VarInfo         { varName         , varType@@ -118,7 +120,7 @@             else "_"         , varRef = if isFn             then NoVariables-            else SpecificVariable ir -- allows forcing the thunk+            else SpecificVariable key -- allows forcing the thunk         , isThunk = not isFn         } @@ -150,8 +152,7 @@           varRef <- do             if hasDirectSubTerms term0              then do-                ir <- getVarReference key-                return (SpecificVariable ir)+                return (SpecificVariable key)              else do                 return NoVariables @@ -165,8 +166,7 @@           varRef <-             if varExpandable             then do-                ir <- getVarReference key-                return (SpecificVariable ir)+                return (SpecificVariable key)              else do                 return NoVariables           return VarInfo

@@ -5,11 +5,13 @@   ( module GHC.Debugger.Utils   , module GHC.Utils.Outputable   , module GHC.Utils.Trace+  , showSDoc   ) where +import Control.Monad import Control.Applicative-import Control.Monad.IO.Class import Control.Exception+import System.IO  import GHC import GHC.Data.FastString@@ -18,14 +20,35 @@ import GHC.Utils.Outputable hiding (char) import GHC.Utils.Trace import qualified Data.Text as T+import qualified Data.Text.IO as T  import Data.Attoparsec.Text -import GHC.Debugger.Monad-import GHC.Debugger.Logger as Logger+import Colog.Core as Logger import GHC.Debugger.Interface.Messages  --------------------------------------------------------------------------------+-- * Handle utils+--------------------------------------------------------------------------------++-- | Read output from the given handle and write it to the given+-- log action (forever).+forwardHandleToLogger :: Handle -> LogAction IO T.Text -> IO ()+forwardHandleToLogger read_h logger = do+  forwarding `catch` -- handles read EOF+    \(_e::SomeException) -> do+      -- Cleanly exit on exception+      -- print _e+      return ()+  where+    forwarding = forever $ do+      -- Mask exceptions to avoid being killed between reading+      -- a line and outputting it.+      mask_ $ do+        out_line <- T.hGetLine read_h -- See Note [External interpreter buffering]+        logger <& out_line++-------------------------------------------------------------------------------- -- * GHC Utilities -------------------------------------------------------------------------------- @@ -40,23 +63,11 @@   }  -- | Display an Outputable value as a String-display :: Outputable a => a -> Debugger String+display :: (GhcMonad m, Outputable a) => a -> m String display x = do   dflags <- getDynFlags   return $ showSDoc dflags (ppr x) {-# INLINE display #-}------------------------------------------------------------------------------------- * More utils-----------------------------------------------------------------------------------expectRight :: Exception e => Either e a -> Debugger a-expectRight s = case s of-  Left e -> do-    logSDoc Logger.Error (text $ displayException e)-    liftIO $ throwIO e-  Right a -> do-    pure a  -------------------------------------------------------------------------------- -- * Parsing

@@ -5,12 +5,13 @@ import qualified Data.IntSet as IS import qualified Data.ByteString as BS import qualified Data.Map as Map+import qualified Data.IntMap as IM import qualified Data.Text as T import System.FilePath  import DAP import qualified GHC-import qualified GHC.Debugger.Interface.Messages as D (Command, Response)+import qualified GHC.Debugger.Interface.Messages as D (Command, Response, RemoteThreadId, VariableReference)  type DebugAdaptor = Adaptor DebugAdaptorState Request type DebugAdaptorCont = Adaptor DebugAdaptorState ()@@ -25,8 +26,10 @@ data DebugAdaptorState = DAS       { syncRequests :: MVar D.Command       , syncResponses :: MVar D.Response-      , nextFreshBreakpointId :: !BreakpointId+      , nextFreshId :: !Int       , breakpointMap :: Map.Map GHC.InternalBreakpointId BreakpointSet+      , stackFrameMap :: IM.IntMap StackFrameIx+      , variablesMap  :: IM.IntMap VariablesIx       , entryFile :: FilePath       , entryPoint :: String       , entryArgs :: [String]@@ -42,6 +45,10 @@ type BreakpointId = Int type BreakpointSet = IS.IntSet +data StackFrameIx = StackFrameIx D.RemoteThreadId Int{-stack frame ix-}+  deriving (Eq, Ord)+data VariablesIx = VariablesIx StackFrameIx D.VariableReference+ instance MonadFail DebugAdaptor where   fail a = error a   -- TODO: PROPER ERROR HANDLING with termination, possibly delete this instance@@ -63,3 +70,9 @@      else return (root </> file)   return defaultSource{sourcePath = Just (T.pack fullPath)} +-- | Generate fresh Int identifier.+getFreshId :: DebugAdaptor Int+getFreshId = do+  nid <- nextFreshId <$> getDebugSession+  updateDebugSession $ \s -> s { nextFreshId = nextFreshId s + 1 }+  pure nid

@@ -141,18 +141,11 @@         , DAP.breakpointId = Just bid         }) bids --- | Adds new BreakpointId for a givent StgPoint+-- | Adds new BreakpointId to the debug adapter mapping registerNewBreakpoint :: GHC.InternalBreakpointId -> DebugAdaptor BreakpointId registerNewBreakpoint breakpoint = do-  bkpId <- getFreshBreakpointId+  bkpId <- getFreshId   updateDebugSession $ \das@DAS{..} -> das {breakpointMap = Map.insertWith mappend breakpoint (IS.singleton bkpId) breakpointMap}-  pure bkpId---- | Generate fresh breakpoint Id.-getFreshBreakpointId :: DebugAdaptor BreakpointId-getFreshBreakpointId = do-  bkpId <- nextFreshBreakpointId <$> getDebugSession-  updateDebugSession $ \s -> s { nextFreshBreakpointId = nextFreshBreakpointId s + 1 }   pure bkpId  -- | Get the file from a DAP Source

@@ -4,6 +4,7 @@ import qualified Data.Text as T import qualified Data.Map as M import qualified Data.IntSet as IS+import qualified Data.IntMap as IM  import DAP @@ -36,7 +37,7 @@ -- | Command for evaluation (includes evaluation-on-hover) commandEvaluate :: DebugAdaptor () commandEvaluate = do-  EvaluateArguments {evaluateArgumentsFrameId=_todo, ..} <- getArguments+  EvaluateArguments {evaluateArgumentsFrameId=_todo{-evaluate expression in specific frame-}, ..} <- getArguments    let simpleEvalResp res ty = EvaluateResponse         { evaluateResponseResult             = res@@ -57,11 +58,26 @@     EvalException {resultVal, resultType} ->       sendEvaluateResponse (simpleEvalResp (T.pack resultVal) (T.pack resultType))     EvalCompleted{resultVal, resultType, resultStructureRef} -> do+      varIx <- case resultStructureRef of+        NoVariables     -> pure 0+        LocalVariables  -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"+        ModuleVariables -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"+        GlobalVariables -> error "Impossible! Eval result ref should always be NoVariables or SpecificVariable"+        SpecificVariable _ -> do+          varId <- getFreshId+          updateDebugSession $ \s ->+            s { variablesMap =+                  IM.insert varId+                    (VariablesIx (StackFrameIx (RemoteThreadId (-1)) (-1) {- shouldn't be a problem bc it's not Local/Module/Global vars -}) resultStructureRef)+                    s.variablesMap+              }+          pure varId+       sendEvaluateResponse EvaluateResponse         { evaluateResponseResult             = T.pack resultVal         , evaluateResponseType               = T.pack resultType         , evaluateResponsePresentationHint   = Nothing-        , evaluateResponseVariablesReference = fromEnum resultStructureRef+        , evaluateResponseVariablesReference = varIx         , evaluateResponseNamedVariables     = Nothing         , evaluateResponseIndexedVariables   = Nothing         , evaluateResponseMemoryReference    = Nothing

@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+module Development.Debug.Adapter.ExceptionInfo+  ( commandExceptionInfo+  ) where++import qualified Data.Text as T++import DAP++import Development.Debug.Adapter+import Development.Debug.Adapter.Interface+import qualified GHC.Debugger.Interface.Messages as D++commandExceptionInfo :: DebugAdaptor ()+commandExceptionInfo = do+  ExceptionInfoArguments{..} <- getArguments+  let remoteThread = D.RemoteThreadId exceptionInfoArgumentsThreadId+  D.GotExceptionInfo info <- sendSync (D.GetExceptionInfo remoteThread)+  sendExceptionInfoResponse (toDAPExceptionInfo info)++-- | Convert the debugger's 'ExceptionInfo' into a DAP 'ExceptionInfoResponse'.+toDAPExceptionInfo :: D.ExceptionInfo -> ExceptionInfoResponse+toDAPExceptionInfo info =+  let typeNameStr = exceptionTypeName info+      typeNameText = T.pack typeNameStr+      messageStr = exceptionMessage info+      messageText = T.pack <$> messageStr+  in ExceptionInfoResponse+      { exceptionInfoResponseExceptionId = typeNameText+      , exceptionInfoResponseDescription = messageText+      , exceptionInfoResponseBreakMode = Always+      , exceptionInfoResponseDetails = Just (exceptionInfoToDetails (Just "_exception") info)+      }++exceptionInfoToDetails :: Maybe T.Text -> D.ExceptionInfo -> ExceptionDetails+exceptionInfoToDetails evalName info@D.ExceptionInfo{..} =+  let typeNameText = T.pack (exceptionTypeName info)+      fullTypeNameText = T.pack (exceptionFullTypeName info)+      stackTraceText = T.pack <$> exceptionInfoContext+      innerDetails = map (exceptionInfoToDetails Nothing) exceptionInfoInner+      innerField = if null innerDetails then Nothing else Just innerDetails+  in defaultExceptionDetails+        { exceptionDetailsMessage = exceptionMessage info+        , exceptionDetailstypeName = Just typeNameText+        , exceptionDetailsFullTypeName = Just fullTypeNameText+        , exceptionDetailsStackTrace = stackTraceText+        , exceptionDetailsInnerException = innerField+        , exceptionDetailsEvaluateName = evalName+        }++exceptionTypeName :: D.ExceptionInfo -> String+exceptionTypeName D.ExceptionInfo{..}+  | null exceptionInfoTypeName = "Exception"+  | otherwise = exceptionInfoTypeName++exceptionFullTypeName :: D.ExceptionInfo -> String+exceptionFullTypeName info@D.ExceptionInfo{..}+  | null exceptionInfoFullTypeName = exceptionTypeName info+  | otherwise = exceptionInfoFullTypeName++exceptionMessage :: D.ExceptionInfo -> Maybe String+exceptionMessage D.ExceptionInfo{..}+  | null exceptionInfoMessage = Nothing+  | otherwise = Just exceptionInfoMessage

@@ -9,7 +9,6 @@  import DAP - import System.IO () import DAP.Log import qualified Data.Text as T@@ -21,16 +20,6 @@ import Control.Exception import Control.Monad import Control.Concurrent.Async--{- Note [Debugger Handles]-~~~~~~~~~~~~~~~~~~~~~~~~~~--The debugger executes arbritary user programs which will output to stdout and stderr.-This output needs to be sent to the debug client. Any output we wish to put in a-log or elsewhere needs to be directed to another handle.----}  handleLogger :: Handle -> IO (LogAction IO T.Text) handleLogger out_handle = do

@@ -32,12 +32,15 @@ import GHC.Generics import System.Directory import System.FilePath+import Data.Functor.Contravariant  import Development.Debug.Adapter import Development.Debug.Adapter.Exit-import GHC.Debugger.Logger as Logger+import Colog.Core as Logger import qualified Development.Debug.Adapter.Output as Output +import GHC.Utils.Logger (defaultLogActionWithHandles)+import GHC.Debugger.Utils (forwardHandleToLogger) import qualified GHC.Debugger as Debugger import qualified GHC.Debugger.Monad as Debugger import qualified GHC.Debugger.Interface.Messages as D (Command, Response)@@ -48,21 +51,6 @@ import Development.Debug.Session.Setup  ----------------------------------------------------------------------------------- * Logging-----------------------------------------------------------------------------------data InitLog-  = DebuggerLog Debugger.DebuggerLog-  | DebuggerMonadLog Debugger.DebuggerMonadLog-  | FlagsLog FlagsLog--instance Pretty InitLog where-  pretty = \ case-    DebuggerLog msg -> pretty msg-    DebuggerMonadLog msg -> pretty msg-    FlagsLog msg -> pretty msg---------------------------------------------------------------------------------- -- * Client -------------------------------------------------------------------------------- @@ -86,17 +74,27 @@     deriving anyclass FromJSON  --------------------------------------------------------------------------------+-- * Logging+--------------------------------------------------------------------------------++data DAPLog+  = DAPSessionSetupLog (WithSeverity SessionSetupLog)+  | DAPDebuggerLog Debugger.DebuggerLog++-------------------------------------------------------------------------------- -- * Launch Debugger -------------------------------------------------------------------------------- + -- | Exception type for when hie-bios initialization fails newtype InitFailed = InitFailed String deriving Show  -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise-initDebugger :: Recorder (WithSeverity InitLog) -> Bool -> LaunchArgs -> ExceptT InitFailed DebugAdaptor ()-initDebugger l supportsRunInTerminal+initDebugger :: LogAction IO DAPLog -> Bool -> Bool+             -> LaunchArgs -> ExceptT InitFailed DebugAdaptor ()+initDebugger l supportsRunInTerminal preferInternalInterpreter                LaunchArgs{ __sessionId                          , projectRoot = givenRoot                          , entryFile = entryFileMaybe@@ -116,40 +114,65 @@    projectRoot <- maybe (liftIO getCurrentDirectory) pure givenRoot -  let hieBiosLogger = cmapWithSev FlagsLog l+  let hieBiosLogger = contramap DAPSessionSetupLog l   liftIO (runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile)) >>= \case     Left e              -> throwError $ InitFailed e     Right (Left e)      -> lift       $ exitWithMsg e     Right (Right flags) -> do-      let nextFreshBreakpointId = 0+      -- Create the stdin handle for the external interpreter+      (readExternalIntStdin, writeExternalIntStdin) <- liftIO P.createPipe+      liftIO $ do+        hSetBuffering readExternalIntStdin LineBuffering+        hSetBuffering writeExternalIntStdin NoBuffering+        hSetEncoding readExternalIntStdin utf8+        hSetEncoding writeExternalIntStdin utf8+      when (not preferInternalInterpreter) $ liftIO $ void $ do+        -- forward proxy in to external interpreter stdin+        forkIO $ forever $ do+          i <- readChan syncProxyIn+          -- 3. Write to write-end of the pipe+          BS.hPut writeExternalIntStdin i >> hFlush writeExternalIntStdin++      let nextFreshId = 0           breakpointMap = mempty+          stackFrameMap = mempty+          variablesMap  = mempty           defaultRunConf = Debugger.RunDebuggerSettings             { supportsANSIStyling = True     -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap             , supportsANSIHyperlinks = False -- VSCode does not support this+            , preferInternalInterpreter+            , externalInterpreterStdinStream = UseHandle readExternalIntStdin             } -      -- Create pipes to read/write the debugger (not debuggee's) output.-      -- The write end is given to `runDebugger` and the read end is continuously-      -- read from until we read an EOF.-      (readDebuggerOutput, writeDebuggerOutput) <- liftIO P.createPipe+      -- Create a pipe to which messages to send to the DAP console are written and read.+      -- todo: This could just be a Haskell channel now...+      (readDAPOutput, writeDAPOutput) <- liftIO P.createPipe       liftIO $ do-        hSetBuffering readDebuggerOutput LineBuffering-        hSetBuffering writeDebuggerOutput NoBuffering+        hSetBuffering readDAPOutput LineBuffering+        hSetBuffering writeDAPOutput NoBuffering         -- GHC output uses utf8-        hSetEncoding readDebuggerOutput utf8-        hSetEncoding writeDebuggerOutput utf8+        hSetEncoding readDAPOutput utf8+        hSetEncoding writeDAPOutput utf8         setLocaleEncoding utf8        finished_init <- liftIO $ newEmptyMVar +      dbgLog <- liftIO $+        createDebuggerLogger l writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr)+       let absEntryFile = normalise $ projectRoot </> entryFile       lift $ registerNewDebugSession (maybe "debug-session" T.pack __sessionId) DAS{entryFile=absEntryFile,..}-        [ debuggerThread l finished_init writeDebuggerOutput projectRoot flags+        [ debuggerThread dbgLog finished_init projectRoot flags             extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses-        , handleDebuggerOutput readDebuggerOutput-        , stdinForwardThread  supportsRunInTerminal syncProxyIn-        , stdoutCaptureThread supportsRunInTerminal syncProxyOut-        , stderrCaptureThread supportsRunInTerminal syncProxyErr++        , \withAdaptor -> forwardHandleToLogger readDAPOutput $+            LogAction (\msg -> withAdaptor (Output.neutral msg))++        -- Setup capturing of the process' own stdout and forwarding of the process' own stdin,+        -- but only if we're using the internal interpreter!+        , if preferInternalInterpreter then stdinForwardThread  supportsRunInTerminal syncProxyIn  else mempty+        , if preferInternalInterpreter then stdoutCaptureThread supportsRunInTerminal syncProxyOut else mempty+        , if preferInternalInterpreter then stderrCaptureThread supportsRunInTerminal syncProxyErr else mempty         ]        -- Do not return until the initialization is finished@@ -160,65 +183,7 @@           -- This can happen if compilation fails and the compiler exits cleanly.           --           -- Instead of signalInitialized, respond with error and exit.-          lift $ exitCleanupWithMsg readDebuggerOutput e---- | This thread captures stdout from the debuggee and sends it to the client.--- NOTE, redirecting the stdout handle is a process-global operation. So this thread--- will capture ANY stdout the debuggee emits. Therefore you should never directly--- write to stdout, but always write to the appropiate handle.-stdoutCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()-stdoutCaptureThread runInTerminal syncOut withAdaptor = do-  tid <- myThreadId-  labelThread tid "Stdin Capture Thread"-  withInterceptedStdout $ \_ interceptedStdout -> do-    forever $ do-      line <- liftIO $ T.hGetLine interceptedStdout-      when runInTerminal $-        writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n")--      -- Always output to Debug Console-      withAdaptor $ Output.stdout line---- | Like 'stdoutCaptureThread' but for stderr-stderrCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()-stderrCaptureThread runInTerminal syncErr withAdaptor = do-  tid <- myThreadId-  labelThread tid "Stderr Capture Thread"-  withInterceptedStderr $ \_ interceptedStderr -> do-    forever $ do-      line <- liftIO $ T.hGetLine interceptedStderr-      when runInTerminal $-        writeChan syncErr $ T.encodeUtf8 (line <> "\n")--      -- Always output to Debug Console-      catch-        (withAdaptor $ Output.stderr line)-        (\(_ :: SomeException) ->-          throwIO (FailedToWriteToAdaptor line))--newtype FailedToWriteToAdaptor = FailedToWriteToAdaptor T.Text-instance Show FailedToWriteToAdaptor where-  show (FailedToWriteToAdaptor t) = "Failed to write to debug adapter: " ++ T.unpack t-instance Exception FailedToWriteToAdaptor--stdinForwardThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()-stdinForwardThread runInTerminal syncIn _withAdaptor = do-  tid <- myThreadId-  labelThread tid "Stdin Forward Thread"-  when runInTerminal $ do-    -- We need to hijack stdin to write to it--    -- 1. Create a new pipe from writeEnd->readEnd-    (readEnd, writeEnd) <- createPipe--    -- 2. Substitute the read-end of the pipe by stdin-    _ <- hDuplicateTo readEnd stdin-    hClose readEnd -- we'll never need to read from readEnd--    forever $ do-      i <- readChan syncIn-      -- 3. Write to write-end of the pipe-      BS.hPut writeEnd i >> hFlush writeEnd+          lift $ exitCleanupWithMsg readDAPOutput e  -- | The main debugger thread launches a GHC.Debugger session. --@@ -237,9 +202,8 @@ --    This sets the global CWD for this process, disallowing multiple sessions --    at the same, but that's OK because we currently only support --    single-session mode. Each new session gets a new debugger process.-debuggerThread :: Recorder (WithSeverity InitLog)+debuggerThread :: LogAction IO Debugger.DebuggerLog                -> MVar (Either String ()) -- ^ To signal when initialization is complete.-               -> Handle          -- ^ The write end of a handle for debug compiler output                -> FilePath        -- ^ Working directory for GHC session                -> HieBiosFlags    -- ^ GHC Invocation flags                -> [String]        -- ^ Extra ghc args@@ -250,7 +214,7 @@                -> (DebugAdaptorCont () -> IO ())                -- ^ Allows unlifting DebugAdaptor actions to IO. See 'registerNewDebugSession'.                -> IO ()-debuggerThread recorder finished_init writeDebuggerOutput workDir HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do+debuggerThread l finished_init workDir HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do    -- See Notes (CWD) above   setCurrentDirectory workDir@@ -264,20 +228,14 @@    catches     (do-      -- The logger should log things starting from Info to the debugger output-      -- handle as well, so the user sees it in the Console.-      debugAdapterLogger <- handleLogger writeDebuggerOutput-      let final_logger = cmapWithSev DebuggerMonadLog recorder <>-                         applyVerbosity (Verbosity Logger.Info)-                          (cmap renderPrettyWithSeverity (fromCologAction debugAdapterLogger))-      Debugger.runDebugger final_logger writeDebuggerOutput rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do+      Debugger.runDebugger l rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do         liftIO $ do           tid <- myThreadId           labelThread tid "Main Debugger Thread"         liftIO $ signalInitialized (Right ())         forever $ do           req <- takeMVar requests & liftIO-          resp <- (Debugger.execute (cmapWithSev DebuggerLog recorder) req <&> Right)+          resp <- (Debugger.execute req <&> Right)                     `catch` \(e :: SomeException) ->                         pure (Left (displayExceptionWithContext e))           either bad reply resp@@ -296,19 +254,114 @@       hPutStrLn stderr m       putMVar replies (Aborted ("Aborted debugger thread: " ++ m)) --- | Reads from the read end of the handle to which the debugger writes compiler messages.--- Writes the compiler messages to the client console-handleDebuggerOutput :: Handle-                     -> (DebugAdaptorCont () -> IO ())-                     -> IO ()-handleDebuggerOutput readDebuggerOutput withAdaptor = do+--------------------------------------------------------------------------------+-- * Logging+--------------------------------------------------------------------------------+{-+Note [Debugger, debuggee, and DAP logs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Specification for the logger given to `Debugger`: -  -- Mask exceptions to avoid being killed between reading a line and outputting it.-  (forever $ mask_ $ do-    line <- T.hGetLine readDebuggerOutput-    withAdaptor $ Output.neutral line-    ) `catch` -- handles read EOF-        \(_e::SomeException) ->-          -- Cleanly exit when readDebuggerOutput is closed or thread is killed.-          return ()+1. All -v3 DebuggerLog and GHCLog messages go to the normal stdout/stderr (this shows up in+  the OUTPUT console in VSCode, without having to send special messages) +2. All -v1 DebuggerLog, GHCLog, and all LogDebuggeeOut and LogDebuggeeErr output+  goes to the DAP console (this is DEBUG CONSOLE in VSCode)++3. All LogDebuggeeOut and LogDebuggeeErr output are forwarded to the proxy if+  the proxy is enabled.+-}++-- See Note [Debugger, debuggee, and DAP logs]+createDebuggerLogger+  :: LogAction IO DAPLog+  -> Handle -- ^ Handle to write to DAP output+  -> (Bool, Chan BS.ByteString, Chan BS.ByteString) -- ^ Proxy channels, and whether is supported+  -> IO (LogAction IO Debugger.DebuggerLog)+createDebuggerLogger l writeDAPOutput (supportsRunInTerminal, syncProxyOut, syncProxyErr) = do+  dapLogger <- handleLogger writeDAPOutput+  return $+    -- (1) (all output is logged to normal logger)+    contramap DAPDebuggerLog l <>+    -- (2) and (3) (log relevant output to DAP handle)+      LogAction (\case+        Debugger.DebuggerLog sev msg+          | sev >= Info -> do+            dapLogger <& T.pack (show msg)+        Debugger.GHCLog logflags msg_class srcSpan msg ->+          defaultLogActionWithHandles writeDAPOutput writeDAPOutput logflags msg_class srcSpan msg+        Debugger.LogDebuggeeOut txt -> debuggeeOut dapLogger syncProxyOut txt+        Debugger.LogDebuggeeErr txt -> debuggeeOut dapLogger syncProxyErr txt+        _ -> pure () -- don't log other messages, already logged to (1)+        )+  where+    debuggeeOut l' proxyChan txt = do+      -- (2)+      l' <& txt+      -- (3)+      when supportsRunInTerminal $+        writeChan proxyChan $+          T.encodeUtf8 (txt <> "\n")++--------------------------------------------------------------------------------+-- * Capturing stdout, stderr, and writing to self stdin+--------------------------------------------------------------------------------++-- | Hijack the current process stdin and forward to it the messages from the given channel+stdinForwardThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()+stdinForwardThread runInTerminal syncIn _withAdaptor = do+  tid <- myThreadId+  labelThread tid "Stdin Forward Thread"+  when runInTerminal $ do+    -- We need to hijack stdin to write to it++    -- 1. Create a new pipe from writeEnd->readEnd+    (readEnd, writeEnd) <- createPipe++    -- 2. Substitute the read-end of the pipe by stdin+    _ <- hDuplicateTo readEnd stdin+    hClose readEnd -- we'll never need to read from readEnd++    forever $ do+      i <- readChan syncIn+      -- 3. Write to write-end of the pipe+      BS.hPut writeEnd i >> hFlush writeEnd++-- | This thread captures stdout from the debuggee and sends it to the client.+-- NOTE, redirecting the stdout handle is a process-global operation. So this thread+-- will capture ANY stdout the debuggee emits. Therefore you should never directly+-- write to stdout, but always write to the appropiate handle.+stdoutCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()+stdoutCaptureThread runInTerminal syncOut withAdaptor = do+  tid <- myThreadId+  labelThread tid "Stdin Capture Thread"+  withInterceptedStdout $ \_ interceptedStdout -> do+    forever $ do+      line <- liftIO $ T.hGetLine interceptedStdout+      when runInTerminal $+        writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n")++      -- Always output to Debug Console+      withAdaptor $ Output.stdout line++-- | Like 'stdoutCaptureThread' but for stderr+stderrCaptureThread :: Bool -> Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO ()+stderrCaptureThread runInTerminal syncErr withAdaptor = do+  tid <- myThreadId+  labelThread tid "Stderr Capture Thread"+  withInterceptedStderr $ \_ interceptedStderr -> do+    forever $ do+      line <- liftIO $ T.hGetLine interceptedStderr+      when runInTerminal $+        writeChan syncErr $ T.encodeUtf8 (line <> "\n")++      -- Always output to Debug Console+      catch+        (withAdaptor $ Output.stderr line)+        (\(_ :: SomeException) ->+          throwIO (FailedToWriteToAdaptor line))++newtype FailedToWriteToAdaptor = FailedToWriteToAdaptor T.Text+instance Show FailedToWriteToAdaptor where+  show (FailedToWriteToAdaptor t) = "Failed to write to debug adapter: " ++ T.unpack t+instance Exception FailedToWriteToAdaptor

@@ -4,7 +4,6 @@ module Development.Debug.Adapter.Proxy   ( serverSideHdbProxy   , runInTerminalHdbProxy-  , ProxyLog(..)   ) where  import DAP@@ -27,16 +26,9 @@ import qualified Data.ByteString.Char8 as BS8 import qualified Data.HashMap.Strict as H -import GHC.Debugger.Logger+import Colog.Core import Development.Debug.Adapter -newtype ProxyLog = ProxyLog T.Text-  deriving newtype Pretty---- | Connect to a running @hdb proxy@ process on the given port--- connectToHdbProxy :: Recorder (WithVerbosity x) -> Int -> DebugAdaptor ()--- connectToHdbProxy = _- -- | Fork a new thread to run the server-side of the proxy. -- -- 1. To setup:@@ -47,7 +39,7 @@ -- 2. In a loop, -- 2.1 Read stdin from the socket and push it to a Chan -- 2.1 Read from a stdout Chan and write to the socket-serverSideHdbProxy :: Recorder (WithSeverity ProxyLog)+serverSideHdbProxy :: LogAction IO (WithSeverity T.Text)                    -> MVar ()                    -> DebugAdaptor () serverSideHdbProxy l client_conn_signal = do@@ -67,7 +59,7 @@     myThreadId >>= \tid -> labelThread tid "Debug/Adapter/Proxy: TCP Server"     runTCPServerWithSocket sock $ \scket -> do -      logWith l Info $ ProxyLog $ T.pack $ "Connected to client on port " ++ show port ++ "...!"+      infoMsg (T.pack $ "Connected to client on port " ++ show port ++ "...!")       putMVar client_conn_signal () -- signal ready (see #95)        -- -- Read stdout from chan and write to socket@@ -76,7 +68,7 @@         labelThread tid "Debug/Adapter/Proxy: Forward stdout"         forever $ do           bs <- readChan dbOut-          logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket: " ++ BS8.unpack bs+          debugMsg (T.pack $ "Writing to socket: " ++ BS8.unpack bs)           NBS.sendAll scket bs        -- Read stderr from chan and write to socket@@ -85,7 +77,7 @@         labelThread tid "Debug/Adapter/Proxy: Forward stderr"         forever $ do           bs <- readChan dbErr-          logWith l Debug $ ProxyLog $ T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs+          debugMsg (T.pack $ "Writing to socket (from stderr): " ++ BS8.unpack bs)           NBS.sendAll scket bs        -- Read stdin from socket and write to chan@@ -93,10 +85,10 @@             bs <- NBS.recv scket 4096             if BS8.null bs               then do-                logWith l Debug $ ProxyLog $ T.pack "Connection to client was closed."+                debugMsg (T.pack "Connection to client was closed.")                 close scket               else do-                logWith l Debug $ ProxyLog $ T.pack $ "Read from socket: " ++ BS8.unpack bs+                debugMsg (T.pack $ "Read from socket: " ++ BS8.unpack bs)                 writeChan dbIn bs >> loop        in ignoreIOException loop @@ -104,7 +96,9 @@    where     ignoreIOException a = catch a $ \(e::IOException) ->-      logWith l Info $ ProxyLog $ T.pack $ "Ignoring connection broken to proxy client: " ++ show e+      infoMsg (T.pack $ "Ignoring connection broken to proxy client: " ++ show e)+    debugMsg msg = l <& WithSeverity msg Debug+    infoMsg msg  = l <& WithSeverity msg Info  -- | The proxy code running on the terminal in which the @hdb proxy@ process is launched. --@@ -112,9 +106,9 @@ -- 1. Connecting to the given proxy-server port -- 2. Forwarding stdin to the port it is connected to -- 3. Read from the network the output and write it to stdout-runInTerminalHdbProxy :: Recorder (WithSeverity ProxyLog) -> Int -> IO ()+runInTerminalHdbProxy :: LogAction IO (WithSeverity T.Text) -> Int -> IO () runInTerminalHdbProxy l port = do-  logWith l Info $ ProxyLog $ T.pack $ "Running in terminal on port " ++ show port ++ "...!"+  l <& WithSeverity (T.pack $ "Running in terminal on port " ++ show port ++ "...!") Info   hSetBuffering stdin LineBuffering    dbg_inv <- lookupEnv "DEBUGGEE_INVOCATION"@@ -137,7 +131,7 @@         msg <- NBS.recv sock 4096         if BS8.null msg           then do-            logWith l Info $ ProxyLog $ T.pack "Exiting..."+            l <& WithSeverity (T.pack "Exiting...") Info             close sock             exitSuccess           else BS8.hPut stdout msg >> hFlush stdout

@@ -10,22 +10,36 @@  commandContinue :: DebugAdaptor () commandContinue = do+  resetObjectReferences   DidContinue er <- sendInterleaved DoContinue $     sendContinueResponse (ContinueResponse True)   handleEvalResult False er  commandNext :: DebugAdaptor () commandNext = do+  resetObjectReferences   DidStep er <- sendInterleaved DoStepLocal sendNextResponse   handleEvalResult True er  commandStepIn :: DebugAdaptor () commandStepIn = do+  resetObjectReferences   DidStep er <- sendInterleaved DoSingleStep sendStepInResponse   handleEvalResult True er  commandStepOut :: DebugAdaptor () commandStepOut = do+  resetObjectReferences   DidStep er <- sendInterleaved DoStepOut sendStepOutResponse   handleEvalResult True er +--------------------------------------------------------------------------------++-- | See "Lifetime of Objects References" in DAP specification.+resetObjectReferences :: DebugAdaptor ()+resetObjectReferences = do+  updateDebugSession $ \s ->+    s { stackFrameMap = mempty+      , breakpointMap = mempty+      , variablesMap  = mempty+      }

@@ -15,6 +15,7 @@ module Development.Debug.Adapter.Stopped where  import Control.Monad+import qualified Data.IntMap as IM import qualified Data.Text as T  import DAP@@ -47,28 +48,30 @@ commandStackTrace :: DebugAdaptor () commandStackTrace = do   StackTraceArguments{..} <- getArguments-  GotStacktrace stackFrames <- sendSync (GetStacktrace (RemoteThreadId stackTraceArgumentsThreadId))-  responseFrames <- forM (zip stackFrames [1..]) $ \(stackFrame, stackFrameIx) -> do-    source <- fileToSource stackFrame.sourceSpan.file-    return defaultStackFrame-      { stackFrameId = stackTraceArgumentsThreadId*1000000 + stackFrameIx-      , stackFrameName = T.pack stackFrame.name-      , stackFrameLine = stackFrame.sourceSpan.startLine-      , stackFrameColumn = stackFrame.sourceSpan.startCol-      , stackFrameEndLine = Just stackFrame.sourceSpan.endLine-      , stackFrameEndColumn = Just stackFrame.sourceSpan.endCol-      , stackFrameSource = Just source-      }+  let threadId = RemoteThreadId stackTraceArgumentsThreadId+  GotStacktrace stackFrames <- sendSync (GetStacktrace threadId)+  (responseFrames, newStackFrameMap) <- fmap (unzip . concat) $+    forM (zip stackFrames [0..]) $ \(stackFrame, stackFrameIx) -> do+      freshId <- getFreshId+      source <- fileToSource stackFrame.sourceSpan.file+      let responseFrame = defaultStackFrame+            { stackFrameId = freshId+            , stackFrameName = T.pack stackFrame.name+            , stackFrameLine = stackFrame.sourceSpan.startLine+            , stackFrameColumn = stackFrame.sourceSpan.startCol+            , stackFrameEndLine = Just stackFrame.sourceSpan.endLine+            , stackFrameEndColumn = Just stackFrame.sourceSpan.endCol+            , stackFrameSource = Just source+            }+      let newMapEntry = (freshId, StackFrameIx threadId stackFrameIx)+      return [(responseFrame, newMapEntry)]++  updateDebugSession (\s -> s { stackFrameMap = s.stackFrameMap <> IM.fromList newStackFrameMap })+   sendStackTraceResponse StackTraceResponse     { stackFrames = responseFrames-    , totalFrames = if null responseFrames then Nothing else Just (length responseFrames) }---- | Come up with a unique identifier for a stack frame (only valid while in--- this stopped environment, see "Lifetime of Objects References" in DAP--- overview).------ The unique identifier is based on the threadId and index of the stack frame for this thread's stack.--- mkUniqueStackId ::+    , totalFrames = if null responseFrames then Nothing else Just (length responseFrames)+    }  -------------------------------------------------------------------------------- -- * Scopes@@ -77,14 +80,24 @@ -- | Command to get scopes for current stopped point commandScopes :: DebugAdaptor () commandScopes = do-  ScopesArguments{scopesArgumentsFrameId=_IGNORED_BUT_NOW_WE_HAVE_TO_CARE} <- getArguments-  GotScopes scopes <- sendSync GetScopes-  sendScopesResponse . ScopesResponse =<<-    mapM scopeInfoToScope scopes+  ScopesArguments{..} <- getArguments+  let frameId = scopesArgumentsFrameId+  sfMap <- stackFrameMap <$> getDebugSession+  case IM.lookup frameId sfMap of+    Nothing -> do+      sendErrorResponse (ErrorMessage (T.pack $ "Could not find stack frame for id " ++ show frameId)) Nothing+    Just six@(StackFrameIx threadId frameIx) -> do+      GotScopes scopes <- sendSync (GetScopes threadId frameIx)+      sendScopesResponse . ScopesResponse =<<+        mapM (scopeInfoToScope six) scopes  -- | 'ScopeInfo' to 'Scope'-scopeInfoToScope :: ScopeInfo -> DebugAdaptor Scope-scopeInfoToScope ScopeInfo{..} = do+scopeInfoToScope :: StackFrameIx -> ScopeInfo -> DebugAdaptor Scope+scopeInfoToScope six ScopeInfo{..} = do++  -- Update vars map+  varId <- freshVarIx six (scopeToVarRef kind)+   source <- fileToSource sourceSpan.file   return defaultScope     { scopeName = case kind of@@ -101,7 +114,7 @@     , scopeColumn = Just sourceSpan.startCol     , scopeEndLine = Just sourceSpan.endLine     , scopeEndColumn = Just sourceSpan.endCol-    , scopeVariablesReference = fromEnum (scopeToVarRef kind)+    , scopeVariablesReference = varId     }  --------------------------------------------------------------------------------@@ -112,42 +125,42 @@ commandVariables :: DebugAdaptor () commandVariables = do   VariablesArguments{..} <- getArguments-  let vk = toEnum variablesArgumentsVariablesReference-  GotVariables vars <- sendSync (GetVariables vk)-  sendVariablesResponse $ VariablesResponse $-    map varInfoToVariables (either (:[]) id vars)-  case vars of-    -- If the reply indicates this was an "inspect lazy variable" request-    -- (because the requested variable was forced instead of returning an-    -- expansion), invalidate the parent variables.-    ---    -- The client side seems to handle rendering only the bits which changed-    -- out very well, while preserving the variable tree expansion.-    -- In any case, we might have to pessimistically redo all variable-    -- responses because any value may be changed by an updated thunk, not only-    -- the parent variables.-    Left _-      -> sendInvalidatedEvent defaultInvalidatedEvent-          { invalidatedEventAreas = [InvalidatedAreasVariables]-          , invalidatedEventStackFrameId = Just 0 -- we only support one stack frame for now (TODO).-          }-    _ -> return () +  vsMap <- variablesMap <$> getDebugSession+  case IM.lookup variablesArgumentsVariablesReference vsMap of+    Nothing -> sendErrorResponse (ErrorMessage (T.pack $ "Could not find variable reference " ++ show variablesArgumentsVariablesReference)) Nothing+    Just (VariablesIx six@(StackFrameIx threadId frameIx) varRef) -> do+      GotVariables vars <- sendSync (GetVariables threadId frameIx varRef)+      sendVariablesResponse . VariablesResponse =<<+        mapM (varInfoToVariables six) (variableResultToList vars)+      case vars of+        -- If the reply indicates this was an "inspect lazy variable" request+        -- (because the requested variable was forced instead of returning an+        -- expansion), invalidate the parent variables.+        --+        -- The client side seems to handle rendering only the bits which changed+        -- out very well, while preserving the variable tree expansion.+        -- In any case, we might have to pessimistically redo all variable+        -- responses because any value may be changed by an updated thunk, not only+        -- the parent variables.+        ForcedVariable _+          -> sendInvalidatedEvent defaultInvalidatedEvent+              { invalidatedEventAreas = [InvalidatedAreasVariables]+              , invalidatedEventStackFrameId = Just 0 -- TODO: REVERSE LOOKUP OF (StackFrameIx threadId frameIx)+              }+        VariableFields _ -> return ()+ -- | 'VarInfo' to 'Variable's.------ Note that if 'VarInfo' is a nested structure, only the top-most VarInfo is--- returned (with the according namedVariables and indexedVariables sizes).------ The @'varFields'@ are ignored. If they are meant to be returned, they should--- be matched against and returned explicitly (see @'getVariables'@).-varInfoToVariables :: VarInfo -> Variable-varInfoToVariables VarInfo{..} =-  defaultVariable+varInfoToVariables :: StackFrameIx -> VarInfo -> DebugAdaptor Variable+varInfoToVariables six VarInfo{..} = do+  varId <- freshVarIx six varRef++  return defaultVariable     { variableName = T.pack varName     , variableValue = T.pack varValue     , variableType = Just $ T.pack varType     , variableEvaluateName = Just $ T.pack varName-    , variableVariablesReference = fromEnum varRef+    , variableVariablesReference = varId     , variableNamedVariables = Nothing     , variableIndexedVariables = Nothing     , variablePresentationHint = Just defaultVariablePresentationHint@@ -155,3 +168,13 @@         }     } +--------------------------------------------------------------------------------+-- Variable ix references+--------------------------------------------------------------------------------++freshVarIx :: StackFrameIx -> VariableReference -> DebugAdaptor Int+freshVarIx _ NoVariables = pure 0 -- No variables means the reference should be 0, e.g. denoting the variable is not expandable+freshVarIx six vr = do+  varId <- getFreshId+  updateDebugSession (\s -> s { variablesMap = IM.insert varId (VariablesIx six vr) s.variablesMap })+  return varId

@@ -1,6 +1,7 @@-{-# LANGUAGE LambdaCase, ViewPatterns, RecordWildCards #-}+{-# LANGUAGE LambdaCase, ViewPatterns, RecordWildCards, OverloadedRecordDot #-} module Development.Debug.Interactive where +import Data.Functor.Contravariant import System.IO import System.Exit import System.Directory@@ -16,38 +17,45 @@  import Development.Debug.Session.Setup -import GHC.Debugger.Logger+import Colog.Core import GHC.Debugger.Interface.Messages import GHC.Debugger.Monad import GHC.Debugger+import Control.Monad+import Data.List (intercalate)+import qualified Data.Maybe as Maybe +data RunOptions = RunOptions+  { runEntryFile :: FilePath+  , runEntryPoint :: String+  , runEntryArgs :: [String]+  }++data RunContext = RunContext+  { runCurrentThread :: Maybe RemoteThreadId+  , runLastCommand :: Maybe Command+  }+ -- | Interactive debugging monad-type InteractiveDM a = InputT (RWST (FilePath{-entry file-},String{-entry point-}, [String]{-run args-}) ()-                                (Maybe Command{-last cmd-}) Debugger) a+type InteractiveDM a = InputT (RWST RunOptions () RunContext Debugger) a  data InteractiveLog-  = DebuggerLog DebuggerLog-  | DebuggerMonadLog DebuggerMonadLog-  | FlagsLog FlagsLog--instance Pretty InteractiveLog where-  pretty = \ case-    DebuggerLog msg -> pretty msg-    FlagsLog msg -> pretty msg-    DebuggerMonadLog msg -> pretty msg+  = IDebuggerLog DebuggerLog+  | ISessionSetupLog (WithSeverity SessionSetupLog)  -- | Run it-runIDM :: Recorder (WithSeverity InteractiveLog)+runIDM :: LogAction IO InteractiveLog        -> String   -- ^ entryPoint        -> FilePath -- ^ entryFile        -> [String] -- ^ entryArgs        -> [String] -- ^ extraGhcArgs+       -> RunDebuggerSettings        -> InteractiveDM a        -> IO a-runIDM logger entryPoint entryFile entryArgs extraGhcArgs act = do+runIDM logger entryPoint entryFile entryArgs extraGhcArgs runConf act = do   projectRoot <- getCurrentDirectory -  let hieBiosLogger = cmapWithSev FlagsLog logger+  let hieBiosLogger = contramap ISessionSetupLog logger   runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile) >>= \case     Left e               -> exitWithMsg e     Right (Left e)       -> exitWithMsg e@@ -55,18 +63,14 @@       | HieBiosFlags{..} <- flags                          -> do -      let defaultRunConf = RunDebuggerSettings-            { supportsANSIStyling = True -- todo: check!!-            , supportsANSIHyperlinks = False-            }-       let absEntryFile = normalise $ projectRoot </> entryFile-      let debugRec = cmapWithSev DebuggerMonadLog logger+      let debugRec = contramap IDebuggerLog logger -      runDebugger debugRec stdout rootDir componentDir libdir units ghcInvocation extraGhcArgs absEntryFile defaultRunConf $+      runDebugger debugRec rootDir componentDir libdir units ghcInvocation extraGhcArgs absEntryFile runConf $         fmap fst $           evalRWST (runInputT (setComplete noCompletion defaultSettings) act)-                   (entryFile, entryPoint, entryArgs) Nothing+                   (RunOptions { runEntryFile = entryFile, runEntryPoint = entryPoint, runEntryArgs = entryArgs })+                   (RunContext { runLastCommand = Nothing, runCurrentThread = Nothing } )   where     exitWithMsg txt = do       hPutStrLn stderr txt@@ -84,57 +88,146 @@   --         _ -> return []  -- | Run the interactive command-line debugger-debugInteractive :: Recorder (WithSeverity InteractiveLog) -> InteractiveDM ()-debugInteractive recorder = withInterrupt loop+debugInteractive :: InteractiveDM ()+debugInteractive = withInterrupt loop   where-    debugRec = cmapWithSev DebuggerLog recorder     loop = handleInterrupt loop $ do       minput <- getInputLine "(hdb) "       case minput of         Nothing -> outputStrLn "Exiting..." >> liftIO (exitWith ExitSuccess)         Just "" -> do-          lift get >>= \case+          lift (gets runLastCommand) >>= \case             Nothing -> return ()-            Just (cmd :: Command) -> do-              out <- lift . lift $ execute debugRec cmd -- repeat last command-              printResponse debugRec out+            Just cmd -> do+              out <- lift . lift $ execute cmd -- repeat last command+              printResponse out         Just input -> do           mcmd <- parseCmd input-          lift $ put mcmd+          lift $ modify (\ o -> o { runLastCommand = mcmd })           case mcmd of             Nothing -> return ()             Just cmd -> do-              out <- lift . lift $ execute debugRec cmd-              printResponse debugRec out+              out <- lift . lift $ execute cmd+              printResponse out       loop +showExceptionDetails :: RemoteThreadId -> InteractiveDM ()+showExceptionDetails tid = do+  infoResp <- lift . lift $ execute (GetExceptionInfo tid)+  case infoResp of+    GotExceptionInfo exc_info -> outputStrLn $ renderExceptionInfo exc_info+    _ -> pure ()+  stackResp <- lift . lift $ execute (GetStacktrace tid)+  case stackResp of+    GotStacktrace (frame:_) ->+      outputStrLn $+        "Exception location: " ++ renderSourceSpan (frame.sourceSpan)+    _ -> outputStrLn "Exception location: <unknown>"+ -------------------------------------------------------------------------------- -- Printing -------------------------------------------------------------------------------- -printResponse :: Recorder (WithSeverity DebuggerLog) -> Response -> InteractiveDM ()-printResponse recd = \case-  DidEval er -> outputStrLn $ show er+printResponse :: Response -> InteractiveDM ()+printResponse = \case+  DidEval er -> outputEvalResult er   DidSetBreakpoint bf       -> outputStrLn $ show bf   DidRemoveBreakpoint bf    -> outputStrLn $ show bf   DidGetBreakpoints mb_span -> outputStrLn $ show mb_span   DidClearBreakpoints -> outputStrLn "Cleared all breakpoints."-  DidContinue er -> outputStrLn $ show er-  DidStep er -> printEvalResult recd er-  DidExec er -> outputStrLn $ show er+  DidContinue er -> outputEvalResult er+  DidStep er -> printEvalResult er+  DidExec er -> outputEvalResult er   GotThreads threads -> outputStrLn $ show threads   GotStacktrace stackframes -> outputStrLn $ show stackframes   GotScopes scopeinfos -> outputStrLn $ show scopeinfos-  GotVariables vis -> outputStrLn $ show vis -- (Either VarInfo [VarInfo])+  GotVariables vis -> outputVariables vis+  GotExceptionInfo exc_info -> outputStrLn $ renderExceptionInfo exc_info   Aborted err_str -> outputStrLn ("Aborted: " ++ err_str)   Initialised -> pure ()+  where+    outputEvalResult er = do+      outputStrLn (showEvalResult er)+      maybeShowException er+      rememberThreadContext er -printEvalResult :: Recorder (WithSeverity DebuggerLog) -> EvalResult -> InteractiveDM ()-printEvalResult recd EvalStopped{breakId=_} = do-  out <- lift . lift $ execute recd GetScopes-  printResponse recd out-printEvalResult _ er = outputStrLn $ show er+    maybeShowException EvalStopped{breakId = Nothing, breakThread=tid} =+      showExceptionDetails tid+    maybeShowException _ = pure () +    rememberThreadContext er =+      case er of+        EvalCompleted{} -> lift $ modify' (\ ctx -> ctx { runCurrentThread = Nothing } )+        EvalException{} -> pure () -- TODO: why does this not have a thread associated?+        EvalStopped{breakThread} -> lift $ modify' (\ ctx -> ctx { runCurrentThread = Just breakThread } )+        EvalAbortedWith{} -> lift $ modify' (\ ctx -> ctx { runCurrentThread = Nothing } )++    outputVariables (ForcedVariable var) = outputVariables (VariableFields [var])+    outputVariables (VariableFields vars) = do+       ctx <- lift get+       case runCurrentThread ctx of+         Just threadId ->+          mapM_ (outputVarWithFields  threadId 0) vars+         Nothing -> error "no thread id"++    outputVarWithFields threadId frameIx var = do+      outputStrLn (showVarInfo var)+      fields <- fetchFields threadId frameIx var+      mapM_ (outputStrLn . ("  " ++) . showVarInfo) fields++    fetchFields _ _ VarInfo{varRef = NoVariables} = pure []+    fetchFields threadId frameIx VarInfo{varRef = ref@(SpecificVariable _), ..} = do+      resp <- lift . lift $ execute (GetVariables threadId frameIx ref)+      case resp of+        GotVariables res -> pure (variableResultToList res)+        Aborted err -> outputStrLn ("Failed to fetch fields for " ++ varName ++ ": " ++ err) >> pure []+        _ -> outputStrLn ("Unexpected response when fetching fields for " ++ varName) >> pure []+    fetchFields _ _ _ = pure []++printEvalResult :: EvalResult -> InteractiveDM ()+printEvalResult EvalStopped{..} = do+  out <- lift . lift $ execute (GetScopes breakThread 0)+  printResponse out+  when (breakId == Nothing) $+    showExceptionDetails breakThread+printEvalResult er = outputStrLn $ showEvalResult er++showEvalResult :: EvalResult -> String+showEvalResult (EvalCompleted{..}) = resultVal+showEvalResult (EvalException{..}) = resultVal+showEvalResult (EvalStopped{}) = "Stopped at breakpoint"+showEvalResult (EvalAbortedWith err) = "Aborted: " ++ err++showVarInfoResult :: VariableResult -> String+showVarInfoResult (ForcedVariable vi) = showVarInfo vi+showVarInfoResult (VariableFields vis) = unlines $ map showVarInfo vis++showVarInfo :: VarInfo -> String+showVarInfo VarInfo{..} = unwords [varName, ":", varType, "=", varValue]++renderSourceSpan :: SourceSpan -> String+renderSourceSpan SourceSpan{..} =+  file ++ ":" ++ show startLine ++ ":" ++ show startCol++renderExceptionInfo :: ExceptionInfo -> String+renderExceptionInfo = unlines . go 0+  where+    go depth exInfo =+      let indent = replicate (depth * 2) ' '+          typeLine = indent ++ "Exception: " ++ exceptionInfoTypeName exInfo+          messageLine = indent ++ "Message: " ++ exceptionInfoMessage exInfo+          ctxLine = case exceptionInfoContext exInfo of+            Nothing -> indent ++ "Call stack: <unavailable>"+            Just ctx -> indent ++ "Call stack:\n" ++ indentMultiline (depth + 1) ctx+          innerLines = case exceptionInfoInner exInfo of+            [] -> []+            xs -> (indent ++ "Inner exceptions:") : concatMap (go (depth + 1)) xs+      in typeLine : messageLine : ctxLine : innerLines++    indentMultiline depth txt =+      let pref = replicate (depth * 2) ' '+      in intercalate "\n" (map (pref ++) (lines txt))+ -------------------------------------------------------------------------------- -- Command parser --------------------------------------------------------------------------------@@ -181,16 +274,16 @@    <> metavar "N:INT"    <> help "Ignore first N:INT times this breakpoint is hit" )) -runParser :: FilePath -> String -> [String] -> Parser Command-runParser entryFile entryPoint entryArgs =+runParser :: RunOptions -> Parser Command+runParser opts =   -- --entry <name> with some args   -- (DebugExecution <$> parseEntry <*> parseSomeArgs)   -- --entry <name> without any args   -- <|> (DebugExecution <$> parseEntry <*> pure [])   -- just some args-  (DebugExecution (mkEntry entryPoint) entryFile <$> parseSomeArgs)+  (DebugExecution (mkEntry (runEntryPoint opts)) (runEntryFile opts) <$> parseSomeArgs)   -- just "run"-  <|> (pure $ DebugExecution (mkEntry entryPoint) entryFile entryArgs)+  <|> (pure $ DebugExecution (mkEntry (runEntryPoint opts)) (runEntryFile opts) (runEntryArgs opts))   where     _parseEntry =       fmap mkEntry $@@ -205,21 +298,18 @@         ( metavar "ARGS" <> help "Arguments to pass to the entry point. If empty, the arguments given at the debugger invocation are used." ) )     mkEntry entry       | entry == "main" = MainEntry Nothing-      | otherwise = FunctionEntry entryPoint+      | otherwise = FunctionEntry (runEntryPoint opts)  -- | Combined parser for 'Command'-cmdParser :: FilePath -> String -> [String] -> Parser Command-cmdParser entryFile entryPoint entryArgs = hsubparser-  ( Options.Applicative.command "break"-    ( info (SetBreakpoint <$> breakpointParser <*> hitCountBreakParser <*> conditionalBreakParser)-      ( progDesc "Set a breakpoint" ) )-  <>+cmdParser :: RunOptions -> RunContext -> Parser Command+cmdParser opts ctx = hsubparser+   (     Options.Applicative.command "delete"     ( info (DelBreakpoint <$> breakpointParser)       ( progDesc "Delete a breakpoint" ) )   <>     Options.Applicative.command "run"-    ( info (runParser entryFile entryPoint entryArgs)+    ( info (runParser opts)       ( progDesc "Run the debuggee" ) )   <>     Options.Applicative.command "next"@@ -246,21 +336,53 @@     Options.Applicative.command "exit"     ( info (pure TerminateProcess)       ( progDesc "Terminate and exit the debugger session" ) )+  <>+    Options.Applicative.command "threads"+    ( info (pure GetThreads)+      ( progDesc "Print all user threads" ) )+  <>+    Options.Applicative.command "backtrace"+    ( info (stackTraceParser ctx <**> helper)+      ( progDesc "Print stack trace" ) )+  <>+    Options.Applicative.command "variables"+    ( info (variablesParser ctx <**> helper)+      ( progDesc "Print local variables" ) )+  <> Options.Applicative.command "break"+    ( info (SetBreakpoint <$> breakpointParser <*> hitCountBreakParser <*> conditionalBreakParser)+      ( progDesc "Set a breakpoint" ) )   ) +stackTraceParser :: RunContext -> Parser Command+stackTraceParser ctx =+  GetStacktrace <$> threadIdParser ctx "Print backtrace of THREAD_ID. Defaults to current thread at breakpoint."++variablesParser :: RunContext -> Parser Command+variablesParser ctx =+  GetVariables+    <$> threadIdParser ctx "Show variables of THREAD_ID. Defaults to current thread at breakpoint."+    <*> pure 0+    <*> pure LocalVariables++threadIdParser :: RunContext -> String -> Parser RemoteThreadId+threadIdParser ctx helpMsg =+     RemoteThreadId <$> argument auto (metavar "THREAD_ID" <> help helpMsg)+ <|> Maybe.maybe (empty <**> abortOption (ErrorMsg "Not stopped at a Breakpoint") mempty) pure (runCurrentThread ctx)+ -- | Main parser info-cmdParserInfo :: FilePath -> String -> [String] -> ParserInfo Command-cmdParserInfo entryFile entryPoint entryArgs = info (cmdParser entryFile entryPoint entryArgs)+cmdParserInfo :: RunOptions -> RunContext -> ParserInfo Command+cmdParserInfo opts ctx = info (cmdParser opts ctx)   ( fullDesc )  -- | Parse command line arguments parseCmd :: String -> InteractiveDM (Maybe Command) parseCmd input = do-  (entryFile, entryPoint, entryArgs) <- lift ask+  opts <- lift ask+  ctx <- lift get   let     res = execParserPure      parserPrefs-     (cmdParserInfo entryFile entryPoint entryArgs)+     (cmdParserInfo opts ctx)      (words input)    in case res of     Success x ->

@@ -4,22 +4,25 @@ module Development.Debug.Options   ( HdbOptions(..) ) where -import GHC.Debugger.Logger+import Colog.Core (Severity)  -- | The options `hdb` is invoked in the command line with data HdbOptions-  -- | @server --port <port>@+  -- | @server [--internal-interpreter] --port <port>@   = HdbDAPServer     { port :: Int-    , verbosity :: Verbosity+    , verbosity :: Severity+    , internalInterpreter :: Bool     }-  -- | @cli [--entry-point=<entryPoint>] [--extra-ghc-args="<args>"] [<entryFile>] -- [<entryArgs>]@+  -- | @cli [--internal-interpreter] [--entry-point=<entryPoint>] [--extra-ghc-args="<args>"] [<entryFile>] -- [<entryArgs>]@   | HdbCLI     { entryPoint :: String     , entryFile :: FilePath     , entryArgs :: [String]     , extraGhcArgs :: [String]-    , verbosity :: Verbosity+    , verbosity :: Severity+    , internalInterpreter :: Bool+    , debuggeeStdin :: Maybe FilePath     }    -- | @proxy --port <port>@@@ -37,6 +40,26 @@   -- See #44 for the original ticket   | HdbProxy     { port :: Int-    , verbosity :: Verbosity+    , verbosity :: Severity     }++  -- | Launch the custom-for-the-debugger external interpreter for running the+  -- debuggee process.+  --+  -- Using an external interpreter will guarantee the debugger and debuggee run+  -- on separate processes. This comes with many benefits:+  --  * Debugger vs debuggee threads naturally separated+  --  * Debugger vs debuggee stdin/stdout/stderr naturally separated+  --  * No *** Ignoring breakpoint when debugging the debugger against another program+  --+  --  A custom server is necessary for the custom commands (starting with GHC+  --  9.16) and because the external interpreter in GHC 9.14 is not compiled+  --  with -threaded, which is a requirement for using thread/stack cloning+  --  messages in the external process.+  --+  --  See #169+  | HdbExternalInterpreter+      { writeFd :: Int+      , readFd  :: Int+      } 

@@ -1,3 +1,4 @@+{-# LANGUAGE MultilineStrings #-} -- | Options parser using optparse-applicative for the debugger options in -- 'Development.Debug.Options' module Development.Debug.Options.Parser@@ -11,7 +12,7 @@ import qualified Options.Applicative import qualified Paths_haskell_debugger as P -import GHC.Debugger.Logger+import Colog.Core import Development.Debug.Options  --------------------------------------------------------------------------------@@ -26,7 +27,8 @@      <> short 'p'      <> metavar "PORT"      <> help "DAP server port" )-  <*> verbosityParser (Verbosity Debug)+  <*> verbosityParser Debug+  <*> internalInterpreterParser  -- | Parser for 'HdbCLI' options cliParser :: Parser HdbOptions@@ -51,8 +53,30 @@      <> metavar "GHC_ARGS"      <> value []      <> help "Additional flags to pass to the ghc invocation that loads the program for debugging" )-  <*> verbosityParser (Verbosity Warning)+  <*> verbosityParser Warning+  <*> internalInterpreterParser+  <*> (optional $ strOption+      ( long "debuggee-stdin"+     <> metavar "FILE"+     <> help """+          Provide a file to be used as stdin for the debuggee. +          If `hdb` is connected to a terminal, the debuggee input can be+          given interactively, interleaved with the debugger input.++          However, if the debuggee reads from stdin and `hdb` is invoked+          reading from a file or pipe (e.g. `hdb Main.hs < instructions`), then+          the debuggee output must be given separately using this flag (and+          `instructions` should only contain debugger commands).++          Otherwise, the debuggee and debugger will race to read from the file+          (regardless of buffering), which typically results in an error like+          `<stdin>: hGetLine: end of file`++          This flag does not do anything when using --internal-interpreter+        """+      ))+ -- | Parser for 'HdbProxy' options proxyParser :: Parser HdbOptions proxyParser = HdbProxy@@ -61,8 +85,19 @@      <> short 'p'      <> metavar "PORT"      <> help "proxy port to which the debugger connects" )-  <*> verbosityParser (Verbosity Warning)+  <*> verbosityParser Warning +-- | Parser for @hdb external-interpreter <write-fd> <read-fd>@+-- See Note [Custom external interpreter]+extInterpParser :: Parser HdbOptions+extInterpParser = HdbExternalInterpreter+  <$> argument auto+    ( metavar "WRITE_FD"+   <> help "external interpreter write file descriptor" )+  <*> argument auto+    ( metavar "READ_FD"+   <> help "external interpreter read file descriptor" )+ -- | Combined parser for HdbOptions hdbOptionsParser :: Parser HdbOptions hdbOptionsParser = hsubparser@@ -75,8 +110,11 @@  <> Options.Applicative.command "proxy"     ( info proxyParser       ( progDesc "Internal mode used by the DAP server to proxy the stdin/stdout to the DAP client's terminal" ) )+ <> Options.Applicative.command "external-interpreter"+    ( info extInterpParser+      ( progDesc "Start the custom-for-debugger external interpreter" ) )   )-  <|> cliParser  -- Default to CLI mode if no subcommand+  <|> cliParser -- Default to CLI mode if no subcommand  -- | Parser for --version flag versioner :: Parser (a -> a)@@ -87,7 +125,7 @@ -- The default verbosity differs by mode (#86): -- - DAP server mode: DEBUG -- - CLI mode: WARNING-verbosityParser :: Verbosity -> Parser Verbosity+verbosityParser :: Severity -> Parser Severity verbosityParser vdef = option verb     ( long "verbosity"    <> short 'v'@@ -96,13 +134,24 @@    <> help "Logger verbosity in [0..3] interval, where 0 is silent and 3 is debug"     )   where-    verb = Verbosity <$> (verbNum =<< auto)+    verb = verbNum =<< auto     verbNum n = case n :: Int of       0 -> pure Error       1 -> pure Warning       2 -> pure Info       3 -> pure Debug       _ -> readerAbort (ErrorMsg "Verbosity must be a value in [0..3]")++-- | Parser for --internal-interpreter+--+-- Prefer running the debuggee on the debugger's internal interpreter rather+-- than using an external interpreter by default.+internalInterpreterParser :: Parser Bool+internalInterpreterParser =+  switch+    ( long "internal-interpreter"+   <> help "Prefer running the debuggee on the debugger's internal interpreter rather than on a separate (external-interpreter) process"+    )  -- | Main parser info hdbParserInfo :: ParserInfo HdbOptions

@@ -10,7 +10,7 @@   , hieBiosSetup    -- * Logging-  , FlagsLog(..)+  , SessionSetupLog(..)   ) where  import Control.Applicative ((<|>))@@ -29,7 +29,7 @@ import System.FilePath import System.IO.Error import Text.ParserCombinators.ReadP (readP_to_S)-import Prettyprinter+import Data.Functor.Contravariant  import qualified Data.Text as T @@ -42,18 +42,13 @@ import qualified Hie.Locate as Implicit import qualified Hie.Yaml as Implicit -import GHC.Debugger.Logger+import Colog.Core -data FlagsLog+data SessionSetupLog   = HieBiosLog HIE.Log   | LogCradle (HIE.Cradle Void)   | LogSetupMsg T.Text--instance Pretty FlagsLog where-  pretty = \ case-    HieBiosLog msg -> pretty msg-    LogCradle crdl -> "Determined Cradle:" <+> viaShow crdl-    LogSetupMsg txt -> pretty txt+  deriving Show  -- | Flags inferred by @hie-bios@ to invoke GHC data HieBiosFlags = HieBiosFlags@@ -69,49 +64,48 @@       }  -- | Prepare a GHC session using hie-bios from scratch-hieBiosSetup :: Recorder (WithSeverity FlagsLog)+hieBiosSetup :: LogAction IO (WithSeverity SessionSetupLog)              -> FilePath -- ^ project root              -> FilePath -- ^ entry file              -> ExceptT String IO (Either String HieBiosFlags) hieBiosSetup logger projectRoot entryFile = do -  logT "Figuring out the right flags to compile the project using hie-bios..."+  logInfo "Figuring out the right flags to compile the project using hie-bios..."   cradle <- hieBiosCradle logger projectRoot entryFile & ExceptT    -- GHC is found in PATH (by hie-bios as well).-  logT "Checking GHC version against debugger version..."-  _version <- hieBiosRuntimeGhcVersion logger cradle+  logInfo "Checking GHC version against debugger version..."+  _version <- hieBiosRuntimeGhcVersion cradle -  logT "Discovering session flags with hie-bios..."-  r <- hieBiosFlags logger cradle projectRoot entryFile     & liftIO+  logInfo "Discovering session flags with hie-bios..."+  r <- hieBiosFlags cradle projectRoot entryFile     & liftIO -  logT "Session setup with hie-bios was successful."+  logInfo "Session setup with hie-bios was successful."   return r    where-    logT = logWith logger Info . LogSetupMsg . T.pack+    logInfo m = liftLogIO logger <& WithSeverity (LogSetupMsg (T.pack m)) Info  -- | Try implicit-hie and the builtin search to come up with a @'HIE.Cradle'@-hieBiosCradle :: Recorder (WithSeverity FlagsLog) {-^ Logger -}-              -> FilePath {-^ Project root -}-              -> FilePath {-^ Entry file relative to root -}+hieBiosCradle :: LogAction IO (WithSeverity SessionSetupLog)+              -> FilePath -- ^ Project root+              -> FilePath -- ^ Entry file relative to root               -> IO (Either String (HIE.Cradle Void)) hieBiosCradle logger root relTarget = runExceptT $ do   let target = root </> relTarget   explicitCradle <- HIE.findCradle target & liftIO   cradle <- maybe (loadImplicitCradle hieBiosLogger target)                   (HIE.loadCradle hieBiosLogger) explicitCradle & liftIO-  logWith logger Info $ LogCradle cradle+  liftLogIO logger <& WithSeverity (LogCradle cradle) Info   pure cradle   where-    hieBiosLogger = toCologAction $ cmapWithSev HieBiosLog logger+    hieBiosLogger = contramap (fmap HieBiosLog) logger  -- | Fetch the runtime GHC version, according to hie-bios, and check it is the -- same as the compile time GHC version-hieBiosRuntimeGhcVersion :: Recorder (WithSeverity FlagsLog)-                         -> HIE.Cradle Void+hieBiosRuntimeGhcVersion :: HIE.Cradle Void                          -> ExceptT String IO Version-hieBiosRuntimeGhcVersion _logger cradle = do+hieBiosRuntimeGhcVersion cradle = do   out <- liftIO (HIE.getRuntimeGhcVersion cradle) >>= unwrapCradleResult "Failed to get runtime GHC version"    case versionMaybe out of@@ -129,12 +123,11 @@       pure actualVersion  -- | Make 'HieBiosFlags' from the given target file-hieBiosFlags :: Recorder (WithSeverity FlagsLog) {-^ Logger -}-             -> HIE.Cradle Void {-^ Project cradle the entry file belongs to -}+hieBiosFlags :: HIE.Cradle Void {-^ Project cradle the entry file belongs to -}              -> FilePath {-^ Project root -}              -> FilePath {-^ Entry file relative to root -}              -> IO (Either String HieBiosFlags)-hieBiosFlags _logger cradle root relTarget = runExceptT $ do+hieBiosFlags cradle root relTarget = runExceptT $ do   let target = root </> relTarget   libdir <- liftIO (HIE.getRuntimeGhcLibDir cradle) >>= unwrapCradleResult "Failed to get runtime GHC libdir" 

@@ -1,6 +1,9 @@-{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, CPP, DeriveAnyClass, DeriveGeneric, DerivingVia, LambdaCase, RecordWildCards, ViewPatterns #-}+{-# LANGUAGE OverloadedStrings, OverloadedRecordDot, CPP, DeriveAnyClass,+   DeriveGeneric, DerivingVia, LambdaCase, RecordWildCards, ViewPatterns,+   DataKinds #-} module Main where +import System.Process import System.Environment import Data.Maybe import Data.IORef@@ -9,6 +12,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Except+import Control.Exception (uninterruptibleMask) import Control.Exception.Backtrace  import DAP@@ -18,17 +22,27 @@ import Development.Debug.Adapter.Stepping import Development.Debug.Adapter.Stopped import Development.Debug.Adapter.Evaluation+import Development.Debug.Adapter.ExceptionInfo import Development.Debug.Adapter.Exit import Development.Debug.Adapter.Handles-import GHC.Debugger.Logger-import Prettyprinter+import Colog.Core -import System.IO (hSetBuffering, BufferMode(LineBuffering))+import Data.Time+import System.IO (hSetBuffering, BufferMode(LineBuffering), Handle, openFile, IOMode(ReadMode)) import qualified DAP.Log as DAP+import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.IO as T import GHC.IO.Handle.FD+import Data.Functor.Contravariant +import qualified GHCi.Server as GHCi+import qualified GHCi.Signals as GHCi+import qualified GHCi.Utils as GHCi+import qualified GHCi.Message as GHCi++import GHC.Utils.Logger (defaultLogActionWithHandles)+import GHC.Debugger.Monad (DebuggerLog(..), RunDebuggerSettings(..)) import Development.Debug.Options (HdbOptions(..)) import Development.Debug.Options.Parser (parseHdbOptions) import Development.Debug.Adapter@@ -37,45 +51,78 @@  -------------------------------------------------------------------------------- -defaultStdoutForwardingAction :: T.Text -> IO ()-defaultStdoutForwardingAction l = do-  T.hPutStrLn stderr ("[INTERCEPTED STDOUT] " <> l)- main :: IO () main = do   setBacktraceMechanismState CostCentreBacktrace False   setBacktraceMechanismState HasCallStackBacktrace True-  setBacktraceMechanismState IPEBacktrace True+  setBacktraceMechanismState IPEBacktrace False -- TODO: True, see #181 -  hdbOpts <- parseHdbOptions-  let-    timeStampLogger  = cmapIO renderWithTimestamp . fromCologAction-    loggerWithSev    = cmap renderPrettyWithSeverity-    loggerFinal opts = applyVerbosity opts.verbosity . loggerWithSev . timeStampLogger+  allArgs <- getArgs+  hdbOpts <- case allArgs of+    [writeFd, readFd, "--external-interpreter"] ->+         -- Special case to detect --external-interpreter in the third+         -- position. If we could specify -opti options to put *before* the+         -- descriptors we could get rid of this.+         pure (HdbExternalInterpreter (read writeFd) (read readFd))+    _ -> parseHdbOptions   case hdbOpts of-    HdbDAPServer{port} -> do+    HdbDAPServer{port, internalInterpreter} -> do       config <- getConfig port-      withInterceptedStdoutForwarding defaultStdoutForwardingAction $ \realStdout -> do+      redirectRealStdout internalInterpreter $ \realStdout -> do         hSetBuffering realStdout LineBuffering-        l <- handleLogger realStdout-        let dapLogger = cmap DAP.renderDAPLog $ timeStampLogger l-        let runLogger = loggerFinal hdbOpts l+        l <- mainLogger hdbOpts.verbosity realStdout         init_var <- liftIO (newIORef False{-not supported by default-})         pid_var  <- liftIO (newIORef Nothing)         ccon_var <- liftIO newEmptyMVar-        runDAPServerWithLogger (toCologAction dapLogger) config-          (talk runLogger init_var pid_var ccon_var)-          (ack runLogger pid_var)+        runDAPServerWithLogger (contramap DAPLibraryLog l) config+          (talk l init_var pid_var ccon_var internalInterpreter)+          (ack l pid_var)     HdbCLI{..} -> do-        l <- handleLogger stdout-        let runLogger = cmapWithSev InteractiveLog $ loggerFinal hdbOpts l-        runIDM runLogger entryPoint entryFile entryArgs extraGhcArgs $-          debugInteractive runLogger+        l <- mainLogger hdbOpts.verbosity stdout+        stdinStream <- case debuggeeStdin of+          Just fp -> UseHandle <$> System.IO.openFile fp ReadMode+          Nothing -> pure Inherit+        let runConf = RunDebuggerSettings+              { supportsANSIStyling = True -- todo: check!!+              , supportsANSIHyperlinks = False+              , preferInternalInterpreter = internalInterpreter+              , externalInterpreterStdinStream = stdinStream+              }+        runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs+          runConf debugInteractive     HdbProxy{port} -> do-        l <- handleLogger stdout-        let runLogger = cmapWithSev RunProxyClientLog $ loggerFinal hdbOpts l-        runInTerminalHdbProxy runLogger port+        l <- mainLogger hdbOpts.verbosity stdout+        runInTerminalHdbProxy (contramap RunProxyClientLog l) port+    HdbExternalInterpreter{writeFd, readFd} -> do+      inh  <- GHCi.readGhcHandle (show readFd)+      outh <- GHCi.readGhcHandle (show writeFd)+      GHCi.installSignalHandlers+      pipe <- GHCi.mkPipeFromHandles inh outh+      let verbose = False+      uninterruptibleMask $ GHCi.serv verbose hook pipe+      where hook = return -- empty hook+        -- we cannot allow any async exceptions while communicating, because+        -- we will lose sync in the protocol, hence uninterruptibleMask.+  where+    -- When using the internal interpreter in DAP mode, we can't write to+    -- stdout directly because there will also be a thread forwarding the+    -- debuggee stdout by capturing it from stdout (and we'd get into a loop+    -- trying to forward what we're writing).+    --+    -- The redirection we use requires hDuplicateTo which isn't supported on+    -- Windows (ghc#22146), so using the internal interpreter on Windows+    -- currently unsupported.+    --+    -- When using the external interpreter, the debuggee output is read from+    -- its process handle directly, so this is unnecessary.+    redirectRealStdout internalInterpreter k+      | internalInterpreter =+        withInterceptedStdoutForwarding+          (\interceptedOut -> T.hPutStrLn stderr ("[INTERCEPTED STDOUT] " <> interceptedOut))+          (\realStdout -> k realStdout)+      | otherwise = k stdout + -- | Fetch config from environment, fallback to sane defaults getConfig :: Int -> IO ServerConfig getConfig port = do@@ -115,7 +162,7 @@       , supportsRestartRequest                = False       , supportsExceptionOptions              = True       , supportsValueFormattingOptions        = True-      , supportsExceptionInfoRequest          = False+      , supportsExceptionInfoRequest          = True       , supportTerminateDebuggee              = True       , supportSuspendDebuggee                = False       , supportsDelayedStackTraceLoading      = False@@ -148,25 +195,10 @@ -- * Talk -------------------------------------------------------------------------------- -data MainLog-  = InitLog InitLog-  | LaunchLog T.Text-  | InteractiveLog InteractiveLog-  | RunProxyServerLog ProxyLog-  | RunProxyClientLog ProxyLog--instance Pretty MainLog where-  pretty = \ case-    InitLog msg -> pretty msg-    LaunchLog msg -> pretty msg-    InteractiveLog msg -> pretty msg-    RunProxyServerLog msg -> pretty ("Proxy Server:" :: String) <+> pretty msg-    RunProxyClientLog msg -> pretty ("Proxy Client:" :: String) <+> pretty msg- -- | Main function where requests are received and Events + Responses are returned. -- The core logic of communicating between the client <-> adaptor <-> debugger -- is implemented in this function.-talk :: Recorder (WithSeverity MainLog)+talk :: LogAction IO MainLog      -> IORef Bool      -- ^ Whether the client supports runInTerminal      -> IORef (Maybe Int)@@ -174,9 +206,11 @@      -> MVar ()      -- ^ A var to block on waiting for the proxy client to connect, if a proxy      -- connection is expected. See #95.+     -> Bool+     -- ^ Prefer internal interpreter      -> Command -> DebugAdaptor () ---------------------------------------------------------------------------------talk l support_rit_var _pid_var client_proxy_signal = \ case+talk l support_rit_var _pid_var client_proxy_signal prefer_internal_interpreter = \ case   CommandInitialize -> do     InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments     let runInTerminal = fromMaybe False supportsRunInTerminalRequest@@ -186,14 +220,16 @@     -- If runInTerminal is not supported by the client, signal readiness right away     when (not runInTerminal) $       liftIO $ putMVar client_proxy_signal ()- --------------------------------------------------------------------------------   CommandLaunch -> do     launch_args <- getArguments      supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var -    merror <- runExceptT $ initDebugger (cmapWithSev InitLog l) supportsRunInTerminalRequest launch_args+    merror <- runExceptT $+      initDebugger (contramap DAPLog l)+        supportsRunInTerminalRequest prefer_internal_interpreter+        launch_args     case merror of       Right () -> do         sendLaunchResponse   -- ack@@ -204,9 +240,9 @@         when supportsRunInTerminalRequest $ do           -- Run proxy thread, server side, and           -- send the 'runInTerminal' request-          serverSideHdbProxy (cmapWithSev RunProxyServerLog l) client_proxy_signal+          serverSideHdbProxy (contramap RunProxyServerLog l) client_proxy_signal -        logWith l Info $ LaunchLog $ T.pack "Debugger launched successfully."+        liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info)        Left (InitFailed err) -> do         sendErrorResponse (ErrorMessage (T.pack err)) Nothing@@ -220,6 +256,7 @@   CommandSetBreakpoints            -> commandSetBreakpoints   CommandSetFunctionBreakpoints    -> commandSetFunctionBreakpoints   CommandSetExceptionBreakpoints   -> commandSetExceptionBreakpoints+  CommandExceptionInfo             -> commandExceptionInfo   CommandSetDataBreakpoints        -> undefined   CommandSetInstructionBreakpoints -> undefined ----------------------------------------------------------------------------@@ -267,13 +304,82 @@ ----------------------------------------------------------------------------  -- | Receive reverse request responses (such as runInTerminal response)-ack :: Recorder (WithSeverity MainLog)+ack :: LogAction IO MainLog     -> IORef (Maybe Int)     -- ^ Reference to PID of runInTerminal proxy process running     -> ReverseRequestResponse -> DebugAdaptorCont () ack l _ref rrr = case rrr.reverseRequestCommand of   ReverseCommandRunInTerminal -> do     when rrr.success $ do-      logWith l Info $ LaunchLog $ T.pack "RunInTerminal was successful"+      liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "RunInTerminal was successful") Info)   _ -> pure () +--------------------------------------------------------------------------------+-- * Logging+--------------------------------------------------------------------------------++data MainLog+  = DAPLog DAPLog+  | InteractiveLog InteractiveLog+  | RunProxyServerLog (WithSeverity T.Text)+  | RunProxyClientLog (WithSeverity T.Text)+  | DAPLaunchLog (WithSeverity T.Text)+  | DAPLibraryLog DAP.DAPLog++-- | Given the severity threshold from which we start logging, create a base+-- logger for consuming the top-level debugger logs ('MainLog').+-- Outputs to given handle.+mainLogger :: Severity -> Handle -> IO (LogAction IO MainLog)+mainLogger threshold h = do+  l <- handleLogger h+  let+    logSessionLog (WithSeverity msg sev)+      | sev >= threshold =+        cmapM renderWithTimestamp l <& (renderSeverity sev <> T.pack (show msg))+      | otherwise = pure ()++    logDebuggerLog = \case+      DebuggerLog sev msg+        | sev >= threshold ->+          cmapM renderWithTimestamp l <&+            (renderSeverity sev <> T.pack (show msg))+      GHCLog logflags msg_class srcSpan msg ->+        defaultLogActionWithHandles h h logflags msg_class srcSpan msg+      LogDebuggeeOut out ->+        -- If we wanted, we could log the debuggee output differently if we are+        -- on the DAP debug mode vs, say, hdb.+        l <& out+      LogDebuggeeErr err -> l <& err+      _ -> pure ()++    defaultLog (WithSeverity msg sev)+      | sev >= threshold =+        cmapM renderWithTimestamp l <& (renderSeverity sev <> msg)+      | otherwise = pure ()++  pure $ LogAction $ \case+    DAPLog (DAPSessionSetupLog sessionLog)       -> logSessionLog sessionLog+    DAPLog (DAPDebuggerLog debuggerLog)          -> logDebuggerLog debuggerLog+    InteractiveLog (ISessionSetupLog sessionLog) -> logSessionLog sessionLog+    InteractiveLog (IDebuggerLog debuggerLog)    -> logDebuggerLog debuggerLog+    RunProxyServerLog sev_msg -> defaultLog sev_msg+    RunProxyClientLog sev_msg -> defaultLog sev_msg+    DAPLaunchLog sev_msg      -> defaultLog sev_msg+    DAPLibraryLog t ->+      l <& DAP.renderDAPLog t+  where+    renderSeverity :: Severity -> Text+    renderSeverity = \ case+      Debug -> "[DEBUG] "+      Info -> "[INFO] "+      Warning -> "[WARNING] "+      Error -> "[ERROR] "++    renderWithTimestamp :: Text -> IO Text+    renderWithTimestamp msg = do+      t <- getCurrentTime+      let timeStamp = utcTimeToText t+      pure $ "[" <> timeStamp <> "] " <> msg+      where+        utcTimeToText utcTime = T.pack $+          formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%6QZ" utcTime

@@ -1,6 +1,8 @@ {-# LANGUAGE LambdaCase, OverloadedStrings, ViewPatterns, QuasiQuotes, CPP #-} module Main (main) where +import Data.List (isSuffixOf)+import qualified Data.Set as Set import Text.RE.TDFA.Text.Lazy import Text.Printf import qualified Data.Text.Lazy as LT@@ -9,9 +11,11 @@ import qualified Data.ByteString.Lazy.Char8 as LBS import qualified System.Process as P import System.FilePath+import qualified System.FilePath.Posix as Posix import System.IO.Temp import System.Exit import System.IO+import System.Environment import Control.Exception  import Test.Tasty@@ -24,13 +28,33 @@  main :: IO () main = do-  goldens <- mapM (mkGoldenTest False) =<< findByExtension [".hdb-test"] "test/golden"+  env <- getEnvironment+  let mkTest = mkGoldenTest False env+  golden_tests_paths <- findByExtension [".hdb-test"] "test/golden"++  let internalOnlyTests = filter (\p -> ".internal" `isSuffixOf` takeBaseName p) golden_tests_paths+  let externalOnlyTests = filter (\p -> ".external" `isSuffixOf` takeBaseName p) golden_tests_paths++  let internalOnlySet = Set.fromList internalOnlyTests+  let externalOnlySet = Set.fromList externalOnlyTests+  let allTestsSet     = Set.fromList golden_tests_paths++  let defaultTestsSet = allTestsSet `Set.difference` (internalOnlySet `Set.union` externalOnlySet)++  let testsForInternal = Set.toList $ internalOnlySet `Set.union` defaultTestsSet+  let testsForExternal = Set.toList $ externalOnlySet `Set.union` defaultTestsSet++  default_goldens   <- mapM (mkTest "") testsForExternal+  intinterp_goldens <- mapM (mkTest "--internal-interpreter") testsForInternal+   defaultMain $+    testGroup "Tests"+      [ testGroup "Golden tests" default_goldens+      , #ifdef mingw32_HOST_OS-    ignoreTestBecause "Testsuite is not enabled on Windows (#149)" $+        ignoreTestBecause "Internal interpreter is not supported on Windows (#149 / ghc#22146)" $ #endif-    testGroup "Tests"-      [ testGroup "Golden tests" goldens+        testGroup "Golden tests (--internal-interpreter)" intinterp_goldens       , testGroup "Unit tests" unitTests       ] @@ -40,23 +64,28 @@   ]  -- | Receives as an argument the path to the @*.hdb-test@ which contains the--- shell invocation for running -mkGoldenTest :: Bool -> FilePath -> IO TestTree-mkGoldenTest keepTmpDirs path = do+-- shell invocation for running+mkGoldenTest :: Bool -> [(String, String)] -> FilePath -> String -> IO TestTree+mkGoldenTest keepTmpDirs inheritedEnv flags path = do   let testName   = takeBaseName     path   let goldenPath = replaceExtension path ".hdb-stdout"-  return (goldenVsStringComparing testName goldenPath action)+  return $ goldenVsStringComparing testName goldenPath action   where     action :: IO LBS.ByteString     action = do-      script <- readFile path       withHermeticDir keepTmpDirs (takeDirectory path) $ \test_dir -> do         (_, Just hout, _, p)-          <- P.createProcess (P.shell script){P.cwd = Just test_dir, P.std_out = P.CreatePipe}+          <- P.createProcess (P.proc "sh" [takeFileName path])+            { P.cwd = Just test_dir, P.std_out = P.CreatePipe+            , P.env = Just $+              inheritedEnv +++              [ ("HDB", "hdb " ++ flags)+              ]+            }         P.waitForProcess p >>= \case           ExitSuccess   -> LBS.hGetContents hout           ExitFailure c -> error $ "Test script in " ++ test_dir ++ " failed with exit code: " ++ show c-        + -------------------------------------------------------------------------------- -- Tasty Golden Advanced wrapper --------------------------------------------------------------------------------@@ -79,17 +108,44 @@   where   upd = createDirectoriesAndWriteFile ref . LT.encodeUtf8 +  escapePathSeparators c =+    if isPathSeparator c+      then "\\" ++ [c]+      else [c]++  useForwardSlashes =+    fmap useForwardSlash++  useForwardSlash c =+    if c == '\\'+      then '/'+      else c++  escapeRegex :: String -> String+  escapeRegex = concatMap escapePathSeparators+   -- Normalise the action producing the output   normalisingAct = do     tmpDir <- getCanonicalTemporaryDirectory+    let+      winTempDirWithForwardSlashes = useForwardSlashes tmpDir+    let posixTempDirRegex =+          escapeRegex $+            Posix.joinPath $+              [ winTempDirWithForwardSlashes+              , "[^/\\]+"+              , takeBaseName (takeDirectory ref)+              ]     replaceREs <- traverse (uncurry compileSearchReplace)-      [ ( tmpDir ++ ".*" ++ takeBaseName (takeDirectory ref) {- the folder in which the test is run, inside the canonical temp dir-}-        , "<TEMPORARY-DIRECTORY>" )-      , ( "Using cabal specification: .*"+      [ ( "Using cabal specification: .*"         , "Using cabal specification: <VERSION>" )-      ]+      , ( "\\\\\\\\", "/" ) -- Use forward slash+      , ( "\\\\", "/" )     -- Use forward slash+      , ( posixTempDirRegex {- the folder in which the test is run, inside the canonical temp dir-}+        , "<TEMPORARY-DIRECTORY>" )+     ] -    let normalising (LT.decodeUtf8 -> txt) = foldl' (*=~/) txt replaceREs+    let normalising (LT.decodeUtf8 -> txt) = LT.filter (/= '\r') $ foldl' (*=~/) txt replaceREs      normalising <$> act @@ -125,6 +181,6 @@             hFlush yH             hClose xH             hClose yH-            (_exitCode, out, err) <- P.readProcessWithExitCode "diff" ["-u", xf, yf] ""+            (_exitCode, out, err) <- P.readProcessWithExitCode "diff"+              ["-u", xf, yf] ""             return $ Just $ msg ++ "\nDiff output:\n" ++ out ++ err-

@@ -32,13 +32,16 @@ #ifdef mingw32_HOST_OS       ignoreTestBecause "Needs to be fixed for Windows" $ #endif-      testCase "runInTerminal: proxy forwards stdin correctly" runInTerminal1+      testGroup "runInTerminal: proxy forwards stdin correctly"+        [ testCase "(default)" (runInTerminal1 "")+        , testCase "(--internal-interpreter)" (runInTerminal1 "--internal-interpreter")+        ]     ]  rit_keep_tmp_dirs :: Bool rit_keep_tmp_dirs = False -runInTerminal1 = do+runInTerminal1 flags = do   withHermeticDir rit_keep_tmp_dirs "test/unit/T44" $ \test_dir -> do      -- Come up with a random port@@ -46,7 +49,7 @@      -- Launch server process     (Just hin, Just hout, _, p)-      <- P.createProcess (P.shell $ "hdb server --port " ++ show testPort)+      <- P.createProcess (P.shell $ "hdb server " ++ flags ++ " --port " ++ show testPort)           {P.cwd = Just test_dir, P.std_out = P.CreatePipe, P.std_in = P.CreatePipe}      -- Fork thread to print out output of server process@@ -60,7 +63,8 @@               then return ()               else do                 _l <- hGetLine hout-                -- putStrLn ("[server] " ++ l)+                -- UNCOMMENT ME TO DEBUG+                -- putStrLn ("[server] " ++ _l)                 loop       loop