diff options
Diffstat (limited to 'compiler/main/Packages.hs')
| -rw-r--r-- | compiler/main/Packages.hs | 212 |
1 files changed, 147 insertions, 65 deletions
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs index 70476a16bd..a25e8e7ee7 100644 --- a/compiler/main/Packages.hs +++ b/compiler/main/Packages.hs @@ -131,9 +131,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 @@ -157,7 +158,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 -> [] @@ -174,17 +175,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 @@ -226,11 +228,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 @@ -248,7 +279,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 @@ -1016,7 +1047,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) @@ -1025,62 +1056,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 @@ -1190,16 +1229,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 @@ -1209,6 +1252,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 @@ -1217,23 +1293,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 @@ -1268,17 +1349,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 @@ -1417,7 +1499,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) |