Various changes needed for ghc-worker integration

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,

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.

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
@@ -867,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

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

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.

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

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/"