diff --git a/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,42 @@ +Darcs 2.10.2, 9 November 2015 + + * switch from dataenc (deprecated) to sandi + * finish updating help strings with new command names + * make patch selection lazier in presence of matchers + * clean contrib scripts + * switch patches retrieval order when using packs + * disable mmap on Windows + * enhance darcs send message + * fix quickcheck suite + * optimize patch apply code memory use + * shorter README with quickstart instructions + * fixed the following bugs: + + * 2457: fix darcs-test command line options + * 2463: building darcs on powerpc + * 2444: added default interactivity parameter to isInteractive + + +Darcs 2.10.1, 9 July 2015 + + * generalized doFastZip for darcsden support + * support terminfo 0.4, network 2.6, zlib 0.6, quickcheck 2.8 and + attoparsec 0.13 + * errorDoc now prints a stack trace (if profiling was enabled) + * beautified error messages for command line and default files + * fixed the following bugs: + + * 2449: test harness/shelly: need to handle mis-encoded/binary data + * 2423: diff only respecting --diff-command when a diff.exe is present + * 2447: get contents of deleted file + * 2307: add information about 'darcs help manpage' and + 'darcs help markdown' + * 2461: darcs log --repo=remoterepo creates and populates + _darcs + * 2459: cloning remote repo fails to use packs if cache is + on a different partition + + Darcs 2.10.0, 19 April 2015 * Important changes in Darcs 2.10 diff --git a/README b/README --- a/README +++ b/README @@ -1,91 +1,48 @@ Darcs ===== -This is the source tree for darcs, a distributed version control system +[Darcs](http://darcs.net) is a distributed version control system written in Haskell. -For more information, visit the darcs website: . - - -Compilation and Installation -============================ - -Building Darcs is best done with the Haskell Platform: -. Any release of darcs should build with -the most recent version of the Platform at the time of the release. This -will also generally apply to unstable versions. - -If you are not using the Platform, then you need GHC and Cabal. -The versions required can be found in the darcs.cabal file under -'build-tools' and 'Cabal-Version' respectively. - -The cabal-install package is also recommended. - -If you have the Platform or otherwise have the "cabal-install" package -on your system (that is, there is a "cabal" executable in your path), -you can use the following command to create an executable in -`~/.cabal/bin/darcs` (this will also automatically fetch and build -dependencies from the Hackage server). - - $ cabal update - $ cabal install - -Otherwise, if you have the "cabal" package but not the "cabal-install" -package, run the following: - - $ runghc Setup configure - $ runghc Setup build - $ sudo runghc Setup install - -You may also omit the last step and copy the darcs executable (found in -`dist/build/darcs/darcs`) to a location of your choosing. - -More detailed instructions can be found at - -including instructions on obtaining a copy of cabal-install. - - -Flags to alter compilation -========================== +Getting started +=============== -There some flags that can be used to alter compilation. They are specified like this: +Compiling +--------- - $ cabal install -fflag_name +Build instructions are available at . -Here are some may be of interest. Search for "flags" in the `darcs.cabal` file -file for the complete list. +Using +----- -* `-f-curl`: - By default the cabal-based build requires the cURL library and development - headers. If you can't provide cURL, use this flag to disable the use of it. - The pure Haskell 'HTTP' package will be used instead. +To clone a repository from HTTP and send patches by mail: -* `-frts`: - When trying to use the patch-index feature, you can may get an error like - this: "Stack space overflow: current size 8388608 bytes." darcs can be - recompiled with this flag to avoid the issue. Some more detail is here: - + $ darcs clone --lazy http://darcs.net + $ (edit files) + $ darcs add (new files) + $ darcs record -m "my changes" + $ darcs send -* `-fstatic`: - Builds a static binary, which bundles most dependencies. The resulting binary - is larger, but is able to be installed on similar machines without also - installing all the dependencies separately. +To clone from SSH and push patches: -Hacking -======= + $ darcs clone user@hub.darcs.net:user/repo + $ (edit files) + $ darcs add (new files) + $ darcs record -m "my changes" + $ darcs push -For more information about darcs hacking and best practices please check -the darcs website +To create a project and start working: -Of particular interest are the following pages: + $ darcs init (project) + $ cd (project) + $ (add files) + $ darcs add (files) + $ darcs record -m "initial version" -* -* +See for more information. -Testing -======= +Reporting bugs +============== -For more information about the test suite, including how to run specific -tests . +Please send bug reports to . -Happy hacking! diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -252,7 +252,7 @@ versionPatches verbosity darcsVersion = do numPatchesDarcs <- do out <- rawSystemStdout verbosity "darcs" - ["changes", "-a", "--from-tag", display darcsVersion, "--count"] + ["log", "-a", "--from-tag", display darcsVersion, "--count"] case reads (out) of ((n,_):_) -> return $ Just ((n :: Int) - 1) _ -> return Nothing @@ -290,7 +290,7 @@ contextDarcs <- do inrepo <- doesDirectoryExist "_darcs" unless inrepo $ fail "Not a repository." - out <- rawSystemStdout verbosity "darcs" ["changes", "-a", "--context"] + out <- rawSystemStdout verbosity "darcs" ["log", "-a", "--context"] return $ Just out `catchAny` \_ -> return Nothing diff --git a/contrib/cygwin-wrapper.bash b/contrib/cygwin-wrapper.bash --- a/contrib/cygwin-wrapper.bash +++ b/contrib/cygwin-wrapper.bash @@ -123,11 +123,12 @@ # treat the option argument like a file. declare -a opaque_binary_opts=( \ '--repo-name' \ - '--to-match' '--to-patch' '--to-tag' \ - '--from-match' '--from-patch' '--from-tag' \ + '--to-match' '--to-patch' '--to-tag' '--to-hash' \ + '--from-match' '--from-patch' '--from-tag' '--from-hash' \ '-t' '--tag' '--tags' '--tag-name' \ '-p' '--patch' '--patches' \ '-m' '--patch-name' \ + '-h' '--hash' \ '--matches' '--match' \ '--token-chars' \ '-A' '--author' '--from' '--to' '--cc' \ @@ -154,16 +155,16 @@ # converted and some that don't. # Commands whose arguments are file paths that need to be translated. -cmds_convert_nonoption_args='|get|put|pull|push|send|apply' +cmds_convert_nonoption_args='|clone|pull|push|send|apply' # Commands who's arguments should be left alone. File paths that # refer to files in the repo should NOT be converted because they # are relative paths, which Darcs will handle just fine. Cygwin # sometimes makes them absolute paths, which confuses Darcs. -#cmds_no_convert_nonoption_paths='|add|remove|mv|replace|record|whatsnew|changes|setpref|trackdown|amend-record|revert|diff|annotate' +#cmds_no_convert_nonoption_paths='|add|remove|mv|replace|record|whatsnew|log|setpref|test|amend|revert|diff|annotate' # Commands that don't accept non-option arguments -#cmds_no_nonoption_args='|initialize|tag|check|optimize|rollback|unrecord|unpull|resolve|dist|repair' +#cmds_no_nonoption_args='|initialize|tag|optimize|rollback|unrecord|unpull|dist|repair' # See if we need to convert the non-option args for the current # command. This matches some prefix of one of the commands in the diff --git a/contrib/upload.cgi b/contrib/upload.cgi --- a/contrib/upload.cgi +++ b/contrib/upload.cgi @@ -27,9 +27,9 @@ my $patch_test_cmd; # command to test patches with $patch_test_cmd = "darcs apply --dry-run --repodir 'TARGETREPO' 'TARGETPATCH'"; -my $repo_get_cmd; # command to get testing repo - # used only when $target_repo is blank -$repo_get_cmd = "darcs get --lazy --repodir 'TARGETDIR' 'TARGETREPO'"; +my $repo_clone_cmd; # command to clone testing repo + # used only when $target_repo is blank +$repo_clone_cmd = "darcs clone --lazy --repodir 'TARGETDIR' 'TARGETREPO'"; sub error_page { @@ -103,10 +103,10 @@ my $test_dir = tempdir(CLEANUP => 1).'/repo' or return "$!: Could not create test directory"; - $repo_get_cmd =~ s/TARGETDIR/$test_dir/; - $repo_get_cmd =~ s/TARGETREPO/$darcsurl/; - system("$repo_get_cmd >/dev/null 2>/dev/null") == 0 or - return "Could not get target repo: '$repo_get_cmd' failed"; + $repo_clone_cmd =~ s/TARGETDIR/$test_dir/; + $repo_clone_cmd =~ s/TARGETREPO/$darcsurl/; + system("$repo_clone_cmd >/dev/null 2>/dev/null") == 0 or + return "Could not clone target repo: '$repo_clone_cmd' failed"; $target_repo = $test_dir; } $patch_test_cmd =~ s/TARGETREPO/$target_repo/; diff --git a/darcs.cabal b/darcs.cabal --- a/darcs.cabal +++ b/darcs.cabal @@ -1,5 +1,5 @@ Name: darcs -version: 2.10.1 +version: 2.10.2 License: GPL License-file: COPYING Author: David Roundy , @@ -55,6 +55,7 @@ tests/data/*.dpatch tests/data/convert/darcs1/*.dpatch tests/data/convert/darcs2/*.dpatch tests/*.sh + tests/bin/renameHelper.hs tests/bin/trackdown-bisect-helper.hs tests/bin/hspwd.hs tests/network/*.sh @@ -447,7 +448,6 @@ build-depends: unix >= 2.5 && < 2.8 build-depends: bytestring >= 0.9.0 && < 0.11, - text >= 0.11.2.0 && < 1.3, old-time >= 1.1 && < 1.2, directory >= 1.1.0.2 && < 1.3.0.0, process >= 1.1.0.1 && < 1.3.0.0, @@ -455,6 +455,13 @@ random >= 1.0 && < 1.2, hashable >= 1.0 && < 1.3 + -- release notes of GHC 7.10.2 recommends to use text >= 1.2.1.3: + -- https://mail.haskell.org/pipermail/haskell/2015-July/024641.html + if impl(ghc>=7.10) + build-depends: text >= 1.2.1.3 && < 1.3 + else + build-depends: text >= 0.11.3.1 && < 1.3 + if flag(use-time-1point5) build-depends: time >= 1.5 && < 1.6 else @@ -559,7 +566,7 @@ Bundled.Posix Storage.Hashed.Utils - build-depends: dataenc >=0.11 && < 0.15, + build-depends: sandi >= 0.2 && < 0.4, unix-compat >= 0.1.2 && < 0.5, cryptohash >= 0.4 && < 0.12 @@ -662,7 +669,6 @@ regex-compat-tdfa >= 0.95.1 && < 0.96, shelly >= 1.6.2 && < 1.7, split >= 0.1.4.1 && < 0.3, - text >= 0.11.0.6 && < 1.3, directory >= 1.1.0.2 && < 1.3.0.0, FindBin >= 0.0 && < 0.1, QuickCheck >= 2.3 && < 2.9, @@ -671,6 +677,13 @@ test-framework-hunit >= 0.2.2 && < 0.4, test-framework-quickcheck2 >= 0.3 && < 0.4 + -- release notes of GHC 7.10.2 recommends to use text >= 1.2.1.3: + -- https://mail.haskell.org/pipermail/haskell/2015-July/024641.html + if impl(ghc>=7.10) + build-depends: text >= 1.2.1.3 && < 1.3 + else + build-depends: text >= 0.11.3.1 && < 1.3 + -- list all unit test modules not exported by libdarcs; otherwise Cabal won't -- include them in the tarball other-modules: Darcs.Test.Email @@ -782,7 +795,7 @@ directory, filepath, bytestring, - dataenc, + sandi, cryptohash, binary, zlib, diff --git a/harness/Darcs/Test/Patch.hs b/harness/Darcs/Test/Patch.hs --- a/harness/Darcs/Test/Patch.hs +++ b/harness/Darcs/Test/Patch.hs @@ -64,10 +64,10 @@ import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU import Darcs.Test.Patch.Properties.Check( Check(..) ) -import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop -import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop -import qualified Darcs.Test.Patch.Properties.Generic as Prop -import qualified Darcs.Test.Patch.Properties.Real as Prop +import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1 +import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2 +import qualified Darcs.Test.Patch.Properties.Generic as PropG +import qualified Darcs.Test.Patch.Properties.Real as PropR import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU import qualified Darcs.Test.Patch.Rebase as Rebase @@ -97,20 +97,20 @@ unit_V1P1:: [Test] unit_V1P1 = - [ testCases "known commutes" Prop.checkCommute Ex.knownCommutes - , testCases "known non-commutes" Prop.checkCantCommute Ex.knownCantCommutes - , testCases "known merges" Prop.checkMerge Ex.knownMerges - , testCases "known merges (equiv)" Prop.checkMergeEquiv Ex.knownMergeEquivs - , testCases "known canons" Prop.checkCanon Ex.knownCanons - , testCases "merge swaps" Prop.checkMergeSwap Ex.mergePairs2 - , testCases "the patch validation works" Prop.tTestCheck Ex.validPatches - , testCases "commute/recommute" (Prop.recommute commute) Ex.commutePairs - , testCases "merge properties: merge either way valid" Prop.tMergeEitherWayValid Ex.mergePairs - , testCases "merge properties: merge swap" Prop.mergeEitherWay Ex.mergePairs - , testCases "primitive patch IO functions" (Prop.tShowRead eqFLUnsafe) Ex.primitiveTestPatches - , testCases "IO functions (test patches)" (Prop.tShowRead eqFLUnsafe) Ex.testPatches - , testCases "IO functions (named test patches)" (Prop.tShowRead unsafeCompare) Ex.testPatchesNamed - , testCases "primitive commute/recommute" (Prop.recommute commute) Ex.primitiveCommutePairs + [ testCases "known commutes" Prop1.checkCommute Ex.knownCommutes + , testCases "known non-commutes" Prop1.checkCantCommute Ex.knownCantCommutes + , testCases "known merges" Prop1.checkMerge Ex.knownMerges + , testCases "known merges (equiv)" Prop1.checkMergeEquiv Ex.knownMergeEquivs + , testCases "known canons" Prop1.checkCanon Ex.knownCanons + , testCases "merge swaps" Prop1.checkMergeSwap Ex.mergePairs2 + , testCases "the patch validation works" Prop1.tTestCheck Ex.validPatches + , testCases "commute/recommute" (PropG.recommute commute) Ex.commutePairs + , testCases "merge properties: merge either way valid" Prop1.tMergeEitherWayValid Ex.mergePairs + , testCases "merge properties: merge swap" PropG.mergeEitherWay Ex.mergePairs + , testCases "primitive patch IO functions" (Prop1.tShowRead eqFLUnsafe) Ex.primitiveTestPatches + , testCases "IO functions (test patches)" (Prop1.tShowRead eqFLUnsafe) Ex.testPatches + , testCases "IO functions (named test patches)" (Prop1.tShowRead unsafeCompare) Ex.testPatchesNamed + , testCases "primitive commute/recommute" (PropG.recommute commute) Ex.primitiveCommutePairs ] unit_V2P1 :: [Test] @@ -155,6 +155,8 @@ , Show1 (ModelOf prim) , Check prim, PrimPatchBase prim, PrimOf prim ~ prim , FromPrim prim + , MightBeEmptyHunk prim + , MightHaveDuplicate prim , Show1 (prim wA) , Show1 ((prim :> prim) wA) , Show1 (WithState model prim wA) @@ -174,7 +176,7 @@ -- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc) (if runCoalesceTests p then [ testProperty "prim coalesce effect preserving... " - (unseal2 $ Prop.coalesceEffectPreserving coalesce :: Sealed2 (WithState model (prim :> prim)) -> TestResult) + (unseal2 $ PropG.coalesceEffectPreserving coalesce :: Sealed2 (WithState model (prim :> prim)) -> TestResult) ] else []) ++ concat @@ -195,19 +197,19 @@ qc_V2P1 :: [Test] qc_V2P1 = [ testProperty "tree flattenings are consistent... " - Prop.propConsistentTreeFlattenings + PropR.propConsistentTreeFlattenings , testProperty "with quickcheck that real patches are consistent... " (unseal $ P1.patchFromTree $ fromMaybe . isConsistent) -- permutivity ---------------------------------------------------------------------------- , testConditional "permutivity" (unseal $ P1.commuteTripleFromTree notDuplicatestriple) - (unseal $ P1.commuteTripleFromTree $ Prop.permutivity commuteReals) + (unseal $ P1.commuteTripleFromTree $ PropG.permutivity commuteReals) , testConditional "partial permutivity" (unseal $ P1.commuteTripleFromTree notDuplicatestriple) - (unseal $ P1.commuteTripleFromTree $ Prop.partialPermutivity commuteReals) + (unseal $ P1.commuteTripleFromTree $ PropG.partialPermutivity commuteReals) , testConditional "nontrivial permutivity" (unseal $ P1.commuteTripleFromTree (\t -> nontrivialTriple t && notDuplicatestriple t)) - (unseal $ P1.commuteTripleFromTree $ (Prop.permutivity commuteReals)) + (unseal $ P1.commuteTripleFromTree $ (PropG.permutivity commuteReals)) ] qc_V2 :: forall prim wXx wYy . (PrimPatch prim, Show1 (ModelOf prim), RepoModel (ModelOf prim), @@ -216,11 +218,11 @@ => prim wXx wYy -> [Test] qc_V2 _ = [ testProperty "readPatch and showPatch work on RealPatch... " - (unseal $ patchFromTree $ (Prop.show_read :: RealPatch prim wX wY -> TestResult)) + (unseal $ patchFromTree $ (PropG.show_read :: RealPatch prim wX wY -> TestResult)) , testProperty "readPatch and showPatch work on FL RealPatch... " - (unseal2 $ (Prop.show_read :: FL (RealPatch prim) wX wY -> TestResult)) + (unseal2 $ (PropG.show_read :: FL (RealPatch prim) wX wY -> TestResult)) , testProperty "we can do merges using QuickCheck" - (isNothing . (Prop.propIsMergeable :: + (isNothing . (PropG.propIsMergeable :: Sealed (WithStartState (ModelOf prim) (Tree prim)) -> Maybe (Tree (RealPatch prim) wX))) ] @@ -247,22 +249,28 @@ type PropList what gen = String -> TestGenerator what gen -> [Test] -pair_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, ShowPatchBasic p, MyEq p) - => p x y -> PropList (p :> p) gen +pair_properties :: forall p gen x y + . ( Show1 gen, Arbitrary (Sealed gen), Patchy p, MightHaveDuplicate p + , ShowPatchBasic p, MyEq p + ) + => p x y -> PropList (p :> p) gen pair_properties _ genname gen = properties gen "commute" genname - [ ("recommute" , const True , Prop.recommute commute ) - , ("nontrivial recommute" , nontrivialCommute, Prop.recommute commute ) - , ("inverses commute" , const True , Prop.commuteInverses commute ) - , ("nontrivial inverses" , nontrivialCommute, Prop.commuteInverses commute ) - , ("inverse composition" , const True , Prop.inverseComposition ) + [ ("recommute" , const True , PropG.recommute commute ) + , ("nontrivial recommute" , nontrivialCommute, PropG.recommute commute ) + , ("inverses commute" , const True , PropG.commuteInverses commute ) + , ("nontrivial inverses" , nontrivialCommute, PropG.commuteInverses commute ) + , ("inverse composition" , const True , PropG.inverseComposition ) ] -coalesce_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, PrimPatch p, ArbitraryPrim p) +coalesce_properties :: forall p gen x y + . ( Show1 gen, Arbitrary (Sealed gen), Patchy p, PrimPatch p + , ArbitraryPrim p, MightBeEmptyHunk p + ) => p x y -> PropList (p :> p :> p) gen coalesce_properties p genname gen = properties gen "commute" genname - (if runCoalesceTests p then [ ("coalesce commutes with commute", const True, Prop.coalesceCommute coalesce) ] else []) + (if runCoalesceTests p then [ ("coalesce commutes with commute", const True, PropG.coalesceCommute coalesce) ] else []) -- The following properties do not hold for "Real" patches (conflictors and -- duplicates, specifically) . @@ -271,15 +279,15 @@ => p x y -> PropList (p :> p) gen nonreal_commute_properties _ genname gen = properties gen "commute" genname - [ ("patch & inverse commute", const True , Prop.patchAndInverseCommute commute) - , ("patch & inverse commute", nontrivialCommute, Prop.patchAndInverseCommute commute) + [ ("patch & inverse commute", const True , PropG.patchAndInverseCommute commute) + , ("patch & inverse commute", nontrivialCommute, PropG.patchAndInverseCommute commute) ] patch_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, MyEq p) => p x y -> PropList p gen patch_properties _ genname gen = properties gen "patch" genname - [ ("inverse . inverse is id" , const True , Prop.invertSymmetry) + [ ("inverse . inverse is id" , const True , PropG.invertSymmetry) ] patch_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), @@ -289,60 +297,61 @@ => p x y -> PropList (WithState (ModelOf (PrimOf p)) p) gen patch_repo_properties _ genname gen = properties gen "patch/repo" genname - [ ("invert rollback" , const True , Prop.invertRollback) + [ ("invert rollback" , const True , PropG.invertRollback) ] pair_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, + MightBeEmptyHunk p, RepoModel (ModelOf p), RepoState (ModelOf p) ~ ApplyState p) => p x y -> PropList (WithState (ModelOf p) (p :> p)) gen pair_repo_properties _ genname gen = properties gen "patch/repo" genname - [ ("commute is effect preserving" , const True , Prop.effectPreserving commute ) + [ ("commute is effect preserving" , const True , PropG.effectPreserving commute ) ] merge_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen) , Patchy p, MyEq p, Merge p, ShowPatchBasic p - , Show2 p, Check p) + , MightHaveDuplicate p, Show2 p, Check p) => p x y -> PropList (p :\/: p) gen merge_properties _ genname gen = properties gen "merge" genname - [ ("merge either way" , const True , Prop.mergeEitherWay ) - , ("merge either way valid" , const True , Prop.tMergeEitherWayValid) - , ("nontrivial merge either way", nontrivialMerge, Prop.mergeEitherWay ) - , ("merge commute" , const True , Prop.mergeCommute ) + [ ("merge either way" , const True , PropG.mergeEitherWay ) + , ("merge either way valid" , const True , Prop1.tMergeEitherWayValid) + , ("nontrivial merge either way", nontrivialMerge, PropG.mergeEitherWay ) + , ("merge commute" , const True , PropG.mergeCommute ) ] qc_V1P1 :: [Test] qc_V1P1 = [ - testProperty "show and read work right" (unseal Prop.propReadShow) + testProperty "show and read work right" (unseal Prop2.propReadShow) ] - ++ Prop.checkSubcommutes Prop.subcommutesInverse "patch and inverse both commute" - ++ Prop.checkSubcommutes Prop.subcommutesNontrivialInverse "nontrivial commutes are correct" - ++ Prop.checkSubcommutes Prop.subcommutesFailure "inverses fail" + ++ Prop2.checkSubcommutes Prop2.subcommutesInverse "patch and inverse both commute" + ++ Prop2.checkSubcommutes Prop2.subcommutesNontrivialInverse "nontrivial commutes are correct" + ++ Prop2.checkSubcommutes Prop2.subcommutesFailure "inverses fail" ++ - [ testProperty "commuting by patch and its inverse is ok" Prop.propCommuteInverse + [ testProperty "commuting by patch and its inverse is ok" Prop2.propCommuteInverse -- , testProperty "conflict resolution is valid... " Prop.propResolveConflictsValid , testProperty "a patch followed by its inverse is identity" - Prop.propPatchAndInverseIsIdentity - , testProperty "'simple smart merge'" Prop.propSimpleSmartMergeGoodEnough - , testProperty "commutes are equivalent" Prop.propCommuteEquivalency - , testProperty "merges are valid" Prop.propMergeValid - , testProperty "inverses being valid" Prop.propInverseValid - , testProperty "other inverse being valid" Prop.propOtherInverseValid + Prop2.propPatchAndInverseIsIdentity + , testProperty "'simple smart merge'" Prop2.propSimpleSmartMergeGoodEnough + , testProperty "commutes are equivalent" Prop2.propCommuteEquivalency + , testProperty "merges are valid" Prop2.propMergeValid + , testProperty "inverses being valid" Prop2.propInverseValid + , testProperty "other inverse being valid" Prop2.propOtherInverseValid -- The patch generator isn't smart enough to generate correct test cases for -- the following: (which will be obsoleted soon, anyhow) -- , testProperty "the order dependence of unravel... " Prop.propUnravelOrderIndependent -- , testProperty "the unravelling of three merges... " Prop.propUnravelThreeMerge -- , testProperty "the unravelling of a merge of a sequence... " Prop.propUnravelSeqMerge - , testProperty "the order of commutes" Prop.propCommuteEitherOrder - , testProperty "commute either way" Prop.propCommuteEitherWay - , testProperty "the double commute" Prop.propCommuteTwice + , testProperty "the order of commutes" Prop2.propCommuteEitherOrder + , testProperty "commute either way" Prop2.propCommuteEitherWay + , testProperty "the double commute" Prop2.propCommuteTwice , testProperty "merges commute and are well behaved" - Prop.propMergeIsCommutableAndCorrect - , testProperty "merges can be swapped" Prop.propMergeIsSwapable - , testProperty "again that merges can be swapped (I'm paranoid) " Prop.propMergeIsSwapable + Prop2.propMergeIsCommutableAndCorrect + , testProperty "merges can be swapped" Prop2.propMergeIsSwapable + , testProperty "again that merges can be swapped (I'm paranoid) " Prop2.propMergeIsSwapable ] -- the following properties are disabled, because they routinely lead to -- exponential cases, making the tests run for ever and ever; nevertheless, diff --git a/harness/Darcs/Test/Patch/Arbitrary/Generic.hs b/harness/Darcs/Test/Patch/Arbitrary/Generic.hs --- a/harness/Darcs/Test/Patch/Arbitrary/Generic.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/Generic.hs @@ -4,6 +4,7 @@ module Darcs.Test.Patch.Arbitrary.Generic ( Tree(..), TreeWithFlattenPos(..), G2(..), ArbitraryPrim(..), NullPatch(..), RepoModel(..) + , MightBeEmptyHunk(..), MightHaveDuplicate(..) , flattenOne, flattenTree, mapTree, sizeTree , commutePairFromTree, mergePairFromTree , commuteTripleFromTree, mergePairFromCommutePair @@ -105,6 +106,28 @@ class NullPatch p where nullPatch :: p wX wY -> EqCheck wX wY + +class MightBeEmptyHunk p where + -- |V1 Prims support the value 'Hunk n [] []' that is treated specially in the + -- commute code and ends up breaking certain tests by behaving anomalously. + -- In practice they shouldn't appear in real repositories. For later, + -- as yet unreleased patch types, we should eliminate them completely. + -- An alternative to using this as a guard might be to avoid generating them. + isEmptyHunk :: p wX wY -> Bool + isEmptyHunk _ = False + +instance MightBeEmptyHunk (FL p) + +class MightHaveDuplicate p where + -- |"duplicates" in V2 patches (RealPatch) have lots of bugs + -- that break various commute/merge properties. + hasDuplicate :: p wX wY -> Bool + hasDuplicate _ = False + +instance MightHaveDuplicate p => MightHaveDuplicate (FL p) where + hasDuplicate NilFL = False + hasDuplicate (p :>: ps) = hasDuplicate p || hasDuplicate ps + class ( ArbitraryState (ModelOf prim) prim , NullPatch prim diff --git a/harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs b/harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs --- a/harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/PatchV1.hs @@ -46,6 +46,7 @@ -- probably means we want to move this elsewhere, but Darcs.Test.Patch.Check is -- already taken with something apparently only semi-related import Darcs.Test.Patch.Properties.Check( checkAPatch ) +import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate ) #include "impossible.h" @@ -109,6 +110,8 @@ instance ArbitraryP Prim where arbitraryP = onepatchgen + +instance MightHaveDuplicate (V1.Patch prim) hunkgen :: Gen (Sealed (Prim wX)) hunkgen = do diff --git a/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs b/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs --- a/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs @@ -77,6 +77,12 @@ nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe? nullPatch _ = NotEq +instance MightBeEmptyHunk Prim where + isEmptyHunk (FP _ (Hunk _ [] [])) = True + isEmptyHunk _ = False + +instance MightHaveDuplicate Prim + instance Arbitrary (Sealed2 (FL (WithState V1Model Prim))) where arbitrary = do repo <- ourSmallRepo liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo diff --git a/harness/Darcs/Test/Patch/Arbitrary/Real.hs b/harness/Darcs/Test/Patch/Arbitrary/Real.hs --- a/harness/Darcs/Test/Patch/Arbitrary/Real.hs +++ b/harness/Darcs/Test/Patch/Arbitrary/Real.hs @@ -36,6 +36,9 @@ y' :/\: x' -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x) +instance MightHaveDuplicate (RealPatch prim) where + hasDuplicate = isDuplicate + instance (RepoModel (ModelOf prim), ArbitraryPrim prim) => Arbitrary (Sealed2 (FL (RealPatch prim))) where arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim))) diff --git a/harness/Darcs/Test/Patch/Properties/Generic.hs b/harness/Darcs/Test/Patch/Properties/Generic.hs --- a/harness/Darcs/Test/Patch/Properties/Generic.hs +++ b/harness/Darcs/Test/Patch/Properties/Generic.hs @@ -34,7 +34,7 @@ import Darcs.Test.Patch.RepoModel ( RepoModel, RepoState, repoApply, eqModel, showModel , maybeFail ) import Darcs.Test.Patch.WithState ( WithState(..), WithStartState(..) ) -import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenOne ) +import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenOne, MightBeEmptyHunk(..), MightHaveDuplicate(..) ) import Control.Monad ( msum ) import Darcs.Patch.Witnesses.Show ( Show2(..), show2 ) @@ -89,12 +89,19 @@ $$ redText "with (invert x) on top:" $$ showPatch (invert x) -- | recommute AB ↔ B′A′ if and only if B′A′ ↔ AB -recommute :: (Patchy p, ShowPatchBasic p, MyEq p) => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY))) +recommute :: (Patchy p, ShowPatchBasic p, MyEq p, MightHaveDuplicate p) + => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY))) -> (p :> p) wA wB -> TestResult recommute c (x :> y) = case c (x :> y) of Nothing -> rejected - Just (y' :> x') -> + Just (y' :> x') + -- this test unfortunately fails on some V2 patches that contain duplicates + -- after the commute. While in theory the underlying bug should be fixed, + -- we don't know how to and even if we did, it would probably involve a repository + -- migration to a new patch type. + | hasDuplicate y' || hasDuplicate x' -> rejected + | otherwise -> case c (y' :> x') of Nothing -> failed (redText "failed" $$ showPatch y' $$ redText ":>" $$ showPatch x') Just (x'' :> y'') -> @@ -136,9 +143,10 @@ IsEq -> succeeded -- | effect preserving AB <--> B'A' then effect(AB) = effect(B'A') -effectPreserving :: (Patchy p, RepoModel model, ApplyState p ~ RepoState model) => +effectPreserving :: (Patchy p, MightBeEmptyHunk p, RepoModel model, ApplyState p ~ RepoState model) => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY)) -> WithState model (p :> p) wA wB -> TestResult +effectPreserving _ (WithState _ (x :> _) _) | isEmptyHunk x = rejected effectPreserving c (WithState r (x :> y) r') = case c (x :> y) of Nothing -> rejected @@ -282,10 +290,17 @@ IsEq <- y'' =\/= y' -> succeeded | otherwise -> failed $ redText "mergeEitherWay bug" -mergeCommute :: (Patchy p, MyEq p, ShowPatchBasic p, Merge p) => (p :\/: p) wX wY -> TestResult +mergeCommute :: (Patchy p, MyEq p, ShowPatchBasic p, Merge p, MightHaveDuplicate p) + => (p :\/: p) wX wY -> TestResult mergeCommute (x :\/: y) = case merge (x :\/: y) of - y' :/\: x' -> + y' :/\: x' + -- this test unfortunately fails on some V2 patches that contain duplicates + -- after the merge. While in theory the underlying bug should be fixed, + -- we don't know how to and even if we did, it would probably involve a repository + -- migration to a new patch type. + | hasDuplicate x' || hasDuplicate y' -> rejected + | otherwise -> case commute (x :> y') of Nothing -> failed $ redText "mergeCommute 1" $$ redText "x" $$ showPatch x $$ @@ -335,8 +350,10 @@ else failed $ redText "r_x /= r'" coalesceCommute - :: (PrimPatch prim) => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY)) + :: (PrimPatch prim, MightBeEmptyHunk prim) + => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY)) -> (prim :> prim :> prim) wA wB -> TestResult +coalesceCommute _ (a :> _ :> _) | isEmptyHunk a = rejected coalesceCommute j (a :> b :> c) = case j (b :> c) of Nothing -> rejected diff --git a/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs b/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs --- a/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs +++ b/harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs @@ -6,7 +6,7 @@ , mergeCommute, patchAndInverseCommute, coalesceCommute, commuteInverses , recommute , show_read ) -import Darcs.Test.Patch.Arbitrary.Generic ( Tree ) +import Darcs.Test.Patch.Arbitrary.Generic ( Tree, MightBeEmptyHunk, MightHaveDuplicate ) import Darcs.Test.Patch.RepoModel( RepoModel, RepoState ) import Darcs.Test.Patch.WithState( WithStartState ) @@ -45,12 +45,13 @@ -> (p :> p) wA wB -> TestResult commuteInverses f = W.commuteInverses (fmap toW . f . fromW) . toW -recommute :: (Patchy wp, ShowPatchBasic wp, MyEq wp, WSub wp p) +recommute :: (Patchy wp, ShowPatchBasic wp, MightHaveDuplicate wp, MyEq wp, WSub wp p) => (forall wX wY . ((p :> p) wX wY -> Maybe ((p :> p) wX wY))) -> (p :> p) wA wB -> TestResult recommute f = W.recommute (fmap toW . f . fromW) . toW -mergeCommute :: (Patchy wp, ShowPatchBasic wp, MyEq wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult +mergeCommute :: (Patchy wp, MightHaveDuplicate wp, ShowPatchBasic wp, MyEq wp, Merge wp, WSub wp p) + => (p :\/: p) wX wY -> TestResult mergeCommute = W.mergeCommute . toW mergeConsistent :: (Patchy wp, Merge wp, ShowPatchBasic wp, WSub wp p) => @@ -72,8 +73,9 @@ patchAndInverseCommute f = W.patchAndInverseCommute (fmap toW . f . fromW) . toW -coalesceCommute :: (forall wX wY . (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY)) - -> (Prim :> Prim :> Prim) wA wB -> TestResult +coalesceCommute :: MightBeEmptyHunk Prim + => (forall wX wY . (Prim :> Prim) wX wY -> Maybe (FL Prim wX wY)) + -> (Prim :> Prim :> Prim) wA wB -> TestResult coalesceCommute f = W.coalesceCommute (fmap toW . f . fromW) . toW consistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model) diff --git a/harness/test.hs b/harness/test.hs --- a/harness/test.hs +++ b/harness/test.hs @@ -29,7 +29,8 @@ import System.FilePath( takeDirectory, takeBaseName, isAbsolute ) import System.IO( hSetBinaryMode, hSetBuffering, BufferMode( NoBuffering ), stdin, stdout, stderr, localeEncoding ) import Test.Framework.Providers.API -import Test.Framework + ( TestResultlike(..), Testlike(..), Test, runImprovingIO, yieldImprovement, Test(..), liftIO ) +import Test.Framework ( defaultMainWithArgs ) import Shelly hiding ( liftIO, run, FilePath, path ) import qualified Shelly @@ -207,32 +208,42 @@ , shell :: Bool , network :: Bool , unit :: Bool - , diffAlgorithm :: [DiffAlgorithm] - , repoFormat :: [Format] + , myers :: Bool + , patience :: Bool + , darcs1 :: Bool + , darcs2 :: Bool , darcs :: String , tests :: [String] , testDir :: Maybe FilePath , plain :: Bool , hideSuccesses :: Bool - , threads :: Int } + , threads :: Int + , qcCount :: Int + } deriving (Data, Typeable, Eq) defaultConfig :: Annotate Ann defaultConfig = record Config{} - [ failing := False += help "Run the failing (shell) tests." - , shell := True += help "Run the passing, non-network shell tests." - , network := False += help "Run the network shell tests." - , unit := True += help "Run the unit tests." - , diffAlgorithm := [PatienceDiff] += help "Diff algorithm(s) to test (myers, patience)." - , repoFormat := [Darcs2] += help "Repo formats to test (darcs-1, darcs-2)." - , darcs := "" += help "Darcs binary path." += typ "PATH" - , tests := [] += name "t" += help "Pattern to limit the tests to run." += typ "PATTERN" - , testDir := Nothing += help "Directory to run tests in" += typ "PATH" - , plain := False += help "Use plain-text output." - , hideSuccesses := False += help "Hide successes." - , threads := 1 += name "j" ] + [ failing := False += help "Run the failing (shell) tests [no]" + , shell := True += help "Run the passing, non-network shell tests [yes]" + , network := False += help "Run the network shell tests [no]" + , unit := True += help "Run the unit tests [yes]" + , myers := False += help "Use myers diff [no]" + , patience := True += help "Use patience diff [yes]" += name "p" + , darcs1 := False += help "Use darcs-1 repo format [no]" += name "1" + , darcs2 := True += help "Use darcs-2 repo format [yes]" += name "2" + , darcs := "" += help "Darcs binary path" += typ "PATH" + , tests := [] += help "Pattern to limit the tests to run" += typ "PATTERN" += name "t" + , testDir := Nothing += help "Directory to run tests in" += typ "PATH" += name "d" + , plain := False += help "Use plain-text output [no]" + , hideSuccesses := False += help "Hide successes [no]" + , threads := 1 += help "Number of threads [1]" += name "j" + , qcCount := 100 += help "Number of QuickCheck iterations per test [100]" += name "q" + ] + += summary "Darcs test harness" + += program "darcs-test" run :: Config -> IO () run conf = do @@ -240,7 +251,10 @@ ++ concat [ ["-t", x ] | x <- tests conf ] ++ [ "--plain" | True <- [plain conf] ] ++ [ "--hide-successes" | True <- [hideSuccesses conf] ] - ++ [ "--maximum-unsuitable-generated-tests", "700" ] + -- this multiplier is calibrated against the observed behaviour of the test harness - + -- increase it if we see lots of "arguments exhausted" errors or similar + ++ [ "--maximum-unsuitable-generated-tests", show (7 * qcCount conf) ] + ++ [ "--maximum-generated-tests", show (qcCount conf) ] case testDir conf of Nothing -> return () Just d -> do e <- shelly (test_e (fromText $ pack d)) @@ -273,10 +287,17 @@ putStrLn $ "Locale encoding is " ++ textEncodingName localeEncoding - ftests <- shelly $ if failing conf then findShell darcsBin (testDir conf) True (diffAlgorithm conf) (repoFormat conf) else return [] - stests <- shelly $ if shell conf then findShell darcsBin (testDir conf) False (diffAlgorithm conf) (repoFormat conf) else return [] + let repoFormat = (if darcs1 conf then (Darcs1:) else id) + . (if darcs2 conf then (Darcs2:) else id) + $ [] + let diffAlgorithm = (if myers conf then (MyersDiff:) else id) + . (if patience conf then (PatienceDiff:) else id) + $ [] + + ftests <- shelly $ if failing conf then findShell darcsBin (testDir conf) True diffAlgorithm repoFormat else return [] + stests <- shelly $ if shell conf then findShell darcsBin (testDir conf) False diffAlgorithm repoFormat else return [] utests <- if unit conf then doUnit else return [] - ntests <- shelly $ if network conf then findNetwork darcsBin (testDir conf) (diffAlgorithm conf) (repoFormat conf) else return [] + ntests <- shelly $ if network conf then findNetwork darcsBin (testDir conf) diffAlgorithm repoFormat else return [] defaultMainWithArgs (ftests ++ stests ++ utests ++ ntests) args where exeSuffix :: String diff --git a/hashed-storage/Storage/Hashed/Hash.hs b/hashed-storage/Storage/Hashed/Hash.hs --- a/hashed-storage/Storage/Hashed/Hash.hs +++ b/hashed-storage/Storage/Hashed/Hash.hs @@ -5,8 +5,8 @@ import qualified Crypto.Hash.SHA256 as SHA256 ( hash ) import qualified Data.ByteString as BS -import qualified Data.ByteString.Internal as BSI import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BS8 import qualified Codec.Binary.Base64Url as B64U import qualified Codec.Binary.Base16 as B16 @@ -27,14 +27,14 @@ base64u :: BS.ByteString -> BS.ByteString debase64u :: BS.ByteString -> Maybe BS.ByteString -base16 = BS.pack . map (BSI.c2w . toLower) . B16.encode . BS.unpack -base64u = BS.pack . map BSI.c2w . B64U.encode . BS.unpack -debase64u bs = case B64U.decode $ map BSI.w2c $ BS.unpack bs of - Just s -> Just $ BS.pack s - Nothing -> Nothing -debase16 bs = case B16.decode $ map (toUpper . BSI.w2c) $ BS.unpack bs of - Just s -> Just $ BS.pack s - Nothing -> Nothing +base16 = BS8.map toLower . B16.b16_enc +base64u = B64U.encode +debase64u bs = case B64U.decode bs of + Right s -> Just s + Left _ -> Nothing +debase16 bs = case B16.b16_dec $ BS8.map toUpper bs of + Right (s, _) -> Just s + Left _ -> Nothing encodeBase64u :: Hash -> BS.ByteString encodeBase64u (SHA256 bs) = base64u bs diff --git a/hashed-storage/Storage/Hashed/Index.hs b/hashed-storage/Storage/Hashed/Index.hs --- a/hashed-storage/Storage/Hashed/Index.hs +++ b/hashed-storage/Storage/Hashed/Index.hs @@ -166,11 +166,11 @@ itemIsDir i = unsafeHead (iDescriptor i) == c2w 'D' -- xlatePeek32 = fmap xlate32 . peek -xlatePeek64 :: (Storable a, Bits a) => Ptr a -> IO a +xlatePeek64 :: (Storable a, Num a, Bits a) => Ptr a -> IO a xlatePeek64 = fmap xlate64 . peek -- xlatePoke32 ptr v = poke ptr (xlate32 v) -xlatePoke64 :: (Storable a, Bits a) => Ptr a -> a -> IO () +xlatePoke64 :: (Storable a, Num a, Bits a) => Ptr a -> a -> IO () xlatePoke64 ptr v = poke ptr (xlate64 v) -- | Lay out the basic index item structure in memory. The memory location is diff --git a/hashed-storage/Storage/Hashed/Utils.hs b/hashed-storage/Storage/Hashed/Utils.hs --- a/hashed-storage/Storage/Hashed/Utils.hs +++ b/hashed-storage/Storage/Hashed/Utils.hs @@ -91,8 +91,8 @@ x -> i + boundary - x {-# INLINE align #-} -xlate32 :: (Bits a) => a -> a -xlate64 :: (Bits a) => a -> a +xlate32 :: (Num a, Bits a) => a -> a +xlate64 :: (Num a, Bits a) => a -> a #ifdef LITTLEENDIAN xlate32 = id @@ -100,7 +100,7 @@ #endif #ifdef BIGENDIAN -bytemask :: (Bits a) => a +bytemask :: (Num a, Bits a) => a bytemask = 255 xlate32 a = ((a .&. (bytemask `shift` 0)) `shiftL` 24) .|. diff --git a/release/distributed-context b/release/distributed-context --- a/release/distributed-context +++ b/release/distributed-context @@ -1,1 +1,1 @@ -Just "\nContext:\n\n[TAG 2.10.1\nGuillaume Hoffmann **20150709164849\n Ignore-this: 91f5dd97c5899801364cdfc0a8266faa\n] \n" +Just "\nContext:\n\n[TAG 2.10.2\nGuillaume Hoffmann **20151109135257\n Ignore-this: b5175dd8e51689988632b312af9611da\n] \n" diff --git a/src/Darcs/Patch/Match.hs b/src/Darcs/Patch/Match.hs --- a/src/Darcs/Patch/Match.hs +++ b/src/Darcs/Patch/Match.hs @@ -119,8 +119,7 @@ import Darcs.Patch.Matchable ( Matchable ) import Darcs.Patch.MaybeInternal ( MaybeInternal, patchInternalChecker, isInternal, flIsInternal ) import Darcs.Patch.MonadProgress ( MonadProgress ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, piap, - conscientiously, hopefully, n2pia ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, conscientiously, hopefully ) import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL, Origin ) import Darcs.Patch.Type ( PatchType(..) ) import Darcs.Patch.Apply( ApplyState ) @@ -538,11 +537,11 @@ -- | @matchAPatch fs p@ tells whether @p@ matches the matchers in -- the flags @fs@ -matchAPatch :: Matchable p => [MatchFlag] -> Named p wX wY -> Bool +matchAPatch :: Matchable p => [MatchFlag] -> PatchInfoAnd p wX wY -> Bool matchAPatch fs p = case nonrangeMatcher fs of Nothing -> True - Just m -> applyMatcher m (patch2patchinfo p `piap` p) + Just m -> applyMatcher m p matchPatch :: Matchable p => [MatchFlag] -> PatchSet p wStart wX -> Sealed2 (Named p) matchPatch fs ps = @@ -619,7 +618,7 @@ -- the earliest patch in a sequence, as opposed to 'matchSecondPatchset' which picks up the -- first match starting from the latest patch splitSecondFL :: Matchable p - => (forall wA wB . q wA wB -> Sealed2 (Named p)) + => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd p)) -> [MatchFlag] -> FL q wX wY -> (FL q :> FL q) wX wY -- ^The first element is the patches before and including the first patch matching the second matcher, @@ -666,10 +665,10 @@ Just (patchSet :> _) -> seal patchSet | otherwise = getMatchingTag m (PatchSet ps ts) -splitMatchFL :: Matchable p => (forall wA wB . q wA wB -> Sealed2 (Named p)) -> Matcher p -> FL q wX wY -> (FL q :> FL q) wX wY +splitMatchFL :: Matchable p => (forall wA wB . q wA wB -> Sealed2 (PatchInfoAnd p)) -> Matcher p -> FL q wX wY -> (FL q :> FL q) wX wY splitMatchFL _extract m NilFL = error $ "Couldn't find patch matching " ++ show m splitMatchFL extract m (p :>: ps) - | unseal2 (applyMatcher m . n2pia) . extract $ p = (p :>: NilFL) :> ps + | unseal2 (applyMatcher m) . extract $ p = (p :>: NilFL) :> ps | otherwise = case splitMatchFL extract m ps of before :> after -> (p :>: before) :> after diff --git a/src/Darcs/Patch/Rebase/Viewing.hs b/src/Darcs/Patch/Rebase/Viewing.hs --- a/src/Darcs/Patch/Rebase/Viewing.hs +++ b/src/Darcs/Patch/Rebase/Viewing.hs @@ -6,7 +6,7 @@ ( RebaseSelect(..) , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect , partitionUnconflicted - , rsToNamed + , rsToPia , WithDroppedDeps(..), WDDNamed, commuterIdWDD , RebaseChange(..), toRebaseChanges ) where @@ -129,10 +129,10 @@ showString "RCRev " . showsPrec2 (appPrec + 1) fixups . showString " " . showsPrec2 (appPrec + 1) changes --- |Get hold of the 'Named' patch inside a 'RebaseSelect'. -rsToNamed :: RebaseSelect p wX wY -> Sealed2 (Named p) -rsToNamed (RSFwd _ toEdit) = Sealed2 toEdit -rsToNamed (RSRev _ toEdit) = Sealed2 toEdit +-- |Get hold of the 'PatchInfoAnd' patch inside a 'RebaseSelect'. +rsToPia :: RebaseSelect p wX wY -> Sealed2 (PatchInfoAnd p) +rsToPia (RSFwd _ toEdit) = Sealed2 (n2pia toEdit) +rsToPia (RSRev _ toEdit) = Sealed2 (n2pia toEdit) instance PrimPatchBase p => PrimPatchBase (RebaseSelect p) where type PrimOf (RebaseSelect p) = PrimOf p diff --git a/src/Darcs/Repository.hs b/src/Darcs/Repository.hs --- a/src/Darcs/Repository.hs +++ b/src/Darcs/Repository.hs @@ -575,7 +575,7 @@ allowCtrlC cloneKind cleanup $ do cleanDir "patches" putVerbose verb $ text "Using patches pack." - unpackPatches toCache3 (mapFL hashedPatchFileName $ newset2FL us) . + unpackPatches toCache3 (mapRL hashedPatchFileName $ newset2RL us) . Tar.read . decompress =<< fetchFileLazyPS (fromDir ++ packsDir ++ "patches.tar.gz") Uncachable pi <- doesPatchIndexExist toDir when pi $ createPIWithInterrupt toRepo diff --git a/src/Darcs/UI/ApplyPatches.hs b/src/Darcs/UI/ApplyPatches.hs --- a/src/Darcs/UI/ApplyPatches.hs +++ b/src/Darcs/UI/ApplyPatches.hs @@ -95,7 +95,7 @@ (hasSummary O.NoSummary opts) (dryRun opts) (hasXmlOutput opts) - (isInteractive opts) + (isInteractive True opts) to_be_applied when (nullFL to_be_applied && reorder opts == O.NoReorder) $ do putStrLn $ "You don't want to " ++ cmdName ++ " any patches, so I'm exiting!" @@ -117,7 +117,7 @@ (verbosity opts) (testChanges opts) (setScriptsExecutable opts) - (isInteractive opts) + (isInteractive True opts) "those patches do not pass the tests." (cmdName ++ " them") Nothing withSignalsBlocked $ do finalizeRepositoryChanges repository YesUpdateWorking (compression opts) _ <- applyToWorking repository (verbosity opts) pw `catch` \(e :: SomeException) -> diff --git a/src/Darcs/UI/Commands/Apply.hs b/src/Darcs/UI/Commands/Apply.hs --- a/src/Darcs/UI/Commands/Apply.hs +++ b/src/Darcs/UI/Commands/Apply.hs @@ -98,7 +98,7 @@ [ "The `darcs apply` command takes a patch bundle and attempts to insert" , "it into the current repository. In addition to invoking it directly" , "on bundles created by `darcs send`, it is used internally by `darcs" - , "push` and `darcs put` on the remote end of an SSH connection." + , "push` on the remote end of an SSH connection." , "" , "If no file is supplied, the bundle is read from standard input." , "" diff --git a/src/Darcs/UI/Commands/Clone.hs b/src/Darcs/UI/Commands/Clone.hs --- a/src/Darcs/UI/Commands/Clone.hs +++ b/src/Darcs/UI/Commands/Clone.hs @@ -291,7 +291,7 @@ , "--tag .` would make a copy of the repository as at the latest release." , "" , "An untagged repository state can still be identified unambiguously by" - , "a context file, as generated by `darcs changes --context`. Given the" + , "a context file, as generated by `darcs log --context`. Given the" , "name of such a file, the `--context` option will create a repository" , "that includes only the patches from that context. When a user reports" , "a bug in an unreleased version of your project, the recommended way to" diff --git a/src/Darcs/UI/Commands/GZCRCs.hs b/src/Darcs/UI/Commands/GZCRCs.hs --- a/src/Darcs/UI/Commands/GZCRCs.hs +++ b/src/Darcs/UI/Commands/GZCRCs.hs @@ -70,7 +70,7 @@ ++ "optionally repairs it." , "By default it also does this for any caches you have configured and " ++ "any other local repositories listed as sources of patches for this " - ++ "one, perhaps because of a lazy get. You can limit the scope to just " + ++ "one, perhaps because of a lazy clone. You can limit the scope to just " ++ "the current repo with the --just-this-repo flag." , "Note that readonly caches, or other repositories listed as sources, " ++ "will be checked but not repaired. Also, this command will abort if " diff --git a/src/Darcs/UI/Commands/Help.hs b/src/Darcs/UI/Commands/Help.hs --- a/src/Darcs/UI/Commands/Help.hs +++ b/src/Darcs/UI/Commands/Help.hs @@ -274,7 +274,7 @@ -- ".SH EXAMPLE", -- FIXME: -- new project: init, rec -la; - -- track upstream project: get, pull -a; + -- track upstream project: clone, pull -a; -- contribute to project: add, rec, push/send. ".SH SEE ALSO", "The Darcs website provides a lot of additional information.", diff --git a/src/Darcs/UI/Commands/Log.hs b/src/Darcs/UI/Commands/Log.hs --- a/src/Darcs/UI/Commands/Log.hs +++ b/src/Darcs/UI/Commands/Log.hs @@ -241,7 +241,7 @@ else do let header = if isJust files && XMLOutput `notElem` opts then text $ "Changes to "++unwords (fromJust recFiles)++":\n" else empty - debugMessage "About to print the changes..." + debugMessage "About to print the patches..." let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters ps <- readRepo repository -- read repo again to prevent holding onto -- values forced by filtered_changes @@ -257,10 +257,10 @@ logHelp' = "When given one or more files or directories as arguments, only\n" ++ "patches which affect those files or directories are listed. This\n" ++ - "includes changes that happened to files before they were moved or\n" ++ + "includes patches that happened to files before they were moved or\n" ++ "renamed.\n" ++ "\n" ++ - "When given a `--from-tag`, `--from-patch` or `--from-match`, only changes\n" ++ + "When given a `--from-tag`, `--from-patch` or `--from-match`, only patches\n" ++ "since that tag or patch are listed. Similarly, the `--to-tag`,\n" ++ "`--to-patch` and `--to-match` options restrict the list to older patches.\n" ++ "\n" ++ @@ -348,7 +348,7 @@ then returnFinal else case hopefullyM hp of Nothing -> do - let err = text "Can't find changes prior to:" + let err = text "Can't find patches prior to:" $$ showPatchInfo (info hp) return ([], renames, Just err) Just p -> @@ -441,7 +441,7 @@ logHelp'' = "Three output formats exist. The default is `--human-readable`. You can\n" ++ "also select `--context`, which is the internal format (as seen in patch\n" ++ - "bundles) that can be re-read by Darcs (e.g. `darcs get --context`).\n" ++ + "bundles) that can be re-read by Darcs (e.g. `darcs clone --context`).\n" ++ "\n" ++ "Finally, there is `--xml-output`, which emits valid XML... unless a the\n" ++ "patch metadata (author, name or description) contains a non-ASCII\n" ++ @@ -449,7 +449,7 @@ "\n" ++ -- FIXME: can't we just disallow the following usage? "Note that while the `--context` flag may be used in conjunction with\n" ++ - "`--xml-output` or `--human-readable`, in neither case will darcs get be\n" ++ + "`--xml-output` or `--human-readable`, in neither case will darcs clone be\n" ++ "able to read the output. On the other hand, sufficient information\n" ++ "WILL be output for a knowledgeable human to recreate the current state\n" ++ "of the repository.\n" @@ -486,7 +486,7 @@ { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrRange flags , S.diffAlgorithm = diffAlgorithm flags - , S.interactive = isInteractive flags + , S.interactive = isInteractive False flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = hasSummary O.NoSummary flags , S.withContext = isUnified flags diff --git a/src/Darcs/UI/Commands/Optimize.hs b/src/Darcs/UI/Commands/Optimize.hs --- a/src/Darcs/UI/Commands/Optimize.hs +++ b/src/Darcs/UI/Commands/Optimize.hs @@ -63,8 +63,7 @@ import Darcs.Repository.InternalTypes ( Repository(..) ) import Darcs.Repository.Util ( getRecursiveDarcsRepos ) import Darcs.Patch.Witnesses.Ordered - ( mapRL - , mapFL + ( mapFL , bunchFL , lengthRL ) @@ -427,7 +426,7 @@ "`--sibling` option (which can be used multiple times).\n" ++ "\n" ++ "Darcs uses hard-links automatically, so this command is rarely needed.\n" ++ - "It is most useful if you used `cp -r` instead of `darcs get` to copy a\n" ++ + "It is most useful if you used `cp -r` instead of `darcs clone` to copy a\n" ++ "repository, or if you pulled the same patch from a remote repository\n" ++ "into multiple local repositories." @@ -532,7 +531,7 @@ Just hash <- readHashedPristineRoot repo writeFile ( packsDir "pristine" ) hash -- pack patchesTar - ps <- mapRL hashedPatchFileName . newset2RL <$> readRepo repo + ps <- mapFL hashedPatchFileName . newset2FL <$> readRepo repo is <- map ((darcsdir "inventories") ) <$> HashedRepo.listInventories writeFile (darcsdir "meta-filelist-inventories") . unlines $ map takeFileName is diff --git a/src/Darcs/UI/Commands/Pull.hs b/src/Darcs/UI/Commands/Pull.hs --- a/src/Darcs/UI/Commands/Pull.hs +++ b/src/Darcs/UI/Commands/Pull.hs @@ -122,7 +122,7 @@ pullHelp :: String pullHelp = unlines - [ "Pull is used to bring changes made in another repository into the current" + [ "Pull is used to bring patches made in another repository into the current" , "repository (that is, either the one in the current directory, or the one" , "specified with the `--repodir` option). Pull allows you to bring over all or" , "some of the patches that are in that repository but not in this one. Pull" @@ -145,7 +145,7 @@ fetchHelp :: String fetchHelp = unlines - [ "Fetch is similar to `pull` except that it does not apply any changes" + [ "Fetch is similar to `pull` except that it does not apply any patches" , "to the current repository. Instead, it generates a patch bundle that" , "you can apply later with `apply`." , "" @@ -410,7 +410,7 @@ then filterOutConflicts (reverseFL us') repository ps else return (False, Sealed ps) when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts." - when (nullFL psFiltered) $ do putInfo opts $ text "No remote changes to pull in!" + when (nullFL psFiltered) $ do putInfo opts $ text "No remote patches to pull in!" setEnvDarcsPatches psFiltered when (reorder opts /= O.Reorder) exitSuccess let direction = if doReverse opts then FirstReversed else First @@ -482,7 +482,7 @@ { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags , S.diffAlgorithm = diffAlgorithm flags - , S.interactive = isInteractive flags + , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = isUnified flags diff --git a/src/Darcs/UI/Commands/Push.hs b/src/Darcs/UI/Commands/Push.hs --- a/src/Darcs/UI/Commands/Push.hs +++ b/src/Darcs/UI/Commands/Push.hs @@ -84,11 +84,11 @@ pushHelp :: String pushHelp = unlines - [ "Push is the opposite of pull. Push allows you to copy changes from the" + [ "Push is the opposite of pull. Push allows you to copy patches from the" , "current repository into another repository." , "" , "If you give the `--apply-as` flag, darcs will use sudo to apply the" - , "changes as a different user. This can be useful if you want to set up a" + , "patches as a different user. This can be useful if you want to set up a" , "system where several users can modify the same repository, but you don't" , "want to allow them full write access. This isn't secure against skilled" , "malicious attackers, but at least can protect your repository from clumsy," @@ -234,7 +234,7 @@ else empty putVerbose opts $ text "We have the following patches to push:" $$ vcat (mapRL description us') unless (nullRL us') $ putInfo opts pull_reminder - when (nullRL us') $ do putInfo opts $ text "No recorded local changes to push!" + when (nullRL us') $ do putInfo opts $ text "No recorded local patches to push!" exitSuccess bundlePatches :: forall t p wZ wW wA. (RepoPatch p, ApplyState p ~ Tree) @@ -249,7 +249,7 @@ (hasSummary O.NoSummary opts) (dryRun opts) (hasXmlOutput opts) - (isInteractive opts) + (isInteractive True opts) to_be_pushed when (nullFL to_be_pushed) $ do putInfo opts $ @@ -279,7 +279,7 @@ { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags , S.diffAlgorithm = diffAlgorithm flags - , S.interactive = isInteractive flags + , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = isUnified flags diff --git a/src/Darcs/UI/Commands/Rebase.hs b/src/Darcs/UI/Commands/Rebase.hs --- a/src/Darcs/UI/Commands/Rebase.hs +++ b/src/Darcs/UI/Commands/Rebase.hs @@ -83,7 +83,7 @@ import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), flToNamesPrims ) import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed ) import Darcs.Patch.Rebase.Viewing - ( RebaseSelect(RSFwd), rsToNamed + ( RebaseSelect(RSFwd), rsToPia , toRebaseSelect, fromRebaseSelect, extractRebaseSelect, reifyRebaseSelect , partitionUnconflicted , WithDroppedDeps(..), WDDNamed, commuterIdWDD @@ -231,7 +231,7 @@ then getLastPatches (parseFlags O.matchSeveralOrLast opts) allpatches_tail else matchingHead (parseFlags O.matchSeveralOrLast opts) allpatches_tail let direction = if doReverse opts then Last else LastReversed - patches_context = selectionContext direction "suspend" (patchSelOpts opts) Nothing Nothing + patches_context = selectionContext direction "suspend" (patchSelOpts True opts) Nothing Nothing (_ :> psToSuspend) <- runSelection (selectChanges patches) @@ -416,7 +416,7 @@ inRange :> outOfRange <- return $ if secondMatch matchFlags then - splitSecondFL rsToNamed matchFlags selects + splitSecondFL rsToPia matchFlags selects else selects :> NilFL offer :> dontoffer <- @@ -431,7 +431,7 @@ warnSkip dontoffer - let patches_context = selectionContextGeneric rsToNamed First "unsuspend" (patchSelOpts opts) Nothing + let patches_context = selectionContextGeneric rsToPia First "unsuspend" (patchSelOpts True opts) Nothing (chosen :> keep) <- runSelection (selectChanges offer) patches_context when (nullFL chosen) $ do putStrLn "No patches selected!" exitSuccess @@ -501,7 +501,7 @@ -- TODO should catch logfiles (fst value from updatePatchHeader) and clean them up as in AmendRecord p' <- snd <$> updatePatchHeader False -- askDeps - (patchSelOpts opts) + (patchSelOpts True opts) (parseFlags O.keepDate opts) (parseFlags O.selectAuthor opts) (parseFlags O.author opts) @@ -573,7 +573,7 @@ -- TODO this selection doesn't need to respect dependencies -- TODO we only want to select one patch: generalise withSelectedPatchFromRepo - let patches_context = selectionContextGeneric rsToNamed First "inject into" (patchSelOpts opts) Nothing + let patches_context = selectionContextGeneric rsToPia First "inject into" (patchSelOpts True opts) Nothing (chosens :> rest_selects) <- runSelection (selectChanges selects) patches_context let extractSingle :: FL (RebaseSelect p) wX wY -> (FL (RebaseFixup p) :> Named p) wX wY @@ -585,7 +585,7 @@ name_fixups :> prim_fixups <- return $ flToNamesPrims fixups - let changes_context = selectionContextPrim Last "inject" (patchSelOpts opts) (Just primSplitter) Nothing Nothing + let changes_context = selectionContextPrim Last "inject" (patchSelOpts True opts) (Just primSplitter) Nothing Nothing (rest_fixups :> injects) <- runSelection (selectChanges prim_fixups) changes_context when (nullFL injects) $ do @@ -653,7 +653,7 @@ let selects = toRebaseSelect ps -- TODO this selection doesn't need to respect dependencies - let patches_context = selectionContextGeneric rsToNamed First "obliterate" (obliteratePatchSelOpts opts) Nothing + let patches_context = selectionContextGeneric rsToPia First "obliterate" (obliteratePatchSelOpts opts) Nothing (chosen :> keep) <- runSelection (selectChanges selects) patches_context when (nullFL chosen) $ do putStrLn "No patches selected!" exitSuccess @@ -928,7 +928,7 @@ (hasSummary O.NoSummary opts) (dryRun opts) (hasXmlOutput opts) - (isInteractive opts) + (isInteractive True opts) to_be_applied setEnvDarcsPatches to_be_applied when (nullFL to_be_applied) $ do @@ -986,16 +986,16 @@ } obliteratePatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions -obliteratePatchSelOpts opts = (patchSelOpts opts) +obliteratePatchSelOpts opts = (patchSelOpts True opts) { S.selectDeps = O.NoDeps } -patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions -patchSelOpts flags = S.PatchSelectionOptions +patchSelOpts :: Bool -> [DarcsFlag] -> S.PatchSelectionOptions +patchSelOpts defInteractive flags = S.PatchSelectionOptions { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags , S.diffAlgorithm = diffAlgorithm flags - , S.interactive = isInteractive flags + , S.interactive = isInteractive defInteractive flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = O.NoContext @@ -1055,8 +1055,8 @@ patches <- readRepo repository (_, Sealed ps, _) <- return $ takeHeadRebase patches let psToShow = toRebaseChanges ps - if isInteractive opts - then viewChanges (patchSelOpts opts) (mapFL Sealed2 psToShow) + if isInteractive False opts + then viewChanges (patchSelOpts False opts) (mapFL Sealed2 psToShow) else do debugMessage "About to print the changes..." let printers = if XMLOutput `elem` opts then simplePrinters else fancyPrinters diff --git a/src/Darcs/UI/Commands/Record.hs b/src/Darcs/UI/Commands/Record.hs --- a/src/Darcs/UI/Commands/Record.hs +++ b/src/Darcs/UI/Commands/Record.hs @@ -540,7 +540,7 @@ "\n" ++ "The `--set-scripts-executable` option causes scripts to be made\n" ++ "executable in the clean copy of the working tree, prior to running the\n" ++ - "test. See `darcs get` for an explanation of the script heuristic.\n" ++ + "test. See `darcs clone` for an explanation of the script heuristic.\n" ++ "\n" ++ "If your test command is tediously slow (e.g. `make all`) and you are\n" ++ "recording several patches in a row, you may wish to use `--no-test` to\n" ++ diff --git a/src/Darcs/UI/Commands/Revert.hs b/src/Darcs/UI/Commands/Revert.hs --- a/src/Darcs/UI/Commands/Revert.hs +++ b/src/Darcs/UI/Commands/Revert.hs @@ -110,7 +110,7 @@ { S.verbosity = verbosity flags , S.matchFlags = [] , S.diffAlgorithm = diffAlgorithm flags - , S.interactive = isInteractive flags + , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default , S.withContext = isUnified flags diff --git a/src/Darcs/UI/Commands/Rollback.hs b/src/Darcs/UI/Commands/Rollback.hs --- a/src/Darcs/UI/Commands/Rollback.hs +++ b/src/Darcs/UI/Commands/Rollback.hs @@ -117,7 +117,7 @@ { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags , S.diffAlgorithm = diffAlgorithm flags - , S.interactive = isInteractive flags + , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps , S.summary = O.NoSummary , S.withContext = O.NoContext diff --git a/src/Darcs/UI/Commands/Send.hs b/src/Darcs/UI/Commands/Send.hs --- a/src/Darcs/UI/Commands/Send.hs +++ b/src/Darcs/UI/Commands/Send.hs @@ -131,6 +131,7 @@ ( Doc, vsep, text, ($$), (<+>), (<>), putDoc, putDocLn , renderPS, RenderMode(..) ) +import Darcs.Util.English ( englishNum, Noun(..) ) import Darcs.Util.Path ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd, getCurrentDirectory, useAbsoluteOrStd, makeAbsoluteOrStd ) import Darcs.Util.Download.HTTP ( postUrl ) @@ -233,7 +234,7 @@ { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveral flags , S.diffAlgorithm = O.PatienceDiff - , S.interactive = isInteractive flags + , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = O.NoContext @@ -318,7 +319,7 @@ (hasSummary O.NoSummary opts) (dryRun opts) O.NoXml - (isInteractive opts) + (isInteractive True opts) to_be_sent when (nullFL to_be_sent) $ do putInfo opts Msg.selectionIsNull @@ -541,12 +542,13 @@ return (doc, Just updatedFile, tryGetCharset doc) Nothing -> return (patchdesc, Nothing, tryGetCharset patchdesc) - where patchdesc = text (if lengthFL patches == 1 - then "1 patch" - else show (lengthFL patches) ++ " patches") + where patchdesc = text (show len) + <+> text (englishNum len (Noun "patch") "") <+> text "for repository" <+> text their_name <> text ":" $$ text "" $$ vsep (mapFL description patches) + where + len = lengthFL patches updateFilename file = maybe (renameFile file darcsSendMessageFinal >> return darcsSendMessageFinal) (return . toFilePath) $ hasLogfile opts diff --git a/src/Darcs/UI/Commands/ShowAuthors.hs b/src/Darcs/UI/Commands/ShowAuthors.hs --- a/src/Darcs/UI/Commands/ShowAuthors.hs +++ b/src/Darcs/UI/Commands/ShowAuthors.hs @@ -82,7 +82,7 @@ "substring). Use ^,$ to match the whole string in regexps\n" ++ "\n" ++ "Currently this canonicalization step is done only in `darcs show\n" ++ - "authors`. Other commands, such as `darcs changes` use author strings\n" ++ + "authors`. Other commands, such as `darcs log` use author strings\n" ++ "verbatim.\n" ++ "\n" ++ "An example `.authorspelling` file is:\n" ++ diff --git a/src/Darcs/UI/Commands/Tag.hs b/src/Darcs/UI/Commands/Tag.hs --- a/src/Darcs/UI/Commands/Tag.hs +++ b/src/Darcs/UI/Commands/Tag.hs @@ -74,7 +74,7 @@ "at .\n" ++ "\n" ++ "To reproduce the state of a repository `R` as at tag `t`, use the\n" ++ - "command `darcs get --tag t R`. The command `darcs show tags` lists\n" ++ + "command `darcs clone --tag t R`. The command `darcs show tags` lists\n" ++ "all tags in the current repository.\n" ++ "\n" ++ "Tagging also provides significant performance benefits: when Darcs\n" ++ diff --git a/src/Darcs/UI/Commands/Unrecord.hs b/src/Darcs/UI/Commands/Unrecord.hs --- a/src/Darcs/UI/Commands/Unrecord.hs +++ b/src/Darcs/UI/Commands/Unrecord.hs @@ -351,7 +351,7 @@ (hasSummary O.NoSummary opts) (dryRun opts) (hasXmlOutput opts) - (isInteractive opts) + (isInteractive True opts) removed setEnvDarcsPatches removed when (isJust $ getOutput opts "") $ @@ -438,7 +438,7 @@ { S.verbosity = verbosity flags , S.matchFlags = parseFlags O.matchSeveralOrLast flags , S.diffAlgorithm = diffAlgorithm flags - , S.interactive = isInteractive flags + , S.interactive = isInteractive True flags , S.selectDeps = selectDeps flags , S.summary = hasSummary O.NoSummary flags , S.withContext = O.NoContext diff --git a/src/Darcs/UI/Commands/Unrevert.hs b/src/Darcs/UI/Commands/Unrevert.hs --- a/src/Darcs/UI/Commands/Unrevert.hs +++ b/src/Darcs/UI/Commands/Unrevert.hs @@ -122,7 +122,7 @@ { S.verbosity = verbosity flags , S.matchFlags = [] , S.diffAlgorithm = diffAlgorithm flags - , S.interactive = isInteractive flags + , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = O.NoSummary -- option not supported, use default , S.withContext = isUnified flags diff --git a/src/Darcs/UI/Commands/WhatsNew.hs b/src/Darcs/UI/Commands/WhatsNew.hs --- a/src/Darcs/UI/Commands/WhatsNew.hs +++ b/src/Darcs/UI/Commands/WhatsNew.hs @@ -148,7 +148,7 @@ { S.verbosity = verbosity flags , S.matchFlags = [] , S.diffAlgorithm = diffAlgorithm flags - , S.interactive = isInteractive flags + , S.interactive = isInteractive True flags , S.selectDeps = O.PromptDeps -- option not supported, use default , S.summary = hasSummary (defaultSummary flags) flags , S.withContext = isUnified flags diff --git a/src/Darcs/UI/Flags.hs b/src/Darcs/UI/Flags.hs --- a/src/Darcs/UI/Flags.hs +++ b/src/Darcs/UI/Flags.hs @@ -182,9 +182,9 @@ hasPause = (== O.YesWantGuiPause) . parseFlags O.pauseForGui -- | Non-trivial interaction between options. Explicit @-i@ or @-a@ dominates, --- else @--count@, @--xml@, or @--dry-run@ imply @-a@, else default to interactive. -isInteractive :: Config -> Bool -isInteractive = oparse (O.dryRunXml ^ O.changesFormat ^ O.interactive) decide +-- else @--count@, @--xml@, or @--dry-run@ imply @-a@, else use the def argument. +isInteractive :: Bool -> Config -> Bool +isInteractive def = oparse (O.dryRunXml ^ O.changesFormat ^ O.interactive) decide where decide :: O.DryRun -> O.XmlOutput -> Maybe O.ChangesFormat -> Maybe Bool -> Bool decide _ _ _ (Just True) = True @@ -192,7 +192,7 @@ decide _ _ (Just O.CountPatches) Nothing = False decide _ O.YesXml _ Nothing = False decide O.YesDryRun _ _ Nothing = False - decide _ _ _ Nothing = True + decide _ _ _ Nothing = def maxCount :: Config -> Maybe Int maxCount = parseFlags O.matchMaxcount diff --git a/src/Darcs/UI/Message/Send.hs b/src/Darcs/UI/Message/Send.hs --- a/src/Darcs/UI/Message/Send.hs +++ b/src/Darcs/UI/Message/Send.hs @@ -163,8 +163,10 @@ savedButNotSent :: String -> Doc savedButNotSent to = - text ("The usual recipent for this bundle is: " ++ to) - $$ text "To send it automatically, mark sure sendmail is working, and add 'send mail' to _darcs/prefs/defaults or ~/.darcs/defaults" + text ("The usual recipent for this bundle is: " ++ to) + $$ text "To send it automatically, make sure sendmail is working," + <+> text "and add 'send mail' to _darcs/prefs/defaults or" + <+> text " ~/.darcs/defaults" willSendTo :: DryRun -> [String] -> Doc willSendTo dr addresses = diff --git a/src/Darcs/UI/SelectChanges.hs b/src/Darcs/UI/SelectChanges.hs --- a/src/Darcs/UI/SelectChanges.hs +++ b/src/Darcs/UI/SelectChanges.hs @@ -95,8 +95,7 @@ import Darcs.Patch.Inspect ( PatchInspect ) import Darcs.Patch.Invert ( Invert ) import Darcs.Patch.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread ) -import Darcs.Patch.Named ( Named ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia ) +import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia ) import Darcs.Patch.Set ( PatchSet(..), newset2RL ) import Darcs.Patch.Show ( ShowPatch ) import Darcs.Patch.Split ( Splitter (..) ) @@ -213,7 +212,7 @@ PSC { opts = o , splitter = spl , files = fs - , matchCriterion = iswanted (seal2 . hopefully) (matchFlags o) + , matchCriterion = iswanted seal2 (matchFlags o) , jobname = jn , allowSkipAll = True , pristine = Nothing @@ -222,7 +221,7 @@ -- | A generic 'PatchSelectionContext'. selectionContextGeneric :: (RepoPatch p, Invert q) - => (forall wX wY . q wX wY -> Sealed2 (Named p)) + => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd p)) -> WhichChanges -> String -> PatchSelectionOptions @@ -268,7 +267,7 @@ -- | 'iswanted' selects patches according to the given match flags iswanted :: forall p q . (RepoPatch p, Invert q) - => (forall wX wY . q wX wY -> Sealed2 (Named p)) + => (forall wX wY . q wX wY -> Sealed2 (PatchInfoAnd p)) -> [MatchFlag] -> MatchCriterion q iswanted extract mflags = MatchCriterion diff --git a/src/Darcs/Util/ByteString.hs b/src/Darcs/Util/ByteString.hs --- a/src/Darcs/Util/ByteString.hs +++ b/src/Darcs/Util/ByteString.hs @@ -67,11 +67,14 @@ import Data.ByteString (intercalate) import Data.ByteString.Internal (fromForeignPtr) +#if mingw32_HOST_OS +#else import Control.Exception ( catch, SomeException ) +#endif import System.IO import System.IO.Unsafe ( unsafePerformIO ) -import Foreign.Storable ( peekElemOff, peek ) +import Foreign.Storable ( peek ) import Foreign.Marshal.Array ( advancePtr ) import Foreign.C.Types ( CInt(..) ) @@ -101,9 +104,12 @@ import Darcs.Util.Encoding ( decode, encode ) import Darcs.Util.Global ( addCRCWarning ) +#if mingw32_HOST_OS +#else import System.IO.MMap( mmapFileByteString ) import System.Mem( performGC ) import System.Posix.Files( fileSize, getSymbolicLinkStatus ) +#endif -- ----------------------------------------------------------------------------- -- obsolete debugging code @@ -405,6 +411,9 @@ -- the file is assumed to be ISO-8859-1. mmapFilePS :: FilePath -> IO B.ByteString +#if mingw32_HOST_OS +mmapFilePS = B.readFile +#else mmapFilePS f = mmapFileByteString f Nothing `catch` (\(_ :: SomeException) -> do @@ -412,6 +421,7 @@ if size == 0 then return B.empty else performGC >> mmapFileByteString f Nothing) +#endif -- ------------------------------------------------------------------------- -- fromPS2Hex @@ -461,21 +471,13 @@ breakAfterNthNewline :: Int -> B.ByteString -> Maybe (B.ByteString, B.ByteString) breakAfterNthNewline 0 the_ps | B.null the_ps = Just (B.empty, B.empty) + | otherwise = Just (B.empty, the_ps) breakAfterNthNewline n the_ps = - case BI.toForeignPtr the_ps of - (fp,the_s,l) -> - unsafePerformIO $ withForeignPtr fp $ \p -> - do let findit 0 s | s == end = return $ Just (the_ps, B.empty) - findit _ s | s == end = return Nothing - findit 0 s = let left_l = s - the_s - in return $ Just (fromForeignPtr fp the_s left_l, - fromForeignPtr fp s (l - left_l)) - findit i s = do w <- peekElemOff p s - if w == nl then findit (i-1) (s+1) - else findit i (s+1) - nl = BI.c2w '\n' - end = the_s + l - findit n the_s + go n (B.elemIndices (BI.c2w '\n') the_ps) + where go 0 [] = Just (the_ps, B.empty) + go _ [] = Nothing + go 1 (i:_) = Just $ B.splitAt (i+1) the_ps + go !m (_:is) = go (m-1) is -- ------------------------------------------------------------------------- -- breakBeforeNthNewline @@ -484,21 +486,10 @@ breakBeforeNthNewline 0 the_ps | B.null the_ps = (B.empty, B.empty) breakBeforeNthNewline n the_ps = - case BI.toForeignPtr the_ps of - (fp,the_s,l) -> - unsafePerformIO $ withForeignPtr fp $ \p -> - do let findit _ s | s == end = return (the_ps, B.empty) - findit i s = do w <- peekElemOff p s - if w == nl - then if i == 0 - then let left_l = s - the_s - in return (fromForeignPtr fp the_s left_l, - fromForeignPtr fp s (l - left_l)) - else findit (i-1) (s+1) - else findit i (s+1) - nl = BI.c2w '\n' - end = the_s + l - findit n the_s + go n (B.elemIndices (BI.c2w '\n') the_ps) + where go _ [] = (the_ps, B.empty) + go 0 (i:_) = B.splitAt i the_ps + go !m (_:is) = go (m-1) is -- | Test if a ByteString is made of ascii characters isAscii :: B.ByteString -> Bool diff --git a/tests/bin/renameHelper.hs b/tests/bin/renameHelper.hs new file mode 100644 --- /dev/null +++ b/tests/bin/renameHelper.hs @@ -0,0 +1,205 @@ +-- Helper to test renaming +-- +-- Copyright (C) 2014 Owen Stephens +-- +-- Permission is hereby granted, free of charge, to any person +-- obtaining a copy of this software and associated documentation +-- files (the "Software"), to deal in the Software without +-- restriction, including without limitation the rights to use, copy, +-- modify, merge, publish, distribute, sublicense, and/or sell copies +-- of the Software, and to permit persons to whom the Software is +-- furnished to do so, subject to the following conditions: +-- +-- The above copyright notice and this permission notice shall be +-- included in all copies or substantial portions of the Software. +-- +-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +-- EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +-- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +-- NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +-- BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +-- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +-- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +module Main where + +import Data.List ( sort, groupBy ) +import Data.Function ( on ) +import System.FilePath ( () ) +import Control.Monad ( forM, void, when, unless, forM_ ) +import System.Directory ( createDirectory, removeFile, removeDirectory + , doesDirectoryExist, doesFileExist ) +import System.Exit ( ExitCode(..) ) +import System.Process ( system ) + +{- +N = nonexistent (unrecorded, not in working) +U = unadded (unrecorded, in working) +S = shadow (recorded, not in working) +K = known (recorded, in working) + +O = OK +F = Fail + tgt + N U S K + N F1 F1 F1 F1 +s U F2 F2 F2 F2 +r S F3 O4 F5 O6 +c K O7 F8 O9 OF10 + +Reasons: + 1 no such source path + 2 shouldn't move paths we don't manage + 3 target not in WD/Repo + 4 post-hoc move + 5 target exists in Repo + 6 target exists in WD/Repo, but could be successful post-hoc if target + is made to appear deleted before the move + 7 simple rename + 8 target in WD + 9 rename into file that has been deleted. + 10 If target is dir then OK: move into dir, else Fail: target exists in WD +-} + +data PathExistence = N + | U + | K + | S + deriving (Eq, Ord, Show) + +data PathType = File + | Dir + deriving (Eq, Ord, Show ) + +-- OK takes a function to modify src/tgt names, used to check for tgt existence +data ExpectedResult = OK ((String, String) -> String) + | Fail + +instance Show ExpectedResult where + show (OK _) = "OK " + show Fail = "FAIL" + +-- ExpectedResults are for: [File/File, File/Dir, Dir/File, Dir/Dir] +resList :: [ (PathExistence, [(PathExistence, [ExpectedResult])]) ] +resList = + [ (N, [ (N, allFail) + , (U, allFail) + , (K, allFail) + , (S, allFail) + ]) + , (U, [ (N, allFail) + , (U, allFail) + , (K, allFail) + , (S, allFail) + ]) + , (K, [ (N, allOkSnd) + , (U, allFail) + , (K, [Fail, okMoveInto, Fail, okMoveInto]) + , (S, allOkSnd) + ]) + , (S, [ (N, allFail) + , (U, [okSnd, Fail, Fail, okSnd]) + , (K, [okSnd, Fail, Fail, okSnd]) + , (S, allFail) + ]) + ] + where + allFail = replicate 4 Fail + allOkSnd = replicate 4 okSnd + okSnd = OK snd + okMoveInto = OK $ \(s,d) -> ds + +-- Add a newline, else we're not creating a valid textfile! +makeAtPath File = \p -> writeFile p (p ++ "\n") +makeAtPath Dir = createDirectory +removeAtPath File p = do + removeFile p + void $ system ("echo 'Removed file " ++ p ++ "'") +removeAtPath Dir p = do + removeDirectory p + void $ system ("echo 'Removed dir " ++ p ++ "'") + +expectFailure args ExitSuccess = + fail $ "Unexpected success: " ++ show args +expectFailure args ec = return () + +exists File = doesFileExist +exists Dir = doesDirectoryExist + +checkTgtExists pathType mod src tgt args = do + tgtExists <- exists pathType $ mod (src, tgt) + unless tgtExists $ + fail $ "Unexpected absence of move tgt: " + ++ show (mod (src, tgt)) ++ " " ++ show args + +checkSrcDoesNotExist pathType src args = do + srcExists <- exists pathType src + when srcExists $ + fail $ "Unexpected presence of move src: " ++ show args + +expectSuccess args (ExitFailure _) _ = + fail $ "Unexpected failure: " ++ show args +expectSuccess (U,_,_,_,_,_,_) ExitSuccess _ = return () +expectSuccess args@(K, srcPathType@File, src, K, Dir, tgt, _) _ mod = do + checkSrcDoesNotExist srcPathType src args + -- src is a file, tgt is a dir, so src will be moved inside dir + checkTgtExists File mod src tgt args +expectSuccess args@(_, srcPathType, src, N, _, tgt, _) _ mod = do + checkSrcDoesNotExist srcPathType src args + -- tgt didn't exist so src will simply be renamed to tgt + checkTgtExists srcPathType mod src tgt args +expectSuccess args@(K, srcPathType, src, S, _, tgt, _) _ mod = do + checkSrcDoesNotExist srcPathType src args + -- tgt was shadow, so src will simply be renamed to tgt + checkTgtExists srcPathType mod src tgt args +expectSuccess args@(_, srcPathType, src,_, tgtPathType, tgt,_) _ mod = do + checkSrcDoesNotExist srcPathType src args + checkTgtExists tgtPathType mod src tgt args + +type RenameInfo = (PathExistence, PathType, FilePath) + +main = do + -- Don't need to do anything with the nonexistent paths + let [_, us, ks, ss] = groupBy ((==) `on` (\(x,_,_) -> x)) . sort . + concatMap (\(x,y) -> [x,y]) . fst . unzip $ pathDetails + -- Create all files/dirs + mapM_ (\(_, ptype, p) -> makeAtPath ptype p) $ us ++ ks ++ ss + -- Let darcs know about all knowns/shadows + mapM_ (system . ("darcs add " ++) . unwords . map (\(_,_,x)->x)) [ks, ss] + _ <- system "darcs rec -am 'add everything'" + -- Remove from working all shadows + mapM_ (\(_, ptype, p) -> removeAtPath ptype p) ss + forM_ pathDetails $ \(( (srcType, srcPathType, srcName) + , (tgtType, tgtPathType, tgtName)), expected) -> do + let movePatchName = + "'move " ++ srcName ++ " -> " ++ tgtName ++ "'" + ec <- system $ unwords [ "darcs whatsnew" + , "&& darcs move", srcName, tgtName + , "&& darcs rec -a ", tgtName, srcName + , "-m", movePatchName] + let args = ( srcType, srcPathType, srcName + , tgtType, tgtPathType, tgtName, expected) + case expected of + OK check -> expectSuccess args ec check + Fail -> expectFailure args ec + where + fileDirCombos = [(a,b) | a <- [File, Dir], b <- [File, Dir]] + + zipErr [] [] = [] + zipErr (x : xs) (y : ys) = (x, y) : zipErr xs ys + zipErr _ _ = error "uneven lists in zipErr" + + pathDetails :: [((RenameInfo, RenameInfo), ExpectedResult)] + pathDetails = + concatFor resList $ \(srcType, srcResults) -> + concatFor srcResults $ \(tgtType, expected) -> + concatFor (zipErr fileDirCombos expected) $ + \((srcPathType, tgtPathType), expectedResult) -> + let nameBase = show srcType ++ show srcPathType + ++ show tgtType ++ show tgtPathType + srcName = nameBase ++ "-src" + tgtName = nameBase ++ "-dst" + src = (srcType, srcPathType, srcName) + tgt = (tgtType, tgtPathType, tgtName) + in [((src, tgt), expectedResult)] + where + concatFor = flip concatMap diff --git a/tests/get-http.sh b/tests/get-http.sh --- a/tests/get-http.sh +++ b/tests/get-http.sh @@ -37,5 +37,5 @@ darcs get $baseurl/R S cd S darcs pull ../R | tee log -grep "No remote changes" log +grep "No remote" log darcs check diff --git a/tests/issue279_get_extra.sh b/tests/issue279_get_extra.sh --- a/tests/issue279_get_extra.sh +++ b/tests/issue279_get_extra.sh @@ -35,7 +35,7 @@ cd .. cd temp_d darcs pull -a ../temp_c > log -not grep -i "no remote changes" log +not grep -i "no remote" log not grep -i get_extra log cd .. diff --git a/tests/pull.sh b/tests/pull.sh --- a/tests/pull.sh +++ b/tests/pull.sh @@ -18,7 +18,7 @@ mkdir two cd two echo darcs pull should work relative to the current directory -darcs pull -a ../../../temp1 | grep -i 'No remote changes to pull in' +darcs pull -a ../../../temp1 | grep -i 'No remote patches to pull in' echo -- darcs pull should pull into repo specified with --repo cd ../.. # now in temp2 diff --git a/tests/pull_compl.sh b/tests/pull_compl.sh --- a/tests/pull_compl.sh +++ b/tests/pull_compl.sh @@ -124,7 +124,7 @@ EOF darcs pull --dry-run --complement ../temp2 ../temp3 > p8.out -grep "No remote changes to pull in!" p8.out +grep "No remote patches to pull in!" p8.out # because duplicates are stripped before performing action, # this is the same as: darcs pull ../temp1 @@ -136,7 +136,7 @@ # so the "null" pull must be tested this way: darcs get ../temp1 ../temp5 darcs pull --dry-run --complement ../temp1 ../temp5 > p9.out -grep "No remote changes to pull in!" p9.out +grep "No remote patches to pull in!" p9.out darcs pull -av --complement ../temp1 ../temp3 darcs check diff --git a/tests/push-formerly-pl.sh b/tests/push-formerly-pl.sh --- a/tests/push-formerly-pl.sh +++ b/tests/push-formerly-pl.sh @@ -33,7 +33,7 @@ mkdir -p temp2/one/two cd temp2/one/two # darcs push should work relative to the current directory -darcs push -a ../../../temp1 | grep -i 'No recorded local changes to push' +darcs push -a ../../../temp1 | grep -i 'No recorded local patches to push' cd ../../../ # darcs push should push into repo specified with --repo diff --git a/tests/v1-braced.sh b/tests/v1-braced.sh --- a/tests/v1-braced.sh +++ b/tests/v1-braced.sh @@ -44,7 +44,7 @@ cd .. cd braced -darcs pull -a ../empty | grep 'No remote changes to pull in' +darcs pull -a ../empty | grep 'No remote patches to pull in' cd ../empty -darcs pull -a ../braced | grep 'No remote changes to pull in' +darcs pull -a ../braced | grep 'No remote patches to pull in'