Commit b5fe957a authored by martinvlk's avatar martinvlk
Browse files

Addressing review comments.

parent 9832269a
......@@ -74,7 +74,8 @@ import Distribution.Client.SetupWrapper
import Distribution.Client.Types ( PackageLocation(..)
, SourcePackage(..) )
import Distribution.Client.Utils ( inDir, tryCanonicalizePath
, tryFindAddSourcePackageDesc )
, tryFindAddSourcePackageDesc
, canonicalizePathNoThrow)
import Distribution.PackageDescription.Configuration
( flattenPackageDescription )
import Distribution.PackageDescription.Parse ( readPackageDescription )
......@@ -113,8 +114,8 @@ 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', isSuffixOf, intersperse )
import Data.Maybe ( fromJust )
import Data.List ( delete, foldl', intersperse, find, (\\))
import Data.Maybe ( fromJust, fromMaybe )
#if !MIN_VERSION_base(4,8,0)
import Data.Monoid ( mempty, mappend )
#endif
......@@ -452,20 +453,31 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
(sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags
indexFile <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
withRemoveTimestamps sandboxDir $ do
removedRefs <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
when (length buildTreeRefs > length removedRefs) $
die $ "Skipping nonregistered sources: " ++ (showL $ prune buildTreeRefs removedRefs)
notice verbosity $ "Success deleting sources: " ++ showL buildTreeRefs ++ "\n\n"
return removedRefs
removedPaths <- Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
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
when (not . null $ removedPaths) $
notice verbosity $ "Success deleting sources: " ++
showL removedRefs ++ "\n\n"
when (length buildTreeRefs > length removedPaths) $
die $ "Skipped the following nonregistered sources: " ++
(showL $ buildTreeRefs \\ removedRefs)
notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " ++
"source dependency, but does not remove the package " ++
"from the sandbox package DB.\n\n" ++
"Use 'sandbox hc-pkg -- unregister' to do that."
where
prune inp out = filter (\btr -> not . or $ map (btr `isSuffixOf`) out) inp
showL = concat . intersperse " " . fmap show
convertWith dict pth = fromMaybe pth $ fmap fst $ find ((==pth) . snd) dict
showL = concat . intersperse " " . fmap show
-- | Entry point for the 'cabal sandbox list-sources' command.
sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags
......
......@@ -162,21 +162,27 @@ removeBuildTreeRefs _ _ [] =
error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"
removeBuildTreeRefs verbosity indexPath l' = do
checkIndexExists indexPath
l <- mapM canonicalizePathNoThrow l'
let tmpFile = indexPath <.> "tmp"
l <- mapM canonicalizePathNoThrow l'
-- 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
-- much smaller.
removedRefs <- doRemove l tmpFile
renameFile tmpFile indexPath
debug verbosity $ "Successfully renamed '" ++ tmpFile
++ "' to '" ++ indexPath ++ "'"
updatePackageIndexCacheFile verbosity indexPath (indexPath `replaceExtension` "cache")
return removedRefs
where
doRemove srcRefs tmpFile = do
(newIdx, changedPaths) <- Tar.read `fmap` BS.readFile indexPath
>>= runWriterT . Tar.filterEntriesW (p srcRefs)
>>= runWriterT . Tar.filterEntriesM (p srcRefs)
BS.writeFile tmpFile $ Tar.writeEntries newIdx
return changedPaths
p :: [FilePath] -> Tar.Entry -> WriterT [FilePath] IO Bool
......
......@@ -59,12 +59,12 @@ module Distribution.Client.Tar (
-- ** Sequences of tar entries
Entries(..),
foldrEntries,
foldrEntriesW,
foldrEntriesM,
foldlEntries,
unfoldrEntries,
mapEntries,
filterEntries,
filterEntriesW,
filterEntriesM,
entriesIndex,
) where
......@@ -441,7 +441,7 @@ unfoldrEntries f = unfold
Right (Just (e, x')) -> Next e (unfold x')
foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a
foldrEntries next done fail' = isoR . foldrEntriesW (isoL .: next) (isoL done) (isoL . fail')
foldrEntries next done fail' = isoR . foldrEntriesM (isoL .: next) (isoL done) (isoL . fail')
where
isoL :: a -> WriterT () Identity a
isoL = return
......@@ -461,12 +461,11 @@ mapEntries :: (Entry -> Entry) -> Entries -> Entries
mapEntries f = foldrEntries (Next . f) Done Fail
filterEntries :: (Entry -> Bool) -> Entries -> Entries
filterEntries p = isoR . filterEntriesW (return . p)
filterEntries p = isoR . filterEntriesM (return . p)
filterEntriesW :: (Monoid w, Monad m) =>
(Entry -> WriterT w m Bool) -> Entries -> WriterT w m Entries
filterEntriesW p =
foldrEntriesW
filterEntriesM :: (Monad m) => (Entry -> m Bool) -> Entries -> m Entries
filterEntriesM p =
foldrEntriesM
(\entry rest -> do
include <- p entry
if include
......@@ -474,10 +473,8 @@ filterEntriesW p =
else return rest)
(return Done) (return . Fail)
foldrEntriesW :: (Monoid w, Monad m) =>
(Entry -> a -> WriterT w m a) -> WriterT w m a -> (String -> WriterT w m a)
-> Entries -> WriterT w m a
foldrEntriesW next done fail' = fold
foldrEntriesM :: (Monad m) => (Entry -> a -> m a) -> m a -> (String -> m a) -> Entries -> m a
foldrEntriesM next done fail' = fold
where
fold (Next e es) = fold es >>= next e
fold Done = done
......
cabal: Skipping nonregistered sources: "q"
cabal: Skipped the following nonregistered sources: "q"
Success deleting sources: "p" "q"
Success deleting sources: "q" "p"
Note: 'sandbox delete-source' only unregisters the source dependency, but does
not remove the package from the sandbox package DB.
......
Success deleting sources: "p"
Note: 'sandbox delete-source' only unregisters the source dependency, but does
not remove the package from the sandbox package DB.
Use 'sandbox hc-pkg -- unregister' to do that.
. ../common.sh
# Create the sandbox
cabal sandbox init > /dev/null
# Add the sources
cabal sandbox add-source p > /dev/null
cabal sandbox add-source q > /dev/null
# delete the directory on disk
# FIXME: the following line needs to be uncommented, but this depends on fixing a regression to #1360 first
#rm -R p
# Remove the registered source which is no longer on disk
cabal sandbox delete-source p
......@@ -4,8 +4,8 @@ module UnitTests.Distribution.Client.Tar (
import Distribution.Client.Tar (foldrEntries
, filterEntries
, foldrEntriesW
, filterEntriesW
, foldrEntriesM
, filterEntriesM
, EntryContent(..)
, simpleEntry
, Entry(..)
......@@ -23,8 +23,8 @@ import Control.Monad.Writer.Lazy (runWriterT, tell)
tests :: [TestTree]
tests = [ testCase "foldrEntries" foldrTest
, testCase "filterEntries" filterTest
, testCase "foldrEntriesW" foldrWTest
, testCase "filterEntriesW" filterWTest
, testCase "foldrEntriesM" foldrMTest
, testCase "filterEntriesM" filterMTest
]
foldrTest :: Assertion
......@@ -57,14 +57,14 @@ filterTest = do
assertEqual "Unexpected result for filter" "xf" $
entriesToString $ filterEntries p $ Next e1 $ Next e2 $ Fail "f"
foldrWTest :: Assertion
foldrWTest = do
(r, w) <- runWriterT $ foldrEntriesW undefined
foldrMTest :: Assertion
foldrMTest = do
(r, w) <- runWriterT $ foldrEntriesM undefined
(tell [1::Int] >> tell [2::Int] >> return "x") undefined Done
assertEqual "Unexpected result for Done" "x" r
assertEqual "Unexpected result for Done w" [1,2] w
(r1, w1) <- runWriterT $ foldrEntriesW undefined undefined
(r1, w1) <- runWriterT $ foldrEntriesM undefined undefined
(return . id) $ Fail "x"
assertEqual "Unexpected result for Fail" "x" r1
assertEqual "Unexpected result for Fail w" "" w1
......@@ -75,36 +75,36 @@ foldrWTest = do
str = BS.Char8.unpack dta
in tell "a" >> return (str ++ acc))
done = tell "b" >> return "z"
(r2, w2) <- runWriterT $ foldrEntriesW next done undefined $
(r2, w2) <- runWriterT $ foldrEntriesM next done undefined $
Next e1 $ Next e2 Done
assertEqual "Unexpected result for Next" "xyz" r2
assertEqual "Unexpected result for Next w" "baa" w2
let fail' = (\f -> tell "c" >> return f) . id
(r3, w3) <- runWriterT $ foldrEntriesW next done fail' $
(r3, w3) <- runWriterT $ foldrEntriesM next done fail' $
Next e1 $ Next e2 $ Fail "f"
assertEqual "Unexpected result for Next" "xyf" r3
assertEqual "Unexpected result for Next w" "caa" w3
filterWTest :: Assertion
filterWTest = do
filterMTest :: Assertion
filterMTest = do
let e1 = getFileEntry "file1" "x"
e2 = getFileEntry "file2" "y"
p = (\e -> let (NormalFile dta _) = entryContent e
str = BS.Char8.unpack dta
in tell "t" >> return (not . (=="y") $ str))
(r, w) <- runWriterT $ filterEntriesW p $ Next e1 $ Next e2 Done
assertEqual "Unexpected result for filterW" "xz" $ entriesToString r
assertEqual "Unexpected result for filterW w" "tt" w
(r, w) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 Done
assertEqual "Unexpected result for filterM" "xz" $ entriesToString r
assertEqual "Unexpected result for filterM w" "tt" w
(r1, w1) <- runWriterT $ filterEntriesW p $ Done
assertEqual "Unexpected result for filterW" "z" $ entriesToString r1
assertEqual "Unexpected result for filterW w" "" w1
(r1, w1) <- runWriterT $ filterEntriesM p $ Done
assertEqual "Unexpected result for filterM" "z" $ entriesToString r1
assertEqual "Unexpected result for filterM w" "" w1
(r2, w2) <- runWriterT $ filterEntriesW p $ Next e1 $ Next e2 $ Fail "f"
assertEqual "Unexpected result for filterW" "xf" $ entriesToString r2
assertEqual "Unexpected result for filterW w" "tt" w2
(r2, w2) <- runWriterT $ filterEntriesM p $ Next e1 $ Next e2 $ Fail "f"
assertEqual "Unexpected result for filterM" "xf" $ entriesToString r2
assertEqual "Unexpected result for filterM w" "tt" w2
getFileEntry :: FilePath -> [Char] -> Entry
getFileEntry pth dta =
......
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