Addressing review comments.

cabal-install/Distribution/Client/Sandbox.hs

@@ -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

cabal-install/Distribution/Client/Sandbox/Index.hs

@@ -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

cabal-install/Distribution/Client/Tar.hs

@@ -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-install/tests/IntegrationTests/sandbox-sources/should_fail/fail_removing_source_thats_not_registered.err

-cabal: Skipping nonregistered sources: "q"
+cabal: Skipped the following nonregistered sources: "q"

cabal-install/tests/IntegrationTests/sandbox-sources/should_run/report_success_removing_source.out

-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.

cabal-install/tests/IntegrationTests/sandbox-sources/should_run/tolerate_nonexistent_source.out

+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.

cabal-install/tests/IntegrationTests/sandbox-sources/should_run/tolerate_nonexistent_source.sh

+. ../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

cabal-install/tests/UnitTests/Distribution/Client/Tar.hs

@@ -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 =