[Fix #299] Be more specific about what hdb brings in scope.

haskell-debugger/GHC/Debugger/Monad.hs

@@ -41,7 +41,6 @@ import System.Process.Internals (mkProcessHandle)
 import Text.Read (readMaybe)
 
 import GHC
-import GHC.Data.FastString
 import GHC.Data.StringBuffer
 import GHC.Driver.Config.Diagnostic
 import GHC.Driver.Config.Logger
@@ -61,9 +60,7 @@ import GHC.Runtime.Interpreter as GHCi
 import GHC.Runtime.Loader as GHC
 import GHC.Runtime.Context as GHCi
 import GHC.Types.Error
-import GHC.Types.PkgQual
 import GHC.Types.SourceError
-import GHC.Types.SourceText
 import GHC.Types.Unique.Supply as GHC
 import GHC.Unit.Module.Graph
 import GHC.Unit.State
@@ -399,8 +396,6 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
         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
@@ -413,35 +408,42 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
       -- in-memory sources.
       (hdv_uid, loadedBuiltinModNames) <- findOrLoadHaskellDebuggerView l buildWays
 
+      -- See Note [Must explicitly expose module graph units]
+      setExposedInUnit interactiveGhcDebuggerUnitId . graphUnits . hsc_mod_graph =<< getSession
 
       -- Set interactive context to import all loaded modules
-      let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude"
+      let preludeImp = GHC.simpleImportDecl $ GHC.mkModuleName "Prelude"
+
+      hsc_env_new <- getSession
+
       -- 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
+            = map (packageImportDecl hvd_pkgName) loadedBuiltinModNames
+            where
+              hvd_pkgName = fromMaybe (error $ "No package name for: " ++ unitIdString hdv_uid) $
+                lookupUnitPackageQualifier hsc_env_new hdv_uid
 
       mss <- getAllLoadedModules
 
-      GHC.setContext
-        (preludeImp :
-          dbgViewImps ++
-          map (GHC.IIModule . GHC.ms_mod) mss)
+      let
+        imports
+          = map GHC.IIDecl $ preludeImp :
+            [ i { ideclImportList = Just (Exactly, L noAnn []) }
+            | i <- instancesOnly ]
+
+        -- We import (only the instances of) all the home unit
+        -- modules to bring any orphan DebugView instances in scope.
+        instancesOnly =
+            dbgViewImps ++
+            [ packageImportDecl pkgName (moduleName modl)
+            | modl <- map GHC.ms_mod mss
+            , let uid = moduleUnitId modl
+            , let pkgName = fromMaybe (error $ "No package name for: " ++ unitIdString uid) $ lookupUnitPackageQualifier hsc_env_new uid
+            ]
+
+
+      GHC.setContext imports
 
       -- See Note [External interpreter buffering]
       setBufferings <- compileExprRemote """
@@ -465,10 +467,10 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
   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
+      withUnliftGhc $ \ unlift -> annotateCallStackIO $ do
+        withAsync (annotateCallStackIO $ void externalInterpFwdThread) $ \ fwd_thr -> do
+          liftIO $ annotateCallStackIO $ link fwd_thr
+          annotateCallStackIO $ unlift mainGhcThread
     Right _ ->
       -- Ext interp is running in user terminal, no need to forward output to logger
       mainGhcThread
@@ -577,27 +579,30 @@ An alternative, closer to what ghci does, would be to copy the `packageFlags`
 from the debuggee units, however doing so doesn't take care of fixing a unitId
 for dependencies of dependencies.
 
-Note [Do not package-qualify imports for home units]
+Note [Package Qualified Imports]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-A package-qualified module import will be looked up directly in the exposed
-packages, IGNORING the home units modules.
-
-This can lead to two scenarios:
+Package qualified imports have a quirky behaviour: the source string qualifier gets converted into a `PkgQual` on the way, which can be one of these two:
+- `ThisPkg unitId` interpreted as a home unit
+- `OtherPkg unitId` interpreted as an external package
 
-  1) a package-import of a loaded unit fails, because that unit, despite being
-  loaded, is not installed
+We get each under these conditions:
+- ThisPkg
+  - qualifier is the literal "this" or the **package name** of the active home unit or any of its home unit dependencies.
+- OtherPkg
+  - qualifier is the **package name** of a non-hidden external unit which exports the module we are importing.
+  - None of the above apply, and the qualifier itself is interpreted as a `UnitId`.
+When choosing between multiple units that satisfy a condition, the first found is committed to.
 
-  2) a package-import of a loaded unit succeeds, because a unit with the same
-  name (but not necessarily the same unit-id!), is installed.
+The upshot is that `UnitId`s normally only work as qualifiers for external packages, unless you change the package names of home units as described in  Note [ Ambiguous Package Qualified Imports Workaround ].
 
-The second case can result in subtly wrong interactive sessions, where the
+At the same time doing a PackageImport with a plain PackageName can succeed while resolving to an installed unit while we meant one of the loaded units, resulting in subtly wrong interactive sessions, where the
 package-qualified imported module shadows the loaded module. Perhaps GHC could
 warn about this. Cabal-repl and ghci also suffer from this subtle interaction.
 
 In light of this, when the debugger imports the `haskell-debugger-view` modules,
 it is imperative that if the `haskell-debugger-view` unit is in the home units
 (e.g. if `haskell-debugger-view` is listed in the cabal.project, like it is in
-the debugger tree), we do not use a package-qualified import.
+the debugger tree), we rely on Note [ Ambiguous Package Qualified Imports Workaround ].
 
 On the other hand, if the `haskell-debugger-view` package is not in the
 home-units, we *should* package-qualify it to make sure we reference the right
@@ -623,10 +628,6 @@ cleanupInterp = do
             sendMessage i Shutdown
             pure InterpPending
 
--- | WARNING: callback is not to be used from other threads.
-withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a
-withUnliftGhc k = reifyGhc $ \ s -> k (flip reflectGhc s)
-
 annotateDebuggerStackString :: String -> Debugger a -> Debugger a
 annotateDebuggerStackString s (Debugger m) = Debugger $ do
   r <- ReaderT $ \val -> do
@@ -857,10 +858,9 @@ doLoad if_cache how_much mg = do
 
 
 loadInMemoryModules ::
-  GhcMonad m
-  => LogAction IO DebuggerLog
+  LogAction IO DebuggerLog
   -> UnitId
-  -> [(ModuleName,StringBuffer)] -> m [SuccessFlag]
+  -> [(ModuleName,StringBuffer)] -> Ghc [SuccessFlag]
 loadInMemoryModules l uid ts = do
   old_targets <- GHC.getTargets
   tgts <- forM ts $  \(modName,modContents) ->

haskell-debugger/GHC/Debugger/Run.hs

@@ -211,7 +211,7 @@ addImport s = handleError $ do
 
 -- | Evaluate expression. Includes context of breakpoint if stopped at one (the current interactive context).
 doEval :: String -> Debugger EvalResult
-doEval expr = withCurrentBreakExtensions $ do
+doEval expr = withCurrentBreakEnv $ do
   excr <- (Right <$> exec expr GHC.execOptions) `catch` \(e::SomeException) -> pure (Left (displayException e))
   case excr of
     Left err -> pure $ EvalAbortedWith err
@@ -250,20 +250,23 @@ continueToCompletion = do
     GHC.ExecBreak{} -> continueToCompletion
     GHC.ExecComplete{} -> return execr
 
--- | @withCurrentBreakExtensions m@ executes @m@ with the language and language
+-- | @withCurrentBreakEnv m@ executes @m@ with the imports, language, and language
 --  extensions of the current breakpoint source module.
 --
 --  If we are not stopped at a breakpoint @m@ is executed with no change.
-withCurrentBreakExtensions :: Debugger a -> Debugger a
-withCurrentBreakExtensions m = do
+withCurrentBreakEnv :: Debugger a -> Debugger a
+withCurrentBreakEnv m = do
   mmodl <- getCurrentBreakModule
   case mmodl of
     Nothing          -> m
     Just breakModule -> do
       ic_dyn_flags <- getInteractiveDebuggerDynFlags
       break_dyn_flags <- ms_hspp_opts <$> GHC.getModSummary breakModule
+      old_context <- GHC.getContext
       setInteractiveDebuggerDynFlags $ adjustFlags ic_dyn_flags break_dyn_flags
+      GHC.setContext (IIModule breakModule : old_context)
       x <- m
+      GHC.setContext old_context
       setInteractiveDebuggerDynFlags ic_dyn_flags
       return x
   where

haskell-debugger/GHC/Debugger/Session.hs

@@ -33,12 +33,19 @@ module GHC.Debugger.Session (
   setExposedInUnit,
   graphUnits,
   compileModuleWithDepsInHpt,
+  home_unit_dflags,
+  packageImportDecl,
+  withUnliftGhc,
+  annotateCallStackGhc,
+  lookupUnitPackageQualifier,
   )
   where
 
 #if MIN_VERSION_ghc(9,14,2)
 import Data.Function ((&))
 #endif
+import Control.Applicative ((<|>))
+import Control.Exception (assert)
 import Control.Monad
 import Control.Monad.IO.Class
 import qualified Crypto.Hash.SHA1                    as H
@@ -75,7 +82,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, ModSummary (ms_hspp_opts))
+import GHC (SingleStep, ExecResult, ModSummary (ms_hspp_opts), ideclPkgQual, ImportDecl, GhcPs)
 import Data.Set (Set)
 import qualified GHC.Unit as GHC
 import GHC.Unit.Module.Graph (mg_mss, ModuleGraphNode (..), mnKey)
@@ -89,7 +96,10 @@ 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, RawPkgQual (..), HasCallStack, FastString, mkFastString, lookupUnitId)
+import GHC.Types.SourceText (StringLiteral(..), SourceText (..))
+import GHC.Stack.Annotation
+import GHC.Stack (callStack)
 
 -- | Throws if package flags are unsatisfiable
 parseHomeUnitArguments :: GhcMonad m
@@ -161,13 +171,24 @@ 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 unitDflags = do
+createHomeUnitGraph logger unitDflags0 = do
+  -- See Note [ Ambiguous Package Qualified Imports Workaround ]
+  let unitDflags = fixFlagsForIIDecl unitDflags0
   let home_units = Set.fromList $ map homeUnitId_ unitDflags
+
   unitEnvList <- flip traverse unitDflags $ \ dflags -> do
+    let uid = homeUnitId_ dflags
     hue <- setupNewHomeUnitEnv logger dflags Nothing home_units
-    pure (homeUnitId_ dflags, hue)
+    assert (homeUnitId_ (homeUnitEnv_dflags hue) == uid) $
+      pure (uid, hue)
 
   pure $ unitEnv_new (Map.fromList unitEnvList)
+  where
+    -- | Makes package names of home units unique and removes hidden modules.
+    fixFlagsForIIDecl [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
 
 setupNewHomeUnitEnv :: GHC.Logger -> DynFlags -> Maybe [GHC.UnitDatabase UnitId] -> Set UnitId -> IO HomeUnitEnv
 setupNewHomeUnitEnv logger dflags cached_dbs other_home_units = do
@@ -225,6 +246,13 @@ graphUnits mod_graph = L.nubOrd .
          InstantiationNode uid _ -> Just uid
          LinkNode _ _ -> Nothing
 
+-- | WARNING: callback is not to be used from other threads.
+withUnliftGhc :: ((Ghc b -> IO b) -> IO a) -> Ghc a
+withUnliftGhc k = reifyGhc $ \ s -> k (flip reflectGhc s)
+
+annotateCallStackGhc :: HasCallStack => Ghc a -> Ghc a
+annotateCallStackGhc m = let x = callStack in withUnliftGhc $ \k -> annotateStackShowIO x $ k m
+
 -- | Rebuilds the UnitState of the unit, exposing the given packages.
 --
 --   Takes care of updating hsc_dflags, ue_platform, and ue_namever if this is the ue_currentUnit.
@@ -280,7 +308,7 @@ setupMultiHomeUnitGhcSession
          -> HscEnv             -- ^ An empty HscEnv that we can use the setup the session.
          -> [(DynFlags, [GHC.Target])]    -- ^ New components to be loaded. Expected to be non-empty.
          -> IO (HscEnv, [TargetDetails])
-setupMultiHomeUnitGhcSession exts hsc_env cis = do
+setupMultiHomeUnitGhcSession exts hsc_env cis = annotateCallStackIO $ do
     let dfs = map fst cis
 
     hscEnv' <- initHomeUnitEnv dfs hsc_env
@@ -353,6 +381,31 @@ fromTargetId _ _ unitId (GHC.TargetFile f _) ctts = do
           | otherwise = (f ++ "-boot")
     return [TargetDetails (TargetFile f) [f, other] unitId ctts]
 
+{-
+Note [ Ambiguous Package Qualified Imports Workaround ]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Source level package qualified imports `import "foo" A` interpret "foo" as a package name.
+
+When one manually builds a `RawPkgQual` for an `ImportDecl` one can get away with using a unit-id, but only for external (i.e. not home) units.
+That it works does not seem entirely intended (see quoted snippet below), the code is in `renamePkgQual`: If a package qualifier is not found among packages it's looked up as an external unit. This is already in the code path for `OtherPkg` though, which is why Home Units are excluded.
+```
+    | otherwise
+    -> OtherPkg (UnitId pkg_fs)
+       -- not really correct as pkg_fs is unlikely to be a valid unit-id but
+       -- we will report the failure later...
+```
+
+Home units will only be found if the qualifier matches their dflags' `thisPackageName`. However that's bugged because the lookup doesn't bother considering there can be multiple units in the same package (library, sublibraries and exe units), and just picks the first found, leading to an import error if e.g. the library unit is picked but the module was in the exe one.
+Related GHC issue: https://gitlab.haskell.org/ghc/ghc/-/issues/24227
+
+Turns out that the package name of a home unit is pretty meaningless though, so we can update the dflags to replace it with anything that's actually unique so we can dodge the bug.
+
+Another stumbling block is that the `IIDecl` mode of an `InteractiveImport` does not allow importing hidden modules, but again for home units we can alter the DynFlags so all modules are exposed.
+
+See issue #288 for what can we do for users at the repl.
+-}
+
 -- ----------------------------------------------------------------------------
 -- GHC Utils that should likely be exposed by GHC
 -- ----------------------------------------------------------------------------
@@ -363,6 +416,33 @@ mkSimpleTarget df fp = GHC.Target (GHC.TargetFile fp Nothing) True (homeUnitId_
 hscSetUnitEnv :: UnitEnv -> HscEnv -> HscEnv
 hscSetUnitEnv ue env = env { hsc_unit_env = ue }
 
+home_unit_dflags :: HscEnv -> UnitId -> Maybe DynFlags
+home_unit_dflags hsc_env uid
+  = fmap homeUnitEnv_dflags
+  . HUG.lookupHugUnitId uid . ue_home_unit_graph
+  . hsc_unit_env
+  $ hsc_env
+
+-- | See Note [Package Qualified Imports] for why this is sometimes a @PackageName@ and sometimes a @UnitId@.
+newtype PackageQualifier = PackageQualifier FastString
+
+lookupUnitPackageQualifier :: HscEnv -> UnitId -> Maybe PackageQualifier
+lookupUnitPackageQualifier env uid = home_unit_name <|> ext_unit_name
+          where
+            -- See Note [Package Qualified Imports]
+            home_unit_name = PackageQualifier . mkFastString <$> (thisPackageName =<< home_unit_dflags env uid)
+            ext_unit_name = const (PackageQualifier (unitIdFS uid)) <$> lookupUnitId (hsc_units env) uid
+
+packageImportDecl :: PackageQualifier -> ModuleName -> ImportDecl GhcPs
+packageImportDecl (PackageQualifier pkgName) mn =
+  (GHC.simpleImportDecl $ mn)
+    { ideclPkgQual = RawPkgQual
+        StringLiteral
+          { sl_st = NoSourceText
+          , sl_fs = pkgName
+          , sl_tc = Nothing
+          }
+    }
 -- ----------------------------------------------------------------------------
 -- Session cache directory
 -- ----------------------------------------------------------------------------
@@ -417,9 +497,9 @@ getTargetFileSummary hsc_env target
       home_unit = ue_unitHomeUnit uid (hsc_unit_env hsc_env)
       dflags = homeUnitEnv_dflags (ue_findHomeUnitEnv uid (hsc_unit_env hsc_env))
 
-compileModuleWithDepsInHpt :: GhcMonad m =>
+compileModuleWithDepsInHpt ::
   GHC.Target ->
-  m (Maybe SourceError)
+  Ghc (Maybe SourceError)
 compileModuleWithDepsInHpt target@GHC.Target{targetUnitId = uid} = do
   hsc_env0 <- getSession
   let !old_active = hscActiveUnitId hsc_env0

haskell-debugger/GHC/Debugger/Session/Builtin.hs

@@ -107,6 +107,7 @@ addInMemoryHsDebuggerViewUnit base_uids initialDynFlags = do
           , unitId /= rtsUnitId
           , unitId /= ghcInternalUnitId
           ]
+        , thisPackageName = Just "haskell-debugger-view"
         }
         & setGeneralFlag' Opt_HideAllPackages
   hsc_env <- getSession