From 00b8f8c5b378fc679639ebe81238cf42d92aa607 Mon Sep 17 00:00:00 2001 From: "Edward Z. Yang" Date: Fri, 1 Aug 2014 18:03:20 +0100 Subject: Refactor package state, also fixing a module reexport bug. Instead of building a multiply indirected data structure and querying it on every import, we now have two data structures moduleToPkgConf and moduleToPkgConfAll. moduleToPkgConf is a single-level UniqFM that is intended to be used for most valid imports; however, it does not contain any information useful for error reporting. If an error is occurred, we then query moduleToPkgConfAll, which contains a more comprehensive view of the package database. This field is lazily initialized (so this means we're retaining the package database list, but this should be fine because we're already maintaining the entries of the list.) Additionally, the full view doesn't keep track of a boolean toggle for visibility/exposure anymore, but instead tracks the *provenance* of how the module binding came to be (the ModuleOrigin data type). Additionally, we move the logic for determining if a module is exposed or not from Finder.lhs and put it in Packages.lhs; this information is communicated via the LookupResult data type. Unfortunately, we can't directly return a FindResult, because this data type is defined in HscTypes which depends on Packages. This is going to change some more in the near future when I add thinning/renaming to package flags; the error messages will need to be more flexible. I've also slightly changed the semantics of error messages for package qualified imports. Previously, if we didn't find any package qualified imports, but there were hidden modules in a *different* package, the error message would prefer mentioning those as opposed to providing suggestions. Now, if a module is hidden but in the wrong package, we won't mention it; instead, it will get mentioned with the other module suggestions. I was too lazy to write a test, but I can add one if people would like. The module reexport bug was, package q reexported p:P as Conflict, and package r reexported p:P2 as Conflict, this was *not* reported as a conflict, because the old logic incorrectly decided that P and P2 were the same module on account of being from the same package. The logic here has been corrected. Contains haddock submodule update. Signed-off-by: Edward Z. Yang --- compiler/main/Finder.lhs | 58 +++------ compiler/main/HscTypes.lhs | 5 +- compiler/main/Packages.lhs | 301 +++++++++++++++++++++++++++++---------------- 3 files changed, 211 insertions(+), 153 deletions(-) (limited to 'compiler') diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index ec7dc53ba5..11d5b6f96d 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -43,7 +43,6 @@ import Maybes ( expectJust ) import Exception ( evaluate ) import Distribution.Text -import Distribution.Package hiding (PackageKey, mkPackageKey) import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import System.Directory import System.FilePath @@ -190,46 +189,21 @@ homeSearchCache hsc_env mod_name do_this = do findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult findExposedPackageModule hsc_env mod_name mb_pkg - -- not found in any package: - = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name of - Left suggest -> return (NotFound { fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_suggestions = suggest }) - Right found' - | null found_visible -- Found, but with no exposed copies - -> return (NotFound { fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = pkg_hiddens - , fr_mods_hidden = mod_hiddens - , fr_suggestions = [] }) - - | [ModConf mod_name' pkg_conf _ _] <- found_visible -- Found uniquely - -> let pkgid = packageConfigId pkg_conf in - findPackageModule_ hsc_env (mkModule pkgid mod_name') pkg_conf - - | otherwise -- Found in more than one place - -> return (FoundMultiple (map (packageConfigId.modConfPkg) - found_visible)) - where - found = eltsUFM found' - for_this_pkg = case mb_pkg of - Nothing -> found - Just p -> filter ((`matches` p).modConfPkg) found - found_visible = filter modConfVisible for_this_pkg - - -- NB: _vis is guaranteed to be False; a non-exposed module - -- can never be visible. - mod_hiddens = [ packageConfigId pkg_conf - | ModConf _ pkg_conf False _vis <- found ] - - -- NB: We /re-report/ non-exposed modules of hidden packages. - pkg_hiddens = [ packageConfigId pkg_conf - | ModConf _ pkg_conf _ False <- found - , not (exposed pkg_conf) ] - - pkg_conf `matches` pkg - = case packageName pkg_conf of - PackageName n -> pkg == mkFastString n + = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name mb_pkg of + LookupFound m pkg_conf -> + findPackageModule_ hsc_env m pkg_conf + LookupMultiple rs -> + return (FoundMultiple (map (packageConfigId . snd) rs)) + LookupHidden pkg_hiddens mod_hiddens -> + return (NotFound { fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = map (packageConfigId.snd) pkg_hiddens + , fr_mods_hidden = map (packageConfigId.snd) mod_hiddens + , fr_suggestions = [] }) + LookupNotFound suggest -> + return (NotFound { fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [] + , fr_mods_hidden = [] + , fr_suggestions = suggest }) modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult modLocationCache hsc_env mod do_this = do @@ -555,7 +529,7 @@ cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult cantFindErr _ multiple_found _ mod_name (FoundMultiple pkgs) = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( sep [ptext (sLit "it was found in multiple packages:"), - hsep (map (text.packageKeyString) pkgs)] + hsep (map ppr pkgs)] ) cantFindErr cannot_find _ dflags mod_name find_result = ptext cannot_find <+> quotes (ppr mod_name) diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 35bab9fe9f..83f43d1da2 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -1471,15 +1471,14 @@ mkQualModule :: DynFlags -> QueryQualifyModule mkQualModule dflags mod | modulePackageKey mod == thisPackage dflags = False - | [pkgconfig] <- [modConfPkg m | m <- lookup - , modConfVisible m ], + | [(_, pkgconfig)] <- lookup, packageConfigId pkgconfig == modulePackageKey mod -- this says: we are given a module P:M, is there just one exposed package -- that exposes a module M, and is it package P? = False | otherwise = True - where lookup = eltsUFM $ lookupModuleInAllPackages dflags (moduleName mod) + where lookup = lookupModuleInAllPackages dflags (moduleName mod) -- | Creates a function for formatting packages based on two heuristics: -- (1) don't qualify if the package in question is "main", and (2) only qualify diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index f59fbc38e7..bbf8752a25 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -10,7 +10,6 @@ module Packages ( -- * Reading the package config, and processing cmdline args PackageState(preloadPackages), - ModuleConf(..), initPackages, -- * Querying the package config @@ -20,8 +19,10 @@ module Packages ( dumpPackages, simpleDumpPackages, getPackageDetails, - lookupModuleInAllPackages, lookupModuleWithSuggestions, listVisibleModuleNames, + lookupModuleInAllPackages, + lookupModuleWithSuggestions, + LookupResult(..), -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -123,62 +124,76 @@ import qualified Data.Set as Set -- When compiling A, we record in B's Module value whether it's -- in a different DLL, by setting the DLL flag. --- | The result of performing a lookup on moduleToPkgConfAll, this --- is one possible provider of a module. -data ModuleConf = ModConf { - -- | The original name of the module - modConfName :: ModuleName, - -- | The original package (config) of the module - modConfPkg :: PackageConfig, - -- | Does the original package expose this module to its clients? This - -- is cached result of whether or not the module name is in - -- exposed-modules or reexported-modules in the package config. While - -- this isn't actually how we want to figure out if a module is visible, - -- this is important for error messages. - modConfExposed :: Bool, - -- | Is the module visible to our current compilation? Interestingly, - -- this is not the same as if it was exposed: if the package is hidden - -- then exposed modules are not visible. However, if another exposed - -- package reexports the module in question, it's now visible! You - -- can't tell this just by looking at the original name, so we - -- record the calculation here. - modConfVisible :: Bool - } - --- | Map from 'PackageId' (used for documentation) -type PackageIdMap = UniqFM - --- | Map from 'ModuleName' to 'PackageId' to 'ModuleConf', see --- 'moduleToPkgConfAll' -type ModuleToPkgConfAll = UniqFM (ModuleName, PackageIdMap ModuleConf) +-- | Given a module name, there may be multiple ways it came into scope, +-- possibly simultaneously (which could lead to ambiguity.) +data ModuleOrigin = + -- | This module name was in the exposed-modules list of a package + FromExposedModules PackageConfig + -- | This module name was in the hidden-modules list of a package + | FromHiddenModules PackageConfig + -- | This module name was in the reexported-modules list of a package + | FromReexportedModules { + theReexporter :: PackageConfig, + theOriginal :: PackageConfig + } + -- FromFlagRenaming + +-- | Is the name from the import actually visible? (i.e. does it cause +-- ambiguity, or is it only relevant when we're making suggestions?) +originVisible :: ModuleOrigin -> Maybe PackageConfig +originVisible (FromHiddenModules _) = Nothing +originVisible (FromExposedModules pkg) + | exposed pkg = Just pkg + | otherwise = Nothing +originVisible (FromReexportedModules{ theReexporter = pkg }) + | exposed pkg = Just pkg + | otherwise = Nothing + +-- | When we do a plain lookup (e.g. for an import), initially, all we want +-- to know is if we can find it or not (and if we do and it's a reexport, +-- what the real name is). If the find fails, we'll want to investigate more +-- to give a good error message. +data SimpleModuleConf = + SModConf Module PackageConfig [ModuleOrigin] + | SModConfAmbiguous + +-- | Map from 'ModuleName' +type ModuleNameMap = UniqFM + +-- | Map from 'PackageKey' +type PackageKeyMap = UniqFM + +type PackageConfigMap = PackageKeyMap PackageConfig +type ModuleToPkgConfAll = Map ModuleName (Map Module [ModuleOrigin]) data PackageState = PackageState { - pkgIdMap :: PackageConfigMap, -- PackageKey -> PackageConfig - -- The exposed flags are adjusted according to -package and - -- -hide-package flags, and -ignore-package removes packages. - + -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted + -- so that only valid packages are here. Currently, we also flip the + -- exposed/trusted bits based on package flags; however, the hope is to + -- stop doing that. + pkgIdMap :: PackageConfigMap, + + -- | The packages we're going to link in eagerly. This list + -- should be in reverse dependency order; that is, a package + -- is always mentioned before the packages it depends on. preloadPackages :: [PackageKey], - -- The packages we're going to link in eagerly. This list - -- should be in reverse dependency order; that is, a package - -- is always mentioned before the packages it depends on. - - -- | ModuleEnv mapping, derived from 'pkgIdMap'. - -- Maps 'Module' to an original module which is providing the module name. - -- Since the module may be provided by multiple packages, this result - -- is further recorded in a map of the original package IDs to - -- module information. The 'modSummaryPkgConf' should agree with - -- this key. Generally, 'modSummaryName' will be the same as the - -- module key, unless there is renaming. + + -- | This is a simplified map from 'ModuleName' to original 'Module' and + -- package configuration providing it. + moduleToPkgConf :: ModuleNameMap SimpleModuleConf, + + -- | This is a full map from 'ModuleName' to all modules which may possibly + -- be providing it. These providers may be hidden (but we'll still want + -- to report them in error messages), or it may be an ambiguous import. moduleToPkgConfAll :: ModuleToPkgConfAll, + -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC + -- internally deals in package keys but the database may refer to installed + -- package IDs. installedPackageIdMap :: InstalledPackageIdMap } --- | A PackageConfigMap maps a 'PackageKey' to a 'PackageConfig' -type PackageConfigMap = UniqFM PackageConfig - type InstalledPackageIdMap = Map InstalledPackageId PackageKey - type InstalledPackageIndex = Map InstalledPackageId PackageConfig emptyPackageConfigMap :: PackageConfigMap @@ -896,57 +911,82 @@ mkPackageState dflags pkgs0 preload0 this_package = do dep_preload <- closeDeps dflags pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload - let pstate = PackageState{ preloadPackages = dep_preload, - pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleMap pkg_db ipid_map, - installedPackageIdMap = ipid_map - } + let pstate = PackageState{ + preloadPackages = dep_preload, + pkgIdMap = pkg_db, + moduleToPkgConf = mkModuleToPkgConf pkg_db ipid_map, + moduleToPkgConfAll = mkModuleToPkgConfAll pkg_db ipid_map, -- lazy! + installedPackageIdMap = ipid_map + } return (pstate, new_dep_preload, this_package) -- ----------------------------------------------------------------------------- --- | Makes the mapping from module to package info for 'moduleToPkgConfAll' +-- | Makes the mapping from module to package info -mkModuleMap +-- | Creates the minimal lookup, which is sufficient if we don't need to +-- report errors. +mkModuleToPkgConf :: PackageConfigMap -> InstalledPackageIdMap - -> ModuleToPkgConfAll -mkModuleMap pkg_db ipid_map = - foldr extend_modmap emptyUFM (eltsUFM pkg_db) + -> ModuleNameMap SimpleModuleConf +mkModuleToPkgConf pkg_db ipid_map = + foldl' extend_modmap emptyUFM (eltsUFM pkg_db) where - extend_modmap pkg modmap = addListToUFM_C merge0 modmap es - where -- Invariant: a == _a' - merge0 :: (ModuleName, PackageIdMap ModuleConf) - -> (ModuleName, PackageIdMap ModuleConf) - -> (ModuleName, PackageIdMap ModuleConf) - merge0 (a,b) (_a',b') = (a, plusUFM_C merge b b') - -- Invariant: m == m' && pkg == pkg' && e == e' - -- && (e || not (v || v')) - -- Some notes about the assert. Merging only ever occurs when - -- we find a reexport. The interesting condition: - -- e || not (v || v') - -- says that a non-exposed module cannot ever become visible. - -- However, an invisible (but exported) module may become - -- visible when it is reexported by a visible package, - -- which is why we merge visibility using logical OR. - merge a b = a { modConfVisible = - modConfVisible a || modConfVisible b } - es = [(m, (m, unitUFM pkgid (ModConf m pkg True (exposed pkg)))) + extend_modmap modmap pkg + | exposed pkg = addListToUFM_C merge modmap es + | otherwise = modmap + where merge (SModConf m pkg o) (SModConf m' _ o') + | m == m' = SModConf m pkg (o ++ o') + | otherwise = SModConfAmbiguous + merge _ _ = SModConfAmbiguous + es = [ (m, SModConf (mkModule pk m ) pkg [FromExposedModules pkg]) | m <- exposed_mods] ++ - [(m, (m, unitUFM pkgid (ModConf m pkg False False))) - | m <- hidden_mods] ++ - [(m, (m, unitUFM pkgid' (ModConf m' pkg' True (exposed pkg)))) + [ (m, SModConf (mkModule pk' m') pkg' [FromReexportedModules{ + theReexporter = pkg, + theOriginal = pkg' + }]) | ModuleExport{ exportName = m , exportCachedTrueOrig = Just (ipid', m')} <- reexported_mods - , Just pkgid' <- [Map.lookup ipid' ipid_map] - , let pkg' = pkg_lookup pkgid' ] - pkgid = packageConfigId pkg - pkg_lookup = expectJust "mkModuleMap" . lookupPackage' pkg_db + , Just pk' <- [Map.lookup ipid' ipid_map] + , let pkg' = pkg_lookup pk' ] + pk = packageConfigId pkg + pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db exposed_mods = exposedModules pkg reexported_mods = reexportedModules pkg - hidden_mods = hiddenModules pkg + +-- | Creates the full lookup, which contains all information we know about +-- modules. Calculate this lazily! (Note: this will get forced if you use +-- package imports. +mkModuleToPkgConfAll + :: PackageConfigMap + -> InstalledPackageIdMap + -> ModuleToPkgConfAll +mkModuleToPkgConfAll pkg_db ipid_map = + -- Uses a Map instead of a UniqFM so we don't have to also put + -- the keys in the values. + foldl' extend_modmap Map.empty (eltsUFM pkg_db) + where + extend_modmap m pkg = foldl' merge m es + where + merge m' (k, v) = Map.insertWith (Map.unionWith (++)) k v m' + sing = Map.singleton + es = + [(m, sing (mkModule pk m) [FromExposedModules pkg]) | m <- exposed_mods] ++ + [(m, sing (mkModule pk m) [FromHiddenModules pkg]) | m <- hidden_mods] ++ + [(m, sing (mkModule pk' m') [FromReexportedModules{ theReexporter = pkg + , theOriginal = pkg'}]) + | ModuleExport{ exportName = m + , exportCachedTrueOrig = Just (ipid', m')} <- reexported_mods + , let pk' = expectJust "mkModuleToPkgConfAll/i" (Map.lookup ipid' ipid_map) + pkg' = pkg_lookup pk' ] + pk = packageConfigId pkg + pkg_lookup = expectJust "mkModuleToPkgConfAll" . lookupPackage' pkg_db + exposed_mods = exposedModules pkg + reexported_mods = reexportedModules pkg + hidden_mods = hiddenModules pkg pprSPkg :: PackageConfig -> SDoc pprSPkg p = text (display (sourcePackageId p)) @@ -1052,43 +1092,88 @@ getPackageFrameworks dflags pkgs = do -- Package Utils -- | Takes a 'ModuleName', and if the module is in any package returns --- a map of package IDs to 'ModuleConf', describing where the module lives --- and whether or not it is exposed. +-- list of modules which take that name. lookupModuleInAllPackages :: DynFlags -> ModuleName - -> PackageIdMap ModuleConf + -> [(Module, PackageConfig)] lookupModuleInAllPackages dflags m - = case lookupModuleWithSuggestions dflags m of - Right pbs -> pbs - Left _ -> emptyUFM - -lookupModuleWithSuggestions - :: DynFlags -> ModuleName - -> Either [Module] (PackageIdMap ModuleConf) - -- Lookup module in all packages - -- Right pbs => found in pbs - -- Left ms => not found; but here are sugestions -lookupModuleWithSuggestions dflags m - = case lookupUFM (moduleToPkgConfAll pkg_state) m of - Nothing -> Left suggestions - Just (_, ps) -> Right ps + = case lookupModuleWithSuggestions dflags m Nothing of + LookupFound a b -> [(a,b)] + LookupMultiple rs -> rs + _ -> [] + +-- | The result of performing a lookup +data LookupResult = + -- | Found the module uniquely, nothing else to do + LookupFound Module PackageConfig + -- | Multiple modules with the same name in scope + | LookupMultiple [(Module, PackageConfig)] + -- | No modules found, but there were some hidden ones with + -- an exact name match. First is due to package hidden, second + -- is due to module being hidden + | LookupHidden [(Module, PackageConfig)] [(Module, PackageConfig)] + -- | Nothing found, here are some suggested different names + | LookupNotFound [Module] -- suggestions + +lookupModuleWithSuggestions :: DynFlags + -> ModuleName + -> Maybe FastString + -> LookupResult +lookupModuleWithSuggestions dflags m mb_pn + = case lookupUFM (moduleToPkgConf pkg_state) m of + Just (SModConf m pkg os) | any (matches mb_pn) os -> LookupFound m pkg + _ -> case Map.lookup m (moduleToPkgConfAll pkg_state) of + Nothing -> LookupNotFound suggestions + Just xs0 -> + let xs = filter (any (matches mb_pn)) (Map.elems xs0) + in case concatMap (selectVisible m) xs of + [] -> case [ (mkModule (packageConfigId pkg) m, pkg) + | origin <- concat xs + , mb_pn `matches` origin + , let pkg = extractPackage origin ] of + [] -> LookupNotFound suggestions + rs -> uncurry LookupHidden $ partition (exposed.snd) rs + [_] -> panic "lookupModuleWithSuggestions" + rs -> LookupMultiple rs where + -- ToDo: this will be wrong when we add flag renaming + + -- NB: ignore the original module; we care about what's user-visible + selectVisible mod_nm origins = + [ (mkModule (packageConfigId pkg) mod_nm, pkg) + | origin <- origins + , mb_pn `matches` origin + , Just pkg <- [originVisible origin] ] + pkg_state = pkgState dflags + suggestions | gopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods | otherwise = [] all_mods :: [(String, Module)] -- All modules - all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm) - | pkg_config <- listPackageConfigMap dflags - , let pkg_id = packageConfigId pkg_config - , mod_nm <- exposedModules pkg_config - ++ map exportName (reexportedModules pkg_config) ] + all_mods = + [ (moduleNameString mod_nm, from_mod) + | (mod_nm, modmap) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) + -- NB: ignore the original module; we care about what's user-visible + , (_, origins) <- Map.toList modmap + -- NB: do *not* filter on mb_pn; user might have passed an incorrect + -- package name + , from_mod <- map (flip mkModule mod_nm + . packageConfigId . extractPackage) origins ] + + extractPackage (FromExposedModules pkg) = pkg + extractPackage (FromHiddenModules pkg) = pkg + extractPackage (FromReexportedModules{ theReexporter = pkg }) = pkg + + Nothing `matches` _ = True + Just pn `matches` origin = case packageName (extractPackage origin) of + PackageName pn' -> fsLit pn' == pn listVisibleModuleNames :: DynFlags -> [ModuleName] listVisibleModuleNames dflags = - map fst (eltsUFM (moduleToPkgConfAll (pkgState dflags))) + Map.keys (moduleToPkgConfAll (pkgState dflags)) -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's -- cgit v1.2.1