Qualify modules with their pkg, but unambiguous

Author: Saizan

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,39 @@ 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"
+
+      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) $
+                lookupUnitPackageName hsc_env_new hdv_uid
+
+      -- See Note [Must explicitly expose module graph units]
+      setExposedInUnit interactiveGhcDebuggerUnitId . graphUnits . hsc_mod_graph =<< getSession
 
       mss <- getAllLoadedModules
 
-      GHC.setContext
-        (preludeImp :
-          dbgViewImps ++
-          map (GHC.IIModule . GHC.ms_mod) mss)
+      let
+        imports
+          = preludeImp :
+            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) $ lookupUnitPackageName hsc_env_new uid
+            ]
+
+
+      GHC.setContext imports
 
       -- See Note [External interpreter buffering]
       setBufferings <- compileExprRemote """
@@ -465,10 +464,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
@@ -581,6 +580,7 @@ Note [Do not package-qualify imports for home units]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 A package-qualified module import will be looked up directly in the exposed
 packages, IGNORING the home units modules.
+-- FIXME: PackageImport expects a PackageName, it only works with unit-ids with external packages by a quirk of the implementation, for home units though you can set your own package names and get around the problem.
 
 This can lead to two scenarios:
 
@@ -623,10 +623,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 +853,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

@@ -254,6 +254,7 @@ continueToCompletion = do
 --  extensions of the current breakpoint source module.
 --
 --  If we are not stopped at a breakpoint @m@ is executed with no change.
+-- FIXME: change name to reflect setContext change, and figure out where else it's needed.
 withCurrentBreakExtensions :: Debugger a -> Debugger a
 withCurrentBreakExtensions m = do
   mmodl <- getCurrentBreakModule
@@ -262,8 +263,11 @@ withCurrentBreakExtensions m = do
     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,
+  lookupUnitPackageName,
   )
   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)
 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, PackageName (..), mkFastString, lookupUnitId, GenericUnitInfo (unitPackageName))
+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,30 @@ 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
+
+
+lookupUnitPackageName :: HscEnv -> UnitId -> Maybe PackageName
+lookupUnitPackageName env uid = home_unit_name <|> ext_unit_name
+          where
+            home_unit_name = PackageName . mkFastString <$> (thisPackageName =<< home_unit_dflags env uid)
+            ext_unit_name = unitPackageName <$> lookupUnitId (hsc_units env) uid
+
+packageImportDecl :: PackageName -> ModuleName -> GHC.InteractiveImport
+packageImportDecl (PackageName pkgName) mn =
+  GHC.IIDecl (GHC.simpleImportDecl $ mn)
+    { ideclPkgQual = RawPkgQual
+        StringLiteral
+          { sl_st = NoSourceText
+          , sl_fs = pkgName
+          , sl_tc = Nothing
+          }
+    }
 -- ----------------------------------------------------------------------------
 -- Session cache directory
 -- ----------------------------------------------------------------------------
@@ -417,9 +494,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

haskell-debugger/GHC/Debugger/Stopped.hs

@@ -35,6 +35,7 @@ import GHC.Debugger.Interface.Messages
 import qualified GHC.Debugger.Interface.Messages as DbgStackFrame (DbgStackFrame(..))
 import GHC.Debugger.Utils
 import qualified Colog.Core as Logger
+import GHC.Debugger.Run (withCurrentBreakExtensions)
 
 {-
 Note [Don't crash if not stopped]
@@ -108,7 +109,7 @@ getThreads = do
 
 -- | Get the stack frames at the point we're stopped at
 getStacktrace :: RemoteThreadId -> Debugger [DbgStackFrame]
-getStacktrace req_tid = do
+getStacktrace req_tid = withCurrentBreakExtensions $ do
 
   tm <- liftIO . readIORef =<< asks threadMap
   let m_f_tid = lookupThreadMap (remoteThreadIntRef req_tid) tm

test/golden/self-debug-cli/self-debug-cli.hdb-stdin

@@ -1,5 +1,6 @@
 break --name runDebugger
 run cli test/golden/self-debug-cli/Main.hs
+print import GHC.Data.FastString
 print mkFastString "this FastString should be displayed pretty as a string (SHOULD NOT SEE ITS FULL INTERNALS)."
 print mkFastString "We have a DebugView FastString instance at this breakpoint."
 exit

test/golden/self-debug-cli/self-debug-cli.no-tmp-dir.external.ghc-914.hdb-stdout

@@ -1,4 +1,5 @@
 (hdb) Stopped at breakpoint
+(hdb) 
 (hdb) this FastString should be displayed pretty as a string (SHOULD NOT SEE ITS FULL INTERNALS).
 (hdb) We have a DebugView FastString instance at this breakpoint.
 (hdb) Exiting...

test/haskell/Test/Integration/Evaluate.hs

@@ -8,7 +8,9 @@ import Data.List (isInfixOf)
 import Test.DAP
 import Test.Tasty
 import Test.Tasty.HUnit
+#ifdef mingw32_HOST_OS
 import Test.Tasty.ExpectedFailure
+#endif
 import qualified DAP
 
 evaluateTests :: TestTree
@@ -21,8 +23,7 @@ evaluateTests =
         evaluateStructured
     , testCase "Imported module bindings available in evaluate context (issue #233)"
         evaluateImportedBindings
-    , expectFailBecause "#299" $
-        testCase "Bindings from other modules not available in evaluate context (issue #233)"
+    , testCase "Bindings from other modules not available in evaluate context (issue #233)"
           evaluateImportedBindingsNotInOtherModule
     ]
 
@@ -91,6 +92,7 @@ evaluateImportedBindingsNotInOtherModule =
       let result = DAP.evaluateResponseResult mapFailResp
       liftIO $ assertBool
         ("expected 'not in scope' error for Map.fromList, got: " ++ show result)
-        ("not in scope" `isInfixOf` show result)
+        (or [not_in_scope `isInfixOf` show result
+            | not_in_scope <- ["not in scope","Not in scope"]])
 
       disconnect