PackageState(..),
initPackages,
getPackageDetails,
- lookupModuleInAllPackages,
+ lookupModuleInAllPackages, lookupModuleWithSuggestions,
-- * Inspecting the set of packages in scope
getPackageIncludePath,
#include "HsVersions.h"
import PackageConfig
-import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) )
+import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..), DPHBackend(..) )
import StaticFlags
import Config ( cProjectVersion )
import Name ( Name, nameModule_maybe )
import UniqFM
-import FiniteMap
import Module
import Util
import Panic
import System.FilePath
import Control.Monad
import Data.List as List
+import Data.Map (Map)
+import qualified Data.Map as Map
+import qualified FiniteMap as Map
+import qualified Data.Set as Set
-- ---------------------------------------------------------------------------
-- The Package state
-- | A PackageConfigMap maps a 'PackageId' to a 'PackageConfig'
type PackageConfigMap = UniqFM PackageConfig
-type InstalledPackageIdMap = FiniteMap InstalledPackageId PackageId
+type InstalledPackageIdMap = Map InstalledPackageId PackageId
-type InstalledPackageIndex = FiniteMap InstalledPackageId PackageConfig
+type InstalledPackageIndex = Map InstalledPackageId PackageConfig
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM
initPackages dflags = do
pkg_db <- case pkgDatabase dflags of
Nothing -> readPackageConfigs dflags
- Just db -> return db
+ Just db -> return $ maybeHidePackages dflags db
(pkg_state, preload, this_pkg)
<- mkPackageState dflags pkg_db [] (thisPackage dflags)
return (dflags{ pkgDatabase = Just pkg_db,
-- the we tack on the system paths.
pkgs <- mapM (readPackageConfig dflags)
- (reverse pkgconfs ++ reverse (extraPkgConfs dflags))
+ (pkgconfs ++ reverse (extraPkgConfs dflags))
-- later packages shadow earlier ones. extraPkgConfs
-- is in the opposite order to the flags on the
-- command line.
if exist then return [pkgconf] else return []
`catchIO` (\_ -> return [])
- return (user_pkgconf ++ [system_pkgconf])
+ return (system_pkgconf : user_pkgconf)
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
selectPackages matches pkgs unusable
= let
(ps,rest) = partition matches pkgs
- reasons = [ (p, lookupFM unusable (installedPackageId p))
+ reasons = [ (p, Map.lookup (installedPackageId p) unusable)
| p <- ps ]
in
if all (isJust.snd) reasons
packageFlagErr :: PackageFlag
-> [(PackageConfig, UnusablePackageReason)]
-> IO a
+
+-- 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 (ExposePackage pkg) [] | is_dph_package pkg
+ = ghcError (CmdLineError (showSDoc $ dph_err))
+ where dph_err = text "the " <> text pkg <> text " package is not installed."
+ $$ text "To install it: \"cabal install dph\"."
+ is_dph_package pkg = "dph" `isPrefixOf` pkg
+
packageFlagErr flag reasons = ghcError (CmdLineError (showSDoc $ err))
where err = text "cannot satisfy " <> ppr_flag <>
(if null reasons then empty else text ": ") $$
integerPackageId,
basePackageId,
rtsPackageId,
- haskell98PackageId,
thPackageId,
dphSeqPackageId,
dphParPackageId ]
| MissingDependencies [InstalledPackageId]
| ShadowedBy InstalledPackageId
-type UnusablePackages = FiniteMap InstalledPackageId UnusablePackageReason
+type UnusablePackages = Map InstalledPackageId UnusablePackageReason
pprReason :: SDoc -> UnusablePackageReason -> SDoc
pprReason pref reason = case reason of
pref <+> ptext (sLit "shadowed by package ") <> text (display ipid)
reportUnusable :: DynFlags -> UnusablePackages -> IO ()
-reportUnusable dflags pkgs = mapM_ report (fmToList pkgs)
+reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
where
report (ipid, reason) =
debugTraceMsg dflags 2 $
-- satisfied until no more can be added.
--
findBroken :: [PackageConfig] -> UnusablePackages
-findBroken pkgs = go [] emptyFM pkgs
+findBroken pkgs = go [] Map.empty pkgs
where
go avail ipids not_avail =
case partitionWith (depsAvailable ipids) not_avail of
([], not_avail) ->
- listToFM [ (installedPackageId p, MissingDependencies deps)
- | (p,deps) <- not_avail ]
+ Map.fromList [ (installedPackageId p, MissingDependencies deps)
+ | (p,deps) <- not_avail ]
(new_avail, not_avail) ->
go (new_avail ++ avail) new_ipids (map fst not_avail)
- where new_ipids = addListToFM ipids
+ where new_ipids = Map.insertList
[ (installedPackageId p, p) | p <- new_avail ]
+ ipids
depsAvailable :: InstalledPackageIndex
-> PackageConfig
depsAvailable ipids pkg
| null dangling = Left pkg
| otherwise = Right (pkg, dangling)
- where dangling = filter (not . (`elemFM` ipids)) (depends pkg)
+ where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
-- -----------------------------------------------------------------------------
-- Eliminate shadowed packages, giving the user some feedback
shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
shadowPackages pkgs preferred
= let (shadowed,_) = foldl check ([],emptyUFM) pkgs
- in listToFM shadowed
+ in Map.fromList shadowed
where
check (shadowed,pkgmap) pkg
- | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg),
- let
+ | Just oldpkg <- lookupUFM pkgmap (packageConfigId pkg)
+ , let
ipid_new = installedPackageId pkg
- ipid_old = installedPackageId oldpkg,
+ ipid_old = installedPackageId oldpkg
--
- ipid_old /= ipid_new
+ , 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' )
-- -----------------------------------------------------------------------------
ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
-ignorePackages flags pkgs = listToFM (concatMap doit flags)
+ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
where
doit (IgnorePackage str) =
case partition (matchingStr str) pkgs of
depClosure :: InstalledPackageIndex
-> [InstalledPackageId]
-> [InstalledPackageId]
-depClosure index ipids = closure emptyFM ipids
+depClosure index ipids = closure Map.empty ipids
where
- closure set [] = keysFM set
+ closure set [] = Map.keys set
closure set (ipid : ipids)
- | ipid `elemFM` set = closure set ipids
- | Just p <- lookupFM index ipid = closure (addToFM set ipid p)
- (depends p ++ ipids)
+ | ipid `Map.member` set = closure set ipids
+ | Just p <- Map.lookup ipid index = closure (Map.insert ipid p set)
+ (depends p ++ ipids)
| otherwise = closure set ipids
-- -----------------------------------------------------------------------------
-> IO (PackageState,
[PackageId], -- new packages to preload
PackageId) -- this package, might be modified if the current
-
-- package is a wired-in package.
mkPackageState dflags pkgs0 preload0 this_package = do
-}
let
- flags = reverse (packageFlags dflags)
-
- ipid_map = listToFM [ (installedPackageId p, p) | p <- pkgs0 ]
+ flags = reverse (packageFlags dflags) ++ dphPackage
+ -- expose the appropriate DPH backend library
+ dphPackage = case dphBackend dflags of
+ DPHPar -> [ExposePackage "dph-prim-par", ExposePackage "dph-par"]
+ DPHSeq -> [ExposePackage "dph-prim-seq", ExposePackage "dph-seq"]
+ DPHThis -> []
+ DPHNone -> []
-- pkgs0 with duplicate packages filtered out. This is
- -- important: it is possible for a package in the user package
- -- DB to have the same IPID as a package in the global DB, and
- -- we want the former to take precedence. This is not the same
+ -- important: it is possible for a package in the global package
+ -- DB to have the same IPID as a package in the user DB, and
+ -- we want the latter to take precedence. This is not the same
-- as shadowing (below), since in this case the two packages
-- have the same ABI and are interchangeable.
- pkgs0_unique = eltsFM ipid_map
+ --
+ -- #4072: note that we must retain the ordering of the list here
+ -- so that shadowing behaves as expected when we apply it later.
+ pkgs0_unique = snd $ foldr del (Set.empty,[]) pkgs0
+ where del p (s,ps)
+ | pid `Set.member` s = (s,ps)
+ | otherwise = (Set.insert pid s, p:ps)
+ where pid = installedPackageId p
+ -- XXX this is just a variant of nub
+
+ ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
ipid_selected = depClosure ipid_map [ InstalledPackageId i
| ExposePackageId i <- flags ]
ignored = ignorePackages ignore_flags pkgs0_unique
- pkgs0' = filter (not . (`elemFM` (plusFM shadowed ignored)) . installedPackageId) pkgs0_unique
+ pkgs0' = filter (not . (`Map.member` (Map.union shadowed ignored)) . installedPackageId) pkgs0_unique
broken = findBroken pkgs0'
- unusable = shadowed `plusFM` ignored `plusFM` broken
+ unusable = shadowed `Map.union` ignored `Map.union` broken
reportUnusable dflags unusable
-- (-package, -hide-package, -ignore-package, -hide-all-packages).
--
pkgs1 <- foldM (applyPackageFlag unusable) pkgs0_unique other_flags
- let pkgs2 = filter (not . (`elemFM` unusable) . installedPackageId) pkgs1
+ let pkgs2 = filter (not . (`Map.member` unusable) . installedPackageId) pkgs1
-- Here we build up a set of the packages mentioned in -package
-- flags on the command line; these are called the "preload"
let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs4
- ipid_map = listToFM [ (installedPackageId p, packageConfigId p)
- | p <- pkgs4 ]
+ ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
+ | p <- pkgs4 ]
lookupIPID ipid@(InstalledPackageId str)
- | Just pid <- lookupFM ipid_map ipid = return pid
- | otherwise = missingPackageErr str
+ | Just pid <- Map.lookup ipid ipid_map = return pid
+ | otherwise = missingPackageErr str
preload2 <- mapM lookupIPID preload1
-- set up preloaded package when we are just building it
preload3 = nub $ filter (/= this_package)
$ (basicLinkedPackages ++ preload2)
-
+
-- Close the preload packages with their dependencies
dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing))
let new_dep_preload = filter (`notElem` preload0) dep_preload
let pstate = PackageState{ preloadPackages = dep_preload,
- pkgIdMap = pkg_db,
- moduleToPkgConfAll = mkModuleMap pkg_db,
+ pkgIdMap = pkg_db,
+ moduleToPkgConfAll = mkModuleMap pkg_db,
installedPackageIdMap = ipid_map
- }
+ }
return (pstate, new_dep_preload, this_package)
-
+
-- -----------------------------------------------------------------------------
-- Make the mapping from module to package info
-- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package,
-- and exposed is @True@ if the package exposes the module.
lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)]
-lookupModuleInAllPackages dflags m =
- case lookupUFM (moduleToPkgConfAll (pkgState dflags)) m of
- Nothing -> []
- Just ps -> ps
+lookupModuleInAllPackages dflags m
+ = case lookupModuleWithSuggestions dflags m of
+ Right pbs -> pbs
+ Left _ -> []
+
+lookupModuleWithSuggestions
+ :: DynFlags -> ModuleName
+ -> Either [Module] [(PackageConfig,Bool)]
+ -- Lookup module in all packages
+ -- Right pbs => found in pbs
+ -- Left ms => not found; but here are sugestions
+lookupModuleWithSuggestions dflags m
+ = case lookupUFM (moduleToPkgConfAll pkg_state) m of
+ Nothing -> Left suggestions
+ Just ps -> Right ps
+ where
+ pkg_state = pkgState dflags
+ suggestions
+ | dopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods
+ | otherwise = []
+
+ all_mods :: [(String, Module)] -- All modules
+ all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm)
+ | pkg_config <- eltsUFM (pkgIdMap pkg_state)
+ , let pkg_id = packageConfigId pkg_config
+ , mod_nm <- exposedModules pkg_config ]
-- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of
-- 'PackageConfig's
-- Takes a list of packages, and returns the list with dependencies included,
-- in reverse dependency order (a package appears before those it depends on).
closeDeps :: PackageConfigMap
- -> FiniteMap InstalledPackageId PackageId
+ -> Map InstalledPackageId PackageId
-> [(PackageId, Maybe PackageId)]
-> IO [PackageId]
closeDeps pkg_map ipid_map ps = throwErr (closeDepsErr pkg_map ipid_map ps)
Succeeded r -> return r
closeDepsErr :: PackageConfigMap
- -> FiniteMap InstalledPackageId PackageId
+ -> Map InstalledPackageId PackageId
-> [(PackageId,Maybe PackageId)]
-> MaybeErr Message [PackageId]
closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
-- internal helper
add_package :: PackageConfigMap
- -> FiniteMap InstalledPackageId PackageId
+ -> Map InstalledPackageId PackageId
-> [PackageId]
-> (PackageId,Maybe PackageId)
-> MaybeErr Message [PackageId]
return (p : ps')
where
add_package_ipid ps ipid@(InstalledPackageId str)
- | Just pid <- lookupFM ipid_map ipid
+ | Just pid <- Map.lookup ipid ipid_map
= add_package pkg_db ipid_map ps (pid, Just p)
| otherwise
= Failed (missingPackageMsg str <> missingDependencyMsg mb_parent)
-- | Will the 'Name' come from a dynamically linked library?
isDllName :: PackageId -> Name -> Bool
+-- Despite the "dll", I think this function just means that
+-- the synbol comes from another dynamically-linked package,
+-- and applies on all platforms, not just Windows
isDllName this_pkg name
| opt_Static = False
| Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg