diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index 48647e48eb1..c410969e88c 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} module Distribution.Client.VCS ( -- * VCS driver type @@ -46,17 +47,18 @@ import Distribution.Simple.Program ( Program(programFindVersion) , ConfiguredProgram(programVersion) , simpleProgram, findProgramVersion - , ProgramInvocation(..), programInvocation, runProgramInvocation + , ProgramInvocation(..), programInvocation, runProgramInvocation, getProgramInvocationOutput , emptyProgramDb, requireProgram ) import Distribution.Version ( mkVersion ) import qualified Distribution.PackageDescription as PD import Control.Exception - ( throw ) + ( throw, try ) import Control.Monad.Trans ( liftIO ) import qualified Data.Char as Char +import qualified Data.List as List import qualified Data.Map as Map import System.FilePath ( takeDirectory ) @@ -322,14 +324,26 @@ vcsDarcs = [ vcsSyncRepo verbosity prog repo localDir (Just primaryLocalDir) | (repo, localDir) <- secondaryRepos ] - vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer = do - removeDirectoryRecursive localDir `catch` \ case - e | isDoesNotExistError e -> pure () - | otherwise -> throw e - darcs (takeDirectory localDir) cloneArgs + vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer = + try (lines <$> darcsWithOutput localDir ["log", "--last", "1"]) >>= \ case + Right (_:_:_:x:_) + | Just tag <- (List.stripPrefix "tagged " . List.dropWhile Char.isSpace) x + , Just tag' <- srpTag + , tag == tag' -> pure () + Left (_ :: SomeException) -> pure () + _ -> do + removeDirectoryRecursive localDir `catch` \ case + e | isDoesNotExistError e -> pure () + | otherwise -> throw e + darcs (takeDirectory localDir) cloneArgs where darcs :: FilePath -> [String] -> IO () - darcs cwd args = runProgramInvocation verbosity (programInvocation prog args) + darcs = darcs' runProgramInvocation + + darcsWithOutput :: FilePath -> [String] -> IO String + darcsWithOutput = darcs' getProgramInvocationOutput + + darcs' f cwd args = f verbosity (programInvocation prog args) { progInvokeCwd = Just cwd } cloneArgs = ["clone"] <|> tagArgs <|> [srpLocation, localDir] <|> verboseArg