Hannes Siebenhandl pushed to branch wip/fendor/T27202 at Glasgow Haskell Compiler / GHC Commits: 77d6c0a6 by fendor at 2026-05-12T15:51:35+02:00 Use home unit package db stacks in GHCi prompt and session unit In order to import modules from home unit dependencies (e.g., `Data.Map`), the ghci prompt unit needs to populate its `UnitEnv`. This is tricky to handle correctly, which `PackageDBFlag`s should we use to populate the `UnitEnv`? We decide, the most intuitive solution for users is to depend on all `PackageDBFlag`s, so that any dependency can be imported in GHCi. This assumes consistency in the `PackageDBFlag`s, so no two home units specify `PackageDBFlag`s that are inconsistent with each other. We could simply concat all the `PackageDBFlag`s of the existing home units, but later `PackageDBFlag`s shadow earlier ones, leading to the last processed home units' `PackageDBFlag`s to shadow the earlier ones. This is hard to fix, we need to give users the capability to provide ghc options for the ghci prompt home unit. However, as this is considerably more work, we decided on an approximation that should work out most of the time. Package Db stacks in cabal and stack follow a certain structure: -no-user-package-db > -package-db $cabal-store > -package-db $local-db The first two arguments are always the same, namely the `-no-user-package-db` and `-package-db`. We compute the longest common prefix over all home units, and use that as the start of the package db stack. Then, over the rest of the `PackageDBFlag`s, we simply take the union and append them to our initial stack. We assume, that this rest of package dbs only defines very few, "local" units that are usually not shadowing each other. This allows us to get a relatively consistent package database stack for the ghci prompt home unit. Similar reasoning applies to the session unit in order to add modules to the session and have dependencies available in the module. We do something similar for `-package` flags, to make sure only the correct units are actually visible in the ghci session. This time, we simply take the union of all `PackageFlag`s, allowing us to import modules from the home unit dependencies. In the future, it would be beneficial to allow the user to provide the exact ghc options to control the visibilities. For now, this will have to do. - - - - - 24 changed files: - changelog.d/T27202 - compiler/GHC/Driver/DynFlags.hs - compiler/GHC/Unit/Home/Graph.hs - compiler/GHC/Unit/State.hs - ghc/GHCi/UI.hs - + testsuite/tests/ghci/prog-mhu006/Makefile - + testsuite/tests/ghci/prog-mhu006/a/A.hs - + testsuite/tests/ghci/prog-mhu006/all.T - + testsuite/tests/ghci/prog-mhu006/b/B.hs - + testsuite/tests/ghci/prog-mhu006/prog-mhu006a.script - + testsuite/tests/ghci/prog-mhu006/prog-mhu006a.stdout - + testsuite/tests/ghci/prog-mhu006/unitA - + testsuite/tests/ghci/prog-mhu006/unitB - + testsuite/tests/ghci/prog025/Makefile - + testsuite/tests/ghci/prog025/a/A.hs - + testsuite/tests/ghci/prog025/all.T - + testsuite/tests/ghci/prog025/prog025a.script - + testsuite/tests/ghci/prog025/prog025a.stdout - + testsuite/tests/ghci/prog025/prog025b.script - + testsuite/tests/ghci/prog025/prog025b.stdout - + testsuite/tests/ghci/prog025/testpkg/Test.hs - + testsuite/tests/ghci/prog025/testpkg/testpkg-0.1.0.0.pkg - + testsuite/tests/ghci/prog025/testpkg/testpkg-0.2.0.0.pkg - + testsuite/tests/ghci/prog025/unitA Changes: ===================================== changelog.d/T27202 ===================================== @@ -1,9 +1,13 @@ section: ghci -synopsis: Fix regression to allow loading modules into the GHCi after startup. +synopsis: Fix regression to honour module targets in nested directories into GHCi after startup. issues: #27202 mrs: !15980 description: { Fix a regression that made it impossible to import modules using `:load <Mod>` and `:add <Mod>` after GHCi startup. GHCi wasn't honouring the `-i<directory>` argument if given via `ghci -i<directory>`. + + Further, we fix a bug while setting up package database stacks for GHCi that was uncovered during this fix. + By underspecifying the version of dependencies, import modules from dependencies were ambiguous, even though + they shouldn't have been! } ===================================== compiler/GHC/Driver/DynFlags.hs ===================================== @@ -37,6 +37,7 @@ module GHC.Driver.DynFlags ( packageFlagsChanged, IgnorePackageFlag(..), TrustFlag(..), PackageDBFlag(..), PkgDbRef(..), + isPackageDbRef, Option(..), showOpt, DynLibLoader(..), positionIndependent, @@ -881,7 +882,7 @@ isNoLink _ = False data PackageArg = PackageArg String -- ^ @-package@, by 'PackageName' | UnitIdArg Unit -- ^ @-package-id@, by 'Unit' - deriving (Eq, Show) + deriving (Eq, Ord, Show) instance Outputable PackageArg where ppr (PackageArg pn) = text "package" <+> text pn @@ -902,7 +903,7 @@ data ModRenaming = ModRenaming { modRenamingWithImplicit :: Bool, -- ^ Bring all exposed modules into scope? modRenamings :: [(ModuleName, ModuleName)] -- ^ Bring module @m@ into scope -- under name @n@. - } deriving (Eq) + } deriving (Eq, Ord) instance Outputable ModRenaming where ppr (ModRenaming b rns) = ppr b <+> parens (ppr rns) @@ -920,14 +921,21 @@ data TrustFlag data PackageFlag = ExposePackage String PackageArg ModRenaming -- ^ @-package@, @-package-id@ | HidePackage String -- ^ @-hide-package@ - deriving (Eq) -- NB: equality instance is used by packageFlagsChanged + deriving (Eq, Ord) -- NB: equality instance is used by packageFlagsChanged data PackageDBFlag = PackageDB PkgDbRef | NoUserPackageDB | NoGlobalPackageDB | ClearPackageDBs - deriving (Eq) + deriving (Eq, Ord) + +isPackageDbRef :: PackageDBFlag -> Maybe PkgDbRef +isPackageDbRef = \ case + PackageDB ref -> Just ref + NoUserPackageDB -> Nothing + NoGlobalPackageDB -> Nothing + ClearPackageDBs -> Nothing packageFlagsChanged :: DynFlags -> DynFlags -> Bool packageFlagsChanged idflags1 idflags0 = @@ -1009,7 +1017,7 @@ data PkgDbRef = GlobalPkgDb | UserPkgDb | PkgDbPath OsPath - deriving Eq + deriving (Eq, Ord) ===================================== compiler/GHC/Unit/Home/Graph.hs ===================================== @@ -118,6 +118,10 @@ allAnns :: HomeUnitGraph -> IO AnnEnv allAnns hug = foldr go (pure emptyAnnEnv) hug where go hue = liftA2 plusAnnEnv (hptAllAnnotations (homeUnitEnv_hpt hue)) +-- | Retrieve all 'UnitId's of units in the 'HomeUnitGraph'. +allUnits :: HomeUnitGraph -> Set.Set UnitId +allUnits = unitEnv_keys + -------------------------------------------------------------------------------- -- HomeUnitGraph (HUG) -------------------------------------------------------------------------------- @@ -211,10 +215,6 @@ renameUnitId oldUnit newUnit hug = case unitEnv_lookup_maybe oldUnit hug of unitEnv_insert newUnit oldHue $ unitEnv_delete oldUnit hug --- | Retrieve all 'UnitId's of units in the 'HomeUnitGraph'. -allUnits :: HomeUnitGraph -> Set.Set UnitId -allUnits = unitEnv_keys - -- | Set the 'DynFlags' of the 'HomeUnitEnv' for unit in the 'HomeModuleGraph' updateUnitFlags :: UnitId -> (DynFlags -> DynFlags) -> HomeUnitGraph -> HomeUnitGraph updateUnitFlags uid f = unitEnv_adjust update uid ===================================== compiler/GHC/Unit/State.hs ===================================== @@ -68,7 +68,9 @@ module GHC.Unit.State ( pprRawUnitIds, -- * Utils - unwireUnit) + unwireUnit, + selectHptFlag, + ) where import GHC.Prelude ===================================== ghc/GHCi/UI.hs ===================================== @@ -8,6 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# OPTIONS -fno-warn-name-shadowing #-} +{-# OPTIONS -Wno-x-partial #-} -- This module does a lot of it ----------------------------------------------------------------------------- @@ -53,6 +54,7 @@ import GHC.Driver.Errors (printOrThrowDiagnostics) import GHC.Driver.Errors.Types import GHC.Driver.Phases import GHC.Driver.Session as DynFlags +import GHC.Driver.DynFlags as DynFlags import GHC.Driver.Ppr hiding (printForUser) import GHC.Utils.Error hiding (traceCmd) import GHC.Driver.Monad ( modifySession, modifySessionM ) @@ -131,6 +133,7 @@ import qualified Data.Foldable as Foldable import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef ) import Data.List ( find, intercalate, intersperse, isPrefixOf, isSuffixOf, nub, partition, sort, sortBy, (\\) ) +import qualified Data.List as List import qualified Data.List.NonEmpty as NE import qualified Data.Set as S import Data.Maybe @@ -745,6 +748,48 @@ installInteractiveHomeUnits dflags = do sessionUnitExposedFlag = homeUnitPkgFlag interactiveSessionUnitId + -- Currently, we are in a somewhat awkward situation. + -- Users clearly want to control precisely which packages are available at the GHCi prompt, + -- but there is currently no way for the user to declaratively change the set of packages + -- available at the prompt. Thus, a bit of guessing is necessary to provide the reasonable + -- GHCi UX experience, but in the future, we might want to give the user more precise control. + -- + -- The prompt and session home unit may not have any package db specified, but we still want to + -- to import modules from our home unit dependencies. + -- To make this possible, the prompt and session home unit need to have a package db, but which one? + -- We decide, if a package db is given at the top level, e.g. @ghci -package-db ...@, + -- then we honour what the user requests and only use this @-package-db@. + -- However, in the case of multiple home units, initialised via @ghci -unit ... -unit ...@, there + -- are not @-package-db@ arguments in the base 'DynFlags'... + -- To fix this, we look at the home units and merge their package dbs stacks. + -- We assume, that many package db stacks look almost identical, and only differ in view elements. + -- Thus, we try to extract a common package db stack (i.e., longest common prefix), and then concat + -- the rest of the package db stacks. At last, we add the two result package db stacks. + -- This should work reliably with cabal and stack, but it is hacky. + -- A proper solution would be to teach cabal and other tooling to specify the correct package db + -- stacks for the prompt and session home unit. + ghciPackageDbStacks = + if all (isNothing . DynFlags.isPackageDbRef) (packageDBFlags dflags0) + then + HUG.unitEnv_assocs (hsc_HUG hsc_env) + & concatPackageDbStacksUsingLongestCommonPrefix . map (packageDBFlags . HUG.homeUnitEnv_dflags . snd) + else + packageDBFlags dflags0 + + -- Make sure the prompt and session home unit use the correct dependencies. + ghciPackageFlags = + if null (packageFlags dflags0) + then + HUG.unitEnv_assocs (hsc_HUG hsc_env) + & concatMap (packageFlags . HUG.homeUnitEnv_dflags . snd) + -- We don't want to add `-package-id` flags for home units. + -- This is mostly for a clear separation of concerns, + -- to indicate we only care about unit dependencies from package dbs. + & filter (not . selectHptFlag (HUG.allUnits $ hsc_HUG hsc_env)) + & ordNub + else + packageFlags dflags0 + -- Explicitly depends on all home units and 'sessionUnitExposedFlag'. -- Normalise the 'dflagsPrompt', as they will be used for 'ic_dflags' -- of the 'InteractiveContext'. @@ -759,8 +804,9 @@ installInteractiveHomeUnits dflags = do , [ homeUnitPkgFlag uid | uid <- S.toList $ HUG.allUnits $ hsc_HUG hsc_env ] - , packageFlags dflags0 + , ghciPackageFlags ] + , packageDBFlags = ghciPackageDbStacks , importPaths = [] } @@ -773,25 +819,19 @@ installInteractiveHomeUnits dflags = do [ [ homeUnitPkgFlag uid | uid <- S.toList $ HUG.allUnits $ hsc_HUG hsc_env ] - , packageFlags dflags + , ghciPackageFlags ] + , packageDBFlags = ghciPackageDbStacks } let - cached_unit_dbs = - concat - . catMaybes - . fmap homeUnitEnv_unit_dbs - $ Foldable.toList - $ hsc_HUG hsc_env - all_unit_ids = S.insert interactiveGhciUnitId $ S.insert interactiveSessionUnitId $ hsc_all_home_unit_ids hsc_env - ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids cached_unit_dbs - ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids cached_unit_dbs + ghciPromptUnit <- setupHomeUnitFor logger dflagsPrompt all_unit_ids + ghciSessionUnit <- setupHomeUnitFor logger dflagsSession all_unit_ids let -- Setup up the HUG, install the interactive home units withInteractiveUnits = @@ -813,13 +853,26 @@ installInteractiveHomeUnits dflags = do pure () where - setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> [UnitDatabase UnitId] -> m HomeUnitEnv - setupHomeUnitFor logger dflags all_home_units cached_unit_dbs = do + setupHomeUnitFor :: GHC.GhcMonad m => Logger -> DynFlags -> S.Set UnitId -> m HomeUnitEnv + setupHomeUnitFor logger dflags all_home_units = do (dbs,unit_state,home_unit,_mconstants) <- - liftIO $ initUnits logger dflags (Just cached_unit_dbs) all_home_units + liftIO $ initUnits logger dflags Nothing all_home_units hpt <- liftIO emptyHomePackageTable pure (HUG.mkHomeUnitEnv unit_state (Just dbs) dflags hpt (Just home_unit)) + concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag] + concatPackageDbStacksUsingLongestCommonPrefix stacks = + let + -- O (m * n) + -- m ... Number of PackageDBFlag stacks + -- n ... Size of the stacks + longestCommonPrefix = + map List.head . List.takeWhile ((List.all . (==) . List.head) <*> List.tail) . List.transpose + prefix = + longestCommonPrefix stacks + in + prefix ++ ordNub (concatMap (List.drop (length prefix)) stacks) + reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do printError err ===================================== testsuite/tests/ghci/prog-mhu006/Makefile ===================================== @@ -0,0 +1,9 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +.PHONY: prog-mhu006a +prog-mhu006a: + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db \ + -unit @unitA -unit @unitB < prog-mhu006a.script ===================================== testsuite/tests/ghci/prog-mhu006/a/A.hs ===================================== @@ -0,0 +1 @@ +module A where ===================================== testsuite/tests/ghci/prog-mhu006/all.T ===================================== @@ -0,0 +1,8 @@ + +proj_files = extra_files(['a/', 'b/', 'unitA', 'unitB']) + +test('prog-mhu006a', + [proj_files, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + makefile_test, ['prog-mhu006a']) ===================================== testsuite/tests/ghci/prog-mhu006/b/B.hs ===================================== @@ -0,0 +1 @@ +module B where ===================================== testsuite/tests/ghci/prog-mhu006/prog-mhu006a.script ===================================== @@ -0,0 +1,4 @@ +"Can import modules from dependencies" +:m + Data.ByteString +:m + Data.Text +"Imported Data.ByteString and Data.Text" ===================================== testsuite/tests/ghci/prog-mhu006/prog-mhu006a.stdout ===================================== @@ -0,0 +1,2 @@ +"Can import modules from dependencies" +"Imported Data.ByteString and Data.Text" ===================================== testsuite/tests/ghci/prog-mhu006/unitA ===================================== @@ -0,0 +1,9 @@ +-i +-ia/ +A +-this-unit-id a-0.0.0 +-this-package-name a +-global-package-db +-package base +-package-id b-0.0.0 +-package containers ===================================== testsuite/tests/ghci/prog-mhu006/unitB ===================================== @@ -0,0 +1,8 @@ +-i +-ib/ +B +-this-unit-id b-0.0.0 +-this-package-name b +-global-package-db +-package base +-package bytestring ===================================== testsuite/tests/ghci/prog025/Makefile ===================================== @@ -0,0 +1,54 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +PKGCONF01=local01.package.conf +LOCAL_GHC_PKG01 = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF01) + +# When the user package databases are cleared, the GHCi prompt still needs to be able to find +# modules from home unit dependencies. +# Moreover, it needs to find the correct dependency unit, not just any. +.PHONY: prog025a +prog025a: + cd testpkg && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-0.1.0.0 -this-unit-id testpkg-0.1.0.0-XXX \ + -i. Test + cd testpkg && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-0.2.0.0 -this-unit-id testpkg-0.2.0.0-XXX \ + -i. Test + + $(LOCAL_GHC_PKG01) init $(PKGCONF01) 2>/dev/null + $(LOCAL_GHC_PKG01) register --force testpkg/testpkg-0.1.0.0.pkg 2>/dev/null + $(LOCAL_GHC_PKG01) register --force testpkg/testpkg-0.2.0.0.pkg 2>/dev/null + $(LOCAL_GHC_PKG01) hide testpkg-0.1.0.0 + $(LOCAL_GHC_PKG01) hide testpkg-0.2.0.0 + $(LOCAL_GHC_PKG01) list + + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db -fno-code -unit @unitA < prog025a.script + +# Same as prog025a, but the home unit arguments are not provided using a response file +.PHONY: prog025b +prog025b: + cd testpkg && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-0.1.0.0 -this-unit-id testpkg-0.1.0.0-XXX \ + -i. Test + cd testpkg && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-0.2.0.0 -this-unit-id testpkg-0.2.0.0-XXX \ + -i. Test + + $(LOCAL_GHC_PKG01) init $(PKGCONF01) 2>/dev/null + $(LOCAL_GHC_PKG01) register --force testpkg/testpkg-0.1.0.0.pkg 2>/dev/null + $(LOCAL_GHC_PKG01) register --force testpkg/testpkg-0.2.0.0.pkg 2>/dev/null + $(LOCAL_GHC_PKG01) hide testpkg-0.1.0.0 + $(LOCAL_GHC_PKG01) hide testpkg-0.2.0.0 + $(LOCAL_GHC_PKG01) list + + # Uses response file for argument, doesn't use it as a -unit argument + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db -fno-code \ + @unitA < prog025b.script ===================================== testsuite/tests/ghci/prog025/a/A.hs ===================================== @@ -0,0 +1,3 @@ +module A where + +import Test ===================================== testsuite/tests/ghci/prog025/all.T ===================================== @@ -0,0 +1,14 @@ + +proj_files = extra_files(['a/', 'unitA', 'testpkg/']) + +test('prog025a', + [proj_files, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + makefile_test, ['prog025a']) + +test('prog025b', + [proj_files, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + makefile_test, ['prog025b']) ===================================== testsuite/tests/ghci/prog025/prog025a.script ===================================== @@ -0,0 +1,2 @@ +:m + Test +"Imported package dependency module with multiple installed versions" ===================================== testsuite/tests/ghci/prog025/prog025a.stdout ===================================== @@ -0,0 +1,7 @@ +Reading package info from "testpkg/testpkg-0.1.0.0.pkg" ... done. +Reading package info from "testpkg/testpkg-0.2.0.0.pkg" ... done. +local01.package.conf + (testpkg-0.1.0.0) + (testpkg-0.2.0.0) + +"Imported package dependency module with multiple installed versions" ===================================== testsuite/tests/ghci/prog025/prog025b.script ===================================== @@ -0,0 +1,2 @@ +:m + Test +"Imported package dependency module with multiple installed versions" ===================================== testsuite/tests/ghci/prog025/prog025b.stdout ===================================== @@ -0,0 +1,7 @@ +Reading package info from "testpkg/testpkg-0.1.0.0.pkg" ... done. +Reading package info from "testpkg/testpkg-0.2.0.0.pkg" ... done. +local01.package.conf + (testpkg-0.1.0.0) + (testpkg-0.2.0.0) + +"Imported package dependency module with multiple installed versions" ===================================== testsuite/tests/ghci/prog025/testpkg/Test.hs ===================================== @@ -0,0 +1 @@ +module Test where ===================================== testsuite/tests/ghci/prog025/testpkg/testpkg-0.1.0.0.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg +version: 0.1.0.0 +id: testpkg-0.1.0.0-XXX +key: testpkg-0.1.0.0-XXX +exposed: True +exposed-modules: Test +hidden-modules: +import-dirs: ${pkgroot}/dist-testpkg-0.1.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog025/testpkg/testpkg-0.2.0.0.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg +version: 0.2.0.0 +id: testpkg-0.2.0.0-XXX +key: testpkg-0.2.0.0-XXX +exposed: True +exposed-modules: Test +hidden-modules: +import-dirs: ${pkgroot}/testpkg/dist-testpkg-0.2.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog025/unitA ===================================== @@ -0,0 +1,11 @@ +-i +-ia/ +A +-this-unit-id a-0.0.0 +-this-package-name a +-clear-package-db +-global-package-db +-no-user-package-db +-package-db local01.package.conf +-package base +-package-id testpkg-0.2.0.0-XXX View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77d6c0a687bf3cf71efaa24d796f1865... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/77d6c0a687bf3cf71efaa24d796f1865... You're receiving this email because of your account on gitlab.haskell.org.