diff options
29 files changed, 720 insertions, 286 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index d527e89dc9..74bd1397b8 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -43,7 +43,7 @@ module DynFlags ( targetRetainsAllBindings, GhcMode(..), isOneShot, GhcLink(..), isNoLink, - PackageFlag(..), PackageArg(..), + PackageFlag(..), PackageArg(..), ModRenaming, PkgConfRef(..), Option(..), showOpt, DynLibLoader(..), @@ -190,6 +190,8 @@ import Data.Word import System.FilePath import System.IO import System.IO.Error +import Text.ParserCombinators.ReadP hiding (char) +import Text.ParserCombinators.ReadP as R import Data.IntSet (IntSet) import qualified Data.IntSet as IntSet @@ -269,6 +271,7 @@ data DumpFlag | Opt_D_dump_hi | Opt_D_dump_hi_diffs | Opt_D_dump_mod_cycles + | Opt_D_dump_mod_map | Opt_D_dump_view_pattern_commoning | Opt_D_verbose_core2core @@ -1025,8 +1028,10 @@ data PackageArg = PackageArg String | PackageKeyArg String deriving (Eq, Show) +type ModRenaming = Maybe [(String, String)] + data PackageFlag - = ExposePackage PackageArg + = ExposePackage PackageArg ModRenaming | HidePackage String | IgnorePackage String | TrustPackage String @@ -1633,6 +1638,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags) enableIfVerbose Opt_D_dump_ticked = False enableIfVerbose Opt_D_dump_view_pattern_commoning = False enableIfVerbose Opt_D_dump_mod_cycles = False + enableIfVerbose Opt_D_dump_mod_map = False enableIfVerbose _ = True -- | Set a 'DumpFlag' @@ -2377,6 +2383,7 @@ dynamic_flags = [ , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_ticked) -- back compat , Flag "ddump-ticked" (setDumpFlag Opt_D_dump_ticked) , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + , Flag "ddump-mod-map" (setDumpFlag Opt_D_dump_mod_map) , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) , Flag "ddump-to-file" (NoArg (setGeneralFlag Opt_DumpToFile)) , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) @@ -3349,7 +3356,26 @@ clearPkgConf = upd $ \s -> s { extraPkgConfs = const [] } parsePackageFlag :: (String -> PackageArg) -- type of argument -> String -- string to parse -> PackageFlag -parsePackageFlag constr str = ExposePackage (constr str) +parsePackageFlag constr str = case filter ((=="").snd) (readP_to_S parse str) of + [(r, "")] -> r + _ -> throwGhcException $ CmdLineError ("Can't parse package flag: " ++ str) + where parse = do + pkg <- munch1 (\c -> isAlphaNum c || c `elem` ":-_.") + (do _ <- tok $ R.char '(' + rns <- tok $ sepBy parseItem (tok $ R.char ',') + _ <- tok $ R.char ')' + return (ExposePackage (constr pkg) (Just rns)) + +++ + return (ExposePackage (constr pkg) Nothing)) + parseMod = munch1 (\c -> isAlphaNum c || c `elem` ".") + parseItem = do + orig <- tok $ parseMod + (do _ <- tok $ string "as" + new <- tok $ parseMod + return (orig, new) + +++ + return (orig, orig)) + tok m = skipSpaces >> m exposePackage, exposePackageId, exposePackageKey, hidePackage, ignorePackage, trustPackage, distrustPackage :: String -> DynP () diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs index 11d5b6f96d..f9c7e2eee0 100644 --- a/compiler/main/Finder.lhs +++ b/compiler/main/Finder.lhs @@ -47,8 +47,8 @@ import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import System.Directory import System.FilePath import Control.Monad -import Data.List ( partition ) import Data.Time +import Data.List ( foldl' ) type FileExt = String -- Filename extension @@ -193,17 +193,17 @@ findExposedPackageModule hsc_env mod_name mb_pkg LookupFound m pkg_conf -> findPackageModule_ hsc_env m pkg_conf LookupMultiple rs -> - return (FoundMultiple (map (packageConfigId . snd) rs)) + return (FoundMultiple 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 = [] }) + return (NotFound{ fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = map (modulePackageKey.fst) pkg_hiddens + , fr_mods_hidden = map (modulePackageKey.fst) mod_hiddens + , fr_suggestions = [] }) LookupNotFound suggest -> - return (NotFound { fr_paths = [], fr_pkg = Nothing - , fr_pkgs_hidden = [] - , fr_mods_hidden = [] - , fr_suggestions = 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 @@ -280,8 +280,16 @@ findPackageModule hsc_env mod = do Nothing -> return (NoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf +-- | Look up the interface file associated with module @mod@. This function +-- requires a few invariants to be upheld: (1) the 'Module' in question must +-- be the module identifier of the *original* implementation of a module, +-- not a reexport (this invariant is upheld by @Packages.lhs@) and (2) +-- 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_ 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. @@ -526,11 +534,34 @@ cannotFindInterface = cantFindErr (sLit "Failed to load interface for") cantFindErr :: LitString -> LitString -> DynFlags -> ModuleName -> FindResult -> SDoc -cantFindErr _ multiple_found _ mod_name (FoundMultiple pkgs) +cantFindErr _ multiple_found _ mod_name (FoundMultiple mods) + | Just pkgs <- unambiguousPackages = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( sep [ptext (sLit "it was found in multiple packages:"), - hsep (map ppr pkgs)] + hsep (map ppr pkgs) ] ) + | otherwise + = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( + vcat (map pprMod mods) + ) + where + unambiguousPackages = foldl' unambiguousPackage (Just []) mods + unambiguousPackage (Just xs) (m, ModOrigin (Just _) _ _ _) + = Just (modulePackageKey m : xs) + unambiguousPackage _ _ = Nothing + + pprMod (m, o) = ptext (sLit "it is bound as") <+> ppr m <+> + ptext (sLit "by") <+> pprOrigin m o + pprOrigin _ ModHidden = panic "cantFindErr: bound by mod hidden" + pprOrigin m (ModOrigin e res _ f) = sep $ punctuate comma ( + if e == Just True + then [ptext (sLit "package") <+> ppr (modulePackageKey m)] + else [] ++ + map ((ptext (sLit "a reexport in package") <+>) + .ppr.packageConfigId) res ++ + if f then [ptext (sLit "a package flag")] else [] + ) + cantFindErr cannot_find _ dflags mod_name find_result = ptext cannot_find <+> quotes (ppr mod_name) $$ more_info @@ -601,22 +632,40 @@ cantFindErr cannot_find _ dflags mod_name find_result mod_hidden pkg = ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg) - pp_suggestions :: [Module] -> SDoc + pp_suggestions :: [ModuleSuggestion] -> SDoc pp_suggestions sugs | null sugs = empty | otherwise = hang (ptext (sLit "Perhaps you meant")) - 2 (vcat [ vcat (map pp_exp exposed_sugs) - , vcat (map pp_hid hidden_sugs) ]) - where - (exposed_sugs, hidden_sugs) = partition from_exposed_pkg sugs - - from_exposed_pkg m = case lookupPackage dflags (modulePackageKey m) of - Just pkg_config -> exposed pkg_config - Nothing -> WARN( True, ppr m ) -- Should not happen - False - - pp_exp mod = ppr (moduleName mod) - <+> parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) - pp_hid mod = ppr (moduleName mod) - <+> parens (ptext (sLit "needs flag -package") <+> ppr (modulePackageKey mod)) + 2 (vcat (map pp_sugg sugs)) + + -- NB: Prefer the *original* location, and then reexports, and then + -- package flags when making suggestions. ToDo: if the original package + -- also has a reexport, prefer that one + pp_sugg (SuggestVisible m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModOrigin{ fromOrigPackage = e, + fromExposedReexport = res, + fromPackageFlag = f }) + | Just True <- e + = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + | f && moduleName mod == m + = parens (ptext (sLit "from") <+> ppr (modulePackageKey mod)) + | (pkg:_) <- res + = parens (ptext (sLit "from") <+> ppr (packageConfigId pkg) + <> comma <+> ptext (sLit "reexporting") <+> ppr mod) + | f + = parens (ptext (sLit "defined via package flags to be") + <+> ppr mod) + | otherwise = empty + pp_sugg (SuggestHidden m mod o) = ppr m <+> provenance o + where provenance ModHidden = empty + provenance (ModOrigin{ fromOrigPackage = e, + fromHiddenReexport = rhs }) + | Just False <- e + = parens (ptext (sLit "needs flag -package-key") + <+> ppr (modulePackageKey mod)) + | (pkg:_) <- rhs + = parens (ptext (sLit "needs flag -package-key") + <+> ppr (packageConfigId pkg)) + | otherwise = empty \end{code} diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs index 89c84f6596..15d67fc882 100644 --- a/compiler/main/HscMain.hs +++ b/compiler/main/HscMain.hs @@ -891,13 +891,6 @@ hscGetSafe hsc_env m l = runHsc hsc_env $ do | otherwise = pkgs return (good, pkgs') --- | A function which only qualifies package names if necessary; but --- qualifies all other identifiers. -pkgQual :: DynFlags -> PrintUnqualified -pkgQual dflags = alwaysQualify { - queryQualifyPackage = mkQualPackage dflags - } - -- | Is a module trusted? If not, throw or log errors depending on the type. -- Return (regardless of trusted or not) if the trust type requires the modules -- own package be trusted and a list of other packages required to be trusted diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs index 83f43d1da2..123b0777fc 100644 --- a/compiler/main/HscTypes.lhs +++ b/compiler/main/HscTypes.lhs @@ -54,7 +54,7 @@ module HscTypes ( setInteractivePrintName, icInteractiveModule, InteractiveImport(..), setInteractivePackage, mkPrintUnqualified, pprModulePrefix, - mkQualPackage, mkQualModule, + mkQualPackage, mkQualModule, pkgQual, -- * Interfaces ModIface(..), mkIfaceWarnCache, mkIfaceHashCache, mkIfaceFixCache, @@ -637,7 +637,7 @@ data FindResult -- ^ The module was found | NoPackage PackageKey -- ^ The requested package was not found - | FoundMultiple [PackageKey] + | FoundMultiple [(Module, ModuleOrigin)] -- ^ _Error_: both in multiple packages -- | Not found @@ -654,7 +654,7 @@ data FindResult , fr_pkgs_hidden :: [PackageKey] -- Module is in these packages, -- but the *package* is hidden - , fr_suggestions :: [Module] -- Possible mis-spelled modules + , fr_suggestions :: [ModuleSuggestion] -- Possible mis-spelled modules } -- | Cache that remembers where we found a particular module. Contains both @@ -1499,6 +1499,13 @@ mkQualPackage dflags pkg_key (lookupPackage dflags pkg_key) pkgid = sourcePackageId pkg +-- | A function which only qualifies package names if necessary; but +-- qualifies all other identifiers. +pkgQual :: DynFlags -> PrintUnqualified +pkgQual dflags = alwaysQualify { + queryQualifyPackage = mkQualPackage dflags + } + \end{code} diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index 122919bb7b..78c8059046 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -2,7 +2,7 @@ % (c) The University of Glasgow, 2006 % \begin{code} -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} -- | Package manipulation module Packages ( @@ -23,6 +23,8 @@ module Packages ( lookupModuleInAllPackages, lookupModuleWithSuggestions, LookupResult(..), + ModuleSuggestion(..), + ModuleOrigin(..), -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -39,6 +41,8 @@ module Packages ( -- * Utils packageKeyPackageIdString, + pprFlag, + pprModuleMap, isDllName ) where @@ -64,6 +68,7 @@ import Distribution.ModuleExport import FastString import ErrUtils ( debugTraceMsg, putMsg, MsgDoc ) import Exception +import Unique import System.Directory import System.FilePath as FilePath @@ -72,6 +77,7 @@ import Control.Monad import Data.Char (isSpace) import Data.List as List import Data.Map (Map) +import Data.Monoid hiding ((<>)) import qualified Data.Map as Map import qualified FiniteMap as Map import qualified Data.Set as Set @@ -125,46 +131,117 @@ 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 (which could lead to ambiguity.) +-- 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! 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 + -- | Module is hidden, and thus never will be available for import. + -- (But maybe the user didn't realize), so we'll still keep track + -- of these modules.) + ModHidden + -- | Module is public, and could have come from some places. + | ModOrigin { + -- | @Just False@ means that this module is in + -- someone's @exported-modules@ list, but that package is hidden; + -- @Just True@ means that it is available; @Nothing@ means neither + -- applies. + fromOrigPackage :: Maybe Bool + -- | Is the module available from a reexport of an exposed package? + -- There could be multiple. + , fromExposedReexport :: [PackageConfig] + -- | Is the module available from a reexport of a hidden package? + , fromHiddenReexport :: [PackageConfig] + -- | Did the module export come from a package flag? (ToDo: track + -- more information. + , fromPackageFlag :: Bool + } + +instance Outputable ModuleOrigin where + ppr ModHidden = text "hidden module" + ppr (ModOrigin e res rhs f) = sep (punctuate comma ( + (case e of + Nothing -> [] + Just False -> [text "hidden package"] + Just True -> [text "exposed package"]) ++ + (if null res + then [] + else [text "reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (if null rhs + then [] + else [text "hidden reexport by" <+> + sep (map (ppr . packageConfigId) res)]) ++ + (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 @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 was bound by a package flag. +fromFlag :: ModuleOrigin +fromFlag = ModOrigin Nothing [] [] True + +instance Monoid ModuleOrigin where + mempty = ModOrigin Nothing [] [] False + mappend (ModOrigin e res rhs f) (ModOrigin e' res' rhs' f') = + ModOrigin (g e e') (res ++ res') (rhs ++ rhs') (f || f') + where g (Just b) (Just b') + | b == b' = Just b + | otherwise = panic "ModOrigin: package both exposed/hidden" + g Nothing x = x + g x Nothing = x + mappend _ _ = panic "ModOrigin: hidden module redefined" -- | 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 +originVisible :: ModuleOrigin -> Bool +originVisible ModHidden = False +originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f + +-- | Are there actually no providers for this module? This will never occur +-- except when we're filtering based on package imports. +originEmpty :: ModuleOrigin -> Bool +originEmpty (ModOrigin Nothing [] [] False) = True +originEmpty _ = False -- | 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] + SModConf Module PackageConfig ModuleOrigin | SModConfAmbiguous --- | Map from 'ModuleName' +-- | 'UniqFM' map from 'ModuleName' type ModuleNameMap = UniqFM --- | Map from 'PackageKey' +-- | 'UniqFM' map from 'PackageKey' type PackageKeyMap = UniqFM +-- | 'UniqFM' map from 'PackageKey' to 'PackageConfig' type PackageConfigMap = PackageKeyMap PackageConfig -type ModuleToPkgConfAll = Map ModuleName (Map Module [ModuleOrigin]) + +-- | 'UniqFM' map from 'PackageKey' to (1) whether or not all modules which +-- are exposed should be dumped into scope, (2) any custom renamings that +-- should also be apply, and (3) what package name is associated with the +-- key, if it might be hidden +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) data PackageState = PackageState { -- | A mapping of 'PackageKey' to 'PackageConfig'. This list is adjusted @@ -196,6 +273,7 @@ data PackageState = PackageState { type InstalledPackageIdMap = Map InstalledPackageId PackageKey type InstalledPackageIndex = Map InstalledPackageId PackageConfig +-- | Empty package configuration map emptyPackageConfigMap :: PackageConfigMap emptyPackageConfigMap = emptyUFM @@ -229,6 +307,7 @@ getPackageDetails dflags pid = listPackageConfigMap :: DynFlags -> [PackageConfig] listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags)) +-- | Looks up a 'PackageKey' given an 'InstalledPackageId' resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey resolveInstalledPackageId dflags ipid = expectJust "resolveInstalledPackageId" @@ -332,17 +411,12 @@ readPackageConfig dflags conf_file = do return pkg_configs2 setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] -setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs +setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs where - maybeHideAll pkgs' - | gopt Opt_HideAllPackages dflags = map hide pkgs' - | otherwise = pkgs' - maybeDistrustAll pkgs' | gopt Opt_DistrustAllPackages dflags = map distrust pkgs' | otherwise = pkgs' - hide pkg = pkg{ exposed = False } distrust pkg = pkg{ trusted = False } -- TODO: This code is duplicated in utils/ghc-pkg/Main.hs @@ -399,70 +473,88 @@ mungePackagePaths top_dir pkgroot pkg = -- Modify our copy of the package database based on a package flag -- (-package, -hide-package, -ignore-package). +-- | A horrible hack, the problem is the package key we'll turn +-- up here is going to get edited when we select the wired in +-- packages, so preemptively pick up the right one. Also, this elem +-- test is slow. The alternative is to change wired in packages first, but +-- then we are no longer able to match against package keys e.g. from when +-- a user passes in a package flag. +calcKey :: PackageConfig -> PackageKey +calcKey p | pk <- display (pkgName (sourcePackageId p)) + , pk `elem` wired_in_pkgids + = stringToPackageKey pk + | otherwise = packageConfigId p + applyPackageFlag :: DynFlags -> UnusablePackages - -> [PackageConfig] -- Initial database + -> ([PackageConfig], VisibilityMap) -- Initial database -> PackageFlag -- flag to apply - -> IO [PackageConfig] -- new database + -> IO ([PackageConfig], VisibilityMap) -- new database -applyPackageFlag dflags unusable pkgs flag = +-- ToDo: Unfortunately, we still have to plumb the package config through, +-- because Safe Haskell trust is still implemented by modifying the database. +-- Eventually, track that separately and then axe @[PackageConfig]@ from +-- this fold entirely + +applyPackageFlag dflags unusable (pkgs, vm) flag = case flag of - ExposePackage arg -> + ExposePackage arg m_rns -> case selectPackages (matching arg) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (p:ps,qs) -> return (p':ps') - where p' = p {exposed=True} - ps' = hideAll (pkgName (sourcePackageId p)) (ps++qs) + Right (p:_,_) -> return (pkgs, vm') + where + n = fsPackageName p + vm' = addToUFM_C edit vm_cleared (calcKey p) + (case m_rns of + Nothing -> (True, [], n) + Just rns' -> (False, map convRn rns', n)) + edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n) + convRn (a,b) = (mkModuleName a, mkModuleName b) + -- ToDo: ATM, -hide-all-packages implicitly triggers change in + -- behavior, maybe eventually make it toggleable with a separate + -- flag + vm_cleared | gopt Opt_HideAllPackages dflags = vm + -- NB: -package foo-0.1 (Foo as Foo1) does NOT hide + -- other versions of foo. Presence of renaming means + -- user probably wanted both. + | Just _ <- m_rns = vm + | otherwise = filterUFM_Directly + (\k (_,_,n') -> k == getUnique (calcKey p) + || n /= n') vm _ -> panic "applyPackageFlag" HidePackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (ps,qs) -> return (map hide ps ++ qs) - where hide p = p {exposed=False} + Right (ps,_) -> return (pkgs, vm') + where vm' = delListFromUFM vm (map calcKey ps) -- we trust all matching packages. Maybe should only trust first one? -- and leave others the same or set them untrusted TrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (ps,qs) -> return (map trust ps ++ qs) + Right (ps,qs) -> return (map trust ps ++ qs, vm) where trust p = p {trusted=True} DistrustPackage str -> case selectPackages (matchingStr str) pkgs unusable of Left ps -> packageFlagErr dflags flag ps - Right (ps,qs) -> return (map distrust ps ++ qs) + Right (ps,qs) -> return (map distrust ps ++ qs, vm) where distrust p = p {trusted=False} IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage" - where - -- When a package is requested to be exposed, we hide all other - -- packages with the same name if -hide-all-packages was not specified. - -- If it was specified, we expect users to not try to expose a package - -- multiple times, so don't hide things. - hideAll name ps = map maybe_hide ps - where maybe_hide p - | gopt Opt_HideAllPackages dflags = p - | pkgName (sourcePackageId p) == name = p {exposed=False} - | otherwise = p - - selectPackages :: (PackageConfig -> Bool) -> [PackageConfig] -> UnusablePackages -> Either [(PackageConfig, UnusablePackageReason)] ([PackageConfig], [PackageConfig]) selectPackages matches pkgs unusable - = let - (ps,rest) = partition matches pkgs - reasons = [ (p, Map.lookup (installedPackageId p) unusable) - | p <- ps ] - in - if all (isJust.snd) reasons - then Left [ (p, reason) | (p,Just reason) <- reasons ] - else Right (sortByVersion [ p | (p,Nothing) <- reasons ], rest) + = let (ps,rest) = partition matches pkgs + in if null ps + then Left (filter (matches.fst) (Map.elems unusable)) + else Right (sortByVersion ps, rest) -- A package named on the command line can either include the -- version, or just the name if it is unambiguous. @@ -495,7 +587,8 @@ packageFlagErr :: DynFlags -- for missing DPH package we emit a more helpful error message, because -- this may be the result of using -fdph-par or -fdph-seq. -packageFlagErr dflags (ExposePackage (PackageArg pkg)) [] | is_dph_package pkg +packageFlagErr dflags (ExposePackage (PackageArg pkg) _) [] + | is_dph_package pkg = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ dph_err)) where dph_err = text "the " <> text pkg <> text " package is not installed." $$ text "To install it: \"cabal install dph\"." @@ -503,56 +596,37 @@ packageFlagErr dflags (ExposePackage (PackageArg pkg)) [] | is_dph_package pkg packageFlagErr dflags flag reasons = throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err)) - where err = text "cannot satisfy " <> ppr_flag <> + where err = text "cannot satisfy " <> pprFlag flag <> (if null reasons then empty else text ": ") $$ nest 4 (ppr_reasons $$ -- ToDo: this admonition seems a bit dodgy text "(use -v for more information)") - ppr_flag = case flag of - IgnorePackage p -> text "-ignore-package " <> text p - HidePackage p -> text "-hide-package " <> text p - ExposePackage a -> ppr_arg a - TrustPackage p -> text "-trust " <> text p - DistrustPackage p -> text "-distrust " <> text p - ppr_arg arg = case arg of - PackageArg p -> text "-package " <> text p - PackageIdArg p -> text "-package-id " <> text p - PackageKeyArg p -> text "-package-key " <> text p ppr_reasons = vcat (map ppr_reason reasons) ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason --- ----------------------------------------------------------------------------- --- Hide old versions of packages - --- --- hide all packages for which there is also a later version --- that is already exposed. This just makes it non-fatal to have two --- versions of a package exposed, which can happen if you install a --- later version of a package in the user database, for example. --- However, don't do this if @-hide-all-packages@ was passed. --- -hideOldPackages :: DynFlags -> [PackageConfig] -> IO [PackageConfig] -hideOldPackages dflags pkgs = mapM maybe_hide pkgs - where maybe_hide p - | gopt Opt_HideAllPackages dflags = return p - | not (exposed p) = return p - | (p' : _) <- later_versions = do - debugTraceMsg dflags 2 $ - (ptext (sLit "hiding package") <+> pprSPkg p <+> - ptext (sLit "to avoid conflict with later version") <+> - pprSPkg p') - return (p {exposed=False}) - | otherwise = return p - where myname = pkgName (sourcePackageId p) - myversion = pkgVersion (sourcePackageId p) - later_versions = [ p | p <- pkgs, exposed p, - let pkg = sourcePackageId p, - pkgName pkg == myname, - pkgVersion pkg > myversion ] +pprFlag :: PackageFlag -> SDoc +pprFlag flag = case flag of + IgnorePackage p -> text "-ignore-package " <> text p + HidePackage p -> text "-hide-package " <> text p + ExposePackage a rns -> ppr_arg a <> ppr_rns rns + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p + where ppr_arg arg = case arg of + PackageArg p -> text "-package " <> text p + PackageIdArg p -> text "-package-id " <> text p + PackageKeyArg p -> text "-package-key " <> text p + ppr_rns Nothing = empty + ppr_rns (Just rns) = char '(' <> hsep (punctuate comma (map ppr_rn rns)) + <> char ')' + ppr_rn (orig, new) | orig == new = text orig + | otherwise = text orig <+> text "as" <+> text new -- ----------------------------------------------------------------------------- -- Wired-in packages +wired_in_pkgids :: [String] +wired_in_pkgids = map packageKeyString wiredInPackageKeys + findWiredInPackages :: DynFlags -> [PackageConfig] -- database @@ -564,9 +638,6 @@ findWiredInPackages dflags pkgs = do -- their canonical names (eg. base-1.0 ==> base). -- let - wired_in_pkgids :: [String] - wired_in_pkgids = map packageKeyString wiredInPackageKeys - matches :: PackageConfig -> String -> Bool pc `matches` pid = display (pkgName (sourcePackageId pc)) == pid @@ -576,9 +647,10 @@ findWiredInPackages dflags pkgs = do -- one. -- -- When choosing which package to map to a wired-in package - -- name, we prefer exposed packages, and pick the latest - -- version. To override the default choice, -hide-package - -- could be used to hide newer versions. + -- name, we pick the latest version (modern Cabal makes it difficult + -- to install multiple versions of wired-in packages, however!) + -- To override the default choice, -ignore-package could be used to + -- hide newer versions. -- findWiredInPackage :: [PackageConfig] -> String -> IO (Maybe InstalledPackageId) @@ -640,7 +712,8 @@ data UnusablePackageReason | MissingDependencies [InstalledPackageId] | ShadowedBy InstalledPackageId -type UnusablePackages = Map InstalledPackageId UnusablePackageReason +type UnusablePackages = Map InstalledPackageId + (PackageConfig, UnusablePackageReason) pprReason :: SDoc -> UnusablePackageReason -> SDoc pprReason pref reason = case reason of @@ -656,7 +729,7 @@ pprReason pref reason = case reason of reportUnusable :: DynFlags -> UnusablePackages -> IO () reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs) where - report (ipid, reason) = + report (ipid, (_, reason)) = debugTraceMsg dflags 2 $ pprReason (ptext (sLit "package") <+> @@ -676,7 +749,7 @@ findBroken pkgs = go [] Map.empty pkgs go avail ipids not_avail = case partitionWith (depsAvailable ipids) not_avail of ([], not_avail) -> - Map.fromList [ (installedPackageId p, MissingDependencies deps) + Map.fromList [ (installedPackageId p, (p, MissingDependencies deps)) | (p,deps) <- not_avail ] (new_avail, not_avail) -> go (new_avail ++ avail) new_ipids (map fst not_avail) @@ -712,8 +785,8 @@ shadowPackages pkgs preferred -- , ipid_old /= ipid_new = if ipid_old `elem` preferred - then ( (ipid_new, ShadowedBy ipid_old) : shadowed, pkgmap ) - else ( (ipid_old, ShadowedBy ipid_new) : shadowed, pkgmap' ) + then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap) + else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap') | otherwise = (shadowed, pkgmap') where @@ -727,7 +800,7 @@ ignorePackages flags pkgs = Map.fromList (concatMap doit flags) where doit (IgnorePackage str) = case partition (matchingStr str) pkgs of - (ps, _) -> [ (installedPackageId p, IgnoredWithFlag) + (ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag)) | p <- ps ] -- missing package is not an error for -ignore-package, -- because a common usage is to -ignore-package P as @@ -825,29 +898,62 @@ mkPackageState dflags pkgs0 preload0 this_package = do ipid_selected = depClosure ipid_map [ InstalledPackageId i - | ExposePackage (PackageIdArg i) <- flags ] + | ExposePackage (PackageIdArg i) _ <- flags ] (ignore_flags, other_flags) = partition is_ignore flags is_ignore IgnorePackage{} = True is_ignore _ = False shadowed = shadowPackages pkgs0_unique ipid_selected - ignored = ignorePackages ignore_flags pkgs0_unique - pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique + isBroken = (`Map.member` (Map.union shadowed ignored)).installedPackageId + pkgs0' = filter (not . isBroken) pkgs0_unique + broken = findBroken pkgs0' + unusable = shadowed `Map.union` ignored `Map.union` broken + pkgs1 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs0' reportUnusable dflags unusable -- + -- Calculate the initial set of packages, prior to any package flags. + -- This set contains the latest version of all valid (not unusable) packages, + -- or is empty if we have -hide-all-packages + -- + let preferLater pkg pkg' = + case comparing (pkgVersion.sourcePackageId) pkg pkg' of + GT -> pkg + _ -> pkg' + calcInitial m pkg = addToUFM_C preferLater m (fsPackageName pkg) pkg + initial = if gopt Opt_HideAllPackages dflags + then emptyUFM + else foldl' calcInitial emptyUFM pkgs1 + vis_map0 = foldUFM (\p vm -> + if exposed p + then addToUFM vm (calcKey p) + (True, [], fsPackageName p) + else vm) + emptyUFM initial + + -- -- Modify the package database according to the command-line flags -- (-package, -hide-package, -ignore-package, -hide-all-packages). + -- This needs to know about the unusable packages, since if a user tries + -- to enable an unusable package, we should let them know. -- - pkgs1 <- foldM (applyPackageFlag dflags unusable) pkgs0_unique other_flags - let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1 + (pkgs2, vis_map) <- foldM (applyPackageFlag dflags unusable) + (pkgs1, vis_map0) other_flags + -- + -- Sort out which packages are wired in. This has to be done last, since + -- it modifies the package keys of wired in packages, but when we process + -- package arguments we need to key against the old versions. + -- + pkgs3 <- findWiredInPackages dflags pkgs2 + + -- -- Here we build up a set of the packages mentioned in -package -- flags on the command line; these are called the "preload" -- packages. we link these packages in eagerly. The preload set @@ -856,21 +962,15 @@ mkPackageState dflags pkgs0 preload0 this_package = do -- let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ] - get_exposed (ExposePackage a) = take 1 . sortByVersion - . filter (matching a) - $ pkgs2 + get_exposed (ExposePackage a _) = take 1 . sortByVersion + . filter (matching a) + $ pkgs2 get_exposed _ = [] - -- hide packages that are subsumed by later versions - pkgs3 <- hideOldPackages dflags pkgs2 - - -- sort out which packages are wired in - pkgs4 <- findWiredInPackages dflags pkgs3 - - let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4 + let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3 ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p) - | p <- pkgs4 ] + | p <- pkgs3 ] lookupIPID ipid@(InstalledPackageId str) | Just pid <- Map.lookup ipid ipid_map = return pid @@ -898,82 +998,115 @@ mkPackageState dflags pkgs0 preload0 this_package = do let pstate = PackageState{ preloadPackages = dep_preload, pkgIdMap = pkg_db, - moduleToPkgConf = mkModuleToPkgConf pkg_db ipid_map, - moduleToPkgConfAll = mkModuleToPkgConfAll pkg_db ipid_map, -- lazy! + moduleToPkgConf = mkModuleToPkgConf dflags pkg_db ipid_map vis_map, + moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map, installedPackageIdMap = ipid_map } - return (pstate, new_dep_preload, this_package) -- ----------------------------------------------------------------------------- -- | Makes the mapping from module to package info --- | Creates the minimal lookup, which is sufficient if we don't need to --- report errors. -mkModuleToPkgConf - :: PackageConfigMap +-- | This function is generic; we instantiate it +mkModuleToPkgConfGeneric + :: forall m e. + -- Empty map, e.g. the initial state of the output + m e + -- How to create an entry in the map based on the calculated information + -> (PackageKey -> ModuleName -> PackageConfig -> ModuleOrigin -> e) + -- How to override the origin of an entry (used for renaming) + -> (e -> ModuleOrigin -> e) + -- How to incorporate a list of entries into the map + -> (m e -> [(ModuleName, e)] -> m e) + -- The proper arguments + -> DynFlags + -> PackageConfigMap -> InstalledPackageIdMap - -> ModuleNameMap SimpleModuleConf -mkModuleToPkgConf pkg_db ipid_map = - foldl' extend_modmap emptyUFM (eltsUFM pkg_db) - where - 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, SModConf (mkModule pk' m') pkg' [FromReexportedModules{ - theReexporter = pkg, - theOriginal = pkg' - }]) - | ModuleExport{ exportName = m - , exportCachedTrueOrig = Just (ipid', m')} - <- reexported_mods - , 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 - --- | 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) + -> VisibilityMap + -> m e +mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo + dflags pkg_db ipid_map vis_map = + foldl' extend_modmap emptyMap (eltsUFM pkg_db) where - extend_modmap m pkg = foldl' merge m es + extend_modmap modmap pkg = addListTo modmap theBindings 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'}]) + theBindings :: [(ModuleName, e)] + theBindings | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg) + = newBindings b rns + | otherwise = newBindings False [] + + newBindings :: Bool -> [(ModuleName, ModuleName)] -> [(ModuleName, e)] + newBindings e rns = es e ++ hiddens ++ map rnBinding rns + + rnBinding :: (ModuleName, ModuleName) -> (ModuleName, e) + rnBinding (orig, new) = (new, setOrigins origEntry fromFlag) + 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, e)] + es e = + [(m, sing pk m pkg (fromExposedModules e)) | m <- exposed_mods] ++ + [(m, sing pk' m' pkg' (fromReexportedModules e pkg)) | ModuleExport{ exportName = m , exportCachedTrueOrig = Just (ipid', m')} <- reexported_mods - , let pk' = expectJust "mkModuleToPkgConfAll/i" (Map.lookup ipid' ipid_map) + , let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map) pkg' = pkg_lookup pk' ] + + esmap :: UniqFM e + esmap = listToUFM (es False) -- parameter here doesn't matter, orig will + -- be overwritten + + hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods] + pk = packageConfigId pkg - pkg_lookup = expectJust "mkModuleToPkgConfAll" . lookupPackage' pkg_db + pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db + exposed_mods = exposedModules pkg reexported_mods = reexportedModules pkg - hidden_mods = hiddenModules pkg + hidden_mods = hiddenModules pkg -pprSPkg :: PackageConfig -> SDoc -pprSPkg p = text (display (sourcePackageId p)) +-- | This is a quick and efficient module map, which only contains an entry +-- if it is specified unambiguously. +mkModuleToPkgConf + :: DynFlags + -> PackageConfigMap + -> InstalledPackageIdMap + -> VisibilityMap + -> ModuleNameMap SimpleModuleConf +mkModuleToPkgConf = + mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo + where emptyMap = emptyUFM + sing pk m pkg = SModConf (mkModule pk m) pkg + -- NB: don't put hidden entries in the map, they're not valid! + addListTo m xs = addListToUFM_C merge m (filter isVisible xs) + isVisible (_, SModConf _ _ o) = originVisible o + isVisible (_, SModConfAmbiguous) = False + merge (SModConf m pkg o) (SModConf m' _ o') + | m == m' = SModConf m pkg (o `mappend` o') + | otherwise = SModConfAmbiguous + merge _ _ = SModConfAmbiguous + setOrigins (SModConf m pkg _) os = SModConf m pkg os + setOrigins SModConfAmbiguous _ = SModConfAmbiguous + +-- | This is a slow and complete map, which includes information about +-- everything, including hidden modules +mkModuleToPkgConfAll + :: DynFlags + -> PackageConfigMap + -> InstalledPackageIdMap + -> VisibilityMap + -> ModuleToPkgConfAll +mkModuleToPkgConfAll = + mkModuleToPkgConfGeneric emptyMap sing setOrigins addListTo + where emptyMap = Map.empty + 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 pprIPkg :: PackageConfig -> SDoc pprIPkg p = text (display (installedPackageId p)) @@ -1083,7 +1216,9 @@ lookupModuleInAllPackages :: DynFlags lookupModuleInAllPackages dflags m = case lookupModuleWithSuggestions dflags m Nothing of LookupFound a b -> [(a,b)] - LookupMultiple rs -> rs + LookupMultiple rs -> map f rs + where f (m,_) = (m, expectJust "lookupModule" (lookupPackage dflags + (modulePackageKey m))) _ -> [] -- | The result of performing a lookup @@ -1091,13 +1226,16 @@ data LookupResult = -- | Found the module uniquely, nothing else to do LookupFound Module PackageConfig -- | Multiple modules with the same name in scope - | LookupMultiple [(Module, PackageConfig)] + | LookupMultiple [(Module, ModuleOrigin)] -- | 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)] + | LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)] -- | Nothing found, here are some suggested different names - | LookupNotFound [Module] -- suggestions + | LookupNotFound [ModuleSuggestion] -- suggestions + +data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin + | SuggestHidden ModuleName Module ModuleOrigin lookupModuleWithSuggestions :: DynFlags -> ModuleName @@ -1105,55 +1243,71 @@ lookupModuleWithSuggestions :: DynFlags -> 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 + Just (SModConf m pkg o) | matches mb_pn pkg o -> + ASSERT( originVisible o ) 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 + Just xs -> + case foldl' classify ([],[],[]) (Map.toList xs) of + ([], [], []) -> LookupNotFound suggestions + -- NB: Yes, we have to check this case too, since package qualified + -- imports could cause the main lookup to fail due to ambiguity, + -- but the second lookup to succeed. + (_, _, [(m, _)]) -> LookupFound m (mod_pkg m) + (_, _, exposed@(_:_)) -> LookupMultiple exposed + (hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod where - -- ToDo: this will be wrong when we add flag renaming + classify (hidden_pkg, hidden_mod, exposed) (m, origin0) = + let origin = filterOrigin mb_pn (mod_pkg m) origin0 + x = (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) + + pkg_lookup = expectJust "lookupModuleWithSuggestions" . lookupPackage dflags + pkg_state = pkgState dflags + mod_pkg = pkg_lookup . modulePackageKey - -- 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] ] + matches Nothing _ _ = True -- shortcut for efficiency + matches mb_pn pkg o = originVisible (filterOrigin mb_pn pkg o) - pkg_state = pkgState dflags + -- Filters out origins which are not associated with the given package + -- qualifier. No-op if there is no package qualifier. Test if this + -- excluded all origins with 'originEmpty'. + filterOrigin :: Maybe FastString + -> PackageConfig + -> ModuleOrigin + -> ModuleOrigin + filterOrigin Nothing _ o = o + filterOrigin (Just pn) pkg o = + case o of + ModHidden -> if go pkg then ModHidden else mempty + ModOrigin { fromOrigPackage = e, fromExposedReexport = res, + fromHiddenReexport = rhs } + -> ModOrigin { + fromOrigPackage = if go pkg then e else Nothing + , fromExposedReexport = filter go res + , fromHiddenReexport = filter go rhs + , fromPackageFlag = False -- always excluded + } + where go pkg = pn == fsPackageName pkg suggestions | gopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods | otherwise = [] - all_mods :: [(String, Module)] -- All modules - 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 + all_mods :: [(String, ModuleSuggestion)] -- All modules + all_mods = sortBy (comparing fst) $ + [ (moduleNameString m, suggestion) + | (m, e) <- Map.toList (moduleToPkgConfAll (pkgState dflags)) + , suggestion <- map (getSuggestion m) (Map.toList e) + ] + getSuggestion name (mod, origin) = + (if originVisible origin then SuggestVisible else SuggestHidden) + name mod origin listVisibleModuleNames :: DynFlags -> [ModuleName] listVisibleModuleNames dflags = @@ -1296,4 +1450,18 @@ simpleDumpPackages = dumpPackages' showIPI t = if trusted ipi then "T" else " " in e ++ t ++ " " ++ i +-- | Show the mapping of modules to where they come from. +pprModuleMap :: DynFlags -> SDoc +pprModuleMap dflags = + vcat (map pprLine (Map.toList (moduleToPkgConfAll (pkgState dflags)))) + where + pprLine (m,e) = ppr m $$ nest 50 (vcat (map (pprEntry m) (Map.toList e))) + pprEntry m (m',o) + | m == moduleName m' = ppr (modulePackageKey m') <+> parens (ppr o) + | otherwise = ppr m' <+> parens (ppr o) + +fsPackageName :: PackageConfig -> FastString +fsPackageName pkg = case packageName (sourcePackageId pkg) of + PackageName n -> mkFastString n + \end{code} diff --git a/docs/users_guide/glasgow_exts.xml b/docs/users_guide/glasgow_exts.xml index 3d2e634c51..00f43153eb 100644 --- a/docs/users_guide/glasgow_exts.xml +++ b/docs/users_guide/glasgow_exts.xml @@ -2461,7 +2461,7 @@ warns if you hide something that the imported module does not export. </sect3> <sect3> - <title>Package-qualified imports</title> + <title id="package-qualified-imports">Package-qualified imports</title> <para>With the <option>-XPackageImports</option> flag, GHC allows import declarations to be qualified by the package name that the @@ -2484,7 +2484,9 @@ import "network" Network.Socket added mainly so that we can build backwards-compatible versions of packages when APIs change. It can lead to fragile dependencies in the common case: modules occasionally move from one package to - another, rendering any package-qualified imports broken.</para> + another, rendering any package-qualified imports broken. + See also <xref linkend="package-thinning-and-renaming" /> for + an alternative way of disambiguating between module names.</para> </sect3> <sect3 id="safe-imports-ext"> diff --git a/docs/users_guide/packages.xml b/docs/users_guide/packages.xml index 50549b409c..ee29cb1c2f 100644 --- a/docs/users_guide/packages.xml +++ b/docs/users_guide/packages.xml @@ -88,7 +88,11 @@ $ ghc-pkg list to expose a hidden package or hide an exposed one. Only modules from exposed packages may be imported by your Haskell code; if you try to import a module from a hidden package, GHC will emit - an error message. + an error message. If there are a multiple exposed versions of a package, + GHC will prefer the latest one. Additionally, some packages may be + broken: that is, they are missing from the package database, or one of + their dependencies are broken; in this case; these packages are excluded + from the default set of packages. </para> <para> @@ -137,8 +141,11 @@ exposed-modules: Network.BSD, (e.g. <literal>network-1.0</literal>) or the version number can be omitted if there is only one version of the package installed. If there are multiple versions - of <replaceable>P</replaceable> installed, then all other - versions will become hidden.</para> + of <replaceable>P</replaceable> installed and + <option>-hide-all-packages</option> was not specified, then all + other versions will become hidden. <option>-package</option> + supports thinning and renaming described in <xref + linkend="package-thinning-and-renaming" />.</para> <para>The <option>-package <replaceable>P</replaceable></option> option also causes package <replaceable>P</replaceable> to @@ -187,6 +194,8 @@ exposed-modules: Network.BSD, more robust way to name packages, and can be used to select packages that would otherwise be shadowed. Cabal passes <option>-package-id</option> flags to GHC. + <option>-package-id</option> supports thinning and renaming + described in <xref linkend="package-thinning-and-renaming" />. </para> </listitem> </varlistentry> @@ -363,6 +372,52 @@ _ZCMain_main_closure name.</para> </sect2> + <sect2 id="package-thinning-and-renaming"> + <title>Thinning and renaming modules</title> + + <para>When incorporating packages from multiple sources, you may end up + in a situation where multiple packages publish modules with the same name. + Previously, the only way to distinguish between these modules was to + use <xref linkend="package-qualified-imports" />. However, since GHC 7.10, + the <option>-package</option> flags (and their variants) have been extended + to allow a user to explicitly control what modules a package brings into + scope, by analogy to the import lists that users can attach to module imports. + </para> + + <para> + The basic syntax is that instead of specifying a package name P to the package + flag <literal>-package</literal>, instead we specify both a package name and a + parenthesized, comma-separated list of module names to import. For example, + <literal>-package "base (Data.List, Data.Bool)"</literal> makes only + <literal>Data.List</literal> and <literal>Data.Bool</literal> visible from + package <literal>base</literal>. + We also support renaming of modules, in case you need to refer to both modules + simultaneously; this is supporting by writing <literal>OldModName as + NewModName</literal>, e.g. <literal>-package "base (Data.Bool as + Bool)</literal>. It's important to specify quotes + so that your shell passes the package name and thinning/renaming list as a + single argument to GHC.</para> + + <para>Package imports with thinning/renaming do not hide other versions of the + package: e.g. if containers-0.9 is already exposed, <literal>-package + "containers-0.8 (Data.List as ListV8)"</literal> will only add an additional + binding to the environment. Similarly, <literal>-package "base (Data.Bool as + Bool)" -package "base (Data.List as List)"</literal> is equivalent to + <literal>-package "base (Data.Bool as Bool, Data.List as List)"</literal>. + Literal names must refer to modules defined by the original package, so for + example <literal>-package "base (Data.Bool as Bool, Bool as Baz)"</literal> is + invalid unless there was a <literal>Bool</literal> module defined in the + original package. Hiding a package also clears all of its renamings. </para> + + <para> + You can use renaming to provide an alternate prelude, e.g. + <literal>-hide-all-packages -package "basic-prelude (BasicPrelude as + Prelude)"</literal>, in lieu of the <xref + linkend="rebindable-syntax">NoImplicitPrelude</xref> extension. + </para> + + </sect2> + <sect2 id="package-databases"> <title>Package Databases</title> diff --git a/ghc/InteractiveUI.hs b/ghc/InteractiveUI.hs index f42d47a51d..386d4df17d 100644 --- a/ghc/InteractiveUI.hs +++ b/ghc/InteractiveUI.hs @@ -39,7 +39,7 @@ import HscTypes ( tyThingParent_maybe, handleFlagWarnings, getSafeMode, hsc_IC, setInteractivePrintName ) import Module import Name -import Packages ( trusted, getPackageDetails, listVisibleModuleNames ) +import Packages ( trusted, getPackageDetails, listVisibleModuleNames, pprFlag ) import PprTyThing import RdrName ( getGRE_NameQualifier_maybes ) import SrcLoc @@ -2333,15 +2333,7 @@ showPackages = do let pkg_flags = packageFlags dflags liftIO $ putStrLn $ showSDoc dflags $ vcat $ text ("active package flags:"++if null pkg_flags then " none" else "") - : map showFlag pkg_flags - where showFlag (ExposePackage a) = text $ showArg a - showFlag (HidePackage p) = text $ " -hide-package " ++ p - showFlag (IgnorePackage p) = text $ " -ignore-package " ++ p - showFlag (TrustPackage p) = text $ " -trust " ++ p - showFlag (DistrustPackage p) = text $ " -distrust " ++ p - showArg (PackageArg p) = " -package " ++ p - showArg (PackageIdArg p) = " -package-id " ++ p - showArg (PackageKeyArg p) = " -package-key " ++ p + : map pprFlag pkg_flags showPaths :: GHCi () showPaths = do diff --git a/ghc/Main.hs b/ghc/Main.hs index 2bb156c5b9..70dde39824 100644 --- a/ghc/Main.hs +++ b/ghc/Main.hs @@ -33,7 +33,7 @@ import InteractiveUI ( interactiveUI, ghciWelcomeMsg, defaultGhciSettings ) import Config import Constants import HscTypes -import Packages ( dumpPackages, simpleDumpPackages ) +import Packages ( dumpPackages, simpleDumpPackages, pprModuleMap ) import DriverPhases import BasicTypes ( failed ) import StaticFlags @@ -217,6 +217,11 @@ main' postLoadMode dflags0 args flagWarnings = do when (verbosity dflags6 >= 3) $ do liftIO $ hPutStrLn stderr ("Hsc static flags: " ++ unwords staticFlags) + + when (dopt Opt_D_dump_mod_map dflags6) . liftIO $ + printInfoForUser (dflags6 { pprCols = 200 }) + (pkgQual dflags6) (pprModuleMap dflags6) + ---------------- Final sanity checking ----------- liftIO $ checkOptions postLoadMode dflags6 srcs objs diff --git a/testsuite/tests/ghci/scripts/T5979.stderr b/testsuite/tests/ghci/scripts/T5979.stderr index fe6e012603..bbdba12305 100644 --- a/testsuite/tests/ghci/scripts/T5979.stderr +++ b/testsuite/tests/ghci/scripts/T5979.stderr @@ -1,4 +1,7 @@ <no location info>: Could not find module ‘Control.Monad.Trans.State’ - It is not a module in the current program, or in any known package. + Perhaps you meant + Control.Monad.Trans.State (from transformers-0.4.1.0@trans_ATJ404cg3uBDx7JJZaSn1I) + Control.Monad.Trans.Class (from transformers-0.4.1.0@trans_ATJ404cg3uBDx7JJZaSn1I) + Control.Monad.Trans.Cont (from transformers-0.4.1.0@trans_ATJ404cg3uBDx7JJZaSn1I) diff --git a/testsuite/tests/package/Makefile b/testsuite/tests/package/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/package/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/package/all.T b/testsuite/tests/package/all.T new file mode 100644 index 0000000000..cb30949124 --- /dev/null +++ b/testsuite/tests/package/all.T @@ -0,0 +1,21 @@ +setTestOpts(only_compiler_types(['ghc'])) + +hide_all = '-hide-all-packages -XNoImplicitPrelude ' +incr_containers = '-package "containers (Data.Map as Map, Data.Set)" ' +inc_containers = '-package containers ' +incr_ghc = '-package "ghc (HsTypes as MyHsTypes, HsUtils)" ' +inc_ghc = '-package ghc ' +hide_ghc = '-hide-package ghc ' + +test('package01', normal, compile, [hide_all + incr_containers]) +test('package01e', normal, compile_fail, [hide_all + incr_containers]) +test('package02', normal, compile, [hide_all + inc_containers + incr_containers]) +test('package03', normal, compile, [hide_all + incr_containers + inc_containers]) +test('package04', normal, compile, [incr_containers]) +test('package05', normal, compile, [incr_ghc + inc_ghc]) +test('package06', normal, compile, [incr_ghc]) +test('package06e', normal, compile_fail, [incr_ghc]) +test('package07e', normal, compile_fail, [incr_ghc + inc_ghc + hide_ghc]) +test('package08e', normal, compile_fail, [incr_ghc + hide_ghc]) +test('package09e', normal, compile_fail, ['-package "containers (Data.Map as M, Data.Set as M)"']) +test('package10', normal, compile, ['-hide-all-packages -package "ghc (UniqFM as Prelude)" ']) diff --git a/testsuite/tests/package/package01.hs b/testsuite/tests/package/package01.hs new file mode 100644 index 0000000000..0fdd41146f --- /dev/null +++ b/testsuite/tests/package/package01.hs @@ -0,0 +1,3 @@ +module Package01 where +import Map +import Data.Set diff --git a/testsuite/tests/package/package01e.hs b/testsuite/tests/package/package01e.hs new file mode 100644 index 0000000000..946d400f78 --- /dev/null +++ b/testsuite/tests/package/package01e.hs @@ -0,0 +1,3 @@ +module Package01e where +import Data.Map +import Data.IntMap diff --git a/testsuite/tests/package/package01e.stderr b/testsuite/tests/package/package01e.stderr new file mode 100644 index 0000000000..232ec6ce2d --- /dev/null +++ b/testsuite/tests/package/package01e.stderr @@ -0,0 +1,10 @@ + +package01e.hs:2:1: + Failed to load interface for ‘Data.Map’ + It is a member of the hidden package ‘containers-0.5.5.1’. + Use -v to see a list of the files searched for. + +package01e.hs:3:1: + Failed to load interface for ‘Data.IntMap’ + It is a member of the hidden package ‘containers-0.5.5.1’. + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package02.hs b/testsuite/tests/package/package02.hs new file mode 100644 index 0000000000..ea06404935 --- /dev/null +++ b/testsuite/tests/package/package02.hs @@ -0,0 +1,5 @@ +module Package02 where +import Data.Map +import Map +import Data.Set +import Data.IntMap diff --git a/testsuite/tests/package/package03.hs b/testsuite/tests/package/package03.hs new file mode 100644 index 0000000000..d81dc3e037 --- /dev/null +++ b/testsuite/tests/package/package03.hs @@ -0,0 +1,5 @@ +module Package03 where +import Data.Map +import Map +import Data.Set +import Data.IntMap diff --git a/testsuite/tests/package/package04.hs b/testsuite/tests/package/package04.hs new file mode 100644 index 0000000000..85c2cae05a --- /dev/null +++ b/testsuite/tests/package/package04.hs @@ -0,0 +1,5 @@ +module Package04 where +import Data.Map +import Map +import Data.Set +import Data.IntMap diff --git a/testsuite/tests/package/package05.hs b/testsuite/tests/package/package05.hs new file mode 100644 index 0000000000..3b0069c5d5 --- /dev/null +++ b/testsuite/tests/package/package05.hs @@ -0,0 +1,4 @@ +module Package05 where +import HsTypes +import MyHsTypes +import HsUtils diff --git a/testsuite/tests/package/package06.hs b/testsuite/tests/package/package06.hs new file mode 100644 index 0000000000..096b81b7ba --- /dev/null +++ b/testsuite/tests/package/package06.hs @@ -0,0 +1,3 @@ +module Package06 where +import MyHsTypes +import HsUtils diff --git a/testsuite/tests/package/package06e.hs b/testsuite/tests/package/package06e.hs new file mode 100644 index 0000000000..6feaebda62 --- /dev/null +++ b/testsuite/tests/package/package06e.hs @@ -0,0 +1,3 @@ +module Package06e where +import HsTypes +import UniqFM diff --git a/testsuite/tests/package/package06e.stderr b/testsuite/tests/package/package06e.stderr new file mode 100644 index 0000000000..2d4945549e --- /dev/null +++ b/testsuite/tests/package/package06e.stderr @@ -0,0 +1,10 @@ + +package06e.hs:2:1: + Failed to load interface for ‘HsTypes’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package06e.hs:3:1: + Failed to load interface for ‘UniqFM’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package07e.hs b/testsuite/tests/package/package07e.hs new file mode 100644 index 0000000000..85bb723989 --- /dev/null +++ b/testsuite/tests/package/package07e.hs @@ -0,0 +1,5 @@ +module Package07e where +import MyHsTypes +import HsTypes +import HsUtils +import UniqFM diff --git a/testsuite/tests/package/package07e.stderr b/testsuite/tests/package/package07e.stderr new file mode 100644 index 0000000000..6a72a2e89c --- /dev/null +++ b/testsuite/tests/package/package07e.stderr @@ -0,0 +1,20 @@ + +package07e.hs:2:1: + Failed to load interface for ‘MyHsTypes’ + Perhaps you meant HsTypes (needs flag -package-key ghc) + Use -v to see a list of the files searched for. + +package07e.hs:3:1: + Failed to load interface for ‘HsTypes’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package07e.hs:4:1: + Failed to load interface for ‘HsUtils’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package07e.hs:5:1: + Failed to load interface for ‘UniqFM’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package08e.hs b/testsuite/tests/package/package08e.hs new file mode 100644 index 0000000000..40f814449a --- /dev/null +++ b/testsuite/tests/package/package08e.hs @@ -0,0 +1,5 @@ +module Package08e where +import MyHsTypes +import HsTypes +import HsUtils +import UniqFM diff --git a/testsuite/tests/package/package08e.stderr b/testsuite/tests/package/package08e.stderr new file mode 100644 index 0000000000..a7e8433f7a --- /dev/null +++ b/testsuite/tests/package/package08e.stderr @@ -0,0 +1,20 @@ + +package08e.hs:2:1: + Failed to load interface for ‘MyHsTypes’ + Perhaps you meant HsTypes (needs flag -package-key ghc) + Use -v to see a list of the files searched for. + +package08e.hs:3:1: + Failed to load interface for ‘HsTypes’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package08e.hs:4:1: + Failed to load interface for ‘HsUtils’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. + +package08e.hs:5:1: + Failed to load interface for ‘UniqFM’ + It is a member of the hidden package ‘ghc’. + Use -v to see a list of the files searched for. diff --git a/testsuite/tests/package/package09e.hs b/testsuite/tests/package/package09e.hs new file mode 100644 index 0000000000..8f08bbd5b2 --- /dev/null +++ b/testsuite/tests/package/package09e.hs @@ -0,0 +1,2 @@ +module Package09e where +import M diff --git a/testsuite/tests/package/package09e.stderr b/testsuite/tests/package/package09e.stderr new file mode 100644 index 0000000000..9cd00a2930 --- /dev/null +++ b/testsuite/tests/package/package09e.stderr @@ -0,0 +1,5 @@ + +package09e.hs:2:1: + Ambiguous interface for ‘M’: + it is bound as Data.Set by a package flag + it is bound as Data.Map by a package flag diff --git a/testsuite/tests/package/package10.hs b/testsuite/tests/package/package10.hs new file mode 100644 index 0000000000..6db31da664 --- /dev/null +++ b/testsuite/tests/package/package10.hs @@ -0,0 +1,2 @@ +module Package10 where +x = emptyUFM |