From 6129d977486bb224a54463cf311f9037f1f521fd Mon Sep 17 00:00:00 2001 From: Andrea Date: Thu, 23 Apr 2026 08:46:47 +0200 Subject: [PATCH 01/11] WIP: runDebugger refactor --- haskell-debugger/GHC/Debugger/Monad.hs | 175 +++++++++++++---------- haskell-debugger/GHC/Debugger/Session.hs | 6 +- 2 files changed, 101 insertions(+), 80 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 3a5d5042..63d38d3b 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -18,6 +18,7 @@ import System.Process import Control.Concurrent import Control.Concurrent.Async import Control.Exception +import qualified Data.Foldable as Foldable import Control.Monad import Control.Monad.Catch as MC import Control.Monad.IO.Class @@ -218,14 +219,99 @@ runDebugger :: forall a -> RunDebuggerSettings -- ^ Other debugger run settings -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation -> IO a -runDebugger l rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp conf (Debugger action) = annotateCallStackIO $ do +runDebugger = \ l rootDir0 compDir libdir units ghcInvocation' extraGhcArgs0 mainFp conf (Debugger action) -> annotateCallStackIO $ 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) $ - flip MC.finally cleanupInterp $ -- See Note [Shutting down the external interpreter] - do + + withHieGhcDebugSession rootDir0 compDir libdir units ghcInvocation' extraGhcArgs0 mainFp $ \ rootDir extraGhcArgs loadHomeUnit -> runDebuggerAction l ghcLog dbgLog rootDir extraGhcArgs thisProg conf action loadHomeUnit + where + lookForHDV :: (LogAction IO DebuggerLog) -> (LogAction Ghc DebuggerLog) -> (Maybe ModIfaceCache) -> Ghc (UnitId, [ModuleName]) + lookForHDV l ghcLog if_cache0 = do + hsc_env <- getSession + let mod_graph_base = hsc_mod_graph hsc_env + if_cache <- maybe (Just <$> liftIO newIfaceCache) (pure . Just) if_cache0 + let unitsWays = case fmap homeUnitEnv_dflags $ Foldable.toList $ hsc_HUG hsc_env of + [] -> error "No units" + (x:xs) -> x NonEmpty.:| xs + buildWays <- liftIO $ validateUnitsWays unitsWays + liftIO $ writeFile "mod_graph.json" $ showPprUnsafe (withPprStyle (PprDump alwaysQualify) $ ppr $ mg_mss mod_graph_base) + -- Try to find or load the built-in classes from `haskell-debugger-view` + findHsDebuggerViewUnitId mod_graph_base >>= \case + Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do + liftIO $ writeFile "hdb.unit" "Not Found" + -- Not imported by any module: no custom views. Therefore, the builtin + -- ones haven't been loaded. In this case, we will load the package ourselves. + + -- Add the custom unit to the HUG + let base_dep_uids = [uid | UnitNode _ uid <- mg_mss mod_graph_base] + 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! + ghcLog <& DebuggerLog Logger.Debug + (LogFailedToCompileDebugViewModule debuggerViewClassModName) + return [] + Succeeded -> (debuggerViewClassModName:) . concat <$> do + + forM debuggerViewInstancesMods $ \(modName, modContent, pkgName) -> do + -- Don't try to load instances whose packages are not even in + -- the module graph: + if any ((pkgName `L.isPrefixOf`) . unitIdString) base_dep_uids then do + tryLoadHsDebuggerViewModule l if_cache + ((\case + -- Keep only "GHC.Debugger.View.Class", which is a dependency of all these. + GHC.TargetFile f _ + -> f == "in-memory:" ++ moduleNameString debuggerViewClassModName + _ -> False) . GHC.targetId) + modName modContent >>= \case + Failed -> do + ghcLog <& DebuggerLog Logger.Info + (LogFailedToCompileDebugViewModule modName) + return [] + Succeeded -> do + return [modName] + else do + ghcLog <& DebuggerLog Logger.Debug + (LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids)) + return [] + + Just uid -> do + liftIO $ writeFile "hdb.unit" (showPprUnsafe $ ppr uid) + -- TODO: We assume for now that if you depended on + -- @haskell-debugger-view@, then you also depend on all its transitive + -- dependencies (containers, text, ...), thus can load all custom + -- views. Hence all `debuggerViewBuiltinMods`. In the future, we + -- may want to guard all dependencies behind cabal flags that the user + -- can tweak when depending on `haskell-debugger-view`. + return (uid, map fst debuggerViewBuiltinMods) + + + withHieGhcDebugSession rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp k = do + let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation' + GHC.runGhc (Just libdir) $ k rootDir extraGhcArgs $ do + dflags2 <- getSessionDynFlags + -- Discover the user-given flags and targets + flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags2 rootDir + + -- Setup base HomeUnitGraph + setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) + -- Downsweep user-given modules first + mod_graph_base <- doDownsweep Nothing + if_cache <- Just <$> liftIO newIfaceCache + + + -- Final load combining all base modules plus haskell-debugger-view ones that loaded successfully + -- The targets which were successfully loaded have been set with `setTarget` (e.g. by setupHomeUnitGraph). + final_mod_graph <- doDownsweep (Just mod_graph_base{-cached previous result-}) + success <- doLoad if_cache GHC.LoadAllTargets final_mod_graph + when (GHC.failed success) $ liftIO $ + throwM DebuggerFailedToLoad + pure $ if_cache + runDebuggerAction l ghcLog dbgLog rootDir extraGhcArgs thisProg conf action (loadHomeUnit :: Ghc (Maybe ModIfaceCache)) = flip MC.finally cleanupInterp $ -- See Note [Shutting down the external interpreter] + 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. @@ -353,77 +439,11 @@ runDebugger l rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp co GHC.getSessionDynFlags >>= \df -> liftIO $ GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df) - -- 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) - -- Downsweep user-given modules first - mod_graph_base <- doDownsweep Nothing - - if_cache <- Just <$> liftIO newIfaceCache - - -- Try to find or load the built-in classes from `haskell-debugger-view` - (hdv_uid, loadedBuiltinModNames) <- findHsDebuggerViewUnitId mod_graph_base >>= \case - Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do - - -- Not imported by any module: no custom views. Therefore, the builtin - -- ones haven't been loaded. In this case, we will load the package ourselves. - - -- Add the custom unit to the HUG - let base_dep_uids = [uid | UnitNode _ uid <- mg_mss mod_graph_base] - 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! - ghcLog <& DebuggerLog Logger.Debug - (LogFailedToCompileDebugViewModule debuggerViewClassModName) - return [] - Succeeded -> (debuggerViewClassModName:) . concat <$> do - - forM debuggerViewInstancesMods $ \(modName, modContent, pkgName) -> do - -- Don't try to load instances whose packages are not even in - -- the module graph: - if any ((pkgName `L.isPrefixOf`) . unitIdString) base_dep_uids then do - tryLoadHsDebuggerViewModule l if_cache - ((\case - -- Keep only "GHC.Debugger.View.Class", which is a dependency of all these. - GHC.TargetFile f _ - -> f == "in-memory:" ++ moduleNameString debuggerViewClassModName - _ -> False) . GHC.targetId) - modName modContent >>= \case - Failed -> do - ghcLog <& DebuggerLog Logger.Info - (LogFailedToCompileDebugViewModule modName) - return [] - Succeeded -> do - return [modName] - else do - ghcLog <& DebuggerLog Logger.Debug - (LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids)) - return [] - - Just uid -> - -- TODO: We assume for now that if you depended on - -- @haskell-debugger-view@, then you also depend on all its transitive - -- dependencies (containers, text, ...), thus can load all custom - -- views. Hence all `debuggerViewBuiltinMods`. In the future, we - -- may want to guard all dependencies behind cabal flags that the user - -- can tweak when depending on `haskell-debugger-view`. - return (uid, map fst debuggerViewBuiltinMods) - - -- Final load combining all base modules plus haskell-debugger-view ones that loaded successfully - -- The targets which were successfully loaded have been set with `setTarget` (e.g. by setupHomeUnitGraph). - final_mod_graph <- doDownsweep (Just mod_graph_base{-cached previous result-}) - success <- doLoad if_cache GHC.LoadAllTargets final_mod_graph - when (GHC.failed success) $ liftIO $ - throwM DebuggerFailedToLoad + if_cache <- loadHomeUnit + (hdv_uid, loadedBuiltinModNames) <- lookForHDV l ghcLog if_cache -- See Note [Must explicitly expose module graph units] - setExposedInUnit interactiveGhcDebuggerUnitId (graphUnits final_mod_graph) + setExposedInUnit interactiveGhcDebuggerUnitId . graphUnits . hsc_mod_graph =<< getSession -- Set interactive context to import all loaded modules let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" @@ -841,11 +861,12 @@ tryLoadHsDebuggerViewModule l if_cache keepTarget modName modContents = do dvcT <- liftIO $ makeInMemoryHsDebuggerViewTarget modName modContents -- Make mod_graph just for this target - GHC.setTargets (dvcT:filter keepTarget old_targets) - dvc_mod_graph <- doDownsweep Nothing + GHC.setTargets (dvcT: old_targets) + mod_graph <- hsc_mod_graph <$> GHC.getSession + dvc_mod_graph <- doDownsweep (Just mod_graph) -- And try to load it - result <- doLoad if_cache (GHC.LoadUpTo [mkModule hsDebuggerViewInMemoryUnitId modName]) dvc_mod_graph + result <- doLoad if_cache (GHC.LoadAllTargets) dvc_mod_graph -- Restore targets plus new one if success GHC.setTargets (old_targets ++ (if succeeded result then [dvcT] else [])) diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index 940b011c..29975da3 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -285,9 +285,9 @@ setupMultiHomeUnitGhcSession exts hsc_env cis = do -- | 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 +validateUnitsWays :: NonEmpty.NonEmpty DynFlags -> IO Ways +validateUnitsWays flags = do + let unitWays = NonEmpty.map ways flags firstWays = NonEmpty.head unitWays restWays = NonEmpty.tail unitWays if all (== firstWays) restWays From 34a8c011f44f1696ed60af81bdb76640879fdf89 Mon Sep 17 00:00:00 2001 From: Andrea Date: Fri, 24 Apr 2026 21:44:33 +0200 Subject: [PATCH 02/11] WIP: compileOne instead of load in-memory:hdv --- haskell-debugger/GHC/Debugger/Monad.hs | 14 ++-- haskell-debugger/GHC/Debugger/Session.hs | 83 +++++++++++++++++++++++- 2 files changed, 87 insertions(+), 10 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 63d38d3b..973d9301 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -440,11 +440,12 @@ runDebugger = \ l rootDir0 compDir libdir units ghcInvocation' extraGhcArgs0 mai GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df) if_cache <- loadHomeUnit - (hdv_uid, loadedBuiltinModNames) <- lookForHDV l ghcLog if_cache - -- See Note [Must explicitly expose module graph units] setExposedInUnit interactiveGhcDebuggerUnitId . graphUnits . hsc_mod_graph =<< getSession + (hdv_uid, loadedBuiltinModNames) <- lookForHDV l ghcLog if_cache + + -- Set interactive context to import all loaded modules let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" -- dbgView should always be available, either because we manually loaded it @@ -860,16 +861,13 @@ tryLoadHsDebuggerViewModule l if_cache keepTarget modName modContents = do -- Make the target dvcT <- liftIO $ makeInMemoryHsDebuggerViewTarget modName modContents - -- Make mod_graph just for this target + -- add Target to modgraph GHC.setTargets (dvcT: old_targets) mod_graph <- hsc_mod_graph <$> GHC.getSession dvc_mod_graph <- doDownsweep (Just mod_graph) + modifySession (setModuleGraph dvc_mod_graph) - -- And try to load it - result <- doLoad if_cache (GHC.LoadAllTargets) dvc_mod_graph - - -- Restore targets plus new one if success - GHC.setTargets (old_targets ++ (if succeeded result then [dvcT] else [])) + result <- compileModuleWithDepsInHpt dvcT -- Restore logger GHC.modifyLogger $ diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index 29975da3..bf5e572a 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies, CPP, RecordWildCards #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NondecreasingIndentation #-} -- | Initialise the GHC session for one or more home units. -- @@ -31,6 +32,7 @@ module GHC.Debugger.Session ( resumeExec, setExposedInUnit, graphUnits, + compileModuleWithDepsInHpt, ) where @@ -73,10 +75,26 @@ import qualified GHC.Unit.Home.Graph as HUG import qualified Data.Set as Set import Data.Maybe import GHC.Types.Target (InputFileBuffer) -import GHC (SingleStep, ExecResult) +import GHC (SingleStep, ExecResult, SuccessFlag (..), ModSummary (ms_hspp_opts)) import Data.Set (Set) import qualified GHC.Unit as GHC -import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), ModNodeKeyWithUid (mnkUnitId), mnKey) +import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), ModNodeKeyWithUid (mnkUnitId), mnKey, ModuleNodeInfo (..)) +import GHC.Driver.Make +import GHC.Driver.Main (Messager) +import GHC.Driver.Errors.Types (GhcMessage) +import Data.Graph (SCC) +import GHC.Driver.MakeAction +import GHC.Unit.Home.ModInfo (HomeModInfo(..)) +import qualified GHC.Driver.Errors.Types as GHC +import System.Directory (doesFileExist) +import qualified GHC.Types.Error as GHC +import qualified GHC.Utils.Error as GHC +import qualified GHC.Plugins as GHC +import GHC.Driver.Pipeline (compileOne) +import qualified GHC.Unit.Home.ModInfo as GHC +import GHC.Utils.TmpFs +import Data.Foldable (for_) +import GHC.Plugins (SourceError, try) -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m @@ -382,6 +400,67 @@ getCacheDirs prefix opts = do -- GHC options will create incompatible interface files. opts_hash = B.unpack $ B16.encode $ H.finalize $ H.updates H.init (map B.pack opts) + +getTargetFileSummary :: + HscEnv -> + GHC.Target -> + IO (Either GHC.DriverMessages GHC.ModSummary) +getTargetFileSummary hsc_env target + | GHC.TargetFile file mb_phase <- targetId + = do + let offset_file = GHC.augmentByWorkingDirectory dflags file + exists <- liftIO $ doesFileExist offset_file + if exists || isJust maybe_buf + then summariseFile hsc_env home_unit old_summary_map offset_file mb_phase + maybe_buf + else + return $ Left $ GHC.singleMessage $ + GHC.mkPlainErrorMsgEnvelope noSrcSpan (GHC.DriverFileNotFound offset_file) + | otherwise = error "FIXME" + where + old_summary_map = Map.empty + GHC.Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target + home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) + -- rootLoc = mkGeneralSrcSpan (GHC.fsLit "") + dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)) + +compileModuleWithDepsInHpt :: GhcMonad m => + GHC.Target -> + m SuccessFlag +compileModuleWithDepsInHpt target@GHC.Target{targetUnitId = uid} = do + hsc_env0 <- getSession + let !old_active = hscActiveUnitId hsc_env0 + let !hsc_env = hscSetActiveUnitId uid hsc_env0 + ehmi <- liftIO $ try @SourceError $ do + Right summary <- getTargetFileSummary hsc_env target + result <- compileOne hsc_env (forceRecomp summary) 1 1 Nothing (GHC.HomeModLinkable Nothing Nothing) + + cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (ms_hspp_opts summary) + pure result + case ehmi of + Left e -> do + liftIO $ putStrLn $ "COMP FAILED" ++ show e -- FIXME + return Failed + Right hmi -> do + setSession . hscSetActiveUnitId old_active =<< liftIO (addDepsToHscEnv [hmi] hsc_env) + return Succeeded + where + -- This bypasses another recompilation check in 'compileOne' + forceRecomp summary = + summary {ms_hspp_opts = gopt_set (ms_hspp_opts summary) Opt_ForceRecomp} + +addDepsToHscEnv :: [HomeModInfo] -> HscEnv -> IO HscEnv +addDepsToHscEnv deps hsc_env = do + for_ deps $ \ dep -> hscInsertHPT dep hsc_env + pure hsc_env + +--cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () +cleanCurrentModuleTempFilesMaybe :: MonadIO m => GHC.Logger -> TmpFs -> DynFlags -> m () +cleanCurrentModuleTempFilesMaybe logger tmpfs dflags = + if gopt Opt_KeepTmpFiles dflags + then liftIO $ keepCurrentModuleTempFiles logger tmpfs + else liftIO $ cleanCurrentModuleTempFiles logger tmpfs + -- ---------------------------------------------------------------------------- -- The Interactive DynFlags -- ---------------------------------------------------------------------------- From 7960b9a26015c31f4de4cc545746bc738411ac66 Mon Sep 17 00:00:00 2001 From: Andrea Date: Mon, 27 Apr 2026 17:44:33 +0200 Subject: [PATCH 03/11] WIP: runDebugger refactor --- haskell-debugger/GHC/Debugger/Monad.hs | 611 +++++++++--------- haskell-debugger/GHC/Debugger/Session.hs | 27 +- .../GHC/Debugger/Session/Builtin.hs | 11 +- hdb/Development/Debug/Adapter/Init.hs | 3 + hdb/Main.hs | 2 + test/golden/T135/T135.ghc-914.hdb-stdout | 3 +- test/golden/T154/T154.ghc-914.hdb-stdout | 3 +- test/golden/T159/T159.ghc-914.hdb-stdout | 3 +- test/golden/T164/T164.ghc-914.hdb-stdout | 3 +- test/golden/T166/T166.ghc-914.hdb-stdout | 3 +- test/golden/T169/T169.ghc-914.hdb-stdout | 3 +- test/golden/T169/T169b.ghc-914.hdb-stdout | 3 +- .../T169/T169c.external.ghc-914.hdb-stdout | 3 +- .../T169/T169c.internal.ghc-914.hdb-stdout | 3 +- test/golden/T217/T217.ghc-914.hdb-stdout | 7 +- test/golden/T218/T218.ghc-914.hdb-stdout | 3 +- test/golden/T225/T225.ghc-914.hdb-stdout | 3 +- test/golden/T225b/T225b.ghc-914.hdb-stdout | 6 +- test/golden/T242/T242.ghc-914.hdb-stdout | 3 +- test/golden/T283/T283.ghc-914.hdb-stdout | 3 +- test/golden/T61/T61.ghc-914.hdb-stdout | 3 +- test/golden/T79/T79.ghc-914.hdb-stdout | 3 +- test/golden/T83/T83.ghc-914.hdb-stdout | 3 +- .../exceptions-multiple.ghc-914.hdb-stdout | 3 +- .../exceptions-uncaught.ghc-914.hdb-stdout | 3 +- .../exceptions/exceptions.ghc-914.hdb-stdout | 3 +- 26 files changed, 347 insertions(+), 377 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 973d9301..164ba6d6 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -13,7 +13,6 @@ module GHC.Debugger.Monad where -import System.Environment import System.Process import Control.Concurrent import Control.Concurrent.Async @@ -46,7 +45,7 @@ import GHC.Data.StringBuffer import GHC.Driver.Config.Diagnostic import GHC.Driver.Config.Logger import GHC.Driver.DynFlags as GHC -import GHC.Driver.Env +import GHC.Driver.Env as GHC import GHC.Driver.Monad import GHC.Driver.Hooks import GHC.Driver.Errors @@ -204,6 +203,7 @@ data RunDebuggerSettings = RunDebuggerSettings -- -- Left: we launch our own external interpreter process through -- GHC's spawnIServ using the given StdStream as the stdin. + , externalInterpreterProg :: FilePath } -- | Run a 'Debugger' action on a session constructed from a given GHC invocation. @@ -219,289 +219,292 @@ runDebugger :: forall a -> RunDebuggerSettings -- ^ Other debugger run settings -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation -> IO a -runDebugger = \ l rootDir0 compDir libdir units ghcInvocation' extraGhcArgs0 mainFp conf (Debugger action) -> annotateCallStackIO $ do - let ghcLog = liftLogIO l :: LogAction Ghc DebuggerLog - let dbgLog = liftLogIO l :: LogAction Debugger DebuggerLog - thisProg <- getExecutablePath - - withHieGhcDebugSession rootDir0 compDir libdir units ghcInvocation' extraGhcArgs0 mainFp $ \ rootDir extraGhcArgs loadHomeUnit -> runDebuggerAction l ghcLog dbgLog rootDir extraGhcArgs thisProg conf action loadHomeUnit - where - lookForHDV :: (LogAction IO DebuggerLog) -> (LogAction Ghc DebuggerLog) -> (Maybe ModIfaceCache) -> Ghc (UnitId, [ModuleName]) - lookForHDV l ghcLog if_cache0 = do - hsc_env <- getSession - let mod_graph_base = hsc_mod_graph hsc_env - if_cache <- maybe (Just <$> liftIO newIfaceCache) (pure . Just) if_cache0 - let unitsWays = case fmap homeUnitEnv_dflags $ Foldable.toList $ hsc_HUG hsc_env of - [] -> error "No units" - (x:xs) -> x NonEmpty.:| xs - buildWays <- liftIO $ validateUnitsWays unitsWays - liftIO $ writeFile "mod_graph.json" $ showPprUnsafe (withPprStyle (PprDump alwaysQualify) $ ppr $ mg_mss mod_graph_base) - -- Try to find or load the built-in classes from `haskell-debugger-view` - findHsDebuggerViewUnitId mod_graph_base >>= \case - Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do - liftIO $ writeFile "hdb.unit" "Not Found" - -- Not imported by any module: no custom views. Therefore, the builtin - -- ones haven't been loaded. In this case, we will load the package ourselves. - - -- Add the custom unit to the HUG - let base_dep_uids = [uid | UnitNode _ uid <- mg_mss mod_graph_base] - 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! - ghcLog <& DebuggerLog Logger.Debug - (LogFailedToCompileDebugViewModule debuggerViewClassModName) - return [] - Succeeded -> (debuggerViewClassModName:) . concat <$> do - - forM debuggerViewInstancesMods $ \(modName, modContent, pkgName) -> do - -- Don't try to load instances whose packages are not even in - -- the module graph: - if any ((pkgName `L.isPrefixOf`) . unitIdString) base_dep_uids then do - tryLoadHsDebuggerViewModule l if_cache - ((\case - -- Keep only "GHC.Debugger.View.Class", which is a dependency of all these. - GHC.TargetFile f _ - -> f == "in-memory:" ++ moduleNameString debuggerViewClassModName - _ -> False) . GHC.targetId) - modName modContent >>= \case - Failed -> do - ghcLog <& DebuggerLog Logger.Info - (LogFailedToCompileDebugViewModule modName) - return [] - Succeeded -> do - return [modName] - else do - ghcLog <& DebuggerLog Logger.Debug - (LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids)) - return [] - - Just uid -> do - liftIO $ writeFile "hdb.unit" (showPprUnsafe $ ppr uid) - -- TODO: We assume for now that if you depended on - -- @haskell-debugger-view@, then you also depend on all its transitive - -- dependencies (containers, text, ...), thus can load all custom - -- views. Hence all `debuggerViewBuiltinMods`. In the future, we - -- may want to guard all dependencies behind cabal flags that the user - -- can tweak when depending on `haskell-debugger-view`. - return (uid, map fst debuggerViewBuiltinMods) - - - withHieGhcDebugSession rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp k = do - let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation' - GHC.runGhc (Just libdir) $ k rootDir extraGhcArgs $ do - dflags2 <- getSessionDynFlags - -- Discover the user-given flags and targets - flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags2 rootDir - - -- Setup base HomeUnitGraph - setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) - -- Downsweep user-given modules first - mod_graph_base <- doDownsweep Nothing - if_cache <- Just <$> liftIO newIfaceCache - - - -- Final load combining all base modules plus haskell-debugger-view ones that loaded successfully - -- The targets which were successfully loaded have been set with `setTarget` (e.g. by setupHomeUnitGraph). - final_mod_graph <- doDownsweep (Just mod_graph_base{-cached previous result-}) - success <- doLoad if_cache GHC.LoadAllTargets final_mod_graph - when (GHC.failed success) $ liftIO $ - throwM DebuggerFailedToLoad - pure $ if_cache - runDebuggerAction l ghcLog dbgLog rootDir extraGhcArgs thisProg conf action (loadHomeUnit :: Ghc (Maybe ModIfaceCache)) = flip MC.finally cleanupInterp $ -- See Note [Shutting down the external interpreter] - do +runDebugger l rootDir0 compDir libdir units ghcInvocation' extraGhcArgs0 mainFp conf (Debugger action) = annotateCallStackIO $ do + withHieGhcDebugSession rootDir0 compDir libdir units ghcInvocation' extraGhcArgs0 mainFp $ \ rootDir extraGhcArgs loadHomeUnit -> runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit action + +-- FIXME: organize arguments somehow. +withHieGhcDebugSession :: GhcMonad m => FilePath -> FilePath -> FilePath -> [String] -> [[Char]] -> p -> FilePath -> (FilePath -> p -> m () -> Ghc a) -> IO a +withHieGhcDebugSession rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp k = do + let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation' + GHC.runGhc (Just libdir) $ k rootDir extraGhcArgs $ do + dflags2 <- getSessionDynFlags + + -- Discover the user-given flags and targets + flagsAndTargets <- parseHomeUnitArguments mainFp compDir units ghcInvocation dflags2 rootDir + + -- Setup HomeUnitGraph with debugee and interactiveGhcDebugger units + setupHomeUnitGraph (NonEmpty.toList flagsAndTargets) + + debugee_mod_graph <- doDownsweep Nothing + + if_cache <- Just <$> liftIO newIfaceCache + success <- doLoad if_cache GHC.LoadAllTargets debugee_mod_graph + + when (GHC.failed success) $ liftIO $ + throwM DebuggerFailedToLoad + +runDebuggerAction :: forall a. LogAction IO DebuggerLog + -> FilePath -- ^ rootDir + -> [String] -- ^ extraGhcArgs + -> RunDebuggerSettings + -> Ghc () -- ^ load home units action + -> ReaderT DebuggerState Ghc a + -> Ghc a +runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit action = flip MC.finally cleanupInterp $ -- See Note [Shutting down the external interpreter] + 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 + -- 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 - dflags0 <- GHC.getSessionDynFlags - let dflags1 = dflags0 - { GHC.ghcMode = GHC.CompManager - , GHC.ghcLink = GHC.LinkInMemory - , GHC.verbosity = 1 - , GHC.canUseColor = conf.supportsANSIStyling - , GHC.canUseErrorLinks = conf.supportsANSIHyperlinks - } - -- Default debugger settings - `GHC.xopt_set` LangExt.TypeApplications - `GHC.xopt_set` LangExt.PackageImports - `GHC.xopt_set` LangExt.MagicHash -- needed for some of the expressions we compile - `GHC.gopt_set` GHC.Opt_ImplicitImportQualified - `GHC.gopt_set` GHC.Opt_IgnoreOptimChanges - `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 $ ghcLogAction l - - dflags2 <- getLogger >>= \logger -> do - -- Set the extra GHC arguments for ALL units by setting them early in - -- dynflags. This is important to make sure unfoldings for interfaces - -- loaded because of the built-in loaded classes (like - -- GHC.Debugger.View.Class) behave the same as if they were loaded for - -- the user program. Otherwise we may run into the problem which - -- 3093efa27468fb2d31a617f6a0e4ff67a90f6623 tried to fix (but had to be - -- reverted) - (dflags2, fileish_args, warns) - <- parseDynamicFlagsWithRootDir rootDir logger dflags1 (map noLoc extraGhcArgs) - liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns) - forM_ fileish_args $ \fish_arg -> liftIO $ do - 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 - - -- 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] + dflags0 <- GHC.getSessionDynFlags + let dflags1 = dflags0 + { GHC.ghcMode = GHC.CompManager + , GHC.ghcLink = GHC.LinkInMemory + , GHC.verbosity = 1 + , GHC.canUseColor = conf.supportsANSIStyling + , GHC.canUseErrorLinks = conf.supportsANSIHyperlinks + } + -- Default debugger settings + `GHC.xopt_set` LangExt.TypeApplications + `GHC.xopt_set` LangExt.PackageImports + `GHC.xopt_set` LangExt.MagicHash -- needed for some of the expressions we compile + `GHC.gopt_set` GHC.Opt_ImplicitImportQualified + `GHC.gopt_set` GHC.Opt_IgnoreOptimChanges + `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 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" + + -- 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 $ ghcLogAction l + + dflags2 <- getLogger >>= \logger -> do + -- Set the extra GHC arguments for ALL units by setting them early in + -- dynflags. This is important to make sure unfoldings for interfaces + -- loaded because of the built-in loaded classes (like + -- GHC.Debugger.View.Class) behave the same as if they were loaded for + -- the user program. Otherwise we may run into the problem which + -- 3093efa27468fb2d31a617f6a0e4ff67a90f6623 tried to fix (but had to be + -- reverted) + (dflags2, fileish_args, warns) + <- parseDynamicFlagsWithRootDir rootDir logger dflags1 (map noLoc extraGhcArgs) + liftIO $ printOrThrowDiagnostics logger (initPrintConfig dflags2) (initDiagOpts dflags2) (GhcDriverMessage <$> warns) + forM_ fileish_args $ \fish_arg -> liftIO $ do + 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 + + -- 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 $ thisProg : drop 1 ws - RawCommand _fp args -> RawCommand thisProg args + , 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 + -- Initializes interpreter! + _ <- GHC.setSessionDynFlags dflags2 + + -- Initialise plugins here because the plugin author might already expect this + -- subsequent call to `getLogger` to be affected by a plugin. + GHC.initializeSessionPlugins + + GHC.getSessionDynFlags >>= \df -> liftIO $ + GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df) + + loadHomeUnit + -- See Note [Must explicitly expose module graph units] + setExposedInUnit interactiveGhcDebuggerUnitId . graphUnits . hsc_mod_graph =<< getSession + + -- Ensure all the home units are built with same Ways and return them. + buildWays <- do + hug_dflags <- fmap homeUnitEnv_dflags . Foldable.toList . hsc_HUG <$> getSession + liftIO $ validateUnitsWays $ case hug_dflags of + [] -> error "No units" + (x:xs) -> x NonEmpty.:| xs + + -- Find haskell-debugger-view in (deps of) home units, or load one from + -- in-memory sources. + (hdv_uid, loadedBuiltinModNames) <- findOrLoadHaskellDebuggerView l buildWays + + + -- Set interactive context to import all loaded modules + let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" + -- dbgView should always be available, either because we manually loaded it + -- or because it's in the transitive closure. + hug <- hsc_HUG <$> getSession + let dbgViewImps + -- If hs-dbg-view is a home-unit, refer to it directly + -- See Note [Do not package-qualify imports for home units] + | memberHugUnitId hdv_uid hug + = map (GHC.IIModule . mkModule (RealUnit (Definite hdv_uid))) loadedBuiltinModNames + -- It's available in an exposed unit in the transitive closure. Resolve it + | otherwise + = map (\mn -> + GHC.IIDecl (GHC.simpleImportDecl mn) + { ideclPkgQual = RawPkgQual + StringLiteral + { sl_st = NoSourceText + , sl_fs = mkFastString (unitIdString hdv_uid) + , sl_tc = Nothing } - 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 - -- Initializes interpreter! - _ <- GHC.setSessionDynFlags dflags2 - - -- Initialise plugins here because the plugin author might already expect this - -- subsequent call to `getLogger` to be affected by a plugin. - GHC.initializeSessionPlugins - - GHC.getSessionDynFlags >>= \df -> liftIO $ - GHC.initUniqSupply (GHC.initialUnique df) (GHC.uniqueIncrement df) - - if_cache <- loadHomeUnit - -- See Note [Must explicitly expose module graph units] - setExposedInUnit interactiveGhcDebuggerUnitId . graphUnits . hsc_mod_graph =<< getSession - - (hdv_uid, loadedBuiltinModNames) <- lookForHDV l ghcLog if_cache - - - -- Set interactive context to import all loaded modules - let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude" - -- dbgView should always be available, either because we manually loaded it - -- or because it's in the transitive closure. - hug <- hsc_HUG <$> getSession - let dbgViewImps - -- If hs-dbg-view is a home-unit, refer to it directly - -- See Note [Do not package-qualify imports for home units] - | memberHugUnitId hdv_uid hug - = map (GHC.IIModule . mkModule (RealUnit (Definite hdv_uid))) loadedBuiltinModNames - -- It's available in an exposed unit in the transitive closure. Resolve it - | otherwise - = map (\mn -> - GHC.IIDecl (GHC.simpleImportDecl mn) - { ideclPkgQual = RawPkgQual - StringLiteral - { sl_st = NoSourceText - , sl_fs = mkFastString (unitIdString hdv_uid) - , sl_tc = Nothing - } - }) loadedBuiltinModNames - - mss <- getAllLoadedModules - - GHC.setContext - (preludeImp : - dbgViewImps ++ - map (GHC.IIModule . GHC.ms_mod) mss) - - -- 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 - - noPrint <- defineNoPrint - modifySession (\hsc_env -> hsc_env {hsc_IC = GHCi.setInteractivePrintName (hsc_IC hsc_env) noPrint}) - - runReaderT action - =<< initialDebuggerState dbgLog - (if loadedBuiltinModNames == [] - 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 -> do - withAsync (void externalInterpFwdThread) $ \ fwd_thr -> do - liftIO $ link fwd_thr - unlift mainGhcThread - Right _ -> - -- Ext interp is running in user terminal, no need to forward output to logger - mainGhcThread + }) loadedBuiltinModNames + + mss <- getAllLoadedModules + + GHC.setContext + (preludeImp : + dbgViewImps ++ + map (GHC.IIModule . GHC.ms_mod) mss) + + -- 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 } + """ + + -- FIXME: does this implicitly wait for the interpreter to be ready, or should we do so explicitly? + hscInterp <$> GHC.getSession >>= \interp -> + liftIO $ evalIO interp setBufferings + + noPrint <- defineNoPrint + modifySession (\hsc_env -> hsc_env {hsc_IC = GHCi.setInteractivePrintName (hsc_IC hsc_env) noPrint}) + + runReaderT action + =<< initialDebuggerState (liftLogIO l) + (if loadedBuiltinModNames == [] + 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 -> do + withAsync (void externalInterpFwdThread) $ \ fwd_thr -> do + liftIO $ link fwd_thr + unlift mainGhcThread + Right _ -> + -- Ext interp is running in user terminal, no need to forward output to logger + mainGhcThread + +findOrLoadHaskellDebuggerView :: LogAction IO DebuggerLog + -> Ways + -> Ghc (UnitId, [ModuleName]) +findOrLoadHaskellDebuggerView l buildWays = do + let ghcLog = liftLogIO l + hsc_env <- getSession + let mod_graph_base = hsc_mod_graph hsc_env + + -- Try to find or load the built-in classes from `haskell-debugger-view` + findHsDebuggerViewUnitId mod_graph_base >>= \case + Nothing -> (hsDebuggerViewInMemoryUnitId,) <$> do + -- Not imported by any module: no custom views. Therefore, the builtin + -- ones haven't been loaded. In this case, we will load the package ourselves. + + -- Add the custom unit to the HUG + let base_dep_uids = [uid | UnitNode _ uid <- mg_mss mod_graph_base] + addInMemoryHsDebuggerViewUnit base_dep_uids . setDynFlagWays buildWays =<< getDynFlags + + -- Load unit modules using in-memory contents. + let + -- Don't try to load instances whose packages are not even in the + -- module graph. + (instanceMods,skipped) = L.partition (\ (_modName,_modContent,pkgName) -> any ((pkgName `L.isPrefixOf`) . unitIdString) base_dep_uids) + debuggerViewInstancesMods + modsToLoad = + (debuggerViewClassModName,debuggerViewClassContents) + : [ (modName,modContent) + | (modName, modContent, _pkgName) <- instanceMods] + + forM_ skipped $ \(modName,_,pkgName) -> + ghcLog <& DebuggerLog Logger.Debug + (LogSkippingViewModuleNoPkg modName pkgName (map unitIdString base_dep_uids)) + + successes <- loadInMemoryModules l hsDebuggerViewInMemoryUnitId modsToLoad + + fmap catMaybes . forM (zip successes modsToLoad) $ \case + (Failed,(modName,_)) -> do + ghcLog <& DebuggerLog Logger.Debug + (LogFailedToCompileDebugViewModule modName) + return $ Nothing + (Succeeded,(modName,_)) -> + return $ Just modName + + Just uid -> do + -- TODO: We assume for now that if you depended on + -- @haskell-debugger-view@, then you also depend on all its transitive + -- dependencies (containers, text, ...), thus can load all custom + -- views. Hence all `debuggerViewBuiltinMods`. In the future, we + -- may want to guard all dependencies behind cabal flags that the user + -- can tweak when depending on `haskell-debugger-view`. + return (uid, map fst debuggerViewBuiltinMods) {- Note [Shutting down the external interpreter] @@ -833,48 +836,42 @@ doLoad if_cache how_much mg = do let msg = batchMultiMsg load' if_cache how_much mkUnknownDiagnostic (Just msg) mg --- | Returns @Just modName@ if the given module was successfully loaded -tryLoadHsDebuggerViewModule - :: GhcMonad m + +loadInMemoryModules :: + GhcMonad m => LogAction IO DebuggerLog - -> Maybe ModIfaceCache - -> (GHC.Target -> Bool) - -- ^ Predicate to determine which of the existing - -- targets should be re-used when doing downsweep - -- Should be as minimal as necessary (i.e. just DebugView class for the - -- instances modules). - -> ModuleName -> StringBuffer -> m SuccessFlag -tryLoadHsDebuggerViewModule l if_cache keepTarget modName modContents = do - dflags <- getDynFlags - -- Store existing targets to restore afterwards - -- We want to use as little targets as possible to keep downsweep minimal+fast + -> UnitId + -> [(ModuleName,StringBuffer)] -> m [SuccessFlag] +loadInMemoryModules l uid ts = do old_targets <- GHC.getTargets + tgts <- forM ts $ \(modName,modContents) -> + liftIO $ makeInMemoryTarget uid modName modContents + GHC.setTargets (tgts ++ old_targets) + mod_graph <- hsc_mod_graph <$> GHC.getSession + -- TODO: use [incremental API](https://gitlab.haskell.org/ghc/ghc/-/issues/27054) when ready. + dvc_mod_graph <- doDownsweep (Just mod_graph) + modifySession $ GHC.setModuleGraph dvc_mod_graph - -- Also: temporarily disable the logger! We don't want to show the user these - -- modules we're trying to load and compile. restore_logger <- GHC.getLogger + dflags <- getSessionDynFlags GHC.modifyLogger $ -- Emit it all as Debug-level debugger logs GHC.pushLogHook $ const $ \_ _ _ sdoc -> l <& DebuggerLog Logger.Debug (LogSDoc dflags sdoc) - -- Make the target - dvcT <- liftIO $ makeInMemoryHsDebuggerViewTarget modName modContents - - -- add Target to modgraph - GHC.setTargets (dvcT: old_targets) - mod_graph <- hsc_mod_graph <$> GHC.getSession - dvc_mod_graph <- doDownsweep (Just mod_graph) - modifySession (setModuleGraph dvc_mod_graph) - - result <- compileModuleWithDepsInHpt dvcT + -- Might not make sense to keep going if the first fails, but we expect all of + -- them to succeed, and it's not that many more modules. + s <- forM tgts $ \ tgt -> compileModuleWithDepsInHpt tgt >>= \case + Nothing -> pure Succeeded + Just e -> do + liftLogIO l <& DebuggerLog Logger.Debug (LogSDoc dflags $ text (show e)) + pure Failed -- Restore logger GHC.modifyLogger $ GHC.pushLogHook (const $ GHC.putLogMsg restore_logger) - - return result + return s -------------------------------------------------------------------------------- -- * Finding Debugger View diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index bf5e572a..647dcced 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -78,18 +78,13 @@ import GHC.Types.Target (InputFileBuffer) import GHC (SingleStep, ExecResult, SuccessFlag (..), ModSummary (ms_hspp_opts)) import Data.Set (Set) import qualified GHC.Unit as GHC -import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), ModNodeKeyWithUid (mnkUnitId), mnKey, ModuleNodeInfo (..)) +import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), mnKey) import GHC.Driver.Make -import GHC.Driver.Main (Messager) -import GHC.Driver.Errors.Types (GhcMessage) -import Data.Graph (SCC) -import GHC.Driver.MakeAction import GHC.Unit.Home.ModInfo (HomeModInfo(..)) import qualified GHC.Driver.Errors.Types as GHC import System.Directory (doesFileExist) import qualified GHC.Types.Error as GHC import qualified GHC.Utils.Error as GHC -import qualified GHC.Plugins as GHC import GHC.Driver.Pipeline (compileOne) import qualified GHC.Unit.Home.ModInfo as GHC import GHC.Utils.TmpFs @@ -421,29 +416,26 @@ getTargetFileSummary hsc_env target old_summary_map = Map.empty GHC.Target {targetId, targetContents = maybe_buf, targetUnitId = uid} = target home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env) - -- rootLoc = mkGeneralSrcSpan (GHC.fsLit "") dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env)) compileModuleWithDepsInHpt :: GhcMonad m => GHC.Target -> - m SuccessFlag + m (Maybe SourceError) compileModuleWithDepsInHpt target@GHC.Target{targetUnitId = uid} = do hsc_env0 <- getSession let !old_active = hscActiveUnitId hsc_env0 let !hsc_env = hscSetActiveUnitId uid hsc_env0 - ehmi <- liftIO $ try @SourceError $ do - Right summary <- getTargetFileSummary hsc_env target - result <- compileOne hsc_env (forceRecomp summary) 1 1 Nothing (GHC.HomeModLinkable Nothing Nothing) - - cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (ms_hspp_opts summary) - pure result + ehmi <- liftIO $ try @SourceError $ do + Right summary <- getTargetFileSummary hsc_env target + result <- compileOne hsc_env (forceRecomp summary) 1 1 Nothing (GHC.HomeModLinkable Nothing Nothing) + cleanCurrentModuleTempFilesMaybe (hsc_logger hsc_env) (hsc_tmpfs hsc_env) (ms_hspp_opts summary) + pure result case ehmi of Left e -> do - liftIO $ putStrLn $ "COMP FAILED" ++ show e -- FIXME - return Failed + return $ Just e Right hmi -> do setSession . hscSetActiveUnitId old_active =<< liftIO (addDepsToHscEnv [hmi] hsc_env) - return Succeeded + return Nothing where -- This bypasses another recompilation check in 'compileOne' forceRecomp summary = @@ -454,7 +446,6 @@ addDepsToHscEnv deps hsc_env = do for_ deps $ \ dep -> hscInsertHPT dep hsc_env pure hsc_env ---cleanCurrentModuleTempFilesMaybe :: MonadIO m => Logger -> TmpFs -> DynFlags -> m () cleanCurrentModuleTempFilesMaybe :: MonadIO m => GHC.Logger -> TmpFs -> DynFlags -> m () cleanCurrentModuleTempFilesMaybe logger tmpfs dflags = if gopt Opt_KeepTmpFiles dflags diff --git a/haskell-debugger/GHC/Debugger/Session/Builtin.hs b/haskell-debugger/GHC/Debugger/Session/Builtin.hs index 0385d77a..c36bbf18 100644 --- a/haskell-debugger/GHC/Debugger/Session/Builtin.hs +++ b/haskell-debugger/GHC/Debugger/Session/Builtin.hs @@ -10,7 +10,7 @@ module GHC.Debugger.Session.Builtin -- * In memory unit , hsDebuggerViewInMemoryUnitId , addInMemoryHsDebuggerViewUnit - , makeInMemoryHsDebuggerViewTarget + , makeInMemoryTarget -- Note: -- Don't export instances mods individually to make sure we get warnings if @@ -128,15 +128,14 @@ addInMemoryHsDebuggerViewUnit base_uids initialDynFlags = do in HUG.unitEnv_insert hsDebuggerViewInMemoryUnitId hdv_hue hug ) --- | Make an in-memory 'GHC.Target' for a @haskell-debugger-view@ built-in --- module from the module name and contents -makeInMemoryHsDebuggerViewTarget :: ModuleName -> StringBuffer -> IO GHC.Target -makeInMemoryHsDebuggerViewTarget modName sb = do +-- | Make an in-memory 'GHC.Target' for a module from the module name and contents +makeInMemoryTarget :: UnitId -> ModuleName -> StringBuffer -> IO GHC.Target +makeInMemoryTarget uid modName sb = do time <- getCurrentTime let mkTarget mn contents = GHC.Target { targetId = GHC.TargetFile ("in-memory:" ++ moduleNameString mn) Nothing , targetAllowObjCode = False - , GHC.targetUnitId = hsDebuggerViewInMemoryUnitId + , GHC.targetUnitId = uid , GHC.targetContents = Just (contents, time) } return $ mkTarget modName sb diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index 5e4c55b5..ee8bc6a5 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -58,6 +58,7 @@ import Development.Debug.Adapter.Proxy import System.Environment import Network.Socket (socketPort) import qualified Network.Socket as Socket +import GHC.Debugger.Monad (RunDebuggerSettings(externalInterpreterCustomProc)) -------------------------------------------------------------------------------- -- * Client @@ -176,6 +177,7 @@ initDebugger l supportsRunInTerminal preferInternalInterpreter (runInTerminalThreads, afterRegisterActions) <- mkRunInTerminalThreads l runInTerminalProc preferInternalInterpreter + thisProg <- liftIO getExecutablePath let defaultRunConf = Debugger.RunDebuggerSettings { supportsANSIStyling = True -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap @@ -185,6 +187,7 @@ initDebugger l supportsRunInTerminal preferInternalInterpreter RunExternalInterpreterInTerminal{extInterpPort} -> Right extInterpPort _ -> Left CreatePipe -- if not runInTerminal, just create a new pipe for stdin + , externalInterpreterProg = thisProg } absEntryFile = normalise $ projectRoot entryFile daState = DAS{entryFile=absEntryFile,..} diff --git a/hdb/Main.hs b/hdb/Main.hs index ab694cd2..5d22dbd3 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -96,11 +96,13 @@ main = do stdinStream <- case debuggeeStdin of Just fp -> UseHandle <$> System.IO.openFile fp ReadMode Nothing -> pure Inherit + thisProg <- getExecutablePath let runConf = RunDebuggerSettings { supportsANSIStyling = True -- todo: check!! , supportsANSIHyperlinks = False , preferInternalInterpreter = internalInterpreter , externalInterpreterCustomProc = Left stdinStream + , externalInterpreterProg = thisProg } runIDM (contramap InteractiveLog l) entryPoint entryFile entryArgs extraGhcArgs runConf debugInteractive diff --git a/test/golden/T135/T135.ghc-914.hdb-stdout b/test/golden/T135/T135.ghc-914.hdb-stdout index 79923c4e..c68de5f7 100644 --- a/test/golden/T135/T135.ghc-914.hdb-stdout +++ b/test/golden/T135/T135.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /myapp/app/Main.hs, interpreted )[myapp-0.1.0.0-inplace-myapp] +[1 of 2] Compiling Main ( /myapp/app/Main.hs, interpreted )[myapp-0.1.0.0-inplace-myapp] /myapp/app/Main.hs:3:1: warning: [GHC-66111] [-Wunused-imports] The import of ‘MyLib’ is redundant except perhaps to import instances from ‘MyLib’ diff --git a/test/golden/T154/T154.ghc-914.hdb-stdout b/test/golden/T154/T154.ghc-914.hdb-stdout index c852858d..2b552170 100644 --- a/test/golden/T154/T154.ghc-914.hdb-stdout +++ b/test/golden/T154/T154.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) hello () (hdb) Exiting... diff --git a/test/golden/T159/T159.ghc-914.hdb-stdout b/test/golden/T159/T159.ghc-914.hdb-stdout index 2a9e583d..c30e703c 100644 --- a/test/golden/T159/T159.ghc-914.hdb-stdout +++ b/test/golden/T159/T159.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /T159.hs, interpreted )[main] +[1 of 2] Compiling Main ( /T159.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 16], sourceSpan = SourceSpan {file = "/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}} (hdb) Stopped at breakpoint (hdb) [DbgStackFrame {name = "Main.foo", sourceSpan = SourceSpan {file = "/T159.hs", startLine = 12, endLine = 12, startCol = 3, endCol = 47}, breakId = Just InternalBreakpointId Main 16},DbgStackFrame {name = "Lovely annotation", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "[1,2,3,4]", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing},DbgStackFrame {name = "annotateCallStackIO, called at /T159.hs:5:3 in main:Main", sourceSpan = SourceSpan {file = "", startLine = 0, endLine = 0, startCol = 0, endCol = 0}, breakId = Nothing}] diff --git a/test/golden/T164/T164.ghc-914.hdb-stdout b/test/golden/T164/T164.ghc-914.hdb-stdout index 3489bc96..c0eff36c 100644 --- a/test/golden/T164/T164.ghc-914.hdb-stdout +++ b/test/golden/T164/T164.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 5], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 42, endLine = 42, startCol = 3, endCol = 70}} (hdb) Stopped at breakpoint (hdb) _result : IO () = :: IO () diff --git a/test/golden/T166/T166.ghc-914.hdb-stdout b/test/golden/T166/T166.ghc-914.hdb-stdout index cb8e5c8d..29337741 100644 --- a/test/golden/T166/T166.ghc-914.hdb-stdout +++ b/test/golden/T166/T166.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) 1 (hdb) 1 (hdb) Prelude.undefined diff --git a/test/golden/T169/T169.ghc-914.hdb-stdout b/test/golden/T169/T169.ghc-914.hdb-stdout index c852858d..2b552170 100644 --- a/test/golden/T169/T169.ghc-914.hdb-stdout +++ b/test/golden/T169/T169.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) hello () (hdb) Exiting... diff --git a/test/golden/T169/T169b.ghc-914.hdb-stdout b/test/golden/T169/T169b.ghc-914.hdb-stdout index 94a3ddfb..b57e5696 100644 --- a/test/golden/T169/T169b.ghc-914.hdb-stdout +++ b/test/golden/T169/T169b.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /T169b.hs, interpreted )[main] +[1 of 2] Compiling Main ( /T169b.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 6, endLine = 8, startCol = 8, endCol = 58}} (hdb) Stopped at breakpoint (hdb) [ScopeInfo {kind = LocalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Nothing, expensive = False},ScopeInfo {kind = ModuleVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 2, expensive = True},ScopeInfo {kind = GlobalVariablesScope, sourceSpan = SourceSpan {file = "/T169b.hs", startLine = 7, endLine = 7, startCol = 3, endCol = 58}, numVars = Just 353, expensive = True}] diff --git a/test/golden/T169/T169c.external.ghc-914.hdb-stdout b/test/golden/T169/T169c.external.ghc-914.hdb-stdout index 9c317dd5..8d1a65b4 100644 --- a/test/golden/T169/T169c.external.ghc-914.hdb-stdout +++ b/test/golden/T169/T169c.external.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /T169c.hs, interpreted )[main] +[1 of 2] Compiling Main ( /T169c.hs, interpreted )[main] (hdb) "hello there" () (hdb) Exiting... diff --git a/test/golden/T169/T169c.internal.ghc-914.hdb-stdout b/test/golden/T169/T169c.internal.ghc-914.hdb-stdout index 6fb733fa..df8beb14 100644 --- a/test/golden/T169/T169c.internal.ghc-914.hdb-stdout +++ b/test/golden/T169/T169c.internal.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /T169c.hs, interpreted )[main] +[1 of 2] Compiling Main ( /T169c.hs, interpreted )[main] (hdb) "hello world" () (hdb) Exiting... diff --git a/test/golden/T217/T217.ghc-914.hdb-stdout b/test/golden/T217/T217.ghc-914.hdb-stdout index 9d556a59..c362dc54 100644 --- a/test/golden/T217/T217.ghc-914.hdb-stdout +++ b/test/golden/T217/T217.ghc-914.hdb-stdout @@ -1,12 +1,11 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 13], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 17, endLine = 17, startCol = 3, endCol = 10}} (hdb) helio Stopped at breakpoint (hdb) _result : IO () = :: IO () -x : forall a. (a ~ IO ()) => a = :: forall a. (a ~ IO ()) => a -y : D Char -> Char = :: D Char -> Char doit : forall {b}. b -> IO () = :: forall {b}. b -> IO () +y : D Char -> Char = :: D Char -> Char +x : forall a. (a ~ IO ()) => a = :: forall a. (a ~ IO ()) => a ix : B = _ ix : B = B (Left _) (hdb) Exiting... diff --git a/test/golden/T218/T218.ghc-914.hdb-stdout b/test/golden/T218/T218.ghc-914.hdb-stdout index b7bc3ada..b59afbd3 100644 --- a/test/golden/T218/T218.ghc-914.hdb-stdout +++ b/test/golden/T218/T218.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) Aborted: :1:1: error: [GHC-88464] Variable not in scope: isLetter (hdb) diff --git a/test/golden/T225/T225.ghc-914.hdb-stdout b/test/golden/T225/T225.ghc-914.hdb-stdout index 89c9a5de..332f6e6c 100644 --- a/test/golden/T225/T225.ghc-914.hdb-stdout +++ b/test/golden/T225/T225.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 1], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 12}} (hdb) Stopped at breakpoint (hdb) "List [1]" diff --git a/test/golden/T225b/T225b.ghc-914.hdb-stdout b/test/golden/T225b/T225b.ghc-914.hdb-stdout index 6deb2d59..009c3d1b 100644 --- a/test/golden/T225b/T225b.ghc-914.hdb-stdout +++ b/test/golden/T225b/T225b.ghc-914.hdb-stdout @@ -1,7 +1,5 @@ -[1 of 4] Compiling B ( /B.hs, interpreted )[main] -[2 of 4] Compiling A ( /Main.hs, interpreted )[main] -[3 of 4] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[4 of 4] Compiling GHC.Debugger.View.Containers ( in-memory:GHC.Debugger.View.Containers, interpreted )[haskell-debugger-view-in-memory] +[1 of 2] Compiling B ( /B.hs, interpreted )[main] +[2 of 2] Compiling A ( /Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId B 3], sourceSpan = SourceSpan {file = "/./B.hs", startLine = 11, endLine = 11, startCol = 3, endCol = 19}} (hdb) 1 Stopped at breakpoint diff --git a/test/golden/T242/T242.ghc-914.hdb-stdout b/test/golden/T242/T242.ghc-914.hdb-stdout index fefca24e..6937d640 100644 --- a/test/golden/T242/T242.ghc-914.hdb-stdout +++ b/test/golden/T242/T242.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 4], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 9, endLine = 9, startCol = 3, endCol = 10}} (hdb) BreakFound {changed = True, breakId = [InternalBreakpointId Main 11], sourceSpan = SourceSpan {file = "/Main.hs", startLine = 3, endLine = 3, startCol = 3, endCol = 10}} (hdb) Stopped at breakpoint diff --git a/test/golden/T283/T283.ghc-914.hdb-stdout b/test/golden/T283/T283.ghc-914.hdb-stdout index fcb7eacd..334ad4ca 100644 --- a/test/golden/T283/T283.ghc-914.hdb-stdout +++ b/test/golden/T283/T283.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /app/Main.hs, interpreted )[T283-0.1.0.0-inplace-T283] +[1 of 2] Compiling Main ( /app/Main.hs, interpreted )[T283-0.1.0.0-inplace-T283] (hdb) (hdb) THIS IS A PACKAGE () diff --git a/test/golden/T61/T61.ghc-914.hdb-stdout b/test/golden/T61/T61.ghc-914.hdb-stdout index 182d6374..9ac75dd3 100644 --- a/test/golden/T61/T61.ghc-914.hdb-stdout +++ b/test/golden/T61/T61.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /x/Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /x/Main.hs, interpreted )[main] (hdb) wrks () (hdb) Exiting... diff --git a/test/golden/T79/T79.ghc-914.hdb-stdout b/test/golden/T79/T79.ghc-914.hdb-stdout index f15672b7..4dc779ba 100644 --- a/test/golden/T79/T79.ghc-914.hdb-stdout +++ b/test/golden/T79/T79.ghc-914.hdb-stdout @@ -7,8 +7,7 @@ [Warn] No synopsis given. You should edit the .cabal file and add one. [Info] You may want to edit the .cabal file and add a Description field. -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /app/Main.hs, interpreted )[T79-tmp-0.1.0.0-inplace-T79-tmp] +[1 of 2] Compiling Main ( /app/Main.hs, interpreted )[T79-tmp-0.1.0.0-inplace-T79-tmp] (hdb) Hello, Haskell! () (hdb) Exiting... diff --git a/test/golden/T83/T83.ghc-914.hdb-stdout b/test/golden/T83/T83.ghc-914.hdb-stdout index ca2bbda5..719b1eba 100644 --- a/test/golden/T83/T83.ghc-914.hdb-stdout +++ b/test/golden/T83/T83.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /Main.hs, interpreted )[main] (hdb) Heli () (hdb) Exiting... diff --git a/test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout b/test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout index 40ac9569..4784a5db 100644 --- a/test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout +++ b/test/golden/exceptions-multiple/exceptions-multiple.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /prog/Main.hs, interpreted )[main] (hdb) BreakFoundNoLoc {changed = True} (hdb) About to throw first Stopped at breakpoint diff --git a/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout b/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout index b7047476..fac591cc 100644 --- a/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout +++ b/test/golden/exceptions-uncaught/exceptions-uncaught.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /prog/Main.hs, interpreted )[main] (hdb) BreakFoundNoLoc {changed = True} (hdb) About to throw Handling exception: boom outer diff --git a/test/golden/exceptions/exceptions.ghc-914.hdb-stdout b/test/golden/exceptions/exceptions.ghc-914.hdb-stdout index 6d2512c1..fcd25706 100644 --- a/test/golden/exceptions/exceptions.ghc-914.hdb-stdout +++ b/test/golden/exceptions/exceptions.ghc-914.hdb-stdout @@ -1,5 +1,4 @@ -[1 of 3] Compiling GHC.Debugger.View.Class ( in-memory:GHC.Debugger.View.Class, interpreted )[haskell-debugger-view-in-memory] -[2 of 3] Compiling Main ( /prog/Main.hs, interpreted )[main] +[1 of 2] Compiling Main ( /prog/Main.hs, interpreted )[main] (hdb) BreakFoundNoLoc {changed = True} (hdb) About to throw Stopped at breakpoint From 5dbb430cf25b3ced1e858204a1e900c2f75aefc0 Mon Sep 17 00:00:00 2001 From: Andrea Date: Mon, 27 Apr 2026 20:47:48 +0200 Subject: [PATCH 04/11] WIP: refactor debugThread --- haskell-debugger/GHC/Debugger/Monad.hs | 39 ++++++++++++------------ haskell-debugger/GHC/Debugger/Session.hs | 2 +- hdb/Development/Debug/Adapter/Init.hs | 24 ++++++--------- hdb/Development/Debug/Interactive.hs | 12 ++------ hdb/Development/Debug/Session/Setup.hs | 16 ++++++++++ 5 files changed, 50 insertions(+), 43 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index 164ba6d6..0daacb8e 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -206,25 +206,26 @@ data RunDebuggerSettings = RunDebuggerSettings , externalInterpreterProg :: FilePath } --- | Run a 'Debugger' action on a session constructed from a given GHC invocation. -runDebugger :: forall a - . LogAction IO DebuggerLog - -> FilePath -- ^ Cradle root directory - -> FilePath -- ^ Component root directory - -> FilePath -- ^ The libdir (given with -B as an arg) - -> [String] -- ^ The list of units included in the invocation - -> [String] -- ^ The full ghc invocation (as constructed by hie-bios flags) - -> [String] -- ^ The extra GHC arguments (as given by the user in @extraGhcArgs@) - -> FilePath -- ^ Path to the main function - -> RunDebuggerSettings -- ^ Other debugger run settings - -> Debugger a -- ^ 'Debugger' action to run on the session constructed from this invocation - -> IO a -runDebugger l rootDir0 compDir libdir units ghcInvocation' extraGhcArgs0 mainFp conf (Debugger action) = annotateCallStackIO $ do - withHieGhcDebugSession rootDir0 compDir libdir units ghcInvocation' extraGhcArgs0 mainFp $ \ rootDir extraGhcArgs loadHomeUnit -> runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit action - --- FIXME: organize arguments somehow. -withHieGhcDebugSession :: GhcMonad m => FilePath -> FilePath -> FilePath -> [String] -> [[Char]] -> p -> FilePath -> (FilePath -> p -> m () -> Ghc a) -> IO a -withHieGhcDebugSession rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp k = do +-- | Run a 'Debugger' action on a session constructed by a 'SessionProvider' +runDebugger :: LogAction IO DebuggerLog -> SessionProvider a -> RunDebuggerSettings -> Debugger a -> IO a +runDebugger l sessionProvider conf (Debugger action) = annotateCallStackIO $ do + sessionProvider $ \ rootDir extraGhcArgs loadHomeUnit -> runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit action + +type SessionProvider a = (FilePath -> [String] -> Ghc () -> Ghc a) -> IO a + +-- | Construct a session from paths and flags inferred from the debugee's project. +withProjectDebugSession + :: GhcMonad m + => FilePath -- ^ Project root directory + -> FilePath -- ^ Component root directory + -> FilePath -- ^ The libdir (given with -B as an arg) + -> [String] -- ^ The list of units included in the invocation + -> [String] -- ^ The full ghc invocation (as constructed by hie-bios flags) + -> [String] -- ^ The extra GHC arguments (as given by the user in @extraGhcArgs@) + -> FilePath -- ^ Path to the main function + -> (FilePath -> [String] -> m () -> Ghc a) + -> IO a +withProjectDebugSession rootDir compDir libdir units ghcInvocation' extraGhcArgs mainFp k = do let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcInvocation' GHC.runGhc (Just libdir) $ k rootDir extraGhcArgs $ do dflags2 <- getSessionDynFlags diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index 647dcced..57ab6f45 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -75,7 +75,7 @@ import qualified GHC.Unit.Home.Graph as HUG import qualified Data.Set as Set import Data.Maybe import GHC.Types.Target (InputFileBuffer) -import GHC (SingleStep, ExecResult, SuccessFlag (..), ModSummary (ms_hspp_opts)) +import GHC (SingleStep, ExecResult, ModSummary (ms_hspp_opts)) import Data.Set (Set) import qualified GHC.Unit as GHC import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), mnKey) diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index ee8bc6a5..678ed226 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -58,7 +58,7 @@ import Development.Debug.Adapter.Proxy import System.Environment import Network.Socket (socketPort) import qualified Network.Socket as Socket -import GHC.Debugger.Monad (RunDebuggerSettings(externalInterpreterCustomProc)) +import GHC.Debugger.Monad (RunDebuggerSettings(externalInterpreterCustomProc), SessionProvider) -------------------------------------------------------------------------------- -- * Client @@ -138,10 +138,9 @@ initDebugger l supportsRunInTerminal preferInternalInterpreter | sev >= Info -> dapLogger <& renderSessionSetupLog msg | otherwise -> mempty - liftIO (runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile)) >>= \case + liftIO (getSessionProvider hieBiosLogger projectRoot entryFile extraGhcArgs) >>= \case Left e -> throwError (ErrorMessage (T.pack e), Nothing) - Right (Left e) -> throwError (ErrorMessage (T.pack e), Nothing) - Right (Right flags) -> do + Right sessionProvider -> do let nextFreshId = 0 @@ -194,7 +193,7 @@ initDebugger l supportsRunInTerminal preferInternalInterpreter sessionId <- liftIO $ maybe (("debug-session:" <>) . T.show <$> UUID.nextRandom) (pure . T.pack) __sessionId registerNewDebugSession sessionId daState $ - [ debuggerThread dbgLog flags extraGhcArgs absEntryFile defaultRunConf syncRequests syncResponses + [ \_withAdaptor -> debuggerThread dbgLog sessionProvider defaultRunConf syncRequests syncResponses , \withAdaptor -> forwardHandleToLogger readDAPOutput $ LogAction (\msg -> withAdaptor (Output.neutral msg)) ] @@ -272,25 +271,22 @@ mkRunInTerminalThreads l RunProxyInTerminal{..} _ -- Concurrently, it reads from the process's stderr forever and outputs it through OutputEvents. -- debuggerThread :: LogAction IO Debugger.DebuggerLog - -> HieBiosFlags -- ^ GHC Invocation flags - -> [String] -- ^ Extra ghc args - -> FilePath + -> SessionProvider () -- ^ GHC Invocation flags -> Debugger.RunDebuggerSettings -- ^ Settings for running the debugger -> MVar D.Command -- ^ Read commands -> MVar D.Response -- ^ Write reponses - -> (DebugAdaptorCont () -> IO ()) - -- ^ Allows unlifting DebugAdaptor actions to IO. See 'registerNewDebugSession'. -> IO () -debuggerThread l HieBiosFlags{..} extraGhcArgs mainFp runConf requests replies withAdaptor = do - +debuggerThread l sessionProvider runConf requests replies = do +{- +-- FIXME -- Log haskell-debugger invocation withAdaptor $ Output.console $ T.pack $ "libdir: " <> libdir <> "\n" <> "units: " <> unwords units <> "\n" <> "args: " <> unwords (ghcInvocation ++ extraGhcArgs) - - Debugger.runDebugger l rootDir componentDir libdir units ghcInvocation extraGhcArgs mainFp runConf $ do +-} + Debugger.runDebugger l sessionProvider runConf $ do liftIO $ do tid <- myThreadId labelThread tid "Main Debugger Thread" diff --git a/hdb/Development/Debug/Interactive.hs b/hdb/Development/Debug/Interactive.hs index f9df8d2d..3994e8af 100644 --- a/hdb/Development/Debug/Interactive.hs +++ b/hdb/Development/Debug/Interactive.hs @@ -7,8 +7,6 @@ import System.Exit import System.Directory import System.Console.Haskeline -- import System.Console.Haskeline.Completion -import System.FilePath -import Control.Monad.Except import Control.Monad.State import Control.Monad.Reader import Control.Monad.RWS @@ -56,17 +54,13 @@ runIDM logger entryPoint entryFile entryArgs extraGhcArgs runConf act = do projectRoot <- getCurrentDirectory let hieBiosLogger = contramap ISessionSetupLog logger - runExceptT (hieBiosSetup hieBiosLogger projectRoot entryFile) >>= \case + getSessionProvider hieBiosLogger projectRoot entryFile extraGhcArgs >>= \case Left e -> exitWithMsg e - Right (Left e) -> exitWithMsg e - Right (Right flags) - | HieBiosFlags{..} <- flags + Right sessionProvider -> do - - let absEntryFile = normalise $ projectRoot entryFile let debugRec = contramap IDebuggerLog logger - runDebugger debugRec rootDir componentDir libdir units ghcInvocation extraGhcArgs absEntryFile runConf $ + runDebugger debugRec sessionProvider runConf $ fmap fst $ evalRWST (runInputT (setComplete noCompletion defaultSettings) act) (RunOptions { runEntryFile = entryFile, runEntryPoint = entryPoint, runEntryArgs = entryArgs }) diff --git a/hdb/Development/Debug/Session/Setup.hs b/hdb/Development/Debug/Session/Setup.hs index 740c088c..cc8d1e06 100644 --- a/hdb/Development/Debug/Session/Setup.hs +++ b/hdb/Development/Debug/Session/Setup.hs @@ -12,6 +12,7 @@ module Development.Debug.Session.Setup -- * Logging , SessionSetupLog(..) , renderSessionSetupLog + , getSessionProvider ) where import Control.Applicative ((<|>)) @@ -50,6 +51,8 @@ import Colog.Core import Prettyprinter import Prettyprinter.Render.Text +import qualified GHC.Debugger.Monad as Debugger + data SessionSetupLog = HieBiosLog HIE.Log | LogCradle (HIE.Cradle Void) @@ -188,6 +191,19 @@ ghcDebuggerFlags = [ "-fno-it" -- don't introduce @it@ after evaluating something at the prompt ] +getSessionProvider + :: LogAction IO (WithSeverity SessionSetupLog) + -> FilePath + -> FilePath + -> [String] + -> IO (Either String (Debugger.SessionProvider a)) +getSessionProvider l projectRoot entryFile extraGhcArgs = runExceptT $ do + r <- hieBiosSetup l projectRoot entryFile + HieBiosFlags{..} <- case r of + Left e -> throwError e + Right f -> return f + let absEntryFile = normalise $ projectRoot entryFile + pure $ Debugger.withProjectDebugSession rootDir componentDir libdir units ghcInvocation extraGhcArgs absEntryFile -- ---------------------------------------------------------------------------- -- Utilities From e9d3cb585a0ff09cd8a7fc1eb6dfc8831eacc55e Mon Sep 17 00:00:00 2001 From: Andrea Date: Mon, 27 Apr 2026 21:04:24 +0200 Subject: [PATCH 05/11] WIP: refactor initDebugger/talk --- hdb/Development/Debug/Adapter/Init.hs | 7 ++++--- hdb/Main.hs | 8 +++++--- 2 files changed, 9 insertions(+), 6 deletions(-) diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index 678ed226..6b14cb68 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -95,13 +95,14 @@ data DAPLog -------------------------------------------------------------------------------- -- * Launch Debugger -------------------------------------------------------------------------------- +type SessionProviderProvider a = LogAction IO (WithSeverity SessionSetupLog) -> FilePath -> FilePath -> [String] -> IO (Either String (SessionProvider a)) -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise -initDebugger :: LogAction IO DAPLog -> Bool -> Bool +initDebugger :: LogAction IO DAPLog -> SessionProviderProvider () -> Bool -> Bool -> LaunchArgs -> DebugAdaptor () -initDebugger l supportsRunInTerminal preferInternalInterpreter +initDebugger l getSP supportsRunInTerminal preferInternalInterpreter LaunchArgs{ __sessionId , projectRoot = givenRoot , entryFile = entryFileMaybe @@ -138,7 +139,7 @@ initDebugger l supportsRunInTerminal preferInternalInterpreter | sev >= Info -> dapLogger <& renderSessionSetupLog msg | otherwise -> mempty - liftIO (getSessionProvider hieBiosLogger projectRoot entryFile extraGhcArgs) >>= \case + liftIO (getSP hieBiosLogger projectRoot entryFile extraGhcArgs) >>= \case Left e -> throwError (ErrorMessage (T.pack e), Nothing) Right sessionProvider -> do diff --git a/hdb/Main.hs b/hdb/Main.hs index 5d22dbd3..8027c86c 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -59,6 +59,7 @@ import Development.Debug.Adapter import Development.Debug.Adapter.Proxy import Development.Debug.Interactive import GHC.Stack.Annotation (annotateCallStackIO) +import Development.Debug.Session.Setup (getSessionProvider) #if MIN_VERSION_ghc(9,15,0) import GHC.Debugger.Runtime.Interpreter.Custom (dbgInterpCmdHandler) @@ -88,7 +89,7 @@ main = do l <- mainLogger hdbOpts.verbosity realStdout init_var <- liftIO (newIORef False{-not supported by default-}) runDAPServerWithLogger (contramap DAPLibraryLog l) config - (talk l init_var internalInterpreter) + (talk l getSessionProvider init_var internalInterpreter) (ack l ) HdbCLI{..} -> do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) @@ -251,13 +252,14 @@ getConfig port = do -- The core logic of communicating between the client <-> adaptor <-> debugger -- is implemented in this function. talk :: LogAction IO MainLog + -> SessionProviderProvider () -> IORef Bool -- ^ Whether the client supports runInTerminal -> Bool -- ^ Prefer internal interpreter -> Command -> DebugAdaptor () -------------------------------------------------------------------------------- -talk l support_rit_var prefer_internal_interpreter = \ case +talk l getSP support_rit_var prefer_internal_interpreter = \ case CommandInitialize -> do InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments #ifdef mingw32_HOST_OS @@ -284,7 +286,7 @@ talk l support_rit_var prefer_internal_interpreter = \ case -- Wrong-ish. See above where this variable is written supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var - initDebugger (contramap DAPLog l) + initDebugger (contramap DAPLog l) getSP supportsRunInTerminalRequest prefer_internal_interpreter launch_args From 422b48f47a5e71c70e9c875258e15a2ff2acf03c Mon Sep 17 00:00:00 2001 From: Andrea Date: Tue, 28 Apr 2026 09:44:38 +0200 Subject: [PATCH 06/11] DAPServerConf --- hdb/Development/Debug/Adapter/Init.hs | 30 +++++++++++++++----------- hdb/Development/Debug/Adapter/Proxy.hs | 7 +++--- hdb/Main.hs | 11 ++++++---- 3 files changed, 27 insertions(+), 21 deletions(-) diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb/Development/Debug/Adapter/Init.hs index 6b14cb68..a85fd3c3 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb/Development/Debug/Adapter/Init.hs @@ -55,7 +55,6 @@ import DAP import Development.Debug.Adapter.Handles import Development.Debug.Session.Setup import Development.Debug.Adapter.Proxy -import System.Environment import Network.Socket (socketPort) import qualified Network.Socket as Socket import GHC.Debugger.Monad (RunDebuggerSettings(externalInterpreterCustomProc), SessionProvider) @@ -97,12 +96,17 @@ data DAPLog -------------------------------------------------------------------------------- type SessionProviderProvider a = LogAction IO (WithSeverity SessionSetupLog) -> FilePath -> FilePath -> [String] -> IO (Either String (SessionProvider a)) +data DAPServerConf = DAPServerConf + { hdbProgram :: FilePath + , sessionProviderProvider :: SessionProviderProvider () + } + -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise -initDebugger :: LogAction IO DAPLog -> SessionProviderProvider () -> Bool -> Bool +initDebugger :: LogAction IO DAPLog -> DAPServerConf -> Bool -> Bool -> LaunchArgs -> DebugAdaptor () -initDebugger l getSP supportsRunInTerminal preferInternalInterpreter +initDebugger l servConf supportsRunInTerminal preferInternalInterpreter LaunchArgs{ __sessionId , projectRoot = givenRoot , entryFile = entryFileMaybe @@ -139,7 +143,7 @@ initDebugger l getSP supportsRunInTerminal preferInternalInterpreter | sev >= Info -> dapLogger <& renderSessionSetupLog msg | otherwise -> mempty - liftIO (getSP hieBiosLogger projectRoot entryFile extraGhcArgs) >>= \case + liftIO (sessionProviderProvider servConf hieBiosLogger projectRoot entryFile extraGhcArgs) >>= \case Left e -> throwError (ErrorMessage (T.pack e), Nothing) Right sessionProvider -> do @@ -173,11 +177,11 @@ initDebugger l getSP supportsRunInTerminal preferInternalInterpreter dbgLog <- liftIO $ createDebuggerLogger l dapLogger writeDAPOutput runInTerminalProc + let hdbProg = hdbProgram servConf (runInTerminalThreads, afterRegisterActions) <- - mkRunInTerminalThreads l runInTerminalProc preferInternalInterpreter + mkRunInTerminalThreads l hdbProg runInTerminalProc preferInternalInterpreter - thisProg <- liftIO getExecutablePath let defaultRunConf = Debugger.RunDebuggerSettings { supportsANSIStyling = True -- TODO: Initialize Request sends supportsANSIStyling; this is False for nvim-dap @@ -187,7 +191,7 @@ initDebugger l getSP supportsRunInTerminal preferInternalInterpreter RunExternalInterpreterInTerminal{extInterpPort} -> Right extInterpPort _ -> Left CreatePipe -- if not runInTerminal, just create a new pipe for stdin - , externalInterpreterProg = thisProg + , externalInterpreterProg = hdbProgram servConf } absEntryFile = normalise $ projectRoot entryFile daState = DAS{entryFile=absEntryFile,..} @@ -207,13 +211,14 @@ initDebugger l getSP supportsRunInTerminal preferInternalInterpreter -- we're running through `runInTerminal` (see 'RunInTerminalProc'). mkRunInTerminalThreads :: LogAction IO DAPLog + -> 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 +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 @@ -222,11 +227,10 @@ mkRunInTerminalThreads _ NoRunInTerminal useInternalInterp | otherwise = pure ([], pure ()) -mkRunInTerminalThreads _ RunExternalInterpreterInTerminal{..} _ +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 - thisProg <- liftIO getExecutablePath -- run the same `hdb` executable in `proxy` mode pure ([], sendRunInTerminalReverseRequest RunInTerminalRequestArguments @@ -234,12 +238,12 @@ mkRunInTerminalThreads _ RunExternalInterpreterInTerminal{..} _ , runInTerminalRequestArgumentsTitle = Nothing , runInTerminalRequestArgumentsCwd = "" , runInTerminalRequestArgumentsArgs = - [T.pack thisProg, "external-interpreter", "--port", T.pack (show extInterpPort)] + [T.pack hdbProg, "external-interpreter", "--port", T.pack (show extInterpPort)] , runInTerminalRequestArgumentsEnv = Nothing , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False }) -mkRunInTerminalThreads l RunProxyInTerminal{..} _ +mkRunInTerminalThreads l hdbProg RunProxyInTerminal{..} _ = do (serverPort, serverProxyThread) <- mkServerSideHdbProxy (contramap RunProxyServerLog l) @@ -259,7 +263,7 @@ mkRunInTerminalThreads l RunProxyInTerminal{..} _ -- (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 serverPort + sendRunProxyInTerminal hdbProg serverPort ) -- | The main debugger thread launches a GHC.Debugger session. diff --git a/hdb/Development/Debug/Adapter/Proxy.hs b/hdb/Development/Debug/Adapter/Proxy.hs index ad2de945..4304a84b 100644 --- a/hdb/Development/Debug/Adapter/Proxy.hs +++ b/hdb/Development/Debug/Adapter/Proxy.hs @@ -181,21 +181,20 @@ runInTerminalHdbProxy l port = do -- | Send a 'runInTerminal' reverse request to the DAP client -- with the @hdb proxy@ invocation -sendRunProxyInTerminal :: PortNumber -> DebugAdaptor () -sendRunProxyInTerminal port = do +sendRunProxyInTerminal :: FilePath -> PortNumber -> DebugAdaptor () +sendRunProxyInTerminal hdbProg port = do DAS { entryFile , entryPoint , entryArgs , projectRoot } <- getDebugSession let debuggee_inv = T.pack $ makeRelative projectRoot entryFile ++ ":" ++ entryPoint ++ (if null entryArgs then "" else " ") ++ unwords entryArgs - thisProg <- liftIO getExecutablePath -- run the same `hdb` executable in `proxy` mode sendRunInTerminalReverseRequest RunInTerminalRequestArguments { runInTerminalRequestArgumentsKind = Just RunInTerminalRequestArgumentsKindIntegrated , runInTerminalRequestArgumentsTitle = Just debuggee_inv , runInTerminalRequestArgumentsCwd = "" - , runInTerminalRequestArgumentsArgs = [T.pack thisProg, "proxy", "--port", T.pack (show port)] + , runInTerminalRequestArgumentsArgs = [T.pack hdbProg, "proxy", "--port", T.pack (show port)] , runInTerminalRequestArgumentsEnv = Just (H.singleton "DEBUGGEE_INVOCATION" debuggee_inv) , runInTerminalRequestArgumentsArgsCanBeInterpretedByShell = False } diff --git a/hdb/Main.hs b/hdb/Main.hs index 8027c86c..c32fc619 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -84,12 +84,15 @@ main = do HdbDAPServer{port, internalInterpreter, disableIpeBacktraces} -> do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) config <- getConfig port + hdbProgram <- getExecutablePath + let servConf = DAPServerConf { sessionProviderProvider = getSessionProvider + , hdbProgram} redirectRealStdout internalInterpreter $ \realStdout -> do hSetBuffering realStdout LineBuffering l <- mainLogger hdbOpts.verbosity realStdout init_var <- liftIO (newIORef False{-not supported by default-}) runDAPServerWithLogger (contramap DAPLibraryLog l) config - (talk l getSessionProvider init_var internalInterpreter) + (talk l servConf init_var internalInterpreter) (ack l ) HdbCLI{..} -> do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) @@ -252,14 +255,14 @@ getConfig port = do -- The core logic of communicating between the client <-> adaptor <-> debugger -- is implemented in this function. talk :: LogAction IO MainLog - -> SessionProviderProvider () + -> DAPServerConf -> IORef Bool -- ^ Whether the client supports runInTerminal -> Bool -- ^ Prefer internal interpreter -> Command -> DebugAdaptor () -------------------------------------------------------------------------------- -talk l getSP support_rit_var prefer_internal_interpreter = \ case +talk l servConf support_rit_var prefer_internal_interpreter = \ case CommandInitialize -> do InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments #ifdef mingw32_HOST_OS @@ -286,7 +289,7 @@ talk l getSP support_rit_var prefer_internal_interpreter = \ case -- Wrong-ish. See above where this variable is written supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var - initDebugger (contramap DAPLog l) getSP + initDebugger (contramap DAPLog l) servConf supportsRunInTerminalRequest prefer_internal_interpreter launch_args From 6496ee041db06ec678080576b8bc710b2a970c79 Mon Sep 17 00:00:00 2001 From: Andrea Date: Tue, 28 Apr 2026 11:28:08 +0200 Subject: [PATCH 07/11] dap sublibrary --- haskell-debugger.cabal | 43 ++- {hdb => hdb-dap}/Development/Debug/Adapter.hs | 1 + .../Development/Debug/Adapter/Breakpoints.hs | 0 .../Development/Debug/Adapter/Evaluation.hs | 0 .../Debug/Adapter/ExceptionInfo.hs | 0 .../Development/Debug/Adapter/Exit.hs | 0 .../Development/Debug/Adapter/Exit/Helpers.hs | 0 .../Development/Debug/Adapter/Handles.hs | 0 .../Development/Debug/Adapter/Init.hs | 8 +- .../Development/Debug/Adapter/Interface.hs | 0 .../Development/Debug/Adapter/Output.hs | 0 .../Development/Debug/Adapter/Proxy.hs | 0 hdb-dap/Development/Debug/Adapter/Server.hs | 302 ++++++++++++++++++ .../Development/Debug/Adapter/Stepping.hs | 0 .../Development/Debug/Adapter/Stopped.hs | 0 .../Development/Debug/Session/Setup.hs | 0 hdb/Main.hs | 276 +--------------- 17 files changed, 354 insertions(+), 276 deletions(-) rename {hdb => hdb-dap}/Development/Debug/Adapter.hs (99%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Breakpoints.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Evaluation.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Adapter/ExceptionInfo.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Exit.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Exit/Helpers.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Handles.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Init.hs (99%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Interface.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Output.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Proxy.hs (100%) create mode 100644 hdb-dap/Development/Debug/Adapter/Server.hs rename {hdb => hdb-dap}/Development/Debug/Adapter/Stepping.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Adapter/Stopped.hs (100%) rename {hdb => hdb-dap}/Development/Debug/Session/Setup.hs (100%) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index bbfad01b..428c8c1c 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -155,10 +155,9 @@ library hs-source-dirs: haskell-debugger default-language: GHC2021 -executable hdb +library dap import: warnings - main-is: Main.hs - other-modules: Development.Debug.Adapter.Breakpoints, + exposed-modules: Development.Debug.Adapter.Breakpoints, Development.Debug.Adapter.Stepping, Development.Debug.Adapter.Stopped, Development.Debug.Adapter.Evaluation, @@ -169,13 +168,46 @@ executable hdb Development.Debug.Adapter.Exit, Development.Debug.Adapter.Exit.Helpers, Development.Debug.Adapter.Handles, + Development.Debug.Adapter.Server, Development.Debug.Adapter, Development.Debug.Adapter.Proxy, - Development.Debug.Interactive, - Development.Debug.Session.Setup, + hs-source-dirs: hdb-dap + default-language: GHC2021 + default-extensions: CPP + build-depends: + base, ghc, ghci, + exceptions, aeson, bytestring, + containers, filepath, + process, mtl, + unordered-containers >= 0.2.19 && < 0.3, + + haskell-debugger, + hie-bios, + prettyprinter ^>= 1.7.0, + co-log-core >= 0.3.2.5 && < 0.4, + implicit-hie ^>=0.1.4.0, + transformers >= 0.6 && < 0.7, + 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.5 && < 0.6, + + haskeline >= 0.8 && < 1, + optparse-applicative >= 0.18 && < 0.20, + uuid >= 1.3 && < 1.4, + ghc-stack-annotations >=0.1 && <0.2, + +executable hdb + import: warnings + main-is: Main.hs + other-modules: Development.Debug.Interactive, Development.Debug.Options, Development.Debug.Options.Parser, @@ -190,6 +222,7 @@ executable hdb unordered-containers >= 0.2.19 && < 0.3, haskell-debugger, + haskell-debugger:dap, hie-bios, prettyprinter ^>= 1.7.0, co-log-core >= 0.3.2.5 && < 0.4, diff --git a/hdb/Development/Debug/Adapter.hs b/hdb-dap/Development/Debug/Adapter.hs similarity index 99% rename from hdb/Development/Debug/Adapter.hs rename to hdb-dap/Development/Debug/Adapter.hs index 5c8e5e03..d78615de 100644 --- a/hdb/Development/Debug/Adapter.hs +++ b/hdb-dap/Development/Debug/Adapter.hs @@ -1,4 +1,5 @@ {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} module Development.Debug.Adapter where import Control.Concurrent.MVar diff --git a/hdb/Development/Debug/Adapter/Breakpoints.hs b/hdb-dap/Development/Debug/Adapter/Breakpoints.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Breakpoints.hs rename to hdb-dap/Development/Debug/Adapter/Breakpoints.hs diff --git a/hdb/Development/Debug/Adapter/Evaluation.hs b/hdb-dap/Development/Debug/Adapter/Evaluation.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Evaluation.hs rename to hdb-dap/Development/Debug/Adapter/Evaluation.hs diff --git a/hdb/Development/Debug/Adapter/ExceptionInfo.hs b/hdb-dap/Development/Debug/Adapter/ExceptionInfo.hs similarity index 100% rename from hdb/Development/Debug/Adapter/ExceptionInfo.hs rename to hdb-dap/Development/Debug/Adapter/ExceptionInfo.hs diff --git a/hdb/Development/Debug/Adapter/Exit.hs b/hdb-dap/Development/Debug/Adapter/Exit.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Exit.hs rename to hdb-dap/Development/Debug/Adapter/Exit.hs diff --git a/hdb/Development/Debug/Adapter/Exit/Helpers.hs b/hdb-dap/Development/Debug/Adapter/Exit/Helpers.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Exit/Helpers.hs rename to hdb-dap/Development/Debug/Adapter/Exit/Helpers.hs diff --git a/hdb/Development/Debug/Adapter/Handles.hs b/hdb-dap/Development/Debug/Adapter/Handles.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Handles.hs rename to hdb-dap/Development/Debug/Adapter/Handles.hs diff --git a/hdb/Development/Debug/Adapter/Init.hs b/hdb-dap/Development/Debug/Adapter/Init.hs similarity index 99% rename from hdb/Development/Debug/Adapter/Init.hs rename to hdb-dap/Development/Debug/Adapter/Init.hs index a85fd3c3..9001b7a3 100644 --- a/hdb/Development/Debug/Adapter/Init.hs +++ b/hdb-dap/Development/Debug/Adapter/Init.hs @@ -86,7 +86,7 @@ data LaunchArgs -- * Logging -------------------------------------------------------------------------------- -data DAPLog +data DAPSessionLog = DAPSessionSetupLog (WithSeverity SessionSetupLog) | DAPDebuggerLog Debugger.DebuggerLog | RunProxyServerLog (WithSeverity T.Text) @@ -104,7 +104,7 @@ data DAPServerConf = DAPServerConf -- | Initialize debugger -- -- Returns @()@ if successful, throws @InitFailed@ otherwise -initDebugger :: LogAction IO DAPLog -> DAPServerConf -> Bool -> Bool +initDebugger :: LogAction IO DAPSessionLog -> DAPServerConf -> Bool -> Bool -> LaunchArgs -> DebugAdaptor () initDebugger l servConf supportsRunInTerminal preferInternalInterpreter LaunchArgs{ __sessionId @@ -210,7 +210,7 @@ initDebugger l servConf supportsRunInTerminal preferInternalInterpreter -- | Additional threads to register for this session depending on the process -- we're running through `runInTerminal` (see 'RunInTerminalProc'). mkRunInTerminalThreads - :: LogAction IO DAPLog + :: LogAction IO DAPSessionLog -> FilePath -> RunInTerminalProc -> Bool -- ^ Use internal interpreter @@ -329,7 +329,7 @@ Specification for the logger given to `Debugger`: -- See Note [Debugger, debuggee, and DAP logs] createDebuggerLogger - :: LogAction IO DAPLog + :: LogAction IO DAPSessionLog -> LogAction IO T.Text -- ^ Logger that writes to to DAP output -> Handle -- ^ Handle to DAP output -> RunInTerminalProc diff --git a/hdb/Development/Debug/Adapter/Interface.hs b/hdb-dap/Development/Debug/Adapter/Interface.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Interface.hs rename to hdb-dap/Development/Debug/Adapter/Interface.hs diff --git a/hdb/Development/Debug/Adapter/Output.hs b/hdb-dap/Development/Debug/Adapter/Output.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Output.hs rename to hdb-dap/Development/Debug/Adapter/Output.hs diff --git a/hdb/Development/Debug/Adapter/Proxy.hs b/hdb-dap/Development/Debug/Adapter/Proxy.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Proxy.hs rename to hdb-dap/Development/Debug/Adapter/Proxy.hs diff --git a/hdb-dap/Development/Debug/Adapter/Server.hs b/hdb-dap/Development/Debug/Adapter/Server.hs new file mode 100644 index 00000000..3581cd01 --- /dev/null +++ b/hdb-dap/Development/Debug/Adapter/Server.hs @@ -0,0 +1,302 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedRecordDot #-} +module Development.Debug.Adapter.Server where + + +import System.Environment +import Data.Maybe +import Data.IORef +import Text.Read +import Control.Concurrent +import Control.Monad +import Control.Monad.IO.Class + +import DAP + +import Development.Debug.Adapter.Init +import Development.Debug.Adapter.Breakpoints +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.Exit.Helpers +import Colog.Core + +import Data.Time +import qualified DAP.Log as DAP +import Data.Text (Text) +import qualified Data.Text as T +import Data.Functor.Contravariant + + +import GHC.Utils.Logger (defaultLogActionWithHandles) +import Development.Debug.Adapter + + +import GHC.Debugger.Monad +import System.IO + + +------------------------------------------------------------------------- +-- * DAP lib config +------------------------------------------------------------------------- + +-- | Fetch config from environment, fallback to sane defaults +getConfig :: Int -> IO ServerConfig +getConfig port = do + let + hostDefault = "0.0.0.0" + portDefault = port + capabilities = Capabilities + { supportsConfigurationDoneRequest = True + , supportsFunctionBreakpoints = True + , supportsConditionalBreakpoints = True + , supportsHitConditionalBreakpoints = True + , supportsEvaluateForHovers = False + -- Exception Breakpoints: + , exceptionBreakpointFilters = [ defaultExceptionBreakpointsFilter + { exceptionBreakpointsFilterLabel = "All exceptions" + , exceptionBreakpointsFilterFilter = BREAK_ON_EXCEPTION + } + , defaultExceptionBreakpointsFilter + { exceptionBreakpointsFilterLabel = "Uncaught exceptions" + , exceptionBreakpointsFilterFilter = BREAK_ON_ERROR + } + ] + , supportsStepBack = False + , supportsSetVariable = False + , supportsRestartFrame = False + , supportsGotoTargetsRequest = False + , supportsStepInTargetsRequest = False + , supportsCompletionsRequest = False + , completionTriggerCharacters = [] + , supportsModulesRequest = False + , additionalModuleColumns = [ defaultColumnDescriptor + { columnDescriptorAttributeName = "Extra" + , columnDescriptorLabel = "Label" + } + ] + , supportedChecksumAlgorithms = [] + , supportsRestartRequest = False + , supportsExceptionOptions = True + , supportsValueFormattingOptions = True + , supportsExceptionInfoRequest = True + , supportTerminateDebuggee = False -- for now, when debugger is disconnected, we always kill the debuggee + , supportSuspendDebuggee = False + , supportsDelayedStackTraceLoading = False + , supportsLoadedSourcesRequest = False + , supportsLogPoints = True + , supportsTerminateThreadsRequest = False + , supportsSetExpression = False + , supportsTerminateRequest = True + , supportsDataBreakpoints = False + , supportsReadMemoryRequest = False + , supportsWriteMemoryRequest = False + , supportsDisassembleRequest = False + , supportsCancelRequest = False + -- Display which breakpoints are valid when user intends to set + -- breakpoint on given line: + , supportsBreakpointLocationsRequest = True + , supportsClipboardContext = False + , supportsSteppingGranularity = False + , supportsInstructionBreakpoints = False + , supportsExceptionFilterOptions = False + , supportsSingleThreadExecutionRequests = False + } + ServerConfig + <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST" + <*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT" + <*> pure capabilities + <*> pure True + +-------------------------------------------------------------------------------- +-- * Talk +-------------------------------------------------------------------------------- + +-- | 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 :: LogAction IO DAPLog + -> DAPServerConf + -> IORef Bool + -- ^ Whether the client supports runInTerminal (FIXME: should be per-client) + -> Bool + -- ^ Prefer internal interpreter + -> Command -> DebugAdaptor () +-------------------------------------------------------------------------------- +talk l servConf support_rit_var prefer_internal_interpreter = \ case + CommandInitialize -> do + InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments +#ifdef mingw32_HOST_OS + -- On Windows, runInTerminal is currently unsupported + -- See #199 + let runInTerminal = False +#else + let runInTerminal = fromMaybe False supportsRunInTerminalRequest +#endif + -- This global variable is wrong. Even though we only register the session + -- and the per-session state on Launch (which gives us __sessionId), the + -- *initialize* command is run once per new session on a new connection and + -- two different clients which may differ in their support for + -- 'runInTerminal'. + -- + -- The `dap` library should likely keep track of the client capabilities + -- per connection. + liftIO $ writeIORef support_rit_var runInTerminal + sendInitializeResponse +-------------------------------------------------------------------------------- + CommandLaunch -> do + launch_args <- getArguments + + -- Wrong-ish. See above where this variable is written + supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var + + initDebugger (contramap DAPSessionLog l) servConf + supportsRunInTerminalRequest prefer_internal_interpreter + launch_args + + sendLaunchResponse -- ack + sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session + + liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info) +-------------------------------------------------------------------------------- + CommandAttach -> do + sendTerminatedEvent (TerminatedEvent False) + destroyDebugSession + sendError (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing +-------------------------------------------------------------------------------- + CommandBreakpointLocations -> commandBreakpointLocations + CommandSetBreakpoints -> commandSetBreakpoints + CommandSetFunctionBreakpoints -> commandSetFunctionBreakpoints + CommandSetExceptionBreakpoints -> commandSetExceptionBreakpoints + CommandExceptionInfo -> commandExceptionInfo + CommandSetDataBreakpoints -> undefined + CommandSetInstructionBreakpoints -> undefined +---------------------------------------------------------------------------- + CommandLoadedSources -> undefined +---------------------------------------------------------------------------- + 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 () + + -- Configuration is finished. Start executing until it halts. + startExecution >>= handleEvalResult False +---------------------------------------------------------------------------- + CommandThreads -> commandThreads + CommandStackTrace -> commandStackTrace + CommandScopes -> commandScopes + CommandVariables -> commandVariables +---------------------------------------------------------------------------- + CommandContinue -> commandContinue +---------------------------------------------------------------------------- + CommandNext -> commandNext +---------------------------------------------------------------------------- + CommandStepIn -> commandStepIn + CommandStepOut -> commandStepOut +---------------------------------------------------------------------------- + CommandEvaluate -> commandEvaluate +---------------------------------------------------------------------------- + CommandTerminate -> commandTerminate + CommandDisconnect -> commandDisconnect +---------------------------------------------------------------------------- + CommandModules -> sendModulesResponse (ModulesResponse [] Nothing) + CommandSource -> undefined + CommandPause -> pure () -- TODO + (CustomCommand "mycustomcommand") -> undefined + other -> do + terminateWithError ("Unsupported command: " <> show other) + +-- | Receive reverse request responses (such as runInTerminal response) +ack :: LogAction IO DAPLog + -> ReverseRequestResponse -> DebugAdaptorCont () +ack l rrr = case rrr.reverseRequestCommand of + ReverseCommandRunInTerminal -> do + + RunInTerminalResponse{} <- getReverseRequestResponseBody rrr + + -- TODO: keep track of body.shellProcessId to then kill the proxy when the + -- session is terminated: + -- [stdout] [127.0.0.1:54427][DEBUG][RECEIVED] + -- { + -- "body": { + -- "shellProcessId": 2092 + -- }, + -- "command": "runInTerminal", + -- "seq": 14, + -- "success": true, + -- "type": "response" + -- } + when rrr.success $ do + liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "RunInTerminal was successful") Info) + _ -> pure () + +-------------------------------------------------------------------------------- +-- * Logging +-------------------------------------------------------------------------------- + +data DAPLog + = DAPSessionLog DAPSessionLog + | DAPLaunchLog (WithSeverity T.Text) + | DAPLibraryLog DAP.DAPLog + +logSessionLog :: Show a => LogAction IO Text -> Severity -> WithSeverity a -> IO () +logSessionLog l threshold (WithSeverity msg sev) + | sev >= threshold = + cmapM renderWithTimestamp l <& (renderSeverity sev <> T.pack (show msg)) + | otherwise = pure () + +logDebuggerLog :: Handle -> LogAction IO Text -> Severity -> DebuggerLog -> IO () +logDebuggerLog h l threshold = \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 :: LogAction IO Text -> Severity -> WithSeverity Text -> IO () +defaultLog l threshold (WithSeverity msg sev) + | sev >= threshold = + cmapM renderWithTimestamp l <& (renderSeverity sev <> msg) + | otherwise = pure () + +logDAPLog :: Handle -> LogAction IO Text -> Severity -> DAPLog -> IO () +logDAPLog h l threshold = \case + DAPSessionLog (DAPSessionSetupLog sessionLog) -> logSessionLog l threshold sessionLog + DAPSessionLog (DAPDebuggerLog debuggerLog) -> logDebuggerLog h l threshold debuggerLog + DAPSessionLog (RunProxyServerLog sev_msg) -> defaultLog l threshold sev_msg + DAPLaunchLog sev_msg -> defaultLog l threshold sev_msg + DAPLibraryLog t -> + l <& DAP.renderDAPLog t + +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/hdb/Development/Debug/Adapter/Stepping.hs b/hdb-dap/Development/Debug/Adapter/Stepping.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Stepping.hs rename to hdb-dap/Development/Debug/Adapter/Stepping.hs diff --git a/hdb/Development/Debug/Adapter/Stopped.hs b/hdb-dap/Development/Debug/Adapter/Stopped.hs similarity index 100% rename from hdb/Development/Debug/Adapter/Stopped.hs rename to hdb-dap/Development/Debug/Adapter/Stopped.hs diff --git a/hdb/Development/Debug/Session/Setup.hs b/hdb-dap/Development/Debug/Session/Setup.hs similarity index 100% rename from hdb/Development/Debug/Session/Setup.hs rename to hdb-dap/Development/Debug/Session/Setup.hs diff --git a/hdb/Main.hs b/hdb/Main.hs index c32fc619..9fb82bd9 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -5,11 +5,7 @@ module Main where import System.Process import System.Environment -import Data.Maybe import Data.IORef -import Text.Read -import Control.Concurrent -import Control.Monad import Control.Monad.IO.Class import Control.Exception (bracket, uninterruptibleMask, bracketOnError) import Control.Exception.Backtrace @@ -17,17 +13,10 @@ import Control.Exception.Backtrace import DAP import Development.Debug.Adapter.Init -import Development.Debug.Adapter.Breakpoints -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.Exit.Helpers import Development.Debug.Adapter.Handles +import Development.Debug.Adapter.Server import Colog.Core -import Data.Time import System.IO ( hFlush , hClose @@ -38,8 +27,6 @@ import System.IO , openFile , IOMode(ReadMode, ReadWriteMode) ) -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 @@ -51,11 +38,9 @@ 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 GHC.Debugger.Monad (RunDebuggerSettings(..)) import Development.Debug.Options (HdbOptions(..)) import Development.Debug.Options.Parser (parseHdbOptions) -import Development.Debug.Adapter import Development.Debug.Adapter.Proxy import Development.Debug.Interactive import GHC.Stack.Annotation (annotateCallStackIO) @@ -89,7 +74,7 @@ main = do , hdbProgram} redirectRealStdout internalInterpreter $ \realStdout -> do hSetBuffering realStdout LineBuffering - l <- mainLogger hdbOpts.verbosity realStdout + l <- contramap DAPLog <$> mainLogger hdbOpts.verbosity realStdout init_var <- liftIO (newIORef False{-not supported by default-}) runDAPServerWithLogger (contramap DAPLibraryLog l) config (talk l servConf init_var internalInterpreter) @@ -179,212 +164,15 @@ main = do | otherwise = k stdout --- | Fetch config from environment, fallback to sane defaults -getConfig :: Int -> IO ServerConfig -getConfig port = do - let - hostDefault = "0.0.0.0" - portDefault = port - capabilities = Capabilities - { supportsConfigurationDoneRequest = True - , supportsFunctionBreakpoints = True - , supportsConditionalBreakpoints = True - , supportsHitConditionalBreakpoints = True - , supportsEvaluateForHovers = False - -- Exception Breakpoints: - , exceptionBreakpointFilters = [ defaultExceptionBreakpointsFilter - { exceptionBreakpointsFilterLabel = "All exceptions" - , exceptionBreakpointsFilterFilter = BREAK_ON_EXCEPTION - } - , defaultExceptionBreakpointsFilter - { exceptionBreakpointsFilterLabel = "Uncaught exceptions" - , exceptionBreakpointsFilterFilter = BREAK_ON_ERROR - } - ] - , supportsStepBack = False - , supportsSetVariable = False - , supportsRestartFrame = False - , supportsGotoTargetsRequest = False - , supportsStepInTargetsRequest = False - , supportsCompletionsRequest = False - , completionTriggerCharacters = [] - , supportsModulesRequest = False - , additionalModuleColumns = [ defaultColumnDescriptor - { columnDescriptorAttributeName = "Extra" - , columnDescriptorLabel = "Label" - } - ] - , supportedChecksumAlgorithms = [] - , supportsRestartRequest = False - , supportsExceptionOptions = True - , supportsValueFormattingOptions = True - , supportsExceptionInfoRequest = True - , supportTerminateDebuggee = False -- for now, when debugger is disconnected, we always kill the debuggee - , supportSuspendDebuggee = False - , supportsDelayedStackTraceLoading = False - , supportsLoadedSourcesRequest = False - , supportsLogPoints = True - , supportsTerminateThreadsRequest = False - , supportsSetExpression = False - , supportsTerminateRequest = True - , supportsDataBreakpoints = False - , supportsReadMemoryRequest = False - , supportsWriteMemoryRequest = False - , supportsDisassembleRequest = False - , supportsCancelRequest = False - -- Display which breakpoints are valid when user intends to set - -- breakpoint on given line: - , supportsBreakpointLocationsRequest = True - , supportsClipboardContext = False - , supportsSteppingGranularity = False - , supportsInstructionBreakpoints = False - , supportsExceptionFilterOptions = False - , supportsSingleThreadExecutionRequests = False - } - ServerConfig - <$> do fromMaybe hostDefault <$> lookupEnv "DAP_HOST" - <*> do fromMaybe portDefault . (readMaybe =<<) <$> do lookupEnv "DAP_PORT" - <*> pure capabilities - <*> pure True - --------------------------------------------------------------------------------- --- * Talk --------------------------------------------------------------------------------- - --- | 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 :: LogAction IO MainLog - -> DAPServerConf - -> IORef Bool - -- ^ Whether the client supports runInTerminal - -> Bool - -- ^ Prefer internal interpreter - -> Command -> DebugAdaptor () --------------------------------------------------------------------------------- -talk l servConf support_rit_var prefer_internal_interpreter = \ case - CommandInitialize -> do - InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments -#ifdef mingw32_HOST_OS - -- On Windows, runInTerminal is currently unsupported - -- See #199 - let runInTerminal = False -#else - let runInTerminal = fromMaybe False supportsRunInTerminalRequest -#endif - -- This global variable is wrong. Even though we only register the session - -- and the per-session state on Launch (which gives us __sessionId), the - -- *initialize* command is run once per new session on a new connection and - -- two different clients which may differ in their support for - -- 'runInTerminal'. - -- - -- The `dap` library should likely keep track of the client capabilities - -- per connection. - liftIO $ writeIORef support_rit_var runInTerminal - sendInitializeResponse --------------------------------------------------------------------------------- - CommandLaunch -> do - launch_args <- getArguments - - -- Wrong-ish. See above where this variable is written - supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var - - initDebugger (contramap DAPLog l) servConf - supportsRunInTerminalRequest prefer_internal_interpreter - launch_args - - sendLaunchResponse -- ack - sendInitializedEvent -- our debugger is only ready to be configured after it has launched the session - - liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "Debugger launched successfully.") Info) --------------------------------------------------------------------------------- - CommandAttach -> do - sendTerminatedEvent (TerminatedEvent False) - destroyDebugSession - sendError (ErrorMessage (T.pack "hdb does not support \"attach\" mode yet")) Nothing --------------------------------------------------------------------------------- - CommandBreakpointLocations -> commandBreakpointLocations - CommandSetBreakpoints -> commandSetBreakpoints - CommandSetFunctionBreakpoints -> commandSetFunctionBreakpoints - CommandSetExceptionBreakpoints -> commandSetExceptionBreakpoints - CommandExceptionInfo -> commandExceptionInfo - CommandSetDataBreakpoints -> undefined - CommandSetInstructionBreakpoints -> undefined ----------------------------------------------------------------------------- - CommandLoadedSources -> undefined ----------------------------------------------------------------------------- - 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 () - - -- Configuration is finished. Start executing until it halts. - startExecution >>= handleEvalResult False ----------------------------------------------------------------------------- - CommandThreads -> commandThreads - CommandStackTrace -> commandStackTrace - CommandScopes -> commandScopes - CommandVariables -> commandVariables ----------------------------------------------------------------------------- - CommandContinue -> commandContinue ----------------------------------------------------------------------------- - CommandNext -> commandNext ----------------------------------------------------------------------------- - CommandStepIn -> commandStepIn - CommandStepOut -> commandStepOut ----------------------------------------------------------------------------- - CommandEvaluate -> commandEvaluate ----------------------------------------------------------------------------- - CommandTerminate -> commandTerminate - CommandDisconnect -> commandDisconnect ----------------------------------------------------------------------------- - CommandModules -> sendModulesResponse (ModulesResponse [] Nothing) - CommandSource -> undefined - CommandPause -> pure () -- TODO - (CustomCommand "mycustomcommand") -> undefined - other -> do - terminateWithError ("Unsupported command: " <> show other) - --- | Receive reverse request responses (such as runInTerminal response) -ack :: LogAction IO MainLog - -> ReverseRequestResponse -> DebugAdaptorCont () -ack l rrr = case rrr.reverseRequestCommand of - ReverseCommandRunInTerminal -> do - - RunInTerminalResponse{} <- getReverseRequestResponseBody rrr - - -- TODO: keep track of body.shellProcessId to then kill the proxy when the - -- session is terminated: - -- [stdout] [127.0.0.1:54427][DEBUG][RECEIVED] - -- { - -- "body": { - -- "shellProcessId": 2092 - -- }, - -- "command": "runInTerminal", - -- "seq": 14, - -- "success": true, - -- "type": "response" - -- } - when rrr.success $ do - liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "RunInTerminal was successful") Info) - _ -> pure () -------------------------------------------------------------------------------- -- * Logging -------------------------------------------------------------------------------- data MainLog - = DAPLog DAPLog - | InteractiveLog InteractiveLog + = InteractiveLog InteractiveLog | RunProxyClientLog (WithSeverity T.Text) - | DAPLaunchLog (WithSeverity T.Text) - | DAPLibraryLog DAP.DAPLog + | DAPLog DAPLog -- | Given the severity threshold from which we start logging, create a base -- logger for consuming the top-level debugger logs ('MainLog'). @@ -392,54 +180,8 @@ data MainLog 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 - DAPLog (RunProxyServerLog sev_msg) -> defaultLog sev_msg - InteractiveLog (ISessionSetupLog sessionLog) -> logSessionLog sessionLog - InteractiveLog (IDebuggerLog debuggerLog) -> logDebuggerLog debuggerLog - 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 + InteractiveLog (ISessionSetupLog sessionLog) -> logSessionLog l threshold sessionLog + InteractiveLog (IDebuggerLog debuggerLog) -> logDebuggerLog h l threshold debuggerLog + RunProxyClientLog sev_msg -> defaultLog l threshold sev_msg + DAPLog dapLog -> logDAPLog h l threshold dapLog From d5151248c2753314f9014bc1b3f2bc948eb9a1a2 Mon Sep 17 00:00:00 2001 From: Andrea Date: Tue, 28 Apr 2026 15:27:18 +0200 Subject: [PATCH 08/11] runInTerminal is now per-session --- hdb-dap/Development/Debug/Adapter/Server.hs | 32 ++++++--------------- hdb/Main.hs | 5 +--- 2 files changed, 10 insertions(+), 27 deletions(-) diff --git a/hdb-dap/Development/Debug/Adapter/Server.hs b/hdb-dap/Development/Debug/Adapter/Server.hs index 3581cd01..b1d2af4d 100644 --- a/hdb-dap/Development/Debug/Adapter/Server.hs +++ b/hdb-dap/Development/Debug/Adapter/Server.hs @@ -7,7 +7,6 @@ module Development.Debug.Adapter.Server where import System.Environment import Data.Maybe -import Data.IORef import Text.Read import Control.Concurrent import Control.Monad @@ -121,41 +120,28 @@ getConfig port = do -- is implemented in this function. talk :: LogAction IO DAPLog -> DAPServerConf - -> IORef Bool - -- ^ Whether the client supports runInTerminal (FIXME: should be per-client) -> Bool -- ^ Prefer internal interpreter -> Command -> DebugAdaptor () -------------------------------------------------------------------------------- -talk l servConf support_rit_var prefer_internal_interpreter = \ case +talk l servConf prefer_internal_interpreter = \ case CommandInitialize -> do - InitializeRequestArguments{supportsRunInTerminalRequest} <- getArguments + sendInitializeResponse +-------------------------------------------------------------------------------- + CommandLaunch -> do + launch_args <- getArguments + + clientCaps <- getClientCapabilities #ifdef mingw32_HOST_OS -- On Windows, runInTerminal is currently unsupported -- See #199 let runInTerminal = False #else - let runInTerminal = fromMaybe False supportsRunInTerminalRequest + let runInTerminal = fromMaybe False $ supportsRunInTerminalRequest =<< clientCaps #endif - -- This global variable is wrong. Even though we only register the session - -- and the per-session state on Launch (which gives us __sessionId), the - -- *initialize* command is run once per new session on a new connection and - -- two different clients which may differ in their support for - -- 'runInTerminal'. - -- - -- The `dap` library should likely keep track of the client capabilities - -- per connection. - liftIO $ writeIORef support_rit_var runInTerminal - sendInitializeResponse --------------------------------------------------------------------------------- - CommandLaunch -> do - launch_args <- getArguments - - -- Wrong-ish. See above where this variable is written - supportsRunInTerminalRequest <- liftIO $ readIORef support_rit_var initDebugger (contramap DAPSessionLog l) servConf - supportsRunInTerminalRequest prefer_internal_interpreter + runInTerminal prefer_internal_interpreter launch_args sendLaunchResponse -- ack diff --git a/hdb/Main.hs b/hdb/Main.hs index 9fb82bd9..341e7ef7 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -5,8 +5,6 @@ module Main where import System.Process import System.Environment -import Data.IORef -import Control.Monad.IO.Class import Control.Exception (bracket, uninterruptibleMask, bracketOnError) import Control.Exception.Backtrace @@ -75,9 +73,8 @@ main = do redirectRealStdout internalInterpreter $ \realStdout -> do hSetBuffering realStdout LineBuffering l <- contramap DAPLog <$> mainLogger hdbOpts.verbosity realStdout - init_var <- liftIO (newIORef False{-not supported by default-}) runDAPServerWithLogger (contramap DAPLibraryLog l) config - (talk l servConf init_var internalInterpreter) + (talk l servConf internalInterpreter) (ack l ) HdbCLI{..} -> do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) From 61169d02269aa4d77c7b23ef767fdfbf2d7f668d Mon Sep 17 00:00:00 2001 From: Andrea Date: Tue, 28 Apr 2026 16:00:36 +0200 Subject: [PATCH 09/11] runHDBServer --- hdb-dap/Development/Debug/Adapter/Init.hs | 1 + hdb-dap/Development/Debug/Adapter/Server.hs | 6 ++++++ hdb/Main.hs | 7 +++++-- 3 files changed, 12 insertions(+), 2 deletions(-) diff --git a/hdb-dap/Development/Debug/Adapter/Init.hs b/hdb-dap/Development/Debug/Adapter/Init.hs index 9001b7a3..f0ca862f 100644 --- a/hdb-dap/Development/Debug/Adapter/Init.hs +++ b/hdb-dap/Development/Debug/Adapter/Init.hs @@ -99,6 +99,7 @@ type SessionProviderProvider a = LogAction IO (WithSeverity SessionSetupLog) -> data DAPServerConf = DAPServerConf { hdbProgram :: FilePath , sessionProviderProvider :: SessionProviderProvider () + , dapServerConfig :: ServerConfig } -- | Initialize debugger diff --git a/hdb-dap/Development/Debug/Adapter/Server.hs b/hdb-dap/Development/Debug/Adapter/Server.hs index b1d2af4d..bfa69a94 100644 --- a/hdb-dap/Development/Debug/Adapter/Server.hs +++ b/hdb-dap/Development/Debug/Adapter/Server.hs @@ -226,6 +226,12 @@ ack l rrr = case rrr.reverseRequestCommand of liftLogIO l <& DAPLaunchLog (WithSeverity (T.pack "RunInTerminal was successful") Info) _ -> pure () +runHDBServer :: LogAction IO DAPLog -> DAPServerConf -> IO () +runHDBServer l servConf@DAPServerConf{ dapServerConfig = config } = do + runDAPServerWithLogger (contramap DAPLibraryLog l) config + (talk l servConf False) + (ack l ) + -------------------------------------------------------------------------------- -- * Logging -------------------------------------------------------------------------------- diff --git a/hdb/Main.hs b/hdb/Main.hs index 341e7ef7..9dcb1ea7 100644 --- a/hdb/Main.hs +++ b/hdb/Main.hs @@ -68,8 +68,11 @@ main = do setBacktraceMechanismState IPEBacktrace (not disableIpeBacktraces) config <- getConfig port hdbProgram <- getExecutablePath - let servConf = DAPServerConf { sessionProviderProvider = getSessionProvider - , hdbProgram} + let servConf = DAPServerConf + { sessionProviderProvider = getSessionProvider + , hdbProgram + , dapServerConfig = config + } redirectRealStdout internalInterpreter $ \realStdout -> do hSetBuffering realStdout LineBuffering l <- contramap DAPLog <$> mainLogger hdbOpts.verbosity realStdout From 70047646d66856821d5adffb2f5dc8dfb0212cc6 Mon Sep 17 00:00:00 2001 From: Andrea Date: Wed, 29 Apr 2026 13:44:26 +0200 Subject: [PATCH 10/11] depend on and expose all home units --- haskell-debugger/GHC/Debugger/Session.hs | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index 57ab6f45..2ec3bd1d 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -89,7 +89,7 @@ import GHC.Driver.Pipeline (compileOne) import qualified GHC.Unit.Home.ModInfo as GHC import GHC.Utils.TmpFs import Data.Foldable (for_) -import GHC.Plugins (SourceError, try) +import GHC.Plugins (SourceError, try, UnitState (homeUnitDepends)) -- | Throws if package flags are unsatisfiable parseHomeUnitArguments :: GhcMonad m @@ -234,21 +234,24 @@ setExposedInUnit unitId exposed = do let old_ie = case lookupHugUnitId unitId (hsc_HUG env) of Just hue -> hue Nothing -> error $ "setExposedInUnit: unit not found " ++ unitIdString unitId + let home_units = allUnits $ hsc_HUG env let dflags = (homeUnitEnv_dflags old_ie) { packageFlags = [ExposePackage (unitIdString uid) (UnitIdArg $ RealUnit (Definite uid)) (ModRenaming True []) - | uid <- exposed + | uid <- exposed ++ Set.toList home_units , uid /= rtsUnitId , uid /= ghcInternalUnitId - , unitIdString uid /= "haskell-debugger-view-in-memory" +-- , unitIdString uid /= "haskell-debugger-view-in-memory" + , uid /= unitId -- FIXME: any other to filter out? - ]} + ] + , importPaths = [] + } let cached_dbs = homeUnitEnv_unit_dbs old_ie - let home_units = Set.fromList $ State.homeUnitDepends $ homeUnitEnv_units old_ie - (dbs,unit_state,home_unit,mconstants) <- liftIO $ State.initUnits (hsc_logger env) dflags cached_dbs home_units - + (dbs,unit_state,home_unit,mconstants) + <- liftIO $ State.initUnits (hsc_logger env) dflags cached_dbs home_units updated_dflags <- liftIO $ GHC.updatePlatformConstants dflags mconstants let ie = old_ie { homeUnitEnv_units = unit_state @@ -258,8 +261,7 @@ setExposedInUnit unitId exposed = do } let home_unit_graph = HUG.unitEnv_insert unitId ie (hsc_HUG env) - let ue0 = hsc_unit_env env - let ue1 = ue0 {ue_home_unit_graph = home_unit_graph} + let ue1 = (hsc_unit_env env) {ue_home_unit_graph = home_unit_graph} let new_env | ue_currentUnit ue1 /= unitId = hscSetUnitEnv ue1 env From 7826d8dea03c31f930be82ccc021c09ade09dd80 Mon Sep 17 00:00:00 2001 From: Andrea Date: Wed, 29 Apr 2026 13:44:58 +0200 Subject: [PATCH 11/11] patched dap source-package-repository --- cabal.project | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/cabal.project b/cabal.project index 12f71242..165e9913 100644 --- a/cabal.project +++ b/cabal.project @@ -13,3 +13,7 @@ if !os(windows) if !os(windows) executable-dynamic: True +source-repository-package + type: git + location: https://github.com/haskell-debugger/dap.git + tag: 2267060ddcee86a5d80b9d7ab29816deddcfe99c