Hannes Siebenhandl pushed to branch wip/fendor/26300 at Glasgow Haskell Compiler / GHC Commits: 8fe49ece by fendor at 2026-08-03T12:39:30+02:00 Check external dependencies and home units for duplicates - - - - - 16 changed files: - compiler/GHC/Iface/Errors/Ppr.hs - compiler/GHC/Iface/Errors/Types.hs - compiler/GHC/Unit/Finder.hs - compiler/GHC/Unit/Finder/Types.hs - + testsuite/tests/ghci/T26300/Makefile - + testsuite/tests/ghci/T26300/T26300.script - + testsuite/tests/ghci/T26300/T26300.stderr - + testsuite/tests/ghci/T26300/T26300.stdout - + testsuite/tests/ghci/T26300/a/Main.hs - + testsuite/tests/ghci/T26300/all.T - + testsuite/tests/ghci/T26300/b/Bar.hs - + testsuite/tests/ghci/T26300/b/Data/List.hs - + testsuite/tests/ghci/T26300/c/Bar.hs - + testsuite/tests/ghci/T26300/unitA - + testsuite/tests/ghci/T26300/unitB - + testsuite/tests/ghci/T26300/unitC Changes: ===================================== compiler/GHC/Iface/Errors/Ppr.hs ===================================== @@ -240,7 +240,9 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst -> vcat (map pprMod mods) where unambiguousPackages = foldl' unambiguousPackage (Just []) mods - unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + unambiguousPackage (Just xs) (m, ExternalUnitOrigin (ModOrigin (Just _) _ _ _)) + = Just (moduleUnit m : xs) + unambiguousPackage (Just xs) (m, HomeOrigin{}) = Just (moduleUnit m : xs) unambiguousPackage _ _ = Nothing GenericMissing pkg_hiddens mod_hiddens unusables files -> @@ -251,9 +253,16 @@ cantFindErrorX pkg_hidden_hint may_show_locations mod_or_interface (CantFindInst where pprMod (m, o) = text "it is bound as" <+> ppr m <+> text "by" <+> pprOrigin m o - pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" - pprOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" - pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + + pprOrigin m HomeOrigin = pprHomeOrigin m + pprOrigin m (ExternalUnitOrigin o) = pprExtOrigin m o + + pprHomeOrigin m = + text "package" <+> ppr (moduleUnit m) + + pprExtOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprExtOrigin _ (ModUnusable _) = panic "cantFindErr: bound by mod unusable" + pprExtOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( if e == Just True then [text "package" <+> ppr (moduleUnit m)] else [] ++ ===================================== compiler/GHC/Iface/Errors/Types.hs ===================================== @@ -6,6 +6,7 @@ module GHC.Iface.Errors.Types ( , ReadInterfaceError(..) , CantFindInstalled(..) , CantFindInstalledReason(..) + , HomeOrExternalOrigin(..) , FindingModuleOrInterface(..) , BuildingCabalPackage(..) @@ -75,9 +76,13 @@ data CantFindInstalledReason | GenericMissing [UnitInfo] [Unit] [UnusableUnit] [FilePath] - | MultiplePackages [(Module, ModuleOrigin)] + | MultiplePackages [(Module, HomeOrExternalOrigin)] deriving Generic +data HomeOrExternalOrigin + = HomeOrigin + | ExternalUnitOrigin ModuleOrigin + data CantFindInstalled = CantFindInstalled ModuleName CantFindInstalledReason deriving Generic ===================================== compiler/GHC/Unit/Finder.hs ===================================== @@ -78,10 +78,11 @@ import GHC.Types.Unique.Set import qualified Data.List as L(sort) import Data.List.NonEmpty ( NonEmpty (..) ) import Data.Set (Set) -import qualified Data.Set as Set (empty, intersection, difference, null, toList) +import qualified Data.Set as Set (empty, intersection, difference, null, toList, member) import qualified System.Directory as SD import qualified System.OsPath as OsPath import qualified Data.List.NonEmpty as NE +import GHC.Iface.Errors.Types type FileExt = OsString -- Filename extension type BaseName = OsPath -- Basename of file @@ -247,8 +248,12 @@ findImportedModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit ue_findHomeUnitEnv home_unit_id ue other_fopts :: [(UnitId, FinderOpts)] - other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map + other_fopts = + let + (providers, others) = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name + in + providers ++ others -- | Locate a plugin module requested by the user, for a compiler -- plugin. This consults the same set of exposed packages as @@ -263,11 +268,17 @@ findPluginModuleNoHsc -> ModuleName -> IO FindResult findPluginModuleNoHsc fc fopts ue home_module_name_providers_map mb_home_unit@(Just home_unit) mod_name = - findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit mod_name + home_import `orIfNotFound` - findExposedPluginPackageModule fc fopts unit_state mod_name + (findHomeModuleAmongDeps fc ue home_module_name_providers_map + mb_home_unit mod_name + `combineFindResult` + findExposedPluginPackageModule fc fopts unit_state mod_name + ) where + home_import = + findHomeModule fc fopts home_unit mod_name + unit_state = HUG.homeUnitEnv_units $ ue_findHomeUnitEnv (homeUnitId home_unit) ue findPluginModuleNoHsc fc fopts ue _ Nothing mod_name = @@ -291,9 +302,9 @@ findPluginModule hsc_env mod_name = do rankedHomeUnitDeps :: HomeModuleNameProvidersMap -> ModuleName -> Set UnitId - -> [UnitId] + -> ([UnitId], [UnitId]) rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps - = [] + = ([], []) -- The special handling of the situation where the dependency set is empty does -- not change the result, but it avoids triggering evaluation of the module -- graph. This is particularly important in one-shot mode, where the module @@ -309,7 +320,7 @@ rankedHomeUnitDeps _ _ home_unit_deps | Set.null home_unit_deps -- 3 | import {-# source #-} A -- | ^^^^^^^^^^^^^^^^^^^^^^^ rankedHomeUnitDeps home_module_name_providers_map mod_name home_unit_deps - = Set.toList cached_deps ++ Set.toList uncached_deps + = (Set.toList cached_deps, Set.toList uncached_deps) where cached_providers :: Set UnitId @@ -330,12 +341,19 @@ homeUnitDepsFinderOpts -> HomeModuleNameProvidersMap -> UnitState -- ^ unit state of the requesting home unit -> ModuleName - -> [(UnitId, FinderOpts)] + -> ([(UnitId, FinderOpts)], [(UnitId, FinderOpts)]) homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name = - [ (uid, initFinderOpts (ue_unitFlags uid ue)) - | uid <- rankedHomeUnitDeps home_module_name_providers_map mod_name + let + (providers, otherHomeUnits) = rankedHomeUnitDeps home_module_name_providers_map mod_name (homeUnitDepends unit_state) - ] + in + ( [ (uid, initFinderOpts (ue_unitFlags uid ue)) + | uid <- providers + ] + , [ (uid, initFinderOpts (ue_unitFlags uid ue)) + | uid <- otherHomeUnits + ] + ) -- | Search for @mod_name@ in the given home unit. findHomeUnitDepModule @@ -364,30 +382,29 @@ findHomeUnitDepModule fc ue home_module_name_providers_map mod_name (uid, opts) -- successful result. findHomeModuleAmongDeps :: FinderCache - -> FinderOpts -> UnitEnv -> HomeModuleNameProvidersMap -> Maybe HomeUnit -> ModuleName -> IO FindResult -findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit mod_name = - foldr1 orIfNotFound (home_import :| map home_pkg_import other_fopts) - -- Do not try to be smart and change this to `foldr orIfNotFound home_import - -- (map home_pkg_import other_fopts)`, as that would not be the same. - -- `home_import` is first because we need to first look within the current - -- unit before looking at the other units in order. +findHomeModuleAmongDeps fc ue home_module_name_providers_map mb_home_unit mod_name = + findInDirectDeps `orIfNotFound` findInOtherDeps where - home_import = case mb_home_unit of - Just home_unit -> findHomeModule fc fopts home_unit mod_name - Nothing -> pure $ - NoPackage (panic "findHomeModuleAmongDeps: no home-unit") + findInDirectDeps = case provider_fopts of + p:ps -> foldr1 combineFindResult (home_pkg_import p :| map home_pkg_import ps) + [] -> pure notFound + + findInOtherDeps = case other_fopts of + p:ps -> foldr1 orIfNotFound (home_pkg_import p :| map home_pkg_import ps) + [] -> pure notFound + home_pkg_import = findHomeUnitDepModule fc ue home_module_name_providers_map mod_name unit_state = case homeUnitId <$> mb_home_unit of Nothing -> ue_homeUnitState ue Just home_unit_id -> HUG.homeUnitEnv_units $ ue_findHomeUnitEnv home_unit_id ue - other_fopts = homeUnitDepsFinderOpts ue home_module_name_providers_map + (provider_fopts, other_fopts) = homeUnitDepsFinderOpts ue home_module_name_providers_map unit_state mod_name -- | Search the home-unit graph and otherwise the regular exposed package @@ -401,10 +418,17 @@ findHomeOrRegularPackageModule -> ModuleName -> IO FindResult findHomeOrRegularPackageModule fc fopts ue home_module_name_providers_map mb_home_unit mod_name = - findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map - mb_home_unit mod_name - `orIfNotFound` - findExposedPackageModule fc fopts unit_state mod_name NoPkgQual + case mb_home_unit of + Just home_unit -> + findHomeModule fc fopts home_unit mod_name + `orIfNotFound` + (findHomeModuleAmongDeps fc ue home_module_name_providers_map + mb_home_unit mod_name + `combineFindResult` + findExposedPackageModule fc fopts unit_state mod_name NoPkgQual + ) + Nothing -> + findExposedPackageModule fc fopts unit_state mod_name NoPkgQual where unit_state = case homeUnitId <$> mb_home_unit of Nothing -> ue_homeUnitState ue @@ -470,6 +494,40 @@ orIfNotFound this or_this = do _other -> return res2 _other -> return res +combineFindResult :: Monad m => m FindResult -> m FindResult -> m FindResult +combineFindResult this or_this = do + res <- this + case res of + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_unusables = u1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_unusables = u2 + , fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_unusables = u1 ++ u2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 + NoPackage{} -> pure res + FoundMultiple ms -> do + otherRes <- or_this + case otherRes of + Found _ other_mod -> pure $ FoundMultiple $ ms ++ [(other_mod, HomeOrigin)] + NoPackage{} -> pure res + FoundMultiple other_ms -> pure $ FoundMultiple $ ms ++ other_ms + NotFound{} -> pure res + Found _mod_location modl -> do + otherRes <- or_this + case otherRes of + Found _ other_mod -> pure $ FoundMultiple $ [(modl, HomeOrigin), (other_mod, HomeOrigin)] + NoPackage{} -> pure res + FoundMultiple other_ms -> pure $ FoundMultiple $ [(modl, HomeOrigin)] ++ other_ms + NotFound{} -> pure res + -- | Helper function for 'findHomeModule': this function wraps an IO action -- which would look up @mod_name@ in the file system (the home package), -- and first consults the 'hsc_FC' cache to see if the lookup has already @@ -483,8 +541,12 @@ homeSearchCache fc home_unit mod_name do_this = do findExposedPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> PkgQual -> IO FindResult findExposedPackageModule fc fopts units mod_name mb_pkg = - findLookupResult fc fopts - $ lookupModuleWithSuggestions units mod_name mb_pkg + findLookupResult fc fopts $ + case lookupModuleWithSuggestions units mod_name mb_pkg of + lf@(LookupFound _ (u, _)) + | unitId u `Set.member` homeUnitDepends units -> LookupNotFound [] + | otherwise -> lf + other -> other findExposedPluginPackageModule :: FinderCache -> FinderOpts -> UnitState -> ModuleName -> IO FindResult findExposedPluginPackageModule fc fopts units mod_name = @@ -509,7 +571,7 @@ findLookupResult fc fopts r = case r of , fr_unusables = [] , fr_suggestions = []}) LookupMultiple rs -> - return (FoundMultiple rs) + return (FoundMultiple $ map (\ (m, o) -> (m, ExternalUnitOrigin o)) rs) LookupHidden fr_pkgs_hidden mod_hiddens -> return (NotFound{ fr_paths = [], fr_pkg = Nothing , fr_pkgs_hidden @@ -588,6 +650,16 @@ mkHomeHidden uid = , fr_unusables = [] , fr_suggestions = []} +notFound :: FindResult +notFound = + NotFound { fr_paths = [] + , fr_pkg = Nothing + , fr_mods_hidden = [] + , fr_pkgs_hidden = [] + , fr_unusables = [] + , fr_suggestions = []} + + findHomePackageModule :: FinderCache -> FinderOpts -> UnitId -> ModuleName -> IO FindResult findHomePackageModule fc fopts home_unit mod_name = do let uid = RealUnit (Definite home_unit) ===================================== compiler/GHC/Unit/Finder/Types.hs ===================================== @@ -19,6 +19,7 @@ import GHC.Unit.Env import GHC.Data.FastString import GHC.Types.Unique.Set +import GHC.Iface.Errors.Types (HomeOrExternalOrigin) -- | The 'FinderCache' maps modules to the result of -- searching for that module. It records the results of searching for @@ -56,7 +57,7 @@ data FindResult -- ^ The module was found | NoPackage Unit -- ^ The requested unit was not found - | FoundMultiple [(Module, ModuleOrigin)] + | FoundMultiple [(Module, HomeOrExternalOrigin)] -- ^ _Error_: both in multiple packages -- | Not found ===================================== testsuite/tests/ghci/T26300/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/T26300/T26300.script ===================================== @@ -0,0 +1,3 @@ +"Report two ambiguous imports." +"The Data.List import is ambiguous with the `base` module." +"Bar module is defined in two home units, as such needs to be reported as ambiguous." ===================================== testsuite/tests/ghci/T26300/T26300.stderr ===================================== @@ -0,0 +1,8 @@ +a/Main.hs:3:1: error: [GHC-45102] + Ambiguous module name ‘Data.List’. + it was found in multiple packages: base-4.23.0.0 b-0.0.1 + +a/Main.hs:4:1: error: [GHC-45102] + Ambiguous module name ‘Bar’. + it was found in multiple packages: c-0.0.1 b-0.0.1 + ===================================== testsuite/tests/ghci/T26300/T26300.stdout ===================================== @@ -0,0 +1,3 @@ +"Report two ambiguous imports." +"The Data.List import is ambiguous with the `base` module." +"Bar module is defined in two home units, as such needs to be reported as ambiguous." ===================================== testsuite/tests/ghci/T26300/a/Main.hs ===================================== @@ -0,0 +1,4 @@ +module Main where + +import Data.List +import Bar ===================================== testsuite/tests/ghci/T26300/all.T ===================================== @@ -0,0 +1,6 @@ +test('T26300', + [extra_files(['a/', 'b/', 'c/', 'unitA', 'unitB', 'unitC']), + cmd_prefix('ghciWayFlags=' + config.ghci_way_flags), + normalise_slashes, + req_interp], + ghci_multiunit_script, [['unitA', 'unitB', 'unitC'], 'T26300.script']) ===================================== testsuite/tests/ghci/T26300/b/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/T26300/b/Data/List.hs ===================================== @@ -0,0 +1 @@ +module Data.List where ===================================== testsuite/tests/ghci/T26300/c/Bar.hs ===================================== @@ -0,0 +1 @@ +module Bar where ===================================== testsuite/tests/ghci/T26300/unitA ===================================== @@ -0,0 +1,6 @@ +-i +-ia +-this-unit-id a-0.0.1 +-package-id b-0.0.1 +-package-id c-0.0.1 +Main ===================================== testsuite/tests/ghci/T26300/unitB ===================================== @@ -0,0 +1,5 @@ +-i +-ib +-this-unit-id b-0.0.1 +Data.List +Bar ===================================== testsuite/tests/ghci/T26300/unitC ===================================== @@ -0,0 +1,4 @@ +-i +-ic +-this-unit-id c-0.0.1 +Bar View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fe49ecefdeb2caccc32a7fafe5add46... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8fe49ecefdeb2caccc32a7fafe5add46... 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