module Packages (
module PackageConfig,
PackageState(preloadPackages),
initPackages,
readPackageConfigs,
getPackageConfRefs,
resolvePackageConfig,
readPackageConfig,
lookupPackage,
resolveInstalledPackageId,
searchPackageId,
getPackageDetails,
listVisibleModuleNames,
lookupModuleInAllPackages,
lookupModuleWithSuggestions,
LookupResult(..),
ModuleSuggestion(..),
ModuleOrigin(..),
getPackageIncludePath,
getPackageLibraryPath,
getPackageLinkOpts,
getPackageExtraCcOpts,
getPackageFrameworkPath,
getPackageFrameworks,
getPreloadPackagesAnd,
collectIncludeDirs, collectLibraryPaths, collectLinkOpts,
packageHsLibs,
packageKeyPackageIdString,
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)
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid hiding ((<>))
#endif
import qualified Data.Map as Map
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
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 PackageKeyMap = UniqFM
type PackageConfigMap = PackageKeyMap PackageConfig
type VisibilityMap =
PackageKeyMap (Bool, [(ModuleName, ModuleName)], FastString)
type ModuleToPkgConfAll =
Map ModuleName (Map Module ModuleOrigin)
data PackageState = PackageState {
pkgIdMap :: PackageConfigMap,
preloadPackages :: [PackageKey],
moduleToPkgConfAll :: ModuleToPkgConfAll,
installedPackageIdMap :: InstalledPackageIdMap
}
type InstalledPackageIdMap = Map InstalledPackageId PackageKey
type InstalledPackageIndex = Map InstalledPackageId PackageConfig
emptyPackageConfigMap :: PackageConfigMap
emptyPackageConfigMap = emptyUFM
lookupPackage :: DynFlags -> PackageKey -> Maybe PackageConfig
lookupPackage dflags = lookupPackage' (pkgIdMap (pkgState dflags))
lookupPackage' :: PackageConfigMap -> PackageKey -> 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 -> PackageKey -> PackageConfig
getPackageDetails dflags pid =
expectJust "getPackageDetails" (lookupPackage dflags pid)
listPackageConfigMap :: DynFlags -> [PackageConfig]
listPackageConfigMap dflags = eltsUFM (pkgIdMap (pkgState dflags))
resolveInstalledPackageId :: DynFlags -> InstalledPackageId -> PackageKey
resolveInstalledPackageId dflags ipid =
expectJust "resolveInstalledPackageId"
(Map.lookup ipid (installedPackageIdMap (pkgState dflags)))
initPackages :: DynFlags -> IO (DynFlags, [PackageKey])
initPackages dflags = do
pkg_db <- case pkgDatabase dflags of
Nothing -> readPackageConfigs dflags
Just db -> return $ setBatchPackageFlags dflags db
(pkg_state, preload, this_pkg)
<- mkPackageState dflags pkg_db [] (thisPackage dflags)
return (dflags{ pkgDatabase = Just pkg_db,
pkgState = pkg_state,
thisPackage = this_pkg },
preload)
readPackageConfigs :: DynFlags -> IO [PackageConfig]
readPackageConfigs dflags = do
conf_refs <- getPackageConfRefs dflags
confs <- liftM catMaybes $ mapM (resolvePackageConfig dflags) conf_refs
liftM concat $ 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 = handleIO (\_ -> return Nothing) $ do
appdir <- getAppUserDataDirectory (programName dflags)
let dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':projectVersion dflags)
pkgconf = dir </> "package.conf.d"
exist <- doesDirectoryExist pkgconf
return $ if exist then Just pkgconf else Nothing
resolvePackageConfig _ (PkgConfFile name) = return $ Just name
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
isdir <- doesDirectoryExist conf_file
proto_pkg_configs <-
if isdir
then do let filename = conf_file </> "package.cache"
debugTraceMsg dflags 2 (text "Using binary package database:" <+> text filename)
readPackageDbForGhc filename
else do
isfile <- doesFileExist conf_file
if isfile
then 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 pkg_configs2
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
calcKey :: PackageConfig -> PackageKey
calcKey p | pk <- packageNameString p
, pk `elem` wired_in_pkgids
= stringToPackageKey pk
| otherwise = packageConfigId p
applyPackageFlag
:: DynFlags
-> UnusablePackages
-> ([PackageConfig], VisibilityMap)
-> PackageFlag
-> IO ([PackageConfig], VisibilityMap)
applyPackageFlag dflags unusable (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 (pkgs, vm')
where
n = fsPackageName p
vm' = addToUFM_C edit vm_cleared (calcKey p) (b, map convRn rns, n)
edit (b, rns, n) (b', rns', _) = (b || b', rns ++ rns', n)
convRn (a,b) = (mkModuleName a, mkModuleName b)
vm_cleared | gopt Opt_HideAllPackages dflags = 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,_) -> return (pkgs, vm')
where vm' = delListFromUFM vm (map calcKey ps)
TrustPackage str ->
case selectPackages (matchingStr str) pkgs unusable of
Left ps -> packageFlagErr dflags flag ps
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, vm)
where distrust p = p {trusted=False}
IgnorePackage _ -> panic "applyPackageFlag: IgnorePackage"
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 ps, rest)
matchingStr :: String -> PackageConfig -> Bool
matchingStr str p
= str == sourcePackageIdString p
|| str == packageNameString p
matchingId :: String -> PackageConfig -> Bool
matchingId str p = str == installedPackageIdString p
matchingKey :: String -> PackageConfig -> Bool
matchingKey str p = str == packageKeyString (packageConfigId p)
matching :: PackageArg -> PackageConfig -> Bool
matching (PackageArg str) = matchingStr str
matching (PackageIdArg str) = matchingId str
matching (PackageKeyArg str) = matchingKey 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
= throwGhcExceptionIO (CmdLineError (showSDoc dflags $ err))
where err = text "cannot satisfy " <> pprFlag flag <>
(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 (installedPackageId p) <+> text "is") reason
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 (ModRenaming True []) = Outputable.empty
ppr_rns (ModRenaming b rns) =
if b then text "with" else Outputable.empty <+>
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_pkgids :: [String]
wired_in_pkgids = map packageKeyString wiredInPackageKeys
findWiredInPackages
:: DynFlags
-> [PackageConfig]
-> IO [PackageConfig]
findWiredInPackages dflags pkgs = do
let
matches :: PackageConfig -> String -> Bool
pc `matches` pid = packageNameString pc == pid
findWiredInPackage :: [PackageConfig] -> String
-> IO (Maybe InstalledPackageId)
findWiredInPackage pkgs wired_pkg =
let all_ps = [ p | p <- pkgs, p `matches` wired_pkg ] in
case all_ps of
[] -> notfound
many -> pick (head (sortByVersion many))
where
notfound = do
debugTraceMsg dflags 2 $
ptext (sLit "wired-in package ")
<> text wired_pkg
<> ptext (sLit " not found.")
return Nothing
pick :: PackageConfig
-> IO (Maybe InstalledPackageId)
pick pkg = do
debugTraceMsg dflags 2 $
ptext (sLit "wired-in package ")
<> text wired_pkg
<> ptext (sLit " mapped to ")
<> ppr (installedPackageId pkg)
return (Just (installedPackageId pkg))
mb_wired_in_ids <- mapM (findWiredInPackage pkgs) wired_in_pkgids
let
wired_in_ids = catMaybes mb_wired_in_ids
updateWiredInDependencies pkgs = map upd_pkg pkgs
where upd_pkg pkg
| installedPackageId pkg `elem` wired_in_ids
= pkg {
packageKey = stringToPackageKey (packageNameString pkg)
}
| otherwise
= pkg
return $ updateWiredInDependencies pkgs
data UnusablePackageReason
= IgnoredWithFlag
| MissingDependencies [InstalledPackageId]
| ShadowedBy InstalledPackageId
type UnusablePackages = Map InstalledPackageId
(PackageConfig, UnusablePackageReason)
pprReason :: SDoc -> UnusablePackageReason -> SDoc
pprReason pref reason = case reason of
IgnoredWithFlag ->
pref <+> ptext (sLit "ignored due to an -ignore-package flag")
MissingDependencies deps ->
pref <+>
ptext (sLit "unusable due to missing or recursive dependencies:") $$
nest 2 (hsep (map ppr deps))
ShadowedBy ipid ->
pref <+> ptext (sLit "shadowed by package ") <> ppr ipid
reportUnusable :: DynFlags -> UnusablePackages -> IO ()
reportUnusable dflags pkgs = mapM_ report (Map.toList pkgs)
where
report (ipid, (_, reason)) =
debugTraceMsg dflags 2 $
pprReason
(ptext (sLit "package") <+>
ppr ipid <+> text "is") reason
findBroken :: [PackageConfig] -> UnusablePackages
findBroken pkgs = go [] Map.empty pkgs
where
go avail ipids not_avail =
case partitionWith (depsAvailable ipids) not_avail of
([], not_avail) ->
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)
where new_ipids = Map.insertList
[ (installedPackageId p, p) | p <- new_avail ]
ipids
depsAvailable :: InstalledPackageIndex
-> PackageConfig
-> Either PackageConfig (PackageConfig, [InstalledPackageId])
depsAvailable ipids pkg
| null dangling = Left pkg
| otherwise = Right (pkg, dangling)
where dangling = filter (not . (`Map.member` ipids)) (depends pkg)
type UnusablePackage = (PackageConfig, UnusablePackageReason)
shadowPackages :: [PackageConfig] -> [InstalledPackageId] -> UnusablePackages
shadowPackages pkgs preferred
= let (shadowed,_) = foldl check ([],emptyUFM) pkgs
in Map.fromList shadowed
where
check :: ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
-> PackageConfig
-> ([(InstalledPackageId, UnusablePackage)], UniqFM PackageConfig)
check (shadowed,pkgmap) pkg
| Just oldpkg <- lookupUFM pkgmap pkgid
, let
ipid_new = installedPackageId pkg
ipid_old = installedPackageId oldpkg
, ipid_old /= ipid_new
= if ipid_old `elem` preferred
then ((ipid_new, (pkg, ShadowedBy ipid_old)) : shadowed, pkgmap)
else ((ipid_old, (oldpkg, ShadowedBy ipid_new)) : shadowed, pkgmap')
| otherwise
= (shadowed, pkgmap')
where
pkgid = packageKeyFS (packageKey pkg)
pkgmap' = addToUFM pkgmap pkgid pkg
ignorePackages :: [PackageFlag] -> [PackageConfig] -> UnusablePackages
ignorePackages flags pkgs = Map.fromList (concatMap doit flags)
where
doit (IgnorePackage str) =
case partition (matchingStr str) pkgs of
(ps, _) -> [ (installedPackageId p, (p, IgnoredWithFlag))
| p <- ps ]
doit _ = panic "ignorePackages"
depClosure :: InstalledPackageIndex
-> [InstalledPackageId]
-> [InstalledPackageId]
depClosure index ipids = closure Map.empty ipids
where
closure set [] = Map.keys set
closure set (ipid : 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
mkPackageState
:: DynFlags
-> [PackageConfig]
-> [PackageKey]
-> PackageKey
-> IO (PackageState,
[PackageKey],
PackageKey)
mkPackageState dflags pkgs0 preload0 this_package = do
let
flags = reverse (packageFlags dflags)
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
ipid_map = Map.fromList [ (installedPackageId p, p) | p <- pkgs0 ]
ipid_selected = depClosure ipid_map
[ InstalledPackageId (mkFastString i)
| 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
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
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_map0 = foldUFM (\p vm ->
if exposed p
then addToUFM vm (calcKey p)
(True, [], fsPackageName p)
else vm)
emptyUFM initial
(pkgs2, vis_map) <- foldM (applyPackageFlag dflags unusable)
(pkgs1, vis_map0) other_flags
pkgs3 <- findWiredInPackages dflags pkgs2
let preload1 = [ installedPackageId p | f <- flags, p <- get_exposed f ]
get_exposed (ExposePackage a _) = take 1 . sortByVersion
. filter (matching a)
$ pkgs2
get_exposed _ = []
let pkg_db = extendPackageConfigMap emptyPackageConfigMap pkgs3
ipid_map = Map.fromList [ (installedPackageId p, packageConfigId p)
| p <- pkgs3 ]
lookupIPID ipid
| Just pid <- Map.lookup ipid ipid_map = return pid
| otherwise = missingPackageErr dflags ipid
preload2 <- mapM lookupIPID preload1
let
basicLinkedPackages
| gopt Opt_AutoLinkPackages dflags
= filter (flip elemUFM pkg_db)
[basePackageKey, rtsPackageKey]
| otherwise = []
preload3 = nub $ filter (/= this_package)
$ (basicLinkedPackages ++ preload2)
dep_preload <- closeDeps dflags 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 = mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map,
installedPackageIdMap = ipid_map
}
return (pstate, new_dep_preload, this_package)
mkModuleToPkgConfAll
:: DynFlags
-> PackageConfigMap
-> InstalledPackageIdMap
-> VisibilityMap
-> ModuleToPkgConfAll
mkModuleToPkgConfAll dflags pkg_db ipid_map vis_map =
foldl' extend_modmap emptyMap (eltsUFM pkg_db)
where
emptyMap = Map.empty
sing pk m _ = Map.singleton (mkModule pk m)
addListTo = foldl' merge
merge m (k, v) = Map.insertWith (Map.unionWith mappend) k v m
setOrigins m os = fmap (const os) m
extend_modmap modmap pkg = addListTo modmap theBindings
where
theBindings :: [(ModuleName, Map Module ModuleOrigin)]
theBindings | 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 _exposedSignature <- exposed_mods
let (pk', m', pkg', origin') =
case exposedReexport of
Nothing -> (pk, m, pkg, fromExposedModules e)
Just (OriginalModule ipid' m') ->
let pk' = expectJust "mkModuleToPkgConf" (Map.lookup ipid' ipid_map)
pkg' = pkg_lookup pk'
in (pk', m', pkg', fromReexportedModules e pkg')
return (m, sing pk' m' pkg' origin')
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 -> [PackageKey] -> IO [String]
getPackageIncludePath dflags pkgs =
collectIncludeDirs `fmap` getPreloadPackagesAnd dflags pkgs
collectIncludeDirs :: [PackageConfig] -> [FilePath]
collectIncludeDirs ps = nub (filter notNull (concatMap includeDirs ps))
getPackageLibraryPath :: DynFlags -> [PackageKey] -> IO [String]
getPackageLibraryPath dflags pkgs =
collectLibraryPaths `fmap` getPreloadPackagesAnd dflags pkgs
collectLibraryPaths :: [PackageConfig] -> [FilePath]
collectLibraryPaths ps = nub (filter notNull (concatMap libraryDirs ps))
getPackageLinkOpts :: DynFlags -> [PackageKey] -> 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
| gopt Opt_Static 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 -> [PackageKey] -> IO [String]
getPackageExtraCcOpts dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (concatMap ccOptions ps)
getPackageFrameworkPath :: DynFlags -> [PackageKey] -> IO [String]
getPackageFrameworkPath dflags pkgs = do
ps <- getPreloadPackagesAnd dflags pkgs
return (nub (filter notNull (concatMap frameworkDirs ps)))
getPackageFrameworks :: DynFlags -> [PackageKey] -> 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
(modulePackageKey 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 m mb_pn
= case Map.lookup m (moduleToPkgConfAll pkg_state) of
Nothing -> LookupNotFound suggestions
Just xs ->
case foldl' classify ([],[],[]) (Map.toList xs) of
([], [], []) -> LookupNotFound suggestions
(_, _, [(m, _)]) -> LookupFound m (mod_pkg m)
(_, _, exposed@(_:_)) -> LookupMultiple exposed
(hidden_pkg, hidden_mod, []) -> LookupHidden hidden_pkg hidden_mod
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
pkg_state = pkgState dflags
mod_pkg = pkg_lookup . modulePackageKey
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 -> [PackageKey] -> IO [PackageConfig]
getPreloadPackagesAnd dflags pkgids =
let
state = pkgState dflags
pkg_map = pkgIdMap state
ipid_map = installedPackageIdMap state
preload = preloadPackages state
pairs = zip pkgids (repeat Nothing)
in do
all_pkgs <- throwErr dflags (foldM (add_package pkg_map ipid_map) preload pairs)
return (map (getPackageDetails dflags) all_pkgs)
closeDeps :: DynFlags
-> PackageConfigMap
-> Map InstalledPackageId PackageKey
-> [(PackageKey, Maybe PackageKey)]
-> IO [PackageKey]
closeDeps dflags pkg_map ipid_map ps
= throwErr dflags (closeDepsErr pkg_map ipid_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
-> Map InstalledPackageId PackageKey
-> [(PackageKey,Maybe PackageKey)]
-> MaybeErr MsgDoc [PackageKey]
closeDepsErr pkg_map ipid_map ps = foldM (add_package pkg_map ipid_map) [] ps
add_package :: PackageConfigMap
-> Map InstalledPackageId PackageKey
-> [PackageKey]
-> (PackageKey,Maybe PackageKey)
-> MaybeErr MsgDoc [PackageKey]
add_package pkg_db ipid_map 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_package_ipid ps (depends pkg)
return (p : ps')
where
add_package_ipid ps ipid
| Just pid <- Map.lookup ipid ipid_map
= add_package pkg_db ipid_map ps (pid, Just p)
| otherwise
= Failed (missingPackageMsg ipid
<> missingDependencyMsg mb_parent)
missingPackageErr :: Outputable pkgid => DynFlags -> pkgid -> IO a
missingPackageErr dflags p
= throwGhcExceptionIO (CmdLineError (showSDoc dflags (missingPackageMsg p)))
missingPackageMsg :: Outputable pkgid => pkgid -> SDoc
missingPackageMsg p = ptext (sLit "unknown package:") <+> ppr p
missingDependencyMsg :: Maybe PackageKey -> SDoc
missingDependencyMsg Nothing = Outputable.empty
missingDependencyMsg (Just parent)
= space <> parens (ptext (sLit "dependency of") <+> ftext (packageKeyFS parent))
packageKeyPackageIdString :: DynFlags -> PackageKey -> String
packageKeyPackageIdString dflags pkg_key
| pkg_key == mainPackageKey = "main"
| otherwise = maybe "(unknown)"
sourcePackageIdString
(lookupPackage dflags pkg_key)
isDllName :: DynFlags -> PackageKey -> Module -> Name -> Bool
isDllName dflags _this_pkg this_mod name
| gopt Opt_Static 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 InstalledPackageId i = installedPackageId 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 (modulePackageKey m') <+> parens (ppr o)
| otherwise = ppr m' <+> parens (ppr o)
fsPackageName :: PackageConfig -> FastString
fsPackageName = mkFastString . packageNameString