[commit: packages/Cabal] ghc-head: Make 'removeBuildTreeRefs' tolerate non-existing paths. (82a0547)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/Cabal

On branch  : ghc-head
Link       : http://git.haskell.org/?p=packages/Cabal.git;a=commit;h=82a0547edb2ca9863fedf3e012d3024a2c951bdc

>---------------------------------------------------------------

commit 82a0547edb2ca9863fedf3e012d3024a2c951bdc
Author: Mikhail Glushenkov <mikhail.glushenkov at gmail.com>
Date:   Fri Jun 7 22:45:00 2013 +0200

    Make 'removeBuildTreeRefs' tolerate non-existing paths.
    
    Fixes #1360.


>---------------------------------------------------------------

82a0547edb2ca9863fedf3e012d3024a2c951bdc
 cabal-install/Distribution/Client/Sandbox.hs       |    6 +-----
 cabal-install/Distribution/Client/Sandbox/Index.hs |    9 ++++++---
 cabal-install/Distribution/Client/Utils.hs         |   10 +++++++++-
 3 files changed, 16 insertions(+), 9 deletions(-)

diff --git a/cabal-install/Distribution/Client/Sandbox.hs b/cabal-install/Distribution/Client/Sandbox.hs
index 37a6785..7296662 100644
--- a/cabal-install/Distribution/Client/Sandbox.hs
+++ b/cabal-install/Distribution/Client/Sandbox.hs
@@ -429,11 +429,7 @@ sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do
   indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)
 
   withRemoveTimestamps sandboxDir $ do
-    -- FIXME: path canonicalisation is done in addBuildTreeRefs, but we do it
-    -- twice because of the timestamps file.
-    buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs
-    Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs'
-    return buildTreeRefs'
+    Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs
 
 -- | Entry point for the 'cabal sandbox list-sources' command.
 sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags
diff --git a/cabal-install/Distribution/Client/Sandbox/Index.hs b/cabal-install/Distribution/Client/Sandbox/Index.hs
index 8c10386..7eb7a4a 100644
--- a/cabal-install/Distribution/Client/Sandbox/Index.hs
+++ b/cabal-install/Distribution/Client/Sandbox/Index.hs
@@ -28,7 +28,8 @@ import Distribution.Client.Types ( Repo(..), LocalRepo(..)
                                  , SourcePackageDb(..)
                                  , SourcePackage(..), PackageLocation(..) )
 import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString
-                                 , makeAbsoluteToCwd, tryCanonicalizePath )
+                                 , makeAbsoluteToCwd, tryCanonicalizePath
+                                 , canonicalizePathNoThrow )
 
 import Distribution.Simple.Utils ( die, debug, findPackageDesc )
 import Distribution.Verbosity    ( Verbosity )
@@ -150,12 +151,12 @@ addBuildTreeRefs verbosity path l' refType = do
       debug verbosity $ "Successfully appended to '" ++ path ++ "'"
 
 -- | Remove given local build tree references from the index.
-removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO ()
+removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath]
 removeBuildTreeRefs _         _   [] =
   error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"
 removeBuildTreeRefs verbosity path l' = do
   checkIndexExists path
-  l <- mapM tryCanonicalizePath l'
+  l <- mapM canonicalizePathNoThrow l'
   let tmpFile = path <.> "tmp"
   -- 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
@@ -166,6 +167,8 @@ removeBuildTreeRefs verbosity path l' = do
   renameFile tmpFile path
   debug verbosity $ "Successfully renamed '" ++ tmpFile
     ++ "' to '" ++ path ++ "'"
+  -- FIXME: return only the refs that vere actually removed.
+  return l
     where
       p l entry = case readBuildTreeRef entry of
         Nothing                     -> True
diff --git a/cabal-install/Distribution/Client/Utils.hs b/cabal-install/Distribution/Client/Utils.hs
index 20c6e05..b025c11 100644
--- a/cabal-install/Distribution/Client/Utils.hs
+++ b/cabal-install/Distribution/Client/Utils.hs
@@ -5,9 +5,11 @@ module Distribution.Client.Utils ( MergeResult(..)
                                  , moreRecentFile, inDir, numberOfProcessors
                                  , removeExistingFile
                                  , makeAbsoluteToCwd, filePathToByteString
-                                 , byteStringToFilePath, tryCanonicalizePath)
+                                 , byteStringToFilePath, tryCanonicalizePath
+                                 , canonicalizePathNoThrow )
        where
 
+import Distribution.Compat.Exception ( catchIO )
 import qualified Data.ByteString.Lazy as BS
 import Control.Monad
          ( when )
@@ -155,3 +157,9 @@ tryCanonicalizePath path = do
                 ++ "(No such file or directory)"
 #endif
   return ret
+
+-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws
+-- an exception, returns the path argument unmodified.
+canonicalizePathNoThrow :: FilePath -> IO FilePath
+canonicalizePathNoThrow path = do
+  canonicalizePath path `catchIO` (\_ -> return path)