Qualify modules with their pkg, but unambiguous

Author: Saizan

haskell-debugger/GHC/Debugger/Monad.hs

@@ -61,9 +61,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
@@ -416,32 +414,36 @@ runDebuggerAction l rootDir extraGhcArgs conf loadHomeUnit (Debugger action) = f
 
       -- Set interactive context to import all loaded modules
       let preludeImp = GHC.IIDecl . GHC.simpleImportDecl $ GHC.mkModuleName "Prelude"
+
+      hu_dflags <- home_unit_dflags <$> getSession
+
+      hug <- hsc_HUG <$> 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 = maybe (unitIdFS hdv_uid) mkFastString
+                          $ thisPackageName $ hu_dflags hdv_uid
 
       mss <- getAllLoadedModules
 
       GHC.setContext
         (preludeImp :
           dbgViewImps ++
-          map (GHC.IIModule . GHC.ms_mod) mss)
+        [ packageImportDecl pkgName (moduleName modl)
+        | modl <- map GHC.ms_mod mss
+        , let uid = moduleUnitId modl
+        , let pkgName = maybe (unitIdFS uid) mkFastString . thisPackageName $ hu_dflags uid
+        ]
+        )
 
       -- See Note [External interpreter buffering]
       setBufferings <- compileExprRemote """

haskell-debugger/GHC/Debugger/Session.hs

@@ -33,12 +33,15 @@ module GHC.Debugger.Session (
   setExposedInUnit,
   graphUnits,
   compileModuleWithDepsInHpt,
+  home_unit_dflags,
+  packageImportDecl,
   )
   where
 
 #if MIN_VERSION_ghc(9,14,2)
 import Data.Function ((&))
 #endif
+import Control.Exception (assert)
 import Control.Monad
 import Control.Monad.IO.Class
 import qualified Crypto.Hash.SHA1                    as H
@@ -75,7 +78,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 +92,9 @@ 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 (..))
+import GHC.Types.SourceText (StringLiteral(..), SourceText (..))
+import qualified GHC.Data.FastString
 
 -- | Throws if package flags are unsatisfiable
 parseHomeUnitArguments :: GhcMonad m
@@ -161,13 +166,21 @@ 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 = fixPackageNames 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
+    fixPackageNames [df] | Just{} <- thisPackageName df = [df]
+    -- TODO #288: pick more user-friendly names.
+    fixPackageNames dfss = map (\ dflags -> dflags { thisPackageName = Just (unitIdString (homeUnitId_ dflags))}) dfss
 
 setupNewHomeUnitEnv :: GHC.Logger -> DynFlags -> Maybe [GHC.UnitDatabase UnitId] -> Set UnitId -> IO HomeUnitEnv
 setupNewHomeUnitEnv logger dflags cached_dbs other_home_units = do
@@ -356,6 +369,29 @@ 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 `InteractiveImportDecl` 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.
+TODO: report this upstream.
+
+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.
+
+See issue #288 for what can we do for users at the repl.
+-}
+
 -- ----------------------------------------------------------------------------
 -- GHC Utils that should likely be exposed by GHC
 -- ----------------------------------------------------------------------------
@@ -366,6 +402,23 @@ 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 -> DynFlags
+home_unit_dflags hsc_env uid
+  = homeUnitEnv_dflags
+  . ue_findHomeUnitEnv uid
+  . hsc_unit_env
+  $ hsc_env
+
+packageImportDecl :: GHC.Data.FastString.FastString -> ModuleName -> GHC.InteractiveImport
+packageImportDecl pkgName mn =
+  GHC.IIDecl (GHC.simpleImportDecl $ mn)
+    { ideclPkgQual = RawPkgQual
+        StringLiteral
+          { sl_st = NoSourceText
+          , sl_fs = pkgName
+          , sl_tc = Nothing
+          }
+    }
 -- ----------------------------------------------------------------------------
 -- Session cache directory
 -- ----------------------------------------------------------------------------

hdb-dap/Development/Debug/Session/Setup.hs

@@ -86,6 +86,7 @@ data HieBiosFlags = HieBiosFlags
       -- Important for multi-package cabal projects, as packages are not in the
       -- root of the cradle, but in some sub-directory.
       }
+  deriving Show
 
 -- | Prepare a GHC session using hie-bios from scratch
 hieBiosSetup :: LogAction IO (WithSeverity SessionSetupLog)
@@ -208,7 +209,9 @@ hieDebugRunner l (DebugRunnerConf projectRoot entryFile extraGhcArgs) = runExcep
   r <- hieBiosSetup l projectRoot entryFile
   HieBiosFlags{..} <- case r of
     Left e -> throwError e
-    Right f -> return f
+    Right f -> do
+      liftIO $ print r
+      return f
   let absEntryFile = normalise $ projectRoot </> entryFile
   let
   pure $ Debugger.withProjectDebugSession ProjectDebugSpec{..}