Commit 12b222af authored by Duncan Coutts's avatar Duncan Coutts
Browse files

Extend HcPkg.init support for dir-style package dbs

The HcPkgInfo useSingleFileDb is split into two: supportsDirDbs and
requiresDirDbs. Then rather than HcPkg.init callers having to do the
writeFile [] thing, HcPkg.init does it itself automatically based on the
HcPkgInfo. In the case that supportsDirDbs is True but requiresDirDbs is
False then we have a choice, to use dir style or file style. For
compatability reasons, when using ghc/ghc-pkg for the inplace package db
we want to use the old file style, even though dir style is supported.
However in other circumstances (e.g. in places in cabal-install) we
would like to use the dir style if it's supported, and there are no
backwards compat issues. So HcPkg.init gains a new Bool arg to request
using the file style if it's still supported. Only this mode is used
within Cabal itself, but the non-compat mode is available for other
users.

The compiler-independent initPackageDB is left with the same old
behaviour, but a new createPackageDB has the extra compat argument
(which is only passed to hc-pkg for ghc-pkg).
parent dee7e0a5
...@@ -486,9 +486,7 @@ createInternalPackageDB verbosity lbi distPref = do ...@@ -486,9 +486,7 @@ createInternalPackageDB verbosity lbi distPref = do
then removeDirectoryRecursive dbPath then removeDirectoryRecursive dbPath
else do file_exists <- doesFileExist dbPath else do file_exists <- doesFileExist dbPath
when file_exists $ removeFile dbPath when file_exists $ removeFile dbPath
if HcPkg.useSingleFileDb hpi HcPkg.init hpi verbosity True dbPath
then writeFile dbPath "[]"
else HcPkg.init hpi verbosity dbPath
return packageDB return packageDB
addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo addInternalBuildTools :: PackageDescription -> LocalBuildInfo -> BuildInfo
......
...@@ -1119,7 +1119,8 @@ hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcPkgProg ...@@ -1119,7 +1119,8 @@ hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcPkgProg
, HcPkg.noPkgDbStack = v < [6,9] , HcPkg.noPkgDbStack = v < [6,9]
, HcPkg.noVerboseFlag = v < [6,11] , HcPkg.noVerboseFlag = v < [6,11]
, HcPkg.flagPackageConf = v < [7,5] , HcPkg.flagPackageConf = v < [7,5]
, HcPkg.useSingleFileDb = v < [7,9] , HcPkg.supportsDirDbs = v >= [6,8]
, HcPkg.requiresDirDbs = v >= [7,10]
} }
where where
v = versionBranch ver v = versionBranch ver
......
...@@ -869,7 +869,8 @@ hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg ...@@ -869,7 +869,8 @@ hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = ghcjsPkgProg
, HcPkg.noPkgDbStack = False , HcPkg.noPkgDbStack = False
, HcPkg.noVerboseFlag = False , HcPkg.noVerboseFlag = False
, HcPkg.flagPackageConf = False , HcPkg.flagPackageConf = False
, HcPkg.useSingleFileDb = v < [7,9] , HcPkg.supportsDirDbs = True
, HcPkg.requiresDirDbs = v >= [7,10]
} }
where where
v = versionBranch ver v = versionBranch ver
......
...@@ -787,7 +787,8 @@ hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = lhcPkgProg ...@@ -787,7 +787,8 @@ hcPkgInfo conf = HcPkg.HcPkgInfo { HcPkg.hcPkgProgram = lhcPkgProg
, HcPkg.noPkgDbStack = False , HcPkg.noPkgDbStack = False
, HcPkg.noVerboseFlag = False , HcPkg.noVerboseFlag = False
, HcPkg.flagPackageConf = False , HcPkg.flagPackageConf = False
, HcPkg.useSingleFileDb = True , HcPkg.supportsDirDbs = True
, HcPkg.requiresDirDbs = True
} }
where where
Just lhcPkgProg = lookupProgram lhcPkgProgram conf Just lhcPkgProg = lookupProgram lhcPkgProgram conf
...@@ -75,16 +75,22 @@ data HcPkgInfo = HcPkgInfo ...@@ -75,16 +75,22 @@ data HcPkgInfo = HcPkgInfo
, noPkgDbStack :: Bool -- ^ no package DB stack supported , noPkgDbStack :: Bool -- ^ no package DB stack supported
, noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags , noVerboseFlag :: Bool -- ^ hc-pkg does not support verbosity flags
, flagPackageConf :: Bool -- ^ use package-conf option instead of package-db , flagPackageConf :: Bool -- ^ use package-conf option instead of package-db
, useSingleFileDb :: Bool -- ^ requires single file package database , supportsDirDbs :: Bool -- ^ supports directory style package databases
, requiresDirDbs :: Bool -- ^ requires directory style package databases
} }
-- | Call @hc-pkg@ to initialise a package database at the location {path}. -- | Call @hc-pkg@ to initialise a package database at the location {path}.
-- --
-- > hc-pkg init {path} -- > hc-pkg init {path}
-- --
init :: HcPkgInfo -> Verbosity -> FilePath -> IO () init :: HcPkgInfo -> Verbosity -> Bool -> FilePath -> IO ()
init hpi verbosity path = init hpi verbosity preferCompat path
runProgramInvocation verbosity (initInvocation hpi verbosity path) | not (supportsDirDbs hpi)
|| (not (requiresDirDbs hpi) && preferCompat)
= writeFile path "[]"
| otherwise
= runProgramInvocation verbosity (initInvocation hpi verbosity path)
-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it. -- provided command-line arguments to it.
......
...@@ -208,15 +208,23 @@ relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb = ...@@ -208,15 +208,23 @@ relocRegistrationInfo verbosity pkg lib lbi clbi abi_hash packageDb =
_ -> die "Distribution.Simple.Register.relocRegistrationInfo: \ _ -> die "Distribution.Simple.Register.relocRegistrationInfo: \
\not implemented for this compiler" \not implemented for this compiler"
initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath -> IO ()
initPackageDB verbosity comp progdb dbPath =
createPackageDB verbosity comp progdb True dbPath
-- | Create an empty package DB at the specified location. -- | Create an empty package DB at the specified location.
initPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> FilePath createPackageDB :: Verbosity -> Compiler -> ProgramConfiguration -> Bool
-> IO () -> FilePath -> IO ()
initPackageDB verbosity comp conf dbPath = createPackageDB verbosity comp progdb preferCompat dbPath =
case compilerFlavor comp of case compilerFlavor comp of
HaskellSuite {} -> HaskellSuite.initPackageDB verbosity conf dbPath GHC -> HcPkg.init (GHC.hcPkgInfo progdb) verbosity preferCompat dbPath
_ -> withHcPkg "Distribution.Simple.Register.initPackageDB: \ GHCJS -> HcPkg.init (GHCJS.hcPkgInfo progdb) verbosity False dbPath
\not implemented for this compiler" comp conf LHC -> HcPkg.init (LHC.hcPkgInfo progdb) verbosity False dbPath
(\hpi -> HcPkg.init hpi verbosity dbPath) UHC -> return ()
HaskellSuite _ -> HaskellSuite.initPackageDB verbosity progdb dbPath
_ -> die $ "Distribution.Simple.Register.createPackageDB: "
++ "not implemented for this compiler"
-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the -- | Run @hc-pkg@ using a given package DB stack, directly forwarding the
-- provided command-line arguments to it. -- provided command-line arguments to it.
......
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