Merge pull request #6684 from phadej/issue-6610

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 0x27de6f0a3d133e71 0x81c8d35b9e4b8bf0
 #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,147 @@ svnProgram = (simpleProgram "svn") {
         _ -> ""
   }
 
+
+-- | VCS driver for Pijul.
+-- Documentation for Pijul can be found at <https://pijul.org/manual/introduction.html>
+--
+-- 2020-04-09 Oleg:
+--
+--    As far as I understand pijul, there are branches and "tags" in pijul,
+--    but there aren't a "commit hash" identifying an arbitrary state.
+--
+--    One can create `a pijul tag`, which will make a patch hash,
+--    which depends on everything currently in the repository.
+--    I guess if you try to apply that patch, you'll be forced to apply
+--    all the dependencies too. In other words, there are no named tags.
+--
+--    It's not clear to me whether there is an option to
+--    "apply this patch *and* all of its dependencies".
+--    And relatedly, whether how to make sure that there are no other
+--    patches applied.
+--
+--    With branches it's easier, as you can `pull` and `checkout` them,
+--    and they seem to be similar enough. Yet, pijul documentations says
+--
+--    > Note that the purpose of branches in Pijul is quite different from Git,
+--      since Git's "feature branches" can usually be implemented by just
+--      patches.
+--
+--    I guess it means that indeed instead of creating a branch and making PR
+--    in "GitHub" workflow, you'd just create a patch and offer it.
+--    You can do that with `git` too. Push (a branch with) commit to remote
+--    and ask other to cherry-pick that commit. Yet, in git identity of commit
+--    changes when it applied to other trees, where patches in pijul have
+--    will continue to have the same hash.
+--
+--    Unfortunately pijul doesn't talk about conflict resolution.
+--    It seems that you get something like:
+--
+--        % pijul status
+--        On branch merge
+--
+--        Unresolved conflicts:
+--          (fix conflicts and record the resolution with "pijul record ...")
+--
+--                foo
+--
+--        % cat foo
+--        first line
+--        >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
+--        branch BBB
+--        ================================
+--        branch AAA
+--        <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
+--        last line
+--
+--    And then the `pijul dependencies` would draw you a graph like
+--
+--
+--                    ----->  foo on branch B ----->
+--    resolve confict                                  Initial patch
+--                    ----->  foo on branch A ----->
+--
+--    Which is seems reasonable.
+--
+--    So currently, pijul support is very experimental, and most likely
+--    won't work, even the basics are in place. Tests are also written
+--    but disabled, as the branching model differs from `git` one,
+--    for which tests are written.
+--
+vcsPijul :: VCS Program
+vcsPijul =
+    VCS {
+      vcsRepoType = KnownRepoType Pijul,
+      vcsProgram  = pijulProgram,
+      vcsCloneRepo,
+      vcsSyncRepos
+    }
+  where
+    vcsCloneRepo :: Verbosity -- ^ it seems 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] -- TODO: this probably doesn't work either
+
+    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"] -- TODO: this probably doesn't work.
+        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) -- TODO: this is definitely wrong.
+
+pijulProgram :: Program
+pijulProgram = (simpleProgram "pijul") {
+    programFindVersion = findProgramVersion "--version" $ \str ->
+      case words str of
+        -- "pijul 0.12.2
+        (_: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

@@ -47,29 +47,26 @@ import UnitTests.TempTestDir (withTestDir, removeDirectoryRecursiveHack)
 --
 tests :: MTimeChange -> [TestTree]
 tests mtimeChange =
-  [ testGroup "check VCS test framework" $
-    [ testProperty "git"    prop_framework_git
-    ] ++
-    [ testProperty "darcs" (prop_framework_darcs mtimeChange)
-    | enableDarcsTests
+  [ testGroup "git"
+    [ testProperty "check VCS test framework"    prop_framework_git
+    , testProperty "cloneSourceRepo"             prop_cloneRepo_git
+    , testProperty "syncSourceRepos"             prop_syncRepos_git
     ]
-  , testGroup "cloneSourceRepo" $
-    [ testProperty "git"    prop_cloneRepo_git
-    ] ++
-    [ testProperty "darcs" (prop_cloneRepo_darcs mtimeChange)
-    | enableDarcsTests
+
+    -- for the moment they're not yet working
+  , testGroup "darcs" $ const []
+    [ testProperty "check VCS test framework"    $ prop_framework_darcs mtimeChange
+    , testProperty "cloneSourceRepo"             $ prop_cloneRepo_darcs mtimeChange
+    , testProperty "syncSourceRepos"             $ prop_syncRepos_darcs mtimeChange
     ]
-  , testGroup "syncSourceRepos" $
-    [ testProperty "git"    prop_syncRepos_git
-    ] ++
-    [ testProperty "darcs" (prop_syncRepos_darcs mtimeChange)
-    | enableDarcsTests
+
+  , testGroup "pijul" $ const []
+    [ testProperty "check VCS test framework"    prop_framework_pijul
+    , testProperty "cloneSourceRepo"             prop_cloneRepo_pijul
+    , testProperty "syncSourceRepos"             prop_syncRepos_pijul
     ]
-  ]
-  where
-    -- for the moment they're not yet working
-    enableDarcsTests = False
 
+  ]
 
 prop_framework_git :: BranchingRepoRecipe -> Property
 prop_framework_git =
@@ -83,6 +80,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 +99,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 +122,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 +709,47 @@ 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 <a@example.com>'"
+                ]
+        commit <- pijul' ["log"]
+        let commit' = takeWhile (not . isSpace) commit
+        return (Just commit')
+
+    -- tags work differently in pijul...
+    -- so this is wrong
+    , vcsTagState = \_ tagname ->
+        pijul ["tag", tagname]
+
+    , vcsSwitchBranch = \_ 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