GitLab

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

  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

 +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

+module A where

testsuite/tests/ghci/prog-mhu006/all.T

++
 +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

+module B where

testsuite/tests/ghci/prog-mhu006/prog-mhu006a.script

 +"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

	1	+"Can import modules from dependencies"
	2	+"Imported Data.ByteString and Data.Text"

testsuite/tests/ghci/prog-mhu006/unitA

 +-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

 +-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

 +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

 +module A where
++
 +import Test

testsuite/tests/ghci/prog025/all.T

++
 +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

	1	+:m + Test
	2	+"Imported package dependency module with multiple installed versions"

testsuite/tests/ghci/prog025/prog025a.stdout

 +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

	1	+:m + Test
	2	+"Imported package dependency module with multiple installed versions"

testsuite/tests/ghci/prog025/prog025b.stdout

 +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

+module Test where

testsuite/tests/ghci/prog025/testpkg/testpkg-0.1.0.0.pkg

 +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

 +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

 +-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