module Packages (
module PackageConfig,
PackageState(preloadPackages, explicitPackages),
emptyPackageState,
initPackages,
readPackageConfigs,
getPackageConfRefs,
resolvePackageConfig,
readPackageConfig,
listPackageConfigMap,
lookupPackage,
searchPackageId,
getPackageDetails,
listVisibleModuleNames,
lookupModuleInAllPackages,
lookupModuleWithSuggestions,
lookupPluginModuleWithSuggestions,
LookupResult(..),
ModuleSuggestion(..),
ModuleOrigin(..),
getPackageIncludePath,
getPackageLibraryPath,
getPackageLinkOpts,
getPackageExtraCcOpts,
getPackageFrameworkPath,
getPackageFrameworks,
getPreloadPackagesAnd,
collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
packageHsLibs,
unitIdPackageIdString,
pprFlag,
pprPackages,
pprPackagesSimple,
pprModuleMap,
isDllName
)
where
#include "HsVersions.h"
import GHC.PackageDb
import PackageConfig
import DynFlags
import Name ( Name, nameModule_maybe )
import UniqFM
import Module
import Util
import Panic
import Outputable
import Maybes
import System.Environment ( getEnv )
import FastString
import ErrUtils ( debugTraceMsg, MsgDoc )
import Exception
import Unique
import System.Directory
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import Control.Monad
import Data.Char ( toUpper )
import Data.List as List
import Data.Map (Map)
import Data.Set (Set)
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid hiding ((<>))
#endif
#if __GLASGOW_HASKELL__ > 710
import Data.Semigroup ( Semigroup )
import qualified Data.Semigroup as Semigroup
#endif
import qualified Data.Map as Map
import qualified Data.Map.Strict as MapStrict
import qualified FiniteMap as Map
import qualified Data.Set as Set
data ModuleOrigin =
ModHidden
| ModOrigin {
fromOrigPackage :: Maybe Bool
, fromExposedReexport :: [PackageConfig]
, fromHiddenReexport :: [PackageConfig]
, 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 [])
))
fromExposedModules :: Bool -> ModuleOrigin
fromExposedModules e = ModOrigin (Just e) [] [] False
fromReexportedModules :: Bool -> PackageConfig -> ModuleOrigin
fromReexportedModules True pkg = ModOrigin Nothing [pkg] [] False
fromReexportedModules False pkg = ModOrigin Nothing [] [pkg] False
fromFlag :: ModuleOrigin
fromFlag = ModOrigin Nothing [] [] True
#if __GLASGOW_HASKELL__ > 710
instance Semigroup ModuleOrigin where
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
_x <> _y = panic "ModOrigin: hidden module redefined"
#endif
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"
originVisible :: ModuleOrigin -> Bool
originVisible ModHidden = False
originVisible (ModOrigin b res _ f) = b == Just True || not (null res) || f
originEmpty :: ModuleOrigin -> Bool
originEmpty (ModOrigin Nothing [] [] False) = True
originEmpty _ = False
type UnitIdMap = UniqFM
type PackageConfigMap = UnitIdMap PackageConfig
type VisibilityMap =
UnitIdMap (Bool, [(ModuleName, ModuleName)], FastString)
type ModuleToPkgConfAll =
Map ModuleName (Map Module ModuleOrigin)
data PackageState = PackageState {
pkgIdMap :: PackageConfigMap,
preloadPackages :: [UnitId],
explicitPackages :: [UnitId],
moduleToPkgConfAll :: !ModuleToPkgConfAll,
pluginModuleToPkgConfAll :: !ModuleToPkgConfAll
}
emptyPackageState :: PackageState
emptyPackageState = PackageState {
pkgIdMap = emptyUFM,
preloadPackages = [],
explicitPackages = [],
moduleToPkgConfAll = Map.empty,
pluginModuleToPkgConfAll = Map.empty
}
type InstalledPackageIndex = Map UnitId PackageConfig
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM
lookupPackage :: DynFlags -> UnitId -> Maybe PackageConfig
lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
lookupPackage' :: PackageConfigMap -> UnitId -> Maybe PackageConfig
lookupPackage' = lookupUFM
searchPackageId :: DynFlags -> SourcePackageId -> [PackageConfig]
searchPackageId dflags pid = filter ((pid ==) . sourcePackageId)
(listPackageConfigMap dflags)
extendPackageConfigMap
:: PackageConfigMap -> [PackageConfig] -> PackageConfigMap
extendPackageConfigMap pkg_map new_pkgs
= foldl add pkg_map new_pkgs
where add pkg_map p = addToUFM pkg_map (packageConfigId p) p
getPackageDetails :: DynFlags -> UnitId -> PackageConfig
getPackageDetails dflags pid =
expectJust "getPackageDetails" (lookupPackage dflags pid)
listPackageConfigMap :: DynFlags -> [PackageConfig]
listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))
initPackages :: DynFlags -> IO (DynFlags, [UnitId])
initPackages dflags = do
pkg_db <-
case pkgDatabase dflags of
Nothing -> readPackageConfigs dflags
Just db -> return $ map (\(p, pkgs)
-> (p, setBatchPackageFlags dflags pkgs)) db
(pkg_state, preload, this_pkg)
<- mkPackageState dflags pkg_db []
return (dflags{ pkgDatabase = Just pkg_db,
pkgState = pkg_state,
thisPackage = this_pkg },
preload)
readPackageConfigs :: DynFlags -> IO [(FilePath, [PackageConfig])]
readPackageConfigs dflags = do
conf_refs <- getPackageConfRefs dflags
confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
mapM (readPackageConfig dflags) confs
getPackageConfRefs :: DynFlags -> IO [PkgConfRef]
getPackageConfRefs dflags = do
let system_conf_refs = [UserPkgConf, GlobalPkgConf]
e_pkg_path <- tryIO (getEnv $ map toUpper (programName dflags) ++ "_PACKAGE_PATH")
let base_conf_refs = case e_pkg_path of
Left _ -> system_conf_refs
Right path
| not (null path) && isSearchPathSeparator (last path)
-> map PkgConfFile (splitSearchPath (init path)) ++ system_conf_refs
| otherwise
-> map PkgConfFile (splitSearchPath path)
return $ reverse (extraPkgConfs dflags base_conf_refs)
resolvePackageConfig :: DynFlags -> PkgConfRef -> IO (Maybe FilePath)
resolvePackageConfig dflags GlobalPkgConf = return $ Just (systemPackageConfig dflags)
resolvePackageConfig dflags UserPkgConf = runMaybeT $ do
dir <- versionedAppDir dflags
let pkgconf = dir </> "package.conf.d"
exist <- tryMaybeT $ doesDirectoryExist pkgconf
if exist then return pkgconf else mzero
resolvePackageConfig _ (PkgConfFile name) = return $ Just name
readPackageConfig :: DynFlags -> FilePath -> IO (FilePath, [PackageConfig])
readPackageConfig dflags conf_file = do
isdir <- doesDirectoryExist conf_file
proto_pkg_configs <-
if isdir
then readDirStylePackageConfig conf_file
else do
isfile <- doesFileExist conf_file
if isfile
then do
mpkgs <- tryReadOldFileStylePackageConfig
case mpkgs of
Just pkgs -> return pkgs
Nothing -> throwGhcExceptionIO $ InstallationError $
"ghc no longer supports single-file style package " ++
"databases (" ++ conf_file ++
") use 'ghc-pkg init' to create the database with " ++
"the correct format."
else throwGhcExceptionIO $ InstallationError $
"can't find a package database at " ++ conf_file
let
top_dir = topDir dflags
pkgroot = takeDirectory conf_file
pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs
pkg_configs2 = setBatchPackageFlags dflags pkg_configs1
return (conf_file, pkg_configs2)
where
readDirStylePackageConfig conf_dir = do
let filename = conf_dir </> "package.cache"
debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
readPackageDbForGhc filename
tryReadOldFileStylePackageConfig = do
content <- readFile conf_file `catchIO` \_ -> return ""
if take 2 content == "[]"
then do
let conf_dir = conf_file <.> "d"
direxists <- doesDirectoryExist conf_dir
if direxists
then do debugTraceMsg dflags 2 (text "Ignoring old file-style db and trying:" <+> text conf_dir)
liftM Just (readDirStylePackageConfig conf_dir)
else return (Just [])
else return Nothing
setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig]
setBatchPackageFlags dflags pkgs = maybeDistrustAll pkgs
where
maybeDistrustAll pkgs'
| gopt Opt_DistrustAllPackages dflags = map distrust pkgs'
| otherwise = pkgs'
distrust pkg = pkg{ trusted = False }
mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig
mungePackagePaths top_dir pkgroot pkg =
pkg {
importDirs = munge_paths (importDirs pkg),
includeDirs = munge_paths (includeDirs pkg),
libraryDirs = munge_paths (libraryDirs pkg),
frameworkDirs = munge_paths (frameworkDirs pkg),
haddockInterfaces = munge_paths (haddockInterfaces pkg),
haddockHTMLs = munge_urls (haddockHTMLs pkg)
}
where
munge_paths = map munge_path
munge_urls = map munge_url
munge_path p
| Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
| Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
| otherwise = p
munge_url p
| Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
| Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
| otherwise = p
toUrlPath r p = "file:///"
++ FilePath.Posix.joinPath
(r :
dropWhile (all isPathSeparator)
(FilePath.splitDirectories p))
stripVarPrefix var path = case stripPrefix var path of
Just [] -> Just []
Just cs@(c : _) | isPathSeparator c -> Just cs
_ -> Nothing
applyTrustFlag
:: DynFlags
-> UnusablePackages
-> [PackageConfig]
-> TrustFlag
-> IO [PackageConfig]
applyTrustFlag dflags unusable pkgs flag =
case flag of
TrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> trustFlagErr dflags flag ps
Right (ps,qs) -> return (map trust ps ++ qs)
where trust p = p {trusted=True}
DistrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> trustFlagErr dflags flag ps
Right (ps,qs) -> return (map distrust ps ++ qs)
where distrust p = p {trusted=False}
applyPackageFlag
:: DynFlags
-> UnusablePackages
-> Bool
-> [PackageConfig]
-> VisibilityMap
-> PackageFlag
-> IO VisibilityMap
applyPackageFlag dflags unusable no_hide_others pkgs vm flag =
case flag of
ExposePackage _ arg (ModRenaming b rns) ->
case selectPackages (matching arg) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
Right (p:_,_) -> return vm'
where
n = fsPackageName p
vm' = addToUFM_C edit vm_cleared (packageConfigId p) (b, rns, n)
edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
vm_cleared | no_hide_others = vm
| otherwise = filterUFM_Directly
(\k (_,_,n') -> k == getUnique (packageConfigId p)
|| n /= n') vm
_ -> panic "applyPackageFlag"
HidePackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
Right (ps,_) -> return vm'
where vm' = delListFromUFM vm (map packageConfigId ps)
selectPackages :: (PackageConfig -> Bool) -> [PackageConfig]
-> UnusablePackages
-> Either [(PackageConfig, UnusablePackageReason)]
([PackageConfig], [PackageConfig])
selectPackages matches pkgs unusable
= let (ps,rest) = partition matches pkgs
in if null ps
then Left (filter (matches.fst) (Map.elems unusable))
else Right (sortByVersion (reverse ps), rest)
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
= str == sourcePackageIdString p
|| str == packageNameString p
matchingId :: String -> PackageConfig -> Bool
matchingId str p = str == unitIdString (packageConfigId p)
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
matching (UnitIdArg str) = matchingId str
sortByVersion :: [PackageConfig] -> [PackageConfig]
sortByVersion = sortBy (flip (comparing packageVersion))
comparing :: Ord a => (t -> a) -> t -> t -> Ordering
comparing f a b = f a `compare` f b
packageFlagErr :: DynFlags
-> PackageFlag
-> [(PackageConfig, UnusablePackageReason)]
-> IO a
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\"."
is_dph_package pkg = "dph" `isPrefixOf` pkg
packageFlagErr dflags flag reasons
= packageFlagErr' dflags (pprFlag flag) reasons
trustFlagErr :: DynFlags
-> TrustFlag
-> [(PackageConfig, UnusablePackageReason)]
-> IO a
trustFlagErr dflags flag reasons
= packageFlagErr' dflags (pprTrustFlag flag) reasons
packageFlagErr' :: DynFlags
-> SDoc
-> [(PackageConfig, UnusablePackageReason)]
-> IO a
packageFlagErr' dflags flag_doc reasons
= throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
where err = text "cannot satisfy " <> flag_doc <>
(if null reasons then Outputable.empty else text ": ") $$
nest 4 (ppr_reasons $$
text "(use -v for more information)")
ppr_reasons = vcat (map ppr_reason reasons)
ppr_reason (p, reason) =
pprReason (ppr (unitId p) <+> text "is") reason
pprFlag :: PackageFlag -> SDoc
pprFlag flag = case flag of
HidePackage p -> text "-hide-package " <> text p
ExposePackage doc _ _ -> text doc
pprTrustFlag :: TrustFlag -> SDoc
pprTrustFlag flag = case flag of
TrustPackage p -> text "-trust " <> text p
DistrustPackage p -> text "-distrust " <> text p
wired_in_pkgids :: [String]
wired_in_pkgids = map unitIdString wiredInUnitIds
type WiredPackagesMap = Map UnitId UnitId
findWiredInPackages
:: DynFlags
-> [PackageConfig]
-> VisibilityMap
-> IO ([PackageConfig],
WiredPackagesMap)
findWiredInPackages dflags pkgs vis_map = do
let
matches :: PackageConfig -> String -> Bool
pc `matches` pid = packageNameString pc == pid
findWiredInPackage :: [PackageConfig] -> String
-> IO (Maybe PackageConfig)
findWiredInPackage pkgs wired_pkg =
let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ]
all_exposed_ps =
[ p | p <- all_ps
, elemUFM (packageConfigId p) vis_map ] in
case all_exposed_ps of
[] -> case all_ps of
[] -> notfound
many -> pick (head (sortByVersion many))
many -> pick (head (sortByVersion many))
where
notfound = do
debugTraceMsg dflags 2 $
text "wired-in package "
<> text wired_pkg
<> text " not found."
return Nothing
pick :: PackageConfig
-> IO (Maybe PackageConfig)
pick pkg = do
debugTraceMsg dflags 2 $
text "wired-in package "
<> text wired_pkg
<> text " mapped to "
<> ppr (unitId pkg)
return (Just pkg)
mb_wired_in_pkgs <- mapM (findWiredInPackage pkgs) wired_in_pkgids
let
wired_in_pkgs = catMaybes mb_wired_in_pkgs
wired_in_ids = map unitId wired_in_pkgs
wiredInMap :: Map UnitId UnitId
wiredInMap = foldl' add_mapping Map.empty pkgs
where add_mapping m pkg
| let key = unitId pkg
, key `elem` wired_in_ids
= Map.insert key (stringToUnitId (packageNameString pkg)) m
| otherwise = m
updateWiredInDependencies pkgs = map (upd_deps . upd_pkg) pkgs
where upd_pkg pkg
| unitId pkg `elem` wired_in_ids
= pkg {
unitId = stringToUnitId (packageNameString pkg)
}
| otherwise
= pkg
upd_deps pkg = pkg {
depends = map upd_wired_in (depends pkg),
exposedModules
= map (\(ExposedModule k v) ->
(ExposedModule k (fmap upd_wired_in_mod v)))
(exposedModules pkg)
}
upd_wired_in_mod (OriginalModule uid m)
= OriginalModule (upd_wired_in uid) m
upd_wired_in key
| Just key' <- Map.lookup key wiredInMap = key'
| otherwise = key
return (updateWiredInDependencies pkgs, wiredInMap)
updateVisibilityMap :: WiredPackagesMap -> VisibilityMap -> VisibilityMap
updateVisibilityMap wiredInMap vis_map = foldl' f vis_map (Map.toList wiredInMap)
where f vm (from, to) = case lookupUFM vis_map from of
Nothing -> vm
Just r -> addToUFM vm to r
type IsShadowed = Bool
data UnusablePackageReason
= IgnoredWithFlag
| MissingDependencies IsShadowed [UnitId]
type UnusablePackages = Map UnitId
(PackageConfig, UnusablePackageReason)
pprReason :: SDoc -> UnusablePackageReason -> SDoc
pprReason pref reason = case reason of
IgnoredWithFlag ->
pref <+> text "ignored due to an -ignore-package flag"
MissingDependencies is_shadowed deps ->
pref <+> text "unusable due to"
<+> (if is_shadowed then text "shadowed"
else text "missing or recursive")
<+> text "dependencies:" $$
nest 2 (hsep (map ppr deps))
reportUnusable :: DynFlags -> UnusablePackages -> IO ()
reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
where
report (ipid, (_, reason)) =
debugTraceMsg dflags 2 $
pprReason
(text "package" <+> ppr ipid <+> text "is") reason
findBroken :: IsShadowed
-> [PackageConfig]
-> Map UnitId PackageConfig
-> UnusablePackages
findBroken is_shadowed pkgs pkg_map0 = go [] pkg_map0 pkgs
where
go avail pkg_map not_avail =
case partitionWith (depsAvailable pkg_map) not_avail of
([], not_avail) ->
Map.fromList [ (unitId p, (p, MissingDependencies is_shadowed deps))
| (p,deps) <- not_avail ]
(new_avail, not_avail) ->
go (new_avail ++ avail) pkg_map' (map fst not_avail)
where pkg_map' = Map.insertList
[ (unitId p, p) | p <- new_avail ]
pkg_map
depsAvailable :: InstalledPackageIndex
-> PackageConfig
-> Either PackageConfig (PackageConfig, [UnitId])
depsAvailable pkg_map pkg
| null dangling = Left pkg
| otherwise = Right (pkg, dangling)
where dangling = filter (not . (`Map.member` pkg_map)) (depends pkg)
ignorePackages :: [IgnorePackageFlag] -> [PackageConfig] -> UnusablePackages
ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
where
doit (IgnorePackage str) =
case partition (matchingStr str) pkgs of
(ps, _) -> [ (unitId p, (p, IgnoredWithFlag))
| p <- ps ]
mkPackageState
:: DynFlags
-> [(FilePath, [PackageConfig])]
-> [UnitId]
-> IO (PackageState,
[UnitId],
UnitId)
mkPackageState dflags0 dbs preload0 = do
dflags <- interpretPackageEnv dflags0
let this_package = thisPackage dflags
let other_flags = reverse (packageFlags dflags)
ignore_flags = reverse (ignorePackageFlags dflags)
let merge (pkg_map, prev_unusable) (db_path, db) = do
debugTraceMsg dflags 2 $
text "loading package database" <+> text db_path
forM_ (Set.toList shadow_set) $ \pkg ->
debugTraceMsg dflags 2 $
text "package" <+> ppr pkg <+>
text "shadows a previously defined package"
reportUnusable dflags unusable
return (pkg_map', (prev_unusable `Map.difference` pkg_map')
`Map.union` unusable)
where
shadow_set :: Set UnitId
shadow_set = foldr ins Set.empty db
where ins pkg s
| Just old_pkg <- Map.lookup (unitId pkg) pkg_map
, abiHash old_pkg /= abiHash pkg
= Set.insert (unitId pkg) s
| otherwise
= s
shadowed_pkgs0 :: [PackageConfig]
shadowed_pkgs0 = filter (not . (`Set.member` shadow_set) . unitId)
(Map.elems pkg_map)
shadowed = findBroken True shadowed_pkgs0 Map.empty
shadowed_pkgs :: [PackageConfig]
shadowed_pkgs = filter (not . (`Map.member` shadowed) . unitId)
shadowed_pkgs0
ignored = ignorePackages ignore_flags db
db2 = filter (not . (`Map.member` ignored) . unitId) db
mk_pkg_map = Map.fromList . map (\p -> (unitId p, p))
broken = findBroken False db2 (mk_pkg_map shadowed_pkgs)
db3 = filter (not . (`Map.member` broken) . unitId) db2
unusable = shadowed `Map.union` ignored
`Map.union` broken
pkg_map' :: Map UnitId PackageConfig
pkg_map' = mk_pkg_map (shadowed_pkgs ++ db3)
(pkg_map1, unusable) <- foldM merge (Map.empty, Map.empty) dbs
pkgs1 <- foldM (applyTrustFlag dflags unusable)
(Map.elems pkg_map1) (reverse (trustFlags dflags))
let preferLater pkg pkg' =
case comparing packageVersion 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_map1 = foldUFM (\p vm ->
if exposed p
then addToUFM vm (packageConfigId p)
(True, [], fsPackageName p)
else vm)
emptyUFM initial
vis_map2 <- foldM (applyPackageFlag dflags unusable
(gopt Opt_HideAllPackages dflags) pkgs1)
vis_map1 other_flags
(pkgs2, wired_map) <- findWiredInPackages dflags pkgs1 vis_map2
let vis_map = updateVisibilityMap wired_map vis_map2
let hide_plugin_pkgs = gopt Opt_HideAllPluginPackages dflags
plugin_vis_map <-
case pluginPackageFlags dflags of
[] | not hide_plugin_pkgs -> return vis_map
| otherwise -> return emptyUFM
_ -> do let plugin_vis_map1
| hide_plugin_pkgs = emptyUFM
| otherwise = vis_map2
plugin_vis_map2
<- foldM (applyPackageFlag dflags unusable
(gopt Opt_HideAllPluginPackages dflags) pkgs1)
plugin_vis_map1
(reverse (pluginPackageFlags dflags))
return (updateVisibilityMap wired_map plugin_vis_map2)
let preload1 = [ let key = unitId p
in fromMaybe key (Map.lookup key wired_map)
| f <- other_flags, p <- get_exposed f ]
get_exposed (ExposePackage _ a _) = take 1 . sortByVersion
. filter (matching a)
$ pkgs1
get_exposed _ = []
let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs2
let preload2 = preload1
let
basicLinkedPackages
| gopt Opt_AutoLinkPackages dflags
= filter (flip elemUFM pkg_db)
[baseUnitId, rtsUnitId]
| otherwise = []
preload3 = nub $ filter (/= this_package)
$ (basicLinkedPackages ++ preload2)
dep_preload <- closeDeps dflags pkg_db (zip preload3 (repeat Nothing))
let new_dep_preload = filter (`notElem` preload0) dep_preload
let !pstate = PackageState{
preloadPackages = dep_preload,
explicitPackages = foldUFM (\pkg xs ->
if elemUFM (packageConfigId pkg) vis_map
then packageConfigId pkg : xs
else xs) [] pkg_db,
pkgIdMap = pkg_db,
moduleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db vis_map,
pluginModuleToPkgConfAll = mkModuleToPkgConfAll dflags pkg_db plugin_vis_map
}
return (pstate, new_dep_preload, this_package)
mkModuleToPkgConfAll
:: DynFlags
-> PackageConfigMap
-> VisibilityMap
-> ModuleToPkgConfAll
mkModuleToPkgConfAll dflags pkg_db vis_map =
foldl' extend_modmap emptyMap (eltsUFM pkg_db)
where
emptyMap = Map.empty
sing pk m _ = Map.singleton (mkModule pk m)
addListTo = foldl' merge
merge m (k, v) = MapStrict.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 | Just (b,rns,_) <- lookupUFM vis_map (packageConfigId pkg)
= newBindings b rns
| otherwise = newBindings False []
newBindings :: Bool
-> [(ModuleName, ModuleName)]
-> [(ModuleName, Map Module ModuleOrigin)]
newBindings e rns = es e ++ hiddens ++ map rnBinding rns
rnBinding :: (ModuleName, ModuleName)
-> (ModuleName, Map Module ModuleOrigin)
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, Map Module ModuleOrigin)]
es e = do
ExposedModule m exposedReexport <- exposed_mods
let (pk', m', pkg', origin') =
case exposedReexport of
Nothing -> (pk, m, pkg, fromExposedModules e)
Just (OriginalModule pk' m') ->
let pkg' = pkg_lookup pk'
in (pk', m', pkg', fromReexportedModules e pkg')
return (m, sing pk' m' pkg' origin')
esmap :: UniqFM (Map Module ModuleOrigin)
esmap = listToUFM (es False)
hiddens = [(m, sing pk m pkg ModHidden) | m <- hidden_mods]
pk = packageConfigId pkg
pkg_lookup = expectJust "mkModuleToPkgConf" . lookupPackage' pkg_db
exposed_mods = exposedModules pkg
hidden_mods = hiddenModules pkg
getPackageIncludePath :: DynFlags -> [UnitId] -> IO [String]
getPackageIncludePath dflags pkgs =
collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
collectIncludeDirs :: [PackageConfig] -> [FilePath]
collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
getPackageLibraryPath :: DynFlags -> [UnitId] -> IO [String]
getPackageLibraryPath dflags pkgs =
collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
collectLibraryPaths :: [PackageConfig] -> [FilePath]
collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
getPackageLinkOpts :: DynFlags -> [UnitId] -> IO ([String], [String], [String])
getPackageLinkOpts dflags pkgs =
collectLinkOpts dflags `fmap` getPreloadPackagesAnd dflags pkgs
collectLinkOpts :: DynFlags -> [PackageConfig] -> ([String], [String], [String])
collectLinkOpts dflags ps =
(
concatMap (map ("-l" ++) . packageHsLibs dflags) ps,
concatMap (map ("-l" ++) . extraLibraries) ps,
concatMap ldOptions ps
)
packageHsLibs :: DynFlags -> PackageConfig -> [String]
packageHsLibs dflags p = map (mkDynName . addSuffix) (hsLibraries p)
where
ways0 = ways dflags
ways1 = filter (/= WayDyn) ways0
ways2 | WayDebug `elem` ways1
= filter (/= WayEventLog) ways1
| otherwise
= ways1
tag = mkBuildTag (filter (not . wayRTSOnly) ways2)
rts_tag = mkBuildTag ways2
mkDynName x
| WayDyn `notElem` ways dflags = x
| "HS" `isPrefixOf` x =
x ++ '-':programName dflags ++ projectVersion dflags
| Just x' <- stripPrefix "C" x = x'
| otherwise
= panic ("Don't understand library name " ++ x)
addSuffix rts@"HSrts" = rts ++ (expandTag rts_tag)
addSuffix other_lib = other_lib ++ (expandTag tag)
expandTag t | null t = ""
| otherwise = '_':t
getPackageExtraCcOpts :: DynFlags -> [UnitId] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (concatMap ccOptions ps)
getPackageFrameworkPath :: DynFlags -> [UnitId] -> IO [String]
getPackageFrameworkPath dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (nub (filter notNull (concatMap frameworkDirs ps)))
getPackageFrameworks :: DynFlags -> [UnitId] -> IO [String]
getPackageFrameworks dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (concatMap frameworks ps)
lookupModuleInAllPackages :: DynFlags
-> ModuleName
-> [(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
(moduleUnitId m)))
_ -> []
data LookupResult =
LookupFound Module PackageConfig
| LookupMultiple [(Module, ModuleOrigin)]
| LookupHidden [(Module, ModuleOrigin)] [(Module, ModuleOrigin)]
| LookupNotFound [ModuleSuggestion]
data ModuleSuggestion = SuggestVisible ModuleName Module ModuleOrigin
| SuggestHidden ModuleName Module ModuleOrigin
lookupModuleWithSuggestions :: DynFlags
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions dflags
= lookupModuleWithSuggestions' dflags
(moduleToPkgConfAll (pkgState dflags))
lookupPluginModuleWithSuggestions :: DynFlags
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupPluginModuleWithSuggestions dflags
= lookupModuleWithSuggestions' dflags
(pluginModuleToPkgConfAll (pkgState dflags))
lookupModuleWithSuggestions' :: DynFlags
-> ModuleToPkgConfAll
-> ModuleName
-> Maybe FastString
-> LookupResult
lookupModuleWithSuggestions' dflags mod_map m mb_pn
= case Map.lookup m mod_map 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
where
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
mod_pkg = pkg_lookup . moduleUnitId
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
}
where go pkg = pn == fsPackageName pkg
suggestions
| gopt Opt_HelpfulErrors dflags =
fuzzyLookup (moduleNameString m) all_mods
| otherwise = []
all_mods :: [(String, ModuleSuggestion)]
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 =
map fst (filter visible (Map.toList (moduleToPkgConfAll (pkgState dflags))))
where visible (_, ms) = any originVisible (Map.elems ms)
getPreloadPackagesAnd :: DynFlags -> [UnitId] -> IO [PackageConfig]
getPreloadPackagesAnd dflags pkgids =
let
state = pkgState dflags
pkg_map = pkgIdMap state
preload = preloadPackages state
pairs = zip pkgids (repeat Nothing)
in do
all_pkgs <- throwErr dflags (foldM (add_package pkg_map) preload pairs)
return (map (getPackageDetails dflags) all_pkgs)
closeDeps :: DynFlags
-> PackageConfigMap
-> [(UnitId, Maybe UnitId)]
-> IO [UnitId]
closeDeps dflags pkg_map ps
= throwErr dflags (closeDepsErr pkg_map ps)
throwErr :: DynFlags -> MaybeErr MsgDoc a -> IO a
throwErr dflags m
= case m of
Failed e -> throwGhcExceptionIO (CmdLineError (showSDoc dflags e))
Succeeded r -> return r
closeDepsErr :: PackageConfigMap
-> [(UnitId,Maybe UnitId)]
-> MaybeErr MsgDoc [UnitId]
closeDepsErr pkg_map ps = foldM (add_package pkg_map) [] ps
add_package :: PackageConfigMap
-> [UnitId]
-> (UnitId,Maybe UnitId)
-> MaybeErr MsgDoc [UnitId]
add_package pkg_db ps (p, mb_parent)
| p `elem` ps = return ps
| otherwise =
case lookupPackage' pkg_db p of
Nothing -> Failed (missingPackageMsg p <>
missingDependencyMsg mb_parent)
Just pkg -> do
ps' <- foldM add_unit_key ps (depends pkg)
return (p : ps')
where
add_unit_key ps key
= add_package pkg_db ps (key, Just p)
missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
missingPackageMsg p = text "unknown package:" <+> ppr p
missingDependencyMsg :: Maybe UnitId -> SDoc
missingDependencyMsg Nothing = Outputable.empty
missingDependencyMsg (Just parent)
= space <> parens (text "dependency of" <+> ftext (unitIdFS parent))
unitIdPackageIdString :: DynFlags -> UnitId -> Maybe String
unitIdPackageIdString dflags pkg_key
| pkg_key == mainUnitId = Just "main"
| otherwise = fmap sourcePackageIdString (lookupPackage dflags pkg_key)
isDllName :: DynFlags -> UnitId -> Module -> Name -> Bool
isDllName dflags _this_pkg this_mod name
| WayDyn `notElem` ways dflags = False
| Just mod <- nameModule_maybe name
= if mod /= this_mod
then True
else case dllSplit dflags of
Nothing -> False
Just ss ->
let findMod m = let modStr = moduleNameString (moduleName m)
in case find (modStr `Set.member`) ss of
Just i -> i
Nothing -> panic ("Can't find " ++ modStr ++ "in DLL split")
in findMod mod /= findMod this_mod
| otherwise = False
pprPackages :: DynFlags -> SDoc
pprPackages = pprPackagesWith pprPackageConfig
pprPackagesWith :: (PackageConfig -> SDoc) -> DynFlags -> SDoc
pprPackagesWith pprIPI dflags =
vcat (intersperse (text "---") (map pprIPI (listPackageConfigMap dflags)))
pprPackagesSimple :: DynFlags -> SDoc
pprPackagesSimple = pprPackagesWith pprIPI
where pprIPI ipi = let i = unitIdFS (unitId ipi)
e = if exposed ipi then text "E" else text " "
t = if trusted ipi then text "T" else text " "
in e <> t <> text " " <> ftext i
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 (moduleUnitId m') <+> parens (ppr o)
| otherwise = ppr m' <+> parens (ppr o)
fsPackageName :: PackageConfig -> FastString
fsPackageName = mkFastString . packageNameString