import Panic
import Outputable
-#if __GLASGOW_HASKELL__ < 603
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 603
import Compat.Directory ( getAppUserDataDirectory )
#endif
import ErrUtils ( debugTraceMsg, putMsg, Message )
import System.Directory
+import System.FilePath
import Data.Maybe
import Control.Monad
import Data.List
-- to maintain the package database on systems with a package
-- management system, or systems that don't want to run ghc-pkg
-- to register or unregister packages. Undocumented feature for now.
- let system_pkgconf_dir = system_pkgconf ++ ".d"
+ let system_pkgconf_dir = system_pkgconf <.> "d"
system_pkgconf_dir_exists <- doesDirectoryExist system_pkgconf_dir
system_pkgconfs <-
if system_pkgconf_dir_exists
then do files <- getDirectoryContents system_pkgconf_dir
- return [ system_pkgconf_dir ++ '/' : file
+ return [ system_pkgconf_dir </> file
| file <- files
- , isSuffixOf ".conf" file]
+ , takeExtension file == ".conf" ]
else return []
-- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
appdir <- getAppUserDataDirectory "ghc"
let
pkgconf = appdir
- `joinFileName` (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
- `joinFileName` "package.conf"
+ </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
+ </> "package.conf"
flg <- doesFileExist pkgconf
if (flg && dopt Opt_ReadUserPackageConf dflags)
then return [pkgconf]
munge_paths = map munge_path
munge_path p
- | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
+ | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p'
+ | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p'
| otherwise = p
+ toHttpPath p = "file:///" ++ p
+
-- -----------------------------------------------------------------------------
-- Modify our copy of the package database based on a package flag
return (pkgs2, preload1, new_this_pkg)
--- -----------------------------------------------------------------------------
+-- ----------------------------------------------------------------------------
--
--- Eliminate any packages which have dangling dependencies (
--- because the dependency was removed by -ignore-package).
+-- Detect any packages that have missing dependencies, and also any
+-- mutually-recursive groups of packages (loops in the package graph
+-- are not allowed). We do this by taking the least fixpoint of the
+-- dependency graph, repeatedly adding packages whose dependencies are
+-- satisfied until no more can be added.
--
elimDanglingDeps
:: DynFlags
-> [PackageId] -- ignored packages
-> IO [PackageConfig]
-elimDanglingDeps dflags pkgs ignored =
- case partition (not.null.snd) (map (getDanglingDeps pkgs ignored) pkgs) of
- ([],ps) -> return (map fst ps)
- (ps,qs) -> do
- mapM_ reportElim ps
- elimDanglingDeps dflags (map fst qs)
- (ignored ++ map packageConfigId (map fst ps))
+elimDanglingDeps dflags pkgs ignored = go [] pkgs'
where
+ pkgs' = filter (\p -> packageConfigId p `notElem` ignored) pkgs
+
+ go avail not_avail =
+ case partitionWith (depsAvailable avail) not_avail of
+ ([], not_avail) -> do mapM_ reportElim not_avail; return avail
+ (new_avail, not_avail) -> go (new_avail ++ avail) (map fst not_avail)
+
+ depsAvailable :: [PackageConfig] -> PackageConfig
+ -> Either PackageConfig (PackageConfig, [PackageIdentifier])
+ depsAvailable pkgs_ok pkg
+ | null dangling = Left pkg
+ | otherwise = Right (pkg, dangling)
+ where dangling = filter (`notElem` pids) (depends pkg)
+ pids = map package pkgs_ok
+
reportElim (p, deps) =
debugTraceMsg dflags 2 $
(ptext SLIT("package") <+> pprPkg p <+>
- ptext SLIT("will be ignored due to missing dependencies:") $$
+ ptext SLIT("will be ignored due to missing or recursive dependencies:") $$
nest 2 (hsep (map (text.showPackageId) deps)))
- getDanglingDeps pkgs ignored p = (p, filter dangling (depends p))
- where dangling pid = mkPackageId pid `elem` ignored
-
-- -----------------------------------------------------------------------------
-- When all the command-line options are in, we can process our package
-- settings and populate the package state.