diff --git a/Cabal/Distribution/PackageDescription/Check.hs b/Cabal/Distribution/PackageDescription/Check.hs index 355b4eb1087..72336652e37 100644 --- a/Cabal/Distribution/PackageDescription/Check.hs +++ b/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 diff --git a/Cabal/Distribution/Types/SourceRepo.hs b/Cabal/Distribution/Types/SourceRepo.hs index 00d7ac24588..ac6f5732622 100644 --- a/Cabal/Distribution/Types/SourceRepo.hs +++ b/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 diff --git a/Cabal/tests/UnitTests/Distribution/Utils/Structured.hs b/Cabal/tests/UnitTests/Distribution/Utils/Structured.hs index 0e55a3ecc13..2d79813b156 100644 --- a/Cabal/tests/UnitTests/Distribution/Utils/Structured.hs +++ b/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 ] diff --git a/cabal-install/Distribution/Client/VCS.hs b/cabal-install/Distribution/Client/VCS.hs index 9f3c43d881e..784c22ecc28 100644 --- a/cabal-install/Distribution/Client/VCS.hs +++ b/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 +-- +-- 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 == '.' diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs index 3c682a532bf..57049a7e685 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/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 '" + ] + 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