diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) ``` diff --git a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs --- a/haskell-debugger-view/src/GHC/Debugger/View/Class.hs +++ b/haskell-debugger-view/src/GHC/Debugger/View/Class.hs @@ -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] - diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -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 diff --git a/haskell-debugger/GHC/Debugger.hs b/haskell-debugger/GHC/Debugger.hs --- a/haskell-debugger/GHC/Debugger.hs +++ b/haskell-debugger/GHC/Debugger.hs @@ -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 - diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs --- a/haskell-debugger/GHC/Debugger/Breakpoint.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Interface/Messages.hs b/haskell-debugger/GHC/Debugger/Interface/Messages.hs --- a/haskell-debugger/GHC/Debugger/Interface/Messages.hs +++ b/haskell-debugger/GHC/Debugger/Interface/Messages.hs @@ -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 - diff --git a/haskell-debugger/GHC/Debugger/Logger.hs b/haskell-debugger/GHC/Debugger/Logger.hs deleted file mode 100644 --- a/haskell-debugger/GHC/Debugger/Logger.hs +++ /dev/null @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -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 --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 diff --git a/haskell-debugger/GHC/Debugger/Run.hs b/haskell-debugger/GHC/Debugger/Run.hs --- a/haskell-debugger/GHC/Debugger/Run.hs +++ b/haskell-debugger/GHC/Debugger/Run.hs @@ -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?!" diff --git a/haskell-debugger/GHC/Debugger/Runtime.hs b/haskell-debugger/GHC/Debugger/Runtime.hs --- a/haskell-debugger/GHC/Debugger/Runtime.hs +++ b/haskell-debugger/GHC/Debugger/Runtime.hs @@ -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 - diff --git a/haskell-debugger/GHC/Debugger/Runtime/Compile.hs b/haskell-debugger/GHC/Debugger/Runtime/Compile.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Compile.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Compile.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Eval.hs b/haskell-debugger/GHC/Debugger/Runtime/Eval.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Eval.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Eval.hs @@ -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 ---------------------------------------------- diff --git a/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs b/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr.hs @@ -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) diff --git a/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs b/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Eval/RemoteExpr/Builtin.hs @@ -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"] diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Instances.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs b/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Instances/Discover.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs b/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs deleted file mode 100644 --- a/haskell-debugger/GHC/Debugger/Runtime/Term/Cache.hs +++ /dev/null @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs b/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Term/Key.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs b/haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Term/Parser.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Thread.hs b/haskell-debugger/GHC/Debugger/Runtime/Thread.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Thread.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Thread.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs b/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs --- a/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs +++ b/haskell-debugger/GHC/Debugger/Runtime/Thread/Stack.hs @@ -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) diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -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. diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -160,4 +160,3 @@ -- | GHC.Debugger.View.ByteString debuggerViewByteStringContents :: StringBuffer debuggerViewByteStringContents = stringToStringBuffer $(embedStringFile "haskell-debugger-view/src/GHC/Debugger/View/ByteString.hs") - diff --git a/haskell-debugger/GHC/Debugger/Stopped.hs b/haskell-debugger/GHC/Debugger/Stopped.hs --- a/haskell-debugger/GHC/Debugger/Stopped.hs +++ b/haskell-debugger/GHC/Debugger/Stopped.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 diff --git a/haskell-debugger/GHC/Debugger/Stopped/Exception.hs b/haskell-debugger/GHC/Debugger/Stopped/Exception.hs new file mode 100644 --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Stopped/Exception.hs @@ -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 "" 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) diff --git a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs --- a/haskell-debugger/GHC/Debugger/Stopped/Variables.hs +++ b/haskell-debugger/GHC/Debugger/Stopped/Variables.hs @@ -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 diff --git a/haskell-debugger/GHC/Debugger/Utils.hs b/haskell-debugger/GHC/Debugger/Utils.hs --- a/haskell-debugger/GHC/Debugger/Utils.hs +++ b/haskell-debugger/GHC/Debugger/Utils.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter.hs b/hdb/Development/Debug/Adapter.hs --- a/hdb/Development/Debug/Adapter.hs +++ b/hdb/Development/Debug/Adapter.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Breakpoints.hs b/hdb/Development/Debug/Adapter/Breakpoints.hs --- a/hdb/Development/Debug/Adapter/Breakpoints.hs +++ b/hdb/Development/Debug/Adapter/Breakpoints.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Evaluation.hs b/hdb/Development/Debug/Adapter/Evaluation.hs --- a/hdb/Development/Debug/Adapter/Evaluation.hs +++ b/hdb/Development/Debug/Adapter/Evaluation.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/ExceptionInfo.hs b/hdb/Development/Debug/Adapter/ExceptionInfo.hs new file mode 100644 --- /dev/null +++ b/hdb/Development/Debug/Adapter/ExceptionInfo.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Handles.hs b/hdb/Development/Debug/Adapter/Handles.hs --- a/hdb/Development/Debug/Adapter/Handles.hs +++ b/hdb/Development/Debug/Adapter/Handles.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Proxy.hs b/hdb/Development/Debug/Adapter/Proxy.hs --- a/hdb/Development/Debug/Adapter/Proxy.hs +++ b/hdb/Development/Debug/Adapter/Proxy.hs @@ -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 diff --git a/hdb/Development/Debug/Adapter/Stepping.hs b/hdb/Development/Debug/Adapter/Stepping.hs --- a/hdb/Development/Debug/Adapter/Stepping.hs +++ b/hdb/Development/Debug/Adapter/Stepping.hs @@ -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 + } diff --git a/hdb/Development/Debug/Adapter/Stopped.hs b/hdb/Development/Debug/Adapter/Stopped.hs --- a/hdb/Development/Debug/Adapter/Stopped.hs +++ b/hdb/Development/Debug/Adapter/Stopped.hs @@ -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 diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -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: " + -------------------------------------------------------------------------------- -- 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: " + 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 with some args -- (DebugExecution <$> parseEntry <*> parseSomeArgs) -- --entry 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 -> diff --git a/hdb/Development/Debug/Options.hs b/hdb/Development/Debug/Options.hs --- a/hdb/Development/Debug/Options.hs +++ b/hdb/Development/Debug/Options.hs @@ -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 @ + -- | @server [--internal-interpreter] --port @ = HdbDAPServer { port :: Int - , verbosity :: Verbosity + , verbosity :: Severity + , internalInterpreter :: Bool } - -- | @cli [--entry-point=] [--extra-ghc-args=""] [] -- []@ + -- | @cli [--internal-interpreter] [--entry-point=] [--extra-ghc-args=""] [] -- []@ | HdbCLI { entryPoint :: String , entryFile :: FilePath , entryArgs :: [String] , extraGhcArgs :: [String] - , verbosity :: Verbosity + , verbosity :: Severity + , internalInterpreter :: Bool + , debuggeeStdin :: Maybe FilePath } -- | @proxy --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 + } diff --git a/hdb/Development/Debug/Options/Parser.hs b/hdb/Development/Debug/Options/Parser.hs --- a/hdb/Development/Debug/Options/Parser.hs +++ b/hdb/Development/Debug/Options/Parser.hs @@ -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 + `: 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 @ +-- 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 diff --git a/hdb/Development/Debug/Session/Setup.hs b/hdb/Development/Debug/Session/Setup.hs --- a/hdb/Development/Debug/Session/Setup.hs +++ b/hdb/Development/Debug/Session/Setup.hs @@ -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" diff --git a/hdb/Main.hs b/hdb/Main.hs --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -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 diff --git a/test/haskell/Main.hs b/test/haskell/Main.hs --- a/test/haskell/Main.hs +++ b/test/haskell/Main.hs @@ -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-} - , "" ) - , ( "Using cabal specification: .*" + [ ( "Using cabal specification: .*" , "Using cabal specification: " ) - ] + , ( "\\\\\\\\", "/" ) -- Use forward slash + , ( "\\\\", "/" ) -- Use forward slash + , ( posixTempDirRegex {- the folder in which the test is run, inside the canonical temp dir-} + , "" ) + ] - 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 - diff --git a/test/haskell/Test/DAP/RunInTerminal.hs b/test/haskell/Test/DAP/RunInTerminal.hs --- a/test/haskell/Test/DAP/RunInTerminal.hs +++ b/test/haskell/Test/DAP/RunInTerminal.hs @@ -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