From e8742a5cc477318aeb6dd3046d0dd239b0447e4a Mon Sep 17 00:00:00 2001
From: Mikhail Glushenkov <mikhail.glushenkov@gmail.com>
Date: Fri, 17 May 2013 17:51:34 +0200
Subject: [PATCH] Make newly-added add-source deps override previously
installed versions.
Fixes #1197.
This patch is a bit large because it includes several related changes:
1) Remove 'installUseSandbox' from 'InstallFlags' and pass 'useSandbox' as an
additional argument instead.
2) Instead of calling 'reinstallAddSourceDeps' from 'installAction', always pass
'SandboxPackageInfo' to 'install'.
3) Set the timestamps of newly-added add-source deps to 0 in the timestamp file.
4) Move the timestamp file update to 'postInstallActions' from
'withModifiedDeps'. This way, the timestamps are updated even when the user runs
'install --only-dependencies' or 'install some-add-source-dep-package-id'.
---
.../Distribution/Client/Dependency.hs | 2 +-
cabal-install/Distribution/Client/Install.hs | 50 ++++--
cabal-install/Distribution/Client/Sandbox.hs | 167 ++++++++++--------
.../Distribution/Client/Sandbox/Timestamp.hs | 68 +++----
.../Distribution/Client/Sandbox/Types.hs | 6 +-
cabal-install/Distribution/Client/Setup.hs | 14 +-
cabal-install/Main.hs | 45 ++---
7 files changed, 207 insertions(+), 145 deletions(-)
diff --git a/cabal-install/Distribution/Client/Dependency.hs b/cabal-install/Distribution/Client/Dependency.hs
index 679e40a110..36d3fa1c14 100644
--- a/cabal-install/Distribution/Client/Dependency.hs
+++ b/cabal-install/Distribution/Client/Dependency.hs
@@ -325,7 +325,7 @@ applySandboxInstallPolicy :: SandboxPackageInfo
-> DepResolverParams
-> DepResolverParams
applySandboxInstallPolicy
- (SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs)
+ (SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs _allDeps)
params
= addPreferences [ PackageInstalledPreference n PreferInstalled
diff --git a/cabal-install/Distribution/Client/Install.hs b/cabal-install/Distribution/Client/Install.hs
index ea276e740b..26d4924ac6 100644
--- a/cabal-install/Distribution/Client/Install.hs
+++ b/cabal-install/Distribution/Client/Install.hs
@@ -29,6 +29,7 @@ module Distribution.Client.Install (
import Data.List
( unfoldr, nub, sort, (\\) )
+import qualified Data.Set as S
import Data.Maybe
( isJust, fromMaybe, maybeToList )
import Control.Exception as Exception
@@ -66,7 +67,10 @@ import Distribution.Client.Setup
, ConfigExFlags(..), InstallFlags(..) )
import Distribution.Client.Config
( defaultCabalDir )
-import Distribution.Client.Sandbox.Types ( SandboxPackageInfo(..), isUseSandbox )
+import Distribution.Client.Sandbox.Timestamp
+ ( withUpdateTimestamps )
+import Distribution.Client.Sandbox.Types
+ ( SandboxPackageInfo(..), UseSandbox(..), isUseSandbox )
import Distribution.Client.Tar (extractTarGzFile)
import Distribution.Client.Types as Source
import Distribution.Client.BuildReports.Types
@@ -120,7 +124,8 @@ import Distribution.Version
import Distribution.Simple.Utils as Utils
( notice, info, warn, debugNoWrap, die, intercalate, withTempDirectory )
import Distribution.Client.Utils
- ( numberOfProcessors, inDir, mergeBy, MergeResult(..) )
+ ( numberOfProcessors, inDir, mergeBy, MergeResult(..)
+ , tryCanonicalizePath )
import Distribution.System
( Platform, OS(Windows), buildOS )
import Distribution.Text
@@ -154,6 +159,7 @@ install
-> Compiler
-> Platform
-> ProgramConfiguration
+ -> UseSandbox
-> Maybe SandboxPackageInfo
-> GlobalFlags
-> ConfigFlags
@@ -162,7 +168,7 @@ install
-> HaddockFlags
-> [UserTarget]
-> IO ()
-install verbosity packageDBs repos comp platform conf mSandboxPkgInfo
+install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo
globalFlags configFlags configExFlags installFlags haddockFlags
userTargets0 = do
@@ -173,7 +179,7 @@ install verbosity packageDBs repos comp platform conf mSandboxPkgInfo
processInstallPlan verbosity args installContext installPlan
where
args :: InstallArgs
- args = (packageDBs, repos, comp, platform, conf, mSandboxPkgInfo,
+ args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,
globalFlags, configFlags, configExFlags, installFlags,
haddockFlags)
@@ -192,6 +198,7 @@ type InstallArgs = ( PackageDBStack
, Compiler
, Platform
, ProgramConfiguration
+ , UseSandbox
, Maybe SandboxPackageInfo
, GlobalFlags
, ConfigFlags
@@ -203,7 +210,7 @@ type InstallArgs = ( PackageDBStack
makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]
-> IO InstallContext
makeInstallContext verbosity
- (packageDBs, repos, comp, _, conf,_,
+ (packageDBs, repos, comp, _, conf,_,_,
globalFlags, _, _, _, _) mUserTargets = do
installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf
@@ -233,7 +240,7 @@ makeInstallContext verbosity
makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> IO (Progress String String InstallPlan)
makeInstallPlan verbosity
- (_, _, comp, platform, _, mSandboxPkgInfo,
+ (_, _, comp, platform, _, _, mSandboxPkgInfo,
_, configFlags, configExFlags, installFlags,
_)
(installedPkgIndex, sourcePkgDb,
@@ -251,7 +258,7 @@ processInstallPlan :: Verbosity -> InstallArgs -> InstallContext
-> InstallPlan
-> IO ()
processInstallPlan verbosity
- args@(_,_, _, _, _, _, _, _, _, installFlags, _)
+ args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)
(installedPkgIndex, sourcePkgDb,
userTargets, pkgSpecifiers) installPlan = do
checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb
@@ -618,8 +625,8 @@ postInstallActions :: Verbosity
-> InstallPlan
-> IO ()
postInstallActions verbosity
- (packageDBs, _, comp, platform, conf, _, globalFlags, configFlags
- , _, installFlags, _)
+ (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo
+ ,globalFlags, configFlags, _, installFlags, _)
targets installPlan = do
unless oneShot $
@@ -643,6 +650,9 @@ postInstallActions verbosity
printBuildFailures installPlan
+ updateSandboxTimestampsFile useSandbox mSandboxPkgInfo
+ comp platform installPlan
+
where
reportingLevel = fromFlag (installBuildReports installFlags)
logsDir = fromFlag (globalLogsDir globalFlags)
@@ -795,6 +805,24 @@ printBuildFailures plan =
InstallFailed e -> " failed during the final install step."
++ " The exception was:\n " ++ show e
+-- | If we're working inside a sandbox and some add-source deps were installed,
+-- update the timestamps of those deps.
+updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo
+ -> Compiler -> Platform -> InstallPlan
+ -> IO ()
+updateSandboxTimestampsFile (UseSandbox sandboxDir)
+ (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))
+ comp platform installPlan =
+ withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do
+ let allInstalled = [ pkg | InstallPlan.Installed pkg _
+ <- InstallPlan.toList installPlan ]
+ allSrcPkgs = [ pkg | ConfiguredPackage pkg _ _ _ <- allInstalled ]
+ allPaths = [ pth | LocalUnpackedPackage pth
+ <- map packageSource allSrcPkgs]
+ allPathsCanonical <- mapM tryCanonicalizePath allPaths
+ return $! filter (`S.member` allAddSourceDeps) allPathsCanonical
+
+updateSandboxTimestampsFile _ _ _ _ _ = return ()
-- ------------------------------------------------------------
-- * Actually do the installations
@@ -815,7 +843,7 @@ performInstallations :: Verbosity
-> InstallPlan
-> IO InstallPlan
performInstallations verbosity
- (packageDBs, _, comp, _, conf,_,
+ (packageDBs, _, comp, _, conf, useSandbox, _,
globalFlags, configFlags, configExFlags, installFlags, haddockFlags)
installedPkgIndex installPlan = do
@@ -921,7 +949,7 @@ performInstallations verbosity
miscOptions = InstallMisc {
rootCmd = if fromFlag (configUserInstall configFlags)
- || isUseSandbox (installUseSandbox installFlags)
+ || (isUseSandbox useSandbox)
then Nothing -- ignore --root-cmd if --user
-- or working inside a sandbox.
else flagToMaybe (installRootCmd installFlags),
diff --git a/cabal-install/Distribution/Client/Sandbox.hs b/cabal-install/Distribution/Client/Sandbox.hs
index 2e9a570c2a..77af2752f2 100644
--- a/cabal-install/Distribution/Client/Sandbox.hs
+++ b/cabal-install/Distribution/Client/Sandbox.hs
@@ -27,6 +27,9 @@ module Distribution.Client.Sandbox (
maybeReinstallAddSourceDeps,
maybeUpdateSandboxConfig,
+ SandboxPackageInfo(..),
+ maybeWithSandboxPackageInfo,
+
tryGetIndexFilePath,
sandboxBuildDir,
getInstalledPackagesInSandbox,
@@ -39,10 +42,10 @@ import Distribution.Client.Setup
( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)
, GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags
, defaultSandboxLocation, globalRepos )
-import Distribution.Client.Sandbox.Timestamp ( maybeAddCompilerTimestampRecord
+import Distribution.Client.Sandbox.Timestamp ( listModifiedDeps
+ , maybeAddCompilerTimestampRecord
, withAddTimestamps
- , withRemoveTimestamps
- , withModifiedDeps )
+ , withRemoveTimestamps )
import Distribution.Client.Config ( SavedConfig(..), loadConfig )
import Distribution.Client.Dependency ( foldProgress )
import Distribution.Client.IndexUtils ( BuildTreeRefType(..) )
@@ -90,12 +93,13 @@ import qualified Distribution.Client.Sandbox.Index as Index
import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import qualified Distribution.Simple.Register as Register
import qualified Data.Map as M
+import qualified Data.Set as S
import Control.Exception ( assert, bracket_ )
import Control.Monad ( forM, liftM2, unless, when )
import Data.Bits ( shiftL, shiftR, xor )
import Data.Char ( ord )
import Data.IORef ( newIORef, writeIORef, readIORef )
-import Data.List ( (\\), delete, foldl' )
+import Data.List ( delete, foldl' )
import Data.Monoid ( mempty, mappend )
import Data.Word ( Word32 )
import Numeric ( showHex )
@@ -167,8 +171,13 @@ tryLoadSandboxConfig verbosity configFileFlag = do
-- | Return the name of the package index file for this package environment.
tryGetIndexFilePath :: SavedConfig -> IO FilePath
-tryGetIndexFilePath config = do
- let paths = globalLocalRepos . savedGlobalFlags $ config
+tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config)
+
+-- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of
+-- 'SavedConfig'.
+tryGetIndexFilePath' :: GlobalFlags -> IO FilePath
+tryGetIndexFilePath' globalFlags = do
+ let paths = globalLocalRepos globalFlags
case paths of
[] -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " ++
"no local repos found. " ++ checkConfiguration
@@ -461,55 +470,42 @@ data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled
-- | Reinstall those add-source dependencies that have been modified since
-- we've last installed them. Assumes that we're working inside a sandbox.
reinstallAddSourceDeps :: Verbosity
- -> SavedConfig
-> ConfigFlags -> ConfigExFlags
-> InstallFlags -> GlobalFlags
-> FilePath
-> IO WereDepsReinstalled
-reinstallAddSourceDeps verbosity config configFlags' configExFlags
+reinstallAddSourceDeps verbosity configFlags' configExFlags
installFlags globalFlags sandboxDir = topHandler' $ do
- let sandboxDistPref = sandboxBuildDir sandboxDir
- configFlags = configFlags'
- { configDistPref = Flag sandboxDistPref }
- haddockFlags = mempty
- { haddockDistPref = Flag sandboxDistPref }
- indexFile <- tryGetIndexFilePath config
- buildTreeRefs <- Index.listBuildTreeRefs verbosity
- Index.DontListIgnored Index.OnlyLinks indexFile
- retVal <- newIORef NoDepsReinstalled
-
- unless (null buildTreeRefs) $ do
- (comp, platform, conf) <- configCompilerAux' configFlags
- let compId = compilerId comp
-
- withModifiedDeps verbosity sandboxDir compId platform $ \modifiedDeps -> do
- assert (null $ modifiedDeps \\ buildTreeRefs) (return ())
- unless (null modifiedDeps) $ do
- sandboxPkgInfo <- makeSandboxPackageInfo verbosity configFlags
- comp conf buildTreeRefs modifiedDeps
- let modifiedAndInstalledDeps = modifiedAddSourceDependencies
- sandboxPkgInfo
-
- unless (null modifiedAndInstalledDeps) $ do
- notice verbosity "Installing add-source dependencies..."
-
- let args :: InstallArgs
- args = ((configPackageDB' configFlags)
- ,(globalRepos globalFlags)
- ,comp, platform, conf, Just sandboxPkgInfo
- ,globalFlags, configFlags, configExFlags, installFlags
- ,haddockFlags)
-
- -- This can actually be replaced by a call to 'install', but we use a
- -- lower-level API because of layer separation reasons. Additionally,
- -- we might want to extend this in the future.
- withSandboxBinDirOnSearchPath sandboxDir $ do
- installContext <- makeInstallContext verbosity args Nothing
- installPlan <- foldProgress logMsg die return =<<
- makeInstallPlan verbosity args installContext
-
- processInstallPlan verbosity args installContext installPlan
- writeIORef retVal ReinstalledSomeDeps
+ let sandboxDistPref = sandboxBuildDir sandboxDir
+ configFlags = configFlags'
+ { configDistPref = Flag sandboxDistPref }
+ haddockFlags = mempty
+ { haddockDistPref = Flag sandboxDistPref }
+ (comp, platform, conf) <- configCompilerAux' configFlags
+ retVal <- newIORef NoDepsReinstalled
+
+ withSandboxPackageInfo verbosity configFlags globalFlags
+ comp platform conf sandboxDir $ \sandboxPkgInfo ->
+ unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do
+
+ let args :: InstallArgs
+ args = ((configPackageDB' configFlags)
+ ,(globalRepos globalFlags)
+ ,comp, platform, conf
+ ,UseSandbox sandboxDir, Just sandboxPkgInfo
+ ,globalFlags, configFlags, configExFlags, installFlags
+ ,haddockFlags)
+
+ -- This can actually be replaced by a call to 'install', but we use a
+ -- lower-level API because of layer separation reasons. Additionally, we
+ -- might want to use some lower-level features this in the future.
+ withSandboxBinDirOnSearchPath sandboxDir $ do
+ installContext <- makeInstallContext verbosity args Nothing
+ installPlan <- foldProgress logMsg die return =<<
+ makeInstallPlan verbosity args installContext
+
+ processInstallPlan verbosity args installContext installPlan
+ writeIORef retVal ReinstalledSomeDeps
readIORef retVal
@@ -522,24 +518,34 @@ reinstallAddSourceDeps verbosity config configFlags' configExFlags
-- to be conservative.
return ReinstalledSomeDeps
--- | Given a list of all add-source deps and a list of modified add-source deps,
--- produce a 'SandboxPackageInfo'.
-makeSandboxPackageInfo :: Verbosity -> ConfigFlags
- -> Compiler -> ProgramConfiguration
- -> [FilePath] -> [FilePath]
- -> IO SandboxPackageInfo
-makeSandboxPackageInfo verbosity configFlags comp conf
- allAddSourceDeps modifiedAddSourceDeps = do
+-- | Produce a 'SandboxPackageInfo' and feed it to the given action. Note that
+-- we don't update the timestamp file here - this is done in
+-- 'postInstallActions'.
+withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags
+ -> Compiler -> Platform -> ProgramConfiguration
+ -> FilePath
+ -> (SandboxPackageInfo -> IO ())
+ -> IO ()
+withSandboxPackageInfo verbosity configFlags globalFlags
+ comp platform conf sandboxDir cont = do
+ -- List all add-source deps.
+ indexFile <- tryGetIndexFilePath' globalFlags
+ buildTreeRefs <- Index.listBuildTreeRefs verbosity
+ Index.DontListIgnored Index.OnlyLinks indexFile
+ let allAddSourceDepsSet = S.fromList buildTreeRefs
+
-- List all packages installed in the sandbox.
installedPkgIndex <- getInstalledPackagesInSandbox verbosity
configFlags comp conf
- -- Get the package descriptions of all add-source deps.
- depsCabalFiles <- mapM findPackageDesc allAddSourceDeps
+ -- Get the package descriptions for all add-source deps.
+ depsCabalFiles <- mapM findPackageDesc buildTreeRefs
depsPkgDescs <- mapM (readPackageDescription verbosity) depsCabalFiles
- let depsMap = M.fromList (zip allAddSourceDeps depsPkgDescs)
+ let depsMap = M.fromList (zip buildTreeRefs depsPkgDescs)
-- Get the package ids of modified (and installed) add-source deps.
+ modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir
+ (compilerId comp) platform
let isInstalled pkgid = not . null
. InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid
isModified path = path `elem` modifiedAddSourceDeps
@@ -548,16 +554,38 @@ makeSandboxPackageInfo verbosity configFlags comp conf
depsMap
modifiedDeps = M.assocs modifiedDepsMap
+ assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())
+ unless (null modifiedDeps) $
+ notice verbosity $ "Some add-source dependencies have been modified. "
+ ++ "They will be reinstalled..."
+
-- Get the package ids of the remaining add-source deps (some are possibly not
-- installed).
- let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)
+ let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)
- return $ SandboxPackageInfo (map toSourcePackage modifiedDeps)
- (map toSourcePackage otherDeps) installedPkgIndex
+ -- Finally, assemble a 'SandboxPackageInfo'.
+ cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps)
+ (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet
- where
- toSourcePackage (path, pkgDesc) = SourcePackage
- (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing
+ where
+ toSourcePackage (path, pkgDesc) = SourcePackage
+ (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing
+
+-- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and a no-op
+-- otherwise.
+maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags
+ -> Compiler -> Platform -> ProgramConfiguration
+ -> UseSandbox
+ -> (Maybe SandboxPackageInfo -> IO ())
+ -> IO ()
+maybeWithSandboxPackageInfo verbosity configFlags globalFlags
+ comp platform conf useSandbox cont =
+ case useSandbox of
+ NoSandbox -> cont Nothing
+ UseSandbox sandboxDir -> withSandboxPackageInfo verbosity
+ configFlags globalFlags
+ comp platform conf sandboxDir
+ (\spi -> cont (Just spi))
-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that
-- case.
@@ -598,8 +626,7 @@ maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do
`mappend` savedInstallFlags config
installFlags = installFlags' {
installNumJobs = installNumJobs installFlags'
- `mappend` numJobsFlag,
- installUseSandbox = useSandbox
+ `mappend` numJobsFlag
}
globalFlags = savedGlobalFlags config
-- This makes it possible to override things like
@@ -608,7 +635,7 @@ maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do
-- fine.
`mappend` globalFlags'
- depsReinstalled <- reinstallAddSourceDeps verbosity config
+ depsReinstalled <- reinstallAddSourceDeps verbosity
configFlags configExFlags installFlags globalFlags
sandboxDir
return (useSandbox, depsReinstalled)
diff --git a/cabal-install/Distribution/Client/Sandbox/Timestamp.hs b/cabal-install/Distribution/Client/Sandbox/Timestamp.hs
index da6e3bbca2..28fee8e7ff 100644
--- a/cabal-install/Distribution/Client/Sandbox/Timestamp.hs
+++ b/cabal-install/Distribution/Client/Sandbox/Timestamp.hs
@@ -14,7 +14,7 @@ module Distribution.Client.Sandbox.Timestamp (
withUpdateTimestamps,
maybeAddCompilerTimestampRecord,
isDepModified,
- withModifiedDeps,
+ listModifiedDeps,
) where
import Control.Exception (finally)
@@ -73,13 +73,16 @@ timestampRecordKey compId platform = display platform ++ "-" ++ display compId
timestampFileName :: FilePath
timestampFileName = "add-source-timestamps"
--- | Read the timestamp file. Returns an empty list if the file doesn't exist.
-readTimestampFile :: FilePath -> IO (Maybe [TimestampFileRecord])
+-- | Read the timestamp file. Exits with error if the timestamp file is
+-- corrupted. Returns an empty list if the file doesn't exist.
+readTimestampFile :: FilePath -> IO [TimestampFileRecord]
readTimestampFile timestampFile = do
timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"
case reads timestampString of
- [(timestamps, s)] | all isSpace s -> return (Just timestamps)
- _ -> return Nothing
+ [(timestamps, s)] | all isSpace s -> return timestamps
+ _ ->
+ die $ "The timestamps file is corrupted. "
+ ++ "Please delete & recreate the sandbox."
-- | Write the timestamp file, atomically.
writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO ()
@@ -94,25 +97,21 @@ withTimestampFile :: FilePath
-> ([TimestampFileRecord] -> IO [TimestampFileRecord])
-> IO ()
withTimestampFile sandboxDir process = do
- let timestampFile = sandboxDir </> timestampFileName
- mTimestampRecords <- readTimestampFile timestampFile
- case mTimestampRecords of
- Nothing -> die $ "The timestamps file is corrupted. "
- ++ "Please delete & recreate the sandbox."
- Just timestampRecords -> do
- timestampRecords' <- process timestampRecords
- writeTimestampFile timestampFile timestampRecords'
+ let timestampFile = sandboxDir </> timestampFileName
+ timestampRecords <- readTimestampFile timestampFile >>= process
+ writeTimestampFile timestampFile timestampRecords
-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps
--- we've added and the current time, add an 'AddSourceTimestamp' to the list for
--- each path that isn't already included.
+-- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list
+-- for each path. If a timestamp for a given path already exists in the list,
+-- update it.
addTimestamps :: EpochTime -> [AddSourceTimestamp] -> [FilePath]
-> [AddSourceTimestamp]
-addTimestamps now timestamps paths =
- map (\p -> (p, now)) newPaths ++ timestamps
+addTimestamps initial timestamps newPaths =
+ [ (p, initial) | p <- newPaths ] ++ oldTimestamps
where
- oldPaths = map fst timestamps
- (_, newPaths) = partition (flip elem oldPaths) paths
+ (oldTimestamps, _toBeUpdated) =
+ partition (\(path, _) -> path `notElem` newPaths) timestamps
-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps
-- we've reinstalled and a new timestamp value, update the timestamp value for
@@ -156,8 +155,8 @@ maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
-- build tree refs to the timestamps file (for all compilers).
withAddTimestamps :: FilePath -> IO [FilePath] -> IO ()
withAddTimestamps sandboxDir act = do
- now <- getCurTime
- withActionOnAllTimestamps (addTimestamps now) sandboxDir act
+ let initialTimestamp = 0
+ withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act
-- | Given an IO action that returns a list of build tree refs, remove those
-- build tree refs from the timestamps file (for all compilers).
@@ -256,14 +255,19 @@ isDepModified verbosity now (packageDir, timestamp) = do
return True
else go rest
--- | Given an IO action, feed to it the list of modified add-source deps and
--- set their timestamps to the current time in the timestamps file.
-withModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform
- -> ([FilePath] -> IO ()) -> IO ()
-withModifiedDeps verbosity sandboxDir compId platform act = do
- withUpdateTimestamps sandboxDir compId platform $ \timestamps -> do
- now <- getCurTime
- modified <- fmap (map fst) . filterM (isDepModified verbosity now)
- $ timestamps
- act modified
- return modified
+-- | List all modified dependencies.
+listModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform
+ -> IO [FilePath]
+listModifiedDeps verbosity sandboxDir compId platform = do
+ timestampRecords <- readTimestampFile (sandboxDir </> timestampFileName)
+ let needle = timestampRecordKey compId platform
+ timestamps <- maybe noTimestampRecord return
+ (lookup needle timestampRecords)
+ now <- getCurTime
+ fmap (map fst) . filterM (isDepModified verbosity now) $ timestamps
+
+ where
+ noTimestampRecord = die $ "Сouldn't find a timestamp record for the given "
+ ++ "compiler/platform pair. "
+ ++ "Please report this on the Cabal bug tracker: "
+ ++ "https://github.com/haskell/cabal/issues/new ."
diff --git a/cabal-install/Distribution/Client/Sandbox/Types.hs b/cabal-install/Distribution/Client/Sandbox/Types.hs
index b0b6726ff3..17f0d46a2d 100644
--- a/cabal-install/Distribution/Client/Sandbox/Types.hs
+++ b/cabal-install/Distribution/Client/Sandbox/Types.hs
@@ -16,6 +16,7 @@ import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex
import Distribution.Client.Types (SourcePackage)
import Data.Monoid
+import qualified Data.Set as S
-- | Are we using a sandbox?
data UseSandbox = UseSandbox FilePath | NoSandbox
@@ -50,8 +51,11 @@ data SandboxPackageInfo = SandboxPackageInfo {
-- ^ Remaining add-source deps. Some of these may be not installed in the
-- sandbox.
- otherInstalledSandboxPackages :: InstalledPackageIndex.PackageIndex
+ otherInstalledSandboxPackages :: InstalledPackageIndex.PackageIndex,
-- ^ All packages installed in the sandbox. Intersection with
-- 'modifiedAddSourceDependencies' and/or 'otherAddSourceDependencies' can be
-- non-empty.
+
+ allAddSourceDependencies :: S.Set FilePath
+ -- ^ A set of paths to all add-source dependencies, for convenience.
}
diff --git a/cabal-install/Distribution/Client/Setup.hs b/cabal-install/Distribution/Client/Setup.hs
index 6188902df6..ee732c4cf1 100644
--- a/cabal-install/Distribution/Client/Setup.hs
+++ b/cabal-install/Distribution/Client/Setup.hs
@@ -45,8 +45,6 @@ import Distribution.Client.BuildReports.Types
( ReportLevel(..) )
import Distribution.Client.Dependency.Types
( PreSolver(..) )
-import Distribution.Client.Sandbox.Types
- ( UseSandbox(..) )
import qualified Distribution.Client.Init.Types as IT
( InitFlags(..), PackageType(..) )
import Distribution.Client.Targets
@@ -778,8 +776,7 @@ data InstallFlags = InstallFlags {
installBuildReports :: Flag ReportLevel,
installSymlinkBinDir :: Flag FilePath,
installOneShot :: Flag Bool,
- installNumJobs :: Flag (Maybe Int),
- installUseSandbox :: UseSandbox
+ installNumJobs :: Flag (Maybe Int)
}
defaultInstallFlags :: InstallFlags
@@ -803,8 +800,7 @@ defaultInstallFlags = InstallFlags {
installBuildReports = Flag NoReports,
installSymlinkBinDir = mempty,
installOneShot = Flag False,
- installNumJobs = mempty,
- installUseSandbox = mempty
+ installNumJobs = mempty
}
where
docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")
@@ -996,8 +992,7 @@ instance Monoid InstallFlags where
installBuildReports = mempty,
installSymlinkBinDir = mempty,
installOneShot = mempty,
- installNumJobs = mempty,
- installUseSandbox = mempty
+ installNumJobs = mempty
}
mappend a b = InstallFlags {
installDocumentation = combine installDocumentation,
@@ -1019,8 +1014,7 @@ instance Monoid InstallFlags where
installBuildReports = combine installBuildReports,
installSymlinkBinDir = combine installSymlinkBinDir,
installOneShot = combine installOneShot,
- installNumJobs = combine installNumJobs,
- installUseSandbox = combine installUseSandbox
+ installNumJobs = combine installNumJobs
}
where combine field = field a `mappend` field b
diff --git a/cabal-install/Main.hs b/cabal-install/Main.hs
index 3119c7d0e2..5b12b30842 100644
--- a/cabal-install/Main.hs
+++ b/cabal-install/Main.hs
@@ -77,9 +77,9 @@ import Distribution.Client.Sandbox (sandboxInit
,loadConfigOrSandboxConfig
,initPackageDBIfNeeded
,maybeWithSandboxDirOnSearchPath
+ ,maybeWithSandboxPackageInfo
,WereDepsReinstalled(..)
,maybeReinstallAddSourceDeps
- ,reinstallAddSourceDeps
,maybeUpdateSandboxConfig
,tryGetIndexFilePath
,sandboxBuildDir
@@ -471,7 +471,6 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
savedConfigureExFlags config `mappend` configExFlags
installFlags' = defaultInstallFlags `mappend`
savedInstallFlags config `mappend` installFlags
- { installUseSandbox = useSandbox }
globalFlags' = savedGlobalFlags config `mappend` globalFlags
haddockFlags' = haddockFlags { haddockDistPref = sandboxDistPref }
(comp, platform, conf) <- configCompilerAux' configFlags'
@@ -493,26 +492,32 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)
maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile
(compilerId comp) platform
- -- If "." is among the targets, we should reinstall add-source dependencies
- -- for this compiler and maybe rewrite the 'with-compiler' and 'package-db'
- -- fields in the 'cabal.sandbox.config' file.
- when (null targets || (UserTargetLocalDir ".") `elem` targets) $ do
+ -- If "." is among the targets, we may need to rewrite the 'with-compiler'
+ -- and 'package-db' fields in the 'cabal.sandbox.config' file (since the
+ -- current package will be configured with the new compiler).
+ when (containsCurrentDir targets) $
maybeUpdateSandboxConfig verbosity config configFlags''
- -- 'install .' always runs 'configure', so we don't need to force
- -- reconfigure ourselves.
- _ <- reinstallAddSourceDeps verbosity config configFlags'' configExFlags'
- installFlags' globalFlags'
- sandboxDir
- return ()
- maybeWithSandboxDirOnSearchPath useSandbox $
- install verbosity
- (configPackageDB' configFlags'')
- (globalRepos globalFlags')
- comp platform conf
- Nothing -- FIXME
- globalFlags' configFlags'' configExFlags' installFlags' haddockFlags'
- targets
+ -- FIXME: Passing 'SandboxPackageInfo' unconditionally means that 'install'
+ -- will sometimes reinstall modified add-source deps. Probably not a big
+ -- problem since 'build', 'test' etc are already doing it.
+ maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags'
+ comp platform conf useSandbox $ \mSandboxPkgInfo ->
+ maybeWithSandboxDirOnSearchPath useSandbox $
+ install verbosity
+ (configPackageDB' configFlags'')
+ (globalRepos globalFlags')
+ comp platform conf
+ useSandbox mSandboxPkgInfo
+ globalFlags' configFlags'' configExFlags'
+ installFlags' haddockFlags'
+ targets
+
+ where
+ -- FIXME: Should also check for absolute path and UserTargetLocalCabalFile.
+ containsCurrentDir targets = null targets
+ || (UserTargetLocalDir ".") `elem` targets
+
testAction :: (TestFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()
testAction (testFlags, buildExFlags) extraArgs globalFlags = do
--
GitLab