Commit 3c3a001b authored by martinvlk's avatar martinvlk
Browse files

Slashing some code duplication.

parent b5fe957a
...@@ -74,8 +74,7 @@ import Distribution.Client.SetupWrapper ...@@ -74,8 +74,7 @@ import Distribution.Client.SetupWrapper
import Distribution.Client.Types ( PackageLocation(..) import Distribution.Client.Types ( PackageLocation(..)
, SourcePackage(..) ) , SourcePackage(..) )
import Distribution.Client.Utils ( inDir, tryCanonicalizePath import Distribution.Client.Utils ( inDir, tryCanonicalizePath
, tryFindAddSourcePackageDesc , tryFindAddSourcePackageDesc)
, canonicalizePathNoThrow)
import Distribution.PackageDescription.Configuration import Distribution.PackageDescription.Configuration
( flattenPackageDescription ) ( flattenPackageDescription )
import Distribution.PackageDescription.Parse ( readPackageDescription ) import Distribution.PackageDescription.Parse ( readPackageDescription )
...@@ -453,14 +452,9 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do ...@@ -453,14 +452,9 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv) indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
removedPaths <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs (removedPaths, convDict) <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
withRemoveTimestamps sandboxDir $ return removedPaths withRemoveTimestamps sandboxDir $ return removedPaths
-- FIXME: we canonicalize paths here as well as in Index.removeBuildTreeRefs,
-- but we need the info here and there is no good way to share without larger
-- refactoring
convDict <- mapM (\btr -> do pth <- canonicalizePathNoThrow btr
return (btr, pth)) buildTreeRefs
let removedRefs = fmap (convertWith convDict) removedPaths let removedRefs = fmap (convertWith convDict) removedPaths
when (not . null $ removedPaths) $ when (not . null $ removedPaths) $
......
...@@ -157,19 +157,20 @@ addBuildTreeRefs verbosity path l' refType = do ...@@ -157,19 +157,20 @@ addBuildTreeRefs verbosity path l' refType = do
(path `replaceExtension` "cache") (path `replaceExtension` "cache")
-- | Remove given local build tree references from the index. -- | Remove given local build tree references from the index.
removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath] removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO ([FilePath], [(FilePath, FilePath)])
removeBuildTreeRefs _ _ [] = removeBuildTreeRefs _ _ [] =
error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected" error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"
removeBuildTreeRefs verbosity indexPath l' = do removeBuildTreeRefs verbosity indexPath l' = do
checkIndexExists indexPath checkIndexExists indexPath
let tmpFile = indexPath <.> "tmp" let tmpFile = indexPath <.> "tmp"
l <- mapM canonicalizePathNoThrow l' convDict <- mapM (\btr -> do pth <- canonicalizePathNoThrow btr
return (btr, pth)) l'
-- Performance note: on my system, it takes 'index --remove-source' -- Performance note: on my system, it takes 'index --remove-source'
-- approx. 3,5s to filter a 65M file. Real-life indices are expected to be -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be
-- much smaller. -- much smaller.
removedRefs <- doRemove l tmpFile removedRefs <- doRemove convDict tmpFile
renameFile tmpFile indexPath renameFile tmpFile indexPath
...@@ -178,20 +179,20 @@ removeBuildTreeRefs verbosity indexPath l' = do ...@@ -178,20 +179,20 @@ removeBuildTreeRefs verbosity indexPath l' = do
updatePackageIndexCacheFile verbosity indexPath (indexPath `replaceExtension` "cache") updatePackageIndexCacheFile verbosity indexPath (indexPath `replaceExtension` "cache")
return removedRefs return (removedRefs, convDict)
where where
doRemove srcRefs tmpFile = do doRemove srcRefs tmpFile = do
(newIdx, changedPaths) <- Tar.read `fmap` BS.readFile indexPath (newIdx, changedPaths) <- Tar.read `fmap` BS.readFile indexPath
>>= runWriterT . Tar.filterEntriesM (p srcRefs) >>= runWriterT . Tar.filterEntriesM (p srcRefs)
BS.writeFile tmpFile $ Tar.writeEntries newIdx BS.writeFile tmpFile $ Tar.writeEntries newIdx
return changedPaths return changedPaths
p :: [FilePath] -> Tar.Entry -> WriterT [FilePath] IO Bool p :: [(FilePath, FilePath)] -> Tar.Entry -> WriterT [FilePath] IO Bool
p refs entry = case readBuildTreeRef entry of p refs entry = case readBuildTreeRef entry of
Nothing -> return True Nothing -> return True
-- FIXME: removing snapshot deps is done with `delete-source -- FIXME: removing snapshot deps is done with `delete-source
-- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to -- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to
-- support removing snapshots by providing the original path. -- support removing snapshots by providing the original path.
(Just (BuildTreeRef _ pth)) -> if pth `elem` refs (Just (BuildTreeRef _ pth)) -> if pth `elem` fmap snd refs
then tell [pth] >> return False then tell [pth] >> return False
else return True else return True
......
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