From b034cc3ec5734e5b0c44e595397c3ea099e9231e Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Mon, 6 Jul 2026 14:54:22 +0200 Subject: [PATCH 1/5] [Fix #266] Add InterpreterSettings/DAPDebuggee interface --- haskell-debugger.cabal | 2 + haskell-debugger/GHC/Debugger/Debuggee.hs | 267 ++++++++++++++++++ haskell-debugger/GHC/Debugger/Monad.hs | 221 +-------------- haskell-debugger/GHC/Debugger/Session.hs | 7 +- hdb-dap/Development/Debug/Adapter.hs | 5 +- .../Development/Debug/Adapter/DAPDebuggee.hs | 222 +++++++++++++++ hdb-dap/Development/Debug/Adapter/Init.hs | 241 +++------------- hdb-dap/Development/Debug/Adapter/Proxy.hs | 28 +- hdb-dap/Development/Debug/Adapter/Server.hs | 14 +- hdb/Development/Debug/Interactive.hs | 1 + hdb/Main.hs | 16 +- test/golden/T130/T130.ghc-1001.hdb-stdout | 1 - test/golden/T130/T130.ghc-914.hdb-stdout | 1 - test/golden/T130/T130.hdb-test | 2 +- ...dout => T154.external.ghc-1001.hdb-stdout} | 0 ...tdout => T154.external.ghc-914.hdb-stdout} | 0 ...tdout => T154.external.ghc-915.hdb-stdout} | 0 .../{T154.hdb-test => T154.external.hdb-test} | 0 ...dout => T169.internal.ghc-1001.hdb-stdout} | 0 ...tdout => T169.internal.ghc-914.hdb-stdout} | 0 ...tdout => T169.internal.ghc-915.hdb-stdout} | 0 .../{T169.hdb-test => T169.internal.hdb-test} | 0 22 files changed, 571 insertions(+), 457 deletions(-) create mode 100644 haskell-debugger/GHC/Debugger/Debuggee.hs create mode 100644 hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs rename test/golden/T154/{T154.ghc-1001.hdb-stdout => T154.external.ghc-1001.hdb-stdout} (100%) rename test/golden/T154/{T154.ghc-914.hdb-stdout => T154.external.ghc-914.hdb-stdout} (100%) rename test/golden/T154/{T154.ghc-915.hdb-stdout => T154.external.ghc-915.hdb-stdout} (100%) rename test/golden/T154/{T154.hdb-test => T154.external.hdb-test} (100%) rename test/golden/T169/{T169.ghc-1001.hdb-stdout => T169.internal.ghc-1001.hdb-stdout} (100%) rename test/golden/T169/{T169.ghc-914.hdb-stdout => T169.internal.ghc-914.hdb-stdout} (100%) rename test/golden/T169/{T169.ghc-915.hdb-stdout => T169.internal.ghc-915.hdb-stdout} (100%) rename test/golden/T169/{T169.hdb-test => T169.internal.hdb-test} (100%) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 45e3b55b..c0ecd65a 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -104,6 +104,7 @@ library GHC.Debugger.Runtime.Interpreter.Custom, GHC.Debugger.Monad, + GHC.Debugger.Debuggee, GHC.Debugger.Utils, GHC.Debugger.Utils.Orphans, @@ -163,6 +164,7 @@ library dap-server Development.Debug.Adapter.Stopped, Development.Debug.Adapter.Evaluation, Development.Debug.Adapter.ExceptionInfo, + Development.Debug.Adapter.DAPDebuggee, Development.Debug.Adapter.Init, Development.Debug.Adapter.Interface, Development.Debug.Adapter.Output, diff --git a/haskell-debugger/GHC/Debugger/Debuggee.hs b/haskell-debugger/GHC/Debugger/Debuggee.hs new file mode 100644 index 00000000..50b0638e --- /dev/null +++ b/haskell-debugger/GHC/Debugger/Debuggee.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE MultilineStrings #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NondecreasingIndentation #-} +module GHC.Debugger.Debuggee where + +import System.Process +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Control.Monad.IO.Class +import Data.Function +import Data.Functor.Contravariant +import Data.Maybe +import Prelude hiding (mod) +import Data.Text (Text) +import Network.Socket hiding (Debug) +import System.Process.Internals (mkProcessHandle) +import Text.Read (readMaybe) + +import GHC +import GHC.Driver.Env as GHC +import GHC.Driver.Monad +import GHC.Driver.Hooks +import GHC.Driver.Ppr +import GHC.Runtime.Interpreter as GHCi +import GHC.Types.Error +import qualified GHC.Utils.Logger as GHC + +import GHC.Debugger.Session +import GHC.Debugger.Utils + +import Colog.Core as Logger + +import GHCi.Message (mkPipeFromHandles) +import System.IO (hGetLine, IOMode(..), openFile, Handle) +import qualified GHC.Linker.Loader as Loader +import GHC.Stack.Annotation +import GHC.Platform.Ways +#if MIN_VERSION_ghc(9,15,0) +import GHC.Data.FastString.Env (emptyFsEnv) +#endif +import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger` +import System.Environment (getExecutablePath) + +data InterpreterSettings = InterpreterSettings + { interpreterFlags :: DynFlags -> DynFlags + , interpreterSetup :: forall a. LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a + } + +mkInternalInterpreterFlags :: DynFlags -> DynFlags +mkExternalInterpreterFlags :: String -> DynFlags -> DynFlags +(mkInternalInterpreterFlags, mkExternalInterpreterFlags) = (mkInterpreterFlags True "", mkInterpreterFlags False) + where + mkInterpreterFlags :: Bool -> String -> DynFlags -> DynFlags + mkInterpreterFlags preferInternalInterpreter externalInterpreterProg df = df + -- Enable the external interpreter by default! See #169 + -- See Note [Custom external interpreter] + & enableExternalInterpreter 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 externalInterpreterProg + -- 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" + + +mkInternalInterpreterSetup :: LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a +mkInternalInterpreterSetup _ dflags mainGhcThread = do + when (gopt Opt_ExternalInterpreter dflags) $ do + throw $ InconsistentInterpreterFlags $ "Used ghc flag -fexternal-interpreter together with --internal-interpreter haskell-debugger flag." + mainGhcThread + +newtype InconsistentInterpreterFlags = InconsistentInterpreterFlags String +instance Show InconsistentInterpreterFlags where + show (InconsistentInterpreterFlags t) = "Interpreter flags are inconsistent: " ++ t +instance Exception InconsistentInterpreterFlags + + +mkExternalInterpreterFromIOSetup :: IO Interp -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a +mkExternalInterpreterFromIOSetup m _l dflags mainGhcThread = do + unless (gopt Opt_ExternalInterpreter dflags) $ do + throw $ InconsistentInterpreterFlags $ "Used ghc flag -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag." + -- we supply our custom external interpreter process, which is + -- already running and connected to the user's terminal. + extInterp <- liftIO + $ annotateStackStringIO "Waiting for an external interpreter run-in-terminal process" + $ m + modifySession $ \h -> h + { hsc_interp = Just extInterp -- set it directly! + } + + -- Ext interp is running in user terminal, no need to forward output to logger + mainGhcThread + + +mkExternalInterpreterFromStdInSetup :: StdStream -> LogAction IO DebuggerLog -> DynFlags -> Ghc a -> Ghc a +mkExternalInterpreterFromStdInSetup givenStdStream l dflags mainGhcThread = do + unless (gopt Opt_ExternalInterpreter dflags) $ do + throw $ InconsistentInterpreterFlags $ "Used ghc flag -fno-external-interpreter instead of --internal-interpreter haskell-debugger flag." + + (putHandles,fwdThread) <- liftIO $ externalInterpFwdThread l + -- Make sure to override the function which creates the external + -- interpreter, because we need to keep track of the standard handles + 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 = givenStdStream + , 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 $ getPgmI dflags : drop 1 ws + RawCommand _fp args -> RawCommand (getPgmI dflags) args +#endif + } + putHandles (o, e) + return ph + } + } + let + -- We launched the external interpreter as a child process, so forward its output to the logger. + withUnliftGhc $ \ unlift -> annotateCallStackIO $ do + withAsync (annotateCallStackIO $ void $ fwdThread) $ \ fwd_thr -> do + liftIO $ annotateCallStackIO $ link fwd_thr + annotateCallStackIO $ unlift mainGhcThread + +externalInterpFwdThread :: LogAction IO DebuggerLog -> + IO ((Handle, Handle) -> IO (), IO ()) +externalInterpFwdThread l = do + iserv_handles <- liftIO newEmptyMVar + -- The external interpreter is spawned lazily, so we block waiting for + -- the handles to be available in a new thread. + let + fwdThread = takeMVar iserv_handles >>= \ (serv_out, serv_err) -> + concurrently_ + (forwardHandleToLogger serv_err (contramap LogDebuggeeErr l)) + (forwardHandleToLogger serv_out (contramap LogDebuggeeOut l)) + return (putMVar iserv_handles, fwdThread) + +-- | Make an 'ExtInterpInstance' based on an external interpreter process that +-- was launched by the DAP client via 'runInTerminal'. The process sends its +-- own PID as the first line on the socket before the GHCi wire protocol +-- begins. +extInterpFromTerminalProcess :: Socket -> IO Interp +extInterpFromTerminalProcess sock0 = do + port <- socketPort sock0 + putStrLn $ "Connected to " ++ show port + Control.Exception.bracketOnError + (accept sock0) + (\ (sock,_) -> close sock0 >> close sock) + (\ (sock,_) -> do + bi_h <- socketToHandle sock ReadWriteMode + + pidLine <- annotateCallStackIO $ hGetLine bi_h + + pid <- case readMaybe pidLine :: Maybe Int of + Just pid -> pure pid + Nothing -> fail $ "invalid external interpreter PID on socket: " ++ show pidLine + ph <- mkProcessHandle (fromIntegral pid) False + interpPipe <- mkPipeFromHandles bi_h bi_h + lock <- newMVar () + let process = InterpProcess + { interpHandle = ph + , interpPipe + , interpLock = lock + } + + pending_frees <- newMVar [] + let inst = ExtInterpInstance + { instProcess = process + , instPendingFrees = pending_frees + , instExtra = () + } + conf = IServConfig + { iservConfProgram = "the process is already running, we should never need to run it again" + , iservConfOpts = [] + -- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger] + , iservConfDynamic = hostIsDynamic + , iservConfProfiled = hostIsProfiled + , iservConfHook = Nothing -- it's already running! + , iservConfTrace = pure () + } + + lookup_cache <- mkInterpSymbolCache + s <- newMVar $ InterpRunning inst + loader <- Loader.uninitializedLoader +#if MIN_VERSION_ghc(9,15,0) + fs_cache <- newMVar emptyFsEnv + return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache) +#else + return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache) +#endif + ) + +mkCliInterpreterSettings :: Bool -> Maybe FilePath -> IO InterpreterSettings +mkCliInterpreterSettings internalInterpreter debuggeeStdin = do + if internalInterpreter then pure $ InterpreterSettings { interpreterFlags = mkInternalInterpreterFlags + , interpreterSetup = mkInternalInterpreterSetup } else do + stdinStream <- case debuggeeStdin of + Just fp -> UseHandle <$> System.IO.openFile fp ReadMode + Nothing -> pure Inherit + -- the same program invoked with `external-interpreter` serves as the external interpreter + thisProg <- getExecutablePath + pure InterpreterSettings { interpreterFlags = mkExternalInterpreterFlags thisProg + , interpreterSetup = mkExternalInterpreterFromStdInSetup stdinStream + } + +-------------------------------------------------------------------------------- +-- * Logging +-------------------------------------------------------------------------------- + +-- | A debugger log. May include debuggee ouput. +data DebuggerLog + = DebuggerLog !Logger.Severity !DebuggerMessage + | GHCLog !GHC.LogFlags !MessageClass !SrcSpan !SDoc + | LogDebuggeeOut !Text + | LogDebuggeeErr !Text + +-- | A debugger log message +data DebuggerMessage + = LogSDoc !DynFlags !SDoc + | LogFailedToCompileDebugViewModule !GHC.ModuleName + | LogSkippingViewModuleNoPkg !GHC.ModuleName String [String] + +instance Show DebuggerMessage where + show = \ case + LogFailedToCompileDebugViewModule mn -> + "Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views." + LogSkippingViewModuleNoPkg mn pkg uids -> + "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 + + +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 + MCOutput -> Info + MCFatal -> Logger.Error + MCInteractive -> Info + MCDump -> Debug + MCInfo -> Info + MCDiagnostic SevIgnore _ _ -> Debug -- ? + MCDiagnostic SevWarning _ _ -> Logger.Warning + MCDiagnostic SevError _ _ -> Logger.Error diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 6aad63e2..b3330c6b 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -15,9 +15,7 @@ module GHC.Debugger.Monad where -import System.Process import Control.Concurrent -import Control.Concurrent.Async import Control.Exception import qualified Data.Foldable as Foldable import Control.Monad @@ -25,7 +23,6 @@ import Control.Monad.Catch as MC import Control.Monad.IO.Class import Control.Monad.Reader import Data.Function -import Data.Functor.Contravariant import Data.IORef import Data.Maybe import qualified Data.Set as Set @@ -34,12 +31,8 @@ import Prelude hiding (mod) #ifdef MIN_VERSION_unix import System.Posix.Signals #endif -import Data.Text (Text) import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty -import Network.Socket hiding (Debug) -import System.Process.Internals (mkProcessHandle) -import Text.Read (readMaybe) import GHC import GHC.Data.StringBuffer @@ -48,7 +41,6 @@ import GHC.Driver.Config.Logger import GHC.Driver.DynFlags as GHC import GHC.Driver.Env as GHC import GHC.Driver.Monad -import GHC.Driver.Hooks import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Main @@ -76,24 +68,18 @@ import GHC.Debugger.Session import GHC.Debugger.Session.Builtin import GHC.Debugger.Session.Interactive 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) -import GHCi.Message (mkPipeFromHandles) -import System.IO (hGetLine, IOMode(..)) -import qualified GHC.Linker.Loader as Loader import GHC.Stack.Annotation import GHC.Platform.Ways -#if MIN_VERSION_ghc(9,15,0) -import GHC.Data.FastString.Env (emptyFsEnv) -#endif import GHC.Unit.Home.Graph import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger` import System.Directory (getCurrentDirectory) +import GHC.Debugger.Debuggee -- | A debugger action. newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a } @@ -195,15 +181,7 @@ instance Outputable BreakpointAction where ppr = text . show data RunDebuggerSettings = RunDebuggerSettings { supportsANSIStyling :: Bool , supportsANSIHyperlinks :: Bool - , preferInternalInterpreter :: Bool - , externalInterpreterCustomProc :: Either StdStream PortNumber - -- ^ Right: use a custom given existing process for the external - -- interpreter listening at given port. (This is used when we want to - -- launch the external interpreter attached to a user's terminal). - -- - -- Left: we launch our own external interpreter process through - -- GHC's spawnIServ using the given StdStream as the stdin. - , externalInterpreterProg :: FilePath + , interpreterSettings :: InterpreterSettings } -- | Run a 'Debugger' action on a session constructed by a 'DebugRunner' @@ -297,17 +275,7 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f `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 conf.externalInterpreterProg - -- 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" - + & interpreterFlags conf.interpreterSettings -- Really important to force -dynamic if host is dynamic -- See Note [Dynamic Debuggee for dynamic debugger] & enableDynamicDebuggee @@ -335,59 +303,7 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns) return dflags2 - -- 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 - case conf.externalInterpreterCustomProc of - -- Left: GHC will launch the external interpreter itself on demand if - -- using external interpreter, and we just provide the stdin stream - Left givenStdStream -> - 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 = givenStdStream - , 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 $ conf.externalInterpreterProg : drop 1 ws - RawCommand _fp args -> RawCommand conf.externalInterpreterProg args -#endif - } - putMVar iserv_handles (o, e) - return ph - } - } - - -- Right: we supply our custom external interpreter process, which is - -- already running and connected to the user's terminal. - Right port -> do - extInterp <- liftIO - $ annotateStackStringIO "Waiting for an external interpreter run-in-terminal process" - $ extInterpFromTerminalProcess port - modifySession $ \h -> h - { hsc_interp = Just extInterp -- set it directly! - } - - let - externalInterpFwdThread :: IO () - externalInterpFwdThread = when (GHC.gopt GHC.Opt_ExternalInterpreter dflags2) $ do - -- The external interpreter is spawned lazily, so we block waiting for - -- the handles to be available in a new thread. - 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)) - - mainGhcThread :: Ghc a - mainGhcThread = do + interpreterSetup conf.interpreterSettings l dflags2 $ do -- Initializes interpreter! _ <- GHC.setSessionDynFlags dflags2 @@ -475,16 +391,6 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f then Nothing else Just hdv_uid) - case conf.externalInterpreterCustomProc of - Left _ -> do - -- We launched the external interpreter ourselves, so forward its output to the logger. - withUnliftGhc $ \ unlift -> annotateCallStackIO $ do - withAsync (annotateCallStackIO $ void externalInterpFwdThread) $ \ fwd_thr -> do - liftIO $ annotateCallStackIO $ link fwd_thr - annotateCallStackIO $ unlift mainGhcThread - Right _ -> - -- Ext interp is running in user terminal, no need to forward output to logger - mainGhcThread findOrLoadHaskellDebuggerView :: LogAction IO DebuggerLog -> Ways @@ -663,84 +569,6 @@ parseDynamicFlagsWithRootDir rootDir logger dflags cmdline = do dflags2 <- liftIO $ interpretPackageEnv logger1 dflags1 return (dflags2, leftovers, warns) --- | Make an 'ExtInterpInstance' based on an external interpreter process that --- was launched by the DAP client via 'runInTerminal'. The process sends its --- own PID as the first line on the socket before the GHCi wire protocol --- begins. -extInterpFromTerminalProcess :: PortNumber -> IO Interp -extInterpFromTerminalProcess port = do - putStrLn $ "Trying to connect to " ++ show port - Control.Exception.bracketOnError - (openListener port >>= accept) - (\ (sock,_) -> close sock) - (\ (sock,_) -> do - bi_h <- socketToHandle sock ReadWriteMode - - pidLine <- annotateCallStackIO $ hGetLine bi_h - - pid <- case readMaybe pidLine :: Maybe Int of - Just pid -> pure pid - Nothing -> fail $ "invalid external interpreter PID on socket: " ++ show pidLine - ph <- mkProcessHandle (fromIntegral pid) False - interpPipe <- mkPipeFromHandles bi_h bi_h - lock <- newMVar () - let process = InterpProcess - { interpHandle = ph - , interpPipe - , interpLock = lock - } - - pending_frees <- newMVar [] - let inst = ExtInterpInstance - { instProcess = process - , instPendingFrees = pending_frees - , instExtra = () - } - conf = IServConfig - { iservConfProgram = "the process is already running, we should never need to run it again" - , iservConfOpts = [] - -- VERY IMPORTANT: See Note [Dynamic dependencies for dynamic debugger] - , iservConfDynamic = hostIsDynamic - , iservConfProfiled = hostIsProfiled - , iservConfHook = Nothing -- it's already running! - , iservConfTrace = pure () - } - - lookup_cache <- mkInterpSymbolCache - s <- newMVar $ InterpRunning inst - loader <- Loader.uninitializedLoader -#if MIN_VERSION_ghc(9,15,0) - fs_cache <- newMVar emptyFsEnv - return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache fs_cache) -#else - return (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache) -#endif - ) - -openListener :: PortNumber -> IO Socket -openListener port = do - addr <- socketAddressFromPort port - sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) - -- Must set before bind! - setSocketOption sock ReuseAddr 1 - - bind sock (addrAddress addr) - listen sock maxListenQueue - - return sock - -socketAddressFromPort :: PortNumber -> IO AddrInfo -socketAddressFromPort port = do - let - hints = defaultHints - { addrSocketType = Stream - , addrFlags = [AI_PASSIVE] -- For wildcard IP (0.0.0.0 or ::) - , addrFamily = AF_UNSPEC -- Allow IPv4 or IPv6 - } - addrs <- getAddrInfo (Just hints) Nothing (Just (show port)) - case addrs of - addr : _ -> pure addr - [] -> fail ("Could not resolve address for external interpreter port " ++ show port) {- Note [Custom external interpreter] @@ -1081,49 +909,8 @@ deepseqTerm hsc_env t = case t of _ -> do seqTerm hsc_env t --------------------------------------------------------------------------------- --- * Logging --------------------------------------------------------------------------------- - --- | A debugger log. May include debuggee ouput. -data DebuggerLog - = DebuggerLog !Logger.Severity !DebuggerMessage - | GHCLog !GHC.LogFlags !MessageClass !SrcSpan !SDoc - | LogDebuggeeOut !Text - | LogDebuggeeErr !Text - --- | A debugger log message -data DebuggerMessage - = LogSDoc !DynFlags !SDoc - | LogFailedToCompileDebugViewModule !GHC.ModuleName - | LogSkippingViewModuleNoPkg !GHC.ModuleName String [String] - -instance Show DebuggerMessage where - show = \ case - LogFailedToCompileDebugViewModule mn -> - "Failed to compile built-in " ++ moduleNameString mn ++ " module! Ignoring these custom debug views." - LogSkippingViewModuleNoPkg mn pkg uids -> - "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 l <& DebuggerLog sev (LogSDoc dflags doc) - -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 - MCOutput -> Info - MCFatal -> Logger.Error - MCInteractive -> Info - MCDump -> Debug - MCInfo -> Info - MCDiagnostic SevIgnore _ _ -> Debug -- ? - MCDiagnostic SevWarning _ _ -> Logger.Warning - MCDiagnostic SevError _ _ -> Logger.Error diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index b697d5ff..ec67d602 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -38,7 +38,7 @@ module GHC.Debugger.Session ( withUnliftGhc, annotateCallStackGhc, lookupUnitPackageQualifier, - fixHomeUnitsDynFlagsForIIDecl, + fixHomeUnitsDynFlagsForIIDecl, getPgmI, ) where @@ -77,7 +77,6 @@ import GHC.Unit.Types 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 @@ -102,6 +101,7 @@ import GHC.Plugins (SourceError, try, RawPkgQual (..), HasCallStack, FastString, import GHC.Types.SourceText (StringLiteral(..), SourceText (..)) import GHC.Stack.Annotation import GHC.Stack (callStack) +import GHC.Settings (ToolSettings(..)) -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m @@ -644,6 +644,9 @@ 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 } +getPgmI :: DynFlags -> String +getPgmI df = toolSettings_pgm_i (toolSettings df) + alterToolSettings :: (ToolSettings -> ToolSettings) -> DynFlags -> DynFlags alterToolSettings f dynFlags = dynFlags { toolSettings = f (toolSettings dynFlags) } diff --git a/hdb-dap/Development/Debug/Adapter.hs b/hdb-dap/Development/Debug/Adapter.hs index d8b34246..1edf53dd 100644 --- a/hdb-dap/Development/Debug/Adapter.hs +++ b/hdb-dap/Development/Debug/Adapter.hs @@ -14,7 +14,7 @@ import System.FilePath import DAP import qualified GHC import qualified GHC.Debugger.Interface.Messages as D (Command, Response, RemoteThreadId, VariableReference) -import Network.Socket (PortNumber) +import Network.Socket (PortNumber, Socket) import GHC.Debugger.Interface.Messages (AbsFilePath, unAbs, (/>)) type DebugAdaptor = Adaptor DebugAdaptorState Request @@ -38,7 +38,7 @@ data DebugAdaptorState = DAS , entryPoint :: String , entryArgs :: [String] , projectRoot :: AbsFilePath - , runInTerminalProc :: RunInTerminalProc + , waitForDebuggee :: IO () -- ^ Potentially a process launched via 'runInTerminal'. } @@ -74,6 +74,7 @@ data RunInTerminalProc -- When 'NoRunInTerminal' but using external-interpreter, we'll still -- launch the external interpreter but in the default GHC way using the -- file descriptors directly. + , socket :: Socket } -- | We launched @hdb proxy ...@ on the user's terminal. diff --git a/hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs b/hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs new file mode 100644 index 00000000..720bd4a4 --- /dev/null +++ b/hdb-dap/Development/Debug/Adapter/DAPDebuggee.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NondecreasingIndentation #-} + +-- | TODO: This module should be called Launch. +module Development.Debug.Adapter.DAPDebuggee where + +#if !MIN_VERSION_ghc(9,15,0) +-- no longer needs to be imported from here in 9.15 +import GHC.Conc.Sync (labelThread) +#endif + +import GHC.IO.Handle +import System.Process +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as T +import Control.Monad.Trans +import System.IO +import Control.Monad.Catch +import Control.Exception (throwIO, IOException) +import Control.Concurrent +import Control.Monad +import Data.Functor.Contravariant + +import Development.Debug.Adapter +import Colog.Core as Logger +import qualified Development.Debug.Adapter.Output as Output + + +import DAP +import Development.Debug.Adapter.Handles +import Development.Debug.Session.Setup +import Development.Debug.Adapter.Proxy +import Network.Socket (socketPort, close) +import GHC.Debugger.Debuggee as Debugger + +data DAPDebuggee = DAPDebuggee + { dapdInterpreterSettings :: InterpreterSettings + , dapdWaitForDebuggee :: IO () + , dapdThreads :: [(DebugAdaptorCont () -> IO ()) -> IO ()] + -- ^ Additional threads to register for this session depending on the process + -- we're running through `runInTerminal` (see 'interpreterInit'). + , dapdAfterRegister :: DebugAdaptor () + -- ^ additional commands to run after registering the session. + } + + +internalNoInTerminalDAPD :: Applicative f => f DAPDebuggee +internalNoInTerminalDAPD + -- Not using the terminal proxy, but we still want to output our own + -- stdout/err (from the internal interpreter) as console events. + = do + let interpSettings = InterpreterSettings + { interpreterFlags = mkInternalInterpreterFlags + , interpreterSetup = mkInternalInterpreterSetup + } + pure $ + DAPDebuggee + interpSettings + (pure ()) + [ stdoutCaptureThread Nothing, stderrCaptureThread Nothing ] + (pure ()) + +externalNoInTerminalDAPD :: Applicative f => FilePath -> f DAPDebuggee +externalNoInTerminalDAPD hdbProg = do + let interpSettings = InterpreterSettings + { interpreterFlags = mkExternalInterpreterFlags hdbProg + , interpreterSetup = mkExternalInterpreterFromStdInSetup CreatePipe + } + pure $ + DAPDebuggee + interpSettings + (pure ()) + [] + (pure ()) + +externalInTerminalDAPD :: MonadIO m => FilePath -> m DAPDebuggee +externalInTerminalDAPD hdbProg + -- No additional bookkeeping is needed in this case because GHC will + -- naturally have to wait for the external interpreter in order to start execution + = liftIO $ do + -- We keep the socket open so we claim the port. + bracketOnError openSocketAvailablePort Network.Socket.close $ \ sock -> do + extInterpPort <- liftIO $ socketPort sock + let interpSettings = InterpreterSettings { + interpreterFlags = mkExternalInterpreterFlags hdbProg + , interpreterSetup = mkExternalInterpreterFromIOSetup $ extInterpFromTerminalProcess sock + } + pure $ + DAPDebuggee + interpSettings + (pure ()) + -- When session is killed the socket is closed too. + [\ _ -> forever (threadDelay 100_000_000) `finally` Network.Socket.close sock] + (sendRunInTerminalReverseRequest + RunInTerminalRequestArguments + { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated + , runInTerminalRequestArgumentsTitle = Nothing + , runInTerminalRequestArgumentsCwd = "" + , runInTerminalRequestArgumentsArgs = + [T.pack hdbProg, "external-interpreter", "--port", T.pack (show extInterpPort)] + , runInTerminalRequestArgumentsEnv = Nothing + , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False + }) + +internalInTerminalDAPD :: LogAction IO DAPSessionLog -> FilePath -> Adaptor DebugAdaptorState r DAPDebuggee +internalInTerminalDAPD l hdbProg = do + (syncProxyIn, syncProxyOut, syncProxyErr) + <- liftIO $ (,,) <$> newChan <*> newChan <*> newChan + proxyClientReady <- liftIO $ newEmptyMVar + + (serverPort, serverProxyThread) <- liftIO $ + mkServerSideHdbProxy (contramap RunProxyServerLog l) + syncProxyIn syncProxyOut syncProxyErr proxyClientReady + let interpSettings = InterpreterSettings + { interpreterFlags = mkInternalInterpreterFlags + , interpreterSetup = mkInternalInterpreterSetup + } + waitForDebuggee = + -- Only start executing after proxy client connects succesfully (#95) + takeMVar proxyClientReady + pure $ DAPDebuggee + interpSettings + waitForDebuggee + [ const serverProxyThread + -- Setup capturing of the process' own stdout and forwarding of the process' own stdin, + -- but only because we're using the internal interpreter! + , stdinForwardThread syncProxyIn + , stdoutCaptureThread (Just syncProxyOut) + , stderrCaptureThread (Just syncProxyErr) + ] + + -- When using the internal interpreter and 'runInTerminal' is supported + -- (the 'RunProxyInTerminal' case), we ask the DAP client to launch the + -- `hdb proxy` attached to the user's terminal. The proxy forwards + -- input/output from the user terminal to the debugger+debuggee shared process + (sendRunProxyInTerminal hdbProg serverPort) + +-------------------------------------------------------------------------------- +-- * Logging +-------------------------------------------------------------------------------- + +data DAPSessionLog + = DAPSessionSetupLog (WithSeverity SessionSetupLog) + | DAPDebuggerLog Debugger.DebuggerLog + | RunProxyServerLog (WithSeverity T.Text) + + +-------------------------------------------------------------------------------- +-- * Capturing stdout, stderr, and writing to self stdin +-------------------------------------------------------------------------------- + +-- | Hijack the current process stdin and forward to it the messages from the given channel +stdinForwardThread :: Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () +stdinForwardThread syncIn _withAdaptor = do + tid <- myThreadId + labelThread tid "Stdin Forward Thread" + + -- 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 :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () +stdoutCaptureThread msyncOut withAdaptor = do + tid <- myThreadId + labelThread tid "Stdout Capture Thread" + withInterceptedStdout $ \_ interceptedStdout -> do + forever $ do + line <- liftIO $ T.hGetLine interceptedStdout + case msyncOut of + Nothing -> pure () + Just syncOut -> writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n") + + -- Always output to Debug Console + catch + (withAdaptor $ Output.stdout line) + (\(_ :: IOException) -> + throwIO (FailedToWriteToAdaptor line)) + +-- | Like 'stdoutCaptureThread' but for stderr +stderrCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () +stderrCaptureThread msyncErr withAdaptor = do + tid <- myThreadId + labelThread tid "Stderr Capture Thread" + withInterceptedStderr $ \_ interceptedStderr -> do + forever $ do + line <- liftIO $ T.hGetLine interceptedStderr + case msyncErr of + Nothing -> pure () + Just syncErr -> writeChan syncErr $ T.encodeUtf8 (line <> "\n") + + -- Always output to Debug Console + catch + (withAdaptor $ Output.stderr line) + (\(_ :: IOException) -> + 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-dap/Development/Debug/Adapter/Init.hs b/hdb-dap/Development/Debug/Adapter/Init.hs index 9059f513..1c227d7a 100644 --- a/hdb-dap/Development/Debug/Adapter/Init.hs +++ b/hdb-dap/Development/Debug/Adapter/Init.hs @@ -5,9 +5,14 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NondecreasingIndentation #-} -- | TODO: This module should be called Launch. -module Development.Debug.Adapter.Init where +module Development.Debug.Adapter.Init + ( module Development.Debug.Adapter.Init + , DAPSessionLog(..) + ) + where #if !MIN_VERSION_ghc(9,15,0) -- no longer needs to be imported from here in 9.15 @@ -15,11 +20,7 @@ import GHC.Conc.Sync (labelThread) #endif import GHC.IO.Handle -import System.Process -import qualified Data.ByteString as BS import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Encoding as T import qualified System.Process as P import Control.Exception (displayExceptionWithInfo) import Control.Monad.Except @@ -31,9 +32,7 @@ import Data.UUID.V4 qualified as UUID import System.IO import GHC.IO.Encoding import Control.Monad.Catch -import Control.Exception (throwIO, IOException) import Control.Concurrent -import Control.Monad import Data.Aeson as Aeson import GHC.Generics import System.Directory @@ -54,10 +53,9 @@ import GHC.Debugger.Interface.Messages hiding (Command, Response) import DAP import Development.Debug.Adapter.Handles import Development.Debug.Session.Setup -import Development.Debug.Adapter.Proxy -import Network.Socket (socketPort) -import qualified Network.Socket as Socket -import GHC.Debugger.Monad (RunDebuggerSettings(externalInterpreterCustomProc)) +import GHC.Debugger.Monad (RunDebuggerSettings(..)) +import GHC.Debugger.Debuggee as Debugger +import Development.Debug.Adapter.DAPDebuggee -------------------------------------------------------------------------------- -- * Client @@ -84,15 +82,6 @@ data LaunchArgs } deriving stock (Show, Eq, Generic) deriving anyclass FromJSON --------------------------------------------------------------------------------- --- * Logging --------------------------------------------------------------------------------- - -data DAPSessionLog - = DAPSessionSetupLog (WithSeverity SessionSetupLog) - | DAPDebuggerLog Debugger.DebuggerLog - | RunProxyServerLog (WithSeverity T.Text) - -------------------------------------------------------------------------------- -- * Launch Debugger -------------------------------------------------------------------------------- @@ -104,12 +93,15 @@ data DAPServerConf = DAPServerConf , dapServerConfig :: ServerConfig } +data InterpreterChoice = InterpreterChoice { runInTerminal :: Bool, internal :: Bool } + + -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise -initDebugger :: LogAction IO DAPSessionLog -> DAPServerConf -> Bool -> Bool +initDebugger :: LogAction IO DAPSessionLog -> DAPServerConf -> InterpreterChoice -> LaunchArgs -> DebugAdaptor () -initDebugger l servConf supportsRunInTerminal preferInternalInterpreter +initDebugger l servConf interpChoice LaunchArgs{ __sessionId , projectRoot = givenRoot , entryFile = entryFileMaybe @@ -159,50 +151,22 @@ initDebugger l servConf supportsRunInTerminal preferInternalInterpreter stackFrameMap = mempty variablesMap = mempty - mkRunInTerminalProc - | not supportsRunInTerminal - = pure NoRunInTerminal - | not preferInternalInterpreter - = do - sock <- openSocketAvailablePort - port <- socketPort sock - -- Close socket again to make sure we can open the server socket - -- later again. - Socket.close sock - pure RunExternalInterpreterInTerminal - { extInterpPort = port - } - | otherwise - = do - (syncProxyIn, syncProxyOut, syncProxyErr) - <- (,,) <$> newChan <*> newChan <*> newChan - proxyClientReady <- newEmptyMVar - pure RunProxyInTerminal{..} - - runInTerminalProc <- liftIO mkRunInTerminalProc - - dbgLog <- liftIO $ - createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc - let hdbProg = hdbProgram servConf - - (runInTerminalThreads, afterRegisterActions) <- - mkRunInTerminalThreads l hdbProg runInTerminalProc preferInternalInterpreter + dbgLog <- liftIO $ createDebuggerLogger l dapLogger writeDAPOutput + + dapd <- initDAPDebuggee l (hdbProgram servConf) interpChoice let defaultRunConf = Debugger.RunDebuggerSettings { supportsANSIStyling = True -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap , supportsANSIHyperlinks = False -- VSCode does not support this - , preferInternalInterpreter - , externalInterpreterCustomProc = case runInTerminalProc of - RunExternalInterpreterInTerminal{extInterpPort} - -> Right extInterpPort - _ -> Left CreatePipe -- if not runInTerminal, just create a new pipe for stdin - , externalInterpreterProg = hdbProgram servConf + , interpreterSettings = dapdInterpreterSettings dapd } absEntryFile = projectRoot /> entryFile - daState = DAS{entryFile=absEntryFile,..} + daState = DAS{entryFile=absEntryFile,waitForDebuggee = dapdWaitForDebuggee dapd,..} + -- TODO: is nextRandom threadsafe? sessionId <- liftIO $ maybe (("debug-session:" <>) . T.show <$> UUID.nextRandom) (pure . T.pack) __sessionId + registerNewDebugSession sessionId daState $ [ \withAdaptor -> do -- The info here is already taken into account in debugRunner. @@ -218,68 +182,24 @@ initDebugger l servConf supportsRunInTerminal preferInternalInterpreter LogAction (\msg -> withAdaptor (Output.neutral msg)) ] ++ - runInTerminalThreads + dapdThreads dapd - afterRegisterActions + dapdAfterRegister dapd --- | Additional threads to register for this session depending on the process --- we're running through `runInTerminal` (see 'RunInTerminalProc'). -mkRunInTerminalThreads +initDAPDebuggee :: LogAction IO DAPSessionLog -> FilePath - -> RunInTerminalProc - -> Bool -- ^ Use internal interpreter - -> DebugAdaptor ([(DebugAdaptorCont () -> IO ()) -> IO ()], DebugAdaptor ()) - -- ^ Threads to register in this debug session and additional commands to - -- run after registering the session. - -mkRunInTerminalThreads _ _ NoRunInTerminal useInternalInterp - -- Not using the terminal proxy, but we still want to output our own - -- stdout/err (from the internal interpreter) as console events. - | True <- useInternalInterp - = pure ([ stdoutCaptureThread Nothing, stderrCaptureThread Nothing ], pure ()) - - | otherwise - = pure ([], pure ()) - -mkRunInTerminalThreads _ hdbProg RunExternalInterpreterInTerminal{..} _ - -- No additional bookkeeping is needed in this case because GHC will - -- naturally have to wait for the external interpreter in order to start execution - = do - pure ([], - sendRunInTerminalReverseRequest - RunInTerminalRequestArguments - { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated - , runInTerminalRequestArgumentsTitle = Nothing - , runInTerminalRequestArgumentsCwd = "" - , runInTerminalRequestArgumentsArgs = - [T.pack hdbProg, "external-interpreter", "--port", T.pack (show extInterpPort)] - , runInTerminalRequestArgumentsEnv = Nothing - , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False - }) - -mkRunInTerminalThreads l hdbProg RunProxyInTerminal{..} _ - = do - (serverPort, serverProxyThread) <- - mkServerSideHdbProxy (contramap RunProxyServerLog l) - syncProxyIn syncProxyOut syncProxyErr proxyClientReady - - pure ( - [ ($ serverProxyThread) - - -- Setup capturing of the process' own stdout and forwarding of the process' own stdin, - -- but only because we're using the internal interpreter! - , stdinForwardThread syncProxyIn - , stdoutCaptureThread (Just syncProxyOut) - , stderrCaptureThread (Just syncProxyErr) - ], - - -- When using the internal interpreter and 'runInTerminal' is supported - -- (the 'RunProxyInTerminal' case), we ask the DAP client to launch the - -- `hdb proxy` attached to the user's terminal. The proxy forwards - -- input/output from the user terminal to the debugger+debuggee shared process - sendRunProxyInTerminal hdbProg serverPort - ) + -> InterpreterChoice + -> DebugAdaptor DAPDebuggee +initDAPDebuggee _ _ InterpreterChoice{runInTerminal = False, internal = True} + = internalNoInTerminalDAPD +initDAPDebuggee _ hdbProg InterpreterChoice{runInTerminal = False, internal = False} + = externalNoInTerminalDAPD hdbProg +initDAPDebuggee _ hdbProg InterpreterChoice{internal = False, runInTerminal = True} + = externalInTerminalDAPD hdbProg +initDAPDebuggee l hdbProg InterpreterChoice{runInTerminal = True, internal = True} + = internalInTerminalDAPD l hdbProg + -- | The main debugger thread launches a GHC.Debugger session. -- @@ -338,9 +258,8 @@ createDebuggerLogger :: LogAction IO DAPSessionLog -> LogAction IO T.Text -- ^ Logger that writes to to DAP output -> Handle -- ^ Handle to DAP output - -> RunInTerminalProc -> IO (LogAction IO Debugger.DebuggerLog) -createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc = do +createDebuggerLogger l dapLogger writeDAPOutput = do return $ -- (1) (all output is logged to normal logger) contramap DAPDebuggerLog l <> @@ -351,91 +270,7 @@ createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc = 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 msyncProxyOut txt - Debugger.LogDebuggeeErr txt -> debuggeeOut dapLogger msyncProxyErr txt + Debugger.LogDebuggeeOut txt -> dapLogger <& txt + Debugger.LogDebuggeeErr txt -> dapLogger <& txt _ -> pure () -- don't log other messages, already logged to (1) ) - where - debuggeeOut l' mproxyChan txt = do - -- (2) - l' <& txt - -- (3) - case mproxyChan of - Nothing -> pure () - Just proxyChan -> - writeChan proxyChan $ - T.encodeUtf8 (txt <> "\n") - - (msyncProxyOut, msyncProxyErr) - | RunProxyInTerminal{syncProxyOut, syncProxyErr} <- runInTerminalProc - = (Just syncProxyOut, Just syncProxyErr) - | otherwise - = (Nothing, Nothing) - --------------------------------------------------------------------------------- --- * Capturing stdout, stderr, and writing to self stdin --------------------------------------------------------------------------------- - --- | Hijack the current process stdin and forward to it the messages from the given channel -stdinForwardThread :: Chan BS.ByteString -> (DebugAdaptorCont () -> IO ()) -> IO () -stdinForwardThread syncIn _withAdaptor = do - tid <- myThreadId - labelThread tid "Stdin Forward Thread" - - -- 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 :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () -stdoutCaptureThread msyncOut withAdaptor = do - tid <- myThreadId - labelThread tid "Stdout Capture Thread" - withInterceptedStdout $ \_ interceptedStdout -> do - forever $ do - line <- liftIO $ T.hGetLine interceptedStdout - case msyncOut of - Nothing -> pure () - Just syncOut -> writeChan syncOut $ T.encodeUtf8 (line <> T.pack "\n") - - -- Always output to Debug Console - catch - (withAdaptor $ Output.stdout line) - (\(_ :: IOException) -> - throwIO (FailedToWriteToAdaptor line)) - --- | Like 'stdoutCaptureThread' but for stderr -stderrCaptureThread :: Maybe (Chan BS.ByteString) -> (DebugAdaptorCont () -> IO ()) -> IO () -stderrCaptureThread msyncErr withAdaptor = do - tid <- myThreadId - labelThread tid "Stderr Capture Thread" - withInterceptedStderr $ \_ interceptedStderr -> do - forever $ do - line <- liftIO $ T.hGetLine interceptedStderr - case msyncErr of - Nothing -> pure () - Just syncErr -> writeChan syncErr $ T.encodeUtf8 (line <> "\n") - - -- Always output to Debug Console - catch - (withAdaptor $ Output.stderr line) - (\(_ :: IOException) -> - 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-dap/Development/Debug/Adapter/Proxy.hs b/hdb-dap/Development/Debug/Adapter/Proxy.hs index a10a1639..f7d9e762 100644 --- a/hdb-dap/Development/Debug/Adapter/Proxy.hs +++ b/hdb-dap/Development/Debug/Adapter/Proxy.hs @@ -30,7 +30,6 @@ import System.Environment import System.FilePath import Control.Exception.Base import Control.Monad -import Control.Monad.IO.Class import Control.Concurrent import qualified Data.List.NonEmpty as NE @@ -61,13 +60,13 @@ mkServerSideHdbProxy :: LogAction IO (WithSeverity T.Text) -> Chan BS8.ByteString -> Chan BS8.ByteString -> MVar () - -> Adaptor DebugAdaptorState r (PortNumber, Adaptor DebugAdaptorState s ()) -mkServerSideHdbProxy l dbIn dbOut dbErr client_conn_signal = do + -> IO (PortNumber, IO ()) +mkServerSideHdbProxy l dbIn dbOut dbErr client_conn_signal = + bracketOnError openSocketAvailablePort close $ \ sock -> do - sock <- liftIO $ openSocketAvailablePort - port <- liftIO $ socketPort sock + port <- socketPort sock - return $ (port,) $ liftIO $ do + return $ (port,) $ do ignoreIOException $ do myThreadId >>= \tid -> labelThread tid "Debug/Adapter/Proxy: TCP Server" runTCPServerWithSocket' sock $ \scket -> do @@ -135,10 +134,21 @@ labelMe name = do -- | Open a socket on an available port openSocketAvailablePort :: IO Socket openSocketAvailablePort = do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV], addrSocketType = Stream } - addr <- NE.head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "0") + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV] ++ [AI_PASSIVE] -- For wildcard IP (0.0.0.0 or ::) + , addrSocketType = Stream + + , addrFamily = AF_UNSPEC -- Allow IPv4 or IPv6 + } + addr <- NE.head <$> getAddrInfo (Just hints) Nothing (Just "0") -- Bind on "0" to let the OS pick a free port - openTCPServerSocket addr + + sock <- Network.Socket.socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + -- Must set before bind! + setSocketOption sock ReuseAddr 1 + + bind sock (addrAddress addr) + listen sock maxListenQueue + return sock -- | The proxy code running on the terminal in which the @hdb proxy@ process is launched. -- diff --git a/hdb-dap/Development/Debug/Adapter/Server.hs b/hdb-dap/Development/Debug/Adapter/Server.hs index 5e2e238d..1486da2f 100644 --- a/hdb-dap/Development/Debug/Adapter/Server.hs +++ b/hdb-dap/Development/Debug/Adapter/Server.hs @@ -13,7 +13,6 @@ module Development.Debug.Adapter.Server import System.Environment import Data.Maybe import Text.Read -import Control.Concurrent import Control.Monad import Control.Monad.IO.Class @@ -39,8 +38,8 @@ import Data.Functor.Contravariant import Development.Debug.Adapter -import GHC.Debugger.Monad import qualified GHC.Utils.Logger as GHC +import GHC.Debugger.Debuggee (DebuggerLog(..)) ------------------------------------------------------------------------- @@ -145,7 +144,7 @@ talk l servConf prefer_internal_interpreter = \ case #endif initDebugger (contramap DAPSessionLog l) servConf - runInTerminal prefer_internal_interpreter + InterpreterChoice {runInTerminal, internal = prefer_internal_interpreter} launch_args sendLaunchResponse -- ack @@ -171,13 +170,8 @@ talk l servConf prefer_internal_interpreter = \ case CommandConfigurationDone -> do sendConfigurationDoneResponse - DAS{runInTerminalProc} <- getDebugSession - case runInTerminalProc of - RunProxyInTerminal{proxyClientReady} -> liftIO $ do - -- Only start executing after proxy client connects succesfully (#95) - takeMVar proxyClientReady - _ -> - pure () + DAS{waitForDebuggee} <- getDebugSession + liftIO $ waitForDebuggee -- Configuration is finished. Start executing until it halts. startExecution >>= handleEvalResult False diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index 02f2984d..07cbc713 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -22,6 +22,7 @@ import GHC.Debugger import Control.Monad import Data.List (intercalate) import qualified Data.Maybe as Maybe +import GHC.Debugger.Debuggee (DebuggerLog) data RunOptions = RunOptions { runEntryFile :: AbsFilePath diff --git a/hdb/Main.hs b/hdb/Main.hs index 2e69ab23..ddebf0f8 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -22,8 +22,8 @@ import System.IO , hSetBuffering , BufferMode(..) , Handle - , openFile - , IOMode(ReadMode, ReadWriteMode) + + , IOMode(ReadWriteMode) ) import qualified Data.Text as T import qualified Data.Text.IO as T @@ -44,6 +44,7 @@ import Development.Debug.Interactive import GHC.Stack.Annotation (annotateCallStackIO) import GHC.Utils.Logger (defaultLogActionWithHandles) import Development.Debug.Session.Setup (hieDebugRunner) +import GHC.Debugger.Debuggee (mkCliInterpreterSettings) #if MIN_VERSION_ghc(9,15,0) import GHC.Debugger.Runtime.Interpreter.Custom (dbgInterpCmdHandler) @@ -84,18 +85,11 @@ main = do HdbCLI{..} -> do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) l <- mainLogger hdbOpts.verbosity stdout - stdinStream <- case debuggeeStdin of - Just fp -> UseHandle <$> System.IO.openFile fp ReadMode - Nothing -> pure Inherit - -- the same program invoked with `external-interpreter` serves as the external interpreter - thisProg <- getExecutablePath + cliInterpSettings <- mkCliInterpreterSettings internalInterpreter debuggeeStdin let runConf = RunDebuggerSettings { supportsANSIStyling = True -- todo: check!! , supportsANSIHyperlinks = False - , preferInternalInterpreter = internalInterpreter - , externalInterpreterCustomProc = Left stdinStream - , externalInterpreterProg = thisProg - } + , interpreterSettings = cliInterpSettings } runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs cradleFile runConf debugInteractive HdbProxy{port} -> do diff --git a/test/golden/T130/T130.ghc-1001.hdb-stdout b/test/golden/T130/T130.ghc-1001.hdb-stdout index 33031342..28630da3 100644 --- a/test/golden/T130/T130.ghc-1001.hdb-stdout +++ b/test/golden/T130/T130.ghc-1001.hdb-stdout @@ -1,2 +1 @@ Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) -While handling Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) diff --git a/test/golden/T130/T130.ghc-914.hdb-stdout b/test/golden/T130/T130.ghc-914.hdb-stdout index 33031342..28630da3 100644 --- a/test/golden/T130/T130.ghc-914.hdb-stdout +++ b/test/golden/T130/T130.ghc-914.hdb-stdout @@ -1,2 +1 @@ Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) -While handling Cannot use unsupported haskell-debugger-view version found in the transitive closure: 0.1.0.0 (supported: 0.2 <= && < 0.3) diff --git a/test/golden/T130/T130.hdb-test b/test/golden/T130/T130.hdb-test index f978e65a..69efd6f0 100644 --- a/test/golden/T130/T130.hdb-test +++ b/test/golden/T130/T130.hdb-test @@ -5,7 +5,7 @@ # which is not supported by this debugger version. # (Note: drop the output because the callstack is hard to normalize) -if ($HDB app/Main.hs 2>&1 | grep "Cannot use unsupported") < T130.hdb-stdin; then +if ($HDB app/Main.hs 2>&1 | grep -v 'While handling' | grep "Cannot use unsupported") < T130.hdb-stdin; then exit 0 fi diff --git a/test/golden/T154/T154.ghc-1001.hdb-stdout b/test/golden/T154/T154.external.ghc-1001.hdb-stdout similarity index 100% rename from test/golden/T154/T154.ghc-1001.hdb-stdout rename to test/golden/T154/T154.external.ghc-1001.hdb-stdout diff --git a/test/golden/T154/T154.ghc-914.hdb-stdout b/test/golden/T154/T154.external.ghc-914.hdb-stdout similarity index 100% rename from test/golden/T154/T154.ghc-914.hdb-stdout rename to test/golden/T154/T154.external.ghc-914.hdb-stdout diff --git a/test/golden/T154/T154.ghc-915.hdb-stdout b/test/golden/T154/T154.external.ghc-915.hdb-stdout similarity index 100% rename from test/golden/T154/T154.ghc-915.hdb-stdout rename to test/golden/T154/T154.external.ghc-915.hdb-stdout diff --git a/test/golden/T154/T154.hdb-test b/test/golden/T154/T154.external.hdb-test similarity index 100% rename from test/golden/T154/T154.hdb-test rename to test/golden/T154/T154.external.hdb-test diff --git a/test/golden/T169/T169.ghc-1001.hdb-stdout b/test/golden/T169/T169.internal.ghc-1001.hdb-stdout similarity index 100% rename from test/golden/T169/T169.ghc-1001.hdb-stdout rename to test/golden/T169/T169.internal.ghc-1001.hdb-stdout diff --git a/test/golden/T169/T169.ghc-914.hdb-stdout b/test/golden/T169/T169.internal.ghc-914.hdb-stdout similarity index 100% rename from test/golden/T169/T169.ghc-914.hdb-stdout rename to test/golden/T169/T169.internal.ghc-914.hdb-stdout diff --git a/test/golden/T169/T169.ghc-915.hdb-stdout b/test/golden/T169/T169.internal.ghc-915.hdb-stdout similarity index 100% rename from test/golden/T169/T169.ghc-915.hdb-stdout rename to test/golden/T169/T169.internal.ghc-915.hdb-stdout diff --git a/test/golden/T169/T169.hdb-test b/test/golden/T169/T169.internal.hdb-test similarity index 100% rename from test/golden/T169/T169.hdb-test rename to test/golden/T169/T169.internal.hdb-test From 91ea11981292bcf1b62f615859b0efb224a9b9f9 Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Thu, 9 Jul 2026 18:39:54 +0200 Subject: [PATCH 2/5] unique workingDirectory for each in-memory hdv --- haskell-debugger.cabal | 1 + haskell-debugger/GHC/Debugger/Session/Builtin.hs | 3 +++ 2 files changed, 4 insertions(+) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index c0ecd65a..27477467 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -149,6 +149,7 @@ library haskell-debugger-view >= 0.2 && < 1.0, ghc-stack-annotations >=0.1 && <0.2, + uuid, if !os(windows) build-depends: unix >= 2.8.6 && < 2.9, diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs index a44eb726..d3b3b103 100644 --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -18,6 +18,7 @@ module GHC.Debugger.Session.Builtin ) where +import Data.UUID.V4 qualified as UUID import Data.FileEmbed import Data.Function import Data.Maybe @@ -95,6 +96,7 @@ addInMemoryHsDebuggerViewUnit -> DynFlags -- ^ Dynflags resulting from first downsweep of user given targets -> m () addInMemoryHsDebuggerViewUnit base_uids initialDynFlags = do + uuid <- liftIO $ UUID.nextRandom let imhdv_dflags = initialDynFlags { homeUnitId_ = hsDebuggerViewInMemoryUnitId , importPaths = [] @@ -108,6 +110,7 @@ addInMemoryHsDebuggerViewUnit base_uids initialDynFlags = do , unitId /= ghcInternalUnitId ] , thisPackageName = Just "haskell-debugger-view" + , workingDirectory = Just (show uuid) } & setGeneralFlag' Opt_HideAllPackages hsc_env <- getSession From ff4480c294ff0d1c4fcadcc458b8190977ae4d3c Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Fri, 10 Jul 2026 09:50:46 +0200 Subject: [PATCH 3/5] unique cache dirs --- haskell-debugger/GHC/Debugger/Session.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index ec67d602..9fbdbba6 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -102,6 +102,7 @@ import GHC.Types.SourceText (StringLiteral(..), SourceText (..)) import GHC.Stack.Annotation import GHC.Stack (callStack) import GHC.Settings (ToolSettings(..)) +import qualified Data.UUID.V4 as UUID -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m @@ -152,7 +153,8 @@ parseHomeUnitArguments cfp compRoot units theOpts dflags rootDir = do Just wdir -> compRoot wdir root_canon <- liftIO $ Directory.canonicalizePath root let targets = HIE.makeTargetsAbsolute root_canon targets' - cacheDirs <- liftIO $ getCacheDirs (takeFileName root) this_opts + uuid <- liftIO UUID.nextRandom + cacheDirs <- liftIO $ getCacheDirs (takeFileName root show uuid) this_opts let dflags'' = makeDynFlagsDirsAbsolute compRoot $ setWorkingDirectory root $ From 84eb3e4ffb319ce3137c58eb038a3d647aba8fc6 Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Thu, 9 Jul 2026 16:45:41 +0200 Subject: [PATCH 4/5] safeRunGhc --- haskell-debugger/GHC/Debugger/Monad.hs | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index b3330c6b..51a09b69 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -28,9 +28,6 @@ import Data.Maybe import qualified Data.Set as Set import Data.Version (makeVersion, showVersion) import Prelude hiding (mod) -#ifdef MIN_VERSION_unix -import System.Posix.Signals -#endif import qualified Data.List as L import qualified Data.List.NonEmpty as NonEmpty @@ -80,6 +77,7 @@ import GHC.Unit.Home.Graph import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger` import System.Directory (getCurrentDirectory) import GHC.Debugger.Debuggee +import GHC.Plugins (panic) -- | A debugger action. newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a } @@ -215,6 +213,16 @@ data ProjectDebugSpec = ProjectDebugSpec , extraGhcArgs :: [String] } +safeRunGhc :: Maybe FilePath -- ^ See argument to 'initGhcMonad'. + -> Ghc a -- ^ The action to perform. + -> IO a +safeRunGhc mb_top_dir ghc = do + ref <- newIORef (panic "empty session") + let session = Session ref + flip unGhc session $ do + initGhcMonad mb_top_dir + withCleanupSession ghc + -- | Construct a session from paths and flags inferred from the debugee's project. withProjectDebugSession :: GhcMonad m @@ -222,15 +230,7 @@ withProjectDebugSession -> DebugRunner m a withProjectDebugSession ProjectDebugSpec{ghcInvocation = ghcI, ..} k = do let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcI - GHC.runGhc (Just libdir) $ do -#ifdef MIN_VERSION_unix - -- Workaround #4162 - -- FIXME: setup reasonable handlers to run cleanupSession for every debugger thread, because runGhc's `withSignalHandlers` is not it. - _ <- liftIO $ installHandler sigINT Default Nothing - _ <- liftIO $ installHandler sigQUIT Default Nothing - _ <- liftIO $ installHandler sigTERM Default Nothing - _ <- liftIO $ installHandler sigHUP Default Nothing -#endif + safeRunGhc (Just libdir) $ do k rootDir extraGhcArgs $ do dflags2 <- getSessionDynFlags From 5b1604f1bf3a47f18d828ea9b17fc0d582260827 Mon Sep 17 00:00:00 2001 From: Andrea Vezzosi Date: Fri, 10 Jul 2026 13:41:41 +0200 Subject: [PATCH 5/5] Lock around getCurrentDirectory too --- haskell-debugger/GHC/Debugger/Monad.hs | 5 ++-- haskell-debugger/GHC/Debugger/Utils.hs | 30 ++++++++++++++++++++++ hdb-dap/Development/Debug/Adapter/Init.hs | 7 ++--- hdb-dap/Development/Debug/Session/Setup.hs | 12 ++------- hdb/Development/Debug/Interactive.hs | 5 ++-- 5 files changed, 42 insertions(+), 17 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 51a09b69..d53393b5 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -75,9 +75,9 @@ import GHC.Stack.Annotation import GHC.Platform.Ways import GHC.Unit.Home.Graph import GHC.Debugger.Utils.Orphans () -- bring orphan instances to everything which uses `Debugger` -import System.Directory (getCurrentDirectory) import GHC.Debugger.Debuggee import GHC.Plugins (panic) +import GHC.Debugger.Utils (withOriginalCurrentDirectory) -- | A debugger action. newtype Debugger a = Debugger { unDebugger :: ReaderT DebuggerState GHC.Ghc a } @@ -854,7 +854,8 @@ getAllLoadedModules = getAllLoadedModulesWithPaths :: GHC.GhcMonad m => m [(AbsFilePath,ModSummary)] getAllLoadedModulesWithPaths = do - ghcCwd <- mkAbsolute <$> liftIO getCurrentDirectory + -- | See Note [ Current directory is a global property that affects HIE and GHC ] + ghcCwd <- liftIO $ withOriginalCurrentDirectory $ pure . mkAbsolute -- TODO: cache? map (\ m -> (absoluteSourcePath ghcCwd m, m)) <$> getAllLoadedModules where diff --git a/haskell-debugger/GHC/Debugger/Utils.hs b/haskell-debugger/GHC/Debugger/Utils.hs index ad521668..550b43e1 100644 --- a/haskell-debugger/GHC/Debugger/Utils.hs +++ b/haskell-debugger/GHC/Debugger/Utils.hs @@ -10,8 +10,11 @@ module GHC.Debugger.Utils import Control.Monad import Control.Applicative +import Control.Concurrent (MVar, newMVar, withMVar) import Control.Exception +import GHC.IO (unsafePerformIO) import System.IO +import qualified System.Directory as D import GHC import GHC.Data.FastString @@ -111,3 +114,30 @@ srcSpanStringToSourceSpan s = parseOnly pSrcSpan (T.pack s) showModule :: Module -> String showModule = showSDocUnsafe . withPprStyle (PprDump alwaysQualify) . ppr + +---------------------------------------------------- +-- Current Directory utils +---------------------------------------------------- +{- +Note [ Current directory is a global property that affects HIE and GHC ] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +We have to change the current directory for hie, and we concurrent debugging sessions we have to make sure we play nice with other hie api calls. + +Thanfully the hie calls should not be too long (as long as dependencies of the project are pre-built), so a solution is to make it a critical section with a global lock. The paths coming from HIE are made absolute at that point. + +We also rely on the CWD as the projectRoot if none is given, or to interpret relative paths from the session or from the DAP requests. Ideally they would all be absolute paths but we don't have full control. +-} + +{-# NOINLINE cwdLock #-} +cwdLock :: MVar () +cwdLock = unsafePerformIO $ newMVar () + +-- | See Note [ Current directory is a global property that affects HIE and GHC ] +withCurrentDirectory :: FilePath -> IO b -> IO b +withCurrentDirectory fp m = withMVar cwdLock $ \ _ -> D.withCurrentDirectory fp m + +-- | See Note [ Current directory is a global property that affects HIE and GHC ] +withOriginalCurrentDirectory :: (FilePath -> IO b) -> IO b +withOriginalCurrentDirectory m = withMVar cwdLock $ \ _ -> + m =<< D.getCurrentDirectory diff --git a/hdb-dap/Development/Debug/Adapter/Init.hs b/hdb-dap/Development/Debug/Adapter/Init.hs index 1c227d7a..f052760d 100644 --- a/hdb-dap/Development/Debug/Adapter/Init.hs +++ b/hdb-dap/Development/Debug/Adapter/Init.hs @@ -35,7 +35,6 @@ import Control.Monad.Catch import Control.Concurrent import Data.Aeson as Aeson import GHC.Generics -import System.Directory import Data.Functor.Contravariant import Development.Debug.Adapter @@ -44,7 +43,7 @@ import qualified Development.Debug.Adapter.Output as Output import GHC (Ghc) import GHC.Utils.Logger (defaultLogActionWithHandles) -import GHC.Debugger.Utils (forwardHandleToLogger) +import GHC.Debugger.Utils (forwardHandleToLogger,withOriginalCurrentDirectory) import qualified GHC.Debugger as Debugger import qualified GHC.Debugger.Monad as Debugger import qualified GHC.Debugger.Interface.Messages as D (Command, Response) @@ -117,7 +116,9 @@ initDebugger l servConf interpChoice Nothing -> throwError ("Missing \"entryFile\" key in debugger configuration", Nothing) Just ef -> pure ef - projectRoot <- liftIO $ mkAbsolute <$> maybe getCurrentDirectory makeAbsolute givenRoot + -- | See Note [ Current directory is a global property that affects HIE and GHC ] + projectRoot <- liftIO $ withOriginalCurrentDirectory + $ \ (mkAbsolute -> cwd) -> pure $ maybe cwd (cwd />) givenRoot -- 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... diff --git a/hdb-dap/Development/Debug/Session/Setup.hs b/hdb-dap/Development/Debug/Session/Setup.hs index de407c25..971939a7 100644 --- a/hdb-dap/Development/Debug/Session/Setup.hs +++ b/hdb-dap/Development/Debug/Session/Setup.hs @@ -21,7 +21,6 @@ module Development.Debug.Session.Setup ) where import Control.Applicative ((<|>)) -import Control.Concurrent (newMVar, MVar, withMVar) import Control.Exception (handleJust) import Control.Monad import Control.Monad.Except @@ -34,12 +33,10 @@ import Data.Maybe import Data.Version import Data.Void import System.Directory hiding (withCurrentDirectory, findFile) -import System.Directory qualified as D import System.FilePath import System.IO.Error import Text.ParserCombinators.ReadP (readP_to_S) import Data.Functor.Contravariant -import GHC.IO (unsafePerformIO) import qualified Data.Text as T @@ -59,6 +56,7 @@ import Prettyprinter.Render.Text import qualified GHC.Debugger.Monad as Debugger import GHC (Ghc) import GHC.Debugger.Monad (ProjectDebugSpec(ProjectDebugSpec)) +import GHC.Debugger.Utils (withCurrentDirectory) data GhcInvocation = GhcInvocation { gi_libdir :: FilePath @@ -185,6 +183,7 @@ hieBiosFlags cradle root relTarget = runExceptT $ do -- To determine the flags we MUST set the current directory to the root -- because hie.yaml may invoke programs relative to the root (e.g. GHC's hie.yaml does) -- (HIE.getCompilerOptions depends on CWD being the proper root dir) + -- | See Note [ Current directory is a global property that affects HIE and GHC ] let compilerOpts = liftIO $ withCurrentDirectory root $ HIE.getCompilerOptions (HIE.TargetWithContext target [target]) HIE.LoadUnitsFromCradle cradle componentOpts <- compilerOpts >>= unwrapCradleResult "Failed to get compiler options using hie-bios cradle" @@ -395,10 +394,3 @@ forgetPatchVersion :: Version -> Version forgetPatchVersion v = case versionBranch v of (major:minor:_patches) -> makeVersion [major, minor] _ -> v - -{-# NOINLINE cwdLock #-} -cwdLock :: MVar () -cwdLock = unsafePerformIO $ newMVar () - -withCurrentDirectory :: FilePath -> IO b -> IO b -withCurrentDirectory fp m = withMVar cwdLock $ \ _ -> D.withCurrentDirectory fp m \ No newline at end of file diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index 07cbc713..81c65390 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -4,7 +4,6 @@ module Development.Debug.Interactive where import Data.Functor.Contravariant import System.IO import System.Exit -import System.Directory import System.Console.Haskeline -- import System.Console.Haskeline.Completion import Control.Monad.State @@ -23,6 +22,7 @@ import Control.Monad import Data.List (intercalate) import qualified Data.Maybe as Maybe import GHC.Debugger.Debuggee (DebuggerLog) +import GHC.Debugger.Utils (withOriginalCurrentDirectory) data RunOptions = RunOptions { runEntryFile :: AbsFilePath @@ -54,7 +54,8 @@ runIDM :: LogAction IO InteractiveLog -> InteractiveDM a -> IO a runIDM logger entryPoint entryFile entryArgs extraGhcArgs cradleFile runConf act = do - projectRoot <- mkAbsolute <$> getCurrentDirectory + -- | See Note [ Current directory is a global property that affects HIE and GHC ] + projectRoot <- withOriginalCurrentDirectory $ pure . mkAbsolute let hieBiosLogger = contramap ISessionSetupLog logger hieDebugRunner hieBiosLogger (DebugRunnerConf (unAbs projectRoot) entryFile extraGhcArgs cradleFile) >>= \case