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..ef996c74086 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 0xd30fe34420e49987 0x5bc6c102b80854e6 #endif ] diff --git a/cabal-install/Distribution/Client/VCS.hs b/cabal-install/Distribution/Client/VCS.hs index 9f3c43d881e..f2d786e9512 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,84 @@ svnProgram = (simpleProgram "svn") { _ -> "" } + +-- | VCS driver for Pijul. +-- Documentation for Pijul can be found at +-- +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 == '.' diff --git a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs b/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs index 3c682a532bf..b3f7a0140dd 100644 --- a/cabal-install/tests/UnitTests/Distribution/Client/VCS.hs +++ b/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 '" + ] + 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