6610 Add pijul to known repository type

Cabal/Distribution/PackageDescription/Check.hs

@@ -1922,6 +1922,7 @@ repoTypeDirname Mercurial = [".hg"]
 repoTypeDirname GnuArch   = [".arch-params"]
 repoTypeDirname Bazaar    = [".bzr"]
 repoTypeDirname Monotone  = ["_MTN"]
+repoTypeDirname Pijul     = [".pijul"]
 
 -- ------------------------------------------------------------
 -- * Checks involving files in the package

Cabal/Distribution/Types/SourceRepo.hs

@@ -126,7 +126,7 @@ instance NFData RepoKind where rnf = genericRnf
 -- obtain and track the repo depend on the repo type.
 --
 data KnownRepoType = Darcs | Git | SVN | CVS
-                   | Mercurial | GnuArch | Bazaar | Monotone
+                   | Mercurial | GnuArch | Bazaar | Monotone | Pijul
   deriving (Eq, Generic, Ord, Read, Show, Typeable, Data, Enum, Bounded)
 
 instance Binary KnownRepoType

Cabal/tests/UnitTests/Distribution/Utils/Structured.hs

@@ -23,6 +23,6 @@ tests = testGroup "Distribution.Utils.Structured"
     , testCase "SPDX.License"   $ structureHash (Proxy :: Proxy License)        @?= Fingerprint 0xd3d4a09f517f9f75 0xbc3d16370d5a853a
     -- The difference is in encoding of newtypes
 #if MIN_VERSION_base(4,7,0)
-    , testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= Fingerprint 0xe426ef7c5c6e25e8 0x79b156f0f3c58f79
+    , testCase "LocalBuildInfo" $ structureHash (Proxy :: Proxy LocalBuildInfo) @?= Fingerprint 0xd30fe34420e49987 0x5bc6c102b80854e6
 #endif
     ]

cabal-install/Distribution/Client/VCS.hs

@@ -28,6 +28,7 @@ module Distribution.Client.VCS (
     vcsGit,
     vcsHg,
     vcsSvn,
+    vcsPijul,
   ) where
 
 import Prelude ()
@@ -498,3 +499,84 @@ svnProgram = (simpleProgram "svn") {
         _ -> ""
   }
 
+
+-- | VCS driver for Pijul.
+-- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>
+--
+vcsPijul :: VCS Program
+vcsPijul =
+    VCS {
+      vcsRepoType = KnownRepoType Pijul,
+      vcsProgram  = pijulProgram,
+      vcsCloneRepo,
+      vcsSyncRepos
+    }
+  where
+    vcsCloneRepo :: Verbosity -- ^ it seams that pijul does not have verbose flag
+                 -> ConfiguredProgram
+                 -> SourceRepositoryPackage f
+                 -> FilePath
+                 -> FilePath
+                 -> [ProgramInvocation]
+    vcsCloneRepo _verbosity prog repo srcuri destdir =
+        [ programInvocation prog cloneArgs ]
+        -- And if there's a tag, we have to do that in a second step:
+     ++ [ (programInvocation prog (checkoutArgs tag)) {
+            progInvokeCwd = Just destdir
+          }
+        | tag <- maybeToList (srpTag repo) ]
+      where
+        cloneArgs  = ["clone", srcuri, destdir]
+                     ++ branchArgs
+        branchArgs = case srpBranch repo of
+          Just b  -> ["--from-branch", b]
+          Nothing -> []
+        checkoutArgs tag = "checkout" : [tag]
+
+    vcsSyncRepos :: Verbosity
+                 -> ConfiguredProgram
+                 -> [(SourceRepositoryPackage f, FilePath)]
+                 -> IO [MonitorFilePath]
+    vcsSyncRepos _ _ [] = return []
+    vcsSyncRepos verbosity pijulProg
+                 ((primaryRepo, primaryLocalDir) : secondaryRepos) = do
+
+      vcsSyncRepo verbosity pijulProg primaryRepo primaryLocalDir Nothing
+      sequence_
+        [ vcsSyncRepo verbosity pijulProg repo localDir (Just primaryLocalDir)
+        | (repo, localDir) <- secondaryRepos ]
+      return [ monitorDirectoryExistence dir
+             | dir <- (primaryLocalDir : map snd secondaryRepos) ]
+
+    vcsSyncRepo verbosity pijulProg SourceRepositoryPackage{..} localDir peer = do
+        exists <- doesDirectoryExist localDir
+        if exists
+          then pijul localDir                 ["pull"]
+          else pijul (takeDirectory localDir) cloneArgs
+        pijul localDir checkoutArgs
+      where
+        pijul :: FilePath -> [String] -> IO ()
+        pijul cwd args = runProgramInvocation verbosity $
+                         (programInvocation pijulProg args) {
+                           progInvokeCwd = Just cwd
+                         }
+
+        cloneArgs      = ["clone", loc, localDir]
+                      ++ case peer of
+                           Nothing           -> []
+                           Just peerLocalDir -> [peerLocalDir]
+                         where loc = srpLocation
+        checkoutArgs   = "checkout" :  ["--force", checkoutTarget, "--" ]
+        checkoutTarget = fromMaybe "HEAD" (srpBranch `mplus` srpTag)
+
+pijulProgram :: Program
+pijulProgram = (simpleProgram "pijul") {
+    programFindVersion = findProgramVersion "--version" $ \str ->
+      case words str of
+        -- "pijul version 2.5.5"
+        (_:_:ver:_) | all isTypical ver -> ver
+        _ -> ""
+  }
+  where
+    isNum     c = c >= '0' && c <= '9'
+    isTypical c = isNum c || c == '.'

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

@@ -50,18 +50,24 @@ tests mtimeChange =
   [ testGroup "check VCS test framework" $
     [ testProperty "git"    prop_framework_git
     ] ++
+    [ testProperty "pijul"  prop_framework_pijul
+    ] ++
     [ testProperty "darcs" (prop_framework_darcs mtimeChange)
     | enableDarcsTests
     ]
   , testGroup "cloneSourceRepo" $
     [ testProperty "git"    prop_cloneRepo_git
     ] ++
+    [ testProperty "pijul"  prop_cloneRepo_pijul
+    ] ++
     [ testProperty "darcs" (prop_cloneRepo_darcs mtimeChange)
     | enableDarcsTests
     ]
   , testGroup "syncSourceRepos" $
     [ testProperty "git"    prop_syncRepos_git
     ] ++
+    [ testProperty "pijul"  prop_syncRepos_pijul
+    ] ++
     [ testProperty "darcs" (prop_syncRepos_darcs mtimeChange)
     | enableDarcsTests
     ]
@@ -83,6 +89,12 @@ prop_framework_darcs mtimeChange =
   . prop_framework vcsDarcs (vcsTestDriverDarcs mtimeChange)
   . WithoutBranchingSupport
 
+prop_framework_pijul :: BranchingRepoRecipe -> Property
+prop_framework_pijul =
+    ioProperty
+  . prop_framework vcsPijul vcsTestDriverPijul
+  . WithBranchingSupport
+
 prop_cloneRepo_git :: BranchingRepoRecipe -> Property
 prop_cloneRepo_git =
     ioProperty
@@ -96,6 +108,12 @@ prop_cloneRepo_darcs mtimeChange =
   . prop_cloneRepo vcsDarcs (vcsTestDriverDarcs mtimeChange)
   . WithoutBranchingSupport
 
+prop_cloneRepo_pijul :: BranchingRepoRecipe -> Property
+prop_cloneRepo_pijul =
+    ioProperty
+  . prop_cloneRepo vcsPijul vcsTestDriverPijul
+  . WithBranchingSupport
+
 prop_syncRepos_git :: RepoDirSet -> SyncTargetIterations -> PrngSeed
                    -> BranchingRepoRecipe -> Property
 prop_syncRepos_git destRepoDirs syncTargetSetIterations seed =
@@ -113,6 +131,13 @@ prop_syncRepos_darcs  mtimeChange destRepoDirs syncTargetSetIterations seed =
                    destRepoDirs syncTargetSetIterations seed
   . WithoutBranchingSupport
 
+prop_syncRepos_pijul :: RepoDirSet -> SyncTargetIterations -> PrngSeed
+                   -> BranchingRepoRecipe -> Property
+prop_syncRepos_pijul destRepoDirs syncTargetSetIterations seed =
+    ioProperty
+  . prop_syncRepos vcsPijul vcsTestDriverPijul
+                   destRepoDirs syncTargetSetIterations seed
+  . WithBranchingSupport
 
 -- ------------------------------------------------------------
 -- * General test setup
@@ -693,3 +718,45 @@ vcsTestDriverDarcs mtimeChange verbosity vcs repoRoot =
                            }
     darcs = runProgramInvocation verbosity . darcsInvocation
 
+
+vcsTestDriverPijul :: Verbosity -> VCS ConfiguredProgram
+                 -> FilePath -> VCSTestDriver
+vcsTestDriverPijul verbosity vcs repoRoot =
+    VCSTestDriver {
+      vcsVCS = vcs
+
+    , vcsRepoRoot = repoRoot
+
+    , vcsIgnoreFiles = Set.empty
+
+    , vcsInit =
+        pijul $ ["init"]
+
+    , vcsAddFile = \_ filename ->
+        pijul ["add", filename]
+
+    , vcsCommitChanges = \_state -> do
+        pijul $ ["record", "-a", "-m 'a patch'"
+                , "-A 'A <[email protected]>'"
+                ]
+        commit <- pijul' ["log"]
+        let commit' = takeWhile (not . isSpace) commit
+        return (Just commit')
+
+    , vcsTagState = \_ tagname ->
+        pijul ["tag", tagname]
+
+    , vcsSwitchBranch = \RepoState{allBranches} branchname -> do
+        unless (branchname `Map.member` allBranches) $
+          pijul ["from-branch", branchname]
+        pijul $ ["checkout", branchname]
+
+    , vcsCheckoutTag = Left $ \tagname ->
+        pijul $ ["checkout", tagname]
+    }
+  where
+    gitInvocation args = (programInvocation (vcsProgram vcs) args) {
+                           progInvokeCwd = Just repoRoot
+                         }
+    pijul  = runProgramInvocation       verbosity . gitInvocation
+    pijul' = getProgramInvocationOutput verbosity . gitInvocation