diff --git a/cabal-install/src/Distribution/Client/VCS.hs b/cabal-install/src/Distribution/Client/VCS.hs index a71f0baf3f8..75ca75d6334 100644 --- a/cabal-install/src/Distribution/Client/VCS.hs +++ b/cabal-install/src/Distribution/Client/VCS.hs @@ -1,5 +1,8 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE NamedFieldPuns, RecordWildCards, RankNTypes #-} +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} module Distribution.Client.VCS ( -- * VCS driver type VCS, @@ -46,7 +49,7 @@ import Distribution.Simple.Program ( Program(programFindVersion) , ConfiguredProgram(programVersion) , simpleProgram, findProgramVersion - , ProgramInvocation(..), programInvocation, runProgramInvocation + , ProgramInvocation(..), programInvocation, runProgramInvocation, getProgramInvocationOutput , emptyProgramDb, requireProgram ) import Distribution.Version ( mkVersion ) @@ -55,10 +58,11 @@ import qualified Distribution.PackageDescription as PD import Control.Applicative ( liftA2 ) 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 ) @@ -324,12 +328,23 @@ vcsDarcs = dirs = primaryLocalDir : (snd <$> secondaryRepos) monitors = monitorDirectoryExistence <$> dirs - vcsSyncRepo verbosity prog SourceRepositoryPackage{..} localDir _peer = do - removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw - 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 () + (_ :: Either SomeException _) -> do + removeDirectoryRecursive localDir `catch` liftA2 unless isDoesNotExistError throw + 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