diff options
Diffstat (limited to 'compiler/main')
| -rw-r--r-- | compiler/main/DriverMkDepend.hs | 5 | ||||
| -rw-r--r-- | compiler/main/DynamicLoading.hs | 21 | ||||
| -rw-r--r-- | compiler/main/Finder.hs | 77 | ||||
| -rw-r--r-- | compiler/main/GHC.hs | 30 | ||||
| -rw-r--r-- | compiler/main/GhcMake.hs | 19 | ||||
| -rw-r--r-- | compiler/main/HscTypes.hs | 36 | ||||
| -rw-r--r-- | compiler/main/Packages.hs | 214 |
7 files changed, 293 insertions, 109 deletions
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs index 310007d000..c51feeb491 100644 --- a/compiler/main/DriverMkDepend.hs +++ b/compiler/main/DriverMkDepend.hs @@ -248,7 +248,7 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps -- we've done it once during downsweep r <- findImportedModule hsc_env imp pkg ; case r of - Found loc _ + FoundModule (FoundHs { fr_loc = loc }) -- Home package: just depend on the .hi or hi-boot file | isJust (ml_hs_file loc) || include_pkg_deps -> return (Just (addBootSuffix_maybe is_boot (ml_hi_file loc))) @@ -257,6 +257,9 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps | otherwise -> return Nothing + -- TODO: FoundSignature. For now, we assume home package + -- "signature" dependencies look like FoundModule. + fail -> let dflags = hsc_dflags hsc_env in throwOneError $ mkPlainErrMsg dflags srcloc $ diff --git a/compiler/main/DynamicLoading.hs b/compiler/main/DynamicLoading.hs index 0d72bece36..3b62717a9c 100644 --- a/compiler/main/DynamicLoading.hs +++ b/compiler/main/DynamicLoading.hs @@ -203,7 +203,15 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do -- First find the package the module resides in by searching exposed packages and home modules found_module <- findImportedModule hsc_env mod_name Nothing case found_module of - Found _ mod -> do + FoundModule h -> check_mod (fr_mod h) + FoundSigs hs _backing -> check_mods (map fr_mod hs) -- (not tested) + err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err + where + dflags = hsc_dflags hsc_env + meth = "lookupRdrNameInModule" + doc = ptext (sLit $ "contains a name used in an invocation of " ++ meth) + + check_mod mod = do -- Find the exports of the module (_, mb_iface) <- initTcInteractive hsc_env $ initIfaceTcRn $ @@ -221,10 +229,13 @@ lookupRdrNameInModuleForPlugins hsc_env mod_name rdr_name = do _ -> panic "lookupRdrNameInModule" Nothing -> throwCmdLineErrorS dflags $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] - err -> throwCmdLineErrorS dflags $ cannotFindModule dflags mod_name err - where - dflags = hsc_dflags hsc_env - doc = ptext (sLit "contains a name used in an invocation of lookupRdrNameInModule") + + check_mods [] = return Nothing + check_mods (m:ms) = do + r <- check_mod m + case r of + Nothing -> check_mods ms + Just _ -> return r wrongTyThingError :: Name -> TyThing -> SDoc wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] diff --git a/compiler/main/Finder.hs b/compiler/main/Finder.hs index 00ba0388dd..d8aef57011 100644 --- a/compiler/main/Finder.hs +++ b/compiler/main/Finder.hs @@ -9,6 +9,7 @@ module Finder ( flushFinderCaches, FindResult(..), + convFindExactResult, -- move to HscTypes? findImportedModule, findExactModule, findHomeModule, @@ -45,8 +46,7 @@ import System.Directory import System.FilePath import Control.Monad import Data.Time -import Data.List ( foldl' ) - +import Data.List ( foldl', partition ) type FileExt = String -- Filename extension type BaseName = String -- Basename of file @@ -75,7 +75,7 @@ flushFinderCaches hsc_env = is_ext mod _ | modulePackageKey mod /= this_pkg = True | otherwise = False -addToFinderCache :: IORef FinderCache -> Module -> FindResult -> IO () +addToFinderCache :: IORef FinderCache -> Module -> FindExactResult -> IO () addToFinderCache ref key val = atomicModifyIORef' ref $ \c -> (extendModuleEnv c key val, ()) @@ -83,7 +83,7 @@ removeFromFinderCache :: IORef FinderCache -> Module -> IO () removeFromFinderCache ref key = atomicModifyIORef' ref $ \c -> (delModuleEnv c key, ()) -lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindResult) +lookupFinderCache :: IORef FinderCache -> Module -> IO (Maybe FindExactResult) lookupFinderCache ref key = do c <- readIORef ref return $! lookupModuleEnv c key @@ -104,7 +104,7 @@ findImportedModule hsc_env mod_name mb_pkg = Just pkg | pkg == fsLit "this" -> home_import -- "this" is special | otherwise -> pkg_import where - home_import = findHomeModule hsc_env mod_name + home_import = convFindExactResult `fmap` findHomeModule hsc_env mod_name pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg @@ -118,7 +118,7 @@ findImportedModule hsc_env mod_name mb_pkg = -- reading the interface for a module mentioned by another interface, -- for example (a "system import"). -findExactModule :: HscEnv -> Module -> IO FindResult +findExactModule :: HscEnv -> Module -> IO FindExactResult findExactModule hsc_env mod = let dflags = hsc_dflags hsc_env in if modulePackageKey mod == thisPackage dflags @@ -152,17 +152,45 @@ orIfNotFound this or_this = do -- been done. Otherwise, do the lookup (with the IO action) and save -- the result in the finder cache and the module location cache (if it -- was successful.) -homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult +homeSearchCache :: HscEnv + -> ModuleName + -> IO FindExactResult + -> IO FindExactResult homeSearchCache hsc_env mod_name do_this = do let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name modLocationCache hsc_env mod do_this +-- | Converts a 'FindExactResult' into a 'FindResult' in the obvious way. +convFindExactResult :: FindExactResult -> FindResult +convFindExactResult (FoundExact loc m) = FoundModule (FoundHs loc m) +convFindExactResult (NoPackageExact pk) = NoPackage pk +convFindExactResult NotFoundExact { fer_paths = paths, fer_pkg = pkg } = + NotFound { + fr_paths = paths, fr_pkg = pkg, + fr_pkgs_hidden = [], fr_mods_hidden = [], fr_suggestions = [] + } + +foundExact :: FindExactResult -> Bool +foundExact FoundExact{} = True +foundExact _ = False + findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult findExposedPackageModule hsc_env mod_name mb_pkg = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name mb_pkg of - LookupFound m pkg_conf -> - findPackageModule_ hsc_env m pkg_conf + LookupFound (m, _) -> do + fmap convFindExactResult (findPackageModule hsc_env m) + LookupFoundSigs ms backing -> do + locs <- mapM (findPackageModule hsc_env . fst) ms + let (ok, missing) = partition foundExact locs + case missing of + -- At the moment, we return the errors one at a time. It might be + -- better if we collected them up and reported them all, but + -- FindResult doesn't have enough information to support this. + -- In any case, this REALLY shouldn't happen (it means there are + -- broken packages in the database.) + (m:_) -> return (convFindExactResult m) + _ -> return (FoundSigs [FoundHs l m | FoundExact l m <- ok] backing) LookupMultiple rs -> return (FoundMultiple rs) LookupHidden pkg_hiddens mod_hiddens -> @@ -176,7 +204,7 @@ findExposedPackageModule hsc_env mod_name mb_pkg , fr_mods_hidden = [] , fr_suggestions = suggest }) -modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult +modLocationCache :: HscEnv -> Module -> IO FindExactResult -> IO FindExactResult modLocationCache hsc_env mod do_this = do m <- lookupFinderCache (hsc_FC hsc_env) mod case m of @@ -189,7 +217,7 @@ modLocationCache hsc_env mod do_this = do addHomeModuleToFinder :: HscEnv -> ModuleName -> ModLocation -> IO Module addHomeModuleToFinder hsc_env mod_name loc = do let mod = mkModule (thisPackage (hsc_dflags hsc_env)) mod_name - addToFinderCache (hsc_FC hsc_env) mod (Found loc mod) + addToFinderCache (hsc_FC hsc_env) mod (FoundExact loc mod) return mod uncacheModule :: HscEnv -> ModuleName -> IO () @@ -216,7 +244,7 @@ uncacheModule hsc_env mod = do -- -- 4. Some special-case code in GHCi (ToDo: Figure out why that needs to -- call this.) -findHomeModule :: HscEnv -> ModuleName -> IO FindResult +findHomeModule :: HscEnv -> ModuleName -> IO FindExactResult findHomeModule hsc_env mod_name = homeSearchCache hsc_env mod_name $ let @@ -247,19 +275,19 @@ findHomeModule hsc_env mod_name = -- This is important only when compiling the base package (where GHC.Prim -- is a home module). if mod == gHC_PRIM - then return (Found (error "GHC.Prim ModLocation") mod) + then return (FoundExact (error "GHC.Prim ModLocation") mod) else searchPathExts home_path mod exts -- | Search for a module in external packages only. -findPackageModule :: HscEnv -> Module -> IO FindResult +findPackageModule :: HscEnv -> Module -> IO FindExactResult findPackageModule hsc_env mod = do let dflags = hsc_dflags hsc_env pkg_id = modulePackageKey mod -- case lookupPackage dflags pkg_id of - Nothing -> return (NoPackage pkg_id) + Nothing -> return (NoPackageExact pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf -- | Look up the interface file associated with module @mod@. This function @@ -269,14 +297,14 @@ findPackageModule hsc_env mod = do -- the 'PackageConfig' must be consistent with the package key in the 'Module'. -- The redundancy is to avoid an extra lookup in the package state -- for the appropriate config. -findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult +findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindExactResult findPackageModule_ hsc_env mod pkg_conf = ASSERT( modulePackageKey mod == packageConfigId pkg_conf ) modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. if mod == gHC_PRIM - then return (Found (error "GHC.Prim ModLocation") mod) + then return (FoundExact (error "GHC.Prim ModLocation") mod) else let @@ -299,7 +327,7 @@ findPackageModule_ hsc_env mod pkg_conf = -- don't bother looking for it. let basename = moduleNameSlashes (moduleName mod) loc <- mk_hi_loc one basename - return (Found loc mod) + return (FoundExact loc mod) _otherwise -> searchPathExts import_dirs mod [(package_hisuf, mk_hi_loc)] @@ -314,7 +342,7 @@ searchPathExts FilePath -> BaseName -> IO ModLocation -- action ) ] - -> IO FindResult + -> IO FindExactResult searchPathExts paths mod exts = do result <- search to_search @@ -340,15 +368,13 @@ searchPathExts paths mod exts file = base <.> ext ] - search [] = return (NotFound { fr_paths = map fst to_search - , fr_pkg = Just (modulePackageKey mod) - , fr_mods_hidden = [], fr_pkgs_hidden = [] - , fr_suggestions = [] }) + search [] = return (NotFoundExact {fer_paths = map fst to_search + ,fer_pkg = Just (modulePackageKey mod)}) search ((file, mk_result) : rest) = do b <- doesFileExist file if b - then do { loc <- mk_result; return (Found loc mod) } + then do { loc <- mk_result; return (FoundExact loc mod) } else search rest mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt @@ -571,7 +597,8 @@ cantFindErr cannot_find _ dflags mod_name find_result vcat (map mod_hidden mod_hiddens) $$ tried_these files - _ -> panic "cantFindErr" + _ -> pprPanic "cantFindErr" + (ptext cannot_find <+> quotes (ppr mod_name)) build_tag = buildTag dflags diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs index 1a7d4ef71e..d9380e10c3 100644 --- a/compiler/main/GHC.hs +++ b/compiler/main/GHC.hs @@ -1378,6 +1378,20 @@ showRichTokenStream ts = go startLoc ts "" -- | Takes a 'ModuleName' and possibly a 'PackageKey', and consults the -- filesystem and package database to find the corresponding 'Module', -- using the algorithm that is used for an @import@ declaration. +-- +-- However, there is a twist for local modules, see #2682. +-- +-- The full algorithm: +-- IF it's a package qualified import for a REMOTE package (not @this_pkg@ or +-- this), do a normal lookup. +-- OTHERWISE see if it is ALREADY loaded, and use it if it is. +-- OTHERWISE do a normal lookup, but reject the result if the found result +-- is from the LOCAL package (@this_pkg@). +-- +-- For signatures, we return the BACKING implementation to keep the API +-- consistent with what we had before. (ToDo: create a new GHC API which +-- can deal with signatures.) +-- findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module findModule mod_name maybe_pkg = withSession $ \hsc_env -> do let @@ -1388,17 +1402,23 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do Just pkg | fsToPackageKey pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of - Found _ m -> return m + FoundModule h -> return (fr_mod h) + FoundSigs _ backing -> return backing err -> throwOneError $ noModError dflags noSrcSpan mod_name err _otherwise -> do home <- lookupLoadedHomeModule mod_name case home of + -- TODO: This COULD be a signature Just m -> return m Nothing -> liftIO $ do res <- findImportedModule hsc_env mod_name maybe_pkg case res of - Found loc m | modulePackageKey m /= this_pkg -> return m - | otherwise -> modNotLoadedError dflags m loc + FoundModule (FoundHs { fr_mod = m, fr_loc = loc }) + | modulePackageKey m /= this_pkg -> return m + | otherwise -> modNotLoadedError dflags m loc + FoundSigs (FoundHs { fr_loc = loc, fr_mod = m }:_) backing + | modulePackageKey m /= this_pkg -> return backing + | otherwise -> modNotLoadedError dflags m loc err -> throwOneError $ noModError dflags noSrcSpan mod_name err modNotLoadedError :: DynFlags -> Module -> ModLocation -> IO a @@ -1419,11 +1439,13 @@ lookupModule mod_name (Just pkg) = findModule mod_name (Just pkg) lookupModule mod_name Nothing = withSession $ \hsc_env -> do home <- lookupLoadedHomeModule mod_name case home of + -- TODO: This COULD be a signature Just m -> return m Nothing -> liftIO $ do res <- findExposedPackageModule hsc_env mod_name Nothing case res of - Found _ m -> return m + FoundModule (FoundHs { fr_mod = m }) -> return m + FoundSigs _ backing -> return backing err -> throwOneError $ noModError (hsc_dflags hsc_env) noSrcSpan mod_name err lookupLoadedHomeModule :: GhcMonad m => ModuleName -> m (Maybe Module) diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs index 2d1d9ebf52..89cab9ef3a 100644 --- a/compiler/main/GhcMake.hs +++ b/compiler/main/GhcMake.hs @@ -1815,7 +1815,10 @@ findSummaryBySourceFile summaries file [] -> Nothing (x:_) -> Just x --- Summarise a module, and pick up source and timestamp. +-- | Summarise a module, and pick up source and timestamp. +-- Returns @Nothing@ if the module is excluded via @excl_mods@ or is an +-- external package module (which we don't compile), otherwise returns the +-- new module summary (or an error saying why we couldn't summarise it). summariseModule :: HscEnv -> NodeMap ModSummary -- Map of old summaries @@ -1877,7 +1880,10 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) uncacheModule hsc_env wanted_mod found <- findImportedModule hsc_env wanted_mod Nothing case found of - Found location mod + -- TODO: When we add -alias support, we can validly find + -- multiple signatures in the home package; need to make this + -- logic more flexible in that case. + FoundModule (FoundHs { fr_loc = location, fr_mod = mod }) | isJust (ml_hs_file location) -> -- Home package just_found location mod @@ -1886,6 +1892,15 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) ASSERT(modulePackageKey mod /= thisPackage dflags) return Nothing + FoundSigs hs _backing + | Just (FoundHs { fr_loc = location, fr_mod = mod }) + <- find (isJust . ml_hs_file . fr_loc) hs -> + just_found location mod + | otherwise -> + ASSERT(all (\h -> modulePackageKey (fr_mod h) + /= thisPackage dflags) hs) + return Nothing + err -> return $ Just $ Left $ noModError dflags loc wanted_mod err -- Not found diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs index b7707f80af..0dd6341e1f 100644 --- a/compiler/main/HscTypes.hs +++ b/compiler/main/HscTypes.hs @@ -10,7 +10,7 @@ module HscTypes ( -- * compilation state HscEnv(..), hscEPS, - FinderCache, FindResult(..), + FinderCache, FindResult(..), FoundHs(..), FindExactResult(..), Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, HscStatus(..), @@ -674,15 +674,30 @@ prepareAnnotations hsc_env mb_guts = do -- modules along the search path. On @:load@, we flush the entire -- contents of this cache. -- --- Although the @FinderCache@ range is 'FindResult' for convenience, --- in fact it will only ever contain 'Found' or 'NotFound' entries. --- -type FinderCache = ModuleEnv FindResult +type FinderCache = ModuleEnv FindExactResult + +-- | The result of search for an exact 'Module'. +data FindExactResult + = FoundExact ModLocation Module + -- ^ The module/signature was found + | NoPackageExact PackageKey + | NotFoundExact + { fer_paths :: [FilePath] + , fer_pkg :: Maybe PackageKey + } + +-- | A found module or signature; e.g. anything with an interface file +data FoundHs = FoundHs { fr_loc :: ModLocation + , fr_mod :: Module + -- , fr_origin :: ModuleOrigin + } -- | The result of searching for an imported module. data FindResult - = Found ModLocation Module + = FoundModule FoundHs -- ^ The module was found + | FoundSigs [FoundHs] Module + -- ^ Signatures were found, with some backing implementation | NoPackage PackageKey -- ^ The requested package was not found | FoundMultiple [(Module, ModuleOrigin)] @@ -2069,6 +2084,15 @@ type IsBootInterface = Bool -- Invariant: the dependencies of a module @M@ never includes @M@. -- -- Invariant: none of the lists contain duplicates. +-- +-- NB: While this contains information about all modules and packages below +-- this one in the the import *hierarchy*, this may not accurately reflect +-- the full runtime dependencies of the module. This is because this module may +-- have imported a boot module, in which case we'll only have recorded the +-- dependencies from the hs-boot file, not the actual hs file. (This is +-- unavoidable: usually, the actual hs file will have been compiled *after* +-- we wrote this interface file.) See #936, and also @getLinkDeps@ in +-- @compiler/ghci/Linker.hs@ for code which cares about this distinction. data Dependencies = Deps { dep_mods :: [(ModuleName, IsBootInterface)] -- ^ All home-package modules transitively below this one diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index 0be5e3ffaf..16ee352243 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -132,9 +132,10 @@ import qualified Data.Set as Set -- in a different DLL, by setting the DLL flag. -- | Given a module name, there may be multiple ways it came into scope, --- possibly simultaneously. This data type tracks all the possible ways --- it could have come into scope. Warning: don't use the record functions, --- they're partial! +-- possibly simultaneously. For a given particular implementation (e.g. +-- original module, or even a signature module), this data type tracks all the +-- possible ways it could have come into scope. Warning: don't use the record +-- functions, they're partial! data ModuleOrigin = -- | Module is hidden, and thus never will be available for import. -- (But maybe the user didn't realize), so we'll still keep track @@ -158,7 +159,7 @@ data ModuleOrigin = } instance Outputable ModuleOrigin where - ppr ModHidden = text "hidden module" + ppr ModHidden = text "hidden module" -- NB: cannot be signature ppr (ModOrigin e res rhs f) = sep (punctuate comma ( (case e of Nothing -> [] @@ -175,17 +176,18 @@ instance Outputable ModuleOrigin where (if f then [text "package flag"] else []) )) --- | Smart constructor for a module which is in @exposed-modules@. Takes --- as an argument whether or not the defining package is exposed. -fromExposedModules :: Bool -> ModuleOrigin -fromExposedModules e = ModOrigin (Just e) [] [] False +-- | Smart constructor for a module which is in @exposed-modules@ or +-- @exposed-signatures@. Takes as an argument whether or not the defining +-- package is exposed. +fromExposed :: Bool -> ModuleOrigin +fromExposed e = ModOrigin (Just e) [] [] False --- | Smart constructor for a module which is in @reexported-modules@. Takes --- as an argument whether or not the reexporting package is expsed, and --- also its 'PackageConfig'. -fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin -fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False -fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False +-- | Smart constructor for a module which is in @reexported-modules@ +-- or @reexported-signatures@. Takes as an argument whether or not the +-- reexporting package is expsed, and also its 'PackageConfig'. +fromReexported :: Bool -> PackageConfig -> ModuleOrigin +fromReexported True pkg = ModOrigin Nothing [pkg] [] False +fromReexported False pkg = ModOrigin Nothing [] [pkg] False -- | Smart constructor for a module which was bound by a package flag. fromFlag :: ModuleOrigin @@ -227,11 +229,40 @@ type PackageConfigMap = PackageKeyMap PackageConfig type VisibilityMap = PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString) --- | Map from 'ModuleName' to 'Module' to all the origins of the bindings --- in scope. The 'PackageConf' is not cached, mostly for convenience reasons --- (since this is the slow path, we'll just look it up again). -type ModuleToPkgConfAll = - Map ModuleName (Map Module ModuleOrigin) +-- | Alias for 'Module' indicating we expect the interface in question to +-- be for a signature. +type Signature = Module + +-- | Alias for 'ModuleOrigin' indicating we expect it to describe a signature. +type SignatureOrigin = ModuleOrigin + +-- | This is the main lookup structure we use to handle imports, which map +-- from 'ModuleName' to 'ModuleDb', which describes all possible implementations +-- which are available under a module name. +type ModuleNameDb = Map ModuleName ModuleDb + +-- | This is an auxiliary structure per module name, and it's a map of +-- backing implementations to more information about them. This is a map +-- so it's easy to tell if we're bringing in an implementation for a name +-- which is already in scope (and thus non-conflicting.) +type ModuleDb = Map Module ModuleDesc + +-- | Per backing implementation, there may be multiple signatures available +-- exporting subsets of its interface; we need to track all of them. +type SignatureDb = Map Signature SignatureOrigin + +-- | Combined module description for a module: includes 'ModuleOrigin' +-- describing the backing implementation, as well as 'SignatureDb' for any +-- signatures of the module in question. +data ModuleDesc = MD ModuleOrigin SignatureDb + +instance Outputable ModuleDesc where + ppr (MD o m) = ppr o <+> parens (ppr m) + +instance Monoid ModuleDesc where + mempty = MD mempty Map.empty + mappend (MD o m) (MD o' m') = MD (o `mappend` o') + (Map.unionWith mappend m m') data PackageState = PackageState { -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted @@ -249,7 +280,7 @@ data PackageState = PackageState { -- | 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, + moduleNameDb :: ModuleNameDb, -- | This is a map from 'InstalledPackageId' to 'PackageKey', since GHC -- internally deals in package keys but the database may refer to installed @@ -261,7 +292,7 @@ emptyPackageState :: PackageState emptyPackageState = PackageState { pkgIdMap = emptyUFM, preloadPackages = [], - moduleToPkgConfAll = Map.empty, + moduleNameDb = Map.empty, installedPackageIdMap = Map.empty } @@ -1025,7 +1056,7 @@ mkPackageState dflags0 pkgs0 preload0 this_package = do let pstate = PackageState{ preloadPackages = dep_preload, pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map, + moduleNameDb = mkModuleNameDb dflags pkg_db ipid_map vis_map, installedPackageIdMap = ipid_map } return (pstate, new_dep_preload, this_package) @@ -1034,62 +1065,70 @@ mkPackageState dflags0 pkgs0 preload0 this_package = do -- ----------------------------------------------------------------------------- -- | Makes the mapping from module to package info -mkModuleToPkgConfAll +mkModuleNameDb :: DynFlags -> PackageConfigMap -> InstalledPackageIdMap -> VisibilityMap - -> ModuleToPkgConfAll -mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map = + -> ModuleNameDb +mkModuleNameDb dflags pkg_db ipid_map vis_map = foldl' extend_modmap emptyMap (eltsUFM pkg_db) where emptyMap = Map.empty - sing pk m _ = Map.singleton (mkModule pk m) + sing pk m = Map.singleton (mkModule pk m) addListTo = foldl' merge merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m - setOrigins m os = fmap (const os) m extend_modmap modmap pkg = addListTo modmap theBindings where - theBindings :: [(ModuleName, Map Module ModuleOrigin)] + theBindings :: [(ModuleName, ModuleDb)] theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg) = newBindings b rns | otherwise = newBindings False [] newBindings :: Bool -> [(ModuleName, ModuleName)] - -> [(ModuleName, Map Module ModuleOrigin)] + -> [(ModuleName, ModuleDb)] newBindings e rns = es e ++ hiddens ++ map rnBinding rns rnBinding :: (ModuleName, ModuleName) - -> (ModuleName, Map Module ModuleOrigin) - rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + -> (ModuleName, ModuleDb) + rnBinding (orig, new) = (new, fmap applyFlag origEntry) where origEntry = case lookupUFM esmap orig of Just r -> r Nothing -> throwGhcException (CmdLineError (showSDoc dflags (text "package flag: could not find module name" <+> ppr orig <+> text "in package" <+> ppr pk))) - es :: Bool -> [(ModuleName, Map Module ModuleOrigin)] + applyFlag (MD _ sigs) = MD fromFlag (fmap (const fromFlag) sigs) + + es :: Bool -> [(ModuleName, ModuleDb)] es e = do - -- TODO: signature support - ExposedModule m exposedReexport _exposedSignature <- exposed_mods - let (pk', m', pkg', origin') = + ExposedModule m exposedReexport exposedSignature <- exposed_mods + let (pk', m', origin') = case exposedReexport of - Nothing -> (pk, m, pkg, fromExposedModules e) + Nothing -> (pk, m, fromExposed e) Just (OriginalModule ipid' m') -> - let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) - pkg' = pkg_lookup pk' - in (pk', m', pkg', fromReexportedModules e pkg') - return (m, sing pk' m' pkg' origin') + let (pk', pkg') = ipid_lookup ipid' + in (pk', m', fromReexported e pkg') + return $ case exposedSignature of + Nothing -> (m, sing pk' m' (MD origin' Map.empty)) + Just (OriginalModule ipid'' m'') -> + let (pk'', _) = ipid_lookup ipid'' + in (m, sing pk'' m'' (MD mempty (sing pk' m' origin'))) - esmap :: UniqFM (Map Module ModuleOrigin) + + esmap :: UniqFM ModuleDb esmap = listToUFM (es False) -- parameter here doesn't matter, orig will -- be overwritten - hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] + hiddens :: [(ModuleName, ModuleDb)] + hiddens = [(m, sing pk m (MD ModHidden Map.empty)) | m <- hidden_mods] pk = packageConfigId pkg - pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db + pkg_lookup = expectJust "mkModuleNameDb" . lookupPackage' pkg_db + ipid_lookup ipid = + let pk = expectJust "mkModuleNameDb" (Map.lookup ipid ipid_map) + in (pk, pkg_lookup pk) exposed_mods = exposedModules pkg hidden_mods = hiddenModules pkg @@ -1199,16 +1238,20 @@ lookupModuleInAllPackages :: DynFlags -> [(Module, PackageConfig)] lookupModuleInAllPackages dflags m = case lookupModuleWithSuggestions dflags m Nothing of - LookupFound a b -> [(a,b)] - LookupMultiple rs -> map f rs - where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags - (modulePackageKey m))) + LookupFound (m,_) -> [(m,get_pkg m)] + LookupMultiple rs -> map (\(m,_) -> (m,get_pkg m)) rs _ -> [] + where get_pkg = expectJust "lookupModule" . lookupPackage dflags + . modulePackageKey -- | The result of performing a lookup data LookupResult = -- | Found the module uniquely, nothing else to do - LookupFound Module PackageConfig + LookupFound (Module, ModuleOrigin) + -- | We found (possibly multiple) signatures with a unique backing + -- implementation: they should be "merged" together. For good measure, + -- the backing implementation is recorded too. + | LookupFoundSigs [(Module, ModuleOrigin)] Module -- | Multiple modules with the same name in scope | LookupMultiple [(Module, ModuleOrigin)] -- | No modules found, but there were some hidden ones with @@ -1218,6 +1261,39 @@ data LookupResult = -- | Nothing found, here are some suggested different names | LookupNotFound [ModuleSuggestion] -- suggestions +instance Monoid LookupResult where + mempty = LookupNotFound [] + + LookupNotFound s1 `mappend` LookupNotFound s2 + = LookupNotFound (s1 ++ s2) + LookupNotFound{} `mappend` l = l + l `mappend` LookupNotFound{} = l + + LookupHidden x1 y1 `mappend` LookupHidden x2 y2 + = LookupHidden (x1 ++ x2) (y1 ++ y2) + LookupHidden{} `mappend` l = l + l `mappend` LookupHidden{} = l + + LookupFound m1 `mappend` LookupFound m2 + = ASSERT(fst m1 /= fst m2) LookupMultiple [m1, m2] + LookupFound m `mappend` LookupMultiple ms + = ASSERT(not (any ((==fst m).fst) ms)) LookupMultiple (m:ms) + LookupFound m `mappend` LookupFoundSigs ms check + | fst m == check = LookupFound m + | otherwise = LookupMultiple (m:ms) + l1 `mappend` l2@LookupFound{} + = l2 `mappend` l1 + + LookupMultiple ms1 `mappend` LookupFoundSigs ms2 _ + = LookupMultiple (ms1 ++ ms2) + LookupMultiple ms1 `mappend` LookupMultiple ms2 + = LookupMultiple (ms1 ++ ms2) + l1 `mappend` l2@LookupMultiple{} + = l2 `mappend` l1 + + LookupFoundSigs ms1 m1 `mappend` LookupFoundSigs ms2 m2 + = ASSERT(m1 /= m2) LookupMultiple (ms1 ++ ms2) + data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin | SuggestHidden ModuleName Module ModuleOrigin @@ -1226,23 +1302,28 @@ lookupModuleWithSuggestions :: DynFlags -> Maybe FastString -> LookupResult lookupModuleWithSuggestions dflags m mb_pn - = case Map.lookup m (moduleToPkgConfAll pkg_state) of + = case Map.lookup m (moduleNameDb pkg_state) of Nothing -> LookupNotFound suggestions - Just xs -> - case foldl' classify ([],[],[]) (Map.toList xs) of - ([], [], []) -> LookupNotFound suggestions - (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) - (_, _, exposed@(_:_)) -> LookupMultiple exposed - (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod + Just xs -> mconcat (LookupNotFound suggestions + :map classify (Map.toList xs)) where - classify (hidden_pkg, hidden_mod, exposed) (m, origin0) = + classify (m, MD origin0 sigs0) = let origin = filterOrigin mb_pn (mod_pkg m) origin0 - x = (m, origin) + r = (m, origin) in case origin of - ModHidden -> (hidden_pkg, x:hidden_mod, exposed) - _ | originEmpty origin -> (hidden_pkg, hidden_mod, exposed) - | originVisible origin -> (hidden_pkg, hidden_mod, x:exposed) - | otherwise -> (x:hidden_pkg, hidden_mod, exposed) + ModHidden -> LookupHidden [] [r] + _ | originVisible origin -> LookupFound r + | otherwise -> + let sigs = do (back_m, back_origin0) <- Map.toList sigs0 + let back_origin = filterOrigin mb_pn + (mod_pkg back_m) + back_origin0 + guard (originVisible back_origin) + return (back_m, back_origin) + in case sigs of + [] | originEmpty origin -> LookupNotFound [] + | otherwise -> LookupHidden [r] [] + _ -> LookupFoundSigs sigs m pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags pkg_state = pkgState dflags @@ -1277,17 +1358,18 @@ lookupModuleWithSuggestions dflags m mb_pn all_mods :: [(String, ModuleSuggestion)] -- All modules all_mods = sortBy (comparing fst) $ [ (moduleNameString m, suggestion) - | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) + | (m, e) <- Map.toList (moduleNameDb (pkgState dflags)) , suggestion <- map (getSuggestion m) (Map.toList e) ] - getSuggestion name (mod, origin) = + -- For now, don't suggest implemented signatures + getSuggestion name (mod, MD origin _) = (if originVisible origin then SuggestVisible else SuggestHidden) name mod origin listVisibleModuleNames :: DynFlags -> [ModuleName] listVisibleModuleNames dflags = - map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags)))) - where visible (_, ms) = any originVisible (Map.elems ms) + map fst (filter visible (Map.toList (moduleNameDb (pkgState dflags)))) + where visible (_, ms) = any (\(MD o _) -> originVisible o) (Map.elems ms) -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's @@ -1426,7 +1508,7 @@ pprPackagesSimple = pprPackagesWith pprIPI -- | Show the mapping of modules to where they come from. pprModuleMap :: DynFlags -> SDoc pprModuleMap dflags = - vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags)))) + vcat (map pprLine (Map.toList (moduleNameDb (pkgState dflags)))) where pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) pprEntry m (m',o) |