Hannes Siebenhandl pushed to branch wip/fendor/26300 at Glasgow Haskell Compiler / GHC Commits: d8aa9526 by fendor at 2026-07-28T13:12:16+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 ===================================== @@ -82,6 +82,7 @@ import qualified Data.Set as Set (empty, intersection, difference, null, toList) 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 @@ -265,7 +270,7 @@ findPluginModuleNoHsc 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 - `orIfNotFound` + `combineFindResult` findExposedPluginPackageModule fc fopts unit_state mod_name where unit_state = HUG.homeUnitEnv_units $ @@ -291,9 +296,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 +314,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 +335,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 @@ -371,11 +383,25 @@ findHomeModuleAmongDeps -> 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. + case other_fopts of + [] -> + foldr1 combineFindResult (home_import :| map home_pkg_import provider_fopts) + -- Do not try to be smart and change this to `foldr combineFindResult 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. + (x:xs) -> + foldr1 combineFindResult (home_import :| map home_pkg_import provider_fopts) + -- Do not try to be smart and change this to `foldr combineFindResult 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. + `orIfNotFound` + foldr1 orIfNotFound (home_pkg_import x :| map home_pkg_import xs) + -- 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. where home_import = case mb_home_unit of Just home_unit -> findHomeModule fc fopts home_unit mod_name @@ -387,7 +413,7 @@ findHomeModuleAmongDeps fc fopts ue home_module_name_providers_map mb_home_unit 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 @@ -403,7 +429,7 @@ findHomeOrRegularPackageModule 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` + `combineFindResult` findExposedPackageModule fc fopts unit_state mod_name NoPkgQual where unit_state = case homeUnitId <$> mb_home_unit of @@ -470,6 +496,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 @@ -509,7 +569,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 ===================================== 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/d8aa95262333abb8485c31bf8aed2da2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d8aa95262333abb8485c31bf8aed2da2... 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