Add support for hg version control system (#7133)

* Add sync support for hg

* Updated VCS tests to include hg. cabal.project requires tests enabled for cabal-install

Co-authored-by: Emily Pillmore <[email protected]>

cabal-install/src/Distribution/Client/VCS.hs

@@ -490,7 +490,35 @@ vcsHg =
                  -> ConfiguredProgram
                  -> [(SourceRepositoryPackage f, FilePath)]
                  -> IO [MonitorFilePath]
-    vcsSyncRepos _v _p _rs = fail "sync repo not yet supported for hg"
+    vcsSyncRepos _ _ [] = return []
+    vcsSyncRepos verbosity hgProg
+                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
+      vcsSyncRepo verbosity hgProg primaryRepo primaryLocalDir
+      sequence_
+        [ vcsSyncRepo verbosity hgProg repo localDir
+        | (repo, localDir) <- secondaryRepos ]
+      return [ monitorDirectoryExistence dir
+            | dir <- (primaryLocalDir : map snd secondaryRepos) ]
+    vcsSyncRepo verbosity hgProg repo localDir = do
+        exists <- doesDirectoryExist localDir
+        if exists
+          then hg localDir ["pull"]
+          else hg (takeDirectory localDir) cloneArgs
+        hg localDir checkoutArgs
+      where
+        hg :: FilePath -> [String] -> IO ()
+        hg cwd args = runProgramInvocation verbosity $
+                          (programInvocation hgProg args) {
+                            progInvokeCwd = Just cwd
+                          }
+        cloneArgs      = ["clone", "--noupdate", (srpLocation repo), localDir]
+                        ++ verboseArg
+        verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]
+        checkoutArgs = [ "checkout", "--clean" ]
+                      ++ tagArgs
+        tagArgs = case srpTag repo of
+            Just t  -> ["--rev", t]
+            Nothing -> []
 
 hgProgram :: Program
 hgProgram = (simpleProgram "hg") {

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

@@ -66,6 +66,12 @@ tests mtimeChange =
     , testProperty "syncSourceRepos"             prop_syncRepos_pijul
     ]
 
+  , testGroup "mercurial" $ const []
+    [ testProperty "check VCS test framework"    prop_framework_hg
+    , testProperty "cloneSourceRepo"             prop_cloneRepo_hg
+    , testProperty "syncSourceRepos"             prop_syncRepos_hg
+    ]
+
   ]
 
 prop_framework_git :: BranchingRepoRecipe -> Property
@@ -86,6 +92,12 @@ prop_framework_pijul =
   . prop_framework vcsPijul vcsTestDriverPijul
   . WithBranchingSupport
 
+prop_framework_hg :: BranchingRepoRecipe -> Property
+prop_framework_hg =
+    ioProperty
+  . prop_framework vcsHg vcsTestDriverHg
+  . WithBranchingSupport
+
 prop_cloneRepo_git :: BranchingRepoRecipe -> Property
 prop_cloneRepo_git =
     ioProperty
@@ -105,6 +117,12 @@ prop_cloneRepo_pijul =
   . prop_cloneRepo vcsPijul vcsTestDriverPijul
   . WithBranchingSupport
 
+prop_cloneRepo_hg :: BranchingRepoRecipe -> Property
+prop_cloneRepo_hg =
+    ioProperty
+  . prop_cloneRepo vcsHg vcsTestDriverHg
+  . WithBranchingSupport
+
 prop_syncRepos_git :: RepoDirSet -> SyncTargetIterations -> PrngSeed
                    -> BranchingRepoRecipe -> Property
 prop_syncRepos_git destRepoDirs syncTargetSetIterations seed =
@@ -130,6 +148,14 @@ prop_syncRepos_pijul destRepoDirs syncTargetSetIterations seed =
                    destRepoDirs syncTargetSetIterations seed
   . WithBranchingSupport
 
+prop_syncRepos_hg :: RepoDirSet -> SyncTargetIterations -> PrngSeed
+                   -> BranchingRepoRecipe -> Property
+prop_syncRepos_hg destRepoDirs syncTargetSetIterations seed =
+    ioProperty
+  . prop_syncRepos vcsHg vcsTestDriverHg
+                   destRepoDirs syncTargetSetIterations seed
+  . WithBranchingSupport
+
 -- ------------------------------------------------------------
 -- * General test setup
 -- ------------------------------------------------------------
@@ -755,3 +781,46 @@ vcsTestDriverPijul verbosity vcs repoRoot =
                          }
     pijul  = runProgramInvocation       verbosity . gitInvocation
     pijul' = getProgramInvocationOutput verbosity . gitInvocation
+
+vcsTestDriverHg :: Verbosity -> VCS ConfiguredProgram
+                 -> FilePath -> VCSTestDriver
+vcsTestDriverHg verbosity vcs repoRoot =
+    VCSTestDriver {
+      vcsVCS = vcs
+
+    , vcsRepoRoot = repoRoot
+
+    , vcsIgnoreFiles = Set.empty
+
+    , vcsInit =
+        hg $ ["init"]  ++ verboseArg
+
+    , vcsAddFile = \_ filename ->
+        hg ["add", filename]
+
+    , vcsCommitChanges = \_state -> do
+        hg $ [ "--user='A <[email protected]>'"
+              , "commit", "--message=a patch"
+              ] ++ verboseArg
+        commit <- hg' ["log", "--template='{node}\\n' -l1"]
+        let commit' = takeWhile (not . isSpace) commit
+        return (Just commit')
+
+    , vcsTagState = \_ tagname ->
+        hg ["tag", "--force", tagname]
+
+    , vcsSwitchBranch = \RepoState{allBranches} branchname -> do
+        unless (branchname `Map.member` allBranches) $
+          hg ["branch", branchname]
+        hg $ ["checkout", branchname] ++ verboseArg
+
+    , vcsCheckoutTag = Left $ \tagname ->
+        hg $ ["checkout", "--rev", tagname] ++ verboseArg
+    }
+  where
+    hgInvocation args = (programInvocation (vcsProgram vcs) args) {
+                           progInvokeCwd = Just repoRoot
+                         }
+    hg  = runProgramInvocation       verbosity . hgInvocation
+    hg' = getProgramInvocationOutput verbosity . hgInvocation
+    verboseArg = [ "--quiet" | verbosity < Verbosity.normal ]