Commit 39a4e6bf authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Make the compiler PackageDB stuff more flexible

We support using multiple package dbs, however the method for
specifying them is very limited. We specify a single package db
and that implicitly specifies any other needed dbs. For example
the user or a specific db require the global db too. We now
represent that stack explicitly. The user interface still uses
the single value method and we convert internally.
parent 7e0c881f
......@@ -55,6 +55,7 @@ module Distribution.Simple.Compiler (
-- * Support for package databases
PackageDB(..),
PackageDBStack,
-- * Support for optimisation levels
OptimisationLevel(..),
......@@ -99,11 +100,30 @@ compilerVersion = (\(CompilerId _ v) -> v) . compilerId
-- the file system. This can be used to build isloated environments of
-- packages, for example to build a collection of related packages
-- without installing them globally.
--
data PackageDB = GlobalPackageDB
| UserPackageDB
| SpecificPackageDB FilePath
deriving (Eq, Show, Read)
-- | We typically get packages from several databases, and stack them
-- together. This type lets us be explicit about that stacking. For example
-- typical stacks include:
--
-- > [GlobalPackageDB]
-- > [GlobalPackageDB, UserPackageDB]
-- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"]
--
-- Note that the 'GlobalPackageDB' is invariably at the bottom since it
-- contains the rts, base and other special compiler-specific packages.
--
-- We are not restricted to using just the above combinations. In particular
-- we can use several custom package dbs and the user package db together.
--
-- When it comes to writing, the top most (last) package is used.
--
type PackageDBStack = [PackageDB]
-- ------------------------------------------------------------
-- * Optimisation levels
-- ------------------------------------------------------------
......
......@@ -67,7 +67,7 @@ module Distribution.Simple.Configure (configure,
import Distribution.Simple.Compiler
( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion
, showCompilerId, unsupportedExtensions, PackageDB(..) )
, showCompilerId, unsupportedExtensions, PackageDB(..), PackageDBStack )
import Distribution.Package
( PackageName(PackageName), PackageIdentifier(PackageIdentifier)
, packageVersion, Package(..), Dependency(Dependency) )
......@@ -291,9 +291,8 @@ configure (pkg_descr0, pbi) cfg
let version = compilerVersion comp
flavor = compilerFlavor comp
-- FIXME: currently only GHC has hc-pkg
maybePackageSet <- getInstalledPackages (lessVerbose verbosity) comp
packageDb programsConfig'
(implicitPackageDbStack packageDb) programsConfig'
(pkg_descr0', flags) <- case pkg_descr0 of
Left ppd ->
......@@ -510,16 +509,28 @@ configDependency verbosity index dep@(Dependency pkgname _) =
++ ": using " ++ display pkgid
return pkgid
getInstalledPackages :: Verbosity -> Compiler -> PackageDB -> ProgramConfiguration
getInstalledPackages :: Verbosity -> Compiler
-> PackageDBStack -> ProgramConfiguration
-> IO (Maybe (PackageIndex InstalledPackageInfo))
getInstalledPackages verbosity comp packageDb progconf = do
getInstalledPackages verbosity comp packageDBs progconf = do
info verbosity "Reading installed packages..."
case compilerFlavor comp of
GHC -> Just `fmap` GHC.getInstalledPackages verbosity packageDb progconf
JHC -> Just `fmap` JHC.getInstalledPackages verbosity packageDb progconf
LHC -> Just `fmap` LHC.getInstalledPackages verbosity packageDb progconf
GHC -> Just `fmap` GHC.getInstalledPackages verbosity packageDBs progconf
JHC -> Just `fmap` JHC.getInstalledPackages verbosity packageDBs progconf
LHC -> Just `fmap` LHC.getInstalledPackages verbosity packageDBs progconf
_ -> return Nothing
-- | Currently the user interface specifies the package dbs to use with just a
-- single valued option, a 'PackageDB'. However internally we represent the
-- stack of 'PackageDB's explictly as a list. This function converts encodes
-- the package db stack implicit in a single packagedb.
--
implicitPackageDbStack :: PackageDB -> PackageDBStack
implicitPackageDbStack packageDB = case packageDB of
GlobalPackageDB -> [GlobalPackageDB]
UserPackageDB -> [GlobalPackageDB, UserPackageDB]
SpecificPackageDB p -> [GlobalPackageDB, SpecificPackageDB p]
-- -----------------------------------------------------------------------------
-- Configuring program dependencies
......
......@@ -104,7 +104,8 @@ import Distribution.Simple.Program
, gccProgram, stripProgram )
import Distribution.Simple.Compiler
( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion
, OptimisationLevel(..), PackageDB(..), Flag, extensionsToFlags )
, OptimisationLevel(..), PackageDB(..), PackageDBStack
, Flag, extensionsToFlags )
import Distribution.Version
( Version(..), anyVersion, orLaterVersion )
import Distribution.System
......@@ -333,13 +334,11 @@ oldLanguageExtensions =
where
fglasgowExts = "-fglasgow-exts"
getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration
getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
-> IO (PackageIndex InstalledPackageInfo)
getInstalledPackages verbosity packagedb conf = do
let packagedbs = case packagedb of
GlobalPackageDB -> [GlobalPackageDB]
_ -> [GlobalPackageDB, packagedb]
getInstalledPackages verbosity packagedbs conf = do
pkgss <- getInstalledPackages' verbosity packagedbs conf
checkPackageDbStack packagedbs
let pkgs = concatMap snd pkgss
-- On Windows, various fields have $topdir/foo rather than full
-- paths. We need to substitute the right value in so that when
......@@ -354,6 +353,13 @@ getInstalledPackages verbosity packagedb conf = do
pi2 = pi1 `merge` fromList rtsPackages'
return pi2
checkPackageDbStack :: PackageDBStack -> IO ()
checkPackageDbStack (GlobalPackageDB:rest)
| GlobalPackageDB `notElem` rest = return ()
checkPackageDbStack _ =
die $ "GHC.getInstalledPackages: the global package db must be "
++ "specified first and cannot be specified multiple times"
-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This
-- breaks when you want to use a different gcc, so we need to filter
-- it out.
......
......@@ -61,7 +61,7 @@ import Distribution.Simple.BuildPaths
( autogenModulesDir, exeExtension )
import Distribution.Simple.Compiler
( CompilerFlavor(..), CompilerId(..), Compiler(..)
, PackageDB, Flag, extensionsToFlags )
, PackageDB(..), PackageDBStack, Flag, extensionsToFlags )
import Language.Haskell.Extension (Extension(..))
import Distribution.Simple.Program ( ConfiguredProgram(..), jhcProgram,
ProgramConfiguration, userMaybeSpecifyPath,
......@@ -111,9 +111,13 @@ jhcLanguageExtensions =
,(CPP , "-fcpp")
]
getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration
getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
-> IO (PackageIndex InstalledPackageInfo)
getInstalledPackages verbosity _packagedb conf = do
getInstalledPackages verbosity packageDBs conf = do
case packageDBs of
[GlobalPackageDB] -> return ()
_ -> die "JHC does not yet support multiple package DBs"
str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"]
case pCheck (readP_to_S (many (skipSpaces >> parse)) str) of
[ps] -> return $ PackageIndex.fromList
......
......@@ -58,7 +58,7 @@ import Distribution.Simple.BuildPaths
( autogenModulesDir, exeExtension )
import Distribution.Simple.Compiler
( CompilerFlavor(..), CompilerId(..), Compiler(..)
, PackageDB(..), Flag, extensionsToFlags )
, PackageDB(..), PackageDBStack, Flag, extensionsToFlags )
import Language.Haskell.Extension (Extension(..))
import Distribution.Simple.Program
( ConfiguredProgram(..), lhcProgram, ProgramConfiguration
......@@ -78,6 +78,7 @@ import Distribution.Text
import System.FilePath ( (</>) )
import System.Directory ( getAppUserDataDirectory )
import Data.List ( nub )
import Data.Maybe ( catMaybes )
import qualified Distribution.Simple.GHC as GHC
......@@ -124,16 +125,28 @@ getLhcLibDirsFromVersion _
= return ("","")
getInstalledPackages :: Verbosity -> PackageDB -> ProgramConfiguration
getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration
-> IO (PackageIndex InstalledPackageInfo)
getInstalledPackages verbosity packagedb conf = do
getInstalledPackages verbosity packageDBs conf = do
(globalDir, userDir) <- getLhcLibDirs verbosity conf
let extraArgs = [ "--global-conf="++globalDir </> "package.conf"
, "--package-conf=" ++ case packagedb of
SpecificPackageDB path -> path
_ -> userDir </> "package.conf"]
let (extraArgs, packageDBs') = (\(a,b) -> (catMaybes a, catMaybes b))
. unzip
. map (fixPackageDB globalDir userDir)
$ packageDBs
-- Yes, LHC really does use ghc-pkg (with a different package.conf).
GHC.getInstalledPackages verbosity GlobalPackageDB $ userSpecifyArgs "ghc-pkg" extraArgs conf
GHC.getInstalledPackages verbosity packageDBs' $
userSpecifyArgs "ghc-pkg" extraArgs conf
where
fixPackageDB globalDir userDir packageDB = case packageDB of
GlobalPackageDB -> (Just flag, Just packageDB)
where flag = "--global-conf="
++ globalDir </> "package.conf"
UserPackageDB -> (Nothing, Just packageDB')
where packageDB' = SpecificPackageDB
(userDir </> "package.conf")
SpecificPackageDB _ -> (Nothing, Just packageDB)
-- -----------------------------------------------------------------------------
-- Building
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment