From b97bc3a98f746a592d8d67504fe3de0c2185ad05 Mon Sep 17 00:00:00 2001 From: Andrea Date: Tue, 12 May 2026 15:15:38 +0200 Subject: [PATCH 1/7] Renamed dap sublib to dap-server and made it public --- haskell-debugger.cabal | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/haskell-debugger.cabal b/haskell-debugger.cabal index 1ec007cc..8730df2c 100644 --- a/haskell-debugger.cabal +++ b/haskell-debugger.cabal @@ -155,8 +155,9 @@ library hs-source-dirs: haskell-debugger default-language: GHC2021 -library dap +library dap-server import: warnings + visibility: public exposed-modules: Development.Debug.Adapter.Breakpoints, Development.Debug.Adapter.Stepping, Development.Debug.Adapter.Stopped, @@ -222,7 +223,7 @@ executable hdb unordered-containers >= 0.2.19 && < 0.3, haskell-debugger, - haskell-debugger:dap, + haskell-debugger:dap-server, hie-bios, prettyprinter ^>= 1.7.0, co-log-core >= 0.3.2.5 && < 0.4, From 1b57f023013796f447a4811de3bc889dfce4bef5 Mon Sep 17 00:00:00 2001 From: Andrea Date: Tue, 19 May 2026 10:14:27 +0200 Subject: [PATCH 2/7] HscEnv workarounds moved to mainThread --- haskell-debugger/GHC/Debugger/Monad.hs | 24 ++++++++------ haskell-debugger/GHC/Debugger/Session.hs | 40 ++++++++++++++++++------ 2 files changed, 46 insertions(+), 18 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index f2da644e..b3ff40ca 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -11,6 +11,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE NondecreasingIndentation #-} module GHC.Debugger.Monad where @@ -52,6 +53,7 @@ import GHC.Driver.Errors import GHC.Driver.Errors.Types import GHC.Driver.Main import GHC.Driver.Make +import qualified GHC.Driver.Monad as GHC import GHC.Driver.Ppr import GHC.Driver.Session (parseDynamicFlagsCmdLine) import GHC.Runtime.Eval @@ -242,7 +244,16 @@ withProjectDebugSession -> DebugRunner m a withProjectDebugSession ProjectDebugSpec{ghcInvocation = ghcI, ..} k = do let ghcInvocation = filter (\case ('-':'B':_) -> False; _ -> True) ghcI - GHC.runGhc (Just libdir) $ k rootDir extraGhcArgs $ do + GHC.runGhc (Just libdir) $ do +#ifdef MIN_VERSION_unix + -- Workaround #4162 + -- FIXME: setup reasonable handlers to run cleanupSession for every debugger thread, because runGhc's `withSignalHandlers` is not it. + _ <- liftIO $ installHandler sigINT Default Nothing + _ <- liftIO $ installHandler sigQUIT Default Nothing + _ <- liftIO $ installHandler sigTERM Default Nothing + _ <- liftIO $ installHandler sigHUP Default Nothing +#endif + k rootDir extraGhcArgs $ do dflags2 <- getSessionDynFlags -- Discover the user-given flags and targets @@ -268,14 +279,6 @@ runDebuggerAction :: forall a. LogAction IO DebuggerLog -> Ghc a runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger 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 -#endif dflags0 <- GHC.getSessionDynFlags let dflags1 = dflags0 { GHC.ghcMode = GHC.CompManager @@ -397,6 +400,9 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f loadHomeUnit + fixHomeUnitsDynFlagsForIIDecl + GHC.modifySessionM $ liftIO . addInteractiveGhcDebuggerUnit + -- 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 diff --git a/haskell-debugger/GHC/Debugger/Session.hs b/haskell-debugger/GHC/Debugger/Session.hs index 27a3ffa6..f94b0b29 100644 --- a/haskell-debugger/GHC/Debugger/Session.hs +++ b/haskell-debugger/GHC/Debugger/Session.hs @@ -38,6 +38,8 @@ module GHC.Debugger.Session ( withUnliftGhc, annotateCallStackGhc, lookupUnitPackageQualifier, + addInteractiveGhcDebuggerUnit, + fixHomeUnitsDynFlagsForIIDecl, ) where @@ -47,6 +49,7 @@ import Data.Function ((&)) import Control.Applicative ((<|>)) import Control.Exception (assert) import Control.Monad +import Control.Monad.Identity import Control.Monad.IO.Class import qualified Crypto.Hash.SHA1 as H import qualified Data.ByteString.Base16 as B16 @@ -171,9 +174,8 @@ setupHomeUnitGraph flagsAndTargets = do -- | Set up the 'HomeUnitGraph' with empty 'HomeUnitEnv's. -- The first 'DynFlags' are the 'DynFlags' for the interactive session. createHomeUnitGraph :: GHC.Logger -> [DynFlags] -> IO HomeUnitGraph -createHomeUnitGraph logger unitDflags0 = do - -- See Note [ Ambiguous Package Qualified Imports Workaround ] - let unitDflags = fixFlagsForIIDecl unitDflags0 +createHomeUnitGraph logger unitDflags = do + --let unitDflags = fixFlagsForIIDecl unitDflags0 let home_units = Set.fromList $ map homeUnitId_ unitDflags unitEnvList <- flip traverse unitDflags $ \ dflags -> do @@ -183,12 +185,21 @@ createHomeUnitGraph logger unitDflags0 = do pure (uid, hue) pure $ unitEnv_new (Map.fromList unitEnvList) + +-- | See Note [ Ambiguous Package Qualified Imports Workaround ] +fixHomeUnitsDynFlagsForIIDecl :: Ghc () +fixHomeUnitsDynFlagsForIIDecl = do + modifySession $ hscUpdateHUG $ \ hug -> do + let manyHomeUnits = Set.size (HUG.allUnits hug) > 1 + let h hue = hue { homeUnitEnv_dflags = fixFlagsForIIDecl manyHomeUnits (homeUnitEnv_dflags hue) } + runIdentity . unitEnv_traverseWithKey (const $ pure . h) $ hug where -- | Makes package names of home units unique and removes hidden modules. - fixFlagsForIIDecl [df] | Just{} <- thisPackageName df = [df {hiddenModules = Set.empty}] + fixFlagsForIIDecl :: Bool -> DynFlags -> DynFlags + fixFlagsForIIDecl False df | Just{} <- thisPackageName df = df {hiddenModules = Set.empty} -- TODO #288: pick more user-friendly names. - fixFlagsForIIDecl dfss = map (\ dflags -> dflags { thisPackageName = Just (unitIdString (homeUnitId_ dflags)) - , hiddenModules = Set.empty}) dfss + fixFlagsForIIDecl _manyHUnits dflags = dflags { thisPackageName = Just (unitIdString (homeUnitId_ dflags)) + , hiddenModules = Set.empty} setupNewHomeUnitEnv :: GHC.Logger -> DynFlags -> Maybe [GHC.UnitDatabase UnitId] -> Set UnitId -> IO HomeUnitEnv setupNewHomeUnitEnv logger dflags cached_dbs other_home_units = do @@ -203,10 +214,17 @@ setupNewHomeUnitEnv logger dflags cached_dbs other_home_units = do -- anything. initHomeUnitEnv :: [DynFlags] -> HscEnv -> IO HscEnv initHomeUnitEnv unitDflags env = do - let dflags0 = hsc_dflags env initial_home_graph <- createHomeUnitGraph (hsc_logger env) unitDflags + -- We need one of the units to be the `ue_currentUnit`: by default it's "main", but we don't create such a unit and Ghc panics. + addInteractiveGhcDebuggerUnit $ hscUpdateHUG (const initial_home_graph) env + +-- | Exported so it can be called in main in case we are getting the initial home graph some other way. +addInteractiveGhcDebuggerUnit :: HscEnv -> IO HscEnv +addInteractiveGhcDebuggerUnit env = do + let dflags0 = hsc_dflags env + let initial_home_graph = hsc_HUG env -- We set up the interactive debugger home unit after the other home units -- have been initialised. -- This allows us to reuse the package databases and their respective visibilities. @@ -233,8 +251,12 @@ initHomeUnitEnv unitDflags env = do HUG.unitEnv_insert interactiveGhcDebuggerUnitId interactiveHomeUnit initial_home_graph let interactiveDFlags = homeUnitEnv_dflags interactiveHomeUnit - unit_env <- - initUnitEnv interactiveGhcDebuggerUnitId home_unit_graph (GHC.ghcNameVersion interactiveDFlags) (targetPlatform interactiveDFlags) + let unit_env = (hsc_unit_env env) + { ue_home_unit_graph = home_unit_graph + , ue_current_unit = interactiveGhcDebuggerUnitId + , ue_platform = targetPlatform interactiveDFlags + , ue_namever = GHC.ghcNameVersion interactiveDFlags + } pure $ hscSetFlags interactiveDFlags $ hscSetUnitEnv unit_env env -- | Extracts @UnitId@s from the graph. From d999724436ef87df58417d651c3b21fed2df23ec Mon Sep 17 00:00:00 2001 From: Andrea Date: Tue, 19 May 2026 14:13:45 +0200 Subject: [PATCH 3/7] reexport LogAction(..) --- hdb-dap/Development/Debug/Adapter/Server.hs | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/hdb-dap/Development/Debug/Adapter/Server.hs b/hdb-dap/Development/Debug/Adapter/Server.hs index 5260c01f..6f788488 100644 --- a/hdb-dap/Development/Debug/Adapter/Server.hs +++ b/hdb-dap/Development/Debug/Adapter/Server.hs @@ -2,7 +2,12 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedRecordDot #-} -module Development.Debug.Adapter.Server where +module Development.Debug.Adapter.Server + ( + module Development.Debug.Adapter.Server, + LogAction(..), + ) + where import System.Environment From b02f6fac3a56cef316d5b20e6aa52a5f8af0a306 Mon Sep 17 00:00:00 2001 From: Andrea Date: Wed, 20 May 2026 11:56:51 +0200 Subject: [PATCH 4/7] add hdb-dap to hie.yaml --- hie.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/hie.yaml b/hie.yaml index 1d6358fe..81e9b4a3 100644 --- a/hie.yaml +++ b/hie.yaml @@ -3,6 +3,8 @@ cradle: cabal: - path: "./haskell-debugger/" component: "lib:haskell-debugger" + - path: "./hdb-dap/" + component: "lib:dap-server" - path: "./hdb/" component: "exe:hdb" - path: "./test/haskell/" From 1aae21e59245c72bcca8825bc3f07c257e3b3bb5 Mon Sep 17 00:00:00 2001 From: Andrea Date: Wed, 20 May 2026 14:02:56 +0200 Subject: [PATCH 5/7] loadInMemoryModules: manually add to home mod. graph. A debugRunner might not set any of the loaded modules as targets, so we can't rely on those to ensure they are included in the result by downsweep. Then we do a downsweep only for the in-memory modules and manually construct the union of the graphs. --- haskell-debugger/GHC/Debugger/Monad.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Monad.hs b/haskell-debugger/GHC/Debugger/Monad.hs index b3ff40ca..991a2cf4 100644 --- a/haskell-debugger/GHC/Debugger/Monad.hs +++ b/haskell-debugger/GHC/Debugger/Monad.hs @@ -873,14 +873,13 @@ loadInMemoryModules :: -> UnitId -> [(ModuleName,StringBuffer)] -> Ghc [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) + GHC.setTargets tgts 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 + modifySession $ GHC.setModuleGraph $ mkModuleGraph $ mg_mss dvc_mod_graph ++ mg_mss mod_graph restore_logger <- GHC.getLogger dflags <- getSessionDynFlags From e58290c2f11ff0dc2477016fabab893f3d97376b Mon Sep 17 00:00:00 2001 From: Andrea Date: Wed, 20 May 2026 14:39:48 +0200 Subject: [PATCH 6/7] normalisedModLoc makes absolute --- haskell-debugger/GHC/Debugger/Run.hs | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Run.hs b/haskell-debugger/GHC/Debugger/Run.hs index 1abf4bbc..80c5cda3 100644 --- a/haskell-debugger/GHC/Debugger/Run.hs +++ b/haskell-debugger/GHC/Debugger/Run.hs @@ -16,7 +16,6 @@ import Control.Monad.IO.Class import Control.Monad.Catch import Control.Monad.Reader import Data.IORef -import qualified Data.List as List import Data.Maybe import System.FilePath import System.Directory @@ -137,9 +136,16 @@ debugExecution entryFile entry args = do findUnitIdOfEntryFile fp = do afp <- normalise <$> liftIO (makeAbsolute fp) modSums <- getAllLoadedModules - let normalisedModLoc = fmap normalise . GHC.ml_hs_file . GHC.ms_location - case List.find ((Just afp ==) . normalisedModLoc) modSums of - Nothing -> error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp ++ "\nCandidates were:\n" ++ unlines (map (show . normalisedModLoc) modSums) + let normalisedModLoc = maybe (pure Nothing) (fmap (Just . normalise) . liftIO . makeAbsolute) . GHC.ml_hs_file . GHC.ms_location + let findM _ [] = return Nothing + findM f (x:xs) = do + b <- f x + if b then return (Just x) else findM f xs + r <- findM (fmap (Just afp ==) . normalisedModLoc) modSums + case r of + Nothing -> do + norms <- mapM normalisedModLoc modSums + error $ "findUnitIdOfEntryFile: no unit id found for: " ++ fp ++ "\nCandidates were:\n" ++ unlines (map show norms) Just summary -> pure summary -- | Resume execution of the stopped debuggee program From 2de8db667a01585f514168b7c87be45f5c9c3f16 Mon Sep 17 00:00:00 2001 From: Andrea Date: Wed, 20 May 2026 14:53:19 +0200 Subject: [PATCH 7/7] deal with relative paths in getModuleByPath --- haskell-debugger/GHC/Debugger/Breakpoint.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/haskell-debugger/GHC/Debugger/Breakpoint.hs b/haskell-debugger/GHC/Debugger/Breakpoint.hs index ec3001ba..f9e2c2c7 100644 --- a/haskell-debugger/GHC/Debugger/Breakpoint.hs +++ b/haskell-debugger/GHC/Debugger/Breakpoint.hs @@ -280,16 +280,16 @@ parseQC a (x:xs) = parseQC (x:a) xs getModuleByPath :: FilePath -> Debugger (Either SDoc ModSummary) getModuleByPath path = do -- get all loaded modules this every time as the loaded modules may have changed - lms <- getAllLoadedModules + lms <- mapM (\ m -> fmap (m,) . liftIO . makeAbsolute . msHsFilePath $ m) =<< getAllLoadedModules absPath <- liftIO $ makeAbsolute path - let matches ms = normalise (msHsFilePath ms) == normalise absPath + let matches (_,ms) = normalise ms == normalise absPath return $ case filter matches lms of - [x] -> Right x + [x] -> Right (fst x) [] -> Left $ text "No module matched" <+> text path <> text "." $$ text "Loaded modules:" - $$ vcat (map (text . msHsFilePath) lms) + $$ vcat (map (text . snd) lms) $$ text "Perhaps you've set a breakpoint on a module that isn't loaded into the session?" - xs -> Left $ text "Too many modules (" <> ppr xs <> text ") matched" <+> text path + xs -> Left $ text "Too many modules (" <> ppr (map fst xs) <> text ") matched" <+> text path <> text ". Please report a bug at https://github.com/well-typed/haskell-debugger." -- | Find a 'BreakpointId' index and its span from a module + line + column.