Commit 930421d4 authored by Simon Marlow's avatar Simon Marlow

Change the representation of the package database

 - the package DB is a directory containing one file per package
   instance (#723)

 - there is a binary cache of the database (#593, #2089)

 - the binary package is now a boot package

 - there is a new package, bin-package-db, containing the Binary
   instance of InstalledPackageInfo for the binary cache.

Also included in this patch

 - Use colour in 'ghc-pkg list' to indicate broken or hidden packages
  
   Broken packages are red, hidden packages are 
  
   Colour support comes from the terminfo package, and is only used when
    - not --simple-output
    - stdout is a TTY
    - the terminal type has colour capability

 - Fix the bug that 'ghc-pkg list --user' shows everything as broken
parent 5364ea8b
......@@ -88,6 +88,8 @@ Library
if !flag(ncg)
CPP-Options: -DOMIT_NATIVE_CODEGEN
Build-Depends: bin-package-db
-- GHC 6.4.2 needs to be able to find WCsubst.c, which needs to be
-- able to find WCsubst.h
Include-Dirs: ../libraries/base/cbits, ../libraries/base/include
......
......@@ -74,11 +74,9 @@ packageConfigToInstalledPackageInfo
-- | Turn an 'InstalledPackageInfo', which contains Cabal 'Distribution.ModuleName.ModuleName's
-- into a GHC specific 'PackageConfig' which contains GHC 'Module.ModuleName's
installedPackageInfoToPackageConfig :: InstalledPackageInfo -> PackageConfig
installedPackageInfoToPackageConfig :: InstalledPackageInfo_ String -> PackageConfig
installedPackageInfoToPackageConfig
(pkgconf@(InstalledPackageInfo { exposedModules = e,
hiddenModules = h })) =
pkgconf{ exposedModules = map convert e,
hiddenModules = map convert h }
where convert :: Distribution.ModuleName.ModuleName -> Module.ModuleName
convert = mkModuleName . display
pkgconf{ exposedModules = map mkModuleName e,
hiddenModules = map mkModuleName h }
......@@ -51,6 +51,7 @@ import Maybes
import System.Environment ( getEnv )
import Distribution.InstalledPackageInfo
import Distribution.InstalledPackageInfo.Binary
import Distribution.Package hiding (PackageId,depends)
import FastString
import ErrUtils ( debugTraceMsg, putMsg, Message )
......@@ -204,44 +205,40 @@ getSystemPackageConfigs dflags = do
-- System one always comes first
let system_pkgconf = systemPackageConfig dflags
-- allow package.conf.d to contain a bunch of .conf files
-- containing package specifications. This is an easier way
-- 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"
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
| file <- files
, takeExtension file == ".conf" ]
else return []
-- Read user's package conf (eg. ~/.ghc/i386-linux-6.3/package.conf)
-- unless the -no-user-package-conf flag was given.
-- We only do this when getAppUserDataDirectory is available
-- (GHC >= 6.3).
user_pkgconf <- do
if not (dopt Opt_ReadUserPackageConf dflags) then return [] else do
appdir <- getAppUserDataDirectory "ghc"
let
pkgconf = appdir
</> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
</> "package.conf"
flg <- doesFileExist pkgconf
if (flg && dopt Opt_ReadUserPackageConf dflags)
then return [pkgconf]
else return []
dir = appdir </> (TARGET_ARCH ++ '-':TARGET_OS ++ '-':cProjectVersion)
pkgconf = dir </> "package.conf.d"
--
exist <- doesDirectoryExist pkgconf
if exist then return [pkgconf] else return []
`catchIO` (\_ -> return [])
return (user_pkgconf ++ system_pkgconfs ++ [system_pkgconf])
return (user_pkgconf ++ [system_pkgconf])
readPackageConfig :: DynFlags -> FilePath -> IO [PackageConfig]
readPackageConfig dflags conf_file = do
debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
proto_pkg_configs <- loadPackageConfig dflags conf_file
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)
conf <- readBinPackageDB filename
return (map installedPackageInfoToPackageConfig conf)
else do
isfile <- doesFileExist conf_file
when (not isfile) $
ghcError $ InstallationError $
"can't find a package database at " ++ conf_file
debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
loadPackageConfig dflags conf_file
let
top_dir = topDir dflags
pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
......
......@@ -160,7 +160,7 @@ initSysTools mbMinusB dflags0
installed file = top_dir </> file
installed_mingw_bin file = top_dir </> ".." </> "mingw" </> "bin" </> file
; let pkgconfig_path = installed "package.conf"
; let pkgconfig_path = installed "package.conf.d"
ghc_usage_msg_path = installed "ghc-usage.txt"
ghci_usage_msg_path = installed "ghci-usage.txt"
......@@ -177,12 +177,6 @@ initSysTools mbMinusB dflags0
; tmpdir <- getTemporaryDirectory
; let dflags1 = setTmpDir tmpdir dflags0
-- Check that the package config exists
; config_exists <- doesFileExist pkgconfig_path
; when (not config_exists) $
ghcError (InstallationError
("Can't find package.conf as " ++ pkgconfig_path))
-- On Windows, mingw is distributed with GHC,
-- so we look in TopDir/../mingw/bin
; let
......
......@@ -171,6 +171,8 @@ libraries/hpc_dist-boot_DO_HADDOCK = NO
libraries/Cabal_dist-boot_DO_HADDOCK = NO
libraries/extensible-exceptions_dist-boot_DO_HADDOCK = NO
libraries/filepath_dist-boot_DO_HADDOCK = NO
libraries/binary_dist-boot_DO_HADDOCK = NO
libraries/bin-package-db_dist-boot_DO_HADDOCK = NO
# -----------------------------------------------------------------------------
# Ways
......@@ -320,6 +322,8 @@ $(eval $(call addPackage,syb))
$(eval $(call addPackage,template-haskell))
$(eval $(call addPackage,base3-compat))
$(eval $(call addPackage,Cabal))
$(eval $(call addPackage,binary))
$(eval $(call addPackage,bin-package-db))
$(eval $(call addPackage,mtl))
$(eval $(call addPackage,utf8-string))
......@@ -337,7 +341,9 @@ PACKAGES_STAGE2 += \
dph/dph-par
endif
BOOT_PKGS = Cabal hpc extensible-exceptions
# We assume that the stage0 compiler has a suitable bytestring package,
# so we don't have to include it below.
BOOT_PKGS = Cabal hpc extensible-exceptions binary bin-package-db
# The actual .a and .so/.dll files: needed for dependencies.
ALL_STAGE1_LIBS = $(foreach lib,$(PACKAGES),$(libraries/$(lib)_dist-install_v_LIB))
......@@ -628,6 +634,8 @@ $(eval $(call clean-target,$(BOOTSTRAPPING_CONF),,$(BOOTSTRAPPING_CONF)))
$(eval $(call build-package,libraries/hpc,dist-boot,0))
$(eval $(call build-package,libraries/extensible-exceptions,dist-boot,0))
$(eval $(call build-package,libraries/Cabal,dist-boot,0))
$(eval $(call build-package,libraries/binary,dist-boot,0))
$(eval $(call build-package,libraries/bin-package-db,dist-boot,0))
# register the boot packages in strict sequence, because running
# multiple ghc-pkgs in parallel doesn't work (registrations may get
......@@ -638,13 +646,23 @@ $(foreach pkg,$(BOOT_PKGS),$(eval $(call fixed_pkg_dep,$(pkg),dist-boot)))
compiler/stage1/package-data.mk : \
libraries/Cabal/dist-boot/package-data.mk \
libraries/hpc/dist-boot/package-data.mk \
libraries/extensible-exceptions/dist-boot/package-data.mk
libraries/extensible-exceptions/dist-boot/package-data.mk \
libraries/bin-package-db/dist-boot/package-data.mk
# These are necessary because the bootstrapping compiler may not know
# about cross-package dependencies:
$(compiler_stage1_depfile) : $(BOOT_LIBS)
$(ghc_stage1_depfile) : $(compiler_stage1_v_LIB)
# A few careful dependencies between bootstrapping packages. When we
# can rely on the stage 0 compiler being able to generate
# cross-package dependencies with -M (fixed in GHC 6.12.1) we can drop
# these, and also some of the phases.
#
# If you miss any out here, then 'make -j8' will probably tell you.
#
libraries/bin-package-db/dist-boot/build/Distribution/InstalledPackageInfo/Binary.$(v_osuf) : libraries/binary/dist-boot/build/Data/Binary.$(v_hisuf)
$(foreach pkg,$(BOOT_PKGS),$(eval libraries/$(pkg)_dist-boot_HC_OPTS += $$(GhcBootLibHcOpts)))
endif
......@@ -770,7 +788,7 @@ install_docs: $(INSTALL_HEADERS)
$(INSTALL_DOC) $(INSTALL_OPTS) $$i/* $(DESTDIR)$(docdir)/html/`basename $$i`; \
done
INSTALLED_PACKAGE_CONF=$(DESTDIR)$(topdir)/package.conf
INSTALLED_PACKAGE_CONF=$(DESTDIR)$(topdir)/package.conf.d
# Install packages in the right order, so that ghc-pkg doesn't complain.
# Also, install ghc-pkg first.
......@@ -785,9 +803,8 @@ endif
install_packages: install_libexecs
install_packages: libffi/package.conf.install rts/package.conf.install
$(INSTALL_DIR) $(DESTDIR)$(topdir)
"$(RM)" $(RM_OPTS) $(INSTALLED_PACKAGE_CONF)
$(CREATE_DATA) $(INSTALLED_PACKAGE_CONF)
echo "[]" >> $(INSTALLED_PACKAGE_CONF)
"$(RM)" -r $(RM_OPTS) $(INSTALLED_PACKAGE_CONF)
$(INSTALL_DIR) $(INSTALLED_PACKAGE_CONF)
"$(INSTALLED_GHC_PKG_REAL)" --force --global-conf $(INSTALLED_PACKAGE_CONF) update libffi/package.conf.install
"$(INSTALLED_GHC_PKG_REAL)" --force --global-conf $(INSTALLED_PACKAGE_CONF) update rts/package.conf.install
$(foreach p, $(PACKAGES) $(PACKAGES_STAGE2),\
......
{-# LANGUAGE RecordWildCards, TypeSynonymInstances, StandaloneDeriving, GeneralizedNewtypeDeriving #-}
-----------------------------------------------------------------------------
-- |
-- Module : Distribution.InstalledPackageInfo.Binary
-- Copyright : (c) The University of Glasgow 2009
--
-- Maintainer : cvs-ghc@haskell.org
-- Portability : portable
--
module Distribution.InstalledPackageInfo.Binary (
readBinPackageDB,
writeBinPackageDB
) where
import Distribution.Version
import Distribution.Package
import Distribution.License
import Distribution.InstalledPackageInfo as IPI
import Data.Binary as Bin
readBinPackageDB :: Binary m => FilePath -> IO [InstalledPackageInfo_ m]
readBinPackageDB file = Bin.decodeFile file
writeBinPackageDB :: Binary m => FilePath -> [InstalledPackageInfo_ m] -> IO ()
writeBinPackageDB file ipis = Bin.encodeFile file ipis
instance Binary m => Binary (InstalledPackageInfo_ m) where
put = putInstalledPackageInfo
get = getInstalledPackageInfo
putInstalledPackageInfo :: Binary m => InstalledPackageInfo_ m -> Put
putInstalledPackageInfo ipi = do
put (sourcePackageId ipi)
put (installedPackageId ipi)
put (license ipi)
put (copyright ipi)
put (maintainer ipi)
put (author ipi)
put (stability ipi)
put (homepage ipi)
put (pkgUrl ipi)
put (description ipi)
put (category ipi)
put (exposed ipi)
put (exposedModules ipi)
put (hiddenModules ipi)
put (importDirs ipi)
put (libraryDirs ipi)
put (hsLibraries ipi)
put (extraLibraries ipi)
put (extraGHCiLibraries ipi)
put (includeDirs ipi)
put (includes ipi)
put (IPI.depends ipi)
put (hugsOptions ipi)
put (ccOptions ipi)
put (ldOptions ipi)
put (frameworkDirs ipi)
put (frameworks ipi)
put (haddockInterfaces ipi)
put (haddockHTMLs ipi)
getInstalledPackageInfo :: Binary m => Get (InstalledPackageInfo_ m)
getInstalledPackageInfo = do
sourcePackageId <- get
installedPackageId <- get
license <- get
copyright <- get
maintainer <- get
author <- get
stability <- get
homepage <- get
pkgUrl <- get
description <- get
category <- get
exposed <- get
exposedModules <- get
hiddenModules <- get
importDirs <- get
libraryDirs <- get
hsLibraries <- get
extraLibraries <- get
extraGHCiLibraries <- get
includeDirs <- get
includes <- get
depends <- get
hugsOptions <- get
ccOptions <- get
ldOptions <- get
frameworkDirs <- get
frameworks <- get
haddockInterfaces <- get
haddockHTMLs <- get
return InstalledPackageInfo{..}
instance Binary PackageIdentifier where
put pid = do put (pkgName pid); put (pkgVersion pid)
get = do
pkgName <- get
pkgVersion <- get
return PackageIdentifier{..}
instance Binary License where
put (GPL v) = do putWord8 0; put v
put (LGPL v) = do putWord8 1; put v
put BSD3 = do putWord8 2
put BSD4 = do putWord8 3
put MIT = do putWord8 4
put PublicDomain = do putWord8 5
put AllRightsReserved = do putWord8 6
put OtherLicense = do putWord8 7
put (UnknownLicense str) = do putWord8 8; put str
get = do
n <- getWord8
case n of
0 -> do v <- get; return (GPL v)
1 -> do v <- get; return (LGPL v)
2 -> return BSD3
3 -> return BSD4
4 -> return MIT
5 -> return PublicDomain
6 -> return AllRightsReserved
7 -> return OtherLicense
8 -> do str <- get; return (UnknownLicense str)
instance Binary Version where
put v = do put (versionBranch v); put (versionTags v)
get = do versionBranch <- get; versionTags <- get; return Version{..}
deriving instance Binary PackageName
deriving instance Binary InstalledPackageId
name: bin-package-db
version: 0.0.0.0
license: BSD3
maintainer: cvs-ghc@haskell.org
bug-reports: glasgow-haskell-bugs@haskell.org
synopsis: A binary format for the package database
cabal-version: >=1.6
build-type: Simple
source-repository head
type: darcs
location: http://darcs.haskell.org/ghc
Library {
exposed-modules:
Distribution.InstalledPackageInfo.Binary
build-depends: base == 4.*,
binary == 0.5.*,
Cabal == 1.7.*
}
......@@ -500,7 +500,7 @@ INSTALL_GHC_STAGE=2
BOOTSTRAPPING_CONF = libraries/bootstrapping.conf
INPLACE_PACKAGE_CONF = $(INPLACE_LIB)/package.conf
INPLACE_PACKAGE_CONF = $(INPLACE_LIB)/package.conf.d
GhcVersion = @GhcVersion@
GhcPatchLevel = @GhcPatchLevel@
......
......@@ -22,6 +22,7 @@ utils/haddock haddock2 darcs
libraries/array packages/array darcs
libraries/base packages/base darcs
libraries/base3-compat packages/base3-compat darcs
libraries/binary packages/binary darcs
libraries/bytestring packages/bytestring darcs
libraries/Cabal packages/Cabal darcs
libraries/containers packages/containers darcs
......
......@@ -155,7 +155,7 @@ doInstall ghc ghcpkg topdir directory distDir myDestDir myPrefix myLibdir myDocd
programArgs = ["-B" ++ topdir],
programLocation = UserSpecified ghc
}
ghcpkgconf = topdir </> "package.conf"
ghcpkgconf = topdir </> "package.conf.d"
ghcPkgProg = ConfiguredProgram {
programId = programName ghcPkgProgram,
programVersion = Nothing,
......
<
......@@ -10,6 +10,7 @@
module Main (main) where
import Version ( version, targetOS, targetARCH )
import Distribution.InstalledPackageInfo.Binary
import qualified Distribution.Simple.PackageIndex as PackageIndex
import Distribution.ModuleName hiding (main)
import Distribution.InstalledPackageInfo
......@@ -20,14 +21,15 @@ import Distribution.Text
import Distribution.Version
import System.FilePath
import System.Cmd ( rawSystem )
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing )
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
getModificationTime )
import Text.Printf
import Prelude
#include "../../includes/ghcconfig.h"
import System.Console.GetOpt
import Text.PrettyPrint
#if __GLASGOW_HASKELL__ >= 609
import qualified Control.Exception as Exception
#else
......@@ -67,6 +69,10 @@ import System.Process(runInteractiveCommand)
import qualified System.Info(os)
#endif
#if __GLASGOW_HASKELL__ >= 611
import System.Console.Terminfo as Terminfo
#endif
-- -----------------------------------------------------------------------------
-- Entry point
......@@ -323,23 +329,27 @@ runit verbosity cli nonopts = do
listPackages verbosity cli Nothing (Just match)
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
latestPackage cli pkgid
latestPackage verbosity cli pkgid
["describe", pkgid_str] ->
case substringCheck pkgid_str of
Nothing -> do pkgid <- readGlobPkgId pkgid_str
describePackage cli (Id pkgid)
Just m -> describePackage cli (Substring pkgid_str m)
describePackage verbosity cli (Id pkgid)
Just m -> describePackage verbosity cli (Substring pkgid_str m)
["field", pkgid_str, fields] ->
case substringCheck pkgid_str of
Nothing -> do pkgid <- readGlobPkgId pkgid_str
describeField cli (Id pkgid) (splitFields fields)
Just m -> describeField cli (Substring pkgid_str m)
describeField verbosity cli (Id pkgid)
(splitFields fields)
Just m -> describeField verbosity cli (Substring pkgid_str m)
(splitFields fields)
["check"] -> do
checkConsistency cli
checkConsistency verbosity cli
["dump"] -> do
dumpPackages cli
dumpPackages verbosity cli
["recache"] -> do
recache verbosity cli
[] -> do
die ("missing command\n" ++
......@@ -381,19 +391,33 @@ globVersion = Version{ versionBranch=[], versionTags=["*"] }
-- Some commands operate on multiple databases, with overlapping semantics:
-- list, describe, field
type PackageDBName = FilePath
type PackageDB = [InstalledPackageInfo]
data PackageDB
= PackageDB { location :: FilePath,
packages :: [InstalledPackageInfo] }
type NamedPackageDB = (PackageDBName, PackageDB)
type PackageDBStack = [NamedPackageDB]
type PackageDBStack = [PackageDB]
-- A stack of package databases. Convention: head is the topmost
-- in the stack. Earlier entries override later one.
-- in the stack.
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
allPackagesInStack = concatMap snd
allPackagesInStack = concatMap packages
getPkgDatabases :: Bool -> [Flag] -> IO (PackageDBStack, Maybe PackageDBName)
getPkgDatabases modify my_flags = do
getPkgDatabases :: Verbosity
-> Bool -- we are modifying, not reading
-> Bool -- read caches, if available
-> [Flag]
-> IO (PackageDBStack,
-- the real package DB stack: [global,user] ++
-- DBs specified on the command line with -f.
Maybe FilePath,
-- which one to modify, if any
PackageDBStack)
-- the package DBs specified on the command
-- line, or [global,user] otherwise. This
-- is used as the list of package DBs for
-- commands that just read the DB, such as 'list'.
getPkgDatabases verbosity modify use_cache my_flags = do
-- first we determine the location of the global package config. On Windows,
-- this is found relative to the ghc-pkg.exe binary, whereas on Unix the
-- location is passed to the binary using the --global-config flag by the
......@@ -403,47 +427,38 @@ getPkgDatabases modify my_flags = do
case [ f | FlagGlobalConfig f <- my_flags ] of
[] -> do mb_dir <- getLibDir
case mb_dir of
Nothing -> die err_msg
Just dir ->
do let path = dir </> "package.conf"
exists <- doesFileExist path
unless exists $ die "Can't find package.conf"
return path
Nothing -> die err_msg
Just dir -> do
r <- lookForPackageDBIn dir
case r of
Nothing -> die ("Can't find package database in " ++ dir)
Just path -> return path
fs -> return (last fs)
let global_conf_dir = global_conf ++ ".d"
global_conf_dir_exists <- doesDirectoryExist global_conf_dir
global_confs <-
if global_conf_dir_exists
then do files <- getDirectoryContents global_conf_dir
return [ global_conf_dir ++ '/' : file
| file <- files
, isSuffixOf ".conf" file]
else return []
let no_user_db = FlagNoUserDb `elem` my_flags
-- get the location of the user package database, and create it if necessary
-- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
appdir <- try $ getAppUserDataDirectory "ghc"
e_appdir <- try $ getAppUserDataDirectory "ghc"
mb_user_conf <-
if no_user_db then return Nothing else
case appdir of
Right dir -> do
let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
user_conf = dir </> subdir </> "package.conf"
user_exists <- doesFileExist user_conf
return (Just (user_conf,user_exists))
Left _ ->
return Nothing
case e_appdir of
Left _ -> return Nothing
Right appdir -> do
let subdir = targetARCH ++ '-':targetOS ++ '-':Version.version
dir = appdir </> subdir
r <- lookForPackageDBIn dir
case r of
Nothing -> return (Just (dir </> "package.conf.d", False))
Just f -> return (Just (f, True))
-- If the user database doesn't exist, and this command isn't a
-- "modify" command, then we won't attempt to create or use it.
let sys_databases
| Just (user_conf,user_exists) <- mb_user_conf,
modify || user_exists = user_conf : global_confs ++ [global_conf]
| otherwise = global_confs ++ [global_conf]
modify || user_exists = [user_conf, global_conf]
| otherwise = [global_conf]
e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
let env_stack =
......@@ -466,52 +481,108 @@ getPkgDatabases modify my_flags = do
is_db_flag (FlagConfig f) = Just f
is_db_flag _ = Nothing
(final_stack, to_modify) <-
if not modify
then -- For a "read" command, we use all the databases
-- specified on the command line. If there are no
-- command-line flags specifying databases, the default
-- is to use all the ones we know about.
if null db_flags then return (env_stack, Nothing)
else return (reverse (nub db_flags), Nothing)
else let
-- For a "modify" command, treat all the databases as
-- a stack, where we are modifying the top one, but it
-- can refer to packages in databases further down the
-- stack.
-- -f flags on the command line add to the database
-- stack, unless any of them are present in the stack
-- already.
flag_stack = filter (`notElem` env_stack)
[ f | FlagConfig f <- reverse my_flags ]
++ env_stack
-- the database we actually modify is the one mentioned
-- rightmost on the command-line.
to_modify = if null db_flags
then Just virt_global_conf
else Just (last db_flags)
in
return (flag_stack, to_modify)
db_stack <- mapM (readParseDatabase mb_user_conf) final_stack
return (db_stack, to_modify)
readParseDatabase :: Maybe (PackageDBName,Bool)
-> PackageDBName
-> IO (PackageDBName,PackageDB)
readParseDatabase mb_user_conf filename
let flag_db_names | null db_flags = env_stack
| otherwise = reverse (nub db_flags)
-- For a "modify" command, treat all the databases as
-- a stack, where we are modifying the top one, but it
-- can refer to packages in databases further down the
-- stack.
-- -f flags on the command line add to the database
-- stack, unless any of them are present in the stack
-- already.
let final_stack = filter (`notElem` env_stack)
[ f | FlagConfig f <- reverse my_flags ]
++ env_stack
-- the database we actually modify is the one mentioned
-- rightmost on the command-line.
let to_modify
| not modify = Nothing
| null db_flags = Just virt_global_conf
| otherwise = Just (last db_flags)
db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack
let flag_db_stack = [ db | db_name <- flag_db_names,
db <- db_stack, location db == db_name ]
return (db_stack, to_modify, flag_db_stack)
lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
lookForPackageDBIn dir = do
let path_dir = dir </> "package.conf.d"
exists_dir <- doesDirectoryExist path_dir
if exists_dir then return (Just path_dir) else do
let path_file = dir </> "package.conf"
exists_file <- doesFileExist path_file
if exists_file then return (Just path_file) else return Nothing
readParseDatabase :: Verbosity
-> Maybe (FilePath,Bool)
-> Bool -- use cache
-> FilePath
-> IO PackageDB
readParseDatabase verbosity mb_user_conf use_cache path
-- the user database (only) is allowed to be non-existent
| Just (user_conf,False) <- mb_user_conf, filename == user_conf
= return (filename, [])
| Just (user_conf,False) <- mb_user_conf, path == user_conf
= return PackageDB { location = path, packages = [] }
| otherwise
= do str <- readFile filename
let packages = map convertPackageInfoIn $ read str
_ <- Exception.evaluate packages
`catchError` \e->
die ("error while parsing " ++ filename ++ ": " ++ show e)
return (filename,packages)
= do e <- try $ getDirectoryContents path
case e of
Left _ -> do
pkgs <- parseMultiPackageConf verbosity path
return PackageDB{ location = path, packages = pkgs }
Right fs
| not use_cache -> ignore_cache
| otherwise -> do
let cache = path </> cachefilename
tdir <- getModificationTime path
e_tcache <- try $ getModificationTime cache
case e_tcache of
Left ex -> do
when (verbosity > Normal) $
putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex)
ignore_cache
Right tcache
| tcache >= tdir -> do
when (verbosity > Normal) $
putStrLn ("using cache: " ++ cache)
pkgs <- readBinPackageDB cache
let pkgs' = map convertPackageInfoIn pkgs
return PackageDB { location = path, packages = pkgs' }
| otherwise -> do
when (verbosity >= Normal) $ do
putStrLn ("WARNING: cache is out of date: " ++ cache)
putStrLn " use 'ghc-pkg recache' to fix."
ignore_cache
where
ignore_cache = do
let confs = filter (".conf" `isSuffixOf`) fs
pkgs <- mapM (parseSingletonPackageConf verbosity) $
map (path </>) confs
return PackageDB { location = path, packages = pkgs }
parseMultiPackageConf :: Verbosity -> FilePath -> IO [InstalledPackageInfo]
parseMultiPackageConf verbosity file = do
when (verbosity > Normal) $ putStrLn ("reading package database: " ++ file)
str <- readFile file
let pkgs = map convertPackageInfoIn $ read str
Exception.evaluate pkgs
`catchError` \e->
die ("error while parsing " ++ file ++ ": " ++ show e)
parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
parseSingletonPackageConf verbosity file = do
when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file)
readFile file >>= parsePackageInfo