Hannes Siebenhandl pushed to branch wip/fendor/ghc-ghci-mhu-27640 at Glasgow Haskell Compiler / GHC Commits: d71f262c by fendor at 2026-08-25T21:10:26+02:00 GHCi: Fix order of `PackageDBFlag`s for interactive home unit `PackageDBFlag`s are stored in reverse order of cli specification. When sorting the `PackageDBFlag`s by longest common prefix, we need thus to reverse the package db stacks before calculating the prefix. We make sure to reverse the package db stack for the interactive home unit to uphold that later specified package dbs overwrite earlier ones. Resolved and adds regression test for #27640 - - - - - 13 changed files: - ghc/GHCi/UI.hs - + testsuite/tests/ghci/prog-mhu007/Makefile - + testsuite/tests/ghci/prog-mhu007/a/A.hs - + testsuite/tests/ghci/prog-mhu007/all.T - + testsuite/tests/ghci/prog-mhu007/b/B.hs - + testsuite/tests/ghci/prog-mhu007/prog-mhu007.script - + testsuite/tests/ghci/prog-mhu007/prog-mhu007.stdout - + testsuite/tests/ghci/prog-mhu007/testpkg-bar/Bar.hs - + testsuite/tests/ghci/prog-mhu007/testpkg-bar/testpkg-bar.pkg - + testsuite/tests/ghci/prog-mhu007/testpkg-foo/Foo.hs - + testsuite/tests/ghci/prog-mhu007/testpkg-foo/testpkg-foo.pkg - + testsuite/tests/ghci/prog-mhu007/unitA - + testsuite/tests/ghci/prog-mhu007/unitB Changes: ===================================== ghc/GHCi/UI.hs ===================================== @@ -148,6 +148,7 @@ import Data.Version ( showVersion ) import qualified Data.Semigroup as S import GHC.Prelude +import GHC.Utils.Trace import GHC.Utils.Exception as Exception hiding (catch, mask, handle) import Foreign hiding (void) import GHC.Stack hiding (SrcLoc(..)) @@ -864,8 +865,14 @@ installInteractiveHomeUnits dflags = do pure (HUG.mkHomeUnitEnv unit_state dflags hpt (Just home_unit)) concatPackageDbStacksUsingLongestCommonPrefix :: [[PackageDBFlag]] -> [PackageDBFlag] - concatPackageDbStacksUsingLongestCommonPrefix stacks = + concatPackageDbStacksUsingLongestCommonPrefix stacks' = let + -- Package DB stacks are accumulated from the cli right to left. + -- E.g., @-clear-package-db -global-package-db@ is stored as + -- @[GlobalPackageDb, ClearPackageDb]@. + -- Hence, we reverse the stacks, before computing the longest common prefix, + -- otherwise the prefix won't match at all. + stacks = map List.reverse stacks' -- O (m * n) -- m ... Number of PackageDBFlag stacks -- n ... Size of the stacks @@ -873,8 +880,22 @@ installInteractiveHomeUnits dflags = do map List.head . List.takeWhile ((List.all . (==) . List.head) <*> List.tail) . List.transpose prefix = longestCommonPrefix stacks + + -- We reverse each individual stack segment to maintain the relative order. + -- There should be no 'ClearPackageDb' in here, otherwise we are going to overwrite + -- the longest common prefix stacks. + unmergableStack = + nubOrd (concatMap (List.reverse . List.drop (length prefix)) stacks) in - prefix ++ nubOrd (concatMap (List.drop (length prefix)) stacks) + -- We reverse the final common package db stack again to match the expectation of 'packageDBFlags' that they are + -- stord in reverse order. + unmergableStack ++ reverse prefix + +-- [[d, b, a], [c, b, a]] +-- [[a, b, d], [a, b, c]] +-- [a, b], [[d], [c]] +-- [d, c,] +-- [d, c, b, a] reportError :: GhciMonad m => GhciCommandMessage -> m () reportError err = do ===================================== testsuite/tests/ghci/prog-mhu007/Makefile ===================================== @@ -0,0 +1,33 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +PKGCONF_FOO=local-foo.package.conf +PKGCONF_BAR=local-bar.package.conf +LOCAL_GHC_PKG_FOO = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_FOO) +LOCAL_GHC_PKG_BAR = '$(GHC_PKG)' --no-user-package-db -f $(PKGCONF_BAR) + +# Finds both packages in different unit databases +.PHONY: prog-mhu007 +prog-mhu007: + cd testpkg-foo && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-foo-0.1.0.0 -this-unit-id testpkg-foo-0.1.0.0-XXX \ + -i. Foo + cd testpkg-bar && \ + '$(TEST_HC)' $(TEST_HC_OPTS) $(WAY_FLAGS) -hisuf=$(ghciWayExt) $(ghciWayFlags) \ + -v0 -fno-code -fwrite-interface -hidir dist-testpkg-bar-0.1.0.0 -this-unit-id testpkg-bar-0.1.0.0-XXX \ + -i. Bar + + $(LOCAL_GHC_PKG_FOO) init $(PKGCONF_FOO) 2>/dev/null + $(LOCAL_GHC_PKG_FOO) register --force testpkg-foo/testpkg-foo.pkg 2>/dev/null + $(LOCAL_GHC_PKG_FOO) hide testpkg-foo + $(LOCAL_GHC_PKG_FOO) list + + $(LOCAL_GHC_PKG_BAR) init $(PKGCONF_BAR) 2>/dev/null + $(LOCAL_GHC_PKG_BAR) register --force testpkg-bar/testpkg-bar.pkg 2>/dev/null + $(LOCAL_GHC_PKG_BAR) hide testpkg-bar + $(LOCAL_GHC_PKG_BAR) list + + '$(TEST_HC)' $(TEST_HC_OPTS_INTERACTIVE) $(WAY_FLAGS) $(ghciWayFlags) \ + -no-user-package-db -fno-code -unit @unitA -unit @unitB < prog-mhu007.script ===================================== testsuite/tests/ghci/prog-mhu007/a/A.hs ===================================== @@ -0,0 +1,3 @@ +module A where + +import Bar ===================================== testsuite/tests/ghci/prog-mhu007/all.T ===================================== @@ -0,0 +1,8 @@ + +proj_files = extra_files(['a/', 'b/', 'unitA', 'unitB', 'testpkg-bar/', 'testpkg-foo/']) + +test('prog-mhu007', + [proj_files, + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + req_interp], + makefile_test, ['prog-mhu007']) ===================================== testsuite/tests/ghci/prog-mhu007/b/B.hs ===================================== @@ -0,0 +1,3 @@ +module B where + +import Foo ===================================== testsuite/tests/ghci/prog-mhu007/prog-mhu007.script ===================================== @@ -0,0 +1,5 @@ +:m + A B +"Loaded A and B" +import Foo +import Bar +"Loaded dependencies Foo and Bar" ===================================== testsuite/tests/ghci/prog-mhu007/prog-mhu007.stdout ===================================== @@ -0,0 +1,10 @@ +Reading package info from "testpkg-foo/testpkg-foo.pkg" ... done. +local-foo.package.conf + (testpkg-foo-0.1.0.0) + +Reading package info from "testpkg-bar/testpkg-bar.pkg" ... done. +local-bar.package.conf + (testpkg-bar-0.1.0.0) + +"Loaded A and B" +"Loaded dependencies Foo and Bar" ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-bar/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-bar/testpkg-bar.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg-bar +version: 0.1.0.0 +id: testpkg-bar-0.1.0.0-XXX +key: testpkg-bar-0.1.0.0-XXX +exposed: True +exposed-modules: Bar +hidden-modules: +import-dirs: ${pkgroot}/testpkg-bar/dist-testpkg-bar-0.1.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-foo/Foo.hs ===================================== @@ -0,0 +1 @@ +module Foo where ===================================== testsuite/tests/ghci/prog-mhu007/testpkg-foo/testpkg-foo.pkg ===================================== @@ -0,0 +1,11 @@ +name: testpkg-foo +version: 0.1.0.0 +id: testpkg-foo-0.1.0.0-XXX +key: testpkg-foo-0.1.0.0-XXX +exposed: True +exposed-modules: Foo +hidden-modules: +import-dirs: ${pkgroot}/testpkg-foo/dist-testpkg-foo-0.1.0.0 +library-dirs: +include-dirs: +hs-libraries: ===================================== testsuite/tests/ghci/prog-mhu007/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 local-bar.package.conf +-package base +-package-id testpkg-bar-0.1.0.0-XXX ===================================== testsuite/tests/ghci/prog-mhu007/unitB ===================================== @@ -0,0 +1,11 @@ +-i +-ib/ +B +-this-unit-id b-0.0.0 +-this-package-name b +-clear-package-db +-global-package-db +-no-user-package-db +-package-db local-foo.package.conf +-package base +-package-id testpkg-foo-0.1.0.0-XXX View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d71f262c340c6847159de00895a06c28... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d71f262c340c6847159de00895a06c28... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help