packages feed

darcs 2.8.5 → 2.18.5

raw patch · 1071 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,3474 @@+Darcs 2.18.5, 9 Jan 2025++This release is mainly to keep up with (breaking) changes in some of our+dependencies. A plain `cabal update && cabal install darcs` should now again+succeed. It also includes a minor fix and an improvement for the+check/repair commands.++  * restrict upper limit on attoparsec from <0.15 to <14.4 for ghc versions <8.10+  * exclude system-fileio-0.3.16.5 which fails to build on Windows+  * raise upper bound on tls, data-default-class -> data-default+  * ci: only aim to be warnings clean on one version of GHC+  * check/repair: avoid newlines in progress messages+  * check/repair: display patch info of repaired patches++Darcs 2.18.4, 26 Oct 2024++  * darcs can now be built with stack against stackage lts-22.34, which is+    the version that the debian haskell team currently targets++  * resolve issue2725: the permissions of _darcs/patch_index are now+    generically set to those of its parent directory++Darcs 2.18.3, 26 May 2024++  * relax upper bounds for some dependencies++  * with GHC up to 9.8 all tests now succeed (including Windows and MacOS)++  * resolve issue2714: cannot remove recursively++  * resolve issue2715: hub.darcs.net does not support "Extended Main Secret"++    We use a new addition to crypton-connection in order to change the default+    setting back to old (tls < 2.0) default.++  * resolve issue2721 by excluding certain versions of directory package++    Versions 1.3.8 up to 1.3.8.4 of the directory package have a bug in their+    implementation of copyFile on Windows.++  * work around issue2720 (caused by x509-system indirect dependency, see+    (see https://github.com/kazu-yamamoto/crypton-certificate/issues/9)++  * make execution of release/gen-version-info.hs more robust++    Using cabal run instead of runghc inside of Setup.hs ensures that we use the+    same ghc version that cabal uses, avoiding dependency errors.++Darcs 2.18.2, 24 Mar 2024++  * Fix deprecated head/tail warnings on GHC 9.8, making the build there+    warning-free.++  * Replace the set-default hint that was removed in 2.18.1++  * Add a --ghcflags/-g option to the test suite to allow flags+    like -dynamic to be passed to GHC when it builds helper exes+    in various test scripts.++Darcs 2.18.1, 25 Feb 2024++  * Supports GHC 9.8 and the most recent version of other dependencies+    at the time of release, with the exception of the tls 2.0 package,+    which has been held back because of problems connecting to hub.darcs.net+    (see https://bugs.darcs.net/issue2715).++  * Substantial rewrite of the 'darcs test' command.++    The most important user visible change is that a test script can now+    return an exit code of 125 to reflect an untestable/skipped state+    (as with with "git bisect run").++    This in turn means that a group of patches can be found to be responsible+    for a failure rather than just a single one. By default, Darcs will+    try to minimise such a group by reordering patches to remove irrelevant+    ones from the initial group found from the patch ordering in the+    repository. This behaviour can be disabled with --no-shrink-failure.++  * Remove support for downloading via curl++    This is no longer particularly useful as we now use modern, maintained+    Haskell libraries for native HTTP downloading, and substantially simplifies+    this area of the code.++  * Patch index: Significant performance improvement++    The patch index is used in commands like annotate and log. A couple of+    performance improvements were made that should speed up using the patch+    index.++  * Progress reporting++    Progress reports are now provided during more long-running operations,+    including updating the "index" (a cache that speeds up detecting+    changes in the working directory), and during merge operations.++    They also behave better on Windows and when outputting long lines.++  * Other changes/fixes:+    * Use hardlinks more often to share files between repositories/caches.+    * Support --leave-test-dir for all commands that support --test+    * Avoid extraneous "repo:." entries in _darcs/prefs/sources [issue2672]+    * Add 'darcs clean' command as an alias for 'darcs revert -l'+    * 'darcs rebase unsuspend': add more patch editing options+    * Fix stale lock files after Ctrl-C+    * External merge tools: preserve output, and fail if tool does+    * Properly reference renamed files in external merge [issue189]+    * Mark conflicts properly if tag pulled at the same time [issue2682]+    * Remove the useless optimize pristine subcommand+    * 'darcs convert': honour the --compress and --diff-algorithm options+    * Fix contrib/darcs-shell [issue2646]+    * Fix 'darcs pull --dont-allow-conflicts' with external-merge [issue1819]+    * Problems with local pristine files now tell user to run+      'darcs repair' [issue1981]+    * Fix various problems with symlinks, including on Windows+    * Add --no-prefs-templates option when creating a repository+    * Allow 'darcs rebase unsuspend' when there are non-conflicting+      unrecorded changes+    * Handle broken pending patches in 'darcs check' and 'darcs repair'+    * Improve error reporting when remote _darcs/format doesn't exist+    * 'darcs optimize reorder': add --deep/--shallow options+    * 'darcs optimize compress/uncompress': also handle pristine files+    * 'darcs optimize cache': don't work with lists of darcs repos+      Instead just the global cache is cleaned by checking hard-link counts+    * Skip the pager when $DARCS_PAGER / $PAGER are set to the empty string+    * 'darcs convert export': allow relative paths for --read-marks and+      --write-marks+    * Fix 'darcs amend --unrecord' to move unrecorded changes to pending+      [issue2697]+    * Don't treat cancelling an operation as failure [issue2074]+    * Fix cloning of ssh repo when using Ctrl-C to stop getting patches+      [issue2701]+    * Don't report invalid regexes as a bug in darcs [issue2702]+    * Add short option -n for --dry-run+    * 'darcs diff': support --look-for-moves and --look-for-adds+    * Fix buffering problem with 'darcs diff' [issue2704]+    * 'darcs obliterate' and 'darcs rebase': offer to revert any conflicting+      unrecorded changes+    * Stop displaying context lines in various interactive scenarios:+      it didn't work properly and would require a lot of work to fix.+    * Improve conflict display for Rebase and V3 patches+    * Increase size limit to 100K for environment variables like+      DARCS_PATCHES_XML, and warn when it is exceeded+    * 'darcs rebase unsuspend': improve the display of dropped dependencies+    * 'darcs amend --ask-deps': also provide a way to remove dependencies+    * 'darcs push': support --reorder-patches option+    * Remove the --remote-repo option+    * Don't display hints about using --set-default+    * Conflict resolution: unrecorded changes will suppress conflict marking+      of appropriate changes [issue2708]+    * Explain what a "clean tag" is in help for tag command+    * Fix problem with naming patch bundles after patches that contain+      characters incompatible with the current locale [issue2716]++Darcs 2.16.5, 20 Feb 2022++  This release is to support newer dependencies, most importantly+  GHC 9.0 and Cabal 3.6.++  It also includes a small number of refactors that help with moving+  to those newer dependencies.++Darcs 2.16.4, 20 May 2021++  This release is mostly to fix http://bugs.darcs.net/issue2674 which can+  lead to repository corruption. This is not quite as bad as it sounds,+  since the broken changes that you could have recorded were consistently+  ignored when applying the patch. This bug has been in darcs for a very+  long time and even our own repos contain (ancient) patches with broken+  move changes, and so far it hasn't caused us any trouble.++  That said, there are certain patch commutations that will erroneously (and+  unexpectedly) fail when such a patch is involved. We therefore recommend+  to upgrade. You may also (after upgrading) run 'darcs check' on your+  repositories to see if you are affected, and 'darcs repair' them if that+  is the case. Fortunately, the broken move changes can be safely eliminated+  from existing patches, and the improved repair command now does exactly+  that.++  Thanks to lemming@henning-thielemann.de for bringing this bug to our+  attention.++  * resolve issue2674: moving unadded files+  * add a check/repair rule for bad move patches+    This drops a move patch with either non-existing source or existing target.++  Also related to issue2674:++  * improve error message when runDefault fails due to an IO error+  * remove catching of exceptions for bad moves in DefaultIO+  * fail in Darcs.Util.Tree.Monad.rename if source does not exist+  * test that we cannot record patches that depend on broken moves++  The rest of the changes are minor bug fixes plus a few dependencies.++  * resolve issue2670: convert "." to absolute path when creating a repo+    This bug was introduced by fix for issue2668.+  * resolve issue2668: createDirectory: permission denied+  * resolve issue2667: darcs init failed with permission denied+  * bugfix: --leave-test-dir should be off by default+  * bash_completion: use '--list-options' before any other option+    This is so to avoid that, e.g.:+    $ darcs record -m <Tab><Tab>+    results in a patch named '--list-options' being recorded.+  * zsh completion: use '--list-options' before any other option+    See the corresponding change in the bash completion for details.+  * zsh completion: improve the get/clone case+    Moving the special case for get/clone down into the catch-all case for the+    current word allows it to complete options and local paths.+  * bugfix: --leave-test-dir should be off by default+  * bugfix in readPendingAndMovesAndUnrecorded+  * print patch application warnings to stderr, not stdout++Darcs 2.16.3, 22 October 2020++  * Fix building with `-f curl` (issue2655)+  * Fix building with stack+  * Various fixes in our custom Setup.hs, mostly to do with cabal commands+    exectuted inside the unpacked source dist tar ball+  * Remove obsolete dependency on split package+  * Remove dependency on sandi and use base16-bytestring >= 1.0, improving+    performance when darcs handles binary files and patches, and more+    generally whenever we convert hashes from/to text.+  * Various minor fixes and additions to tests scripts+  * Issues fixed:+    * 2654: amend --prompt-long-comment removes the long comment+    * 2658: show dependencies should only show direct dependencies+    * 2659: check for bad patch name after invoking editor, too++Darcs 2.16.2, 19 August 2020++  * Fix build problem when using 'cabal install' from inside the sdist.++    This fails because in this case cabal will try to 'cabal sdist' the+    bundled shelly dependency, and we do not (nor want to) list all shelly+    files in our own cabal file. To avoid problems like this, we no longer+    use the bundled shelly as a dependency, but rather as part of our+    sources for the test suite.++Darcs 2.16.1, 14 August 2020++  * Building:+    * Drop support for building with ghc-8.0+    * Allow clean (warning-free) builds with all ghc versions from 8.2.2 up+      to ghc-8.10.1+    * Various dependency updates+    * Remove sdist and postConf hooks from Setup.hs+    * move -DHAVE_MAPI from Setup.hs to darcs.cabal+    * Recommended way to build is using cabal-install >= 3.0+    * The source tree now contains a cleaned-up version of shelly-1.7.1+      (locally named shelly-1.7.1.1) which we need to run our test suite.+      Unfortunately, later versions break compatibility on Windows and+      keeping the dependency fixed to 1.7.1 would mean we cannot support+      newer ghc versions.++  * Preliminary UNSTABLE support for a new patch theory named "darcs-3",+    largely based on the pioneering work of Ian Lynagh for 'camp'.++    Please note that this format is not yet officially supported: some+    features (like conversion from older formats) are still missing, and we+    have not yet finalized the on-disk format. You should NOT use it for any+    serious work yet.++    The new theory finally solves all the well-known consistency problems+    that plagued the earlier ones, and thus fixes a number of issues+    (including issue1401 and issue2605) that have been outstanding for many+    years. It also reduces the worst case asymptotic runtime for commutation+    and merging from exponential to merely quadratic in the number of+    patches involved.++    One of the reasons we are confident this new theory and its+    implementation is sound, i.e. respect all required properties, is that+    we have improved our test case generator for sequences of patches. It+    now generates all possible conflict scenarios. Since the new theory no+    longer has worst case exponential runtime, we can and did test all+    required properties and invariants with a large number of generated test+    cases (up to 100000).++  * The internals of how 'darcs rebase' stores and handles suspended patches+    and their "fixups" has been changed in incompatible ways. This means+    that if you have a rebase in progress started with darcs < 2.16, you+    will first need to use the new 'darcs rebase upgrade' command to upgrade+    the suspended patches to the new format. If you start a rebase with+    darcs-2.16, then earlier darcs versions will not work with that repo,+    until you have finished the rebase.++    The new implementation fixes a lot of bugs (including outright crashes+    in some situations). The behavior when conflicted patches are suspended+    is much better now, though there are still a few corner cases where the+    behavior can be quite unintuitive, especially when complicated conflicts+    are suspended.++    A number of limitations regarding repositories with a rebase in progress+    have been lifted; in particular, push, pull, and clone between repos can+    now be done regardless of whether any of the repos have a rebase in+    progress or not.++  * The way conflict markup is generated has been cleaned up and refactored.+    The main user-visible improvement is that darcs now reliably /either/+    marks a conflict /or/ keeps the default resolution (i.e. remove both+    changes) and reports the conflicts that it cannot mark. Previously,+    conflicts that could not be properly marked (roughly all conflicts+    involving changes other than hunks, e.g. replaces and file or dir adds,+    removes, and renames) would be silently "half-resolved" in favour of one+    of the alternatives. This could be pretty confusing, the more so since+    it was hard to predict which of the conflicting alternatives was chosen.++  * Complete re-implementation of the way in which the pending patch is+    updated after record and amend. This fixes a number of problems with+    pending becoming corrupt. The new code also works in cases where hunks+    are edited interactively. The algorithm is documented in detail.++  * Downloading files via http now uses the http-conduit package. This is+    now the default method when building darcs. Building against the curl+    library is still supported but you have to explicitly request it by+    passing -fcurl to cabal.++  * Reworked internal failure handling so we can clearly distinguish between+    normal command failures and internal errors, i.e bugs, in darcs. In case+    of a bug, darcs exits with status 4 and prints a message that asks the+    user to report it and how to do that.++  * During interactive patch selection, the 'x', 'v', and 'p' keys no longer+    print the patch description (if any), only the summary or the patch+    content. A new key 'r' was added to re-display the currently selected+    patch in default mode (normally this is just the description). See+    issue2649 for details.++  * A large number of other internal refactors and code cleanups.++  * A forward compatibility bug (issue2650), roughly fixed in Darcs 2.14.5,+    is now resolved in full. In particular, we modify the format file only+    if we have taken the repo lock, silently fix possibly corrupted entries+    when reading the format file, internally document the forward+    compatibility rules, and finally test them more thoroughly.++  * Issues fixed:+    * 1316: amend-record: files/dirs still in pending even if they are removed+    * 1609: darcs conflict marking gives different results in different orders+    * 2001: repair fails to detect missing pristine files+    * 2275: ignore symlinks as repo paths even when the index is used+    * 2404: darcs convert export ignores --repodir+    * 2441: Use pager for darcs annotate+    * 2445: internal error if suspended patch is pulled into repository again+    * 2454: help markdown/manpage should use a pager+    * 2533: add umask option to all commands that modify the repo+    * 2536: show files --no-files: can't mix match and pending flags+    * 2548: inconsistent pending after addfile f; rm f; mkdir f+    * 2550: apply only properly mangled resolutions, warn about any others+    * 2592: update pending with coalesced look-for changes+    * 2593: network test can collide with shell tests+    * 2594: darcs show index crashes replace with unrecorded force hunk+    * 2599: don't bother to update pending when cloning a repo+    * 2603: warn and mark conflicts when cloning+    * 2604: remove --reply and related options+    * 2608: download _darcs/hashed_inventory separately+    * 2610: add --inherit-default option+    * 2614: (an intermediate regression)+    * 2618: option --ask-deps adds too many dependencies+    * 2625: catch only IO exceptions from applyToWorking+    * 2626: treat applyToWorking more uniformly+    * 2634: use unwind to suspend patches+    * 2635: build/install man page only if we build darcs executable+    * 2639: darcs diff crashes with --last=1 and file name+    * 2645: search for ":" to detect ssh URLs only up to the first "/"+    * 2648: convert import with non-ASCII meta data and filepaths+    * 2649: cleanup display of patches++  * Partial fixes:+    * 1959: read-only commands should not need write access to the index+      This is mostly fixed, see tests/issue1959-unwritable-darcsdir.sh+      for the few remaining problematic cases. We also now check+      writability of the index when we start a transaction.++  * Miscellaneous user-visible changes and bugfixes:+    * always prompt for confirmation when there are conflicts with unrecorded+      changes+    * darcs optimize upgrade: don't throw away pending+    * use cryptonite instead of cryptohash and random; the random junk added+      to patch meta data now uses a cryptographically secure random number+      generator; also replaces our own implementation of SHA1+    * darcs repair: handle broken binary patches+    * fail if pending patch cannot be parsed instead of silently ignoring it+    * darcs remove: don't allow removal of root+    * darcs suspend reify: give reified fixup patches a real author+    * darcs add: fail unconditionally when no files were added+    * darcs optimize compress: don't compress special patches such as+      pending or unrevert+    * darcs send: bugfix on Windows with GHC>=8.6+    * fix prompting when we get a bad patch name from the user+    * darcs apply: fix interpretation of patch bundles as patchsets when the+      context tag is not in our repo+    * darcs apply: fix lazy reading of inventories+    * darcs amend: fix editing of tag names+    * clone to ssh: don't overwrite existing remote target directories+    * darcs rebase: remove error if no suspended patches found+    * fully respect the (badly named) --no-ignore-times option (which+      actually means to ignore the index)+    * replace the code for creating unique temporary directory names+      (that was prone to race conditions); instead we now use the temporary+      package+    * darcs check/repair: detect and repair missing (hashed) pristine files+    * remove option --restrict-paths (is always active now)+    * remove defunct --set-default option for rebase pull+    * remove env var DARCS_DO_COLOR_LINES+    * demote errors in defaults file and commandline to warnings+    * add --not-in-remote option to amend and rebase suspend; the option+      is now supported by all history editing commands.+    * remove our own optimisation settings in darcs.cabal+    * regard explicit dependencies as resolving conflicts+    * suspend reify: give reified fixup patches a real author+    * never overwrite existing files with -O/--output-auto-name+    * make working with temporary directories more robust+    * make sure we cancel pending download actions at exit+    * darcs diff: allow use of interactive external diff commands+    * remove graphviz dependency by re-implementing show dependencies+    * darcs show dependencies: review matching options+    * darcs annotate: more than one file argument is now an error++  * Changes in the output of commands:+    * add a warning when the index code ignores a symlink+    * print remote execution failure message to stderr+    * darcs amend: respect verbosity options+    * commands that can produce large amounts of output now display it using+      a pager, similar to 'darcs log'+    * remove "withSignalsHandled:" from message when we are interrupted (Ctrl-C)+    * add progress reporting to patch index+    * print remote execution failure message to stderr+    * re-formulate the bad sources hint+    * remove hint "Do you have the right URI for the repository?"+    * remove the "darcs failed:" from error messages+    * re-formulate the set-default hint+    * darcs check/repair: no coloring in progress reports+    * add progress reporting when creating packs+    * darcs test: make linear search report results like bisect+    * colorize --dry-run output and warnings+    * darcs whatsnew: print via pager (unless --xml or -s is active)+    * darcs apply: print "reading from stdin" unless --quiet+    * darcs send: include all the information when reporting exceptions+    * print name of patch bundle for obliterate --output++  * Deliberate API changes to support darcsden:+    * export getPrefLines+    * export a simplified version of getLogInfo+    * export runWithHooks instead of recordConfig and RecordConfig++  * Documentation/help changes:+    * extend help text for darcs show and darcs convert+    * re-word some option descriptions+    * improve the (top level) usage text+    * update help for defaults file(s)+    * add subcommand 'darcs help preferences'+    * improve help for _darcs/prefs/sources+    * darcs diff: fix help for --unified option+    * fix manpage formatting of bullet lists+    * fix docs and description for the status command+    * automatically format (most) help texts to 80 chars per line+    * replace initial blurb in the manpage+    * unify warning hints for history editing commands+    * move debugging options to the end of the advanced options+    * shorten the help for alias commands+    * add extended help for rebase super command+    * include help for super commands in the man page+    * group --reorder under the merge options and improve its help text+    * bring help text for 'darcs repair' up to date+    * darcs.cabal: fix license and reword package description++Darcs 2.14.5, 6 August 2020++  * Resolve issue2650++    This is a stupid and rather unfortunate bug that affects all previous+    versions of the 2.12 and 2.14 branch. It can lead to corruption of the+    _darcs/format file in repos where *future* darcs versions add an+    alternative format property. The bug affects commands rebase suspend,+    rebase pull, and rebase apply.++    It is possible to manually fix the corruption by deleting from+    _darcs/format strings of the form "Unknown property: ". Future releases+    will contain a work-around that automatically fixes this particular kind+    of corruption when reading the format file, in case it should ever+    happen in practice. Nevertheless we strongly recommend to upgrade and+    avoid using the darcs versions affected by this bug.++Darcs 2.14.4, 28 April 2020++  * Restored the ability to run our shell tests, at least when building+    directly from a clone of our darcs repo. This was done by importing an+    old version of shelly (1.7.1, the last that worked for us on Windows),+    so that (modern) cabal picks that version instead of the newest one from+    hackage. Then made it build with all supported ghc versions and fixed+    all warnings.+  * Fix the quick-and-dirty "solutions" to the MonadFail incompatibility+    that replaced fail with error to avoid cascading MonadFail requirements+    all over the place. This broke a number of our tests, proving it to be+    semantically unsound, as I had expected. In most cases the correct+    solution was to replace it with (throw . userError), or if possible with+    (liftIO . fail).++Darcs 2.14.3, 24 April 2020++  * Support for GHC 8.8 and GHC 8.10+  * Loosen upper bounds for a few dependencies+  * mitigate issue 2643 (corrupt patch index) with a better error message+  * remove our own optimisation settings in darcs.cabal+  * Setup.hs: allow use of darcs as a cabal subproject++Darcs 2.14.2, 26 January 2019++  * Support GHC 8.6 (Ganesh Sittampalam)+  * Some other dependency bumps (Ganesh Sittampalam)+  * Fixed the following bugs:+    * 2617 convert import crashes with out-of-order tags (Ben Franksen)++Darcs 2.14.1, 24 June 2018++  * Some dependency bumps (Ganesh Sittampalam, Ben Franksen, Guillaume Hoffmann)+  * Windows test fixes (Ganesh)+  * Fixed the following bugs:+    * 2588 clone creates target repo with wrong permissions (Ben)++Darcs 2.14.0, 4 April 2018++  * fix encoding business, make DARCS_DONT_ESCAPE_8BIT=1 default (Ben, Ganesh Sittampalam)+  * show explicit dependencies in `darcs log -s` (Gian Piero Carrubba)+  * improve bash/zsh completion (Ben, Gian Piero)+  * no longer print an error message when ctrlc'ing pager (Guillaume Hoffmann)+  * `darcs help markdown` mentions all files in `_darcs/prefs/` (Guillaume)+  * add patch index status to `show repo` command (Ben)+  * per-file conflict marking (Ben Franksen)+  * make it possible to use DARCS_SCP=rsync (Ben)+  * add --not-in-remote option to unrecord command (Ben)+  * plug memory leak and improve efficiency in annotate (Ben)+  * save unneeded FL/RL reverses in SelectChanges module (Ben)+  * optimize token replace code and --look-for-replaces (Ben)+  * no longer show conflicting files on `whatsnew -s`, will reintrodue this+    feature when it is done efficiently (Guillaume)+  * separate display and storage of patches (Ben)+  * support GHC 8.2 and GHC 8.4 (Ganesh)+  * many refactorings in Darcs.Repository modules and API (Ben, Guillaume)+  * no longer track build dependencies in Setup.hs, nor use+    alpha, beta, rc names (Guillaume)+  * refactor `pull --reorder-patches` (Ben)+  * refactor SelectChanges (Ben)+  * remove Patchy typeclass and redundant constaints where possible (Guillaume)+  * fix build with cabal new-build (Francesco Ariis)+  * unit and quickcheck tests for inventories (Ben)+  * throw out all access to bytestring internals from Darcs.Util.ByteString (Ben)+  * refactor, simplify, and document hunk application (Ben)+  * drop support of old cache location and SHA1-hashed repos (Guillaume)+  * rely on GHC's own stack traces for bug reporting (Guillaume)+  * fixed the following bugs:+    * fix mail encoding with '.' or '=' as last character (Timo von Holtz)+    * 2526: whatsnew -l --boring should list boring files (Ben)+    * 2208: replace detects existing force hunks in working (Ben)+    * 2512: author name is written to repository after multiple-choice+      prompt (Stephan-A. Posselt)+    * 2359: convert --export mishandles Unicode filenames (Ben)+    * 2545: prevent argument smuggling in SSH repository URLs (Gian Piero)+    * 2581: fix rebase pull --reorder (Ben)+    * 2575: fix unrevert with rebase (Ben)+    * 2579: allow darcs send to work even if no MTA is installed+    * 2555: include explicit dependencies in the output of `log -v` (Gian Piero)+    * 2569: decoding multibyte characters (Ben)+    * 2563: create remote repo in correct format in ssh tests (Ben)+    * 2565: create _darcs dir after searching for an existing one (Ben)+    * 2567: darcs whatsnew --unified (Ben)+    * 2566: avoid renaming across file systems (Ben)+    * 2564: delete wrong and irrelevant propConcatPS (Guillaume)+    * 2559: remove trailing empty lines in patch header edition (Guillaume)+    * 2536: mask out internal matchers in `show files` routing logic (Gian Piero)+++Darcs 2.12.5, 11 January 2017++ * Bump some dependency upper bounds (Ganesh Sittampalam)+ * Fix issue2516 - failure cloning from URLs on Windows (Ben Franksen)+++Darcs 2.12.4, 14 September 2016++ * *really* fix compile error under Windows (Guillaume Hoffmann)+++Darcs 2.12.3, 10 September 2016++ * fix compile error under Windows (Guillaume Hoffmann)+++Darcs 2.12.2, 7 September 2016++ * fix missing testsuite file in tarball (Guillaume Hoffmann)+++Darcs 2.12.1, 5 September 2016++ * fix building with GHC 8+ * drop support for GHC 7.6 and 7.8, i.e., require GHC 7.10+ * improvements in `darcs whatsnew` output with irrelevant files (Ben Franksen)+++Darcs 2.12.0, 29 April 2016++ * `darcs show dependencies`: export patch dependency graph as dot file (Ale Gadea)+ * improvements in `record` output with irrelevant files (Ben Franksen)+ * `darcs log -v --machine-readable`: show internal representation of+   patches (including explicit dependencies). Remove patch viewing via the+   `annotate` command. (Guillaume Hoffmann)+ * `whatsnew -s` (and `status`) show conflicting files (Guillaume Hoffmann)+ * honor "quiet" flag in command outputs (Ben Franksen)+ * a single `show patch-index` command (Guillaume Hoffmann)+ * remove deprecated aliases of show (Guillaume Hoffmann)+ * handle file moves natively when importing from git (Owen Stephens)+ * require GHC 7.6 (base > 4.6) and support GHC 8 (Ganesh Sittampalam)+ * switch to sandi from dataenc (Daniil Frumin)+ * remove hack to enable arbitrary protocols via env variables (Guillaume Hoffmann)+ * fixed the following bugs:++    * 1807: clarify help of PAGER, DARCS_PAGER (Guillaume Hoffmann)+    * 2258: improve patch index error message with suggestion (Guillaume Hoffmann)+    * 2269: push hijack test to suspend time (Eric Kow)+    * 2276: Keep track of patch hijack decisions (Eric Kow)+    * 2138: report conflicting files in whatsnew -s (Guillaume Hoffmann)+    * 2393: remove whatsnew functionality from annotate (Guillaume Hoffmann)+    * 2400: use async package to keep track of unpack threads (Ben Franksen)+    * 2459: fall back to writing the file if createLink fails (Ben Franksen)+    * 2479: root dir most not be among the sources of a move (Ben Franksen)+    * 2481: expose API for 'darcs diff' command (Ganesh Sittampalam)+    * 2486: obliterate --not-in-remote -q should be more quiet (Ben Franksen)+    * 2489: dequote filepaths while importing from git (Guillaume Hoffmann)+    * 2494: output of darcs record with file arguments (Ben Franksen)+++Darcs 2.10.3, 29 January 2016++ * implement weak repository hash and show it in "darcs show repo"+ * implement "whatsnew --machine-readable" for more parsability+ * enhance Git import: empty directories, unescape file names, unnamed commits+ * make commit an alias for record+ * expose API for "darcs diff"+ * force grep to treat output of locale as text+ * bump dependencies: vector, process, HUnit, binary, transformers, time, HTTP,+   transformers-compat+++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++   * darcs rebase: enable deep amending of history+   * darcs pull --reorder: keep local-only patches on top of mainstream patches+   * darcs dist --zip: generate a zip archive from a repository+   * patch bundle contexts are minimized by default.+   * darcs convert export/import for conversion+     to/from VCSes supporting the fast-export protocol+   * darcs test --backoff: exponential backoff test strategy,+     faster than bisect on big repositories+   * work normally on sshfs-mounted repositories+   * automatic detection of file/directory moves, and of token replaces+   * patience diff algorithm by default+   * interactive mode for whatsnew+   * tag --ask-deps: create tags that may not include some patches+   * add a last question after all patches have been selected to confirm+     the whole selection+   * command names:+     * `clone` is the new name of `get` and `put`+     * `log`   is the new name of `changes`+     * `amend` is the new name of `amend-record`+   * show output of `log` into a pager by default+   * the output of `log` is more similar to git's:+     * show patch hash in UI (hash of the patch's metadata)+     * put author and date on separate lines+   * enable to match on patch hash prefix with -h and --hash+   * better messages:+     * better error messages for http and ssh errors+     * `init`, `add`, `remove`, `move` and `replace` print+       confirmation messages+   * `rollback` only happens in the working copy+   * `darcs send` no longer tries to send a mail by default+   * when no patch name given, directly invoke text editor+   * use nano as default text editor instead of vi+   * keep log files for patch name and mail content in _darcs+   * `optimize` and `convert` are now supercommands+   * improve `darcs help environment` and `darcs help markdown`+   * warn about duplicate tags when creating a new one+   * allow `darcs mv` into known, but deleted in working, file+   * improve` --not-in-remote`, allowing multiple repos and use default+   * faster `darcs diff`+   * faster `log` and `annotate` thanks to patch index data structure+   * faster push via ssh by using compression+   * cloning to an ssh destination (formerly `darcs put`) is more efficient+   * faster internal representation of patch hashes+   * when cloning from http, use packs in a more predictable way+   * store global cache in bucketed format+   * require and support GHC 7.4 to 7.10++ * Other issues resolved in Darcs 2.10++   * 346: implement "patience diff" from bzr+   * 642: Automatic detection of file renames+   * 822: generalized the IO Type for better error messages and exception handling+   * 851: interactive mode for whatsnew+   * 904: Fix record on Linux/FUSE/sshfs (fall back to sloppy locks automatically)+   * 1066: clone to ssh URL by locally cloning then copying by scp+   * 1268: enable to write darcs init x+   * 1416: put log files in tempdir instead of in working dir+   * 1514: send --minimize-context flag for send+   * 1624: bucketed cache+   * 1828: file listing and working --dry-run for mark-conflicts+   * 1987: Garbage collection for inventories and patches+   * 2181: put cache in $XDG_CACHE_HOME (~/.cache by default)+   * 2193: make that finalizeTentativeChanges no longer run tests+   * 2198: move repo testing code to Darcs.Repository.Test+   * 2200: darcs replace complains if no filepaths given+   * 2204: do not send mail by default+   * 2237: prevent patch index creation for non-hashed repos+   * 2235: Accept RFC2822 dates+   * 2246: add default boring entry for emacs session save files+   * 2253: attempting to use the patch index shouldn't create it on OF repos+   * 2278: Document default value for --keep-date / --no-keep-date+   * 2199: getMatchingTag needs to commute for dirty tags+   * 2247: move patch index creation into the job running code+   * 2238: let optsModifier remove all occurrences of LookForAdds+   * 2236: make 'n' an alias for 'q' in lastregret questions+   * 2155: Expurgate the non-functional annotate --xml-output option+   * 2248: always clean up rebase-in-progress state+   * 2270: fixed darcs changes -i --only-to-files+   * 2282: don't allow remote operations to copy the rebase patch+   * 2287: obliterate -O doesn't overwrite existing file.+   * 2227: move the rebase patch to the end before an amend-record+   * 2277: rebase suspend and unsuspend supports --summary.+   * 2311: posthook for 'get' should run in created repo+   * 2312: posthooks for 'record' and 'amend-record' should receive DARCS_PATCHES+   * 2163: new option for amend, select author for patch stealing.+   * 2321: when no patch name given, directly invoke text editor+   * 2320: save prompted author name in ~/.darcs/author instead of ./_darcs/prefs/author+   * 2250: tabbing in usageHelper - pad by max length of command name+   * 2309: annotate includes line numbers+   * 2334: fix win32 build removing file permission functions+   * 2343: darcs amend-record does not record my change+   * 2335: one liner when adding tracked files if not verbose+   * 2313: whatsnew -l: Stack space overflow+   * 2347: fix amend-record --prompt-long-comment+   * 2348: switch to cabal's test framework+   * 2209: Automatically detect replace+   * 2332: ignore case of characters in prompt+   * 2263: Option --set-scripts-executable is not properly documented+   * 2367: rename amend-record to amend, make --unrecord more visible+   * 2345: solution using cabal's checkForeignDeps+   * 2357: switching to regex-compat-tdfa for unicode support+   * 2379: only use packs to copy pristine when up-to-date+   * 2365: correctly copy pristine in no-working-dir clones+   * 2244: darcs tag should warn about duplicate tags+   * 2364: don't break list of 'bad sources'+   * 2361: optimize --reorder runs forever with one repository+   * 2364: fix file corruption on double fetch+   * 2394: make optimize a supercommand+   * 2396: make convert a supercommand and enhance help strings+   * 2314: output-auto-name in defaults file+   * 2388: check if inventories dir has been created+   * 2249: Rename isFile to isValidLocalPath and WorkRepoURL to WorkRepoPossibleURL+   * 2153: allow skipping backwards through depended-upon patches+   * 2380: allow darcs mv into known, but deleted in working, file+   * 2403: need to avoid moving the rebase patch to the end+   * 2409: implement darcs rebase apply+   * 2385: invoke pager without temporary file+   * 2333: better error message when pushing and darcs not in path+++Darcs 2.8.5, 25 August 2014++ * GHC 7.8 support+ * Resolved issue2364: Download problems with GHC 7.8+ * Support matching on short patch hash+ * Resolved issue2345: Fix bug where configure script reported missing libiconv rather than libcurl+++Darcs 2.8.4, 7 February 2013++ * GHC 7.6 support+ * Resolved issue2199: get --tag can include extra patches+ * Removed the --xml-output option to annotate which has been non-functional for a while+++Darcs 2.8.3, 4 November 2012++ *  Tweak the library to avoid a C symbol clash with cryptohash+++Darcs 2.8.2, 2 September 2012++ * Addition to the Darcs API to support darcsden+++Darcs 2.8.1, 14 May 2012++ * Bumped mtl dependency+ * Updated contact details to use development mailing list+++Darcs 2.8, 22 April 2012++ * Important changes in Darcs 2.8++   * Local support for the legacy "old-fashioned" repository format+        has been removed.+      * You can still work with remote repositories in this format+      * Local repositories can still be upgraded via "darcs optimize --upgrade".+   * "darcs annotate" is now significantly faster and uses less memory, although it still slows down linearly with repository size.+   * An experimental option is available to speed up HTTP downloads.+      * You can now use "darcs optimize --http" to create a repo optimized for HTTP downloads, and use "darcs get --packs" to download such a repo.+      * There are still some known issues with it, so the feature is not enabled by default.+   * Darcs now supports multiple email addresses for the author in the global prefs file. So, if you use different identities for home and work, you can now easily select between them. (issue1530)+   * The -o/-O options for obliterate which were removed in 2.5 are back.+   * "darcs status" has been added as a hidden alias for "darcs whatnew -ls" to ease the transition from some other source control systems. (issue182)+   * "darcs amend-record" now has the option --unrecord to allow individual changes to be unrecorded. (issue1470). This can also be used as "darcs amend-unrecord".+   * "darcs amend-record"'s interactive selection now supports 'k' for going back to a previous patch.+   * "darcs dist" now has the option --set-scripts-executable. (issue734)+   * pushing to ssh:// URLS is now supported. eg: darcs push ssh://code.haskell.org/foo+   * If a test fails during darcs record, you now have the option to record it anyway. (issue332)+   * Hunk-splitting now works in "darcs revert" (issue114)+   * Sending patches by email is now more robust and human friendly. We display a cleaner version in plain text for humans, and have added a complete version of the patch for "darcs apply". (issue1350)+   * "darcs send" now tries to report the right character set in the email headers, and has the option --charset to override this.+   * A new environment variable has been added to help control network connections: DARCS\_CONNECTION\_TIMEOUT. See the manual for details.+   * The --ephemeral and --partials options to "darcs get" has been removed. "darcs check --partial" has also been removed.+   * "darcs rollback" now has a --no-record option, to be used when you only want to update the working directory.+   * The --nolinks option for "darcs get" was removed.+   * The "--old" flag has been removed for "darcs init", "darcs get" and "darcs put".+   * "darcs resolve" has been removed an alias for "darcs mark-conflicts".+   * "darcs init" and "darcs get" now have a --no-working-dir option.+   * Conflicts are now marked with red in the terminal. (issue1681)+   * ssh ControlMaster support has been removed.+   * ssh stderr output is now passed through, making it easier to diagnose problems. (issue845)+   * Interactive selection now has a 'g' command to go to the first patch.+   * The --unified flag is now available for record, end-record, revert and unrevert (issue1166)+   * darcs now has a "darcs test" command for running whatever test-suite is associated with the repository.++ * Other issues resolved in Darcs 2.8++   * 1266: "darcs init" now warns when run inside another darcs repo.+   * 1344: When using darcs send, let users know sooner if they won't eventually be able to send+   * 1397: darcs changes /bad /paths no longer lists all changes+   * 1473: problem with annotate --repodir+   * 1551: Now we only use 'file content did not change' prompt for darcs send+   * 1558: xml output for patch hash no longer includes "gz" extension+   * 1599: automatically expire unused caches+   * 1637: When darcs get fails due to a HTTP failure, port the actual HTTP failure.+   * 1640: darcs apply --verbose docs have been improved+   * 1661: darcs add --quiet is quieter+   * 1705: fix error with unhandled --index in "darcs show contents"+   * 1714: provide more sensible behavior when combining an "ALL" default with a default for a specific sub-command+   * 1727: a better diagnostic message is provided when the user tries to move the root of the repository+   * 1740: "darcs mv" now gracefully the handles the case where the user first does an "mv" on a directory and then follows up with a "darcs mv"+   * 1804: The diagnostic message "getSymbolicLinkStatus: does not exist" has been improved+   * 1883: rename --patch-name option to --name. This is usually used in darcs record in shorthand (-m) form. This rename is aimed at eliminating the confusion with the patch matcher, which bites amend-record and rollback users.+   * 1884: darcs get was wrongly reporting "getting lazy repository" when you hit C-c+   * 1908: try to create a global cache before checking its availability+   * 1922: Fixed bug where obliterate -o was producing incorrect bundles in some cases+   * 1923: bad source warning mechanism no longer warns about sources outside your control+   * 1932: Handling of files with colons is improved+   * 1965: attempting "darcs move" on non-repo files now gives a sensible error+   * 1977: "darcs repair" now no longer complains if the pristine.hashed directory is missing+   * 1978: Improve handling of the _darcs/format file with "darcs get"+   * 1984: "darcs convert" now gives a better error message for invalid repo names+   * 2013: "darcs send" no longer ignores --to (or default recipient) with --context+   * 2021: character encoding handling has been improved+   * 2041: "darcs add" no longer follows directory symlinks+   * 2054: The behavior when combining --boring with a boring file has been improved+   * 2066: "darcs record" better handles adding deleted and added files passed on the command line+   * 2067: darcs diff no longer outputs blank lines when non-existent files are given+   * 2076: "darcs move myfile" into directory confuses darcs+   * 2077: "darcs mv myfile" into directory no longer confuses darcs+   * 2079: "darcs put" now does --set-default by default+++++Darcs 2.5.2, 14 March 2011++ * Important changes in Darcs 2.5.2++   * compatible with Haskell Platform 2011.2.0.0+   * bump parsec dependency for HP compatibility+   * fix regression allowing to add files inside boring directories++ * Issues resolved in Darcs 2.5.2++   * 2049: Darcs regression: 2.5 creates a broken patch++Darcs 2.5.1, 10 February 2011++ * Important changes in Darcs 2.5.1++   * original text is included in conflict marks+   * GHC 7.0 is supported+   * the version of GHC is restricted in the cabal file+   * warning message about old-fashioned repositories points to wiki+   * non-repository paths are guarded+   * library API: program name is configurable+   * darcs send prints the remote repository address right away+   * informational message about --set-default is disabled with --no-set+   * _darcs/format is correctly handled on get+   * linking libdarcs on Windows is fixed++ * Issues resolved in Darcs 2.5.1++   * 1978: get does not correctly treat _darcs/format+   * 2003: Message about --set-default should be optional+   * 2008: build with GHC 7.0+   * 2015: linking with libdarcs broken under Windows (2.5.0)+   * 2019: allow building with mtl 2+   * 2035: darcs accepts fake subpaths (relative paths outside of the repo)++Darcs 2.5, 30 October 2010:++ * Important changes in Darcs 2.5++   * trackdown can now do binary search with the --bisect option+   * darcs always stores patch metadata encoded with UTF-8+   * diff now supports the --index option+   * amend-record now supports the --ask-deps option+   * apply now supports the --match option+   * amend-record has a new --keep-date option+   * inventory-changing commands (like record and pull) now operate in+     constant time with respect to the number of patches in the repository+   * the push, pull, send and fetch commands no longer set the default+     repository by default+   * the --edit-description option is now on by default for the send command++ * Issues resolved in Darcs 2.5++   * 64:   store metadata as UTF-8+   * 121:  add --ask-deps support to amend-record+   * 643:  darcs send -o outputs remote repo email address+   * 1159: avoid bogus repository cache entries+   * 1176: caches interfere with --remote-repo flag+   * 1208: add trackdown --bisect+   * 1210: global cache gets recorded in _darcs/prefs/sources+   * 1232: darcs convert copies _darcs/prefs/prefs+   * 1250: check for newlines in setpref values+   * 1277: percolate repository format errors correctly+   * 1288: the main darcs code now compiles and runs with witnesses+   * 1290: support diff --index+   * 1337: don't show unrelated patches in darcs changes on untracked path+   * 1389: change predist pref to point people to use 'cabal sdist'+   * 1427: accept gzipped patch bundles in darcs apply+   * 1456: make dist write more portable archives+   * 1473: make annotate accept '.' as argument+   * 1503: prefer local caches to remote ones+   * 1713: shorter interactive prompts+   * 1716: allow mail header lines of all whitespace in test+   * 1719: do not back up files when no conflict markers are inserted+   * 1726: don't consider all files with _darcs prefix boring+   * 1739: make ColorPrinter handle characters > 255+   * 1763: use correct filename encoding in conflictors+   * 1765: refuse to remove non-tracked directories recursively+   * 1769: add support for --match 'comment ...'+   * 1784: push and pull print remote address right away+   * 1815: work around Cabal sdist permissions issue+   * 1817: fix support for external merge tools+   * 1824: avoid PACKAGE_VERSION under Windows+   * 1825: do not omit important prims in unrecordedChanges w/ files+   * 1860: (un)applying move patches doesn't corrupt pristine+   * 1861: fix typo in --no-boring help+   * 1874: recognise network tests on cabal test command line+   * 1875: avoid accidentally setting default+   * 1879: notice unexpected commute failure on merge+   * 1887: add a missing newline to --list-options output+   * 1893: move fields of conditional builds within scope of condition+   * 1898: notify user when they can use set-default+   * 1913: sort changes in treeDiff++Darcs 2.4.4, 9 May 2010++ * Important changes in Darcs 2.4.4++   * darcs builds on Windows with GHC 6.10 (and GHC 6.12).+   * darcs (built with GHC 6.12 on Windows) works with SSH again++ * Issues resolved in Darcs 2.4.4++   * 1814: Apply binary mode to ssh process and patch file handles.+++Darcs 2.4.3, 9 May 2010++ * Important changes in Darcs 2.4.3++   * darcs builds on Windows with GHC 6.12.++Darcs 2.4.2, 8 May 2010++ * Important changes in Darcs 2.4.2++   * darcs will no longer give "mmap of _darcs_index" errors on Windows+   * darcs convert performance regression (against 2.3.x) solved+   * darcs get --partial no longer produces inconsistent repositories++ * Issues resolved in Darcs 2.4.2++   * 1761: mmap of '_darcs/index' failed on Windows mapped drives+   * 1814: include contrib/darcs-errors.hlint in release tarball+   * 1823: read (mmap) _darcs/index file correctly on Windows+   * 1826: error building on Windows with GHC 6.12+   * 1837: inconsistent repository upon darcs get --partial++Darcs 2.4.1, 31 March 2010++ * Important changes in Darcs 2.4.1++   * darcs works again on Windows shared directories+   * missing documentation and test files have been added to the tarball+   * darcs will no longer give errors about a nonexistent file when compiled+     with the wrong mmap+   * moving files between directories can no longer break the directory index+   * darcs handles the case that someone uses 'remove -r' on an+     untracked directory++ * Bugs Fixed in Darcs 2.4.1++   * 1750: uncover help text for 'darcs show pristine'+   * 1753: restrict mmap to version used by hashed-storage+   * 1754: fix issue458.sh on systems with xattrs+   * 1756: moving files between directories breaks index+   * 1757: add test files to distribution tarball+   * 1765: refuse to remove non-tracked directories recursively+   * 1767: send CRC erros to standard error+++Darcs 2.4, 27 February 2010++ * Important changes in Darcs 2.4++   * Use fast index-based diffing everywhere (Petr)+   * Interactive patch splitting (Ganesh)+   * An 'optimize --upgrade' option to convert  to hashed format in-place+     (Eric)+   * Hunk matching (Kamil Dworakowski, tat.wright)+   * Progress reporting is no longer deceptive (Roman)+   * A 'remove --recursive' option to remove a directory tree from revision+     control (Roman)+   * 'show files' accepts arguments to show a subset of tracked files (Luca)+   * A '--remote-darcs' flag for pushing to a host where darcs isn't called+     darcs+   * Many miscellaneous Windows improvements (Salvatore, Petr and others)+   * 'darcs send' now mentions the repository name in the email body (Joachim)+   * Handle files with boring names in the repository correctly (Petr)+   * Fix parsing of .authorspellings file (Tomáš)+   * Various sane new command-line option names (Florent)+   * Remove the '--checkpoint' option (Petr)+   * Use external libraries for all UTF-8 handling (Eric, Reinier)+   * Use the Haskell zlib package exclusively for compression (Petr)++ * Bugs Fixed in Darcs 2.4++   *  183: do not sort changes --summary output+   *  223: add --remote-darcs flag to specify name of remote darcs executable+   *  291: provide (basic) interactive patch splitting+   *  540: darcs remove --recursive+   *  835: 'show files' with arguments+   * 1122: get --complete should not offer to create a lazy repository+   * 1216: list Match section in ToC+   * 1224: refuse to convert a repo that's already in darcs-2 format+   * 1300: logfile deleted on unsucessful record+   * 1308: push should warn about unpulled patches before patch-selection+   * 1336: sane error message on --last "" (empty string to numbers parser)+   * 1362: mention repo name in mail send body+   * 1377: getProgname for local darcs instances+   * 1392: use parsec to parse .authorspelling+   * 1424: darcs get wrongly reports "using lazy repository" if you ctrl-c +           old-fashioned get+   * 1447: different online help for send/apply --cc+   * 1488: fix crash in whatsnew when invoked in non-tracked directory+   * 1548: show contents requires at least one argument+   * 1554: allow opt-out of -threaded (fix ARM builds)+   * 1563: official thank-you page+   * 1578: don't put newlines in the Haskeline prompts+   * 1583: on darcs get, suggest upgrading source repo to hashed+   * 1584: provide optimize --upgrade command+   * 1588: add --skip-conflicts option+   * 1594: define PREPROCHTML in makefile+   * 1620: make amend leave a log file when it should+   * 1636: hunk matching+   * 1643: optimize --upgrade should do optimize+   * 1652: suggest cabal update before cabal install+   * 1659: make restrictBoring take recorded state into account+   * 1677: create correct hashes for empty directories in index+   * 1681: preserve log on amend failure+   * 1709: fix short version of progress reporting+   * 1712: correctly report number of patches to pull+   * 1720: fix cabal haddock problem+   * 1731: fix performance regression in check and repair+   * 1741: fix --list-options when option has multiple names+   * 1749: refuse to remove non-empty directories+++Darcs 2.3.1, 20 Sep 2009++ * Important changes in Darcs 2.3.1++   * Fix bugs introduced by optimizations in 2.3.0 (Petr, Salvatore)+   * Documentation improvements (Taylor, Trent)+   * Remove autoconf build system (Petr)++ * Bugs Fixed in Darcs 2.3.1++   See http://bugs.darcs.net/issueN for details on bug number N.++   * issue1373 darcs manual wrongly promises [^ ] is a valid token spec (Trent)+   * issue1478: document summary mnemonics (Trent)+   * issue1582 DeleteFile: permission denied (Access is denied.) (Salvatore)+   * issue1507 whatsnew does not use 'current' when 'pristine' is missing (Petr)+++Darcs 2.3.0, 23 Jul 2009++ * Important changes in Darcs 2.3.0++   * Lots and lots of documentation changes (Trent).+   * Haskeline improvements (Judah).+   * Cabal as default buildsystem (many contributors).+   * Fixes in darcs check/repair memory usage (Bertram, David).+   * Performance improvement in subtree record (Reinier).+   * New option: --summary --xml (Florian Gilcher).+   * New option: changes --max-count (Eric and Petr).+   * Fix changes --only-to-files for renames (Dmitry).+   * Performance fix in "darcs changes" (Benedikt).+   * Hardlinks on NTFS (Salvatore).+   * Coalesce more changes when creating rollbacks (David).+   * New unit test runner (Reinier).+   * Inclusion of darcs-shell in contrib (László, Trent).+   * Author name/address canonisation: .authorspellings (Simon).+   * Working directory index and substantial "darcs wh" optimisation (Petr).+   * New command: "darcs show index" (Petr).+   * Gzip CRC check and repair feature (Ganesh).++ * Bugs Fixed in Darcs 2.3.0++   See http://bugs.darcs.net/issueN for details on bug number N.++   *  948 darcsman (Trent)+   * 1206 countable nouns (Trent)+   * 1285 cabal test v. cabal clean (Trent)+   * 1302 use resolved, not resolved-in-unstable (Trent)+   * 1235 obliterate --summary (Rob)+   * 1270 no MOTD for --xml-output (Lele)+   * 1311 cover more timezones (Dave)+   * 1292 re-encoding haskeline input (Judah)+   * 1313 clickable ToC and refs in PDF manual Trent)+   * 1310 create merged \darcsCommand{add} (Trent)+   * 1333 better "cannot push to current repository" warning (Petr)+   * 1347 (autoconf) check for unsafeMMapFile if mmap use enabled (Dave)+   * 1361 specify required includes for curl in cabal file (Reinier)+   * 1379 remove libwww support (Trent)+   * 1366 remove unreachable code for direct ncurses use (Trent)+   * 1271 do not install two copies of darcs.pdf (Trent)+   * 1358 encode non-ASCII characters in mail headers (Reinier)+   * 1393 swap "darcs mv" and "darcs move" (Trent)+   * 1405 improve discoverability of global author file (Trent)+   * 1402 don't "phone home" about bugs (Trent)+   * 1301 remove obsolete zsh completion scripts (Trent)+   * 1162 makeAbsolute is now a total function (Ben F)+   * 1269 setpref predist - exitcode ignored bug (Ben M)+   * 1415 --edit-long-comment, not --edit-description, in help (Trent)+   * 1413 remove duplicate documentation (Trent)+   * 1423 complain about empty add/remove (Trent)+   * 1437 Implement darcs changes --max-count (Eric)+   * 1430 lazy pattern matching in (-:-) from Changes command module (Dmitry)+   * 1434 refactor example test (Trent)+   * 1432 refer to %APPDATA%, not %USERPROFILE% (Trent)+   * 1186 give a chance to abort if user did not edit description file (Dmitry)+   * 1446 make amend-record -m foo replace only the patch name (Dmitry)+   * 1435 default to get --hashed from a darcs-1.0 source (Trent)+   * 1312 update and reduce build notes (Trent)+   * 1351 fix repository path handling on Windows (Salvatore)+   * 1173 support hard links on NTFS (Salvatore)+   * 1248 support compressed inventories for darcs-1 repos (Ganesh)+   * 1455 implement "darcs help environment" (Trent)+++Darcs 2.2.0, 16 Jan 2009++ * Important changes in Darcs 2.2.0++   * Support for GHC 6.10.+   * Improved Windows support.+   * Cabal is now supported as a build method for darcs.+   * Low-level optimisations in filesystem code.+   * Overhaul of the make-based build system.+   * Extensive manual and online help improvements.+   * Improved API documentation (haddock) for existing darcs modules.+   * Improvements in the testing infrastructure.+   * Improved performance for "darcs repair".+   * Improved robustness for "darcs check".+   * Numerous major and minor bug fixes, refactorings and cleanups.+   * When recording interactively it is now possible to list all+     currently selected hunks (command 'l').++   * It is now possible to specify --in-reply-to when using darcs send,+     to generate correct references in the mail header.++   * Repositories can no longer be created with --no-pristine-tree.+     This only affects the legacy darcs-1 repository format.++   * Experimental Darcs library, providing increase flexibility and+     efficiency to third-party utilities (compared to the command-line+     interface).  Only built via Cabal.  NOT a stable API yet.++ * Bugs Fixed in Darcs 2.2.0++   See http://bugs.darcs.net/issueN for details on bug number N.++   *  525 amend-record => darcs patches show duplicate additions+   *  971 darcs check fails (case sensitivity on filenames)+   * 1006 darcs check and repair do not look for adds+   * 1043 pull => mergeAfterConflicting failed in geteff (2.0.2+)+   * 1101 darcs send --cc recipient not included in success message+   * 1117 Whatsnew should warn on non-recorded files+   * 1144 Add darcs send --in-reply-to or --header "In-Reply-To:...+   * 1165 get should print last gotten tag+   * 1196 Asking for changes in /. of directory that doesn't exist...+   * 1198 Reproducible "mergeConflictingNons failed in geteff with ix"+   * 1199 Backup files darcs added after external merge+   * 1223 sporadic init.sh test failure (2.1.1rc2+472)+   * 1238 wish: darcs help setpref should list all prefs+   * 1247 make TAGS is broken+   * 1249 2.1.2 (+ 342 patches) local drive detection on Windows error+   * 1272 amend-record not the same as unrecord + record+   * 1273 renameFile: does not exist (No such file or directory)+   * 1223 sporadic init.sh test failure (2.1.1rc2+472)+++darcs (2.1.2)++ * Quality Assurance: Disable a new test that was not yet working+   under Windows++ -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 10:40:00 GMT++darcs (2.1.1)++ -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 08:18:00 GMT++darcs (2.1.1rc2)++  * Portability: Removed accidental QuickCheck 2.1 configure check.+    Note that it may be required in a future version of darcs.++ -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 11:17:00 GMT++darcs (2.1.1rc1)++  * Portability: GHC 6.10.1 support (Petr Ročkai, Eric Kow)++  * Bug Fix: Fix file handle leak and check for exceptions on process+    running on Windows (issue784, Salvatore Insalaco)++  * Quality Assurance: Consolidated regression test suites using+    shell scripts only (Eric Kow, Tommy Petterson, Matthias Kilian)++ -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 09:49:00 GMT++darcs (2.1.0)++  * Bug Fix: Eliminate a 'same URLs with different parameters' error when+    fetching files over HTTP (issue1131, Dmitry Kurochkin)++  * User Experience: Corrections to the default boring file (Ben Franksen)++  * Bug Fix: Fix the %a option in darcs send --sendmail-command (Ben Franksen)++  * Bug Fix: Do not obscure the SSH prompts or text editor output with+    progress reporting (issue1104, issue1109, Dmitry Kurochkin, David Roundy)++  * Bug Fix: pull --intersection work now works as advertised (Tommy+    Pettersson)++ -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 09 Oct 2008 12:05:32 GMT++darcs (2.1.0pre3)++  * Bug Fix: Eliminate an error merging repeated conflicts in darcs-2+    repositories (issue1043, David Roundy)++  * New Feature: Hide 'Ignore-this:' lines which will be generated by future+    versions of darcs to prevent patch-id collisions. (issue1102, Eric Kow,+    David Roundy)++  * Bug Fix: Support darcs repositories which have symbolic links in their+    paths (issue1078, Dmitry Kurochkin)++  * Bug Fix: Make ssh connection sharing (darcs transfer-mode) work with+    old-fashioned repositories (issue1003, David Roundy)++ -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 02 Oct 2008 09:12:41 GMT++darcs (2.1.0pre2)++  * IMPORTANT: Create darcs-2 repositories by default in darcs init (issue806,+    David Roundy)++  * User Experience: Do not allow users to add files to a darcs repository if+    their filenames would be considered invalid under Windows. This can be+    overridden with the --reserved-ok flag (issue53, Eric Kow)++  * Bug Fix: Do not leave behind a half-gotten directory if darcs get fails+    (issue1041, Vlad Dogaru, David Roundy)++  * User Experience: notice when you are trying to pull from a seemingly+    unrelated repository, that is one with a sufficiently different history.+    This can be overridden with the --allow-unrelated-repos flag (Dmitry+    Kurochkin, David Roundy)++  * Bug Fix: Fix hang after a user input error (for example, EOF) (Judah+    Jacobson)++  * Quality Assurance: Improvements to documentation and online help (Simon+    Michael)++ -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 25 Sep 2008 08:10:49 GMT++darcs (2.0.3pre1)++  * New Feature: Optional readline-like functionality when compiled with the+    haskeline package (Judah Jacobson, Gaëtan Lehmann)++  * Bug Fix: No more spurious pending patches (issue709, issue1012, David+    Roundy)++  * Bug Fix: darcs get --to-match now works with hashed repositories+    (issue885, David Roundy)++  * User Experience: Catch mistakes in _darcs/prefs/defaults (issue691, Dmitry+    Kurochkin)++  * User Experience: Improved support for darcs send over http (see also+    tools/upload.cgi) (Dmitry Kurochkin, David Roundy)++  * Bug Fix: Recognize user@example.com: as an ssh path, that is, not+    requiring a path after the server component. (David Roundy)++  * New Feature: Accept an optional directory argument in darcs send+    --output-auto-name (Dmitry Kurochkin)++  * User Experience: New --no-cache option to help debug network issues+    (issue1054, Dmitry Kurochkin)++  * Performance: New --http-pipelining and --no-http-pipelining flags. Passing+    --http-pipelining to darcs can make darcs get and pull faster over HTTP.+    Due to a libcurl bug, this is not the default option unless darcs is+    compiled with libcurl 7.19.1, due 2008-11. (Dmitry Kurochkin)++  * Bug Fix: Eliminate hanging and crashes while fetching files over HTTP+    (issue920, issue977, issue996, issue1037, Dmitry Kurochkin)++  * Security: Fix some insecure uses of printfs in darcs.cgi (Steve Cotton)++  * Bug Fix: Handle filepaths in a simpler and more robust fashion. This fixes+    relative filepaths and recognition of symbolic links and avoids possible+    future bugs (issue950, issue1057, David Roundy, Dmitry Kurochkin)++  * Bug Fix: Make darcs diff --patch work even if the patch is within a tag+    (issue966, darcs 2 regression, Dmitry Kurochkin)++  * Quality Assurance: Extend use of Haskell's GADTs to most of the darcs+    code, fixing many potential bugs along the way (Jason Dagit, David Roundy)++  * Quality Assurance: Several improvements to darcs code quality (Petr+    Ročkai)++  * Bug Fix: Correct assumptions made by darcs about Windows file size types+    (issue1015, Simon Marlow, Ganesh Sittampalam)++  * Bug Fix: Support case insensitive file systems using hashed repositories+    in darcs repair (partial issue971, Petr Ročkai). IMPORTANT: This+    introduces a memory use regression, which affects large repositories. We+    found that doing a darcs repair on the GHC repository requires a machine+    with 2 GB of RAM. The regression is well-understood and should be solved+    in the next darcs release. In the meantime we felt that the improved+    robustness was worth the performance trade-off.++  * Quality Assurance: Simplify building darcs on Windows by optionally using+    the zlib and terminfo Haskell packages (Ganesh Sittampalam, Petr Ročkai)++  * User Experience: Better error reporting when patches that should commute+    fail to do so. (Jason Dagit)++  * New Feature: --match "touch filenames", for example --match 'touch+    foo|bar|splotz.*(c|h)' (issue115, Dmitry Kurochkin)++  * User Experience: Improve debugging and error messages in HTTP code (Dmitry+    Kurochkin, David Roundy)++  * Bug Fix: Ensure that darcs responds to Ctrl-C on Window, even if compiled+    with GHC < 6.10 (issue1016, Simon Marlow)++  * New Feature: darcs changes --context now also works with --human-readable+    and --xml-output (issue995, Dmitry Kurochkin)++  * Bug Fix: Always darcs send with context, as if --unified flag were used+    (was implemented in 2.0.2, but not consistently) (David Roundy)++  * Bug Fix: Make sure that darcs get --tag works even when the user hits+    Ctrl-C to get a lazy repository (Dmitry Kurochkin)++  * Quality Assurance: Improvements to documentation and online help, most+    crucially, user-focused help on upgrading to darcs 2. (Trent Buck, Lele+    Gaifax, Simon Michael, Max Battcher)++  * New Feature: darcs changes --number associates each patch with number,+    counting backwards (see the --index feature) (David Roundy)++  * New Feature: ability to match patches on index, for example, darcs changes+    --index=3-6 shows the last three to six patches (David Roundy)++  * User Experience: slightly reduce the verbosity of darcs pull --verbose+    (David Roundy)++ -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 18 Sep 2008 02:36:45 GMT++darcs (2.0.2)++ -- David Roundy <droundy@darcs.net>  Sun, 24 Jun 2008 01:20:41 GMT++darcs (2.0.1)++  * Bug Fix: Make Ctrl-C work even though darcs is now compiled to use the+    threaded runtime (issue916, David Roundy)++  * New Feature: Include patch count in darcs --version, for example, 2.0.1 (++    32 patches) (David Roundy)++  * Bug Fix: Avoid an error caused by renaming a file on case-insensitive+    file-systems (Eric Kow)++  * Bug Fix and New Feature: Improved XML output (Benjamin Franksen, Lele+    Gaifax, David Roundy)++  * User Experience: Always darcs send with context, as if --unified flag were+    used (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 23 Jun 2008 21:47:07 GMT++darcs (2.0.1rc2)++  * Performance: Faster strings, using Data.Bytestring by default (Gwern+    Branwen, Eric Kow, Ian Lynagh, David Roundy)++  * User Experience: On Windows, use MS-DOS 'edit' as a default editor if+    Emacs and friends are not available (Eric Kow)++  * Bug Fix: On Windows, notice when external programs fail to launch because+    they do not exist (Eric Kow)++  * New Feature: darcs put --no-set-default and --set-default (Nicolas+    Pouillard)++ -- David Roundy <droundy@darcs.net>  Sun, 13 Jun 2008 01:17:45 GMT++darcs (2.0.1rc1)++  * Bug Fix: Fix tag --checkpoint so that darcs get --partial can avoid+    fetching all patches (issue873, David Roundy)++  * User Experience: Better progress reporting [NB: darcs is now compiled with+    threaded runtime by default] (issue739, David Roundy, Bertram Felgenhauer)++  * Performance: Reduce memory usage of darcs put (David Roundy)++  * Bug Fix: Improved date matching (issue793, issue187, Eric Kow)++  * Performance: Fix an optimization in diff-detection (affects darcs whatsnew+    and record) (Pekka Pessi)++  * Quality Assurance: --enable-hpc for checking program coverage (Christopher+    Lane Hinson)++  * Bug Fix: Do not rollback if no primitive patches were selected (issue870,+    Eric Kow)++  * Bug Fix: Make it possible to --dry-run on repositories we cannot write to+    (issue855, Eric Kow, David Roundy)++  * Bug Fix: Avoid a race condition caused by cleaning out the pristine cache+    (issue687, David Roundy)++  * User Experience: When pushing, prints a small reminder when the remote+    repository has patches to pull (Eric Kow, David Roundy)++  * UI changes: --extended-help is now called --overview, no more+    --verify-hash, no more send --unified (David Roundy, Eric Kow)++  * User Experience: Show ssh's stderr output in case it wants to ask the user+    something (issue845, Eric Kow)++  * Bug Fix: Improved interaction with pager (David Roundy, Pekka Pessi, Eric+    Kow)++  * Bug Fix: darcs send -o - (Pekka Pessi)++  * Bug Fix: (regression) Re-enable darcs mv as a means of informing darcs+    about manual renames (issue803, David Roundy)++  * Bug Fix: Fix bugs related to use of threaded runtime (issue776, David+    Roundy)++  * Portability: Respect OS conventions in creation of temporary files (Eric+    Kow)++  * New Feature: Check for and repair patches which remove non-empty files+    (issue815, David Roundy)++  * Bug Fix: Make get --to-match work with hashed repositories (David Roundy)++  * Bug Fix: Conflict-handling with darcs-2 semantics (issue817, David Roundy)++  * Bug Fix: Make --ask-deps ask the right questions (Tommy Pettersson)++  * User Experience: Improved error messages and warnings (issue245, issue371,+    Nicolas Pouillard, David Roundy, Eric Kow)++  * New Feature: darcs trackdown --set-scripts-executable (Reinier Lamers)++  * Quality Assurance: Various improvements to documentation (issue76,+    issue809, Gwern Branwen, Lele Gaifax, Eric Kow, Nicolas Pouillard, David+    Roundy)++  * Bug Fix: Correct detection of incompatibility with future darcs (issue794,+    Eric Kow)++  * User Experience: Make darcs changes --interactive behave more like other+    interactive commands (Eric Kow)++  * Performance: Optimized handling of very large files (Gwern Branwen)++  * New Feature: Colorize added and removed lines, if the environment variable+    DARCS_DO_COLOR_LINES=True (Nicolas Pouillard)++  * New Feature: --remote-repodir flag to allow separate default repositories+    for push, pull and send (issue792, Eric Kow)++  * Performance: Optimized get --to-match handling for darcs 1 repositories+    (Reinier Lamers)++  * Bug Fix: Make changes --repo work when not in a repository (David Roundy)++  * New Feature: darcs changes --count (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 03 Jun 2008 12:43:31 GMT++darcs (2.0.0)++  * Fix silly bug which leads to darcs --version not showing release when it's+    a released version. (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 07 Apr 2008 15:06:38 GMT++darcs (2.0.0rc1)++ -- David Roundy <droundy@darcs.net>  Sun, 01 Apr 2008 15:44:11 GMT++darcs (2.0.0pre4)++  * When darcs encounters a bug, check version versus central server in order+    to decide whether to recommend that the user report the bug.++  * Display duplicate identical changes when using darcs-2 repository format.+    (Issue579)++  * Fix a bug in convert that lead to invalid tags in the converted+    repository. (Issue585)++  * Add an annoying warning when users run convert.++  * Numerous fixes to the time/date matching code, which should now work even+    in central Europe. (Eric Kow)++  * Add support for reading hashed repositories that use SHA256 hashes. The+    plan is to enable writing of SHA256 hashes in the next release. (David+    Roundy)++  * New Feature: Add a 'show authors' command (Eric Kow)++  * darcs.cgi improvements: Patch pages show "Who" and "When" some file+    annotation pages show "who" and "when" with a mouse-over. Also, darcs.cgi+    can now be hosted in a path containing The tilde character. (Zooko, Mark+    Stosberg)++  * User Experience: Improved and added many debugging, error and progress+    messages (David Roundy, Mark Stosberg, Eric Kow)++  * New Feature: New DARCS_PATCHES, DARCS_FILES and DARCS_PATCHES_XML+    environment variables are made available for the posthook system, allowing+    for more easier options to to integrate darcs with other systems. (David+    Roundy, Mark Stosberg)++  * Quality Assurance: Added and updated automated regression tests (Mark+    Stosberg, David Roundy, Eric Kow, Trent Buck, Nicolas Pouillard, Dave+    Love, Tommy Pettersson)++  * Bug Fix: Gzipped files stored in the repo are now handled properly (Zooko,+    David Roundy)++  * Quality Assurance: Various Documentation Improvements (issue347, issue55+    Mark Stosberg, Nicolas Pouillard, Marnix Klooster)++  * Bug Fix: With --repodir, commands could not be disabled (Trent Buck, David+    Roundy)++  * New Feature: tools/update_roundup.pl scripts allows the darcs bug tracker+    to be notified with a darcs patch resolving a particular issue is applied.+    A link to the patch in the web-based repo browser is provided in the+    e-mail notifying bug subscribers. (Mark Stosberg)++  * Internal: Begin work on memory efficiency improvements (David Roundy)++  * Performance: darcs is faster when identifying remote repos handling+    pending changes and running unrecord. (David Roundy)++  * Internal: Source code clean-up and improvements (David Roundy, Jason+    Dagit, Eric Kow, Mark Stosberg)++  * User Experience: A pager is used automatically more often, especially when+    viewing help. (Eric Kow)++  * Bug Fix: push => incorrect return code when couldn't get lock. (issue257,+    VMiklos, David Roundy, Eric Kow, Mark Stosberg)++  * Bug Fix: 'whatsnew' and 'replace' now work together correctly. (Nicolas+    Pouillard, David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 21 Mar 2008 15:31:37 GMT++darcs (2.0.0pre3)++  * Fix issue 244, allowing users of darcs changes to specify the new name of+    a file that has an unrecorded mv. (David Roundy, Mark Stosberg, Tuomo+    Valkonen)++  * Fix issue 600, bug in darcs optimize --relink. (David Roundy, Trent Buck,+    Mark Stosberg, Tommy Pettersson)++  * Add a new framework for outputting progress messages. If darcs takes more+    than about one second to run a command, some sort of feedback should now+    be provided. (David Roundy)++  * Rewrite rollback, changing its behavior to be more useful. Rollback now+    prompts for a name for the new "rollback" patches. It also allows you to+    roll back multiple patches simultaneously, and to roll back only portions+    of the patches selected. Altogether, rollback is now more interactive, and+    should also be more useful. (David Roundy)++  * Bug Fix: date parsing is now improved (Mark Stosberg, David Roundy)++  * Performance: Improved speed of darcs pull on very large repos. (David+    Roundy)++  * Fix issue 586, but in darcs repair on hashed and darcs-2 repositories.+    (Nicolas Pouillard)++  * Improve docs for 'darcs init' (Mark Stosberg)++  * Fix typo in test partial.sh which made part of the tests for --partial+    invalid. (Mark Stosberg)++  * Document that darcs handles some types of binary files automatically.+    (issue55, Mark Stosberg)++  * Fix typo in a test that made it compare a file to itself. (Mark Stosberg)++  * Document that single quotes should be used in .darcs/defaults. (issue347,+    Mark Stosberg)++  * New Feature: Automatically create the the global cache if we define we+    want to use it. (David Roundy, Trent Buck)++  * Performance: Improved HTTP pipelining support (Dmitry Kurochkin)++  * Fix issue 571, build failure when termio.h is not found. (Dave Love)++ -- David Roundy <droundy@darcs.net>  Sun, 22 Jan 2008 20:06:12 GMT++darcs (2.0.0pre2)++  * Add instructions in documentation for how to view patches in Mutt (a mail+    reader). (Gwern Branwen)++  * Fix build on Solaris. (Dave Love)++  * Added "auto-optimize" support for hashed inventories, in that darcs+    automatically optimizes inventories when it seems wise (which is currently+    defined as "every time we modify the inventory").++  * Fix expensive performance bugs involved in conflict handling. Thanks to+    Peter for pointing these out!.++  * Fix reading of hashed repositories to avoid reading patches that we don't+    actually need (i.e. foolish inefficiency bug). Thanks to Simon for+    reporting these performance bugs.++  * Added a new --debug flag for debug output.++  * Added compatibility with ghc 6.4. At this point darcs 2 should work with+    any ghc from 6.4 to 6.8.2.++  * Fix bug where parsing of setpref patch called tailPS unnecessarily. (David+    Roundy)++  * Refactor parsing of commands and command line arguments. Implement hidden+    commands. (Eric Kow)++  * Use a single command to initialize a remote repository. This replaces the+    method of stringing together multiple commands with the shell-dependent &&+    operator. (Tristan Seligmann)++  * Allow for files in _darcs/inventories to be gzipped. This is not+    specifically related to issue553, but it fixes a regression introduced by+    the issue553 fix. (Issue553, Eric Kow)++  * Check for potential hash collision in writeHashFile. (Eric Kow)++  * Don't try to write hash file if it already exists, as you can not+    overwrite an open file on Windows. (Issue553, Eric Kow)++  * Close file handles when done reading it lazily. (Eric Kow)++  * Modernize and enhance buggy renameFile workaround by using the+    hierarchical library structure and only catching 'does not exist' errors.+    (Eric Kow)++  * Add "hidden" printer for decorating patches with color for easier reading+    when printed to screen during verbose or debug output, but hides (removes)+    the decoration when printing to the repository files. This is the+    counterpart of the invisible printer, which makes non-human-friendly patch+    contents invisible when printed to the screen. (David Roundy)++  * Add "hidden" printer, for printing things to screen but not file. (David+    Roundy)++  * Make darcs distinguish between repository sub paths and "normal" relative+    paths. Better handling of absolute paths. (Eric Kow)++  * Fix some bugs introduced by Better handling of file paths. (Eric Kow)++  * Handle corner case when polling from self. (issue354, issue358, Eric Kow)++  * Handle corner cases when pulling from current repository. (Issue354,+    Issue358, Eric Kow)++  * Fix bug in make_dotdots when pushing from a sub directory. (issue268, Eric+    Kow)++  * Fix bug in make_dotdots when pushing from a subdirectory. (Issue268, Eric+    Kow)++  * Better handling of file paths. Distinguish between paths to files+    belonging to the repository as well as not belonging to the repository,+    both in absolute and relative form. (Eric Kow)++  * Add path fixing to darcs send, and don't try sending to self. (issue427,+    Eric Kow)++  * Fix path issue for darcs send. (Issue427, Eric Kow)++  * Disable mmap under Windows. (issue320, Eric Kow)++  * Backup unmanaged working dir files as needed. (issue319, issue440, Eric+    Kow)++  * Backup unmanaged files in the working directory when they are overwritten+    by managed files with the same names in pulled or applied patches.+    (Issue319, Issue440, Eric Kow)++  * Offer some advice if sendmail failed. (issue407, Eric Kow)++  * Document behavior of "boring" managed files. (Issue259, Eric Kow)++  * Make Doc a newtype, so we can define a Show instance. (David Roundy)++  * Make make_changelog GHC 6.8 compliant. (Ganesh Sittampalam)++  * GHC 6.8 needs containers package. (Ganesh Sittampalam)++  * Configure hack to deal with openFd -> fdToHandle' renaming in GHC 6.8.+    (Ganesh Sittampalam)++  * Make makefile summarize calls to GHC when compiling. VERBOSE=1 turns the+    long format back on. (Eric Kow)++  * When building, print summarized call to GHC in makefile, instead of very+    long command lines with many boring options. VERBOSE=1 reverts to showing+    options again. (Eric Kow)++  * Add svg logo. (David Roundy)++  * Add mercurial files to the default boring file. (David Roundy)++  * Add patterns for mercurial files to default boring patterns. (David Roundy)++  * Define color versions of traceDoc and errorDoc for debugging. (David+    Roundy)++  * Clarify error message for --last. (issue537, Eric Kow)++  * Clarify in error message that darcs option --last requires a *positive*+    integer argument. (Issue537, Eric Kow)++  * Optimize getCurrentDirectorySansDarcs a little. (Eric Kow)++  * Never create temporary directories in the _darcs directory. (issue348,+    Eric Kow)++  * Never create temporary directories in the _darcs directory. (Issue348,+    Eric Kow)++  * Make revert short help less cryptic. (Eric Kow)++  * Make revert short help less cryptic. (Eric Kow)++  * Make --checkpoint short help more explicit. (issue520, Eric Kow)++  * Make --checkpoint short help more explicit. (Issue520, Eric Kow)++  * Add format infrastructure for darcs-2 repo format. (David Roundy)++  * Always optimize the inventory in 'darcs tag'. (Eric Kow)++  * Fix bug in Tag --checkpoint where the inventory was not updated. (Eric Kow)++  * Fix accidental regression of --no-ssh-cm flag. (Eric Kow)++  * Move conditional #include from Darcs.External to makefile. The GHC manual+    says that this is *not* the preferred option, but for some reason, the+    include pragmas seem to get ignored. Perhaps it is because the requirement+    that the pragmas be on the top of the file conflict with the #ifdef+    statements. In any case, this patch gets rid of the warning on MacOS X:+    warning: implicit declaration of function 'tgetnum'. (Eric Kow)++  * Pass CFLAGS to the assembler. E.g. -mcpu is essential on sparc. (Lennart+    Kolmodin)++  * Optimize 'darcs optimize --reorder'. (David Roundy)++  * Add a table of environmental variables to the manual. (issue69, Eric Kow)++  * Use System.Directory.copyFile for file copying. (Kevin Quick)++  * Implement darcs show contents command. It shows the contents of a file at+    a given version. (issue141, Eric Kow)++  * Make Changes --context --repodir work. (Issue467, Erik Kow)++  * Rename 'query' to 'show', but keep 'query' as an alias. (There is also an+    extra alias 'list' that means the same as show.) The subcommand 'query+    manifest' is renamed to 'show files', and does not list directories by+    default, unless the alias 'manifest' is used. (Eric Kow)++  * Support record -m --prompt-long-comment. (issue389, Eric Kow)++  * Hide the command 'unpull' in favor of 'obliterate'. (Eric Kow)++  * Make option --no-deps work again. It now also works for obliterate,+    unrecord, push and send. (issue353, Tommy Pettersson)++  * Make Record --ask-deps abort if user types 'q' instead of recording+    without explicit dependencies. User is now required to type 'd' (done). If+    the resulting patch is completely empty (no changes and no dependencies)+    the record is automatically canceled. (issue308, issue329, Kevin Quick)++  * Use pure record-access for PatchInfo in Patch.Info. (David Roundy)++  * Improve error message when unable to access a repository. (David Roundy)++  * Switch to using new Haskell standard library function cloneFile for+    copying files. (Kevin Quick)++  * Remove more GUI code. (Eric Kow)++  * Fix some --dry-run messages: "Would push" instead of "Pushing". (issue386,+    Eric Kow)++  * Ensure that logfile for record has trailing newline. (issue313, Eric Kow)++  * Add a stub command 'commit' that explains how to commit changes with+    darcs. (Eric Kow)++  * Makes non-repository paths in DarcsFlags absolute. (issue427, Zachary P.+    Landau)++  * Fix problem with missing newline in inventory, to simplify for third party+    scripts. (Issue412, Eric Kow)++  * Add all pulled repositories to _darcs/prefs/repos. (Issue368, Eric Kow)++  * Implement Apply --dry-run. (Issue37, Eric Kow)++  * Never change defaultrepo if --dry-run is used (issue186, Eric Kow)++  * Filter out any empty filenames from the command line arguments. (Issue396,+    Eric Kow)++  * Use prettyException in clarify_errors so we don't blame user for darcs'+    own errors. (Issue73, Eric Kow)++  * Rename command 'resolve' to 'mark-conflicts'. 'Resolve' remains as a+    hidden alias. (issue113, Eric Kow)++  * Make 'query manifest' list directories by default. (issue456, Eric Kow)++  * Allow --list-options even if command can not be run. (issue297, Eric Kow)++  * Make 'unadd' an alias for 'remove'. Make 'move' an alias for 'mv'. Add a+    stub for 'rm' that explains how to remove a file from a darcs repository.+    (issue127, Eric Kow)++  * Fix <supercommand> --help. (Issue282, Eric Kow)++  * New --nolinks option to request actual copies instead of hard-links for+    files. (Kevin Quick)++  * Harmonize capitalization in flags help. (Eric Kow)++  * Define datarootdir early enough in autoconf.mk.in. (Issue493, Eric Kow)++  * Fix a bug where Get --partial would use a checkpoint without detecting it+    was invalid. Checkpoints can for example become invalid after an Optimize+    --reorder. (issue490, David Roundy)++  * User Agent size limit for curl gets is removed. (Issue420, Kevin Quick)++  * Don't garb string parameters passed to libcurl, as required by the api+    specification. (Daniel Gorin)++  * Fix handling of --repo with relative paths. (Eric Kow)++  * Check for gzopen in zlib. curl depends on zlib and is detected prior to+    zlib by the configure file, but without the -lz flag on some versions.+    (Andres Loeh)++  * Switch to haskell's System.Process under Unix for execution of external+    commands; requires GHC 6.4. (Eric Kow)++  * Remove (some more) conflictor code. (Eric Kow)++  * Remove (unused) conflictor code. (David Roundy)++  * Support makefile docdir/datarootdir variables. (Dave Love)++  * Added prehooks that works the same as posthooks, but they run before the+    command is executed. This can for example be used to convert line endings+    or check character encodings before every Record. The darcs command aborts+    if the prehook exits with an error status. (Jason Dagit)++  * Use system instead of rawSystem for calling interactive cmds in Windows,+    which lets us support switches, for example, in DARCS_EDITOR. (Eric Kow)++  * add support for partial and lazy downloading of hashed repositories.+    (David Roundy)++  * Fix refactoring bug in Checkpoints where we sometimes looked for things in+    the wrong place. (David Roundy)++  * Fail on error in get_patches_beyond_tag. This will expose any bugs where+    we use this function wrongly. (As was the case in darcs check --partial+    with hashed inventories.) (David Roundy)++  * Restructure the source tree hierarchy from a mostly flat layout to one+    with directories and subdirectories that reflects the modularity of the+    source. (Eric Kow)++  * In tests, don't assume grep has -q and -x flags. (Dave Love)++  * Add --output-auto-name option to Send (Zachary P. Landau)++  * Added regression testing for the "pull --complement" operation. Updated+    documentation to explain why "darcs pull --complement R1 R1" is the same+    as "darcs pull R1" instead of the empty set. (Kevin Quick)++  * Change all "current" to "pristine" in manual and help texts. (Tommy+    Pettersson)++  * Added the ability to specify the --complement argument on the pull command+    as an alternative to --intersect and --union. When --complement is+    specified, candidate patches for a pull are all of the pullable patches+    that exist in the first repository specified but which don't exist in any+    of the remaining repositories (the set-theory complement of the first+    repository to the union of the remaining repositories). (Kevin Quick)++  * Fix bug where darcs would try to write temporary files in the root+    directory (/) if it couldn't find a repository root to write them in. Now+    it uses the current directory in that case. (issue385, Zachary P. Landau)++  * Make write_repo_format use the same syntax as read_repo_format when+    dealing with different repository formats. (Benedikt Schmidt)++  * Remove some unused functions from Population. (Eric Kow)++  * Use IO.bracket instead of Control.Exception.bracket in Exec, to restore+    the old way darcs works on *nix. (Eric Kow)++  * Import bracketOnError from Workaround instead of Control.Exception to+    support GHC 6.4. (Eric Kow)++  * Switch to haskell's System.Process under Windows for execution of external+    commands; requires GHC 6.4. (Simon Marlow)++  * Fix bug where darcs ignored command arguments in the VISUAL environment+    variable. (issue370, Benedikt Schmidt)++  * Make annotate work on files with spaces in the name. (Edwin Thomson)++  * Prettify exceptions in identifyRepository. (Juliusz Chroboczek)++  * QP-encode patch bundles transfered with the Put command. (Juliusz+    Chroboczek)++  * Fix bug in darcs get --tag that left cruft in pending. (David Roundy)++  * Fix bug when trying to 'darcs mv foo foo'. (issue360, David Roundy)++  * Separate comment from OPTIONS pragma for GHC 6.4 compatibility. (Eric Kow)++  * Make hashed inventories support optimize and reordering. (David Roundy)++  * Change all Maybe Patch to the new type Hopefully Patch, which is similar+    to Either String, for storing patches that may or may not exist. This+    should make it much easier to improve error reporting. (David Roundy)++  * Fix pending bug that broke several_commands.sh. (David Roundy)++  * Fix hashed inventory bug in Add. (David Roundy)++  * Make Get and Put reuse code for Initialize. This makes Put accept any+    flags that Init accepts. (David Roundy)++  * Fix new get to not mess up pending. (David Roundy)++  * External resolution can resolve conflicting adds. (Edwin Thomson)++  * Only copy the files that are needed for the resolution, when invoking an+    external resolution tool. This saves much time and resources on+    repositories with many files in them. (Edwin Thomson)++  * Change message in 'darcs check' from "applying" to "checking". (issue147,+    Tommy Pettersson)++  * Add code fore hashed inventories. (David Roundy)++  * New option for Diff: --store-in-memory. darcs diff usually builds the+    version to diff in a temporary file tree, but with --store-in-memory it+    will represent the files in memory, which is much faster (unless the tmp+    directory already is a ram disk). (Edwin Thomson)++  * Fix bug where duplicated file names on the command line would fool darcs.+    (issue273, Tommy Pettersson)++  * When recording with option --pipe, assume users local timezone if none is+    given, instead of UTC. Except if the date is given in raw patch format+    'yyyymmddhhmmss' it is still parsed as UTC. (issue220, Eric Kow)++  * Account for timezone information, e.g. in dates when recording with option+    --pipe. (issue173, Eric Kow)++  * Fix bug in refactoring of get. (David Roundy)++  * Refactor repository handling to allow truly atomic updates. (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 16 Dec 2007 20:16:47 GMT++darcs (1.0.9)++  * Make shell harness failures fatal in Makefile. (Eric Kow)++  * Bugfix, fix bug where we add a file but not its boring parent directory.+    (David Roundy)++  * Allow escaped quotes in 'quoted' for match text. (Dave Love)++  * Don't exit with failure when tests_to_run is used and there are no perl+    tests. (David Roundy)++  * Apply patches "tolerantly" to the working directory; don't quit, but print+    a warning for every problem and continue. This is a workaround for a bug+    in darcs where it sometimes fails to update the working directory. When+    darcs updates the working directory it has already successfully updated+    the inventory and the pristine cache, so the repository itself is not+    corrupted. However, an incomplete update to the working directory results+    in unintended differences between the working and pristine tree, looking+    like spurious unrecorded changes. These can be easily removed with 'darcs+    revert', but spurious changes have to be manually sorted out from real+    unrecorded changes. By darcs no longer quiting at the first problem, more+    of the working tree gets updated, giving less spurious changes and less+    manual work to fix the mess should the bug bite you. (issue434, Eric Kow,+    David Roundy)++  * Add a README file, created from HACKING. (issue287, Eric Kow)++  * New command, query tags (similar to 'darcs changes -t .) (Florian Weimer)++  * Include the query commands in the manual. (Florian Weimer)++  * The ssh control master is now off by default (it seems to hang on some+    large repositories). The option --disable-ssh-cm is replaced by the two+    options --ssh-cm and --no-ssh-cm (default). (Eric Kow)++  * Do not append a colon to host name when calling sftp. This does not solve+    all of issue362, just a minor annoyance along its way. (issue362, Eric Kow)++  * Get 'open' and 'psignal' declared on Solaris. (Dave Love)++  * Zsh completion supports new _darcs/pristine repository format. (Georg Neis)++  * Add documentation for DARCS_PAGER. (Benedikt Schmidt)++  * Turning off and on the ssh control master works for the Changes command.+    (issue383, Georg Neis)++  * Optimize unrecorded file moves with unrecorded file adds and removals.+    That is, if you add, rename and remove files multiple times without+    recording, whatsnew (and record) will only see the final result, not the+    whole sequence of moves. (Marco Tulio Gontijo e Silva)++  * Fix link error with errno for gcc 4.12 / glibc 2.4. (Benedikt Schmidt)++  * Remove the confusing text "user error" from some of GHC's error+    descriptions. (Juliusz Chroboczek)++  * Check for and fail build configuration if module quickcheck isn't+    available. (issue369, David Roundy)++  * Make darcs push QP-encode the bundle before transferring. This should+    hopefully fix issues with scp/sftp corrupting bundles in transit. (Juliusz+    Chroboczek)++  * Make it very clear in the documentation that the options --from and+    --author does NOT have anything to do with the sender or email author when+    sending patches as email with the darcs Send command. (Kirsten Chevalier)++  * Allow commented tests in tests_to_run. (David Roundy)++  * Make it an error to Put into a preexisting directory. Often one could be+    tempted to try to put into a directory, expecting to have the repository+    created as a subdirectory there, and it is confusing to have instead the+    repository contents mingled with whatever was already in that directory.+    (David Roundy)++  * Explicitly flush output on Windows after waiting for a lock, because+    Windows' stdout isn't always in line-buffered mode. (Simon Marlow)++  * Improve unhelpful "fromJust" error message in Push command. (Kirsten+    Chevalier)++  * Support option --all for Obliterate, Unpull and Unrecord. (issue111, David+    Roundy)++  * Ignore failure to set buffering mode for terminal in some places+    (supposedly fixes issue41, issue94, issue146 and issue318). (Tommy+    Pettersson)++  * Buildfix, don't import Control.Exception functions when compiling on+    Windows. (Edwin Thomson)++  * Add make rules for tag files. (Dave Love)++  * Add a semi-automated test for SSH-related things. (Eric Kow)++  * Allow Dist --dist-name to put the tar file in any directory by giving a+    full path as the dist name. (issue323, Wim Lewis)++  * Add rigorous error checking when darcs executes external commands. All+    low-level C return values are checked and turned into exceptions if they+    are error codes. In darcs main ExecExceptions are caught and turned into+    error messages to help the user. (Magnus Jonsson)++  * Redirect error messages from some external commands to stderr. (Tommy+    Pettersson)++  * Make configure fail if a required module is missing. (David Roundy)++  * The options for turning off and on the ssh control master works from the+    defaults file. (issue351, Tommy Pettersson)++  * Amend-record now keeps explicit dependencies (made with --ask-deps) from+    the amended patch. (issue328, Edwin Thomson)++  * Make libcurl use any http authentication. This let darcs use repositories+    protected with digest authentication. (Tobias Gruetzmacher)++  * Turning off and on the ssh control master works for the Send command.+    (Eric Kow)++  * Redirect stderr to Null when exiting SSH control master. This suppresses+    the output "Exit request sent" not suppressed by the quiet flag. (Eric Kow)++  * Fix curses stuff, especially on Solaris 10. (Dave Love)++  * Annotate various boring patterns. (Dave Love)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 03 Jun 2007 21:37:06 GMT++darcs (1.0.9rc2)++  * Pass e-mail address only for %t in --sendmail-command. Msmtp seems to+    require this. Note that the full address is encoded in the message body.+    (Eric Kow)++  * Show error messages on stderr when starting and stopping the ssh control+    master. (Tommy Pettersson)++  * Rewrite check for spoofed patches with malicious paths. The check can now+    be turned off with the option --dont-restrict-paths (issue177). The new+    check only works for Apply and Pull, and it only looks at the remote+    patches. A more complete check is desirable. (Tommy Pettersson)++  * Add LGPL file referenced in fpstring.c (Dave Love).++  * Update FSF address in copyright headers(Dave Love).++  * New default boring file patterns: ,v .# .elc tags SCCS config.log .rej+    .bzr core .obj .a .exe .so .lo .la .darcs-temp-mail .depend and some more+    (Dave Love).++  * Move darcs.ps to the manual directory (Tommy Pettersson).++  * Pass -q flag to scp only, not ssh and scp. Putty's SSH (plink) does not+    recognize the -q flag. (issue334, Eric Kow)++  * Bugfix. Make darcs.cgi look for both pristine and current (Dan).++  * Don't lock the repo during `query manifest' (issue315, Dave Love).++  * Buildfix. Include curses.h with term.h (issue326, Dave Love).++  * Bugfix. Unrecord, Unpull and Obliterate could mess up a repository+    slightly if they removed a tag with a corresponding checkpoint. Only the+    commands Check and Repair were affected by the damage, and Get would also+    copy the damage to the new repository. (issue281, Tommy Pettersson)++  * Add a HACKING file with helpful references to pages on the darcs wiki+    (Jason Dagit).++  * New boring file patterns: hi-boot o-boot (Bulat Ziganshin, Eric Kow).++  * Require 'permission denied' test for MacOS X again. Perhaps something in+    MacOS X was fixed? (Eric Kow).++  * Look for Text.Regex in package regex-compat. Needed for GHC 6.6. (Josef+    Svenningsson)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 16 Nov 2006 14:03:51 GMT++darcs (1.0.9rc1)++  * Improved handling of input, output and error output of external commands.+    Null-redirection on windows now works. Only stderr of ssh is+    null-redirected since putty needs stdin and stdout. (issue219, Eric Kow,+    Tommy Pettersson, Esa Ilari Vuokko)++  * Optimize away reading of non-managed files in summary mode of Whatsnew+    --look-for-adds (issue79, Jason Dagit).++  * Remove direct dependency to mapi32.dll; Improve MAPI compatibility. (Esa+    Ilari Vuokko)++  * Ignore .git if _darcs is found (Juliusz Chroboczek).++  * Add a haskell code policy test to catch uses of unwanted functions, bad+    formating and such. (Tommy Pettersson)++  * If the logfile supplied with option --logfile does not exist, fail instead+    of inserting no long comment. (issue142, Zachary P. Landau)++  * Make the pull 'permission test' work when run as root (Jon Olsson).++  * Handle unsimplified patches when further simplifying the summarized+    output. For unknown reason (a possibly previous version of) darcs allows a+    single patch to Add and Remove the same file in a single patch. The+    Changes command used to combine them, showing just a Remove. (issue185,+    Lele Gaifax)++  * Add workaround for HasBounds that was removed in GHC 6.6 (Esa Ilari+    Vuokko).++  * Really make --disable-ssh-cm work (issue239, Eric Kow).++  * Fix false errors in pull.pl test (David Roundy).++  * Clean up docs on DarcsRepo format (David Roundy).++  * Use stdin for passing the batch file to sftp, to allow password-based+    authentication (issue237, Eric Kow, Ori Avtalion).++  * Make darcs fail if the replace token pattern contains spaces. It would+    otherwise create a non-parsable patch in pending. (issue231, Tommy+    Pettersson)++  * Set a default author in the test suite harness so not every test has to do+    so. (Tommy Pettersson).++  * Run external ssh and scp commands quietly (with the quiet flag), but not+    sftp which doesn't recognize it (issue240). This reduces the amount of+    bogus error messages from putty. (Eric Kow)++  * Implement help --match, which lists all available forms for matching+    patches and tags with the various match options (Eric Kow).++  * Added .elc and .pyc suffixes to default binary file patterns (Juliusz+    Chroboczek ).++  * Added a link to the 'projects' part of the cgi repository interface, so+    that you go back to the project list (Peter Stuifzand).++  * Add a test suite for calling external programs (Eric Kow).++  * Don't warn about non-empty dirs when in quiet mode (Eric Kow).++  * New option --umask. This is best used in a repository's defaults file to+    ensure newly created files in the repository are (not) readable by other+    users. It can also be used when invoking darcs from a mail reader that+    otherwise sets a too restrictive umask. (Issue50, Juliusz Chroboczek)++  * Only check for ssh control master when it might be used. This suppresses+    the annoying "invalid command" error message. (Issue171, Eric Kow)++  * Fail with a sensible message when there is no default repository to pull+    from. (Lele Gaifax)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 08 Oct 2006 17:52:07 GMT++darcs (1.0.7)++  * Fixed bug leading to a spurious "darcs failed: resource vanished" error+    message when darcs output is piped to a program such as head that then+    exits. (Issue160, David Roundy)++  * New option --diff-command overrides the default value of "diff" when darcs+    calls an external program to show differences between versions (Eric Kow).++  * Use the ControlMaster feature in OpenSSH version 3.9 and above to+    multiplex ssh sessions over a single connection, instead of opening a new+    connection for every patch (Issue32, Eric Kow).++  * Add a standalone graphical interface (experimental). The gui code prior to+    this patch allows graphical darcs forms to be run from the command line.+    This builds off that functionality by adding a graphical front-end,+    allowing users to access these forms with a click of a button. In other+    words, this allows users to run darcs without the command line. (Eric Kow)++  * Make unpull, unrecord, obliterate accept --gui (Eric Kow).++  * Freshen GUI code so that it compiles (Eric Kow).++  * Provide more information when a remote repository can't be correctly+    identified. (Juliusz Chroboczek)++  * The Send command can save, reuse and delete the accompanying description+    in a logfile. (Zachary P. Landau)++  * Display list of subcommands when getting help on a supercommand. (Eric Kow)++  * A proper fix for the problem with rmdir when there are non-managed files+    left in the working copy of the directory so it can't really be removed.+    This solves the two related problems with a missguiding error message in+    one case, and an unreported repository corruption in the other. Now there+    is no false warning and no repository coruption. (issue154, Eric Kow)++  * Escaping of trailing spaces and coloring now works with in the pager+    called with 'p' from interactive dialogues. (issue108, Tommy Pettersson)++  * Added default recognized binary file extensions: bmp, mng, pbm, pgm, pnm,+    ppm, tif, tiff. (Daniel Freedman)++  * Added a RSS link to common.xslt. (Peter Stuifzand)++  * Make short option -i a synonym for --interactive (Zachary P. Landau).++  * Improved argument substitution for --external-merger. All apperences of %N+    are replaced, not only those occurring as single words. (Daan Leijen)++  * Transition from _darcs/current to _darcs/pristine completed. New+    repositories are created with a "pristine" directory. Previous versions of+    darcs have been looking for this directory since version 1.0.2, but older+    versions than that can't read the new repository format. (Juliusz+    Chroboczek)++  * If you specify a repository directory, any absolute paths prefixed by this+    directory are converted to be ones relative to the repodir. (issue39, Eric+    Kow)++  * The --repodir flag works with many more commands: changes, dist, get,+    optimize, repair, replace, setpref, tag, trackdown. (RT#196, RT#567, Eric+    Kow)++  * The --repodir flag works with initialize command, and tries to create it+    if it does not exists. (RT#104, Eric Kow)++  * Add autom4te.cache to default boring patterns. (Kirill Smelkov)++  * Don't create temporary copies of the repository for the external merger+    program, unless there is for sure some conflict to resolve. (Edwin Thomson)++  * Modify Changes --interactive dialogue to behave like other interactive+    commands: accept 'y' and 'n' as answers and exit automatically after last+    question. (Zachary P. Landau)++  * Unnamed patches are now called "changes" in the interactive patch+    selection dialogues. (Tommy Pettersson)++  * Treat Enter as an invalid response in single character prompt mode, and+    give feedback instead of being mysteriously silent and unresponsive.+    (RT#261, Eric Kow)++  * Make short option -f a synonym for --force (Zooko).++  * Posthooks no longer cause an output message about success or failure,+    unless the --verbose option is used. (Jason Dagit)++  * Fix crash when using changes --interactive with --patch or --match+    (Zachary P. Landau).++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 13 May 2006 17:14:38 GMT++darcs (1.0.6)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 28 Feb 2006 11:18:41 GMT++darcs (1.0.6rc1)++  * Check paths when applying patches to files and directories to stop+    maliciously handcrafted patches from modifying files outside of the+    repository or inside darcs private directories (issue48, Tommy Pettersson).++  * Revert optimization that sometimes applied patches incorrectly and+    corrupted the repository. This make darcs somewhat slower when applying+    patches. A full pull of the darcs repository itself takes 50% longer.+    (issue128, Tommy Pettersson).++  * Fix bug in Get --tag that produced a corrupt repository (issue67, Edwin+    Thomson).++  * Add newline between long comment and changed files list in dry-run summary+    to remove ambiguity (Edwin Thomson).++  * Extended date matching functionality: ISO 8601 dates and intervals, a+    larger subset of English like "yesterday at noon" (issue31/RT#34, Eric+    Kow).++  * Allow rename to different case (RT #466, Eric Kow).++  * Save long comment in a file if record fails the test run (Zachary P.+    Landau).++  * Fix win32 build breaks (Will Glozer).++  * Make --exact-version work when darcs is built from distributed tar ball+    (Marnix Klooster).++  * Coalesce pending changes created with setpref (issue70/RT#349, Eric Kow).++  * Support --interactive option in changes command (issue59, Zachary P.+    Landau).++  * New help command (RT#307, Eric Kow).++  * Add --without-docs option to configure (Richard Smith).++  * Obey normal autoconf conventions. Allows you to 'make install prefix=...'+    and doesn't change default for sysconfdir. (Dave Love)++  * Fix bug with non-existing directories. (David Roundy)++  * Remote apply does not use cd to change current directory to target+    directory any more. It uses --repodir when invoking remote darcs. This may+    break some darcs wrappers. (Victor Hugo Borja Rodriguez)++  * Support signed push (Esa Ilari Vuokko).++  * Added support for pulling from multiple repositories with one pull. The+    choice of --union/--intersection determines whether all new patches are+    pulled, or just those which are in all source repositories. This feature+    implements a suggestion by Junio Hamano of git. (David Roundy)++  * Patch bundle attachments get a file name, based on the first patch.+    (Zachary P. Landau)++  * The send command now takes a --subject flag. (Joeri van Ruth)++  * Fix --set-scripts-executable to work also when getting a local repository.+    (issue38, Eric Kow)++  * Removed the helper program darcs-createrepo. It was used for guided settup+    of a darcs repository and a corresponding user account to accept patches+    from signed emails. (issue14, Jason Dagit)++  * Print out the patch name when a test fails. (Zachary P. Landau).++  * Bugfix for --sendmail-command in Windows (Esa Ilari Vuokko).++  * Make apply --verify work with GnuPG in Windows (Esa Ilari Vuokko)++  * Bugfix for handling of absolute paths in Windows (issue47, Will Glozer)++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 19 Feb 2006 23:19:19 GMT++darcs (1.0.5)++  * Fixes for Windows (Will Glozer).++  * Adapt makefile to work with current ghc 6.4 (Will Glozer).++  * --help and --list-commands ignore other options (issue34, Eric Kow).++  * Fix apply with --verify for patch bundles signed by GnuPG in Windows (Esa+    Ilari Vuokko).++  * Make patch selection options together with --context work again (Daniel+    Bünzli).++  * Make option --commands outside of a repository work again (issue9, David+    Roundy).++  * Bugfix for pushing with ssh under Windows (issue15, Will Glozer).++  * Fix superfluous input bug in test suite (Florian Weimer).++  * Many English and markup fixes (Dave Love).++ -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 07 Dec 2005 11:27:30 GMT++darcs (1.0.4)++  * Fixed a bug in the external conflict resolution code. (bug #577, David+    Roundy)++  * Fixed a bug which made apply sometimes (but rarely) fail to check the the+    hash on patch bundles corrupted in just the wrong way. (David Roundy)++  * Added a simple check to darcs replace that avoids tokenizing lines that+    don't contain the token we're replacing. I feel a bit bad about+    introducing an optimization this late in the release cycle, but it makes a+    huge difference, and really should be safe. (David Roundy---famous last+    words)++  * Fixed bug where darcs didn't honor the SSH_PORT environment variable when+    calling sftp. (bug #576, fix suggested by Nicolas Frisby)++  * Avoid putting a wrongly-named directory in the tarball generated by darcs+    dist, if the name we wanted already exists in $TMPDIR. (Simon McVittie)++  * Fixed bug which caused "pull_firsts_middles called badly" errors when+    running record with --ask-deps flag. (bug #476, David Roundy)++  * Fixed bug where 'darcs changes --context' created a context that contained+    escapes that prevented its use with send. (bug #544, David Roundy)++  * Make interactive push/pull/send/apply respect the --summary option by+    printing each patch as if you had hit 'x'. (David Roundy, bug #512)++  * Fix bug when calling whatsnew --summary when a file without a trailing+    newline has been deleted. (David Roundy)++  * Fix --set-scripts-executable to work again. This feature had been broken+    since version 1.0.3. (David Roundy)++  * Simple (safe) fix for a bug which caused darcs to run out of file+    descriptors when pulling over 1000 patches. (David Roundy)++  * Fix bug in perl parts of test suite which led to spurious warning+    messages. (David Roundy)++  * Fix bug in configure when compiling darcs from tarball on a system that+    has no darcs present. (David Roundy)++  * Fix bug that shows up when recording in a repository lacking a pristine+    tree. (David Roundy)++ -- David Roundy <droundy@darcs.net>  Sun, 13 Nov 2005 13:44:31 GMT++darcs (1.0.4pre4)++  * Fix error in install target of makefile, which was introduced in+    1.0.4pre3. (Andres Loeh)++  * Fix problem where make install modified the permissions on system+    directories. (David Roundy, bug #494)++  * Fix bug in display when whatsnew is given "-l" twice. (David Roundy, bug+    #501)++  * Added support for --posthook to all commands. (Jason Dagit)++  * Made repair able to work on partial repositories. (fixes bug #189)++  * Changed the delimiter in the long-comment file from ***DARCS*** to ***END+    OF DESCRIPTION*** and clarified its meaning a bit. (Jason Dagit and David+    Roundy)++  * Added code to allow darcs to apply some patch bundles that have had+    carriage returns added to their line endings. (David Roundy, bug #291)++  * Make darcs accept command line flags in any order, rather than requiring+    that they precede file, directory or repository arguments. Fixes bug #477+    (David Roundy)++  * Modified darcs get to display patch numbers rather than a bunch of dots+    while applying patches during a darcs get. Also added similar feedback to+    the check and repair commands. (Mat Lavin, bug #212)++  * Made revert --all not ask for confirmation, so it can be used in+    scripting, as one would use pull --all or record --all. (Jani Monoses)++  * Added file ChangeLog.README explaining how to add entries to the+    changelog. (Mark Stosberg and David Roundy)++  * Fixed incompatibility with somewhat older versions of libcurl. (Kannan+    Goundan)++  * Fixed bug that showed up when after editing a long comment, the long+    comment file is empty. (David Roundy, bug #224)++ -- David Roundy <droundy@darcs.net>  Sun, 01 Sep 2005 11:04:18 GMT++darcs (1.0.4pre2)++  * (EXPERIMENTAL) Added support for reading and writing to git repositories.+    There remain efficiency issues with the handling of git merges and darcs+    is not yet able to either create a new git repository, or to pull from a+    remote git repository. See building darcs chapter in manual for+    instructions on building darcs with git support. (Juliusz Chroboczek,+    configuration contributed by Wim Lewis)++  * Add new "query manifest" command to list files and/or directories in+    repository. Add some related infrastucture to support "subcommands".+    (Florian Weimer)++  * Make configure properly detect that we're on windows when building under+    mingw. (David Roundy)++  * Fixed bug #208: error when specifying pulling from a relative default+    repository if we are ourselves within a subdirectory of our repository.+    (David Roundy)++  * Change internal mechanism for writing the "pending" file to be (hopefully)+    more robust. (David Roundy, original idea by Ian Lynagh)++  * Fixed a bug that caused get --partial to fail sometimes. (David Roundy)++  * Made push/pull --verbose --dry-run now display contents of patches,+    analogous to the behavior of changes --verbose. (Jim Radford)++  * Various build system cleanups. (Peter Simons)++ -- David Roundy <droundy@abridgegame.org>  Sun, 31 Jul 2005 12:10:29 GMT++darcs (1.0.4pre1)++  * Performance improvement: Several commands now read patches lazily, which+    reduces memory usage. A test of 'darcs check' on the Linux kernel+    repository showed the memory usage was nearly cut in half, from about 700+    Megs to 400. Coded by David Roundy.++  * New feature: darcs put, the easiest way to create a remote repo, symmetric+    with 'darcs get'. Coded by Josef Svenningsson.++  * Performance improvement: RT#222: darcs performs better on files with+    massive changes. Coded by Benedikt Schmidt.++  * New Feature: darcs optimize now has "--modernize-patches" and+    "--reorder-patches" flags. See the manual for details.++  * Performance improvement: Using 'darcs diff' is now exponentially faster+    when comparing specific files in the working directory to the most recent+    copy in the repo. Coded by kannan@cakoose.com.++ -- David Roundy <droundy@abridgegame.org>  Sun, 18 Jul 2005 11:22:34 GMT++darcs (1.0.3)++  * Fixed bug #396: error when specifying a removed file on the command line+    of darcs record.++ -- Tomasz Zielonka <tomasz.zielonka@gmail.com>  Sun, 24 May 2005 21:51:27 GMT++darcs (1.0.3rc2)++  * Internals: darcs' ChangeLog is automatically generated from repo history+    and a database of ChangeLog entries (Tomasz Zielonka)++  * Fixed: RT#370: --tags work in unpull and unrecord (Tommy Pettersson)++  * New feature: added support for displaying patches with pager when+    selecting patches (Benedikt Schmidt)++  * New feature: new match type "exact" (John Goerzen)++  * Feature: unrevert accepts --all and --interactive options (Jani Monoses)++  * Fixed: darcs works with nvi (Benedikt Schmidt)++ -- Tomasz Zielonka <tomasz.zielonka@gmail.com>  Sun, 15 May 2005 08:56:17 GMT++darcs (1.0.3rc1)++  * New Feature: darcs.cgi now uses appropriate caching headers. This will+    make repeated calls to the same pages by cache-aware browsers much faste+    in some cases. It also means that darcs.cgi can be usefully combined with+    a cache-aware proxy for even better performance. (Will Glozer)++  * New feature: more control over color and escaping in printed patches,+    alternative color scheme, escaping of trailing spaces (Tommy Pettersson)++  * Fixed: fixed bug manifesting with failed createDirectory (David Roundy)++  * Internals: RT#255, several welcome refactors were made to the test suite,+    including comprehensible shell test script output, improved portability,+    and easier maintenance. (Michael Schwern).++  * New Feature: RT#245: Using --look-for-adds with 'whatsnew' implies+    --summary. This should save some typing for the common case. (Karel+    Gardas, Mark Stosberg)++  * New Feature: RT#231: darcs gives better feedback now if you try to record+    nonexistent files or directories. (Karel Gardas, Mark Stosberg)++  * New feature: send accepts --sendmail-command that allows to customize the+    command used for sending patch bundles (Benedikt Schmidt)++  * Fixed: RT#266: Adding a non-existent dir and file gives the expected+    message now. (Tomasz Zielonka).++  * Fixed: RT#10, a missed conflict resolution case. More accurately, we+    noticed at had been fixed some point. A regression test for it was added.+    (Tomasz Zielonka, Mark Stosberg)++  * New feature: darcs tag can now accept the tag name on the command line+    (RT#143). (Josef Svenningsson, Mark Stosberg, David Roundy)++  * New feature: unrecord and unpull have a more powerful interface similar to+    'darcs pull'. This allows for multiple patch selection. Coded by Tommy+    Pettersson.++  * Bug fix: RT#305: Removed '--patch' from the 'changes', which conflicted+    with the new '--patches' option.++  * New feature: Automatically add parent directories for darcs add. (RT#20)+    Coded by Benedikt Schmidt.++  * Add helpful diagnostic message when there is a failure while pulling+    (RT#201)++ -- Tomasz Zielonka <tomasz.zielonka@gmail.com>  Sun, 26 Apr 2005 00:25:54 GMT++darcs (1.0.2)++  * No changes from 1.0.2rc4.++ -- David Roundy <droundy@darcs.net>  Fri,  4 Feb 2005 07:33:09 -0500++darcs (1.0.2rc4)++  * More documentation improvements, plus one clearer error message.+  * Fixed (new since 1.0.1) bug which broke darcs repair.+  * Fixed problem with makefile which caused spurious relinkings.+  * Fixed bug in new optimize --relink command, which could cause+    repository corruption.++ -- David Roundy <droundy@abridgegame.org>  Wed, 2 Feb 2005 06:24:19 -0500++darcs (1.0.2rc3)++  * Documentation improvements related to Juliusz new code.+  * Fixed longstanding leaks in zlib/threads code.+  * Fixed some bugs in the new optimize --relink code.+  * Fixed bug in darcs diff when the repository name is empty.++ -- David Roundy <droundy@abridgegame.org>  Sat, 29 Jan 2005 07:28:39 -0500++darcs (1.0.2rc2)++  * Fixed bug on win32 when there are spaces in a repositories path and an+    external program (i.e. ssh) is called. (Will Glozer)++ -- David Roundy <droundy@abridgegame.org>  Thu, 27 Jan 2005 06:46:37 -0500++darcs (1.0.2rc1)++  * Added experimental support for repositories without a "pristine tree"+    This is the new name for the cache stored in _darcs/current/.+    (Juliusz Chroboczek)+  * Added an optimize --relink command to save disk space when using+    multiple repositories. (Juliusz Chroboczek)+  * Ignore conflict markers in the boring and binaries files.+  * Fixed bug in get --partial when patches are in an unusual order.+    (Andrew Johnson)+  * Fixed bug which caused a crash on a local get of a repository owned by+    another user.+  * Fixed bug in changes/annotate that shows up when a directory has been+    moved.+  * Allow ncurses in addition to curses in configure.+  * Added --set-scripts-executable option. (Karel Gardas)+  * Added configure option to fix path to sendmail even if it's not+    present.+  * Made bash completion more robust regarding shell special chars.+  * Added konquerer workaround to cgi annotate. (Will Glozer)+  * Addressed bug #114 - provide a better error when you accidently try to+    pull from yourself. (Mark Stosberg)+  * Made a few documentation improvements.+  * Made http user agent reflect the darcs and libcurl version.+  * Fixed commute bug in merger code.+  * Fixed bug in decoding mime messages.++ -- David Roundy <droundy@abridgegame.org>  Wed, 26 Jan 2005 08:51:24 -0500++darcs (1.0.1)++  * Made darcs changes --context work on an empty repo.+  * Fixed bug in relative directories as arguments to pull/push.+  * Fixed bug leading to extraneous changes in pending.+  * Fixed bug #137 - XML escaping for >.+  * Fixed gui code to compile with wxhaskell 0.8 (but it's still buggy).++ -- David Roundy <droundy@abridgegame.org>  Tue, 14 Dec 2004 08:16:10 -0500++darcs (1.0.1rc3)++  * Made it so adding and removing a file doesn't leave changes in pending.+  * Fixed bug in creating the file to be edited for the long comment.+  * Made "bug in get_extra" message explain possible cause of the problem,+    which is related to a bug in commutation that made it into version+    1.0.0.+  * Fixed stubborn bug in annotate.+  * Fixed problem when unrecording binary file patches.++ -- David Roundy <droundy@abridgegame.org>  Sat, 11 Dec 2004 14:23:53 -0500++darcs (1.0.1rc2)++  * Various optimizations.+  * darcs now supports an arbitrary number of transport protocols through the+    use new environment variables. See DARCS_GET_FOO in the 'Configuring+    Darcs' chapter in the manual for more details.+  * darcs now supports an arbitrary number of concurrent connections when+    communicating with remote repos. See the documentation for DARCS_MGET_FOO+    in the 'Configuring Darcs' chapter in the manual for more details.++ -- David Roundy <droundy@abridgegame.org>  Wed,  8 Dec 2004 08:02:48 -0500++darcs (1.0.1rc1)++  * Fixed bug in commutation of adjacent hunks which have either no new or+    no old lines.+  * Numerous newline fixes for windows.+  * On windows, use MAPI to resolve to and from addresses.+  * Fixed problem where the --cc was ignored in apply if the patch+    succeeded.++ -- David Roundy <droundy@abridgegame.org>  Wed,  1 Dec 2004 06:24:08 -0500++darcs (1.0.1pre1)++  * Changed apply to by default refuse to apply patches that would lead to+    conflicts.+  * Removed the old darcs_cgi script, in favor of the darcs.cgi script.+  * Fixed changes to work better in partial repositories.+  * Set stdin and stdout to binary mode to fix end of line problems with+    push under windows.+  * Made send create proper MIME email.+  * Removed reportbug command, really wasn't necesary, and didn't work+    well.  Report bugs by an email to bugs@darcs.net, which creates a+    ticket in our BTS.+  * Allow darcs to work with a password protected proxy.+  * Get multiple files with a single wget call when darcs is compiled+    without libcurl support.+  * Use sftp instead of scp to copy patches via ssh -- this reuses a single+    connection for better speed.+  * Made _darcs/current polymorphic (but not really documented).+  * Made optimize --uncompress work with --partial repos.+  * Various minor interface improvements.+  * Made changes work better when specifying a file, and working in a+    partial repository.+  * Fixed bug in causing "Fail: _darcs/patches/unrevert: removeFile: does+    not exist (No such file or directory)".  Resolves bugs #57, #61.++ -- David Roundy <droundy@abridgegame.org>  Sun, 21 Nov 2004 08:29:24 -0500++darcs (1.0.0)++  * Fixed compile error when antimemoize is enabled.+  * Fixed bug that showed up when dealing with international characters in+    filenames.+  * Various documentation improvements.++ -- David Roundy <droundy@abridgegame.org>  Mon,  8 Nov 2004 06:12:08 -0500++darcs (1.0.0rc4)++  * Use autoconf to check for working install program.+  * Renamed rerecord to amend-record in a futile attempt to avoid+    confusion.+  * Made pull accept the --repodir option.+  * Fixed off-by-one error in annotate that kept users from seeing+    "deleted" version.+  * Check filesystem semantics at runtime to avoid using mmap on+    windows filesystems.+  * Fixed darcs.cgi to work properly when browsing history of renamed+    files.+  * Use anonymous file handle for temporary files in darcs.cgi -- fixes a+    temporary file leak and potentially improves security.+  * Added --summary option to commands that accept --dry-run.+  * Made pull prompt for confirmation when there is a conflict with+    unrecorded changes.+  * Made unrevert interactive.+  * Don't try to generate a new name on get if name was given explicitely.+  * Always mark conflicts, even if there's an obvious solution.+  * Quote conflict attribute values in xml output.+  * Fail if the user gives a newline in the patch name.+  * Fixed bug where new files didn't show up in darcs diff.+  * Really fix newlines in whatsnew -u.+  * Fixed bug in handling of tags in changes and annotate.+  * Fixed bug in default options containing "--".+  * Fixed various other build problems in 1.0.0rc3.+  * Fixed embarrassing failure-to-compile-on-windows bug.++ -- David Roundy <droundy@abridgegame.org>  Mon,  1 Nov 2004 05:19:01 -0500++darcs (1.0.0rc3)++  * Fixed bug leading to creation of empty "hunk" patches.+  * Fixed bug in rollback when there are pending changes.+  * Fixed push bug when default apply is --interactive.+  * Fixed a bug where "darcs pull --list-options" would try to+    complete to "home/.../darcs_repo" instead of "/home/.../darcs_repo".+  * Fixed flushing bug in darcs.cgi.+  * Fixed commutation bug with renames and file adds/removals.+  * Made --summary indicate conflicted changes.+  * Fixed generation of extra hunk in diff algorithm.+  * Added X-Mail-Originator header to emails sent by darcs.+  * Fixed a couple of bugs in the resolve command.+  * Added new cgi diff command to produce unified diff.+  * Notify when there are conflicts on push.+  * Added 'a' key to say yes to all remaining changes for interactive+    commands.+  * Automatically generate AUTHORS file from repo history.+  * Made pull --quiet actually quiet.+  * Fixed bugs in whatsnew -ls, and distinguished between manually added+    files and automatically added files.+  * Fixed bug in darcs --commands when called outside a repo.++ -- David Roundy <droundy@abridgegame.org>  Sun,  3 Oct 2004 07:45:05 -0400++darcs (1.0.0rc2)++  * Added support for comments in prefs files.+  * Added new --enable-antimemoize compile option which reduces memory+    usage at the expense of increased computational time.+  * Added a new command:  "reportbug"+  * Fixed a bug that prevented applying of a patch bundle to an+    "unoptimized" repo.+  * Fixed bug where asking for changes to a nonexistent file in a+    subdirectory would show the patch that created or renamed that+    subdirectory.+  * Improved the robustness of unrevert.  Now actions that will make+    unrevert impossible should warn the user.+  * Fixed bug when moving files or directories to the root directory of+    repo.+  * Various changes to make the --logfile way of specifying the patch name+    and comments in record more friendly:+    - Allows editing of the long comment even when --logfile is specified,+      if the --edit-long-comment option is also used.+    - When editing the long comment, the change summary is included below+      the actual text for reference, and the patch name is included in the+      first line (and thus may be modified).+    - The --logfile option is ignored if such a file doesn't exist.+    - A --delete-logfile option was added, which tells darcs to delete the+      file after doing the record.  This is intended to allow you to stick+      a --logfile=foo option in your defaults without accidentally+      recording multiple patches with the same comments because you forgot+      to modify it.+  * Fixed bug leading to .hi files in tarball.+  * Made ctrl-C work under windows, but only "pure" windows consoles, not+    in cygwin shells or mingw's rxvt (room for improvement here).+  * Fixed bug that led to curl not being tried when darcs is not compiled+    with libcurl.+  * Added an environment variable DARCS_USE_ISPRINT for people who use+    non-ascii characters in their files to indicate if the haskell standard+    library "isPrint" function works properly on their system (which+    depends on locale).+  * Reduced the number of hunks produced by the internal diff algorithm,+    when there are multiple equivalent ways of interpreting a change.+  * Made the --from-{patch,tag,match} options inclusive, and added a+    --{patch,match} option to diff (which was made easier to define by the+    inclusiveness change, since --patch x is now equivalent to+    --from-patch x --to-patch x).+  * Added support for a second argument to get, which specifies the name of+    the new directory.++ -- David Roundy <droundy@abridgegame.org>  Sun, 12 Sep 2004 06:54:45 -0400++darcs (1.0.0rc1)++  * Remove some lazy file IO which may have been causing trouble pushing in+    windows and using windows shares.+  * Various interface improvements and improved error messages.+  * Fixed bug that could cause conflicts in pending when unrecording a+    patch that contained two non-commuting non-hunk patches.+  * Fixed bug in --ask-deps option of record.+  * Added --exact-version option which gives the precise darcs context from+    which darcs was compiled.+  * MIME fixes in patch forwarding.+  * Various improvements to the darcs.cgi script.+  * Added --reverse option to changes.+  * Fixed patch numbering when file or directory arguments are given to an+    interactive command.++ -- David Roundy <droundy@abridgegame.org>  Sun, 15 Aug 2004 07:43:30 -0400++darcs (0.9.23)++  * Added a rerecord command, which will add changes to an existing+    recorded patch+  * Added support for a MOTD.+  * Vastly improved the speed and memory use of darcs optimize --checkpoint+    as well as darcs record, in the case where a record consists primarily+    of adds.++ -- David Roundy <droundy@abridgegame.org>  Mon, 26 Jul 2004 08:11:20 -0400++darcs (0.9.22)++  * add preliminary --context option to changes and get.+  * display change number, e.g. "(1/3)" in interactive commands.+  * show moves in summary format.+  * add hash of patch bundles in darcs send.+  * properly support --verbose and --quiet in add.+  * don't display binary data to screen.+  * fix bug in selecting patches by pattern.+  * fix various locking-related bugs introduced in 0.9.21.+  * fix bug when specifying logfile in a subdirectory.+  * support backslashes for directory separators in windows.+  * fix file modification time bug.++ -- David Roundy <droundy@abridgegame.org>  Sat, 26 Jun 2004 07:42:05 -0400++darcs (0.9.21)++  * made mv work even if you've already mv'ed the file or directory.+  * remember configure settings when reconfiguring.+  * added --leave-test-directory to save the directory in which the test is+    run on record or check.+  * added HTTP redirect support (thanks Benedikt).+  * fixed problems when unrecording a patch with conflits.+  * fixed locking on nfs (thanks Juliusz).+  * added preliminary version of a new cgi script for browsing darcs+    repositories (thanks to Will Glozer for contributing this).+  * add and modify a number of short flag options.+  * fix bug in applying new order patch bundles that are GPG signed.+  * fix bug in diff when a tagged version was requested.++ -- David Roundy <droundy@abridgegame.org>  Sat, 12 Jun 2004 05:39:48 -0400++darcs (0.9.20)++  * fix bug in darcs-createrepo.+  * add support for DARCS_SCP and DARCS_SSH environment variables.+  * add XML support for --summary options of changes and annotate.+  * better command-line completion on commands accepting a list of files or+    directories.+  * fix bug causing empty hunk patches to lead to failures.+  * fix bug where --all overrode file choice in record.+  * fix bug when testing patches that create subdirectories within subdirectories.+  * preserve pending changes when pulling or applying.+  * give better error message in pull when patch isn't readable.+  * allow sendEmail with no "to", just "cc" recipients.  This should fix+    the trouble with trying to --reply to a patch coming from a push rather+    than a send.++ -- David Roundy <droundy@abridgegame.org>  Wed,  5 May 2004 06:01:48 -0400++darcs (0.9.19)++  * fix bugs leading to failures in the wxhaskell interface.+  * fix bug that caused darcs diff to fail.+  * fixed bug in get that lead to _darcs/current/_darcs directories.+  * improved error reporting in several situations.+  * fixed bug when pulling or pushing into an empty repo.+  * added --summary option to changes to summarize the changes made in each+    patch.++ -- David Roundy <droundy@abridgegame.org>  Fri,  9 Apr 2004 07:19:34 -0400++darcs (0.9.18)++  * added support for sending email from windows using the MAPI interface.+    This code attaches the patch bundle in base64-encoded form, which darcs+    can't currently decode (expect that in the next release), but the patch+    bundle can be manually applied if a mail program does the decoding.+  * renamed "darcs push" to "darcs send" and added a new "darcs push"+    command roughly equivalent to the old "darcs push --and-apply".+  * removed support for setting up a test suite by simple creating a file+    named "darcs_test".  You now should use setpref to define the test+    suite command.+  * fixed some problems when working in a --partial repository.+  * lots of code was cleaned up.  We have enabled the -Wall compiler flag+    and are in the process of eliminating all the warnings.  This should+    make the code more friendly to new developers, and also helps with the+    next bullet point:+  * improved handling of errors--informative failure messages are more+    likely than they were before.+  * by default only check changes made since last checkpoint--this greatly+    speeds up check.+  * add --quiet option.  Some commands don't yet support this.  If+    there's a command you want to quiet down, let us know.+  * several performance enhancements: improved SHA1 performance, faster+    check and get on repositories with a long history and improved+    performance with very large files.++ -- David Roundy <droundy@abridgegame.org>  Thu,  1 Apr 2004 05:43:18 -0500++darcs (0.9.17)++  * fixed bug in darcs apply that made the --no-test option fail.+  * fixed bug that caused darcs to set file permissions to be+    non-world-readable.+  * darcs record and whatsnew can now accept file or directory arguments+    and limit their actions to changes in those files or directories.+  * darcs changes now can accept file or directory arguments and limit+    itself to changes affecting those files or directories.++ -- David Roundy <droundy@abridgegame.org>  Sat, 21 Feb 2004 08:12:34 -0500++darcs (0.9.16)++  * Add --sign-as=KEYID option to push command.+  * make optimize split up inventory for faster pulls+  * Allow use of a different make command for tests, such as gmake+  * Can now put prefs that would normally go in _darcs/prefs (defaults,+    binaries and boring) in ~/.darcs/ to set the prefs for all your+    repositories at once.+  * add primitive xml output to annotate of directory.+  * When pushing a patch, add the list of changes in the description.+  * refuse to rollback a patch twice, since that would cause problems.+  * make darcs diff accept optional arguments indicating files and+    directories to diff.+  * preserve permissions on files in working directory.+  * put docs in ...share/doc/darcs not share/darcs/doc.+  * add support for multiple-choice options.  This means that you can now+    set your default option in _darcs/prefs/defaults, and then override+    that default on the command line.+  * shortened --use-external-merge-tool option to --external-merge+  * more "boring" patterns.++ -- David Roundy <droundy@abridgegame.org>  Tue, 10 Feb 2004 07:08:14 -0500++darcs (0.9.15)++  * next step repository format transition--we use the new patch filenames.+  * fix handling of text files with no trailing newline--this will cause+    some trouble.  Darcs will require that you convert your repository+    using convert-repo.  This will leave you with a bunch of changes+    regarding trailing newlines which you will either want to record or+    revert.+  * the windows support is somewhat improved.+  * added simple "repair" command that can repair some kinds of+    inconsistencies in the repository.+  * added primitive "annotate" command to extract information about+    modifications to files and directories.+  * fixed handling of darcs mv to allow moving to directories in a more+    intuitive manner.+  * handling of binary files was dramatically improved in both memory and+    cpu usage.+  * added autoconf testing framework to clean up code dealing with+    different versions of ghc, features that don't exist on windows, bugs+    that only exist on windows, etc.+  * don't accept invalid flags.+  * add more patterns to boring and binary.+  * use autoconf test to handle posix signals and windows '\\' handling.+  * switch to using new patch filenames.+  * XML formatted output for 'changes' command+  * add support for unidiff-like whatsnew output.+  * fix bug in RTS memory calculation for large RAM size+  * add rollback command.+  * improve checkpointing support.+  * add diff-opts option to darcs diff.+  * add support for building docs using htlatex or hevea rather than+    latex2html.+  * use locking whereever it is needed.+  * add safe (atomic) writing of inventory files.++ -- David Roundy <droundy@abridgegame.org>  Fri, 12 Dec 2003 07:59:54 -0500++darcs (0.9.14)++  * darcs changes now shows times formatted according to current locale.+  * add support for automatically treating files containing ^Z or '\0' as+    binary.+  * add experimental checkpointing, allowing get to only download the+    recent change history.+  * allow darcs to be called within subdirectories of a repository.+  * make default be to compress patches.+  * add --summary option to whatsnew.+  * add trackdown command.+  * fix bug in darcs dist --verbose.+  * make darcs diff have closer behavior to cvs diff.  In particular, darcs+    diff with no arguments now gives you the difference between the working+    directory and the latest recorded version.+  * support external graphical merge tools.+  * fix bug where binary patch is created even with no change.+  * support darcs -v for version.  Also mention the darcs version in the+    usage mesage.+  * ignore empty lines in boring file and binary file.+  * preserve pending changes (e.g. file adds or darcs replaces) across+    revert and record.+  * create repositories with new patch filename format.+    The new repo format is now created alongside the old format, but the+    old format is read.  There is a tool called convert-repo that will+    convert an old format repo to have both formats.+  * use iso format for dates in record.+  * New patch-selecting interface.+    This patch only uses the new routine for revert, since it's not+    particularly well tested.  The text method now allows one to go back+    and edit previous patches.  The idea is that eventually all commands+    that need the user to select a subset of patches will use this routine.+  * use hash for cgi cache file names.+  * add preliminary experimental GUI support using wxhaskell.+  * remember author name after first record in a repo.+  * add unrevert command.+  * always match full pathnames when checking boringness or binaryness.+  * rewrite replace tokenizer for more speed.+  * make darcs compile with ghc 6.2 and later.+  * fix some bugs in darcs diff.+  * make --and-apply work locally as well as via ssh.+    Also added a --and-apply-as that uses sudo to run the apply command as+    a different user.++ -- David Roundy <droundy@abridgegame.org>  Mon, 10 Nov 2003 07:08:20 -0500++darcs (0.9.13)++  * Various performance enhancements.+  * add --pipe option to tag and record, which causes them to prompt for+    all their input, including date.  This can be useful when creating+    repository converters.+  * remove '-t' short command line option for '--to' and the '-o' short+    option for '--reponame'.+  * remove the darcs-patcher program.+        The functionality of the darcs-patcher program is taken over by+        the darcs apply command.  Several fancy features have been added,+        as described in the Apply section of the manual.+  * support spaces and (maybe) unicode in filenames.+  * updates to win32 support+  * push via ssh+  * add --without-libcurl option to configure+  * include DarcsURL in push email.+  * add support for reading and writing gzipped patch files.+  * allow multiple --to addresses on push, and also support --cc for+    additional addresses.+  * when pulling or pushing from lastrepo, say where lastrepo is.+  * only save lastrepo in get if the source repo wasn't a relative+    directory path.++ -- David Roundy <droundy@abridgegame.org>++darcs (0.9.12)++  * add manual section on building darcs.+  * improve scaling of checking for and resolving conflicts, which was an+    O(n^2) function.+  * escape ESC char when printing patches.+  * don't reorder patches unless necesary--this avoids an O(n^2) operation+    which was making a darcs record very slow when a lot of files were+    added.+  * fix default regexps for boring file (Thanks Trevor!)+  * replace now ignores files that aren't in the repo.+  * make darcs add refuse to add files whose subdirectories don't exist.+  * implement support for binary files.+  * added support for running external programs to fetch files.+  * fix conflict resolution bug from 0.9.11.+  * make the patcher run the test prior to applying.+  * add repo locking.+  * Fix bug when pulling from a repo containing just one patch (thanks+    Peter).+  * install cgi script in cgi-bin directory.++ -- David Roundy <droundy@abridgegame.org>++darcs (0.9.11)++  * A rewrite of the configure code and makefile (thanks to Peter Simons).+  * Added several new repository configuration options including a setpref+    command which allows you to set preferences options that are pulled+    from repo to repo.+  * Yet another rewrite of the merging code.+  * User can now revert changes on a change-by-change basis.+  * Yet another major improvement in speed and memory consumption.+  * Add a darcs diff command to compare two versions.++ -- David Roundy <droundy@abridgegame.org>  Mon, 30 Jun 2003 06:42:10 -0400++darcs (0.9.10)++  * Added a way to configure the default values for options to darcs+    commands.  See Appendix B of manual.+  * darcs push and pull now default to pulling and pushing from the most+    recently accessed repository (if you don't specify a repo).+  * Numerous bugfixes.++ -- David Roundy <droundy@abridgegame.org>  Wed, 21 May 2003 07:08:40 -0400++darcs (0.9.9)++  * Created a way to have a "centralized server".  (See darcs-patcher+    chapter in manual).+  * Added new darcs-server package.+  * Switch to new repository format.  Note that your repo will only be+    converted to the new format if you use certain commands such as+    unpull.  You can recognize the new format by the presence of a+    _darcs/inventories/ directory.+  * Add the ability to sign patches sent with push using gnupg and to+    verify those signatures when applying.  (This is the authentication+    basis for the above-mentioned server).+  * Fix bug in application of a file rename patch.++ -- David Roundy <droundy@abridgegame.org>  Thu,  8 May 2003 06:58:42 -0400++darcs (0.9.8)++  * Fix rare bug in check when files happen to be a multiple of 1024 bytes+    in length.+  * Fix bug in reading patch ids with long comments from local files.+  * Prepare for a change in the repository format.  The format doesn't+    change for this version, but version 0.9.8 is able to read the new+    repository format.++ -- David Roundy <droundy@abridgegame.org>  Wed, 30 Apr 2003 08:54:18 -0400++darcs (0.9.7)++  * Fix a couple of rename conflict bugs.+  * Add new test suite framework, along with several tests.+  * Several major optimizations for speed and memory.+  * Added --ignore-times option to not assume that when a file+    modification time hasn't changed the file itself hasn't changed.++ -- David Roundy <droundy@abridgegame.org>  Sat, 26 Apr 2003 07:57:01 -0400++darcs (0.9.6)++  * Fixed a couple of bugs in the merging of conflicting renames.+  * Added an interface to include long comments when recording.+  * Improve the interface of pull, allowing for viewing the patches before+    pulling them.+  * Include zsh command completion examples with docs.+  * Massively improved responsiveness in command completion.+  * Use packed strings to save memory.+  * Fixed a bug that shows up in empty repos.+  * Fixed multiple bugs in the mv command.++ -- David Roundy <droundy@abridgegame.org>  Thu, 17 Apr 2003 09:34:34 -0400++darcs (0.9.5)++  * Improve merge of creation of files and directories with the same name.+  * Add darcs push and apply commands, which are the beginning of work+    towards supporting a "centralized server" concept a la CVS.  However,+    they are also useful for a "Linus" style workflow, based on emailing+    patches.  In theory they could also be used to provide a smart server+    that could server pulls using less bandwidth.+  * Add an unpull command analagous to unrecord, but which removes the+    patches from the working directory also.+  * Enable the mv command, since the mv patches have now been supported by+    a couple of versions.+  * Include zsh_completion code, thanks to Aaron Denney <wnoise@ofb.net>.++ -- David Roundy <droundy@abridgegame.org>  Wed,  9 Apr 2003 07:52:01 -0400++darcs (0.9.4)++  * Speed up whatsnew and record in the case where there are huge numbers+    of extra files in the working directory.+  * Small (~10%) speedup in get.++ -- David Roundy <droundy@abridgegame.org>  Fri,  4 Apr 2003 09:08:38 -0500++darcs (0.9.3)++  * Optimized whatsnew and record by seting modification time of "current"+    files equal to that of working files if they are identical, so I won't+    have to check again if the working one hasn't been changed.+  * Rewrite file renaming code (no creation).+  * Add support for replacing tokens in files.+  * Make cgi output work more accurately, and point out which files were+    modified by each patch.+  * Add a caching feature to the cgi script to speed things up a bit.+  * Turn on creation of dependencies when recording.+  * Add a 'tag' command.+  * Rewrote the 'pull' code to hopefully speed it up (and in any case to+    greatly simplify it).++ -- David Roundy <droundy@abridgegame.org>  Thu,  3 Apr 2003 07:08:05 -0500++darcs (0.9.2)++  * Add build dependency on tetex and latex2html+  * Have internal diff code properly respond to deleted files and+    directories.+  * Create file and directory rename patch types. (no creation--which+    means that I am waiting to create commands to create such patches+    until later, to avoid backward compatibility issues of repos.)+  * Add support for patch dependencies. (no creation)+  * Add support for token replacement patches. (no creation)++ -- David Roundy <droundy@abridgegame.org>  Thu, 27 Mar 2003 07:59:09 -0500++darcs (0.9.1)++  * Make darcs get --verbose actually be verbose (which is important+    because it takes so long that the user might be afraid it's hanging.+  * Speed up the merge in complicated cases, possibly dramatically.+  * Add a darcs remove command.++ -- David Roundy <droundy@abridgegame.org>  Mon, 10 Mar 2003 09:48:55 -0500++darcs 0.9.0++  * Initial Release.++ -- David Roundy <droundy@abridgegame.org>  Wed,  3 Mar 2003 13:51:58 -0500++++Local variables:+mode: outline+outline-regexp: "[dD]\\| +\\*+"+paragraph-separate: "[  ]*$"+end:
GNUmakefile view
@@ -1,44 +1,10 @@-### XXX we eventually want building of the manual to be part of Setup.lhs--# hardcode some bits-RUBBER=rubber--DARCS = dist/build/darcs/darcs-PREPROC=./dist/build/darcs/darcs --preprocess-manual-PREPROCHTML=--html-TEXSOURCES = doc/src/darcs.tex $(wildcard doc/src/*.tex) $(filter %.lhs,$(DARCS_FILES))-doc/manual/darcs.tex: $(TEXSOURCES) $(DARCS)-	mkdir -p doc/manual-	$(PREPROC) darcs.tex $(PREPROCHTML) >$@-doc/manual/darcs_print.tex: $(TEXSOURCES) $(DARCS)-	mkdir -p doc/manual-	$(PREPROC) darcs.tex >$@--%.pdf: %.tex-	cd $(<D) && $(RUBBER) --pdf $(<F)--pdf: %: doc/manual/darcs.%-html: doc/manual/index.html-website: pdf html doc/manual/bigpage.html--### TODO use latex2html since bigpage seems to needslatex2html anyway;-###      we can restore hevea/tex4ht support when we move this to Setup.lhs-doc/manual/index.html: doc/manual/darcs.tex doc/src/gpl.tex doc/darcs.css-	latex2html -long_titles 2 -split +1 -dir doc/manual doc/manual/darcs.tex-	cp -f doc/darcs.css doc/manual/darcs.css--doc/manual/bigpage.html: doc/manual/darcs.tex doc/src/gpl.tex doc/darcs.css-	ln -sf darcs.tex doc/manual/bigpage.tex-	latex2html -split 0 -external_file darcs -prefix big \-		-no_auto_link -dir doc/manual doc/manual/bigpage.tex-	cp -f doc/darcs.css doc/manual/bigpage.css--doc/manual/darcs.pdf: doc/manual/darcs_print.pdf-	cp $< $@- # Good for tags. DARCS_FILES = $(wildcard src/[A-Z]*.hs src/*/[A-Z]*.hs src/*/*/[A-Z]*.hs) \-	      $(wildcard src/[A-Z]*.lhs src/*/[A-Z]*.lhs src/*/*/[A-Z]*.lhs)+	      $(wildcard src/*/*/*/[A-Z]*.hs src/*/*/*/*/[A-Z]*.hs) \+	      $(wildcard darcs/[A-Z]*.hs) \+	      $(wildcard harness/[A-Z]*.hs harness/*/[A-Z]*.hs) \+	      $(wildcard harness/*/*/[A-Z]*.hs harness/*/*/*/[A-Z]*.hs) \+	      $(wildcard harness/*/*/*/*/[A-Z]*.hs)  tags: $(DARCS_FILES) src/*.c 	hasktags -c $(filter %.lhs %.hs,$^)@@ -51,12 +17,3 @@  clean: 	rm -f TAGS tags-	rm -f doc/manual/bigpage.tex doc/manual/bigpage.css-	rm -f doc/manual/bigimg*.png doc/manual/bigimages.*-	rm -f doc/manual/*.html doc/manual/darcs*.??? doc/manual/darcs.lg-	rm -f doc/manual/darcs.html-	rm -f doc/manual/darcs.xref c_context.c-	rm -f doc/manual/WARNINGS doc/manual/*.pl-	rm -f doc/manual/images.* doc/manual/img*.png doc/manual/*.html--.PHONY: pdf html clean website
− NEWS 
@@ -1,2668 +0,0 @@-Darcs 2.8.5, 25 August 2014-  * GHC 7.8 support-  * Resolve issue2364: Download problems with GHC 7.8-  * Bump some dependencies: base, network, unix, process, array, mtl, text-  * Support matching on short patch hash-  * Resolve issue2345: Fix bug where configure script reported missing libiconv rather than libcurl-  * Darcs API: Rename iconv functions imported from haskeline to avoid name clash---Darcs 2.8.4, 7 February 2013-  * GHC 7.6 support-  * Bump some dependencies: base, network, unix, containers, bytestring, tar-  * Resolved issue2199: get --tag can include extra patches-  * Remove the --xml-output option to annotate: it stopped having any effect some time ago---Darcs 2.8.3, 4 November 2012--  * Darcs API: #ifdef some FFI imports so ghci works with -f-curl-  * Darcs API: Use darcs-specific names in sha2.c to avoid clashes with other packages---Darcs 2.8.2, 3 September 2012-- * Added PrimV1Job type to API to support darcsden---Darcs 2.8.1, 14 May 2012-- * Bumped mtl dependency- * Updated contact details to use development mailing list---Darcs 2.8, 22 April 2012-- * Important changes in Darcs 2.8--   * Local support for the legacy "old-fashioned" repository format-        has been removed.-      * You can still work with remote repositories in this format-      * Local repositories can still be upgraded via "darcs optimize --upgrade".-   * "darcs annotate" is now significantly faster and uses less memory, although it still slows down linearly with repository size.-   * An experimental option is available to speed up HTTP downloads.-      * You can now use "darcs optimize --http" to create a repo optimized for HTTP downloads, and use "darcs get --packs" to download such a repo.-      * There are still some known issues with it, so the feature is not enabled by default.-   * Darcs now supports multiple email addresses for the author in the global prefs file. So, if you use different identities for home and work, you can now easily select between them. (issue1530)-   * The -o/-O options for obliterate which were removed in 2.5 are back.-   * "darcs status" has been added as a hidden alias for "darcs whatnew -ls" to ease the transition from some other source control systems. (issue182)-   * "darcs amend-record" now has the option --unrecord to allow individual changes to be unrecorded. (issue1470). This can also be used as "darcs amend-unrecord".-   * "darcs amend-record"'s interactive selection now supports 'k' for going back to a previous patch.-   * "darcs dist" now has the option --set-scripts-executable. (issue734)-   * pushing to ssh:// URLS is now supported. eg: darcs push ssh://code.haskell.org/foo-   * If a test fails during darcs record, you now have the option to record it anyway. (issue332)-   * Hunk-splitting now works in "darcs revert" (issue114)-   * Sending patches by email is now more robust and human friendly. We display a cleaner version in plain text for humans, and have added a complete version of the patch for "darcs apply". (issue1350)-   * "darcs send" now tries to report the right character set in the email headers, and has the option --charset to override this.-   * A new environment variable has been added to help control network connections: DARCS\_CONNECTION\_TIMEOUT. See the manual for details.-   * The --ephemeral and --partials options to "darcs get" has been removed. "darcs check --partial" has also been removed.-   * "darcs rollback" now has a --no-record option, to be used when you only want to update the working directory.-   * The --nolinks option for "darcs get" was removed.-   * The "--old" flag has been removed for "darcs init", "darcs get" and "darcs put".-   * "darcs resolve" has been removed an alias for "darcs mark-conflicts".-   * "darcs init" and "darcs get" now have a --no-working-dir option.-   * Conflicts are now marked with red in the terminal. (issue1681)-   * ssh ControlMaster support has been removed.-   * ssh stderr output is now passed through, making it easier to diagnose problems. (issue845)-   * Interactive selection now has a 'g' command to go to the first patch.-   * The --unified flag is now available for record, end-record, revert and unrevert (issue1166)-   * darcs now has a "darcs test" command for running whatever test-suite is associated with the repository.-- * Other issues resolved in Darcs 2.8--   * 1266: "darcs init" now warns when run inside another darcs repo.-   * 1344: When using darcs send, let users know sooner if they won't eventually be able to send-   * 1397: darcs changes /bad /paths no longer lists all changes-   * 1473: problem with annotate --repodir-   * 1551: Now we only use 'file content did not change' prompt for darcs send-   * 1558: xml output for patch hash no longer includes "gz" extension-   * 1599: automatically expire unused caches-   * 1637: When darcs get fails due to a HTTP failure, port the actual HTTP failure.-   * 1640: darcs apply --verbose docs have been improved-   * 1661: darcs add --quiet is quieter-   * 1705: fix error with unhandled --index in "darcs show contents"-   * 1714: provide more sensible behavior when combining an "ALL" default with a default for a specific sub-command-   * 1727: a better diagnostic message is provided when the user tries to move the root of the repository-   * 1740: "darcs mv" now gracefully the handles the case where the user first does an "mv" on a directory and then follows up with a "darcs mv"-   * 1804: The diagnostic message "getSymbolicLinkStatus: does not exist" has been improved-   * 1883: rename --patch-name option to --name. This is usually used in darcs record in shorthand (-m) form. This rename is aimed at eliminating the confusion with the patch matcher, which bites amend-record and rollback users.-   * 1884: darcs get was wrongly reporting "getting lazy repository" when you hit C-c-   * 1908: try to create a global cache before checking its availability-   * 1922: Fixed bug where obliterate -o was producing incorrect bundles in some cases-   * 1923: bad source warning mechanism no longer warns about sources outside your control-   * 1932: Handling of files with colons is improved-   * 1965: attempting "darcs move" on non-repo files now gives a sensible error-   * 1977: "darcs repair" now no longer complains if the pristine.hashed directory is missing-   * 1978: Improve handling of the _darcs/format file with "darcs get"-   * 1984: "darcs convert" now gives a better error message for invalid repo names-   * 2013: "darcs send" no longer ignores --to (or default recipient) with --context-   * 2021: character encoding handling has been improved-   * 2041: "darcs add" no longer follows directory symlinks-   * 2054: The behavior when combining --boring with a boring file has been improved-   * 2066: "darcs record" better handles adding deleted and added files passed on the command line-   * 2067: darcs diff no longer outputs blank lines when non-existent files are given-   * 2076: "darcs move myfile" into directory confuses darcs-   * 2077: "darcs mv myfile" into directory no longer confuses darcs-   * 2079: "darcs put" now does --set-default by default-----Darcs 2.5.2, 14 March 2011-- * Important changes in Darcs 2.5.2--   * compatible with Haskell Platform 2011.2.0.0-   * bump parsec dependency for HP compatibility-   * fix regression allowing to add files inside boring directories-- * Issues resolved in Darcs 2.5.2--   * 2049: Darcs regression: 2.5 creates a broken patch--Darcs 2.5.1, 10 February 2011-- * Important changes in Darcs 2.5.1--   * original text is included in conflict marks-   * GHC 7.0 is supported-   * the version of GHC is restricted in the cabal file-   * warning message about old-fashioned repositories points to wiki-   * non-repository paths are guarded-   * library API: program name is configurable-   * darcs send prints the remote repository address right away-   * informational message about --set-default is disabled with --no-set-   * _darcs/format is correctly handled on get-   * linking libdarcs on Windows is fixed-- * Issues resolved in Darcs 2.5.1--   * 1978: get does not correctly treat _darcs/format-   * 2003: Message about --set-default should be optional-   * 2008: build with GHC 7.0-   * 2015: linking with libdarcs broken under Windows (2.5.0)-   * 2019: allow building with mtl 2-   * 2035: darcs accepts fake subpaths (relative paths outside of the repo)--Darcs 2.5, 30 October 2010:-- * Important changes in Darcs 2.5--   * trackdown can now do binary search with the --bisect option-   * darcs always stores patch metadata encoded with UTF-8-   * diff now supports the --index option-   * amend-record now supports the --ask-deps option-   * apply now supports the --match option-   * amend-record has a new --keep-date option-   * inventory-changing commands (like record and pull) now operate in-     constant time with respect to the number of patches in the repository-   * the push, pull, send and fetch commands no longer set the default-     repository by default-   * the --edit-description option is now on by default for the send command-- * Issues resolved in Darcs 2.5--   * 64:   store metadata as UTF-8-   * 121:  add --ask-deps support to amend-record-   * 643:  darcs send -o outputs remote repo email address-   * 1159: avoid bogus repository cache entries-   * 1176: caches interfere with --remote-repo flag-   * 1208: add trackdown --bisect-   * 1210: global cache gets recorded in _darcs/prefs/sources-   * 1232: darcs convert copies _darcs/prefs/prefs-   * 1250: check for newlines in setpref values-   * 1277: percolate repository format errors correctly-   * 1288: the main darcs code now compiles and runs with witnesses-   * 1290: support diff --index-   * 1337: don't show unrelated patches in darcs changes on untracked path-   * 1389: change predist pref to point people to use 'cabal sdist'-   * 1427: accept gzipped patch bundles in darcs apply-   * 1456: make dist write more portable archives-   * 1473: make annotate accept '.' as argument-   * 1503: prefer local caches to remote ones-   * 1713: shorter interactive prompts-   * 1716: allow mail header lines of all whitespace in test-   * 1719: do not back up files when no conflict markers are inserted-   * 1726: don't consider all files with _darcs prefix boring-   * 1739: make ColorPrinter handle characters > 255-   * 1763: use correct filename encoding in conflictors-   * 1765: refuse to remove non-tracked directories recursively-   * 1769: add support for --match 'comment ...'-   * 1784: push and pull print remote address right away-   * 1815: work around Cabal sdist permissions issue-   * 1817: fix support for external merge tools-   * 1824: avoid PACKAGE_VERSION under Windows-   * 1825: do not omit important prims in unrecordedChanges w/ files-   * 1860: (un)applying move patches doesn't corrupt pristine-   * 1861: fix typo in --no-boring help-   * 1874: recognise network tests on cabal test command line-   * 1875: avoid accidentally setting default-   * 1879: notice unexpected commute failure on merge-   * 1887: add a missing newline to --list-options output-   * 1893: move fields of conditional builds within scope of condition-   * 1898: notify user when they can use set-default-   * 1913: sort changes in treeDiff--Darcs 2.4.4, 9 May 2010-- * Important changes in Darcs 2.4.4--   * darcs builds on Windows with GHC 6.10 (and GHC 6.12).-   * darcs (built with GHC 6.12 on Windows) works with SSH again-- * Issues resolved in Darcs 2.4.4--   * 1814: Apply binary mode to ssh process and patch file handles.---Darcs 2.4.3, 9 May 2010-- * Important changes in Darcs 2.4.3--   * darcs builds on Windows with GHC 6.12.--Darcs 2.4.2, 8 May 2010-- * Important changes in Darcs 2.4.2--   * darcs will no longer give "mmap of _darcs_index" errors on Windows-   * darcs convert performance regression (against 2.3.x) solved-   * darcs get --partial no longer produces inconsistent repositories-- * Issues resolved in Darcs 2.4.2--   * 1761: mmap of '_darcs/index' failed on Windows mapped drives-   * 1814: include contrib/darcs-errors.hlint in release tarball-   * 1823: read (mmap) _darcs/index file correctly on Windows-   * 1826: error building on Windows with GHC 6.12-   * 1837: inconsistent repository upon darcs get --partial--Darcs 2.4.1, 31 March 2010-- * Important changes in Darcs 2.4.1--   * darcs works again on Windows shared directories-   * missing documentation and test files have been added to the tarball-   * darcs will no longer give errors about a nonexistent file when compiled-     with the wrong mmap-   * moving files between directories can no longer break the directory index-   * darcs handles the case that someone uses 'remove -r' on an-     untracked directory-- * Bugs Fixed in Darcs 2.4.1--   * 1750: uncover help text for 'darcs show pristine'-   * 1753: restrict mmap to version used by hashed-storage-   * 1754: fix issue458.sh on systems with xattrs-   * 1756: moving files between directories breaks index-   * 1757: add test files to distribution tarball-   * 1765: refuse to remove non-tracked directories recursively-   * 1767: send CRC erros to standard error---Darcs 2.4, 27 February 2010-- * Important changes in Darcs 2.4--   * Use fast index-based diffing everywhere (Petr)-   * Interactive patch splitting (Ganesh)-   * An 'optimize --upgrade' option to convert  to hashed format in-place-     (Eric)-   * Hunk matching (Kamil Dworakowski, tat.wright)-   * Progress reporting is no longer deceptive (Roman)-   * A 'remove --recursive' option to remove a directory tree from revision-     control (Roman)-   * 'show files' accepts arguments to show a subset of tracked files (Luca)-   * A '--remote-darcs' flag for pushing to a host where darcs isn't called-     darcs-   * Many miscellaneous Windows improvements (Salvatore, Petr and others)-   * 'darcs send' now mentions the repository name in the email body (Joachim)-   * Handle files with boring names in the repository correctly (Petr)-   * Fix parsing of .authorspellings file (Tomáš)-   * Various sane new command-line option names (Florent)-   * Remove the '--checkpoint' option (Petr)-   * Use external libraries for all UTF-8 handling (Eric, Reinier)-   * Use the Haskell zlib package exclusively for compression (Petr)-- * Bugs Fixed in Darcs 2.4--   *  183: do not sort changes --summary output-   *  223: add --remote-darcs flag to specify name of remote darcs executable-   *  291: provide (basic) interactive patch splitting-   *  540: darcs remove --recursive-   *  835: 'show files' with arguments-   * 1122: get --complete should not offer to create a lazy repository-   * 1216: list Match section in ToC-   * 1224: refuse to convert a repo that's already in darcs-2 format-   * 1300: logfile deleted on unsucessful record-   * 1308: push should warn about unpulled patches before patch-selection-   * 1336: sane error message on --last "" (empty string to numbers parser)-   * 1362: mention repo name in mail send body-   * 1377: getProgname for local darcs instances-   * 1392: use parsec to parse .authorspelling-   * 1424: darcs get wrongly reports "using lazy repository" if you ctrl-c -           old-fashioned get-   * 1447: different online help for send/apply --cc-   * 1488: fix crash in whatsnew when invoked in non-tracked directory-   * 1548: show contents requires at least one argument-   * 1554: allow opt-out of -threaded (fix ARM builds)-   * 1563: official thank-you page-   * 1578: don't put newlines in the Haskeline prompts-   * 1583: on darcs get, suggest upgrading source repo to hashed-   * 1584: provide optimize --upgrade command-   * 1588: add --skip-conflicts option-   * 1594: define PREPROCHTML in makefile-   * 1620: make amend leave a log file when it should-   * 1636: hunk matching-   * 1643: optimize --upgrade should do optimize-   * 1652: suggest cabal update before cabal install-   * 1659: make restrictBoring take recorded state into account-   * 1677: create correct hashes for empty directories in index-   * 1681: preserve log on amend failure-   * 1709: fix short version of progress reporting-   * 1712: correctly report number of patches to pull-   * 1720: fix cabal haddock problem-   * 1731: fix performance regression in check and repair-   * 1741: fix --list-options when option has multiple names-   * 1749: refuse to remove non-empty directories---Darcs 2.3.1, 20 Sep 2009-- * Important changes in Darcs 2.3.1--   * Fix bugs introduced by optimizations in 2.3.0 (Petr, Salvatore)-   * Documentation improvements (Taylor, Trent)-   * Remove autoconf build system (Petr)-- * Bugs Fixed in Darcs 2.3.1--   See http://bugs.darcs.net/issueN for details on bug number N.--   * issue1373 darcs manual wrongly promises [^ ] is a valid token spec (Trent)-   * issue1478: document summary mnemonics (Trent)-   * issue1582 DeleteFile: permission denied (Access is denied.) (Salvatore)-   * issue1507 whatsnew does not use 'current' when 'pristine' is missing (Petr)---Darcs 2.3.0, 23 Jul 2009-- * Important changes in Darcs 2.3.0--   * Lots and lots of documentation changes (Trent).-   * Haskeline improvements (Judah).-   * Cabal as default buildsystem (many contributors).-   * Fixes in darcs check/repair memory usage (Bertram, David).-   * Performance improvement in subtree record (Reinier).-   * New option: --summary --xml (Florian Gilcher).-   * New option: changes --max-count (Eric and Petr).-   * Fix changes --only-to-files for renames (Dmitry).-   * Performance fix in "darcs changes" (Benedikt).-   * Hardlinks on NTFS (Salvatore).-   * Coalesce more changes when creating rollbacks (David).-   * New unit test runner (Reinier).-   * Inclusion of darcs-shell in contrib (László, Trent).-   * Author name/address canonisation: .authorspellings (Simon).-   * Working directory index and substantial "darcs wh" optimisation (Petr).-   * New command: "darcs show index" (Petr).-   * Gzip CRC check and repair feature (Ganesh).-- * Bugs Fixed in Darcs 2.3.0--   See http://bugs.darcs.net/issueN for details on bug number N.--   *  948 darcsman (Trent)-   * 1206 countable nouns (Trent)-   * 1285 cabal test v. cabal clean (Trent)-   * 1302 use resolved, not resolved-in-unstable (Trent)-   * 1235 obliterate --summary (Rob)-   * 1270 no MOTD for --xml-output (Lele)-   * 1311 cover more timezones (Dave)-   * 1292 re-encoding haskeline input (Judah)-   * 1313 clickable ToC and refs in PDF manual Trent)-   * 1310 create merged \darcsCommand{add} (Trent)-   * 1333 better "cannot push to current repository" warning (Petr)-   * 1347 (autoconf) check for unsafeMMapFile if mmap use enabled (Dave)-   * 1361 specify required includes for curl in cabal file (Reinier)-   * 1379 remove libwww support (Trent)-   * 1366 remove unreachable code for direct ncurses use (Trent)-   * 1271 do not install two copies of darcs.pdf (Trent)-   * 1358 encode non-ASCII characters in mail headers (Reinier)-   * 1393 swap "darcs mv" and "darcs move" (Trent)-   * 1405 improve discoverability of global author file (Trent)-   * 1402 don't "phone home" about bugs (Trent)-   * 1301 remove obsolete zsh completion scripts (Trent)-   * 1162 makeAbsolute is now a total function (Ben F)-   * 1269 setpref predist - exitcode ignored bug (Ben M)-   * 1415 --edit-long-comment, not --edit-description, in help (Trent)-   * 1413 remove duplicate documentation (Trent)-   * 1423 complain about empty add/remove (Trent)-   * 1437 Implement darcs changes --max-count (Eric)-   * 1430 lazy pattern matching in (-:-) from Changes command module (Dmitry)-   * 1434 refactor example test (Trent)-   * 1432 refer to %APPDATA%, not %USERPROFILE% (Trent)-   * 1186 give a chance to abort if user did not edit description file (Dmitry)-   * 1446 make amend-record -m foo replace only the patch name (Dmitry)-   * 1435 default to get --hashed from a darcs-1.0 source (Trent)-   * 1312 update and reduce build notes (Trent)-   * 1351 fix repository path handling on Windows (Salvatore)-   * 1173 support hard links on NTFS (Salvatore)-   * 1248 support compressed inventories for darcs-1 repos (Ganesh)-   * 1455 implement "darcs help environment" (Trent)---Darcs 2.2.0, 16 Jan 2009-- * Important changes in Darcs 2.2.0--   * Support for GHC 6.10.-   * Improved Windows support.-   * Cabal is now supported as a build method for darcs.-   * Low-level optimisations in filesystem code.-   * Overhaul of the make-based build system.-   * Extensive manual and online help improvements.-   * Improved API documentation (haddock) for existing darcs modules.-   * Improvements in the testing infrastructure.-   * Improved performance for "darcs repair".-   * Improved robustness for "darcs check".-   * Numerous major and minor bug fixes, refactorings and cleanups.-   * When recording interactively it is now possible to list all-     currently selected hunks (command 'l').--   * It is now possible to specify --in-reply-to when using darcs send,-     to generate correct references in the mail header.--   * Repositories can no longer be created with --no-pristine-tree.-     This only affects the legacy darcs-1 repository format.--   * Experimental Darcs library, providing increase flexibility and-     efficiency to third-party utilities (compared to the command-line-     interface).  Only built via Cabal.  NOT a stable API yet.-- * Bugs Fixed in Darcs 2.2.0--   See http://bugs.darcs.net/issueN for details on bug number N.--   *  525 amend-record => darcs patches show duplicate additions-   *  971 darcs check fails (case sensitivity on filenames)-   * 1006 darcs check and repair do not look for adds-   * 1043 pull => mergeAfterConflicting failed in geteff (2.0.2+)-   * 1101 darcs send --cc recipient not included in success message-   * 1117 Whatsnew should warn on non-recorded files-   * 1144 Add darcs send --in-reply-to or --header "In-Reply-To:...-   * 1165 get should print last gotten tag-   * 1196 Asking for changes in /. of directory that doesn't exist...-   * 1198 Reproducible "mergeConflictingNons failed in geteff with ix"-   * 1199 Backup files darcs added after external merge-   * 1223 sporadic init.sh test failure (2.1.1rc2+472)-   * 1238 wish: darcs help setpref should list all prefs-   * 1247 make TAGS is broken-   * 1249 2.1.2 (+ 342 patches) local drive detection on Windows error-   * 1272 amend-record not the same as unrecord + record-   * 1273 renameFile: does not exist (No such file or directory)-   * 1223 sporadic init.sh test failure (2.1.1rc2+472)---darcs (2.1.2)-- * Quality Assurance: Disable a new test that was not yet working-   under Windows-- -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 10:40:00 GMT--darcs (2.1.1)-- -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 08:18:00 GMT--darcs (2.1.1rc2)--  * Portability: Removed accidental QuickCheck 2.1 configure check.-    Note that it may be required in a future version of darcs.-- -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 11:17:00 GMT--darcs (2.1.1rc1)--  * Portability: GHC 6.10.1 support (Petr Ročkai, Eric Kow)--  * Bug Fix: Fix file handle leak and check for exceptions on process-    running on Windows (issue784, Salvatore Insalaco)--  * Quality Assurance: Consolidated regression test suites using-    shell scripts only (Eric Kow, Tommy Petterson, Matthias Kilian)-- -- Eric Kow <kowey@darcs.net>  Mon, 10 Nov 2008 09:49:00 GMT--darcs (2.1.0)--  * Bug Fix: Eliminate a 'same URLs with different parameters' error when-    fetching files over HTTP (issue1131, Dmitry Kurochkin)--  * User Experience: Corrections to the default boring file (Ben Franksen)--  * Bug Fix: Fix the %a option in darcs send --sendmail-command (Ben Franksen)--  * Bug Fix: Do not obscure the SSH prompts or text editor output with-    progress reporting (issue1104, issue1109, Dmitry Kurochkin, David Roundy)--  * Bug Fix: pull --intersection work now works as advertised (Tommy-    Pettersson)-- -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 09 Oct 2008 12:05:32 GMT--darcs (2.1.0pre3)--  * Bug Fix: Eliminate an error merging repeated conflicts in darcs-2-    repositories (issue1043, David Roundy)--  * New Feature: Hide 'Ignore-this:' lines which will be generated by future-    versions of darcs to prevent patch-id collisions. (issue1102, Eric Kow,-    David Roundy)--  * Bug Fix: Support darcs repositories which have symbolic links in their-    paths (issue1078, Dmitry Kurochkin)--  * Bug Fix: Make ssh connection sharing (darcs transfer-mode) work with-    old-fashioned repositories (issue1003, David Roundy)-- -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 02 Oct 2008 09:12:41 GMT--darcs (2.1.0pre2)--  * IMPORTANT: Create darcs-2 repositories by default in darcs init (issue806,-    David Roundy)--  * User Experience: Do not allow users to add files to a darcs repository if-    their filenames would be considered invalid under Windows. This can be-    overridden with the --reserved-ok flag (issue53, Eric Kow)--  * Bug Fix: Do not leave behind a half-gotten directory if darcs get fails-    (issue1041, Vlad Dogaru, David Roundy)--  * User Experience: notice when you are trying to pull from a seemingly-    unrelated repository, that is one with a sufficiently different history.-    This can be overridden with the --allow-unrelated-repos flag (Dmitry-    Kurochkin, David Roundy)--  * Bug Fix: Fix hang after a user input error (for example, EOF) (Judah-    Jacobson)--  * Quality Assurance: Improvements to documentation and online help (Simon-    Michael)-- -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 25 Sep 2008 08:10:49 GMT--darcs (2.0.3pre1)--  * New Feature: Optional readline-like functionality when compiled with the-    haskeline package (Judah Jacobson, Gaëtan Lehmann)--  * Bug Fix: No more spurious pending patches (issue709, issue1012, David-    Roundy)--  * Bug Fix: darcs get --to-match now works with hashed repositories-    (issue885, David Roundy)--  * User Experience: Catch mistakes in _darcs/prefs/defaults (issue691, Dmitry-    Kurochkin)--  * User Experience: Improved support for darcs send over http (see also-    tools/upload.cgi) (Dmitry Kurochkin, David Roundy)--  * Bug Fix: Recognize user@example.com: as an ssh path, that is, not-    requiring a path after the server component. (David Roundy)--  * New Feature: Accept an optional directory argument in darcs send-    --output-auto-name (Dmitry Kurochkin)--  * User Experience: New --no-cache option to help debug network issues-    (issue1054, Dmitry Kurochkin)--  * Performance: New --http-pipelining and --no-http-pipelining flags. Passing-    --http-pipelining to darcs can make darcs get and pull faster over HTTP.-    Due to a libcurl bug, this is not the default option unless darcs is-    compiled with libcurl 7.19.1, due 2008-11. (Dmitry Kurochkin)--  * Bug Fix: Eliminate hanging and crashes while fetching files over HTTP-    (issue920, issue977, issue996, issue1037, Dmitry Kurochkin)--  * Security: Fix some insecure uses of printfs in darcs.cgi (Steve Cotton)--  * Bug Fix: Handle filepaths in a simpler and more robust fashion. This fixes-    relative filepaths and recognition of symbolic links and avoids possible-    future bugs (issue950, issue1057, David Roundy, Dmitry Kurochkin)--  * Bug Fix: Make darcs diff --patch work even if the patch is within a tag-    (issue966, darcs 2 regression, Dmitry Kurochkin)--  * Quality Assurance: Extend use of Haskell's GADTs to most of the darcs-    code, fixing many potential bugs along the way (Jason Dagit, David Roundy)--  * Quality Assurance: Several improvements to darcs code quality (Petr-    Ročkai)--  * Bug Fix: Correct assumptions made by darcs about Windows file size types-    (issue1015, Simon Marlow, Ganesh Sittampalam)--  * Bug Fix: Support case insensitive file systems using hashed repositories-    in darcs repair (partial issue971, Petr Ročkai). IMPORTANT: This-    introduces a memory use regression, which affects large repositories. We-    found that doing a darcs repair on the GHC repository requires a machine-    with 2 GB of RAM. The regression is well-understood and should be solved-    in the next darcs release. In the meantime we felt that the improved-    robustness was worth the performance trade-off.--  * Quality Assurance: Simplify building darcs on Windows by optionally using-    the zlib and terminfo Haskell packages (Ganesh Sittampalam, Petr Ročkai)--  * User Experience: Better error reporting when patches that should commute-    fail to do so. (Jason Dagit)--  * New Feature: --match "touch filenames", for example --match 'touch-    foo|bar|splotz.*(c|h)' (issue115, Dmitry Kurochkin)--  * User Experience: Improve debugging and error messages in HTTP code (Dmitry-    Kurochkin, David Roundy)--  * Bug Fix: Ensure that darcs responds to Ctrl-C on Window, even if compiled-    with GHC < 6.10 (issue1016, Simon Marlow)--  * New Feature: darcs changes --context now also works with --human-readable-    and --xml-output (issue995, Dmitry Kurochkin)--  * Bug Fix: Always darcs send with context, as if --unified flag were used-    (was implemented in 2.0.2, but not consistently) (David Roundy)--  * Bug Fix: Make sure that darcs get --tag works even when the user hits-    Ctrl-C to get a lazy repository (Dmitry Kurochkin)--  * Quality Assurance: Improvements to documentation and online help, most-    crucially, user-focused help on upgrading to darcs 2. (Trent Buck, Lele-    Gaifax, Simon Michael, Max Battcher)--  * New Feature: darcs changes --number associates each patch with number,-    counting backwards (see the --index feature) (David Roundy)--  * New Feature: ability to match patches on index, for example, darcs changes-    --index=3-6 shows the last three to six patches (David Roundy)--  * User Experience: slightly reduce the verbosity of darcs pull --verbose-    (David Roundy)-- -- Eric Kow <E.Y.Kow@brighton.ac.uk>  Sun, 18 Sep 2008 02:36:45 GMT--darcs (2.0.2)-- -- David Roundy <droundy@darcs.net>  Sun, 24 Jun 2008 01:20:41 GMT--darcs (2.0.1)--  * Bug Fix: Make Ctrl-C work even though darcs is now compiled to use the-    threaded runtime (issue916, David Roundy)--  * New Feature: Include patch count in darcs --version, for example, 2.0.1 (+-    32 patches) (David Roundy)--  * Bug Fix: Avoid an error caused by renaming a file on case-insensitive-    file-systems (Eric Kow)--  * Bug Fix and New Feature: Improved XML output (Benjamin Franksen, Lele-    Gaifax, David Roundy)--  * User Experience: Always darcs send with context, as if --unified flag were-    used (David Roundy)-- -- David Roundy <droundy@darcs.net>  Sun, 23 Jun 2008 21:47:07 GMT--darcs (2.0.1rc2)--  * Performance: Faster strings, using Data.Bytestring by default (Gwern-    Branwen, Eric Kow, Ian Lynagh, David Roundy)--  * User Experience: On Windows, use MS-DOS 'edit' as a default editor if-    Emacs and friends are not available (Eric Kow)--  * Bug Fix: On Windows, notice when external programs fail to launch because-    they do not exist (Eric Kow)--  * New Feature: darcs put --no-set-default and --set-default (Nicolas-    Pouillard)-- -- David Roundy <droundy@darcs.net>  Sun, 13 Jun 2008 01:17:45 GMT--darcs (2.0.1rc1)--  * Bug Fix: Fix tag --checkpoint so that darcs get --partial can avoid-    fetching all patches (issue873, David Roundy)--  * User Experience: Better progress reporting [NB: darcs is now compiled with-    threaded runtime by default] (issue739, David Roundy, Bertram Felgenhauer)--  * Performance: Reduce memory usage of darcs put (David Roundy)--  * Bug Fix: Improved date matching (issue793, issue187, Eric Kow)--  * Performance: Fix an optimization in diff-detection (affects darcs whatsnew-    and record) (Pekka Pessi)--  * Quality Assurance: --enable-hpc for checking program coverage (Christopher-    Lane Hinson)--  * Bug Fix: Do not rollback if no primitive patches were selected (issue870,-    Eric Kow)--  * Bug Fix: Make it possible to --dry-run on repositories we cannot write to-    (issue855, Eric Kow, David Roundy)--  * Bug Fix: Avoid a race condition caused by cleaning out the pristine cache-    (issue687, David Roundy)--  * User Experience: When pushing, prints a small reminder when the remote-    repository has patches to pull (Eric Kow, David Roundy)--  * UI changes: --extended-help is now called --overview, no more-    --verify-hash, no more send --unified (David Roundy, Eric Kow)--  * User Experience: Show ssh's stderr output in case it wants to ask the user-    something (issue845, Eric Kow)--  * Bug Fix: Improved interaction with pager (David Roundy, Pekka Pessi, Eric-    Kow)--  * Bug Fix: darcs send -o - (Pekka Pessi)--  * Bug Fix: (regression) Re-enable darcs mv as a means of informing darcs-    about manual renames (issue803, David Roundy)--  * Bug Fix: Fix bugs related to use of threaded runtime (issue776, David-    Roundy)--  * Portability: Respect OS conventions in creation of temporary files (Eric-    Kow)--  * New Feature: Check for and repair patches which remove non-empty files-    (issue815, David Roundy)--  * Bug Fix: Make get --to-match work with hashed repositories (David Roundy)--  * Bug Fix: Conflict-handling with darcs-2 semantics (issue817, David Roundy)--  * Bug Fix: Make --ask-deps ask the right questions (Tommy Pettersson)--  * User Experience: Improved error messages and warnings (issue245, issue371,-    Nicolas Pouillard, David Roundy, Eric Kow)--  * New Feature: darcs trackdown --set-scripts-executable (Reinier Lamers)--  * Quality Assurance: Various improvements to documentation (issue76,-    issue809, Gwern Branwen, Lele Gaifax, Eric Kow, Nicolas Pouillard, David-    Roundy)--  * Bug Fix: Correct detection of incompatibility with future darcs (issue794,-    Eric Kow)--  * User Experience: Make darcs changes --interactive behave more like other-    interactive commands (Eric Kow)--  * Performance: Optimized handling of very large files (Gwern Branwen)--  * New Feature: Colorize added and removed lines, if the environment variable-    DARCS_DO_COLOR_LINES=True (Nicolas Pouillard)--  * New Feature: --remote-repodir flag to allow separate default repositories-    for push, pull and send (issue792, Eric Kow)--  * Performance: Optimized get --to-match handling for darcs 1 repositories-    (Reinier Lamers)--  * Bug Fix: Make changes --repo work when not in a repository (David Roundy)--  * New Feature: darcs changes --count (David Roundy)-- -- David Roundy <droundy@darcs.net>  Sun, 03 Jun 2008 12:43:31 GMT--darcs (2.0.0)--  * Fix silly bug which leads to darcs --version not showing release when it's-    a released version. (David Roundy)-- -- David Roundy <droundy@darcs.net>  Sun, 07 Apr 2008 15:06:38 GMT--darcs (2.0.0rc1)-- -- David Roundy <droundy@darcs.net>  Sun, 01 Apr 2008 15:44:11 GMT--darcs (2.0.0pre4)--  * When darcs encounters a bug, check version versus central server in order-    to decide whether to recommend that the user report the bug.--  * Display duplicate identical changes when using darcs-2 repository format.-    (Issue579)--  * Fix a bug in convert that lead to invalid tags in the converted-    repository. (Issue585)--  * Add an annoying warning when users run convert.--  * Numerous fixes to the time/date matching code, which should now work even-    in central Europe. (Eric Kow)--  * Add support for reading hashed repositories that use SHA256 hashes. The-    plan is to enable writing of SHA256 hashes in the next release. (David-    Roundy)--  * New Feature: Add a 'show authors' command (Eric Kow)--  * darcs.cgi improvements: Patch pages show "Who" and "When" some file-    annotation pages show "who" and "when" with a mouse-over. Also, darcs.cgi-    can now be hosted in a path containing The tilde character. (Zooko, Mark-    Stosberg)--  * User Experience: Improved and added many debugging, error and progress-    messages (David Roundy, Mark Stosberg, Eric Kow)--  * New Feature: New DARCS_PATCHES, DARCS_FILES and DARCS_PATCHES_XML-    environment variables are made available for the posthook system, allowing-    for more easier options to to integrate darcs with other systems. (David-    Roundy, Mark Stosberg)--  * Quality Assurance: Added and updated automated regression tests (Mark-    Stosberg, David Roundy, Eric Kow, Trent Buck, Nicolas Pouillard, Dave-    Love, Tommy Pettersson)--  * Bug Fix: Gzipped files stored in the repo are now handled properly (Zooko,-    David Roundy)--  * Quality Assurance: Various Documentation Improvements (issue347, issue55-    Mark Stosberg, Nicolas Pouillard, Marnix Klooster)--  * Bug Fix: With --repodir, commands could not be disabled (Trent Buck, David-    Roundy)--  * New Feature: tools/update_roundup.pl scripts allows the darcs bug tracker-    to be notified with a darcs patch resolving a particular issue is applied.-    A link to the patch in the web-based repo browser is provided in the-    e-mail notifying bug subscribers. (Mark Stosberg)--  * Internal: Begin work on memory efficiency improvements (David Roundy)--  * Performance: darcs is faster when identifying remote repos handling-    pending changes and running unrecord. (David Roundy)--  * Internal: Source code clean-up and improvements (David Roundy, Jason-    Dagit, Eric Kow, Mark Stosberg)--  * User Experience: A pager is used automatically more often, especially when-    viewing help. (Eric Kow)--  * Bug Fix: push => incorrect return code when couldn't get lock. (issue257,-    VMiklos, David Roundy, Eric Kow, Mark Stosberg)--  * Bug Fix: 'whatsnew' and 'replace' now work together correctly. (Nicolas-    Pouillard, David Roundy)-- -- David Roundy <droundy@darcs.net>  Sun, 21 Mar 2008 15:31:37 GMT--darcs (2.0.0pre3)--  * Fix issue 244, allowing users of darcs changes to specify the new name of-    a file that has an unrecorded mv. (David Roundy, Mark Stosberg, Tuomo-    Valkonen)--  * Fix issue 600, bug in darcs optimize --relink. (David Roundy, Trent Buck,-    Mark Stosberg, Tommy Pettersson)--  * Add a new framework for outputting progress messages. If darcs takes more-    than about one second to run a command, some sort of feedback should now-    be provided. (David Roundy)--  * Rewrite rollback, changing its behavior to be more useful. Rollback now-    prompts for a name for the new "rollback" patches. It also allows you to-    roll back multiple patches simultaneously, and to roll back only portions-    of the patches selected. Altogether, rollback is now more interactive, and-    should also be more useful. (David Roundy)--  * Bug Fix: date parsing is now improved (Mark Stosberg, David Roundy)--  * Performance: Improved speed of darcs pull on very large repos. (David-    Roundy)--  * Fix issue 586, but in darcs repair on hashed and darcs-2 repositories.-    (Nicolas Pouillard)--  * Improve docs for 'darcs init' (Mark Stosberg)--  * Fix typo in test partial.sh which made part of the tests for --partial-    invalid. (Mark Stosberg)--  * Document that darcs handles some types of binary files automatically.-    (issue55, Mark Stosberg)--  * Fix typo in a test that made it compare a file to itself. (Mark Stosberg)--  * Document that single quotes should be used in .darcs/defaults. (issue347,-    Mark Stosberg)--  * New Feature: Automatically create the the global cache if we define we-    want to use it. (David Roundy, Trent Buck)--  * Performance: Improved HTTP pipelining support (Dmitry Kurochkin)--  * Fix issue 571, build failure when termio.h is not found. (Dave Love)-- -- David Roundy <droundy@darcs.net>  Sun, 22 Jan 2008 20:06:12 GMT--darcs (2.0.0pre2)--  * Add instructions in documentation for how to view patches in Mutt (a mail-    reader). (Gwern Branwen)--  * Fix build on Solaris. (Dave Love)--  * Added "auto-optimize" support for hashed inventories, in that darcs-    automatically optimizes inventories when it seems wise (which is currently-    defined as "every time we modify the inventory").--  * Fix expensive performance bugs involved in conflict handling. Thanks to-    Peter for pointing these out!.--  * Fix reading of hashed repositories to avoid reading patches that we don't-    actually need (i.e. foolish inefficiency bug). Thanks to Simon for-    reporting these performance bugs.--  * Added a new --debug flag for debug output.--  * Added compatibility with ghc 6.4. At this point darcs 2 should work with-    any ghc from 6.4 to 6.8.2.--  * Fix bug where parsing of setpref patch called tailPS unnecessarily. (David-    Roundy)--  * Refactor parsing of commands and command line arguments. Implement hidden-    commands. (Eric Kow)--  * Use a single command to initialize a remote repository. This replaces the-    method of stringing together multiple commands with the shell-dependent &&-    operator. (Tristan Seligmann)--  * Allow for files in _darcs/inventories to be gzipped. This is not-    specifically related to issue553, but it fixes a regression introduced by-    the issue553 fix. (Issue553, Eric Kow)--  * Check for potential hash collision in writeHashFile. (Eric Kow)--  * Don't try to write hash file if it already exists, as you can not-    overwrite an open file on Windows. (Issue553, Eric Kow)--  * Close file handles when done reading it lazily. (Eric Kow)--  * Modernize and enhance buggy renameFile workaround by using the-    hierarchical library structure and only catching 'does not exist' errors.-    (Eric Kow)--  * Add "hidden" printer for decorating patches with color for easier reading-    when printed to screen during verbose or debug output, but hides (removes)-    the decoration when printing to the repository files. This is the-    counterpart of the invisible printer, which makes non-human-friendly patch-    contents invisible when printed to the screen. (David Roundy)--  * Add "hidden" printer, for printing things to screen but not file. (David-    Roundy)--  * Make darcs distinguish between repository sub paths and "normal" relative-    paths. Better handling of absolute paths. (Eric Kow)--  * Fix some bugs introduced by Better handling of file paths. (Eric Kow)--  * Handle corner case when polling from self. (issue354, issue358, Eric Kow)--  * Handle corner cases when pulling from current repository. (Issue354,-    Issue358, Eric Kow)--  * Fix bug in make_dotdots when pushing from a sub directory. (issue268, Eric-    Kow)--  * Fix bug in make_dotdots when pushing from a subdirectory. (Issue268, Eric-    Kow)--  * Better handling of file paths. Distinguish between paths to files-    belonging to the repository as well as not belonging to the repository,-    both in absolute and relative form. (Eric Kow)--  * Add path fixing to darcs send, and don't try sending to self. (issue427,-    Eric Kow)--  * Fix path issue for darcs send. (Issue427, Eric Kow)--  * Disable mmap under Windows. (issue320, Eric Kow)--  * Backup unmanaged working dir files as needed. (issue319, issue440, Eric-    Kow)--  * Backup unmanaged files in the working directory when they are overwritten-    by managed files with the same names in pulled or applied patches.-    (Issue319, Issue440, Eric Kow)--  * Offer some advice if sendmail failed. (issue407, Eric Kow)--  * Document behavior of "boring" managed files. (Issue259, Eric Kow)--  * Make Doc a newtype, so we can define a Show instance. (David Roundy)--  * Make make_changelog GHC 6.8 compliant. (Ganesh Sittampalam)--  * GHC 6.8 needs containers package. (Ganesh Sittampalam)--  * Configure hack to deal with openFd -> fdToHandle' renaming in GHC 6.8.-    (Ganesh Sittampalam)--  * Make makefile summarize calls to GHC when compiling. VERBOSE=1 turns the-    long format back on. (Eric Kow)--  * When building, print summarized call to GHC in makefile, instead of very-    long command lines with many boring options. VERBOSE=1 reverts to showing-    options again. (Eric Kow)--  * Add svg logo. (David Roundy)--  * Add mercurial files to the default boring file. (David Roundy)--  * Add patterns for mercurial files to default boring patterns. (David Roundy)--  * Define color versions of traceDoc and errorDoc for debugging. (David-    Roundy)--  * Clarify error message for --last. (issue537, Eric Kow)--  * Clarify in error message that darcs option --last requires a *positive*-    integer argument. (Issue537, Eric Kow)--  * Optimize getCurrentDirectorySansDarcs a little. (Eric Kow)--  * Never create temporary directories in the _darcs directory. (issue348,-    Eric Kow)--  * Never create temporary directories in the _darcs directory. (Issue348,-    Eric Kow)--  * Make revert short help less cryptic. (Eric Kow)--  * Make revert short help less cryptic. (Eric Kow)--  * Make --checkpoint short help more explicit. (issue520, Eric Kow)--  * Make --checkpoint short help more explicit. (Issue520, Eric Kow)--  * Add format infrastructure for darcs-2 repo format. (David Roundy)--  * Always optimize the inventory in 'darcs tag'. (Eric Kow)--  * Fix bug in Tag --checkpoint where the inventory was not updated. (Eric Kow)--  * Fix accidental regression of --no-ssh-cm flag. (Eric Kow)--  * Move conditional #include from Darcs.External to makefile. The GHC manual-    says that this is *not* the preferred option, but for some reason, the-    include pragmas seem to get ignored. Perhaps it is because the requirement-    that the pragmas be on the top of the file conflict with the #ifdef-    statements. In any case, this patch gets rid of the warning on MacOS X:-    warning: implicit declaration of function 'tgetnum'. (Eric Kow)--  * Pass CFLAGS to the assembler. E.g. -mcpu is essential on sparc. (Lennart-    Kolmodin)--  * Optimize 'darcs optimize --reorder'. (David Roundy)--  * Add a table of environmental variables to the manual. (issue69, Eric Kow)--  * Use System.Directory.copyFile for file copying. (Kevin Quick)--  * Implement darcs show contents command. It shows the contents of a file at-    a given version. (issue141, Eric Kow)--  * Make Changes --context --repodir work. (Issue467, Erik Kow)--  * Rename 'query' to 'show', but keep 'query' as an alias. (There is also an-    extra alias 'list' that means the same as show.) The subcommand 'query-    manifest' is renamed to 'show files', and does not list directories by-    default, unless the alias 'manifest' is used. (Eric Kow)--  * Support record -m --prompt-long-comment. (issue389, Eric Kow)--  * Hide the command 'unpull' in favor of 'obliterate'. (Eric Kow)--  * Make option --no-deps work again. It now also works for obliterate,-    unrecord, push and send. (issue353, Tommy Pettersson)--  * Make Record --ask-deps abort if user types 'q' instead of recording-    without explicit dependencies. User is now required to type 'd' (done). If-    the resulting patch is completely empty (no changes and no dependencies)-    the record is automatically canceled. (issue308, issue329, Kevin Quick)--  * Use pure record-access for PatchInfo in Patch.Info. (David Roundy)--  * Improve error message when unable to access a repository. (David Roundy)--  * Switch to using new Haskell standard library function cloneFile for-    copying files. (Kevin Quick)--  * Remove more GUI code. (Eric Kow)--  * Fix some --dry-run messages: "Would push" instead of "Pushing". (issue386,-    Eric Kow)--  * Ensure that logfile for record has trailing newline. (issue313, Eric Kow)--  * Add a stub command 'commit' that explains how to commit changes with-    darcs. (Eric Kow)--  * Makes non-repository paths in DarcsFlags absolute. (issue427, Zachary P.-    Landau)--  * Fix problem with missing newline in inventory, to simplify for third party-    scripts. (Issue412, Eric Kow)--  * Add all pulled repositories to _darcs/prefs/repos. (Issue368, Eric Kow)--  * Implement Apply --dry-run. (Issue37, Eric Kow)--  * Never change defaultrepo if --dry-run is used (issue186, Eric Kow)--  * Filter out any empty filenames from the command line arguments. (Issue396,-    Eric Kow)--  * Use prettyException in clarify_errors so we don't blame user for darcs'-    own errors. (Issue73, Eric Kow)--  * Rename command 'resolve' to 'mark-conflicts'. 'Resolve' remains as a-    hidden alias. (issue113, Eric Kow)--  * Make 'query manifest' list directories by default. (issue456, Eric Kow)--  * Allow --list-options even if command can not be run. (issue297, Eric Kow)--  * Make 'unadd' an alias for 'remove'. Make 'move' an alias for 'mv'. Add a-    stub for 'rm' that explains how to remove a file from a darcs repository.-    (issue127, Eric Kow)--  * Fix <supercommand> --help. (Issue282, Eric Kow)--  * New --nolinks option to request actual copies instead of hard-links for-    files. (Kevin Quick)--  * Harmonize capitalization in flags help. (Eric Kow)--  * Define datarootdir early enough in autoconf.mk.in. (Issue493, Eric Kow)--  * Fix a bug where Get --partial would use a checkpoint without detecting it-    was invalid. Checkpoints can for example become invalid after an Optimize-    --reorder. (issue490, David Roundy)--  * User Agent size limit for curl gets is removed. (Issue420, Kevin Quick)--  * Don't garb string parameters passed to libcurl, as required by the api-    specification. (Daniel Gorin)--  * Fix handling of --repo with relative paths. (Eric Kow)--  * Check for gzopen in zlib. curl depends on zlib and is detected prior to-    zlib by the configure file, but without the -lz flag on some versions.-    (Andres Loeh)--  * Switch to haskell's System.Process under Unix for execution of external-    commands; requires GHC 6.4. (Eric Kow)--  * Remove (some more) conflictor code. (Eric Kow)--  * Remove (unused) conflictor code. (David Roundy)--  * Support makefile docdir/datarootdir variables. (Dave Love)--  * Added prehooks that works the same as posthooks, but they run before the-    command is executed. This can for example be used to convert line endings-    or check character encodings before every Record. The darcs command aborts-    if the prehook exits with an error status. (Jason Dagit)--  * Use system instead of rawSystem for calling interactive cmds in Windows,-    which lets us support switches, for example, in DARCS_EDITOR. (Eric Kow)--  * add support for partial and lazy downloading of hashed repositories.-    (David Roundy)--  * Fix refactoring bug in Checkpoints where we sometimes looked for things in-    the wrong place. (David Roundy)--  * Fail on error in get_patches_beyond_tag. This will expose any bugs where-    we use this function wrongly. (As was the case in darcs check --partial-    with hashed inventories.) (David Roundy)--  * Restructure the source tree hierarchy from a mostly flat layout to one-    with directories and subdirectories that reflects the modularity of the-    source. (Eric Kow)--  * In tests, don't assume grep has -q and -x flags. (Dave Love)--  * Add --output-auto-name option to Send (Zachary P. Landau)--  * Added regression testing for the "pull --complement" operation. Updated-    documentation to explain why "darcs pull --complement R1 R1" is the same-    as "darcs pull R1" instead of the empty set. (Kevin Quick)--  * Change all "current" to "pristine" in manual and help texts. (Tommy-    Pettersson)--  * Added the ability to specify the --complement argument on the pull command-    as an alternative to --intersect and --union. When --complement is-    specified, candidate patches for a pull are all of the pullable patches-    that exist in the first repository specified but which don't exist in any-    of the remaining repositories (the set-theory complement of the first-    repository to the union of the remaining repositories). (Kevin Quick)--  * Fix bug where darcs would try to write temporary files in the root-    directory (/) if it couldn't find a repository root to write them in. Now-    it uses the current directory in that case. (issue385, Zachary P. Landau)--  * Make write_repo_format use the same syntax as read_repo_format when-    dealing with different repository formats. (Benedikt Schmidt)--  * Remove some unused functions from Population. (Eric Kow)--  * Use IO.bracket instead of Control.Exception.bracket in Exec, to restore-    the old way darcs works on *nix. (Eric Kow)--  * Import bracketOnError from Workaround instead of Control.Exception to-    support GHC 6.4. (Eric Kow)--  * Switch to haskell's System.Process under Windows for execution of external-    commands; requires GHC 6.4. (Simon Marlow)--  * Fix bug where darcs ignored command arguments in the VISUAL environment-    variable. (issue370, Benedikt Schmidt)--  * Make annotate work on files with spaces in the name. (Edwin Thomson)--  * Prettify exceptions in identifyRepository. (Juliusz Chroboczek)--  * QP-encode patch bundles transfered with the Put command. (Juliusz-    Chroboczek)--  * Fix bug in darcs get --tag that left cruft in pending. (David Roundy)--  * Fix bug when trying to 'darcs mv foo foo'. (issue360, David Roundy)--  * Separate comment from OPTIONS pragma for GHC 6.4 compatibility. (Eric Kow)--  * Make hashed inventories support optimize and reordering. (David Roundy)--  * Change all Maybe Patch to the new type Hopefully Patch, which is similar-    to Either String, for storing patches that may or may not exist. This-    should make it much easier to improve error reporting. (David Roundy)--  * Fix pending bug that broke several_commands.sh. (David Roundy)--  * Fix hashed inventory bug in Add. (David Roundy)--  * Make Get and Put reuse code for Initialize. This makes Put accept any-    flags that Init accepts. (David Roundy)--  * Fix new get to not mess up pending. (David Roundy)--  * External resolution can resolve conflicting adds. (Edwin Thomson)--  * Only copy the files that are needed for the resolution, when invoking an-    external resolution tool. This saves much time and resources on-    repositories with many files in them. (Edwin Thomson)--  * Change message in 'darcs check' from "applying" to "checking". (issue147,-    Tommy Pettersson)--  * Add code fore hashed inventories. (David Roundy)--  * New option for Diff: --store-in-memory. darcs diff usually builds the-    version to diff in a temporary file tree, but with --store-in-memory it-    will represent the files in memory, which is much faster (unless the tmp-    directory already is a ram disk). (Edwin Thomson)--  * Fix bug where duplicated file names on the command line would fool darcs.-    (issue273, Tommy Pettersson)--  * When recording with option --pipe, assume users local timezone if none is-    given, instead of UTC. Except if the date is given in raw patch format-    'yyyymmddhhmmss' it is still parsed as UTC. (issue220, Eric Kow)--  * Account for timezone information, e.g. in dates when recording with option-    --pipe. (issue173, Eric Kow)--  * Fix bug in refactoring of get. (David Roundy)--  * Refactor repository handling to allow truly atomic updates. (David Roundy)-- -- David Roundy <droundy@darcs.net>  Sun, 16 Dec 2007 20:16:47 GMT--darcs (1.0.9)--  * Make shell harness failures fatal in Makefile. (Eric Kow)--  * Bugfix, fix bug where we add a file but not its boring parent directory.-    (David Roundy)--  * Allow escaped quotes in 'quoted' for match text. (Dave Love)--  * Don't exit with failure when tests_to_run is used and there are no perl-    tests. (David Roundy)--  * Apply patches "tolerantly" to the working directory; don't quit, but print-    a warning for every problem and continue. This is a workaround for a bug-    in darcs where it sometimes fails to update the working directory. When-    darcs updates the working directory it has already successfully updated-    the inventory and the pristine cache, so the repository itself is not-    corrupted. However, an incomplete update to the working directory results-    in unintended differences between the working and pristine tree, looking-    like spurious unrecorded changes. These can be easily removed with 'darcs-    revert', but spurious changes have to be manually sorted out from real-    unrecorded changes. By darcs no longer quiting at the first problem, more-    of the working tree gets updated, giving less spurious changes and less-    manual work to fix the mess should the bug bite you. (issue434, Eric Kow,-    David Roundy)--  * Add a README file, created from HACKING. (issue287, Eric Kow)--  * New command, query tags (similar to 'darcs changes -t .) (Florian Weimer)--  * Include the query commands in the manual. (Florian Weimer)--  * The ssh control master is now off by default (it seems to hang on some-    large repositories). The option --disable-ssh-cm is replaced by the two-    options --ssh-cm and --no-ssh-cm (default). (Eric Kow)--  * Do not append a colon to host name when calling sftp. This does not solve-    all of issue362, just a minor annoyance along its way. (issue362, Eric Kow)--  * Get 'open' and 'psignal' declared on Solaris. (Dave Love)--  * Zsh completion supports new _darcs/pristine repository format. (Georg Neis)--  * Add documentation for DARCS_PAGER. (Benedikt Schmidt)--  * Turning off and on the ssh control master works for the Changes command.-    (issue383, Georg Neis)--  * Optimize unrecorded file moves with unrecorded file adds and removals.-    That is, if you add, rename and remove files multiple times without-    recording, whatsnew (and record) will only see the final result, not the-    whole sequence of moves. (Marco Tulio Gontijo e Silva)--  * Fix link error with errno for gcc 4.12 / glibc 2.4. (Benedikt Schmidt)--  * Remove the confusing text "user error" from some of GHC's error-    descriptions. (Juliusz Chroboczek)--  * Check for and fail build configuration if module quickcheck isn't-    available. (issue369, David Roundy)--  * Make darcs push QP-encode the bundle before transferring. This should-    hopefully fix issues with scp/sftp corrupting bundles in transit. (Juliusz-    Chroboczek)--  * Make it very clear in the documentation that the options --from and-    --author does NOT have anything to do with the sender or email author when-    sending patches as email with the darcs Send command. (Kirsten Chevalier)--  * Allow commented tests in tests_to_run. (David Roundy)--  * Make it an error to Put into a preexisting directory. Often one could be-    tempted to try to put into a directory, expecting to have the repository-    created as a subdirectory there, and it is confusing to have instead the-    repository contents mingled with whatever was already in that directory.-    (David Roundy)--  * Explicitly flush output on Windows after waiting for a lock, because-    Windows' stdout isn't always in line-buffered mode. (Simon Marlow)--  * Improve unhelpful "fromJust" error message in Push command. (Kirsten-    Chevalier)--  * Support option --all for Obliterate, Unpull and Unrecord. (issue111, David-    Roundy)--  * Ignore failure to set buffering mode for terminal in some places-    (supposedly fixes issue41, issue94, issue146 and issue318). (Tommy-    Pettersson)--  * Buildfix, don't import Control.Exception functions when compiling on-    Windows. (Edwin Thomson)--  * Add make rules for tag files. (Dave Love)--  * Add a semi-automated test for SSH-related things. (Eric Kow)--  * Allow Dist --dist-name to put the tar file in any directory by giving a-    full path as the dist name. (issue323, Wim Lewis)--  * Add rigorous error checking when darcs executes external commands. All-    low-level C return values are checked and turned into exceptions if they-    are error codes. In darcs main ExecExceptions are caught and turned into-    error messages to help the user. (Magnus Jonsson)--  * Redirect error messages from some external commands to stderr. (Tommy-    Pettersson)--  * Make configure fail if a required module is missing. (David Roundy)--  * The options for turning off and on the ssh control master works from the-    defaults file. (issue351, Tommy Pettersson)--  * Amend-record now keeps explicit dependencies (made with --ask-deps) from-    the amended patch. (issue328, Edwin Thomson)--  * Make libcurl use any http authentication. This let darcs use repositories-    protected with digest authentication. (Tobias Gruetzmacher)--  * Turning off and on the ssh control master works for the Send command.-    (Eric Kow)--  * Redirect stderr to Null when exiting SSH control master. This suppresses-    the output "Exit request sent" not suppressed by the quiet flag. (Eric Kow)--  * Fix curses stuff, especially on Solaris 10. (Dave Love)--  * Annotate various boring patterns. (Dave Love)-- -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 03 Jun 2007 21:37:06 GMT--darcs (1.0.9rc2)--  * Pass e-mail address only for %t in --sendmail-command. Msmtp seems to-    require this. Note that the full address is encoded in the message body.-    (Eric Kow)--  * Show error messages on stderr when starting and stopping the ssh control-    master. (Tommy Pettersson)--  * Rewrite check for spoofed patches with malicious paths. The check can now-    be turned off with the option --dont-restrict-paths (issue177). The new-    check only works for Apply and Pull, and it only looks at the remote-    patches. A more complete check is desirable. (Tommy Pettersson)--  * Add LGPL file referenced in fpstring.c (Dave Love).--  * Update FSF address in copyright headers(Dave Love).--  * New default boring file patterns: ,v .# .elc tags SCCS config.log .rej-    .bzr core .obj .a .exe .so .lo .la .darcs-temp-mail .depend and some more-    (Dave Love).--  * Move darcs.ps to the manual directory (Tommy Pettersson).--  * Pass -q flag to scp only, not ssh and scp. Putty's SSH (plink) does not-    recognize the -q flag. (issue334, Eric Kow)--  * Bugfix. Make darcs.cgi look for both pristine and current (Dan).--  * Don't lock the repo during `query manifest' (issue315, Dave Love).--  * Buildfix. Include curses.h with term.h (issue326, Dave Love).--  * Bugfix. Unrecord, Unpull and Obliterate could mess up a repository-    slightly if they removed a tag with a corresponding checkpoint. Only the-    commands Check and Repair were affected by the damage, and Get would also-    copy the damage to the new repository. (issue281, Tommy Pettersson)--  * Add a HACKING file with helpful references to pages on the darcs wiki-    (Jason Dagit).--  * New boring file patterns: hi-boot o-boot (Bulat Ziganshin, Eric Kow).--  * Require 'permission denied' test for MacOS X again. Perhaps something in-    MacOS X was fixed? (Eric Kow).--  * Look for Text.Regex in package regex-compat. Needed for GHC 6.6. (Josef-    Svenningsson)-- -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 16 Nov 2006 14:03:51 GMT--darcs (1.0.9rc1)--  * Improved handling of input, output and error output of external commands.-    Null-redirection on windows now works. Only stderr of ssh is-    null-redirected since putty needs stdin and stdout. (issue219, Eric Kow,-    Tommy Pettersson, Esa Ilari Vuokko)--  * Optimize away reading of non-managed files in summary mode of Whatsnew-    --look-for-adds (issue79, Jason Dagit).--  * Remove direct dependency to mapi32.dll; Improve MAPI compatibility. (Esa-    Ilari Vuokko)--  * Ignore .git if _darcs is found (Juliusz Chroboczek).--  * Add a haskell code policy test to catch uses of unwanted functions, bad-    formating and such. (Tommy Pettersson)--  * If the logfile supplied with option --logfile does not exist, fail instead-    of inserting no long comment. (issue142, Zachary P. Landau)--  * Make the pull 'permission test' work when run as root (Jon Olsson).--  * Handle unsimplified patches when further simplifying the summarized-    output. For unknown reason (a possibly previous version of) darcs allows a-    single patch to Add and Remove the same file in a single patch. The-    Changes command used to combine them, showing just a Remove. (issue185,-    Lele Gaifax)--  * Add workaround for HasBounds that was removed in GHC 6.6 (Esa Ilari-    Vuokko).--  * Really make --disable-ssh-cm work (issue239, Eric Kow).--  * Fix false errors in pull.pl test (David Roundy).--  * Clean up docs on DarcsRepo format (David Roundy).--  * Use stdin for passing the batch file to sftp, to allow password-based-    authentication (issue237, Eric Kow, Ori Avtalion).--  * Make darcs fail if the replace token pattern contains spaces. It would-    otherwise create a non-parsable patch in pending. (issue231, Tommy-    Pettersson)--  * Set a default author in the test suite harness so not every test has to do-    so. (Tommy Pettersson).--  * Run external ssh and scp commands quietly (with the quiet flag), but not-    sftp which doesn't recognize it (issue240). This reduces the amount of-    bogus error messages from putty. (Eric Kow)--  * Implement help --match, which lists all available forms for matching-    patches and tags with the various match options (Eric Kow).--  * Added .elc and .pyc suffixes to default binary file patterns (Juliusz-    Chroboczek ).--  * Added a link to the 'projects' part of the cgi repository interface, so-    that you go back to the project list (Peter Stuifzand).--  * Add a test suite for calling external programs (Eric Kow).--  * Don't warn about non-empty dirs when in quiet mode (Eric Kow).--  * New option --umask. This is best used in a repository's defaults file to-    ensure newly created files in the repository are (not) readable by other-    users. It can also be used when invoking darcs from a mail reader that-    otherwise sets a too restrictive umask. (Issue50, Juliusz Chroboczek)--  * Only check for ssh control master when it might be used. This suppresses-    the annoying "invalid command" error message. (Issue171, Eric Kow)--  * Fail with a sensible message when there is no default repository to pull-    from. (Lele Gaifax)-- -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 08 Oct 2006 17:52:07 GMT--darcs (1.0.7)--  * Fixed bug leading to a spurious "darcs failed: resource vanished" error-    message when darcs output is piped to a program such as head that then-    exits. (Issue160, David Roundy)--  * New option --diff-command overrides the default value of "diff" when darcs-    calls an external program to show differences between versions (Eric Kow).--  * Use the ControlMaster feature in OpenSSH version 3.9 and above to-    multiplex ssh sessions over a single connection, instead of opening a new-    connection for every patch (Issue32, Eric Kow).--  * Add a standalone graphical interface (experimental). The gui code prior to-    this patch allows graphical darcs forms to be run from the command line.-    This builds off that functionality by adding a graphical front-end,-    allowing users to access these forms with a click of a button. In other-    words, this allows users to run darcs without the command line. (Eric Kow)--  * Make unpull, unrecord, obliterate accept --gui (Eric Kow).--  * Freshen GUI code so that it compiles (Eric Kow).--  * Provide more information when a remote repository can't be correctly-    identified. (Juliusz Chroboczek)--  * The Send command can save, reuse and delete the accompanying description-    in a logfile. (Zachary P. Landau)--  * Display list of subcommands when getting help on a supercommand. (Eric Kow)--  * A proper fix for the problem with rmdir when there are non-managed files-    left in the working copy of the directory so it can't really be removed.-    This solves the two related problems with a missguiding error message in-    one case, and an unreported repository corruption in the other. Now there-    is no false warning and no repository coruption. (issue154, Eric Kow)--  * Escaping of trailing spaces and coloring now works with in the pager-    called with 'p' from interactive dialogues. (issue108, Tommy Pettersson)--  * Added default recognized binary file extensions: bmp, mng, pbm, pgm, pnm,-    ppm, tif, tiff. (Daniel Freedman)--  * Added a RSS link to common.xslt. (Peter Stuifzand)--  * Make short option -i a synonym for --interactive (Zachary P. Landau).--  * Improved argument substitution for --external-merger. All apperences of %N-    are replaced, not only those occurring as single words. (Daan Leijen)--  * Transition from _darcs/current to _darcs/pristine completed. New-    repositories are created with a "pristine" directory. Previous versions of-    darcs have been looking for this directory since version 1.0.2, but older-    versions than that can't read the new repository format. (Juliusz-    Chroboczek)--  * If you specify a repository directory, any absolute paths prefixed by this-    directory are converted to be ones relative to the repodir. (issue39, Eric-    Kow)--  * The --repodir flag works with many more commands: changes, dist, get,-    optimize, repair, replace, setpref, tag, trackdown. (RT#196, RT#567, Eric-    Kow)--  * The --repodir flag works with initialize command, and tries to create it-    if it does not exists. (RT#104, Eric Kow)--  * Add autom4te.cache to default boring patterns. (Kirill Smelkov)--  * Don't create temporary copies of the repository for the external merger-    program, unless there is for sure some conflict to resolve. (Edwin Thomson)--  * Modify Changes --interactive dialogue to behave like other interactive-    commands: accept 'y' and 'n' as answers and exit automatically after last-    question. (Zachary P. Landau)--  * Unnamed patches are now called "changes" in the interactive patch-    selection dialogues. (Tommy Pettersson)--  * Treat Enter as an invalid response in single character prompt mode, and-    give feedback instead of being mysteriously silent and unresponsive.-    (RT#261, Eric Kow)--  * Make short option -f a synonym for --force (Zooko).--  * Posthooks no longer cause an output message about success or failure,-    unless the --verbose option is used. (Jason Dagit)--  * Fix crash when using changes --interactive with --patch or --match-    (Zachary P. Landau).-- -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 13 May 2006 17:14:38 GMT--darcs (1.0.6)-- -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 28 Feb 2006 11:18:41 GMT--darcs (1.0.6rc1)--  * Check paths when applying patches to files and directories to stop-    maliciously handcrafted patches from modifying files outside of the-    repository or inside darcs private directories (issue48, Tommy Pettersson).--  * Revert optimization that sometimes applied patches incorrectly and-    corrupted the repository. This make darcs somewhat slower when applying-    patches. A full pull of the darcs repository itself takes 50% longer.-    (issue128, Tommy Pettersson).--  * Fix bug in Get --tag that produced a corrupt repository (issue67, Edwin-    Thomson).--  * Add newline between long comment and changed files list in dry-run summary-    to remove ambiguity (Edwin Thomson).--  * Extended date matching functionality: ISO 8601 dates and intervals, a-    larger subset of English like "yesterday at noon" (issue31/RT#34, Eric-    Kow).--  * Allow rename to different case (RT #466, Eric Kow).--  * Save long comment in a file if record fails the test run (Zachary P.-    Landau).--  * Fix win32 build breaks (Will Glozer).--  * Make --exact-version work when darcs is built from distributed tar ball-    (Marnix Klooster).--  * Coalesce pending changes created with setpref (issue70/RT#349, Eric Kow).--  * Support --interactive option in changes command (issue59, Zachary P.-    Landau).--  * New help command (RT#307, Eric Kow).--  * Add --without-docs option to configure (Richard Smith).--  * Obey normal autoconf conventions. Allows you to 'make install prefix=...'-    and doesn't change default for sysconfdir. (Dave Love)--  * Fix bug with non-existing directories. (David Roundy)--  * Remote apply does not use cd to change current directory to target-    directory any more. It uses --repodir when invoking remote darcs. This may-    break some darcs wrappers. (Victor Hugo Borja Rodriguez)--  * Support signed push (Esa Ilari Vuokko).--  * Added support for pulling from multiple repositories with one pull. The-    choice of --union/--intersection determines whether all new patches are-    pulled, or just those which are in all source repositories. This feature-    implements a suggestion by Junio Hamano of git. (David Roundy)--  * Patch bundle attachments get a file name, based on the first patch.-    (Zachary P. Landau)--  * The send command now takes a --subject flag. (Joeri van Ruth)--  * Fix --set-scripts-executable to work also when getting a local repository.-    (issue38, Eric Kow)--  * Removed the helper program darcs-createrepo. It was used for guided settup-    of a darcs repository and a corresponding user account to accept patches-    from signed emails. (issue14, Jason Dagit)--  * Print out the patch name when a test fails. (Zachary P. Landau).--  * Bugfix for --sendmail-command in Windows (Esa Ilari Vuokko).--  * Make apply --verify work with GnuPG in Windows (Esa Ilari Vuokko)--  * Bugfix for handling of absolute paths in Windows (issue47, Will Glozer)-- -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 19 Feb 2006 23:19:19 GMT--darcs (1.0.5)--  * Fixes for Windows (Will Glozer).--  * Adapt makefile to work with current ghc 6.4 (Will Glozer).--  * --help and --list-commands ignore other options (issue34, Eric Kow).--  * Fix apply with --verify for patch bundles signed by GnuPG in Windows (Esa-    Ilari Vuokko).--  * Make patch selection options together with --context work again (Daniel-    Bünzli).--  * Make option --commands outside of a repository work again (issue9, David-    Roundy).--  * Bugfix for pushing with ssh under Windows (issue15, Will Glozer).--  * Fix superfluous input bug in test suite (Florian Weimer).--  * Many English and markup fixes (Dave Love).-- -- Tommy Pettersson <ptp@lysator.liu.se>  Sun, 07 Dec 2005 11:27:30 GMT--darcs (1.0.4)--  * Fixed a bug in the external conflict resolution code. (bug #577, David-    Roundy)--  * Fixed a bug which made apply sometimes (but rarely) fail to check the the-    hash on patch bundles corrupted in just the wrong way. (David Roundy)--  * Added a simple check to darcs replace that avoids tokenizing lines that-    don't contain the token we're replacing. I feel a bit bad about-    introducing an optimization this late in the release cycle, but it makes a-    huge difference, and really should be safe. (David Roundy---famous last-    words)--  * Fixed bug where darcs didn't honor the SSH_PORT environment variable when-    calling sftp. (bug #576, fix suggested by Nicolas Frisby)--  * Avoid putting a wrongly-named directory in the tarball generated by darcs-    dist, if the name we wanted already exists in $TMPDIR. (Simon McVittie)--  * Fixed bug which caused "pull_firsts_middles called badly" errors when-    running record with --ask-deps flag. (bug #476, David Roundy)--  * Fixed bug where 'darcs changes --context' created a context that contained-    escapes that prevented its use with send. (bug #544, David Roundy)--  * Make interactive push/pull/send/apply respect the --summary option by-    printing each patch as if you had hit 'x'. (David Roundy, bug #512)--  * Fix bug when calling whatsnew --summary when a file without a trailing-    newline has been deleted. (David Roundy)--  * Fix --set-scripts-executable to work again. This feature had been broken-    since version 1.0.3. (David Roundy)--  * Simple (safe) fix for a bug which caused darcs to run out of file-    descriptors when pulling over 1000 patches. (David Roundy)--  * Fix bug in perl parts of test suite which led to spurious warning-    messages. (David Roundy)--  * Fix bug in configure when compiling darcs from tarball on a system that-    has no darcs present. (David Roundy)--  * Fix bug that shows up when recording in a repository lacking a pristine-    tree. (David Roundy)-- -- David Roundy <droundy@darcs.net>  Sun, 13 Nov 2005 13:44:31 GMT--darcs (1.0.4pre4)--  * Fix error in install target of makefile, which was introduced in-    1.0.4pre3. (Andres Loeh)--  * Fix problem where make install modified the permissions on system-    directories. (David Roundy, bug #494)--  * Fix bug in display when whatsnew is given "-l" twice. (David Roundy, bug-    #501)--  * Added support for --posthook to all commands. (Jason Dagit)--  * Made repair able to work on partial repositories. (fixes bug #189)--  * Changed the delimiter in the long-comment file from ***DARCS*** to ***END-    OF DESCRIPTION*** and clarified its meaning a bit. (Jason Dagit and David-    Roundy)--  * Added code to allow darcs to apply some patch bundles that have had-    carriage returns added to their line endings. (David Roundy, bug #291)--  * Make darcs accept command line flags in any order, rather than requiring-    that they precede file, directory or repository arguments. Fixes bug #477-    (David Roundy)--  * Modified darcs get to display patch numbers rather than a bunch of dots-    while applying patches during a darcs get. Also added similar feedback to-    the check and repair commands. (Mat Lavin, bug #212)--  * Made revert --all not ask for confirmation, so it can be used in-    scripting, as one would use pull --all or record --all. (Jani Monoses)--  * Added file ChangeLog.README explaining how to add entries to the-    changelog. (Mark Stosberg and David Roundy)--  * Fixed incompatibility with somewhat older versions of libcurl. (Kannan-    Goundan)--  * Fixed bug that showed up when after editing a long comment, the long-    comment file is empty. (David Roundy, bug #224)-- -- David Roundy <droundy@darcs.net>  Sun, 01 Sep 2005 11:04:18 GMT--darcs (1.0.4pre2)--  * (EXPERIMENTAL) Added support for reading and writing to git repositories.-    There remain efficiency issues with the handling of git merges and darcs-    is not yet able to either create a new git repository, or to pull from a-    remote git repository. See building darcs chapter in manual for-    instructions on building darcs with git support. (Juliusz Chroboczek,-    configuration contributed by Wim Lewis)--  * Add new "query manifest" command to list files and/or directories in-    repository. Add some related infrastucture to support "subcommands".-    (Florian Weimer)--  * Make configure properly detect that we're on windows when building under-    mingw. (David Roundy)--  * Fixed bug #208: error when specifying pulling from a relative default-    repository if we are ourselves within a subdirectory of our repository.-    (David Roundy)--  * Change internal mechanism for writing the "pending" file to be (hopefully)-    more robust. (David Roundy, original idea by Ian Lynagh)--  * Fixed a bug that caused get --partial to fail sometimes. (David Roundy)--  * Made push/pull --verbose --dry-run now display contents of patches,-    analogous to the behavior of changes --verbose. (Jim Radford)--  * Various build system cleanups. (Peter Simons)-- -- David Roundy <droundy@abridgegame.org>  Sun, 31 Jul 2005 12:10:29 GMT--darcs (1.0.4pre1)--  * Performance improvement: Several commands now read patches lazily, which-    reduces memory usage. A test of 'darcs check' on the Linux kernel-    repository showed the memory usage was nearly cut in half, from about 700-    Megs to 400. Coded by David Roundy.--  * New feature: darcs put, the easiest way to create a remote repo, symmetric-    with 'darcs get'. Coded by Josef Svenningsson.--  * Performance improvement: RT#222: darcs performs better on files with-    massive changes. Coded by Benedikt Schmidt.--  * New Feature: darcs optimize now has "--modernize-patches" and-    "--reorder-patches" flags. See the manual for details.--  * Performance improvement: Using 'darcs diff' is now exponentially faster-    when comparing specific files in the working directory to the most recent-    copy in the repo. Coded by kannan@cakoose.com.-- -- David Roundy <droundy@abridgegame.org>  Sun, 18 Jul 2005 11:22:34 GMT--darcs (1.0.3)--  * Fixed bug #396: error when specifying a removed file on the command line-    of darcs record.-- -- Tomasz Zielonka <tomasz.zielonka@gmail.com>  Sun, 24 May 2005 21:51:27 GMT--darcs (1.0.3rc2)--  * Internals: darcs' ChangeLog is automatically generated from repo history-    and a database of ChangeLog entries (Tomasz Zielonka)--  * Fixed: RT#370: --tags work in unpull and unrecord (Tommy Pettersson)--  * New feature: added support for displaying patches with pager when-    selecting patches (Benedikt Schmidt)--  * New feature: new match type "exact" (John Goerzen)--  * Feature: unrevert accepts --all and --interactive options (Jani Monoses)--  * Fixed: darcs works with nvi (Benedikt Schmidt)-- -- Tomasz Zielonka <tomasz.zielonka@gmail.com>  Sun, 15 May 2005 08:56:17 GMT--darcs (1.0.3rc1)--  * New Feature: darcs.cgi now uses appropriate caching headers. This will-    make repeated calls to the same pages by cache-aware browsers much faste-    in some cases. It also means that darcs.cgi can be usefully combined with-    a cache-aware proxy for even better performance. (Will Glozer)--  * New feature: more control over color and escaping in printed patches,-    alternative color scheme, escaping of trailing spaces (Tommy Pettersson)--  * Fixed: fixed bug manifesting with failed createDirectory (David Roundy)--  * Internals: RT#255, several welcome refactors were made to the test suite,-    including comprehensible shell test script output, improved portability,-    and easier maintenance. (Michael Schwern).--  * New Feature: RT#245: Using --look-for-adds with 'whatsnew' implies-    --summary. This should save some typing for the common case. (Karel-    Gardas, Mark Stosberg)--  * New Feature: RT#231: darcs gives better feedback now if you try to record-    nonexistent files or directories. (Karel Gardas, Mark Stosberg)--  * New feature: send accepts --sendmail-command that allows to customize the-    command used for sending patch bundles (Benedikt Schmidt)--  * Fixed: RT#266: Adding a non-existent dir and file gives the expected-    message now. (Tomasz Zielonka).--  * Fixed: RT#10, a missed conflict resolution case. More accurately, we-    noticed at had been fixed some point. A regression test for it was added.-    (Tomasz Zielonka, Mark Stosberg)--  * New feature: darcs tag can now accept the tag name on the command line-    (RT#143). (Josef Svenningsson, Mark Stosberg, David Roundy)--  * New feature: unrecord and unpull have a more powerful interface similar to-    'darcs pull'. This allows for multiple patch selection. Coded by Tommy-    Pettersson.--  * Bug fix: RT#305: Removed '--patch' from the 'changes', which conflicted-    with the new '--patches' option.--  * New feature: Automatically add parent directories for darcs add. (RT#20)-    Coded by Benedikt Schmidt.--  * Add helpful diagnostic message when there is a failure while pulling-    (RT#201)-- -- Tomasz Zielonka <tomasz.zielonka@gmail.com>  Sun, 26 Apr 2005 00:25:54 GMT--darcs (1.0.2)--  * No changes from 1.0.2rc4.-- -- David Roundy <droundy@darcs.net>  Fri,  4 Feb 2005 07:33:09 -0500--darcs (1.0.2rc4)--  * More documentation improvements, plus one clearer error message.-  * Fixed (new since 1.0.1) bug which broke darcs repair.-  * Fixed problem with makefile which caused spurious relinkings.-  * Fixed bug in new optimize --relink command, which could cause-    repository corruption.-- -- David Roundy <droundy@abridgegame.org>  Wed, 2 Feb 2005 06:24:19 -0500--darcs (1.0.2rc3)--  * Documentation improvements related to Juliusz new code.-  * Fixed longstanding leaks in zlib/threads code.-  * Fixed some bugs in the new optimize --relink code.-  * Fixed bug in darcs diff when the repository name is empty.-- -- David Roundy <droundy@abridgegame.org>  Sat, 29 Jan 2005 07:28:39 -0500--darcs (1.0.2rc2)--  * Fixed bug on win32 when there are spaces in a repositories path and an-    external program (i.e. ssh) is called. (Will Glozer)-- -- David Roundy <droundy@abridgegame.org>  Thu, 27 Jan 2005 06:46:37 -0500--darcs (1.0.2rc1)--  * Added experimental support for repositories without a "pristine tree"-    This is the new name for the cache stored in _darcs/current/.-    (Juliusz Chroboczek)-  * Added an optimize --relink command to save disk space when using-    multiple repositories. (Juliusz Chroboczek)-  * Ignore conflict markers in the boring and binaries files.-  * Fixed bug in get --partial when patches are in an unusual order.-    (Andrew Johnson)-  * Fixed bug which caused a crash on a local get of a repository owned by-    another user.-  * Fixed bug in changes/annotate that shows up when a directory has been-    moved.-  * Allow ncurses in addition to curses in configure.-  * Added --set-scripts-executable option. (Karel Gardas)-  * Added configure option to fix path to sendmail even if it's not-    present.-  * Made bash completion more robust regarding shell special chars.-  * Added konquerer workaround to cgi annotate. (Will Glozer)-  * Addressed bug #114 - provide a better error when you accidently try to-    pull from yourself. (Mark Stosberg)-  * Made a few documentation improvements.-  * Made http user agent reflect the darcs and libcurl version.-  * Fixed commute bug in merger code.-  * Fixed bug in decoding mime messages.-- -- David Roundy <droundy@abridgegame.org>  Wed, 26 Jan 2005 08:51:24 -0500--darcs (1.0.1)--  * Made darcs changes --context work on an empty repo.-  * Fixed bug in relative directories as arguments to pull/push.-  * Fixed bug leading to extraneous changes in pending.-  * Fixed bug #137 - XML escaping for >.-  * Fixed gui code to compile with wxhaskell 0.8 (but it's still buggy).-- -- David Roundy <droundy@abridgegame.org>  Tue, 14 Dec 2004 08:16:10 -0500--darcs (1.0.1rc3)--  * Made it so adding and removing a file doesn't leave changes in pending.-  * Fixed bug in creating the file to be edited for the long comment.-  * Made "bug in get_extra" message explain possible cause of the problem,-    which is related to a bug in commutation that made it into version-    1.0.0.-  * Fixed stubborn bug in annotate.-  * Fixed problem when unrecording binary file patches.-- -- David Roundy <droundy@abridgegame.org>  Sat, 11 Dec 2004 14:23:53 -0500--darcs (1.0.1rc2)--  * Various optimizations.-  * darcs now supports an arbitrary number of transport protocols through the-    use new environment variables. See DARCS_GET_FOO in the 'Configuring-    Darcs' chapter in the manual for more details.-  * darcs now supports an arbitrary number of concurrent connections when-    communicating with remote repos. See the documentation for DARCS_MGET_FOO-    in the 'Configuring Darcs' chapter in the manual for more details.-- -- David Roundy <droundy@abridgegame.org>  Wed,  8 Dec 2004 08:02:48 -0500--darcs (1.0.1rc1)--  * Fixed bug in commutation of adjacent hunks which have either no new or-    no old lines.-  * Numerous newline fixes for windows.-  * On windows, use MAPI to resolve to and from addresses.-  * Fixed problem where the --cc was ignored in apply if the patch-    succeeded.-- -- David Roundy <droundy@abridgegame.org>  Wed,  1 Dec 2004 06:24:08 -0500--darcs (1.0.1pre1)--  * Changed apply to by default refuse to apply patches that would lead to-    conflicts.-  * Removed the old darcs_cgi script, in favor of the darcs.cgi script.-  * Fixed changes to work better in partial repositories.-  * Set stdin and stdout to binary mode to fix end of line problems with-    push under windows.-  * Made send create proper MIME email.-  * Removed reportbug command, really wasn't necesary, and didn't work-    well.  Report bugs by an email to bugs@darcs.net, which creates a-    ticket in our BTS.-  * Allow darcs to work with a password protected proxy.-  * Get multiple files with a single wget call when darcs is compiled-    without libcurl support.-  * Use sftp instead of scp to copy patches via ssh -- this reuses a single-    connection for better speed.-  * Made _darcs/current polymorphic (but not really documented).-  * Made optimize --uncompress work with --partial repos.-  * Various minor interface improvements.-  * Made changes work better when specifying a file, and working in a-    partial repository.-  * Fixed bug in causing "Fail: _darcs/patches/unrevert: removeFile: does-    not exist (No such file or directory)".  Resolves bugs #57, #61.-- -- David Roundy <droundy@abridgegame.org>  Sun, 21 Nov 2004 08:29:24 -0500--darcs (1.0.0)--  * Fixed compile error when antimemoize is enabled.-  * Fixed bug that showed up when dealing with international characters in-    filenames.-  * Various documentation improvements.-- -- David Roundy <droundy@abridgegame.org>  Mon,  8 Nov 2004 06:12:08 -0500--darcs (1.0.0rc4)--  * Use autoconf to check for working install program.-  * Renamed rerecord to amend-record in a futile attempt to avoid-    confusion.-  * Made pull accept the --repodir option.-  * Fixed off-by-one error in annotate that kept users from seeing-    "deleted" version.-  * Check filesystem semantics at runtime to avoid using mmap on-    windows filesystems.-  * Fixed darcs.cgi to work properly when browsing history of renamed-    files.-  * Use anonymous file handle for temporary files in darcs.cgi -- fixes a-    temporary file leak and potentially improves security.-  * Added --summary option to commands that accept --dry-run.-  * Made pull prompt for confirmation when there is a conflict with-    unrecorded changes.-  * Made unrevert interactive.-  * Don't try to generate a new name on get if name was given explicitely.-  * Always mark conflicts, even if there's an obvious solution.-  * Quote conflict attribute values in xml output.-  * Fail if the user gives a newline in the patch name.-  * Fixed bug where new files didn't show up in darcs diff.-  * Really fix newlines in whatsnew -u.-  * Fixed bug in handling of tags in changes and annotate.-  * Fixed bug in default options containing "--".-  * Fixed various other build problems in 1.0.0rc3.-  * Fixed embarrassing failure-to-compile-on-windows bug.-- -- David Roundy <droundy@abridgegame.org>  Mon,  1 Nov 2004 05:19:01 -0500--darcs (1.0.0rc3)--  * Fixed bug leading to creation of empty "hunk" patches.-  * Fixed bug in rollback when there are pending changes.-  * Fixed push bug when default apply is --interactive.-  * Fixed a bug where "darcs pull --list-options" would try to-    complete to "home/.../darcs_repo" instead of "/home/.../darcs_repo".-  * Fixed flushing bug in darcs.cgi.-  * Fixed commutation bug with renames and file adds/removals.-  * Made --summary indicate conflicted changes.-  * Fixed generation of extra hunk in diff algorithm.-  * Added X-Mail-Originator header to emails sent by darcs.-  * Fixed a couple of bugs in the resolve command.-  * Added new cgi diff command to produce unified diff.-  * Notify when there are conflicts on push.-  * Added 'a' key to say yes to all remaining changes for interactive-    commands.-  * Automatically generate AUTHORS file from repo history.-  * Made pull --quiet actually quiet.-  * Fixed bugs in whatsnew -ls, and distinguished between manually added-    files and automatically added files.-  * Fixed bug in darcs --commands when called outside a repo.-- -- David Roundy <droundy@abridgegame.org>  Sun,  3 Oct 2004 07:45:05 -0400--darcs (1.0.0rc2)--  * Added support for comments in prefs files.-  * Added new --enable-antimemoize compile option which reduces memory-    usage at the expense of increased computational time.-  * Added a new command:  "reportbug"-  * Fixed a bug that prevented applying of a patch bundle to an-    "unoptimized" repo.-  * Fixed bug where asking for changes to a nonexistent file in a-    subdirectory would show the patch that created or renamed that-    subdirectory.-  * Improved the robustness of unrevert.  Now actions that will make-    unrevert impossible should warn the user.-  * Fixed bug when moving files or directories to the root directory of-    repo.-  * Various changes to make the --logfile way of specifying the patch name-    and comments in record more friendly:-    - Allows editing of the long comment even when --logfile is specified,-      if the --edit-long-comment option is also used.-    - When editing the long comment, the change summary is included below-      the actual text for reference, and the patch name is included in the-      first line (and thus may be modified).-    - The --logfile option is ignored if such a file doesn't exist.-    - A --delete-logfile option was added, which tells darcs to delete the-      file after doing the record.  This is intended to allow you to stick-      a --logfile=foo option in your defaults without accidentally-      recording multiple patches with the same comments because you forgot-      to modify it.-  * Fixed bug leading to .hi files in tarball.-  * Made ctrl-C work under windows, but only "pure" windows consoles, not-    in cygwin shells or mingw's rxvt (room for improvement here).-  * Fixed bug that led to curl not being tried when darcs is not compiled-    with libcurl.-  * Added an environment variable DARCS_USE_ISPRINT for people who use-    non-ascii characters in their files to indicate if the haskell standard-    library "isPrint" function works properly on their system (which-    depends on locale).-  * Reduced the number of hunks produced by the internal diff algorithm,-    when there are multiple equivalent ways of interpreting a change.-  * Made the --from-{patch,tag,match} options inclusive, and added a-    --{patch,match} option to diff (which was made easier to define by the-    inclusiveness change, since --patch x is now equivalent to-    --from-patch x --to-patch x).-  * Added support for a second argument to get, which specifies the name of-    the new directory.-- -- David Roundy <droundy@abridgegame.org>  Sun, 12 Sep 2004 06:54:45 -0400--darcs (1.0.0rc1)--  * Remove some lazy file IO which may have been causing trouble pushing in-    windows and using windows shares.-  * Various interface improvements and improved error messages.-  * Fixed bug that could cause conflicts in pending when unrecording a-    patch that contained two non-commuting non-hunk patches.-  * Fixed bug in --ask-deps option of record.-  * Added --exact-version option which gives the precise darcs context from-    which darcs was compiled.-  * MIME fixes in patch forwarding.-  * Various improvements to the darcs.cgi script.-  * Added --reverse option to changes.-  * Fixed patch numbering when file or directory arguments are given to an-    interactive command.-- -- David Roundy <droundy@abridgegame.org>  Sun, 15 Aug 2004 07:43:30 -0400--darcs (0.9.23)--  * Added a rerecord command, which will add changes to an existing-    recorded patch-  * Added support for a MOTD.-  * Vastly improved the speed and memory use of darcs optimize --checkpoint-    as well as darcs record, in the case where a record consists primarily-    of adds.-- -- David Roundy <droundy@abridgegame.org>  Mon, 26 Jul 2004 08:11:20 -0400--darcs (0.9.22)--  * add preliminary --context option to changes and get.-  * display change number, e.g. "(1/3)" in interactive commands.-  * show moves in summary format.-  * add hash of patch bundles in darcs send.-  * properly support --verbose and --quiet in add.-  * don't display binary data to screen.-  * fix bug in selecting patches by pattern.-  * fix various locking-related bugs introduced in 0.9.21.-  * fix bug when specifying logfile in a subdirectory.-  * support backslashes for directory separators in windows.-  * fix file modification time bug.-- -- David Roundy <droundy@abridgegame.org>  Sat, 26 Jun 2004 07:42:05 -0400--darcs (0.9.21)--  * made mv work even if you've already mv'ed the file or directory.-  * remember configure settings when reconfiguring.-  * added --leave-test-directory to save the directory in which the test is-    run on record or check.-  * added HTTP redirect support (thanks Benedikt).-  * fixed problems when unrecording a patch with conflits.-  * fixed locking on nfs (thanks Juliusz).-  * added preliminary version of a new cgi script for browsing darcs-    repositories (thanks to Will Glozer for contributing this).-  * add and modify a number of short flag options.-  * fix bug in applying new order patch bundles that are GPG signed.-  * fix bug in diff when a tagged version was requested.-- -- David Roundy <droundy@abridgegame.org>  Sat, 12 Jun 2004 05:39:48 -0400--darcs (0.9.20)--  * fix bug in darcs-createrepo.-  * add support for DARCS_SCP and DARCS_SSH environment variables.-  * add XML support for --summary options of changes and annotate.-  * better command-line completion on commands accepting a list of files or-    directories.-  * fix bug causing empty hunk patches to lead to failures.-  * fix bug where --all overrode file choice in record.-  * fix bug when testing patches that create subdirectories within subdirectories.-  * preserve pending changes when pulling or applying.-  * give better error message in pull when patch isn't readable.-  * allow sendEmail with no "to", just "cc" recipients.  This should fix-    the trouble with trying to --reply to a patch coming from a push rather-    than a send.-- -- David Roundy <droundy@abridgegame.org>  Wed,  5 May 2004 06:01:48 -0400--darcs (0.9.19)--  * fix bugs leading to failures in the wxhaskell interface.-  * fix bug that caused darcs diff to fail.-  * fixed bug in get that lead to _darcs/current/_darcs directories.-  * improved error reporting in several situations.-  * fixed bug when pulling or pushing into an empty repo.-  * added --summary option to changes to summarize the changes made in each-    patch.-- -- David Roundy <droundy@abridgegame.org>  Fri,  9 Apr 2004 07:19:34 -0400--darcs (0.9.18)--  * added support for sending email from windows using the MAPI interface.-    This code attaches the patch bundle in base64-encoded form, which darcs-    can't currently decode (expect that in the next release), but the patch-    bundle can be manually applied if a mail program does the decoding.-  * renamed "darcs push" to "darcs send" and added a new "darcs push"-    command roughly equivalent to the old "darcs push --and-apply".-  * removed support for setting up a test suite by simple creating a file-    named "darcs_test".  You now should use setpref to define the test-    suite command.-  * fixed some problems when working in a --partial repository.-  * lots of code was cleaned up.  We have enabled the -Wall compiler flag-    and are in the process of eliminating all the warnings.  This should-    make the code more friendly to new developers, and also helps with the-    next bullet point:-  * improved handling of errors--informative failure messages are more-    likely than they were before.-  * by default only check changes made since last checkpoint--this greatly-    speeds up check.-  * add --quiet option.  Some commands don't yet support this.  If-    there's a command you want to quiet down, let us know.-  * several performance enhancements: improved SHA1 performance, faster-    check and get on repositories with a long history and improved-    performance with very large files.-- -- David Roundy <droundy@abridgegame.org>  Thu,  1 Apr 2004 05:43:18 -0500--darcs (0.9.17)--  * fixed bug in darcs apply that made the --no-test option fail.-  * fixed bug that caused darcs to set file permissions to be-    non-world-readable.-  * darcs record and whatsnew can now accept file or directory arguments-    and limit their actions to changes in those files or directories.-  * darcs changes now can accept file or directory arguments and limit-    itself to changes affecting those files or directories.-- -- David Roundy <droundy@abridgegame.org>  Sat, 21 Feb 2004 08:12:34 -0500--darcs (0.9.16)--  * Add --sign-as=KEYID option to push command.-  * make optimize split up inventory for faster pulls-  * Allow use of a different make command for tests, such as gmake-  * Can now put prefs that would normally go in _darcs/prefs (defaults,-    binaries and boring) in ~/.darcs/ to set the prefs for all your-    repositories at once.-  * add primitive xml output to annotate of directory.-  * When pushing a patch, add the list of changes in the description.-  * refuse to rollback a patch twice, since that would cause problems.-  * make darcs diff accept optional arguments indicating files and-    directories to diff.-  * preserve permissions on files in working directory.-  * put docs in ...share/doc/darcs not share/darcs/doc.-  * add support for multiple-choice options.  This means that you can now-    set your default option in _darcs/prefs/defaults, and then override-    that default on the command line.-  * shortened --use-external-merge-tool option to --external-merge-  * more "boring" patterns.-- -- David Roundy <droundy@abridgegame.org>  Tue, 10 Feb 2004 07:08:14 -0500--darcs (0.9.15)--  * next step repository format transition--we use the new patch filenames.-  * fix handling of text files with no trailing newline--this will cause-    some trouble.  Darcs will require that you convert your repository-    using convert-repo.  This will leave you with a bunch of changes-    regarding trailing newlines which you will either want to record or-    revert.-  * the windows support is somewhat improved.-  * added simple "repair" command that can repair some kinds of-    inconsistencies in the repository.-  * added primitive "annotate" command to extract information about-    modifications to files and directories.-  * fixed handling of darcs mv to allow moving to directories in a more-    intuitive manner.-  * handling of binary files was dramatically improved in both memory and-    cpu usage.-  * added autoconf testing framework to clean up code dealing with-    different versions of ghc, features that don't exist on windows, bugs-    that only exist on windows, etc.-  * don't accept invalid flags.-  * add more patterns to boring and binary.-  * use autoconf test to handle posix signals and windows '\\' handling.-  * switch to using new patch filenames.-  * XML formatted output for 'changes' command-  * add support for unidiff-like whatsnew output.-  * fix bug in RTS memory calculation for large RAM size-  * add rollback command.-  * improve checkpointing support.-  * add diff-opts option to darcs diff.-  * add support for building docs using htlatex or hevea rather than-    latex2html.-  * use locking whereever it is needed.-  * add safe (atomic) writing of inventory files.-- -- David Roundy <droundy@abridgegame.org>  Fri, 12 Dec 2003 07:59:54 -0500--darcs (0.9.14)--  * darcs changes now shows times formatted according to current locale.-  * add support for automatically treating files containing ^Z or '\0' as-    binary.-  * add experimental checkpointing, allowing get to only download the-    recent change history.-  * allow darcs to be called within subdirectories of a repository.-  * make default be to compress patches.-  * add --summary option to whatsnew.-  * add trackdown command.-  * fix bug in darcs dist --verbose.-  * make darcs diff have closer behavior to cvs diff.  In particular, darcs-    diff with no arguments now gives you the difference between the working-    directory and the latest recorded version.-  * support external graphical merge tools.-  * fix bug where binary patch is created even with no change.-  * support darcs -v for version.  Also mention the darcs version in the-    usage mesage.-  * ignore empty lines in boring file and binary file.-  * preserve pending changes (e.g. file adds or darcs replaces) across-    revert and record.-  * create repositories with new patch filename format.-    The new repo format is now created alongside the old format, but the-    old format is read.  There is a tool called convert-repo that will-    convert an old format repo to have both formats.-  * use iso format for dates in record.-  * New patch-selecting interface.-    This patch only uses the new routine for revert, since it's not-    particularly well tested.  The text method now allows one to go back-    and edit previous patches.  The idea is that eventually all commands-    that need the user to select a subset of patches will use this routine.-  * use hash for cgi cache file names.-  * add preliminary experimental GUI support using wxhaskell.-  * remember author name after first record in a repo.-  * add unrevert command.-  * always match full pathnames when checking boringness or binaryness.-  * rewrite replace tokenizer for more speed.-  * make darcs compile with ghc 6.2 and later.-  * fix some bugs in darcs diff.-  * make --and-apply work locally as well as via ssh.-    Also added a --and-apply-as that uses sudo to run the apply command as-    a different user.-- -- David Roundy <droundy@abridgegame.org>  Mon, 10 Nov 2003 07:08:20 -0500--darcs (0.9.13)--  * Various performance enhancements.-  * add --pipe option to tag and record, which causes them to prompt for-    all their input, including date.  This can be useful when creating-    repository converters.-  * remove '-t' short command line option for '--to' and the '-o' short-    option for '--reponame'.-  * remove the darcs-patcher program.-        The functionality of the darcs-patcher program is taken over by-        the darcs apply command.  Several fancy features have been added,-        as described in the Apply section of the manual.-  * support spaces and (maybe) unicode in filenames.-  * updates to win32 support-  * push via ssh-  * add --without-libcurl option to configure-  * include DarcsURL in push email.-  * add support for reading and writing gzipped patch files.-  * allow multiple --to addresses on push, and also support --cc for-    additional addresses.-  * when pulling or pushing from lastrepo, say where lastrepo is.-  * only save lastrepo in get if the source repo wasn't a relative-    directory path.-- -- David Roundy <droundy@abridgegame.org>--darcs (0.9.12)--  * add manual section on building darcs.-  * improve scaling of checking for and resolving conflicts, which was an-    O(n^2) function.-  * escape ESC char when printing patches.-  * don't reorder patches unless necesary--this avoids an O(n^2) operation-    which was making a darcs record very slow when a lot of files were-    added.-  * fix default regexps for boring file (Thanks Trevor!)-  * replace now ignores files that aren't in the repo.-  * make darcs add refuse to add files whose subdirectories don't exist.-  * implement support for binary files.-  * added support for running external programs to fetch files.-  * fix conflict resolution bug from 0.9.11.-  * make the patcher run the test prior to applying.-  * add repo locking.-  * Fix bug when pulling from a repo containing just one patch (thanks-    Peter).-  * install cgi script in cgi-bin directory.-- -- David Roundy <droundy@abridgegame.org>--darcs (0.9.11)--  * A rewrite of the configure code and makefile (thanks to Peter Simons).-  * Added several new repository configuration options including a setpref-    command which allows you to set preferences options that are pulled-    from repo to repo.-  * Yet another rewrite of the merging code.-  * User can now revert changes on a change-by-change basis.-  * Yet another major improvement in speed and memory consumption.-  * Add a darcs diff command to compare two versions.-- -- David Roundy <droundy@abridgegame.org>  Mon, 30 Jun 2003 06:42:10 -0400--darcs (0.9.10)--  * Added a way to configure the default values for options to darcs-    commands.  See Appendix B of manual.-  * darcs push and pull now default to pulling and pushing from the most-    recently accessed repository (if you don't specify a repo).-  * Numerous bugfixes.-- -- David Roundy <droundy@abridgegame.org>  Wed, 21 May 2003 07:08:40 -0400--darcs (0.9.9)--  * Created a way to have a "centralized server".  (See darcs-patcher-    chapter in manual).-  * Added new darcs-server package.-  * Switch to new repository format.  Note that your repo will only be-    converted to the new format if you use certain commands such as-    unpull.  You can recognize the new format by the presence of a-    _darcs/inventories/ directory.-  * Add the ability to sign patches sent with push using gnupg and to-    verify those signatures when applying.  (This is the authentication-    basis for the above-mentioned server).-  * Fix bug in application of a file rename patch.-- -- David Roundy <droundy@abridgegame.org>  Thu,  8 May 2003 06:58:42 -0400--darcs (0.9.8)--  * Fix rare bug in check when files happen to be a multiple of 1024 bytes-    in length.-  * Fix bug in reading patch ids with long comments from local files.-  * Prepare for a change in the repository format.  The format doesn't-    change for this version, but version 0.9.8 is able to read the new-    repository format.-- -- David Roundy <droundy@abridgegame.org>  Wed, 30 Apr 2003 08:54:18 -0400--darcs (0.9.7)--  * Fix a couple of rename conflict bugs.-  * Add new test suite framework, along with several tests.-  * Several major optimizations for speed and memory.-  * Added --ignore-times option to not assume that when a file-    modification time hasn't changed the file itself hasn't changed.-- -- David Roundy <droundy@abridgegame.org>  Sat, 26 Apr 2003 07:57:01 -0400--darcs (0.9.6)--  * Fixed a couple of bugs in the merging of conflicting renames.-  * Added an interface to include long comments when recording.-  * Improve the interface of pull, allowing for viewing the patches before-    pulling them.-  * Include zsh command completion examples with docs.-  * Massively improved responsiveness in command completion.-  * Use packed strings to save memory.-  * Fixed a bug that shows up in empty repos.-  * Fixed multiple bugs in the mv command.-- -- David Roundy <droundy@abridgegame.org>  Thu, 17 Apr 2003 09:34:34 -0400--darcs (0.9.5)--  * Improve merge of creation of files and directories with the same name.-  * Add darcs push and apply commands, which are the beginning of work-    towards supporting a "centralized server" concept a la CVS.  However,-    they are also useful for a "Linus" style workflow, based on emailing-    patches.  In theory they could also be used to provide a smart server-    that could server pulls using less bandwidth.-  * Add an unpull command analagous to unrecord, but which removes the-    patches from the working directory also.-  * Enable the mv command, since the mv patches have now been supported by-    a couple of versions.-  * Include zsh_completion code, thanks to Aaron Denney <wnoise@ofb.net>.-- -- David Roundy <droundy@abridgegame.org>  Wed,  9 Apr 2003 07:52:01 -0400--darcs (0.9.4)--  * Speed up whatsnew and record in the case where there are huge numbers-    of extra files in the working directory.-  * Small (~10%) speedup in get.-- -- David Roundy <droundy@abridgegame.org>  Fri,  4 Apr 2003 09:08:38 -0500--darcs (0.9.3)--  * Optimized whatsnew and record by seting modification time of "current"-    files equal to that of working files if they are identical, so I won't-    have to check again if the working one hasn't been changed.-  * Rewrite file renaming code (no creation).-  * Add support for replacing tokens in files.-  * Make cgi output work more accurately, and point out which files were-    modified by each patch.-  * Add a caching feature to the cgi script to speed things up a bit.-  * Turn on creation of dependencies when recording.-  * Add a 'tag' command.-  * Rewrote the 'pull' code to hopefully speed it up (and in any case to-    greatly simplify it).-- -- David Roundy <droundy@abridgegame.org>  Thu,  3 Apr 2003 07:08:05 -0500--darcs (0.9.2)--  * Add build dependency on tetex and latex2html-  * Have internal diff code properly respond to deleted files and-    directories.-  * Create file and directory rename patch types. (no creation--which-    means that I am waiting to create commands to create such patches-    until later, to avoid backward compatibility issues of repos.)-  * Add support for patch dependencies. (no creation)-  * Add support for token replacement patches. (no creation)-- -- David Roundy <droundy@abridgegame.org>  Thu, 27 Mar 2003 07:59:09 -0500--darcs (0.9.1)--  * Make darcs get --verbose actually be verbose (which is important-    because it takes so long that the user might be afraid it's hanging.-  * Speed up the merge in complicated cases, possibly dramatically.-  * Add a darcs remove command.-- -- David Roundy <droundy@abridgegame.org>  Mon, 10 Mar 2003 09:48:55 -0500--darcs 0.9.0--  * Initial Release.-- -- David Roundy <droundy@abridgegame.org>  Wed,  3 Mar 2003 13:51:58 -0500----Local variables:-mode: outline-outline-regexp: "[dD]\\| +\\*+"-paragraph-separate: "[  ]*$"-end:
− README 
@@ -1,83 +0,0 @@-Darcs-=====-This is the source tree for darcs, a distributed version control system-written in Haskell.--For more information, visit the darcs web site:--   http://www.darcs.net---Compilation and Installation-============================--Building Darcs is best done with the Haskell Platform:-http://www.haskell.org/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-<http://www.haskell.org/haskellwiki/Cabal/How_to_install_a_Cabal_package>-including instructions on obtaining a copy of cabal-install.--Please also note that the cabal-based build by default requires the cURL-library (and development headers). If, for some reason, you cannot provide-cURL, please pass "-f-curl" to the configure step above.---Hacking-=======-For more information about darcs hacking and best practices please check-the darcs wiki at http://wiki.darcs.net--Of particular interest are the following documents:-  * http://wiki.darcs.net/Development/GettingStarted-  * http://wiki.darcs.net/Development/FAQ--Comments about do-notation warnings-===================================-You may find a number of comments (163 of them at the time of writing) looking-like:--- Warning:  A do-notation statement discarded a result of type Whatever.-They signal warnings issued by GHC that have been automatically silenced.-See http://bugs.darcs.net/issue1988 for more detail.--These warnings were most certainly harmless, but who knows... If you stumble-upon one such comment, take a minute or two to check if it is really okay to-ignore the return value (look for "_ <- " on the line next to the comment).  If-everything is correct, please remove the comment and send a patch (mentioning-issue1988).  If it isn't, you have found a bug, congratulations!  Fix it, or-fill a bug report on http//bugs.darcs.net/.  Finally, if in doubt, leave it as-is.  Many thanks.--Testing-=======-For more information about the test suite, including how to run specific-tests please read tests/README.test_maintainers.txt.--Happy hacking!
+ README.md view
@@ -0,0 +1,134 @@+About+-----++[Darcs](http://darcs.net) is a distributed version control system+written in Haskell.++Building+--------++To build and install the latest release, use++```+cabal update && cabal install darcs+```++with a recent cabal (version 3.2 or later is recommended). Any version of+ghc from 8.2 up to 9.8 should work.++From inside a clone or a source dist, use++```+> cabal build+```++Cabal will tell you where the resulting darcs binary is. If you'd rather+use `cabal install` and you are in a clone (not a source dist), you first have+to generate the version info, like this:++```+> runghc release/gen-version-info.hs+> cabal install+```++Building/installing with stack used to work with a few tweaks, but is no+longer officially supported due to lack of manpower. If this inconveniences+you, consider contributing patches to maintain our stack.yaml.++Testing+-------++Running the test-suite is optional, of course, but useful if you want to+help find bugs or before you contribute patches. The easiest and most+flexible way to do this is++```+> cabal configure --enable-tests+> cabal run darcs-test -- [options for darcs-test, try --help]+```++Using+-----++To clone a repository via HTTP and send patches by mail:++```+> darcs clone --lazy http://darcs.net+> # edit files...+> darcs add my_new_file+> darcs record -m "my changes"+> darcs send+```++To clone via SSH and push patches:++```+> darcs clone user@hub.darcs.net:user/repo+> # edit files...+> darcs add my_new_file+> darcs record -m "my changes"+> darcs push+```++To create a project and start working:++```+> darcs init my_project+> cd my_project+> # create and edit files...+> darcs add my_new_file+> darcs record -m "initial version"+```++Pull new patches from upstream:++```+> darcs pull+```++Documentation+-------------++Concise and up-to-date documentation is available from darcs itself:++```+> darcs help # list all commands+> darcs help command # help for specific command+> darcs command --help # dito+```++The complete documentation is available as a man page which can be generated+using++```+darcs help manpage > darcs.1+```++Reporting bugs+--------------++Please send bug reports to <bugs@darcs.net>. This will automatically add+your report to the bug tracker. If you are unsure or just have a question or+a comment, you can subscribe to darcs-users@darcs.net and post your question+or comments there. See http://darcs.net/MailingLists for details.++There is also an IRC channel named `#darcs` on freenode.net, where you can+report problems or ask questions.+++Hacking+-------++We are happy to receive patches and will try our best to review them in a+timely fashion. Just record your patches in a clone of+<http://darcs.net/screened> and `darcs send` them. You are encouraged, but not+required, to look at <http://darcs.net/Development/GettingStarted> for+additional information.++BTW, the wiki is a darcs repo, you can clone it with:++```+> darcs clone --lazy http://darcs.net/darcs-wiki+```++to edit the contents and send us patches.
+ Setup.hs view
@@ -0,0 +1,173 @@+-- copyright (c) 2008 Duncan Coutts+-- portions copyright (c) 2008 David Roundy+-- portions copyright (c) 2007-2009 Judah Jacobson+{-# OPTIONS_GHC -Wall #-}+import Distribution.Simple+         ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )+import Distribution.PackageDescription ( PackageDescription )+import Distribution.Package ( packageVersion )+import Distribution.Version( Version )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), absoluteInstallDirs )+import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest))+import Distribution.Simple.Setup+    (buildVerbosity, copyDest, copyVerbosity, fromFlag,+     haddockVerbosity, installVerbosity, replVerbosity )+import Distribution.Simple.BuildPaths ( autogenPackageModulesDir )+import Distribution.Simple.Utils+    (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout,+     rewriteFileEx)+import Distribution.Verbosity ( Verbosity, silent )+import Distribution.Text ( display )++import Control.Monad ( unless, when, void )+import System.Directory ( doesDirectoryExist, doesFileExist )+import System.IO ( openFile, IOMode(..) )+import System.Process (callProcess, runProcess)+import Data.List( isInfixOf )+import System.FilePath ( (</>) )++import qualified Control.Exception as Exception++catchAny :: IO a -> (Exception.SomeException -> IO a) -> IO a+catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException))++main :: IO ()+main = defaultMainWithHooks $ simpleUserHooks {++  buildHook = \ pkg lbi hooks flags ->+              let verb = fromFlag $ buildVerbosity flags+               in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags),++  haddockHook = \ pkg lbi hooks flags ->+                let verb = fromFlag $ haddockVerbosity flags+                 in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) ,+  replHook = \pkg lbi hooks flags args ->+                let verb = fromFlag $ replVerbosity flags+                 in commonBuildHook replHook pkg lbi hooks verb >>= (\f -> f flags args) ,+  postBuild = \ _ _ _ lbi -> buildManpage lbi,+  postCopy = \ _ flags pkg lbi ->+             installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags),+  postInst = \ _ flags pkg lbi ->+             installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest++}++-- | For @./Setup build@ and @./Setup haddock@, do some unusual+-- things, then invoke the base behaviour ("simple hook").+commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a)+                -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a+commonBuildHook runHook pkg lbi hooks verbosity = do+  versionInfoExists <-+    (&&) <$> doesFileExist "release/distributed-context"+         <*> doesFileExist "release/distributed-version"+  unless versionInfoExists $+    callProcess "cabal" ["run", "./release/gen-version-info.hs"]+  (version, state) <- determineVersion verbosity pkg+  generateVersionModule verbosity lbi version state+  return $ runHook simpleUserHooks pkg lbi hooks++-- ---------------------------------------------------------------------+-- man page+-- ---------------------------------------------------------------------++buildManpage :: LocalBuildInfo -> IO ()+buildManpage lbi = do+  have_darcs_exe_dir <- doesDirectoryExist (buildDir lbi </> "darcs")+  when have_darcs_exe_dir $ do+    let darcs = buildDir lbi </> "darcs/darcs"+        manpage = buildDir lbi </> "darcs/darcs.1"+    manpageHandle <- openFile manpage WriteMode+    void $ runProcess darcs ["help","manpage"]+            Nothing Nothing Nothing (Just manpageHandle) Nothing++installManpage :: PackageDescription -> LocalBuildInfo -> Verbosity -> CopyDest -> IO ()+installManpage pkg lbi verbosity copy = do+  have_manpage <- doesFileExist (buildDir lbi </> "darcs" </> "darcs.1")+  when have_manpage $+    copyFiles+      verbosity+      (mandir (absoluteInstallDirs pkg lbi copy) </> "man1")+      [(buildDir lbi </> "darcs", "darcs.1")]++-- ---------------------------------------------------------------------+-- version module+-- ---------------------------------------------------------------------++determineVersion :: Verbosity -> PackageDescription -> IO (String, String)+determineVersion verbosity pkg = do+  let darcsVersion = packageVersion pkg+  numPatches <- versionPatches verbosity darcsVersion+  return (display darcsVersion, versionStateString numPatches)++  where+    versionStateString :: Maybe Int -> String+    versionStateString Nothing  = "unknown"+    versionStateString (Just 0) = "release"+    versionStateString (Just 1) = "+ 1 patch"+    versionStateString (Just n) = "+ " ++ show n ++ " patches"++versionPatches :: Verbosity -> Version -> IO (Maybe Int)+versionPatches verbosity darcsVersion = do+  numPatchesDarcs <- do+      out <- rawSystemStdout verbosity "darcs"+               ["log", "-a", "--from-tag", display darcsVersion, "--count"]+      case reads out of+        ((n,_):_) -> return $ Just ((n :: Int) - 1)+        _         -> return Nothing+    `catchAny` \_ -> return Nothing+  numPatchesDist <- parseFile "release/distributed-version"+  return $ case (numPatchesDarcs, numPatchesDist) of+             (Just x, _) -> Just x+             (Nothing, Just x) -> Just x+             (Nothing, Nothing) -> Nothing++generateVersionModule :: Verbosity -> LocalBuildInfo -> String -> String -> IO ()+generateVersionModule verbosity lbi version state = do+  let dir = autogenPackageModulesDir lbi+  createDirectoryIfMissingVerbose verbosity True dir+  ctx <- context verbosity+  hash <- weakhash verbosity+  rewriteFileEx silent (dir </> "Version.hs") $ unlines+    ["module Version where"+    ,"import Darcs.Prelude"+    ,"version, weakhash, context :: String"+    ,"version = \"" ++ version ++ " (" ++ state ++ ")\""+    ,"weakhash = " ++ case hash of+                        Just x -> show x+                        Nothing -> show "not available"+    ,"context = " ++ case ctx of+                       Just x -> show x+                       Nothing -> show "context not available"+    ]++weakhash :: Verbosity -> IO (Maybe String)+weakhash verbosity = do+  inrepo <- doesDirectoryExist "_darcs"+  unless inrepo $ fail "Not a repository."+  out <- rawSystemStdout verbosity "darcs" ["show", "repo"]+  let line = filter ("Weak Hash:" `isInfixOf`) $ lines out+  return $ case line of+                [] -> Nothing+                x:_ -> Just $ last $ words x+ `catchAny` \_ -> return Nothing++context :: Verbosity -> IO (Maybe String)+context verbosity =+   do+      inrepo <- doesDirectoryExist "_darcs"+      unless inrepo $ fail "Not a repository."+      out <- rawSystemStdout verbosity "darcs" ["log", "-a", "--context"]+      return $ Just out+   `catchAny` \_ -> parseFile "release/distributed-context"++parseFile :: Read a => FilePath -> IO (Maybe a)+parseFile f = do+  exist <- doesFileExist f+  if exist+    then do+      content <- readFile f+      case reads content of+        ((s, _):_) -> return s+        _ -> return Nothing+    else return Nothing
− Setup.lhs 
@@ -1,369 +0,0 @@-\begin{code}-{-# LANGUAGE CPP #-}--- copyright (c) 2008 Duncan Coutts--- portions copyright (c) 2008 David Roundy--- portions copyright (c) 2007-2009 Judah Jacobson--import Prelude hiding ( catch )-import qualified Prelude--import qualified Distribution.InstalledPackageInfo as Installed-import Distribution.Simple-         ( defaultMainWithHooks, UserHooks(..), simpleUserHooks )-import Distribution.Simple.Configure-         ( checkForeignDeps )-import Distribution.ModuleName( toFilePath )-import Distribution.PackageDescription-         ( PackageDescription(executables), Executable(buildInfo, exeName)-         , BuildInfo(customFieldsBI), emptyBuildInfo-         , FlagName(FlagName)-         , updatePackageDescription-         , cppOptions, ccOptions, ldOptions-         , library, libBuildInfo, otherModules-         , extraLibs, extraLibDirs, includeDirs )-import Distribution.Package-         ( packageVersion, packageName, PackageName(..) )-import Distribution.Version-         ( Version(versionBranch) )-import Data.Version( showVersion )-import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), absoluteInstallDirs, externalPackageDeps )-import Distribution.Simple.InstallDirs (mandir, CopyDest (NoCopyDest))-import Distribution.Simple.PackageIndex ( topologicalOrder )-import Distribution.Simple.Program ( gccProgram, rawSystemProgramStdoutConf )-import Distribution.Simple.Setup-    (buildVerbosity, copyDest, copyVerbosity, fromFlag,-     haddockVerbosity, installVerbosity, sDistVerbosity,-     configVerbosity, ConfigFlags, configConfigurationsFlags)-import Distribution.Simple.BuildPaths-         ( autogenModulesDir, exeExtension )-import Distribution.System-         ( OS(Windows), buildOS )-import Distribution.Simple.Utils-    (copyFiles, createDirectoryIfMissingVerbose, rawSystemStdout,-     rewriteFile, withTempFile)-import Distribution.Verbosity-         ( Verbosity )-import Distribution.Text-         ( display )-import Distribution.Package (Package)--import Control.Monad ( zipWithM_, when, unless, filterM )-import Control.Exception ( bracket, handle, IOException )-import System.Directory-    (copyFile, createDirectory, createDirectoryIfMissing,-     doesDirectoryExist, doesFileExist,-     getCurrentDirectory, getDirectoryContents,-     removeDirectoryRecursive, removeFile, setCurrentDirectory,-     getTemporaryDirectory-    )-import System.Exit ( ExitCode(ExitSuccess) )-import System.IO-    ( openFile, IOMode (..), stdout-    , hPutStr, hFlush, hClose-    )-import System.Process (runProcess)-import System.IO.Error ( isDoesNotExistError )-import Data.List( isPrefixOf, isSuffixOf, sort, partition )--import System.Cmd( rawSystem )-import System.Exit( exitWith )-import System.FilePath       ( (</>), (<.>), splitDirectories, isAbsolute )-import Foreign.Marshal.Utils ( with )-import Foreign.Storable      ( peek )-import Foreign.Ptr           ( castPtr )-import Data.Word             ( Word8, Word32 )--import qualified Control.Exception as Exception---- Handle exceptions migration. We could use extensible-exceptions--- but Cabal can't handle package dependencies of Setup.lhs--- automatically so it'd be disruptive for users.--- Once we drop older GHCs we can clean up the use sites properly--- and perhaps think about being more restrictive in which exceptions--- are caught at each site.-#if __GLASGOW_HASKELL__ >= 610-catchAny f h = Exception.catch f (\e -> h (e :: Exception.SomeException))-#else-catchAny = Exception.catch-#endif--main :: IO ()-main = defaultMainWithHooks simpleUserHooks {--  buildHook = \ pkg lbi hooks flags ->-              let verb = fromFlag $ buildVerbosity flags-               in commonBuildHook buildHook pkg lbi hooks verb >>= ($ flags),--  haddockHook = \ pkg lbi hooks flags ->-                let verb = fromFlag $ haddockVerbosity flags-                 in commonBuildHook haddockHook pkg lbi hooks verb >>= ($ flags) ,--  postBuild = \ _ _ _ lbi -> buildManpage lbi,-  postCopy = \ _ flags pkg lbi ->-             installManpage pkg lbi (fromFlag $ copyVerbosity flags) (fromFlag $ copyDest flags),-  postInst = \ _ flags pkg lbi ->-             installManpage pkg lbi (fromFlag $ installVerbosity flags) NoCopyDest,--  runTests = \ args0 _ _ lbi -> do-             cwd <- getCurrentDirectory-             let isabs = isAbsolute $ buildDir lbi-                 builddir = (if isabs then id else (cwd </>)) $ buildDir lbi-                 darcs = builddir </> "darcs" </> "darcs" <.> exeExtension-                 darcstest = builddir </> "darcs-test" </> "darcs-test" <.> exeExtension-                 (flags, args1) = partition ('=' `elem`) args0-                 (what', args2) = partition (`elem` ["bugs", "network", "tests", "unit"]) args1-                 what = if null what' then ["tests"] else what'-                 opts = [ "--darcs", darcs ] ++ concat [ ["-t", x] | x <- args2 ] ++-                        [ "--no-unit" | "unit" `notElem` what] ++-                        [ "--network" | "network" <- what ] ++ [ "--failing" | "bugs" <- what ] ++-                        [ "--no-shell" | _ <- [()], "tests" `notElem` what ] ++-                        [ "--threads=" ++ drop 8 t | t <- flags, "threads" `isPrefixOf` t ] ++-                        [ "--plain" | "output=plain" <- flags ]-             rawSystem darcstest opts >>= exitWith-             ,--  sDistHook = \ pkg lbi hooks flags -> do-    let pkgVer = packageVersion pkg-        verb = fromFlag $ sDistVerbosity flags-    x <- versionPatches verb pkgVer-    y <- context verb pkgVer-    rewriteFile "release/distributed-version" $ show x-    rewriteFile "release/distributed-context" $ show y-    putStrLn "about to hand over"-    let pkg' = pkg { library = sanity (library pkg) }-        sanity (Just lib) = Just $ lib { libBuildInfo = sanity' $ libBuildInfo lib }-        sanity _ = error "eh"-        sanity' bi = bi { otherModules = [ m | m <- otherModules bi, toFilePath m /= "Version" ] }--    sDistHook simpleUserHooks pkg' lbi hooks flags-             ,-  confHook =-    if buildOS == Windows-      then confHook simpleUserHooks-      else-        \genericDescript flags -> do-          lbi <- confHook simpleUserHooks genericDescript flags-          let pkgDescr = localPkgDescr lbi-          let verb = fromFlag (configVerbosity flags)-          checkForeignDeps pkgDescr lbi verb-          let Just lib = library pkgDescr-          let bi = libBuildInfo lib-          bi' <- maybeSetLibiconv flags bi lbi-          return lbi {localPkgDescr = pkgDescr {-                                  library = Just lib {-                                      libBuildInfo = bi'}}}-              ,-  postConf = \_ _ _ _ -> return () --- Usually this checked for external C-             --- dependencies, but we already have performed such-             --- check in the confHook-}---- | For @./Setup build@ and @./Setup haddock@, do some unusual--- things, then invoke the base behaviour ("simple hook").-commonBuildHook :: (UserHooks -> PackageDescription -> LocalBuildInfo -> t -> a)-                -> PackageDescription -> LocalBuildInfo -> t -> Verbosity -> IO a-commonBuildHook runHook pkg lbi hooks verbosity = do-  (version, state) <- determineVersion verbosity pkg--  -- Create our own context file.-  generateVersionModule verbosity pkg lbi version state--  -- Add custom -DFOO[=BAR] flags to the cpp (for .hs) and cc (for .c)-  -- invocations, doing a dance to make the base hook aware of them.-  littleEndian <- testEndianness-  let args = ("-DPACKAGE_VERSION=" ++ show' version) :-             ("-DPACKAGE_VERSION_STATE=" ++ show' state) :-             [arg | (arg, True) <-         -- include fst iff snd.-              [("-DHAVE_HTTP", "x-have-http" `elem` customFields),-               ("-DUSE_COLOR", "x-use-color" `elem` customFields),-               -- We have MAPI iff building on/for Windows.-               ("-DHAVE_MAPI", buildOS == Windows),-               ("-DBIGENDIAN", not littleEndian)]]-      bi = emptyBuildInfo { cppOptions = args, ccOptions = args }-      hbi = (Just bi, [(exeName exe, bi) | exe <- executables pkg])-      pkg' = updatePackageDescription hbi pkg-      lbi' = lbi { localPkgDescr = pkg' }-  return $ runHook simpleUserHooks pkg' lbi' hooks--  where-    customFields = map fst . customFieldsBI . buildInfo $ darcsExe-    darcsExe = head [e | e <- executables pkg, exeName e == "darcs"]-    show' :: String -> String   -- Petr was worried that we might-    show' = show                -- allow non-String arguments.-    testEndianness :: IO Bool-    testEndianness = with (1 :: Word32) $ \p -> do o <- peek $ castPtr p-                                                   return $ o == (1 :: Word8)--buildManpage :: LocalBuildInfo -> IO ()-buildManpage lbi = do-  let darcs = buildDir lbi </> "darcs/darcs"-      manpage = buildDir lbi </> "darcs/darcs.1"-  manpageHandle <- openFile manpage WriteMode-  runProcess darcs ["help","manpage"]-             Nothing Nothing Nothing (Just manpageHandle) Nothing-  return ()--installManpage :: PackageDescription -> LocalBuildInfo-                  -> Verbosity -> CopyDest -> IO ()-installManpage pkg lbi verbosity copy =-    copyFiles verbosity-              (mandir (absoluteInstallDirs pkg lbi copy) </> "man1")-              [(buildDir lbi </> "darcs", "darcs.1")]--determineVersion :: Verbosity -> PackageDescription -> IO (String, String)-determineVersion verbosity pkg = do-  let darcsVersion  =  packageVersion pkg-  numPatches <- versionPatches verbosity darcsVersion-  return (display darcsVersion, versionStateString numPatches darcsVersion)--  where-    versionStateString :: Maybe Int -> Version -> String-    versionStateString Nothing  _ = "unknown"-    versionStateString (Just 0) v = case versionBranch v of-                         x | 97 `elem` x -> "alpha " ++ show (after 97 x)-                           | 98 `elem` x -> "beta " ++ show (after 98 x)-                           | 99 `elem` x  ->-                               "release candidate " ++ show (after 99 x)-                         _ -> "release"-    versionStateString (Just 1) _ = "+ 1 patch"-    versionStateString (Just n) _ = "+ " ++ show n ++ " patches"-    after w (x:r) | w == x = head r-                  | otherwise = after w r-    after _ [] = undefined--versionPatches :: Verbosity -> Version -> IO (Maybe Int)-versionPatches verbosity darcsVersion = do-  numPatchesDarcs <- do-      out <- rawSystemStdout verbosity "darcs"-               ["changes", "-a", "--from-tag", display darcsVersion, "--count"]-      case reads (out) of-        ((n,_):_) -> return $ Just ((n :: Int) - 1)-        _         -> return Nothing-    `catchAny` \_ -> return Nothing--  numPatchesDist <- parseFile versionFile-  return $ case (numPatchesDarcs, numPatchesDist) of-             (Just x, _) -> Just x-             (Nothing, Just x) -> Just x-             (Nothing, Nothing) -> Nothing-- where-  versionFile = "release/distributed-version"--generateVersionModule :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> String -> String -> IO ()-generateVersionModule verbosity pkg lbi version state = do-  let dir = autogenModulesDir lbi-  createDirectoryIfMissingVerbose verbosity True dir-  ctx <- context verbosity (packageVersion pkg)-  rewriteFile (dir </> "Version.hs") $ unlines-    ["module Version where"-    ,"builddeps, version, context :: String"-    ,"version = \"" ++ version ++ " (" ++ state ++ ")\""-    ,"builddeps = " ++ (show $ formatdeps (externalPackageDeps lbi))-    ,"context = " ++ case ctx of-                       Just x -> show x-                       Nothing -> show "context not available"-    ]-  where formatdeps = unlines . map (formatone . snd)-        formatone p = case packageName p of PackageName n -> n ++ "-" ++ showVersion (packageVersion p)--context :: Verbosity -> Version -> IO (Maybe String)-context verbosity version = do-  contextDarcs <- do-      inrepo <- doesDirectoryExist "_darcs"-      unless inrepo $ fail "Not a repository."-      out <- rawSystemStdout verbosity "darcs" ["changes", "-a", "--context"]-      return $ Just out-   `catchAny` \_ -> return Nothing--  contextDist <- parseFile contextFile-  return $ case (contextDarcs, contextDist) of-             (Just x, _) -> Just x-             (Nothing, Just x) -> Just x-             (Nothing, Nothing) -> Nothing- where contextFile = "release/distributed-context"--parseFile :: (Read a) => String -> IO (Maybe a)-parseFile f = do-  exist <- doesFileExist f-  if exist then do-             content <- readFile f -- ^ ratify readFile: we don't care here.-             case reads content of-               ((s,_):_) -> return s-               _         -> return Nothing-             else return Nothing---- Test whether compiling a c program that links against libiconv needs -liconv.-maybeSetLibiconv :: ConfigFlags -> BuildInfo -> LocalBuildInfo -> IO BuildInfo-maybeSetLibiconv flags bi lbi = do-    let biWithIconv = addIconv bi-    let verb = fromFlag (configVerbosity flags)-    if hasFlagSet flags (FlagName "libiconv")-        then do-            putStrLn "Using -liconv."-            return biWithIconv-        else do-    putStr "checking whether to use -liconv... "-    hFlush stdout-    worksWithout <- tryCompile iconv_prog bi lbi verb-    if worksWithout-        then do-            putStrLn "not needed."-            return bi-        else do-    worksWith <- tryCompile iconv_prog biWithIconv lbi verb-    if worksWith-        then do-            putStrLn "using -liconv."-            return biWithIconv-        else error "Unable to link against the iconv library."--hasFlagSet :: ConfigFlags -> FlagName -> Bool-hasFlagSet cflags flag = Just True == lookup flag (configConfigurationsFlags cflags)--tryCompile :: String -> BuildInfo -> LocalBuildInfo -> Verbosity -> IO Bool-tryCompile program bi lbi verb = handle processExit $ handle processException $ do-    tempDir <- getTemporaryDirectory-    withTempFile tempDir ".c" $ \fname cH ->-      withTempFile tempDir "" $ \execName oH -> do-        hPutStr cH program-        hClose cH-        hClose oH-        -- TODO take verbosity from the args.-        rawSystemProgramStdoutConf verb gccProgram (withPrograms lbi)-                        (fname : "-o" : execName : args)-        return True-  where-    processException :: IOException -> IO Bool-    processException e = return False-    processExit = return . (==ExitSuccess)-    -- Mimicing Distribution.Simple.Configure-    deps = topologicalOrder (installedPkgs lbi)-    args = concat-                  [ ccOptions bi-                  , cppOptions bi-                  , ldOptions bi-                  -- --extra-include-dirs and --extra-lib-dirs are included-                  -- in the below fields.-                  -- Also sometimes a dependency like rts points to a nonstandard-                  -- include/lib directory where iconv can be found. -                  , map ("-I" ++) (includeDirs bi ++ concatMap Installed.includeDirs deps)-                  , map ("-L" ++) (extraLibDirs bi ++ concatMap Installed.libraryDirs deps)-                  , map ("-l" ++) (extraLibs bi)-                  ]--addIconv :: BuildInfo -> BuildInfo-addIconv bi = bi {extraLibs = "iconv" : extraLibs bi}--iconv_prog :: String-iconv_prog = unlines $-    [ "#include <iconv.h>"-    , "int main(void) {"-    , "    iconv_t t = iconv_open(\"UTF-8\", \"UTF-8\");"-    , "    return 0;"-    , "}"-    ]--\end{code}
contrib/_darcs.zsh view
@@ -1,36 +1,54 @@ #compdef darcs-## Darcs completion snippet for zsh.+## Darcs completion for zsh. ##+## Originally derived from a version by ## Copyright (C) 2009  Nicolas Pouillard-##-## This program is free software; you can redistribute it and/or modify-## it under the terms of the GNU General Public License as published by-## the Free Software Foundation; either version 2 of the License, or-## (at your option) any later version.-##-## This program is distributed in the hope that it will be useful,-## but WITHOUT ANY WARRANTY; without even the implied warranty of-## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-## GNU General Public License for more details. +local -a darcs_options darcs_non_options darcs_arguments darcs_list_options+ if (($CURRENT == 2)); then-  # We're completing the first word after "darcs" -- the command.-  _wanted command expl 'darcs command' \-    compadd -- $( darcs --commands )+  compadd -- $(darcs --commands) else-  case "${words[$CURRENT]}"; in-    # If it looks like an URL...-    ht*|ft*)-        _arguments '*:URL:_urls'-        ;;-    # If it looks like an explicit path...+  # advanced zsh (array) parameter expansion fu:+  # - ${(f)...} means split into array elements at line endings+  #   instead of white space+  # - ${arr:#pat} drops elements matching pat from arr, whereas+  #   ${(M)arr:#pat} drops non-matching elements+  # - ${arr/pat/repl} replaces pat with repl for all elements of arr+  # - ${arr[(i)val]} is reverse indexing: returns index of first+  #   occurrence of val in arr++  # save current word+  local current_word=$words[$CURRENT]+  # delete it from words+  words[$CURRENT]=()+  # find the index of the first option argument+  local first_opt=${words[(i)-*]}+  # insert --list-options right before the first option argument+  darcs_list_options=($words[1,$(($first_opt - 1))] --list-options $words[$first_opt,-1])+  # debugging help+  #print -l $darcs_list_options > ./debug_darcs_completion+  # execute command line with --list-options inserted and+  # split the result (stdout) at line endings+  darcs_arguments=(${(f)"$($darcs_list_options 2>/dev/null)"})+  case $current_word; in     /*|./*|\~*|../*)-        _arguments '*:file:_files'-        ;;-    # Otherwise, let's ask darcs for all possible options+      _files+      ;;+    -*)+      darcs_options=(${${(M)darcs_arguments:#-*}/;/:})+      _describe '' darcs_options+      ;;     *)-      _wanted args expl 'arg for darcs command' \-        compadd -- $( darcs ${words[2]} --list-option )+      case "${words[2]}"; in+        get|clone)+          _urls+          ;;+        *)+          darcs_non_options=(${darcs_arguments:#-*})+          _multi_parts -i -S ' ' / darcs_non_options+          ;;+      esac       ;;   esac fi
contrib/cygwin-wrapper.bash view
@@ -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
contrib/darcs-errors.hlint view
@@ -1,28 +1,3 @@--- Only report errors, since we use this as part of the testsuite. It needs to--- be easy to see what tripped up the testcase.--ignore "Eta reduce" = ""-ignore "Use camelCase" = ""-ignore "Use const" = ""-ignore "Use on" = ""-ignore "Use foldr" = ""-ignore "Use String" = ""-ignore "Use string literal" = ""-ignore "Use guards" = ""-ignore "Use :" = ""-ignore "Redundant brackets" = ""-ignore "Redundant do" = ""-ignore "Redundant return" = ""-ignore "Redundant $" = ""-ignore "Redundant lambda" = ""--ignore "Use fewer imports" = ""-ignore "Use better pragmas" = ""-ignore "Use let" = ""-ignore "Operator rotate" = ""-ignore "Use foldl" = ""-ignore "Unused LANGUAGE pragma" = ""- -- The problem with Prelude readFile is that it's based on hGetContents, which -- is lazy by definition. This also means that unless you force consumption of -- the produced list, it will keep an fd open for the file, possibly
contrib/darcs_completion view
@@ -16,37 +16,58 @@         return 0     fi -    local IFS=$'\n' # So that the following "command-output to array" operation splits only at newlines, not at each space, tab or newline.-    COMPREPLY=( $( darcs ${COMP_WORDS[1]} --list-option | command grep "^${cur//./\\.}") )+    # Top-level options do not accept any further options+    case "${COMP_WORDS[1]}" in+        (-*) COMPREPLY=''; return 0;;+    esac -	# Then, we adapt the resulting strings to be reusable by bash. If we don't-	# do this, in the case where we have two repositories named-	# ~/space in there-0.1 and ~/space in there-0.2, the first completion will-	# give us:-	# bash> darcs push ~/space in there-0.-	# ~/space in there-0.1 ~/space in there-0.2-	# and we have introduced two spaces in the command line (if we try to-	# recomplete that, it won't find anything, as it doesn't know anything-	# starting with "there-0.").-	# printf %q will gracefully add the necessary backslashes.-	#-	# Bash also interprets colon as a separator. If we didn't handle it-	# specially, completing http://example.org/repo from http://e would -	# give us:-	# bash> darcs pull http:http://example.org/repo-	# An option would be to require the user to escape : as \: and we-	# would do the same here. Instead, we return only the part after-	# the last colon that is already there, and thus fool bash. The-	# downside is that bash only shows this part to the user.+    # Build a new command line copying all the tokens and inserting+    # '--list-options' before the first option (a token starting with '-').+    local -a cmdline+    local i=0+    local m=$(( ${#COMP_WORDS[@]} - 1 ))+    for token in "${COMP_WORDS[@]:0:${m}}"+    do+        case "$token" in+            (-*) cmdline+=("--list-options" "${COMP_WORDS[@]:${i}}");+                 break;;+             (*) cmdline+=("$token");+                 i=$(( $i + 1 ));;+        esac+    done+    test $i -eq $m && cmdline+=("--list-options")++    # So that the following "command-output to array" operation splits only at+    # newlines, not at each space, tab or newline.+    local IFS=$'\n'+    COMPREPLY=( $( "${cmdline[@]}" 2>/dev/null |\+        command grep "^${cur//./\\.}" | cut -d ';' -f 1) )++    # Then, we adapt the resulting strings to be reusable by bash. If we don't+    # do this, in the case where we have two repositories named+    # ~/space in there-0.1 and ~/space in there-0.2, the first completion will+    # give us:+    # bash> darcs push ~/space in there-0.+    # ~/space in there-0.1 ~/space in there-0.2+    # and we have introduced two spaces in the command line (if we try to+    # recomplete that, it won't find anything, as it doesn't know anything+    # starting with "there-0.").+    # printf %q will gracefully add the necessary backslashes.+    #+    # Bash also interprets colon as a separator. If we didn't handle it+    # specially, completing http://example.org/repo from http://e would+    # give us:+    # bash> darcs pull http:http://example.org/repo+    # An option would be to require the user to escape : as \: and we+    # would do the same here. Instead, we return only the part after+    # the last colon that is already there, and thus fool bash. The+    # downside is that bash only shows this part to the user.     local i=${#COMPREPLY[*]}     local colonprefixes=${cur%"${cur##*:}"}     while [ $((--i)) -ge 0 ]; do       COMPREPLY[$i]=`printf %q "${COMPREPLY[$i]}"`--      COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"} +      COMPREPLY[$i]=${COMPREPLY[$i]#"$colonprefixes"}     done     return 0- } complete -F _darcs -o default darcs-
+ contrib/runHLint.sh view
@@ -0,0 +1,12 @@+#!/bin/bash++hlint --hint=contrib/darcs-errors.hlint --cpp-simple  ./src+hlint --cpp-simple  ./src++# --cpp-simple is to avoid issues with MIN_VERSION+#   see https://github.com/ndmitchell/hlint/issues/53+# using it creates other problems since #if are ignored..++# When the above bug is solved we can use:+# hlint --hint=contrib/darcs-errors.hlint --cpp-include=./src ./src+# hlint --cpp-include=./src ./src
contrib/update_roundup.pl view
@@ -56,12 +56,15 @@     # Otherwise, we default to darcs-devel as the sender.      my $email = ($author =~ m/\@/) ? $author : 'darcs-devel@darcs.net'; -    my $comment = $patch->{comment} ? "\n$patch->{comment}" : '';+    my $comment = $patch->{comment};+    $comment =~ s/^Ignore-this:.*\n?//m;+    $comment =~ s/^/  /mg;      my $patch_name_minus_status = $patch_name;      $patch_name_minus_status =~ s/$issue_re(:?\s?)//; -     # Each patches can potentially update the status of a different issue, so generates a different e-mail+    # Each patch can potentially update the status of a different issue, so+    # generates a different e-mail     my $msg = MIME::Lite->new(          From     => 'noreply@darcs.net',          To      =>'bugs@lists.osuosl.org',@@ -71,8 +74,12 @@          Data     => qq!The following patch sent by $email updated issue $issue with $UPDATE_STRING -* $patch_name $comment+Hash: $patch->{hash}+Author: $patch->{author}+* $patch_name +$comment+ !      );      $msg->send;@@ -80,5 +87,3 @@      # use File::Slurp;      # write_file("msg-$patch->{hash}.out",$msg->as_string); }--
contrib/upload.cgi view
@@ -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/;
darcs.cabal view
@@ -1,840 +1,735 @@-Name:           darcs-version:        2.8.5-License:        GPL-License-file:   COPYING-Author:         David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net>-Maintainer:     <darcs-devel@darcs.net>--Stability:      Experimental-Category:       Development-Synopsis:       a distributed, interactive, smart revision control system-Description:    Darcs is a free, open source revision control-                system. It is:-                .-                * Distributed: Every user has access to the full-                  command set, removing boundaries between server and-                  client or committer and non-committers.-                .-                * Interactive: Darcs is easy to learn and efficient to-                  use because it asks you questions in response to-                  simple commands, giving you choices in your work-                  flow. You can choose to record one change in a file,-                  while ignoring another. As you update from upstream,-                  you can review each patch name, even the full "diff"-                  for interesting patches.-                .-                * Smart: Originally developed by physicist David-                  Roundy, darcs is based on a unique algebra of-                  patches.-                .-                  This smartness lets you respond to changing demands-                  in ways that would otherwise not be possible. Learn-                  more about spontaneous branches with darcs.-Homepage:       http://darcs.net/--Build-Type:     Custom-Cabal-Version:  >= 1.8--extra-source-files:-  -- C headers-  src/*.h src/Crypt/sha2.h-  src/win32/send_email.h src/win32/sys/mman.h--  -- The contrib directory would make a sensible 'darcs-contrib' package-  contrib/_darcs.zsh, contrib/darcs_completion,-  contrib/cygwin-wrapper.bash, contrib/update_roundup.pl, contrib/upload.cgi,-  contrib/darcs-errors.hlint,--  -- documentation files-  doc/src/best_practices.tex, doc/src/building_darcs.tex, doc/src/configuring_darcs.tex,-  doc/src/features.tex, doc/src/gpl.tex, doc/src/darcs.tex-  doc/darcs.css--  README, NEWS--  -- release data-  release/distributed-version, release/distributed-context--  -- testsuite-  tests/data/*.tgz tests/data/README-  tests/data/*.dpatch-  tests/data/convert/darcs1/*.dpatch tests/data/convert/darcs2/*.dpatch-  tests/*.sh-  tests/bin/trackdown-bisect-helper.hs-  tests/bin/hspwd.hs-  tests/network/*.sh-  tests/lib-  tests/data/example_binary.png-  tests/README.test_maintainers.txt--  GNUmakefile--source-repository head-  type:     darcs-  location: http://darcs.net/--flag curl-  description: Use libcurl for HTTP support.--flag http-  description: Use the pure Haskell HTTP package for HTTP support.--flag network-uri-  description: Get Network.URI from the network-uri package-  default: True--flag static-  description: Build static binary-  default:     False--flag terminfo-  description: Use the terminfo package for enhanced console support.--flag threaded-  description: Use threading and SMP support.-  default:     True--flag library-  description: Build darcs library-  default:     True--flag executable-  description: Build darcs executable-  default:     True--flag color-  description: Use ansi color escapes.--flag mmap-  description: Compile with mmap support.--flag hpc-  default:     False--flag test-  default:     False-  description: Build test harness---- We need optimizations by default, regardless of what Hackage says-flag optimize-  default:     True-  description: Build with optimizations (-O2)--flag warn-as-error-  default:     False-  description: Build with warnings-as-errors---- If base >= 4.4 is used, the standard directory functions--- do Unicode translation. Use a flag so we can--- detect this situation and use a workaround.-flag force-char8-encoding-  default:     False-  description: Allow base 4.5 or above on Unix. base 4.4 introduces a change in-               the behaviour of filenames that requires API calls in-               base 4.5 to workaround. So base 4.4 is not supported at all.---- Note that the Setup script checks whether -liconv is necessary.  This flag--- lets us override that decision.  When it is True, we use -liconv.  When it--- is False, we run tests to decide.-flag libiconv-    Description: Explicitly link against the libiconv library.-    Default: False----- ------------------------------------------------------------------------- darcs library--- ------------------------------------------------------------------------Library-  if !flag(library)-    buildable: False-  else-    buildable: True--    build-tools: ghc >= 6.10 && < 7.10--    hs-source-dirs:   src-    include-dirs:     src--    cpp-options:      -DGADT_WITNESSES=1--    exposed-modules:  CommandLine-                      Crypt.SHA256-                      Darcs.Annotate-                      Darcs.ArgumentDefaults-                      Darcs.Arguments-                      Darcs.Bug-                      Darcs.ColorPrinter-                      Darcs.Commands-                      Darcs.Commands.Add-                      Darcs.Commands.AmendRecord-                      Darcs.Commands.Annotate-                      Darcs.Commands.Apply-                      Darcs.CommandsAux-                      Darcs.Commands.Changes-                      Darcs.Commands.Check-                      Darcs.Commands.Convert-                      Darcs.Commands.Diff-                      Darcs.Commands.Dist-                      Darcs.Commands.Get-                      Darcs.Commands.GZCRCs-                      Darcs.Commands.Help-                      Darcs.Commands.Init-                      Darcs.Commands.MarkConflicts-                      Darcs.Commands.Move-                      Darcs.Commands.Optimize-                      Darcs.Commands.Pull-                      Darcs.Commands.Push-                      Darcs.Commands.Put-                      Darcs.Commands.Record-                      Darcs.Commands.Remove-                      Darcs.Commands.Replace-                      Darcs.Commands.Revert-                      Darcs.Commands.Rollback-                      Darcs.Commands.Send-                      Darcs.Commands.SetPref-                      Darcs.Commands.Show-                      Darcs.Commands.ShowAuthors-                      Darcs.Commands.ShowBug-                      Darcs.Commands.ShowContents-                      Darcs.Commands.ShowFiles-                      Darcs.Commands.ShowIndex-                      Darcs.Commands.ShowRepo-                      Darcs.Commands.ShowTags-                      Darcs.Commands.Tag-                      Darcs.Commands.Test-                      Darcs.Commands.TrackDown-                      Darcs.Commands.TransferMode-                      Darcs.Commands.Util-                      Darcs.Commands.Unrecord-                      Darcs.Commands.Unrevert-                      Darcs.Commands.WhatsNew-                      Darcs.Compat-                      Darcs.Diff-                      Darcs.Email-                      Darcs.External-                      Darcs.Flags-                      Darcs.Global-                      Darcs.IO-                      Darcs.Lock-                      Darcs.Match-                      Darcs.MonadProgress-                      Darcs.Patch-                      Darcs.Patch.Apply-                      Darcs.Patch.ApplyMonad-                      Darcs.Patch.Bracketed-                      Darcs.Patch.Bracketed.Instances-                      Darcs.Patch.Bundle-                      Darcs.Patch.Choices-                      Darcs.Patch.Commute-                      Darcs.Patch.Conflict-                      Darcs.Patch.ConflictMarking-                      Darcs.Patch.Depends-                      Darcs.Patch.Dummy-                      Darcs.Patch.Effect-                      Darcs.Patch.FileName-                      Darcs.Patch.FileHunk-                      Darcs.Patch.Format-                      Darcs.Patch.Info-                      Darcs.Patch.Inspect-                      Darcs.Patch.Invert-                      Darcs.Patch.Match-                      Darcs.Patch.MatchData-                      Darcs.Patch.Merge-                      Darcs.Patch.Named-                      Darcs.Patch.OldDate-                      Darcs.Patch.PatchInfoAnd-                      Darcs.Patch.Patchy-                      Darcs.Patch.Patchy.Instances-                      Darcs.Patch.Permutations-                      Darcs.Patch.Prim-                      Darcs.Patch.Prim.Class-                      Darcs.Patch.Prim.V1-                      Darcs.Patch.Prim.V1.Apply-                      Darcs.Patch.Prim.V1.Coalesce-                      Darcs.Patch.Prim.V1.Commute-                      Darcs.Patch.Prim.V1.Core-                      Darcs.Patch.Prim.V1.Details-                      Darcs.Patch.Prim.V1.Read-                      Darcs.Patch.Prim.V1.Show-                      Darcs.Patch.Prim.V3-                      Darcs.Patch.Prim.V3.ObjectMap-                      Darcs.Patch.Prim.V3.Apply-                      Darcs.Patch.Prim.V3.Coalesce-                      Darcs.Patch.Prim.V3.Commute-                      Darcs.Patch.Prim.V3.Core-                      Darcs.Patch.Prim.V3.Details-                      Darcs.Patch.Prim.V3.Read-                      Darcs.Patch.Prim.V3.Show-                      Darcs.Patch.Read-                      Darcs.Patch.ReadMonads-                      Darcs.Patch.RegChars-                      Darcs.Patch.Repair-                      Darcs.Patch.RepoPatch-                      Darcs.Patch.Set-                      Darcs.Patch.Show-                      Darcs.Patch.Split-                      Darcs.Patch.Summary-                      Darcs.Patch.SummaryData-                      Darcs.Patch.TokenReplace-                      Darcs.Patch.TouchesFiles-                      Darcs.Patch.Viewing-                      Darcs.Patch.V1-                      Darcs.Patch.V1.Apply-                      Darcs.Patch.V1.Commute-                      Darcs.Patch.V1.Core-                      Darcs.Patch.V1.Read-                      Darcs.Patch.V1.Show-                      Darcs.Patch.V1.Viewing-                      Darcs.Patch.V2-                      Darcs.Patch.V2.Non-                      Darcs.Patch.V2.Real-                      Darcs.PrintPatch-                      Darcs.ProgressPatches-                      Darcs.RemoteApply-                      Darcs.RepoPath-                      Darcs.Repository-                      Darcs.Repository.ApplyPatches-                      Darcs.Repository.Cache-                      Darcs.Repository.Format-                      Darcs.Repository.HashedIO-                      Darcs.Repository.HashedRepo-                      Darcs.Repository.Internal-                      Darcs.Repository.LowLevel-                      Darcs.Repository.Merge-                      Darcs.Repository.InternalTypes-                      Darcs.Repository.Motd-                      Darcs.Repository.Old-                      Darcs.Repository.Prefs-                      Darcs.Repository.Repair-                      Darcs.Repository.State-                      Darcs.Resolution-                      Darcs.RunCommand-                      Darcs.SelectChanges-                      Darcs.SignalHandler-                      Darcs.Ssh-                      Darcs.Test-                      Darcs.TheCommands-                      Darcs.URL-                      Darcs.Utils-                      Darcs.Witnesses.Eq-                      Darcs.Witnesses.Ordered-                      Darcs.Witnesses.Sealed-                      Darcs.Witnesses.Show-                      Darcs.Witnesses.Unsafe-                      Darcs.Witnesses.WZipper-                      DateMatcher-                      Encoding-                      English-                      Exec-                      ByteStringUtils-                      IsoDate-                      Lcs-                      Printer-                      Progress-                      Ratified-                      SHA1-                      URL-                      URL.Request-                      URL.HTTP-                      Workaround--    other-modules:    Version-                      URL.Curl--    c-sources:        src/atomic_create.c-                      src/fpstring.c-                      src/maybe_relink.c-                      src/umask.c-                      src/Crypt/sha2.c-                      src/system_encoding.c--    cc-options:       -D_REENTRANT--    if os(windows)-      hs-source-dirs: src/win32-      include-dirs:   src/win32-      other-modules:  CtrlC-                      Encoding.Win32-                      System.Posix-                      System.Posix.Files-                      System.Posix.IO-      cpp-options:    -DWIN32-      c-sources:      src/win32/send_email.c-      build-depends:  unix-compat >= 0.1.2,-                      Win32 >= 2.0,-                      regex-posix >= 0.95.1-    else-      other-modules:  Encoding.IConv-      c-sources:      src/h_iconv.c-      build-depends:  utf8-string >= 0.3.6 && < 0.4--    if os(solaris)-      cc-options:     -DHAVE_SIGINFO_H--    if os(windows)-      build-depends:  base >= 4 && < 4.8-    else-      if flag(force-char8-encoding)-        build-depends:  base >= 4.5 && < 4.8-        cpp-options:    -DFORCE_CHAR8_ENCODING-      else-        build-depends:  base >= 4 && < 4.4--    build-depends:   extensible-exceptions >= 0.1 && < 0.2,-                     regex-compat >= 0.95.1,-                     mtl          >= 1.0 && < 2.3,-                     parsec       >= 2.0 && < 3.2,-                     html         == 1.0.*,-                     filepath     >= 1.1.0.0 && < 1.5.0.0,-                     haskeline    >= 0.6.3 && < 0.8,-                     hashed-storage >= 0.5.6 && < 0.6,-                     vector       >= 0.7,-                     tar          >= 0.3 && < 0.5--    if impl(ghc<7.0)-      -- haskeline 0.6.4.7 doesn't build with ghc 6.12-      build-depends: haskeline <= 0.6.4.6--    if !os(windows)-      build-depends: unix >= 1.0 && < 2.8--    build-depends: bytestring >= 0.9.0 && < 0.11,-                   text       >= 0.11.0.6 && < 1.2,-                   old-time   >= 1.0 && < 1.2,-                   directory  >= 1.0.0.0 && < 1.3.0.0,-                   process    >= 1.0.0.0 && < 1.3.0.0,-                   containers >= 0.1 && < 0.6,-                   array      >= 0.1 && < 0.6,-                   random     == 1.0.*---    if flag(optimize)-      ghc-options:      -O2-    else-      ghc-options:      -O0--    if flag(warn-as-error)-      ghc-options:      -Werror--    -- Note: "if true" works around a cabal bug with order of flag composition-    if true-      ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs--    ghc-prof-options: -prof -auto-all--    if flag(hpc)-      ghc-prof-options: -fhpc -hpcdir dist/hpc/libdarcs--    if flag(curl)-      extra-libraries:   curl-      includes:          curl/curl.h-      cpp-options:       -DHAVE_CURL-      c-sources:         src/hscurl.c-      cc-options:        -DHAVE_CURL--    if flag(http)-        build-depends:    HTTP    >= 4000.0.8 && < 4000.3-        cpp-options:      -DHAVE_HTTP-        x-have-http:-        if flag(network-uri)-          build-depends: network >= 2.6, network-uri >= 2.6-        else-          build-depends: network >= 2.2, network < 2.6--    if (!flag(curl) && !flag(http))-        buildable: False--    if flag(mmap) && !os(windows)-      build-depends:    mmap >= 0.5 && < 0.6-      cpp-options:      -DHAVE_MMAP--    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0--    -- The terminfo package cannot be built on Windows.-    if flag(terminfo) && !os(windows)-      build-depends:    terminfo == 0.3.*-      cpp-options:      -DHAVE_TERMINFO--    if flag(color)-      x-use-color:--    -- if true to work around cabal bug with flag ordering-    if true-      extensions:-        CPP-        BangPatterns-        PatternGuards-        GADTs-        TypeOperators-        FlexibleContexts-        FlexibleInstances-        ScopedTypeVariables-        KindSignatures-        RankNTypes-        TypeFamilies--    if impl(ghc>=7.0)-      extensions:-        NoMonoLocalBinds--    if impl(ghc>=7.6)-      -- in ghc < 7.6 we need to import Prelude hiding (catch)-      -- in ghc >= 7.6 catch isn't in Prelude-      ghc-options:     -fno-warn-dodgy-imports----- ------------------------------------------------------------------------- darcs itself--- ------------------------------------------------------------------------Executable          darcs-  if !flag(executable)-    buildable: False-  else-    buildable: True-  build-tools: ghc >= 6.10 && < 7.10--  main-is:          darcs.hs-  hs-source-dirs:   src-  include-dirs:     src-  c-sources:        src/atomic_create.c-                    src/fpstring.c-                    src/maybe_relink.c-                    src/umask.c-                    src/Crypt/sha2.c-                    src/system_encoding.c---  if flag(optimize)-    ghc-options:      -O2-  else-    ghc-options:      -O0--  if flag(warn-as-error)-    ghc-options:      -Werror--  -- Note: "if true" works around a cabal bug with order of flag composition-  if true-    ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs--  ghc-prof-options: -prof -auto-all-  if flag(threaded)-    ghc-options:    -threaded--  if flag(static)-    ghc-options: -static -optl-static -optl-pthread--  if flag(hpc)-    ghc-prof-options: -fhpc -hpcdir dist/hpc/darcs--  cc-options:       -D_REENTRANT--  if os(windows)-    hs-source-dirs: src/win32-    include-dirs:   src/win32-    other-modules:  CtrlC-                    System.Posix-                    System.Posix.Files-                    System.Posix.IO-                    Preproc-    cpp-options:    -DWIN32-    c-sources:      src/win32/send_email.c-    build-depends:  unix-compat >= 0.1.2,-                    Win32 >= 2.0,-                    regex-posix >= 0.95.1-  else-    c-sources:      src/h_iconv.c-    build-depends:  utf8-string >= 0.3.6 && < 0.4-    -- need to list this explicitly to get cabal to run hsc2hs-    other-modules:  Encoding.IConv---  if os(solaris)-    cc-options:     -DHAVE_SIGINFO_H--  if os(windows)-    build-depends:  base >= 4 && < 4.8-  else-    if flag(force-char8-encoding)-      build-depends:  base >= 4.5 && < 4.8-      cpp-options:    -DFORCE_CHAR8_ENCODING-    else-      build-depends:  base >= 4 && < 4.4--  build-depends:   extensible-exceptions >= 0.1 && < 0.2,-                   regex-compat >= 0.95.1,-                   mtl          >= 1.0 && < 2.3,-                   parsec       >= 2.0 && < 3.2,-                   html         == 1.0.*,-                   filepath     >= 1.1.0.0 && < 1.5.0.0,-                   haskeline    >= 0.6.3 && < 0.8,-                   hashed-storage >= 0.5.6 && < 0.6,-                   vector       >= 0.7,-                   tar          >= 0.3 && < 0.5--  if impl(ghc<7.0)-    -- haskeline 0.6.4.7 doesn't build with ghc 6.12-    build-depends: haskeline <= 0.6.4.6--  if !os(windows)-    build-depends: unix >= 1.0 && < 2.8--  build-depends:   bytestring >= 0.9.0 && < 0.11,-                   text       >= 0.11.0.6 && < 1.2,-                   old-time   >= 1.0 && < 1.2,-                   directory  >= 1.0.0.0 && < 1.3.0.0,-                   process    >= 1.0.0.0 && < 1.3.0.0,-                   containers >= 0.1 && < 0.6,-                   array      >= 0.1 && < 0.6,-                   random     == 1.0.*--  if flag(curl)-    extra-libraries:   curl-    includes:          curl/curl.h-    cpp-options:       -DHAVE_CURL-    c-sources:         src/hscurl.c-    cc-options:        -DHAVE_CURL--  if flag(http)-      build-depends:    HTTP    >= 4000.0.8 && < 4000.3-      cpp-options:      -DHAVE_HTTP-      x-have-http:-      if flag(network-uri)-        build-depends: network >= 2.6, network-uri >= 2.6-      else-        build-depends: network >= 2.2, network < 2.6--  if (!flag(curl) && !flag(http))-      buildable: False--  if flag(mmap) && !os(windows)-    build-depends:    mmap >= 0.5 && < 0.6-    cpp-options:      -DHAVE_MMAP--  build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0--  -- The terminfo package cannot be built on Windows.-  if flag(terminfo) && !os(windows)-    build-depends:    terminfo == 0.3.*-    cpp-options:      -DHAVE_TERMINFO--  if flag(color)-    x-use-color:--  -- if true to work around cabal bug with flag ordering-  if true-    extensions:-      CPP-      BangPatterns-      PatternGuards-      GADTs-      TypeOperators-      FlexibleContexts-      FlexibleInstances-      ScopedTypeVariables-      KindSignatures-      RankNTypes-      TypeFamilies--  if impl(ghc>=7.0)-    extensions:-      NoMonoLocalBinds--  if impl(ghc>=7.6)-    -- in ghc < 7.6 we need to import Prelude hiding (catch)-    -- in ghc >= 7.6 catch isn't in Prelude-    ghc-options:     -fno-warn-dodgy-imports---- ------------------------------------------------------------------------- unit test driver--- ------------------------------------------------------------------------Executable          darcs-test-  main-is:          test.hs--  build-tools: ghc >= 6.10 && < 7.10---  if !flag(test)-    buildable: False-  else-    buildable: True--    build-depends:   extensible-exceptions >= 0.1 && < 0.2,-                     regex-compat >= 0.95.1,-                     mtl          >= 1.0 && < 2.3,-                     parsec       >= 2.0 && < 3.2,-                     html         == 1.0.*,-                     filepath     >= 1.1.0.0 && < 1.5.0.0,-                     FindBin      >= 0.0 && < 0.1,-                     QuickCheck   >= 2.3,-                     HUnit        >= 1.0,-                     cmdlib       >= 0.2.1 && < 0.4,-                     shellish     >= 0.1.3 && < 0.2,-                     test-framework             >= 0.4.0,-                     test-framework-hunit       >= 0.2.2,-                     test-framework-quickcheck2 >= 0.2.8--    hs-source-dirs:   src-    include-dirs:     src-    c-sources:        src/atomic_create.c-                      src/fpstring.c-                      src/maybe_relink.c-                      src/umask.c-                      src/Crypt/sha2.c-                      src/system_encoding.c-    -- list all unit test modules not exported by libdarcs; otherwise Cabal won't-    -- include them in the tarball-    other-modules:    Darcs.Test.Email-                      Darcs.Test.Patch.Check-                      Darcs.Test.Patch.Examples.Set1-                      Darcs.Test.Patch.Examples.Set2Unwitnessed-                      Darcs.Test.Patch.WSub-                      Darcs.Test.Patch.Info-                      Darcs.Test.Patch.Properties.V1Set1-                      Darcs.Test.Patch.Properties.V1Set2-                      Darcs.Test.Patch.Properties.Generic-                      Darcs.Test.Patch.Properties.GenericUnwitnessed-                      Darcs.Test.Patch.Properties.Check-                      Darcs.Test.Patch.Properties.Real-                      Darcs.Test.Patch.Arbitrary.Generic-                      Darcs.Test.Patch.Arbitrary.Real-                      Darcs.Test.Patch.Arbitrary.PrimV1-                      Darcs.Test.Patch.Arbitrary.PrimV3-                      Darcs.Test.Patch.Arbitrary.PatchV1-                      Darcs.Test.Patch.RepoModel-                      Darcs.Test.Patch.Utils-                      Darcs.Test.Patch.V1Model-                      Darcs.Test.Patch.V3Model-                      Darcs.Test.Patch.WithState-                      Darcs.Test.Patch-                      Darcs.Test.Misc-                      Darcs.Test.Util.TestResult-                      Darcs.Test.Util.QuickCheck--    if flag(optimize)-      ghc-options:      -O2-    else-      ghc-options:      -O0--    if flag(warn-as-error)-      ghc-options:      -Werror--    -- Note: "if true" works around a cabal bug with order of flag composition-    if true-      ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs--    ghc-prof-options: -prof -auto-all-    if flag(threaded)-      ghc-options:    -threaded--    if flag(curl)-      extra-libraries:   curl-      includes:          curl/curl.h-      cpp-options:       -DHAVE_CURL-      c-sources:         src/hscurl.c-      cc-options:        -DHAVE_CURL---    if flag(hpc)-      ghc-prof-options: -fhpc -hpcdir dist/hpc/darcs-test--    cc-options:       -D_REENTRANT--    cpp-options:      -DGADT_WITNESSES=1--    if os(windows)-      hs-source-dirs: src/win32-      include-dirs:   src/win32-      other-modules:  CtrlC-                      System.Posix-                      System.Posix.Files-                      System.Posix.IO-      cpp-options:    -DWIN32-      c-sources:      src/win32/send_email.c-      build-depends:  unix-compat >= 0.1.2,-                      Win32 >= 2.0,-                      regex-posix >= 0.95.1-    else-      c-sources:      src/h_iconv.c-      build-depends:  utf8-string >= 0.3.6 && < 0.4-      -- need to list this explicitly to get cabal to run hsc2hs-      other-modules:  Encoding.IConv--    if os(solaris)-      cc-options:     -DHAVE_SIGINFO_H--    if os(windows)-      build-depends:  base >= 4 && < 4.8-    else-      if flag(force-char8-encoding)-        build-depends:  base >= 4.5 && < 4.8-        cpp-options:    -DFORCE_CHAR8_ENCODING-      else-        build-depends:  base >= 4 && < 4.4--    if !os(windows)-      build-depends: unix >= 1.0 && < 2.8--    build-depends: bytestring >= 0.9.0 && < 0.11,-                   haskeline    >= 0.6.3 && < 0.8,-                   text       >= 0.11.0.6 && < 1.2,-                   old-time   >= 1.0 && < 1.2,-                   directory  >= 1.0.0.0 && < 1.3.0.0,-                   process    >= 1.0.0.0 && < 1.3.0.0,-                   containers >= 0.1 && < 0.6,-                   array      >= 0.1 && < 0.6,-                   hashed-storage >= 0.5.6 && < 0.6,-                   vector       >= 0.7,-                   tar        >= 0.3 && < 0.5,-                   random     == 1.0.*--    if impl(ghc<7.0)-      -- haskeline 0.6.4.7 doesn't build with ghc 6.12-      build-depends: haskeline <= 0.6.4.6--    if flag(mmap) && !os(windows)-      build-depends:    mmap >= 0.5 && < 0.6-      cpp-options:      -DHAVE_MMAP--    build-depends:    zlib >= 0.5.1.0 && < 0.6.0.0--    -- The terminfo package cannot be built on Windows.-    if flag(terminfo) && !os(windows)-      build-depends:    terminfo == 0.3.*-      cpp-options:      -DHAVE_TERMINFO--    if flag(http)-        build-depends:    HTTP    >= 4000.0.8 && < 4000.3-        if flag(network-uri)-          build-depends: network >= 2.6, network-uri >= 2.6-        else-          build-depends: network >= 2.2, network < 2.6--    if flag(color)-      x-use-color:--    -- if true to work around cabal bug with flag ordering-    if true-      extensions:-        CPP-        BangPatterns-        PatternGuards-        GADTs-        TypeOperators-        FlexibleContexts-        FlexibleInstances-        ScopedTypeVariables-        KindSignatures-        RankNTypes-        TypeFamilies--    if impl(ghc>=7.0)-      extensions:-        NoMonoLocalBinds--    if impl(ghc>=7.6)-      -- in ghc < 7.6 we need to import Prelude hiding (catch)-      -- in ghc >= 7.6 catch isn't in Prelude-      ghc-options:     -fno-warn-dodgy-imports+Cabal-Version:  2.4+Name:           darcs+version:        2.18.5+License:        GPL-2.0-or-later+License-file:   COPYING+Author:         David Roundy <droundy@darcs.net>, <darcs-devel@darcs.net>+Maintainer:     <darcs-devel@darcs.net>++Stability:      Experimental+Category:       Development+Synopsis:       a distributed, interactive, smart revision control system+Description:    Darcs is a free, open source revision control+                system. It is:+                .+                * Distributed: Darcs was one of the first revision control+                  systems in which every user has access to the full command+                  set, removing boundaries between server and client or+                  committer and non-committers.+                .+                * Interactive: Darcs is easy to learn and efficient to use+                  because it asks you questions in response to simple+                  commands, giving you choices in your work flow. You can+                  choose to record one change in a file, while ignoring+                  another. As you update from upstream, you can review each+                  patch, picking and choosing which patches are appropriate.+                .+                * Smart: Darcs is different from most revision control+                  systems in that it is based on the notion of change (or+                  patch), rather than version. An underlying algebra of+                  patches determines whether changes can be re-ordered. The+                  laws of this algebra guarantee that the result of merging+                  depends only on the final set of patches applied in a+                  repository and not on their order.+                .+                * Simple: As a consequence, Darcs offers a conceptually+                  simpler view of the state of a repository: it is given by+                  the set of patches it contains. Pulling and pushing+                  patches merely transfers them from one set to another. So+                  called "cherry-picking" is the default mode of operation,+                  and it fully preserves the identity of patches.++Homepage:       http://darcs.net/++Build-Type:     Custom+extra-source-files:+  -- C files+  src/*.h+  src/win32/send_email.h++  contrib/cygwin-wrapper.bash+  contrib/darcs_completion+  contrib/darcs-errors.hlint+  contrib/_darcs.zsh+  contrib/runHLint.sh+  contrib/update_roundup.pl+  contrib/upload.cgi++  README.md++  -- release data+  release/distributed-version+  release/distributed-context++  -- bundled shelly (the bare minimum required)+  shelly/LICENSE++  -- testsuite+  tests/data/*.tgz+  tests/data/README+  tests/data/cyrillic_import_stream+  tests/data/*.dpatch+  tests/data/example_binary.png+  tests/data/convert/darcs1/*.dpatch+  tests/data/convert/darcs2/*.dpatch+  tests/*.sh+  tests/README.test_maintainers.txt+  tests/bin/*.hs+  tests/network/httplib+  tests/network/sshlib+  tests/network/*.sh+  tests/lib+  harness/hstestdata.zip++  GNUmakefile++extra-doc-files:+  CHANGELOG.md++source-repository head+  type:     darcs+  location: http://darcs.net/++flag static+  description: Build static binary+  default:     False+  manual:      True++flag terminfo+  description: Use the terminfo package for enhanced console support.++flag threaded+  description: Use threading and SMP support.+  default:     True+  manual:      True++flag executable+  description: Build darcs executable+  default:     True+  manual:      True++flag rts+  description: Support RTS options+  default:     False+  manual:      True++flag warn-as-error+  default:     False+  manual:      True+  description: Build with warnings-as-errors++-- ----------------------------------------------------------------------+-- setup+-- ----------------------------------------------------------------------++custom-setup+    setup-depends: base      >= 4.10 && < 4.20,+                   Cabal     >= 2.4 && < 3.11,+                   process   >= 1.2.3.0 && < 1.7,+                   filepath  >= 1.4.1 && < 1.5.0.0,+                   directory >= 1.2.7 && < 1.4++-- ----------------------------------------------------------------------+-- darcs library+-- ----------------------------------------------------------------------++Library+    default-language: Haskell2010++    hs-source-dirs:   src+    include-dirs:     src++    exposed-modules:+                      Darcs.Patch+                      Darcs.Patch.Annotate+                      Darcs.Patch.Annotate.Class+                      Darcs.Patch.Apply+                      Darcs.Patch.ApplyMonad+                      Darcs.Patch.Bracketed+                      Darcs.Patch.Bundle+                      Darcs.Patch.Choices+                      Darcs.Patch.Commute+                      Darcs.Patch.CommuteFn+                      Darcs.Patch.CommuteNoConflicts+                      Darcs.Patch.Conflict+                      Darcs.Patch.Debug+                      Darcs.Patch.Depends+                      Darcs.Patch.Effect+                      Darcs.Patch.FileHunk+                      Darcs.Patch.Format+                      Darcs.Patch.FromPrim+                      Darcs.Patch.Ident+                      Darcs.Patch.Index.Monad+                      Darcs.Patch.Index.Types+                      Darcs.Patch.Info+                      Darcs.Patch.Inspect+                      Darcs.Patch.Invert+                      Darcs.Patch.Invertible+                      Darcs.Patch.Match+                      Darcs.Patch.Merge+                      Darcs.Patch.Named+                      Darcs.Patch.Object+                      Darcs.Patch.PatchInfoAnd+                      Darcs.Patch.Permutations+                      Darcs.Patch.Prim+                      Darcs.Patch.Prim.Canonize+                      Darcs.Patch.Prim.Class+                      Darcs.Patch.Prim.Coalesce+                      Darcs.Patch.Prim.FileUUID+                      Darcs.Patch.Prim.FileUUID.Apply+                      Darcs.Patch.Prim.FileUUID.Coalesce+                      Darcs.Patch.Prim.FileUUID.Commute+                      Darcs.Patch.Prim.FileUUID.Core+                      Darcs.Patch.Prim.FileUUID.Details+                      Darcs.Patch.Prim.FileUUID.ObjectMap+                      Darcs.Patch.Prim.FileUUID.Read+                      Darcs.Patch.Prim.FileUUID.Show+                      Darcs.Patch.Prim.Named+                      Darcs.Patch.Prim.V1+                      Darcs.Patch.Prim.V1.Apply+                      Darcs.Patch.Prim.V1.Coalesce+                      Darcs.Patch.Prim.V1.Commute+                      Darcs.Patch.Prim.V1.Core+                      Darcs.Patch.Prim.V1.Details+                      Darcs.Patch.Prim.V1.Mangle+                      Darcs.Patch.Prim.V1.Read+                      Darcs.Patch.Prim.V1.Show+                      Darcs.Patch.Prim.WithName+                      Darcs.Patch.Progress+                      Darcs.Patch.Read+                      Darcs.Patch.Rebase.Change+                      Darcs.Patch.Rebase.Fixup+                      Darcs.Patch.Rebase.Legacy.Item+                      Darcs.Patch.Rebase.Legacy.Wrapped+                      Darcs.Patch.Rebase.Name+                      Darcs.Patch.Rebase.PushFixup+                      Darcs.Patch.Rebase.Suspended+                      Darcs.Patch.RegChars+                      Darcs.Patch.Repair+                      Darcs.Patch.RepoPatch+                      Darcs.Patch.Set+                      Darcs.Patch.Show+                      Darcs.Patch.Split+                      Darcs.Patch.Summary+                      Darcs.Patch.SummaryData+                      Darcs.Patch.TokenReplace+                      Darcs.Patch.TouchesFiles+                      Darcs.Patch.Unwind+                      Darcs.Patch.V1+                      Darcs.Patch.V1.Apply+                      Darcs.Patch.V1.Commute+                      Darcs.Patch.V1.Core+                      Darcs.Patch.V1.Prim+                      Darcs.Patch.V1.Read+                      Darcs.Patch.V1.Show+                      Darcs.Patch.V1.Viewing+                      Darcs.Patch.V2+                      Darcs.Patch.V2.Non+                      Darcs.Patch.V2.Prim+                      Darcs.Patch.V2.RepoPatch+                      Darcs.Patch.V3+                      Darcs.Patch.V3.Contexted+                      Darcs.Patch.V3.Core+                      Darcs.Patch.V3.Resolution+                      Darcs.Patch.Viewing+                      Darcs.Patch.Witnesses.Eq+                      Darcs.Patch.Witnesses.Maybe+                      Darcs.Patch.Witnesses.Ordered+                      Darcs.Patch.Witnesses.Sealed+                      Darcs.Patch.Witnesses.Show+                      Darcs.Patch.Witnesses.Unsafe+                      Darcs.Patch.Witnesses.WZipper+                      Darcs.Prelude+                      Darcs.Repository+                      Darcs.Repository.ApplyPatches+                      Darcs.Repository.Clone+                      Darcs.Repository.Create+                      Darcs.Repository.Diff+                      Darcs.Repository.Flags+                      Darcs.Repository.Format+                      Darcs.Repository.Hashed+                      Darcs.Repository.Identify+                      Darcs.Repository.InternalTypes+                      Darcs.Repository.Inventory+                      Darcs.Repository.Inventory.Format+                      Darcs.Repository.Job+                      Darcs.Repository.Match+                      Darcs.Repository.Merge+                      Darcs.Repository.Old+                      Darcs.Repository.Packs+                      Darcs.Repository.PatchIndex+                      Darcs.Repository.Paths+                      Darcs.Repository.Pending+                      Darcs.Repository.Prefs+                      Darcs.Repository.Pristine+                      Darcs.Repository.Rebase+                      Darcs.Repository.Repair+                      Darcs.Repository.Resolution+                      Darcs.Repository.State+                      Darcs.Repository.Transaction+                      Darcs.Repository.Traverse+                      Darcs.Repository.Unrevert+                      Darcs.Repository.Working+                      Darcs.Test.TestOnly+                      Darcs.UI.ApplyPatches+                      Darcs.UI.Commands+                      Darcs.UI.Commands.Add+                      Darcs.UI.Commands.Amend+                      Darcs.UI.Commands.Annotate+                      Darcs.UI.Commands.Apply+                      Darcs.UI.Commands.Clone+                      Darcs.UI.Commands.Convert+                      Darcs.UI.Commands.Convert.Darcs2+                      Darcs.UI.Commands.Convert.Export+                      Darcs.UI.Commands.Convert.Import+                      Darcs.UI.Commands.Convert.Util+                      Darcs.UI.Commands.Diff+                      Darcs.UI.Commands.Dist+                      Darcs.UI.Commands.GZCRCs+                      Darcs.UI.Commands.Help+                      Darcs.UI.Commands.Init+                      Darcs.UI.Commands.Log+                      Darcs.UI.Commands.MarkConflicts+                      Darcs.UI.Commands.Move+                      Darcs.UI.Commands.Optimize+                      Darcs.UI.Commands.Pull+                      Darcs.UI.Commands.Push+                      Darcs.UI.Commands.Rebase+                      Darcs.UI.Commands.Record+                      Darcs.UI.Commands.Remove+                      Darcs.UI.Commands.Repair+                      Darcs.UI.Commands.Replace+                      Darcs.UI.Commands.Revert+                      Darcs.UI.Commands.Rollback+                      Darcs.UI.Commands.Send+                      Darcs.UI.Commands.SetPref+                      Darcs.UI.Commands.Show+                      Darcs.UI.Commands.ShowAuthors+                      Darcs.UI.Commands.ShowContents+                      Darcs.UI.Commands.ShowDependencies+                      Darcs.UI.Commands.ShowFiles+                      Darcs.UI.Commands.ShowIndex+                      Darcs.UI.Commands.ShowPatchIndex+                      Darcs.UI.Commands.ShowRepo+                      Darcs.UI.Commands.ShowTags+                      Darcs.UI.Commands.Tag+                      Darcs.UI.Commands.Test+                      Darcs.UI.Commands.Test.Impl+                      Darcs.UI.Commands.TransferMode+                      Darcs.UI.Commands.Unrecord+                      Darcs.UI.Commands.Unrevert+                      Darcs.UI.Commands.Util+                      Darcs.UI.Commands.WhatsNew+                      Darcs.UI.Completion+                      Darcs.UI.Defaults+                      Darcs.UI.Email+                      Darcs.UI.External+                      Darcs.UI.Flags+                      Darcs.UI.Options+                      Darcs.UI.Options.All+                      Darcs.UI.Options.Core+                      Darcs.UI.Options.Flags+                      Darcs.UI.Options.Iso+                      Darcs.UI.Options.Markdown+                      Darcs.UI.Options.Matching+                      Darcs.UI.Options.Util+                      Darcs.UI.PatchHeader+                      Darcs.UI.PrintPatch+                      Darcs.UI.Prompt+                      Darcs.UI.RunCommand+                      Darcs.UI.RunHook+                      Darcs.UI.SelectChanges+                      Darcs.UI.TestChanges+                      Darcs.UI.TheCommands+                      Darcs.UI.Usage+                      Darcs.Util.AtExit+                      Darcs.Util.ByteString+                      Darcs.Util.Cache+                      Darcs.Util.CommandLine+                      Darcs.Util.Compat+                      Darcs.Util.DateMatcher+                      Darcs.Util.DateTime+                      Darcs.Util.Diff+                      Darcs.Util.Diff.Myers+                      Darcs.Util.Diff.Patience+                      Darcs.Util.Encoding+                      Darcs.Util.English+                      Darcs.Util.Exception+                      Darcs.Util.Exec+                      Darcs.Util.File+                      Darcs.Util.Global+                      Darcs.Util.Graph+                      Darcs.Util.Hash+                      Darcs.Util.HTTP+                      Darcs.Util.Index+                      Darcs.Util.IndexedMonad+                      Darcs.Util.IsoDate+                      Darcs.Util.Lock+                      Darcs.Util.Parser+                      Darcs.Util.Path+                      Darcs.Util.Printer+                      Darcs.Util.Printer.Color+                      Darcs.Util.Progress+                      Darcs.Util.Prompt+                      Darcs.Util.Ratified+                      Darcs.Util.Regex+                      Darcs.Util.Show+                      Darcs.Util.SignalHandler+                      Darcs.Util.Ssh+                      Darcs.Util.StrictIdentity+                      Darcs.Util.Tree+                      Darcs.Util.Tree.Hashed+                      Darcs.Util.Tree.Monad+                      Darcs.Util.Tree.Plain+                      Darcs.Util.URL+                      Darcs.Util.ValidHash+                      Darcs.Util.Workaround++    autogen-modules:  Version++    other-modules:    Version++    c-sources:        src/atomic_create.c+                      src/maybe_relink.c+                      src/umask.c++    -- see http://bugs.darcs.net/issue1037+    cc-options:       -D_REENTRANT++    if os(windows)+      hs-source-dirs: src/win32+      include-dirs:   src/win32+      other-modules:  Darcs.Util.CtrlC+                      Darcs.Util.Encoding.Win32+                      -- These are kept outside the Darcs.* namespace as System.Posix+                      -- is well-established and its just trying to simulate that+                      -- TODO try to abstract this out better+                      System.Posix+                      System.Posix.Files+                      System.Posix.IO+      cpp-options:    -DWIN32+      c-sources:      src/win32/send_email.c+      build-depends:  Win32             >= 2.4.0 && < 2.14,+                      -- exclude 1.3.8 .. 1.3.8.4 due to bug on windows+                      directory         >= 1.2.7 && < 1.3.8 || >= 1.3.8.5 && < 1.4+    else+      build-depends:  unix              >= 2.7.1.0 && < 2.9,+                      directory         >= 1.2.7 && < 1.4++    build-depends:    base              >= 4.10 && < 4.20,+                      safe              >= 0.3.20 && < 0.4,+                      stm               >= 2.1 && < 2.6,+                      binary            >= 0.5 && < 0.11,+                      containers        >= 0.5.11 && < 0.8,+                      regex-base        >= 0.94.0.1 && < 0.94.1,+                      regex-tdfa        >= 1.3.2 && < 1.4,+                      regex-applicative >= 0.2 && < 0.4,+                      mtl               >= 2.2.1 && < 2.4,+                      transformers      >= 0.4.2.0 && < 0.7,+                      parsec            >= 3.1.9 && < 3.2,+                      fgl               >= 5.5.2.3 && < 5.9,+                      html              >= 1.0.1.2 && < 1.1,+                      filepath          >= 1.4.1 && < 1.6,+                      haskeline         >= 0.7.2 && < 0.9,+                      memory            >= 0.14 && < 0.19,+                      cryptonite        >= 0.24 && < 0.31,+                      base16-bytestring >= 1.0 && < 1.1,+                      utf8-string       >= 1 && < 1.1,+                      vector            >= 0.11 && < 0.14,+                      tar               >= 0.5 && < 0.7,+                      data-ordlist      == 0.4.*++    if impl(ghc < 8.10)+      build-depends:  attoparsec        >= 0.13.0.1 && < 0.14.4+    else+      build-depends:  attoparsec        >= 0.14.4 && < 0.15++    build-depends:    zip-archive       >= 0.3 && < 0.5,+                      async             >= 2.0.2 && < 2.3,+                      constraints       >= 0.11 && < 0.15,+                      unix-compat       >= 0.6 && < 0.8,+                      bytestring        >= 0.10.6 && < 0.13,+                      old-time          >= 1.1.0.3 && < 1.2,+                      time              >= 1.9 && < 1.15,+                      text              >= 1.2.1.3 && < 2.2,+                      temporary         >= 1.2.1 && < 1.4,+                      process           >= 1.2.3.0 && < 1.7,+                      array             >= 0.5.1.0 && < 0.6,+                      hashable          >= 1.2.3.3 && < 1.5,+                      mmap              >= 0.5.9 && < 0.6,+                      zlib              >= 0.6.1.2 && < 0.8,+                      network-uri       >= 2.6 && < 2.8,+                      network           >= 2.6 && < 3.3,+                      conduit           >= 1.3.0 && < 1.4,+                      http-conduit      >= 2.3 && < 2.4,+                      http-types        >= 0.12.1 && < 0.12.5,+                      exceptions        >= 0.6 && < 0.11,+                      terminal-size     >= 0.3.4 && < 0.4++    if impl(ghc >= 9.8)+      cpp-options:    -DHAVE_CRYPTON_CONNECTION+      build-depends:  crypton-connection >= 0.4 && < 0.5,+                      data-default      >= 0.7.1.3 && < 0.9,+                      http-client-tls   >= 0.3.5 && < 0.4,+                      tls               >= 2.0.6 && < 2.2+    else+      -- cannot use crypton-connection >= 0.4, so+      -- constraining indirect dependency to work around problems+      -- connecting to hub.darcs.net - see https://bugs.darcs.net/issue2715+      build-depends:  tls               < 2.0.0++    if flag(warn-as-error)+      ghc-options:    -Werror++    ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs++    if impl(ghc >= 9.4.1)+      ghc-options:    -Wno-gadt-mono-local-binds++    if impl(ghc >= 9.0.1)+      ghc-options:    -Wno-star-is-type++    -- The terminfo package cannot be built on Windows.+    if flag(terminfo) && !os(windows)+      build-depends:  terminfo >= 0.4.0.2 && < 0.5+      cpp-options:    -DHAVE_TERMINFO++    default-extensions:+        BangPatterns+        ConstraintKinds+        DataKinds+        DefaultSignatures+        DeriveDataTypeable+        DeriveFunctor+        EmptyDataDecls+        FlexibleContexts+        FlexibleInstances+        GADTs+        GeneralizedNewtypeDeriving+        KindSignatures+        LambdaCase+        NoImplicitPrelude+        PatternGuards+        RankNTypes+        RecordWildCards+        RoleAnnotations+        ScopedTypeVariables+        StandaloneDeriving+        TupleSections+        TypeApplications+        TypeFamilies+        TypeOperators+        -- this must come last because some of the+        -- other extensions imply MonoLocalBinds+        NoMonoLocalBinds++-- ----------------------------------------------------------------------+-- darcs itself+-- ----------------------------------------------------------------------++Executable          darcs+  if !flag(executable)+    buildable: False+  else+    buildable: True++  default-language: Haskell2010++  main-is:          darcs.hs+  hs-source-dirs:   darcs++  autogen-modules:  Version++  other-modules:    Version++  if flag(warn-as-error)+    ghc-options:    -Werror++  ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs++  if flag(threaded)+    ghc-options:    -threaded++  if flag(static)+    ghc-options:    -static -optl-static -optl-pthread++  if flag(rts)+    ghc-options:    -rtsopts++  -- see http://bugs.darcs.net/issue1037+  cc-options:       -D_REENTRANT++  build-depends:    darcs, base++  default-extensions:+                    NoImplicitPrelude++-- ----------------------------------------------------------------------+-- unit test driver+-- ----------------------------------------------------------------------++test-suite darcs-test+  buildable:        True+  type:             exitcode-stdio-1.0+  default-language: Haskell2010+  main-is:          test.hs+  hs-source-dirs:   harness, shelly/src++  if os(windows)+    cpp-options:    -DWIN32+    build-depends:  Win32++  build-depends:    darcs,+                    base,+                    array,+                    bytestring,+                    cmdargs      >= 0.10.10 && < 0.11,+                    containers,+                    constraints,+                    filepath,+                    mtl,+                    safe,+                    transformers,+                    text,+                    directory,+                    FindBin      >= 0.0.5 && < 0.1,+                    QuickCheck   >= 2.13 && < 2.16,+                    quickcheck-instances       >= 0.3.29.1 && < 0.4,+                    leancheck    >= 0.9 && < 1.1,+                    HUnit        >= 1.3 && < 1.7,+                    test-framework             >= 0.8.1.1 && < 0.9,+                    test-framework-hunit       >= 0.3.0.2 && < 0.4,+                    test-framework-quickcheck2 >= 0.3.0.3 && < 0.4,+                    test-framework-leancheck   >= 0.0.1 && < 0.1,+                    vector,+                    zip-archive,+                    -- additional dependencies needed by the shelly modules+                    async,+                    exceptions,+                    monad-control              >= 0.3.2 && < 1.1,+                    process,+                    system-filepath            >= 0.4.7 && < 0.5,+                    -- exclude 0.3.16.5 which fails to build on Windows+                    system-fileio              < 0.3.16.5 || > 0.3.16.5 && < 0.4,+                    time,+                    transformers-base,+                    unix-compat,++  -- the tests shell out to a built darcs binary, so we depend on it to make+  -- sure that it's built. It's not actually required for build, just at runtime,+  -- but there isn't a way to express the latter and it seems harmless.+  build-tool-depends: darcs:darcs++  -- list all unit test modules not exported by libdarcs; otherwise Cabal won't+  -- include them in the tarball+  other-modules:    Darcs.Test.Email+                    Darcs.Test.HashedStorage+                    Darcs.Test.Patch.Check+                    Darcs.Test.Patch.Depends+                    Darcs.Test.Patch.Examples.Set1+                    Darcs.Test.Patch.Examples.Set2Unwitnessed+                    Darcs.Test.Patch.Examples.Unwind+                    Darcs.Test.Patch.WSub+                    Darcs.Test.Patch.Info+                    Darcs.Test.Patch.Properties+                    Darcs.Test.Patch.Properties.V1Set1+                    Darcs.Test.Patch.Properties.V1Set2+                    Darcs.Test.Patch.Properties.Generic+                    Darcs.Test.Patch.Properties.GenericUnwitnessed+                    Darcs.Test.Patch.Properties.Check+                    Darcs.Test.Patch.Properties.RepoPatch+                    Darcs.Test.Patch.Properties.RepoPatchV3+                    Darcs.Test.Patch.Arbitrary.Generic+                    Darcs.Test.Patch.Arbitrary.Named+                    Darcs.Test.Patch.Arbitrary.NamedPrim+                    Darcs.Test.Patch.Arbitrary.PatchTree+                    Darcs.Test.Patch.Arbitrary.PrimFileUUID+                    Darcs.Test.Patch.Arbitrary.PrimV1+                    Darcs.Test.Patch.Arbitrary.RepoPatch+                    Darcs.Test.Patch.Arbitrary.RepoPatchV1+                    Darcs.Test.Patch.Arbitrary.RepoPatchV2+                    Darcs.Test.Patch.Arbitrary.RepoPatchV3+                    Darcs.Test.Patch.Arbitrary.Sealed+                    Darcs.Test.Patch.Arbitrary.Shrink+                    Darcs.Test.Patch.Merge.Checked+                    Darcs.Test.Patch.Rebase+                    Darcs.Test.Patch.RepoModel+                    Darcs.Test.Patch.Selection+                    Darcs.Test.Patch.Utils+                    Darcs.Test.Patch.V1Model+                    Darcs.Test.Patch.FileUUIDModel+                    Darcs.Test.Patch.Types.MergeableSequence+                    Darcs.Test.Patch.Types.Merged+                    Darcs.Test.Patch.Types.Pair+                    Darcs.Test.Patch.Types.Triple+                    Darcs.Test.Patch.Unwind+                    Darcs.Test.Patch.WithState+                    Darcs.Test.Patch+                    Darcs.Test.Misc+                    Darcs.Test.Misc.CommandLine+                    Darcs.Test.Misc.Encoding+                    Darcs.Test.Misc.Graph+                    Darcs.Test.Misc.URL+                    Darcs.Test.Repository.Inventory+                    Darcs.Test.Shell+                    Darcs.Test.TestOnly.Instance+                    Darcs.Test.UI+                    Darcs.Test.UI.Commands.Convert.Export+                    Darcs.Test.UI.Commands.Test+                    Darcs.Test.UI.Commands.Test.Commutable+                    Darcs.Test.UI.Commands.Test.IndexedApply+                    Darcs.Test.UI.Commands.Test.Simple+                    Darcs.Test.Util.TestResult+                    Darcs.Test.Util.QuickCheck+                    Shelly+                    Shelly.Base+                    Shelly.Find++  if flag(warn-as-error)+    ghc-options:    -Werror++  ghc-options:      -Wall -funbox-strict-fields -fwarn-tabs++  if impl(ghc >= 9.4.1)+    ghc-options:    -Wno-gadt-mono-local-binds++  if impl(ghc >= 9.0.1)+    ghc-options:    -Wno-star-is-type++  if flag(threaded)+    ghc-options:    -threaded++  if flag(rts)+    ghc-options:    -rtsopts++  -- see http://bugs.darcs.net/issue1037+  cc-options:       -D_REENTRANT++  default-extensions:+      AllowAmbiguousTypes+      BangPatterns+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveDataTypeable+      DeriveFunctor+      EmptyCase+      EmptyDataDecls+      FlexibleContexts+      FlexibleInstances+      GADTs+      GeneralizedNewtypeDeriving+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      NoImplicitPrelude+      RankNTypes+      RoleAnnotations+      ScopedTypeVariables+      StandaloneDeriving+      TypeApplications+      TypeFamilies+      TypeOperators+      -- this must come last because some of the+      -- other extensions imply MonoLocalBinds+      NoMonoLocalBinds
+ darcs/darcs.hs view
@@ -0,0 +1,92 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module      : Main+-- Copyright   : 2002-2003 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Main ( main ) where++import Darcs.Prelude++import Control.Exception ( handle, ErrorCall )+import System.Exit ( exitWith, ExitCode(..) )+import System.Environment ( getArgs )+import System.IO ( hPutStr, stderr )++import Darcs.UI.RunCommand ( runTheCommand )+import Darcs.UI.Commands.Help ( helpCmd, listAvailableCommands, printVersion,+                             commandControlList )+import Darcs.Util.AtExit ( withAtexit, atexit )+import Darcs.Repository( reportBadSources )+import Darcs.Util.SignalHandler ( withSignalsHandled )++import Darcs.UI.External ( setDarcsEncodings )+import Darcs.Util.Exec ( ExecException(..) )+import Darcs.Util.HTTP ( configureHttpConnectionManager )+import Darcs.Util.Path ( getCurrentDirectory )+import Version ( version, context, weakhash )++execExceptionHandler :: ExecException -> IO a+execExceptionHandler (ExecException cmd args redirects reason) = do+    hPutStr stderr . unlines $+        [ "Failed to execute external command: " ++ unwords (cmd:args)+        , "Lowlevel error: " ++ reason+        , "Redirects: " ++ show redirects+        ]+    exitWith $ ExitFailure 3++errorExceptionHandler :: ErrorCall -> IO a+errorExceptionHandler e = do+    hPutStr stderr . unlines $+        [ "This is a bug! Please report it at http://bugs.darcs.net " +++          "or via email to bugs@darcs.net:"+        , show e+        ]+    exitWith $ ExitFailure 4++main :: IO ()+main = handleErrors . handleExecFail . withSignalsHandled . withAtexit $ do+    atexit reportBadSources+    setDarcsEncodings+    configureHttpConnectionManager+    argv <- getArgs+    here <- getCurrentDirectory+    let runHelpCmd = helpCmd (here, here) [] []+    -- Explicitly handle no-args and special "help" arguments.+    case argv of+        [] -> printVersion >> runHelpCmd+        ["-h"] -> runHelpCmd+        ["--help"] -> runHelpCmd+        ["--commands"] -> listAvailableCommands+        ["-v"] -> putStrLn version+        ["-V"] -> putStrLn version+        ["--version"] -> putStrLn version+        ["--exact-version"] -> printExactVersion+        cmd:args -> runTheCommand commandControlList cmd args+  where+    handleErrors = handle errorExceptionHandler+    handleExecFail = handle execExceptionHandler+    printExactVersion =  do+        putStrLn $ "Weak Hash: " ++ weakhash+        putStrLn context
− doc/darcs.css 
@@ -1,103 +0,0 @@-BODY {-  background: white;-  color: black;-  font-family: arial,sans-serif;-  font-size: 90%;-  margin: 0;-  padding: 1em;-}--#col1, #col2 { float: left; width: 50%; }-#col2 { margin-left: -1px; }-.inner { margin: 0 1em; }--A:link {-  background: transparent;-  color: #494a82;-}--A:visited {-  background: transparent;-  color: #8081b3-}--IMG.thanks-left {-  float: left;-  margin-right: 5px;-  height: 50px;-}--IMG.thanks-right {-  float: right;-  margin-left: 5px;-  height: 50px;-}--BLOCKQUOTE.testimonial {-  font-style: italic;-}--PRE     {-  background: #eeeeee;-  border: 1px solid #888888;-  color: black;-  padding: 1em;-  white-space: pre;-}--H1      {-  color: #494a82;-  font-size: 24px ;-}--H2      {-  color: #494a82;-  font-size: 18px;-}--H3      {-  color: #494a82;-  font-size: 16px;-}--H4      {-  color: #494a82;-  font-size: 14px;-}--/* headers for darcs command options */-.cmd-opt-hdr     {-  color: #494a82;-  font-size: 14px;-  font-weight: bold;-}--/* begin styles for RSS Feed This is the most basic style to use for a list with no bullets */--.rss_title, rss_title a {-    margin: 0px 0;-    padding: 0;-}--.rss_items {-       list-style:none;-       margin:0;-       padding:0;-}--.rss_item  {-/*  font-size: x-small; */-  margin-bottom: 1em;;-}--.rss_item a:link, .rss_item a:visited, .rss_item a:active {--    }--.rss_item a:hover { --    }-    -.rss_date {-    font-size: xx-small;-    }
− doc/src/best_practices.tex 
@@ -1,612 +0,0 @@-% This file (unlike the rest of darcs) is in the public domain.- --\chapter{Best practices}--This chapter is intended to review various scenarios and describe in each-case effective ways of using darcs.  There is no one ``best practice'', and-darcs is a sufficiently low-level tool that there are many high-level ways-one can use it, which can be confusing to new users.--\section{Creating patches}--This section will lay down the concepts around patch creation.-The aim is to develop a way of thinking-that corresponds well to how darcs is behaving---- even in complicated situations.--	In a single darcs repository you can think of two ``versions'' of the source tree.-	They are called the \emph{working} and \emph{pristine} trees.-    \emph{Working} is your normal source tree, with or without darcs alongside.-	The only thing that makes it part of a darcs repository-	is the \verb!_darcs! directory in its root.-    \emph{Pristine} is the recorded state of the source tree.-	The pristine tree is constructed from groups of changes,-        called {\em patches\/} (some other version control systems use the-	term {\em changeset\/} instead of {\em patch\/}).\footnote{If-	you look inside \_darcs you will find files or directories named-	{\tt patches} and {\tt inventories}, which store all the patches-          ever recorded.  If the repository holds a cached pristine tree, it-          is stored in a directory called {\tt pristine.hashed}.}-	Darcs will create and store these patches-	based on the changes you make in \emph{working}.---\subsection{Changes}-	If \emph{working} and \emph{pristine} are the same,-	there are ``no changes'' in the working copy.-	Changes can be introduced (or removed) by editing the files in \emph{working}.-	They can also be caused by darcs commands,-	which can modify \emph{both} \emph{working} and \emph{pristine}.-	It is important to understand for each darcs command-	how it modifies \emph{working}, \emph{pristine} or both of them.--	\verb!whatsnew! (as well as \verb!diff!) can show-	the difference between \emph{working} and \emph{pristine} to you.-	It will be shown as a difference in \emph{working}.-	In advanced cases it need \emph{not} be \emph{working} that has changed;-	it can just as well have been \emph{pristine}, or both.-	The important thing is the difference and what darcs can do with it.--\subsection{Keeping or discarding changes}-    If you have a difference in \emph{working}, you do two things-    with it: \verb!record! it to keep it, or \verb!revert! it to lose the changes.%-		\footnote{%-		Revert can undo precious work in a blink.-		To protect you from great grief,-		the discarded changes are saved temporarily-		so the latest revert can be undone with unrevert.}--	If you have a difference between \emph{working} and \emph{pristine}%-	---for example after editing some files in \emph{working}---%-	\verb!whatsnew! will show some ``unrecorded changes''.-	To save these changes, use \verb!record!.-	It will create a new patch in \emph{pristine} with the same changes,-	so \emph{working} and \emph{pristine} are no longer different.-	To instead undo the changes in \emph{working}, use \verb!revert!.-	It will modify the files in \emph{working} to be the same as in \emph{pristine}-	(where the changes do not exist).---\subsection{Unrecording changes}-    \verb!unrecord! is a command meant to be run only in private-    repositories. Its intended purpose is to allow developers the flexibility-    to undo patches that haven't been distributed yet.--	If you \verb!unrecord! a patch, that patch will be deleted from \emph{pristine}.-	This will cause \emph{working} to be different from \emph{pristine},-	and \verb!whatsnew! to report unrecorded changes.-	The difference will be the same as just before that patch was \verb!record!ed.-	Think about it.-	\verb!record! examines what's different with \emph{working}-	and constructs a patch with the same changes in \emph{pristine}-	so they are no longer different.-	\verb!unrecord! deletes this patch;-	the changes in \emph{pristine} disappear and the difference is back.--	If the recorded changes included an error,-	the resulting flawed patch can be unrecorded.-	When the changes have been fixed,-	they can be recorded again as a new---hopefully flawless---patch.--	If the whole change was wrong it can be discarded from \emph{working} too,-	with \verb!revert!.-	\verb!revert! will update \emph{working} to the state of \emph{pristine},-	in which the changes do no longer exist after the patch was deleted.--	Keep in mind that the patches are your history,-	so deleting them with \verb!unrecord! makes it impossible to track-	what changes you \emph{really} made.-	Redoing the patches is how you ``cover the tracks''.-	On the other hand,-	it can be a very convenient way to manage and organize changes-	while you try them out in your private repository.-	When all is ready for shipping,-	the changes can be reorganized in what seems as useful and impressive patches.-	Use it with care.--	All patches are global,-	so don't \emph{ever} replace an already ``shipped'' patch in this way!-	If an erroneous patch is deleted and replaced with a better one,-	you have to replace it in \emph{all} repositories that have a copy of it.-	This may not be feasible, unless it's all private repositories.-	If other developers have already made patches or tags in their repositories-	that depend on the old patch, things will get complicated.---\subsection{Special patches and pending}--The patches described in the previous sections have mostly been hunks.-A \emph{hunk} is one of darcs' primitive patch types,-and it is used to remove old lines and/or insert new lines.-There are other types of primitive patches,-such as \emph{adddir} and \emph{addfile}-which add new directories and files,-and \emph{replace}-which does a search-and-replace on tokens in files.--Hunks are always calculated in place with a diff algorithm-just before \verb!whatsnew! or \verb!record!.-But other types of primitive patches need to be explicitly created-with a darcs command.-They are kept in \emph{pending}, ie, in the file {\tt\_darcs/patches/pending},-until they are either recorded or reverted.--\emph{Pending} can be thought of as a special extension of \emph{working}.-When you issue, e.g., a darcs \verb!replace! command,-the replace is performed on the files in \emph{working}-and at the same time a replace patch is put in \emph{pending}.-Patches in \emph{pending} describe special changes made in \emph{working}.-The diff algorithm will fictively apply these changes to \emph{pristine}-before it compares it to \emph{working},-so all lines in \emph{working} that are changed by a \verb!replace! command-will also be changed in \emph{pending} and \emph{pristine}-when the hunks are calculated.-That's why no hunks with the replaced lines will be shown by \verb!whatsnew!;-it only shows the replace patch in \emph{pending} responsible for the change.--If a special patch is recorded, it will simply be moved to \emph{pristine}.-If it is instead reverted, it will be deleted from \emph{pending}-and the accompanying change will be removed from \emph{working}.--Note that reverting a patch in pending is \emph{not} the same as-simply removing it from pending.-It actually applies the inverse of the change to \emph{working}.-Most notable is that reverting an addfile patch-will delete the file in \emph{working} (the inverse of adding it).-So if you add the wrong file to darcs by mistake,-\emph{don't} \verb!revert! the addfile.-Instead use \verb!remove!, which cancels out the addfile in pending.---\section{Using patches} % still basics--This section will lay down the concepts around patch distribution and branches.-The aim is to develop a way of thinking-that corresponds well to how darcs is behaving---- even in complicated situations.--A repository is a collection of patches.-Patches have no defined order,-but patches can have dependencies on other patches.-Patches can be added to a repository in any order-as long as all patches depended upon are there.-Patches can be removed from a repository in any order,-as long as no remaining patches depend on them.--Repositories can be cloned to create branches.-Patches created in different branches may conflict.-A conflict is a valid state of a repository.-A conflict makes the working tree ambiguous until the conflict is resolved.---\subsection{Dependencies}--There are two kinds of dependencies.--Implicit dependencies is the far most common kind.-These are calculated automatically by darcs.-If a patch removes a file or a line of code,-it will have to depend on the patch that added that file or line of code.-If a patch adds a line of code,-it will usually have to depend on the patch or patches that added the adjacent lines.--Explicit dependencies can be created if you give the \verb|--ask-deps| option to \verb|darcs record|.-This is good for assuring that logical dependencies hold between patches.-It can also be used to group patches---%-a patch with explicit dependencies doesn't need to change anything---%-and pulling the patch also pulls all patches it was made to depend on.---\subsection{Branches: just normal repositories}--Darcs does not have branches---it doesn't need to.-Any two repositories are ``branches'' in darcs,-but it is not of much use unless they have a large portion of patches in common.-If they are different projects they will have nothing in common,-but darcs may still very well be able to merge them,-although the result probably is nonsense.-Therefore the word ``branch'' isn't a technical term in darcs;-it's just the way we think of one repository in relation to another.--Branches are \emph{very} useful in darcs.-They are in fact \emph{necessary} if you want to do more than only simple work.-When you \verb|get| someone's repository from the Internet,-you are actually creating a branch of it.-But darcs is designed this way, and it has means to make it efficient.-The answer to many questions about how to do a thing with darcs is: ``use a branch''.-It is a simple and elegant solution with great power and flexibility,-which contributes to darcs' uncomplicated user interface.--You create new branches (i.e., clone repositories)-with the \verb|get| and \verb|put| commands.---\subsection{Moving patches around---no versions}--Patches are global, and a copy of a patch either is or is not present in a branch.-This way you can rig a branch almost any way you like,-as long as dependencies are fulfilled---%-darcs \emph{won't} let you break dependencies.-If you suspect a certain feature from some time ago introduced a bug,-you can remove the patch/patches that adds the feature,-and try without it.\footnote{%-darcs even has a special command, {\tt trackdown}-that automatically removes patches-until a specified test no longer fails.}--Patches are added to a repository with \verb|pull|-and removed from the repositories with \verb|obliterate|.-Don't confuse these two commands with \verb|record| and \verb|unrecord|,-which constructs and deconstructs patches.--It is important not to lose patches when (re)moving them around.-\verb|pull| needs a source repository to copy the patch from,-whereas \verb|obliterate| just erases the patch.-Beware that if you obliterate \emph{all} copies of a patch-it is completely lost---forever.-Therefore you should work with branches when you obliterate patches.-The \verb|obliterate| command can wisely be disabled in a dedicated main repository-by adding \verb|obliterate disable| to the repository's defaults file.--For convenience, there is a \verb|push| command.-It works like \verb|pull| but in the other direction.-It also differs from \verb|pull| in an important way:-it starts a second instance of darcs to apply the patch in the target repository,-even if it's on the same computer.-It can cause surprises if you have a ``wrong'' darcs in your PATH.---\subsection{Tags---versions}--While \verb|pull| and \verb|obliterate| can be used to-construct different ``versions'' in a repository,-it is often desirable to name specific configurations of patches-so they can be identified and retrieved easily later.-This is how darcs implements what is usually known as versions.-The command for this is \verb|tag|,-and it records a tag in the current repository.--A tag is just a patch, but it only contains explicit dependencies.-It will depend on all the patches in the current repository.\footnote{%-It will omit patches already depended upon by other patches,-since they will be indirectly depended upon anyway.}-Darcs can recognize if a patch is as a tag;-tags are sometimes treated specially by darcs commands.--While traditional revision control systems tag versions in the time line history,-darcs lets you tag any configuration of patches at any time,-and pass the tags around between branches.--With the option \verb|--tag| to \verb|get| you can easily get-a named version in the repository-as a new branch.---\subsection{Conflicts}--A conflict \emph{happens} when two conflicting patches meet in the same repository.-This is no problem for darcs; it can happily pull together just any patches.-But it is a problem for the files in \emph{working} (and \emph{pristine}).-The conflict can be thought of as-two patches telling darcs different things about what a file should look like.--Darcs escapes this problem-by ignoring those parts of the patches that conflict.-They are ignored in \emph{both} patches.-If patch~A changes the line ``FIXME'' to ``FIXED'',-and patch~B changes the same line to ``DONE'',-the two patches together will produce the line ``FIXME''.-Darcs doesn't care which one you pulled into the repository first,-you still get the same result when the conflicting patches meet.-All other changes made by A and B are performed as normal.--Darcs can mark a conflict for you in \emph{working}.-This is done with \verb|mark-conflicts|.-Conflicts are marked such that both conflicting changes-are inserted with special delimiter lines around them.-Then you can merge the two changes by hand,-and remove the delimiters.--When you pull patches,-darcs automatically performs a \verb|mark-conflicts| for you if a conflict happens.-You can remove the markup with \verb|revert|,-Remember that the result will be the lines from-the previous version common to both conflicting patches.-The conflict marking can be redone again with \verb|mark-conflicts|.--A special case is when a pulled patch conflicts with unrecorded changes in the repository.-The conflict will be automatically marked as usual,-but since the markup is \emph{also} an unrecorded change,-it will get mixed in with your unrecorded changes.-There is no guarantee you can revert \emph{only} the markup after this,-and \verb|mark-conflicts| will not be able to redo this markup later if you remove it.-It is good practice to record important changes before pulling.--\verb|mark-conflicts| can't mark complicated conflicts.-In that case you'll have to use \verb|darcs diff| and other commands-to understand what the conflict is all about.-If for example two conflicting patches create the same file,-\verb|mark-conflicts| will pick just one of them,-and no delimiters are inserted.-So watch out if darcs tells you about a conflict.--\verb|mark-conflicts| can also be used to check for unresolved conflicts.-If there are none, darcs replies ``No conflicts to mark.''.-While \verb|pull| reports when a conflict happens,-\verb|obliterate| and \verb|get| don't.---\subsection{Resolving conflicts}--A conflict is resolved-(not marked, as with the command \verb|mark-conflicts|)-as soon as some new patch depends on the conflicting patches.-This will usually be the resolve patch you record after manually putting together the pieces-from the conflict markup produced by \verb|mark-conflicts| (or \verb|pull|).-But it can just as well be a tag.-So don't forget to fix conflicts before you accidentally ``resolve'' them by recording other patches.--If the conflict is with one of your not-yet-published patches,-you may choose to amend that patch rather than creating a resolve patch.--If you want to back out and wait with the conflict,-you can \verb|obliterate| the conflicting patch you just pulled.-Before you can do that you have to \verb|revert| the conflict markups-that \verb|pull| inserted when the conflict happened.--\section{Global and per-repository caches}--Darcs uses a global cache, as this is one of its biggest performance-enhancing tools.  The global-cache acts as a giant patch pool where darcs first looks for a patch when-grabbing new patches. This saves time by not downloading the same patch-twice from a remote server. It also saves space by storing the patch only-once, if you ensure your cache and your repositories are on the same-hardlink-supporting filesystem. --Darcs now enables a global patch cache under your home directory by default.-Older darcs 2.x versions required this manual step:--\begin{verbatim}-$ mkdir -p $HOME/.darcs/cache-$ echo cache:$HOME/.darcs/cache > $HOME/.darcs/sources-\end{verbatim}--On MS Windows~\ref{ms_win}, using \verb|cmd.exe| (Command Prompt under Accessories):--\begin{verbatim}-> md "%APPDATA%\darcs\cache" (notice double quotes!)-> echo cache:%APPDATA%\darcs\cache > "%APPDATA%\darcs\sources"-\end{verbatim}--Individual repositories also contain cache location information.-Each time a repository is got, its location is added as an-entry in \verb!_darcs/prefs/sources!.  If one of these repositories were to-become totally or temporarily unreachable, it can cause darcs to hang-for a long time trying to reach it.  Fortunately darcs has a mechanism-which helps us to deal with that problem: if an unreachable entry is-discovered, darcs stops using it for the rest of the session and then-notifies the user to take further action. It will display a message-like the following:-\begin{verbatim}> I could not reach the following repository:-> http://darcs.net/-> If you're not using it, you should probably delete-> the corresponding entry from _darcs/prefs/sources.-\end{verbatim}--There are some other advanced things you can do in \verb!_darcs/prefs/sources!,-such as create read-only caches and even set a-primary source repository above any used in a \verb|darcs get| or-\verb|darcs pull| command.--\section{Distributed development with one primary developer}-\label{darcs-development-practices}--This is how a project with many contributors, but every contribution is reviewed-and manually applied by the project leader, can be run.-For this sort of a situation, \verb|darcs send| is ideal, since the barrier for-contributions is very low, which helps encourage contributors.--One could simply set the \verb!_darcs/prefs/email! value to the project-mailing list, but you may also want to use darcs send to send your changes to the main-server, so instead the email address could be set to something like-``\verb!Darcs Repo <maintainer@host.com>!''.  Then the-\verb-.procmailrc--file on the server should have the following rule:-\begin{verbatim}-:0-* ^TODarcs Repo-|(umask 022; darcs apply --reply project-mailing-list@host.com \-             --repodir /path/to/repo --verify /path/to/allowed_keys)-\end{verbatim}-This causes darcs apply to be run on any email sent to ``Darcs Repo''.-\verb'apply' actually applies them only if they are signed by an-authorized key.--The central darcs repository contains the following values in its-\verb!_darcs/prefs/defaults!:-\begin{verbatim}-apply test-apply verbose-apply happy-forwarding-\end{verbatim}-The first line tells apply to always run the test suite.  The test suite can-be a reason to use send rather than push, since it allows to-easily continue working (or put one's computer to sleep) while the tests are-being run on the main server.  The second line is just there to improve the-email response that the maintainer gets when a patch has either been applied or failed-the tests.  The third line makes darcs not complain about unsigned patches,-but just to forward them to \verb!darcs-devel!.--On one's development computer, one can have in their \verb!.muttrc! the following-alias, which allows to easily apply patches received via email-directly to one's darcs working directory:-\begin{verbatim}-macro pager A "<pipe-entry>(umask 022; darcs apply --no-test -v \-        --repodir ~/darcs)"-\end{verbatim}--\section{Sending signed patches by email}--Darcs send can be configured to send a cryptographically signed patch by email.-You can then set up your mail system to have darcs verify that patches were-signed by an authorized user and apply them when a patch is received by-email.  The results of the apply can be returned to the user by email.-Unsigned patches (or patches signed by unauthorized users) will be-forwarded to the repository owner (or whoever you configure them to be-forwarded to\ldots).--This method is especially nice when combined with the \verb!--test! option-of darcs apply, since it allows you to run the test suite (assuming you-have one) and reject patches that fail---and it's all done on the server,-so you can happily go on working on your development machine without-slowdown while the server runs the tests.--Setting up darcs to run automatically in response to email is by far the-most complicated way to get patches from one repository to another\ldots\ so it'll-take a few sections to explain how to go about it.--\paragraph{Security considerations}--When you set up darcs to run apply on signed patches, you should assume-that a user with write access can write to any file or directory that is-writable by the user under which the apply process runs.  Unless you-specify the \verb!--no-test! flag to darcs apply (and this is \emph{not}-the default), you are also allowing anyone with write access to that-repository to run arbitrary code on your machine (since they can run a test-suite---which they can modify however they like).  This is quite a-potential security hole.--For these reasons, if you don't implicitly trust your users, it is-recommended that you create a user for each repository to limit the damage-an attacker can do with access to your repository.  When considering who to-trust, keep in mind that a security breach on any developer's machine could-give an attacker access to their private key and passphrase, and thus to-your repository.--\paragraph{Installing necessary programs}--You also must install the following programs: gnupg, a mailer configured to-receive mail (e.g.\ exim, sendmail or postfix), and a web server (usually-apache).--\paragraph{Granting access to a repository}--You create your gpg key by running (as your normal user):-\begin{verbatim}-$ gpg --gen-key-\end{verbatim}-You will be prompted for your name and email address, among other options.-%%To add your public key to the allowed keys keyring.-Of course, you can-skip this step if you already have a gpg key you wish to use.--You now need to export the public key so we can tell the patcher about it.-You can do this with the following command (again as your normal user):-\begin{verbatim}-$ gpg --export "email@address" > /tmp/exported_key-\end{verbatim}-And now we can add your key to the \verb!allowed_keys!:-\begin{verbatim}-(as root)> gpg --keyring /var/lib/darcs/repos/myproject/allowed_keys \-               --no-default-keyring --import /tmp/exported_key-\end{verbatim}-You can repeat this process any number of times to authorize multiple users-to send patches to the repository.--You should now be able to send a patch to the repository by running as your-normal user, in a working copy of the repository:-\begin{verbatim}-$ darcs send --sign http://your.computer/repos/myproject-\end{verbatim}-You may want to add ``send sign'' to the file \verb!_darcs/prefs/defaults!-so that you won't need to type \verb!--sign! every time you want to-send\ldots--If your gpg key is protected by a passphrase, then executing \verb!send!-with the \verb!--sign! option might give you the following error:-\begin{verbatim}-darcs failed:  Error running external program 'gpg'-\end{verbatim}-The most likely cause of this error is that you have a misconfigured-gpg that tries to automatically use a non-existent gpg-agent-program. GnuPG will still work without gpg-agent when you try to sign-or encrypt your data with a passphrase protected key. However, it will-exit with an error code 2 (\verb!ENOENT!) causing \verb!darcs! to-fail. To fix this, you will need to edit your \verb!~/.gnupg/gpg.conf!-file and comment out or remove the line that says:-\begin{verbatim}-use-agent-\end{verbatim}-If after commenting out or removing the \verb!use-agent! line in your-gpg configuration file you still get the same error, then you probably-have a modified GnuPG with use-agent as a hard-coded option. In that-case, you should change \verb!use-agent! to \verb!no-use-agent! to-disable it explicitly.--\paragraph{Setting up a sendable repository using procmail}-If you don't have root access on your machine, or perhaps simply don't want-to bother creating a separate user, you can set up a darcs repository using-procmail to filter your mail.  Let us assume that you already use procmail-to filter your email.  If not, you will need to read up on it, or perhaps-should use a different method for routing the email to darcs.--To begin with, you must configure your repository so that a darcs send to-your repository will know where to send the email.  Do this by creating a-file in \verb!/path/to/your/repo/_darcs/prefs! called \verb!email!-containing your email address.  As a trick (to be explained below), we will-create the email address with ``darcs repo'' as your name, in an email-address of the form ``User Name $<$user@host.com$>$.''-\begin{verbatim}-$ echo 'my darcs repo <user@host.com>' \-      > /path/to/your/repo/_darcs/prefs/email-\end{verbatim}--The next step is to set up a gnupg keyring containing the public keys of-people authorized to send to your repository.  Here is a second way of-going about this (see above for the first).  This time let us assume you-want to give someone write access to your repository.  You can do this by:-\begin{verbatim}-gpg --no-default-keyring \-    --keyring /path/to/the/allowed_keys --recv-keys FFFFFFFF-\end{verbatim}-With ``FFFFFFFF'' being the ID of the gpg key of the person to be-authorised, if this person has uploaded their key to the gpg keyservers.-Actually, this also requires that-you have configured gpg to access a valid keyserver.  You can, of course,-repeat this command for all keys you want to allow access to.--Finally, we add a few lines to your \verb!.procmailrc!:-\begin{verbatim}-:0-* ^TOmy darcs repo-|(umask 022; darcs apply --reply user@host.com \-    --repodir /path/to/your/repo --verify /path/to/the/allowed_keys)-\end{verbatim}-The purpose for the ``my darcs repo'' trick is partially to make it easier-to recognize patches sent to the repository, but is even more crucial to-avoid nasty bounce loops by making the \verb!--reply! option have an email-address that won't go back to the repository.  This means that unsigned-patches that are sent to your repository will be forwarded to your ordinary-email.--Like most mail-processing programs, Procmail by default sets a tight umask.-However, this will prevent the repository from remaining world-readable;-thus, the ``umask 022'' is required to relax the umask.-(Alternatively, you could set Procmail's global \verb!UMASK! variable-to a more suitable value.)--\paragraph{Checking if your e-mail patch was applied}--After sending a patch with \verb!darcs send!, you may not receive any feedback,-even if the patch is applied. You can confirm whether or not your patch was applied-to the remote repository by pointing \verb!darcs changes! at a remote repository:-\begin{verbatim}-darcs changes --last=10 --repo=http://darcs.net/-\end{verbatim}--That shows you the last 10 changes in the remote repository. You can adjust the options given-to \verb!changes! if a more advanced query is needed.--
− doc/src/building_darcs.tex 
@@ -1,33 +0,0 @@-\chapter{Building darcs}-If your distribution provides a pre-built binary package of a recent-Darcs release, you are strongly encouraged to use that rather than-building Darcs yourself.--If you have (or can install) the-\htmladdnormallinkfoot{Haskell Platform}{http://haskell.org/platform/}-this is the next best option, as this will resolve build dependencies-automatically.  To download, compile and install Darcs and its-dependencies via \texttt{cabal-install}, the build tool provided by the-Haskell Platform, simply run-\begin{verbatim}-cabal update-cabal install darcs-\end{verbatim}--If you cannot install the Haskell Platform or \texttt{cabal-install}, you need to run-\begin{verbatim}-ghc --make Setup-./Setup configure-./Setup build-./Setup install-\end{verbatim}--This will require the following build dependencies:-\begin{itemize}-\item GHC 6.10 or higher; and-\item Cabal 1.6 or higher.-\end{itemize}--Additional build dependencies are declared in the \texttt{darcs.cabal}-file, and \texttt{./Setup configure} will tell you if any required-build dependencies aren't found.
− doc/src/configuring_darcs.tex 
@@ -1,472 +0,0 @@-%  Copyright (C) 2004 David Roundy-%-%  This program is free software; you can redistribute it and/or modify-%  it under the terms of the GNU General Public License as published by-%  the Free Software Foundation; either version 2, or (at your option)-%  any later version.-%-%  This program is distributed in the hope that it will be useful,-%  but WITHOUT ANY WARRANTY; without even the implied warranty of-%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-%  GNU General Public License for more details.-%-%  You should have received a copy of the GNU General Public License-%  along with this program; if not, write to the Free Software Foundation,-%  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.--\chapter{Configuring darcs}\label{configuring}--There are several ways you can adjust darcs' behavior to suit your needs.-The first is to edit files in the \verb!_darcs/prefs/! directory of a-repository.  Such configuration only applies when working with that-repository.  To configure darcs on a per-user rather than per-repository-basis (but with essentially the same methods), you can edit (or create)-files in the \verb!~/.darcs/! directory.-Finally, the behavior of some darcs commands can be modified by setting-appropriate environment variables.--\paragraph{Microsoft Windows}\label{ms_win}--The global darcs directory is \verb!%APPDATA%\darcs\!.  This typically expands to-\texttt{C:\textbackslash{}Documents And Settings\textbackslash{}\emph{user}\textbackslash{}Application Data\textbackslash{}darcs\textbackslash{}}.-This folder contains the cache, as well as all the per-user-settings files: preferences, boring etc... These will became the new defaults-that can be overridden on per-repository basis.--\section{prefs}--The \verb!_darcs! directory contains a \verb!prefs!  directory.  This-directory exists simply to hold user configuration settings specific to-this repository.  The contents of this directory are intended to be-modifiable by the user, although in some cases a mistake in such a-modification may cause darcs to behave strangely.--\paragraph{defaults}\label{defaults}--Default values for darcs commands can be configured on a per-repository-basis by editing (and possibly creating) the \verb!_darcs/prefs/defaults!-file.  Each line of this file has the following form:-\begin{verbatim}-COMMAND FLAG VALUE-\end{verbatim}-where \verb!COMMAND! is either the name of the command to which the default-applies, or \verb!ALL! to indicate that the default applies to all commands-accepting that flag.  The \verb!FLAG! term is the name of the long argument-option without the ``\verb!--!'', i.e.\ \verb!verbose! rather than-\verb!--verbose!.  Finally, the \verb!VALUE! option can be omitted if the-flag is one such as \verb!verbose! that doesn't involve a value.-If the value has spaces in it, use single quotes, not double quotes, to surround it.-Each line only takes one flag.  To set multiple defaults for the same-command (or for \verb!ALL! commands), use multiple lines.--Note that the use of \verb|ALL| easily can have unpredicted consequences,-especially if commands in newer versions of darcs accepts flags that they-didn't in previous versions. A command like \verb|obliterate| could be-devastating with the ``wrong'' flags (for example --all). Only use safe-flags with \verb|ALL|.--\begin{tabular}{ll}-{\tt \verb!~/.darcs/defaults!} & provides defaults for this user account-                                 (for MS Windows, see ~\ref{ms_win}) \\-{\tt \verb!repo/_darcs/prefs/defaults!} & provides defaults for one project,\\-  & overrules changes per user \\-\end{tabular}--For example, if your system clock is bizarre, you could instruct darcs to-always ignore the file modification times by adding the following line to-your \verb!_darcs/prefs/defaults! file.  (Note that this would have to be-done for each repository!)-\begin{verbatim}-ALL ignore-times-\end{verbatim}--If you never want to run a test when recording to a particular repository-(but still want to do so when running-\verb'check' on that repository), and like to name-all your patches ``Stupid patch'', you could use the following:-\begin{verbatim}-record no-test-record patch-name Stupid patch-\end{verbatim}--If you would like a command to be run every time patches are recorded-in a particular repository (for example if you have one central-repository, that all developers contribute to), then you can set apply-to always run a command when apply is successful.  For example, if you-need to make sure that the files in the repository have the correct-access rights you might use the following.  There are two things-to note about using darcs this way:-\begin{itemize}-\item Without the second line you will get errors, because the sub-      process that runs apply cannot prompt interactively.-\item Whatever script is run by the post apply command should not be-      added to the repository with \verb!darcs add!; doing so would-      allow people to modify that file and then run arbitrary scripts on-      your main repository, possibly damaging or violating security.-\end{itemize}-\begin{verbatim}-apply posthook chmod -R a+r *-apply run-posthook-\end{verbatim}--Similarly, if you need a command to run automatically before darcs-performs an action you can use a prehook.  Using prehooks it could be-possible to canonicalize line endings before recording patches.--There are some options which are meant specifically for use in-\verb!_darcs/prefs/defaults!. One of them is \verb!--disable!. As the name-suggests, this option will disable every command that got it as argument. So,-if you are afraid that you could damage your repositories by inadvertent use of-a command like amend-record, add the following line to-\verb!_darcs/prefs/defaults!:-\begin{verbatim}-amend-record disable-\end{verbatim}--Also, a global preferences file can be created with the name-\verb!.darcs/defaults! in your home directory, on MS Windows~\ref{ms_win}.-Options present there will be added to the repository-specific preferences.-If they conflict with repository-specific options, the repository-specific-ones will take precedence.--\paragraph{repos}-The \verb!_darcs/prefs/repos! file contains a list of repositories you have-pulled from or pushed to, and is used for autocompletion of pull and push-commands in bash.  Feel free to delete any lines from this list that might-get in there, or to delete the file as a whole.--\paragraph{author}\label{author_prefs}-The \verb!_darcs/prefs/author! file contains the email address (or name) to-be used as the author when patches are recorded in this repository,-e.g.\ \verb!David Roundy <droundy@abridgegame.org>!.  This-file overrides the contents of the environment variables-\verb!$DARCS_EMAIL! and \verb!$EMAIL!.--\paragraph{boring}\label{boring}-The \verb!_darcs/prefs/boring! file may contain a list of regular-expressions describing files, such as object files, that you do not expect-to add to your project.  As an example, you could have:-\begin{verbatim}-\.hi$-\.o$-^\.[^/]-^_-~$-(^|/)CVS($|/)-\end{verbatim}-A newly created repository has a longer boring file that-includes many common source control, backup, temporary, and compiled files.--You may want to have the boring file under version-control.  To do this you can use darcs setpref to set the value-``boringfile'' to the name of your desired boring file-(e.g.\ \verb-darcs setpref boringfile .boring-, where \verb-.boring--is the repository path of a file-that has been-darcs added to your repository).  The boringfile preference overrides-\verb!_darcs/prefs/boring!, so be sure to copy that file to the boringfile.--You can also set up a ``boring'' regexps-file in your home directory, named \verb!~/.darcs/boring!,-(see \ref{ms_win} on MS Windows), which will be-used with all of your darcs repositories.--Any file not already managed by darcs and whose repository path (such-as \verb!manual/index.html!) matches any of-the boring regular expressions is considered boring.  The boring file is-used to filter the files provided to darcs add, to allow you to use a-simple \verb-darcs add newdir newdir/-\verb-*- % cabal haddock barfs on adjacent / *-without accidentally adding a bunch of-object files.  It is also used when the \verb!--look-for-adds! flag is-given to whatsnew or record.-Note that once a file has been added to darcs, it is not considered-boring, even if it matches the boring file filter.---\paragraph{binaries}-The \verb!_darcs/prefs/binaries! file may contain a list of regular-expressions describing files that should be treated as binary files rather-than text files. Darcs automatically treats files containing-\verb!^Z\! or \verb!'\0'! within the first 4096 bytes as being binary files.-You probably will want to have the binaries file under-version control.  To do this you can use darcs setpref to set the value-``binariesfile'' to the name of your desired binaries file-(e.g.\ \verb'darcs setpref binariesfile ./.binaries', where-\verb'.binaries' is a file that has been-darcs added to your repository).  As with the boring file, you can also set-up a \verb!~/.darcs/binaries! file if you like-(see \ref{ms_win} on MS Windows).--\paragraph{email}-The \verb!_darcs/prefs/email! file is used to provide the e-mail address for your-repository that others will use when they \verb!darcs send! a patch back to you.-The contents of the file should simply be an e-mail address.---\paragraph{sources}-The \verb!_darcs/prefs/sources! file is used to indicate alternative-locations from which to download patches when using a ``hashed''-repository.  This file contains lines such as:-\begin{verbatim}-cache:/home/droundy/.darcs/cache-readonly:/home/otheruser/.darcs/cache-repo:http://darcs.net-\end{verbatim}-This would indicate that darcs should first look in-\verb!/home/droundy/.darcs/cache! for patches that might be missing, and if-the patch isn't there, it should save a copy there for future use.  In that-case, darcs will look in \verb!/home/otheruser/.darcs/cache! to see if that-user might have downloaded a copy, but won't try to save a copy there, of-course.  Finally, it will look in \verb!http://darcs.net!.  Note that the-\verb!sources! file can also exist in \verb!~/.darcs/!.  Also note that the-sources mentioned in your \verb!sources! file will be tried \emph{before}-the repository you are pulling from.  This can be useful in avoiding-downloading patches multiple times when you pull from a remote repository-to more than one local repository.--A global cache is enabled by default in your home directory.  The cache-allows darcs to avoid re-downloading patches (for example, when doing a-second darcs get of the same repository), and also allows darcs to use hard-links to reduce disk usage.--Note that the cache directory should reside on the same filesystem as your-repositories, so you may need to vary this.  You can also use multiple-cache directories on different filesystems, if you have several filesystems-on which you use darcs.--\paragraph{motd}\label{motd}-The \verb!_darcs/prefs/motd! file may contain a ``message of the day''-which will be displayed to users who get or pull from the repository without the-\verb!--quiet! option.--\section{Environment variables}--There are a few environment variables whose contents affect darcs'-behavior.  Here is a quick list of all the variables and their-documentation in the rest of the manual:--\begin{tabular}{|l|r|}-\hline-\textbf{Variable} & \textbf{Section} \\-\hline-DARCS\_EDITOR, EDITOR, VISUAL & \ref{env:DARCS_EDITOR} \\-DARCS\_PAGER, PAGER &  \ref{env:DARCS_PAGER} \\-HOME & \ref{env:HOME} \\-TERM & \ref{env:TERM} \\-\hline-DARCS\_EMAIL, EMAIL  & \ref{env:DARCS_EMAIL} \\-\hline-DARCS\_APPLY\_FOO & \ref{env:DARCS_X_FOO} \\-DARCS\_GET\_FOO & \ref{env:DARCS_X_FOO} \\-DARCS\_MGET\_FOO & \ref{env:DARCS_X_FOO} \\-DARCS\_MGETMAX & \ref{env:DARCS_MGETMAX} \\-DARCS\_PROXYUSERPWD & \ref{env:DARCS_PROXYUSERPWD} \\-DARCS\_CONNECTION\_TIMEOUT & \ref{env:DARCS_CONNECTION_TIMEOUT}\\-DARCS\_SSH & \ref{env:DARCS_SSH} \\-DARCS\_SCP & \ref{env:DARCS_SCP} \\-DARCS\_SFTP & \ref{env:DARCS_SFTP} \\-SSH\_PORT & \ref{env:SSH_PORT} \\-\hline-DARCS\_ALTERNATIVE\_COLOR & \ref{env:DARCS_ALWAYS_COLOR}\\-DARCS\_ALWAYS\_COLOR & \ref{env:DARCS_ALWAYS_COLOR}\\-DARCS\_DO\_COLOR\_LINES & \ref{env:DARCS_DO_COLOR_LINES}\\-DARCS\_DONT\_COLOR   & \ref{env:DARCS_ALWAYS_COLOR} \\-DARCS\_DONT\_ESCAPE\_TRAILING\_CR     & \ref{env:DARCS_DONT_ESCAPE_white}\\-DARCS\_DONT\_ESCAPE\_TRAILING\_SPACES & \ref{env:DARCS_DONT_ESCAPE_white} \\-DARCS\_DONT\_ESCAPE\_8BIT & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-DARCS\_DONT\_ESCAPE\_ANYTHING & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-DARCS\_DONT\_ESCAPE\_ISPRINT & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-DARCS\_ESCAPE\_EXTRA & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-DARCS\_DONT\_ESCAPE\_EXTRA & \ref{env:DARCS_DONT_ESCAPE_nonascii}\\-\hline-\end{tabular}--\section{General-purpose variables}--\darcsEnv{DARCS_EDITOR}-\darcsEnv{DARCS_PAGER}-\darcsEnv{DARCS_TMPDIR}-\darcsEnv{DARCS_KEEP_TMPDIR}-\darcsEnv{HOME}--\section{Remote repositories}-\paragraph{DARCS\_CONNECTION\_TIMEOUT}-\label{env:DARCS_CONNECTION_TIMEOUT}-Set the maximum time in seconds that darcs allows and connection to-take. If the variable is not specified the default are 30 seconds. This-option only works with curl.-\darcsEnv{DARCS_SSH}-\darcsEnv{DARCS_SCP}-\darcsEnv{SSH_PORT}-\darcsEnv{HTTP_PROXY}-\darcsEnv{DARCS_PROXYUSERPWD}--\paragraph{DARCS\_GET\_FOO, DARCS\_MGET\_FOO and DARCS\_APPLY\_FOO}-\label{env:DARCS_X_FOO}-When trying to access a repository with a URL beginning foo://,-darcs will invoke the program specified by the DARCS\_GET\_FOO-environment variable (if defined) to download each file, and the-command specified by the DARCS\_APPLY\_FOO environment variable (if-defined) when pushing to a foo:// URL.  --This method overrides all other ways of getting \verb!foo://xxx! URLs.--Note that each command should be constructed so that it sends the downloaded-content to STDOUT, and the next argument to it should be the URL\@.  Here are some-examples that should work for DARCS\_GET\_HTTP:--\begin{verbatim}-fetch -q -o -  -curl -s -f-lynx -source -wget -q -O --\end{verbatim}--Apart from such toy examples, it is likely that you will need to-manipulate the argument before passing it to the actual fetcher-program.  For example, consider the problem of getting read access to-a repository on a CIFS (SMB) share without mount privileges:--\begin{verbatim}-export DARCS_GET_SMB="smbclient -c get"-darcs get smb://fs/twb/Desktop/hello-world-\end{verbatim}--The above command will not work for several reasons.  Firstly, Darcs-will pass it an argument beginning with `smb:', which smbclient does-not understand.  Secondly, the host and share `//fs/twb' must be-presented as a separate argument to the path `Desktop/hello-world'.-Thirdly, smbclient requires that `get' and the path be a single-argument (including a space), rather than two separate arguments.-Finally, smbclient's `get' command writes the file to disk, while-Darcs expects it to be printed to standard output.--In principle, we could get around such problems by making the variable-contain a shell script, e.g.--\begin{verbatim}-export DARCS_GET_SMB='sh -c "...; smbclient $x -c \"get $y\""'-\end{verbatim}--Unfortunately, Darcs splits the command on whitespace and does not-understand that quotation or escaping, so there is no way to make-Darcs pass the text after `-c' to sh as a single argument.  Therefore,-we instead need to put such one-liners in separate, executable scripts.--Continuing our smbclient example, we create an executable script-\verb|~/.darcs/libexec/get_smb| with the following contents:--\begin{verbatim}-#!/bin/bash -e-IFS=/ read host share file <<<"${1#smb://}"-smbclient //$host/$share -c "get $file -"-\end{verbatim}--And at last we can say--\begin{verbatim}-export DARCS_GET_SMB=~/.darcs/libexec/get_smb-darcs get smb://fs/twb/Desktop/hello-world-\end{verbatim}---If set, DARCS\_MGET\_FOO-will be used to fetch many files from a single repository simultaneously.-Replace FOO and foo as appropriate to handle other URL schemes.-These commands are \emph{not} interpreted by a shell, so you cannot-use shell metacharacters, and the first word in the command must-be the name of an executable located in your path. The GET command-will be called with a URL for each file.  The MGET command will be-invoked with a number of URLs and is expected to download the files-to the current directory, preserving the file name but not the path.-The APPLY command will be called with a darcs patchfile piped into-its standard input. Example:--\begin{verbatim}-wget -q -\end{verbatim}--\paragraph{DARCS\_MGETMAX}-\label{env:DARCS_MGETMAX}-When invoking a DARCS\_MGET\_FOO command, darcs will limit the-number of URLs presented to the command to the value of this variable,-if set, or 200.--These commands are \emph{not} interpreted by a shell, so you cannot use shell-meta-characters.--\section{Highlighted output}-\label{env:DARCS_ALWAYS_COLOR}-\label{env:DARCS_DO_COLOR_LINES}-\label{env:DARCS_DONT_ESCAPE_white}--If the terminal understands ANSI color escape sequences,-darcs will highlight certain keywords and delimiters when printing patches.-This can be turned off by setting the environment variable DARCS\_DONT\_COLOR to 1.-If you use a pager that happens to understand ANSI colors, like \verb!less -R!,-darcs can be forced always to highlight the output-by setting DARCS\_ALWAYS\_COLOR to 1.-If you can't see colors you can set DARCS\_ALTERNATIVE\_COLOR to 1,-and darcs will use ANSI codes for bold and reverse video instead of colors.-In addition, there is an extra-colorful mode, which is not enabled by-default, which can be activated with DARCS\_DO\_COLOR\_LINES.--By default darcs will escape (by highlighting if possible) any kind of spaces at the end of lines-when showing patch contents.-If you don't want this you can turn it off by setting-DARCS\_DONT\_ESCAPE\_TRAILING\_SPACES to 1.-A special case exists for only carriage returns:-DARCS\_DONT\_ESCAPE\_TRAILING\_CR.---\section{Character escaping and non-ASCII character encodings}-\label{env:DARCS_DONT_ESCAPE_nonascii}--Darcs needs to escape certain characters when printing patch contents to a terminal.-Characters like \emph{backspace} can otherwise hide patch content from the user,-and other character sequences can even in some cases redirect commands to the shell-if the terminal allows it.--By default darcs will only allow printable 7-bit ASCII characters (including space),-and the two control characters \emph{tab} and \emph{newline}.-(See the last paragraph in this section for a way to tailor this behavior.)-All other octets are printed in quoted form (as \verb!^<control letter>! or-\verb!\!\verb!<hex code>!).--Darcs has some limited support for locales.-If the system's locale is a single-byte character encoding,-like the Latin encodings,-you can set the environment variable DARCS\_DONT\_ESCAPE\_ISPRINT to 1-and darcs will display all the printables in the current system locale-instead of just the ASCII ones.-NOTE: This curently does not work on some architectures if darcs is-compiled with GHC~6.4 or later. Some non-ASCII control characters might be printed-and can possibly spoof the terminal.--For multi-byte character encodings things are less smooth.-UTF-8 will work if you set DARCS\_DONT\_ESCAPE\_8BIT to 1,-but non-printables outside the 7-bit ASCII range are no longer escaped.-E.g., the extra control characters from Latin-1-might leave your terminal at the mercy of the patch contents.-Space characters outside the 7-bit ASCII range are no longer recognized-and will not be properly escaped at line endings.--As a last resort you can set DARCS\_DONT\_ESCAPE\_ANYTHING to 1.-Then everything that doesn't flip code sets should work,-and so will all the bells and whistles in your terminal.-This environment variable can also be handy-if you pipe the output to a pager or external filter-that knows better than darcs how to handle your encoding.-Note that \emph{all} escaping,-including the special escaping of any line ending spaces,-will be turned off by this setting.--There are two environment variables you can set-to explicitly tell darcs to not escape or escape octets.-They are-DARCS\_DONT\_ESCAPE\_EXTRA and DARCS\_ESCAPE\_EXTRA.-Their values should be strings consisting of the verbatim octets in question.-The do-escapes take precedence over the dont-escapes.-Space characters are still escaped at line endings though.-The special environment variable DARCS\_DONT\_ESCAPE\_TRAILING\_CR-turns off escaping of carriage return last on the line (DOS style).
− doc/src/darcs.tex 
@@ -1,1538 +0,0 @@-%  Copyright (C) 2002-2003 David Roundy-%-%  This program is free software; you can redistribute it and/or modify-%  it under the terms of the GNU General Public License as published by-%  the Free Software Foundation; either version 2, or (at your option)-%  any later version.-%-%  This program is distributed in the hope that it will be useful,-%  but WITHOUT ANY WARRANTY; without even the implied warranty of-%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-%  GNU General Public License for more details.-%-%  You should have received a copy of the GNU General Public License-%  along with this program; see the file COPYING.  If not, write to-%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,-%  Boston, MA 02110-1301, USA.--\documentclass[oneside]{book}-%\usepackage{color}--\usepackage{fullpage}-\usepackage{verbatim}-\usepackage{html}-\usepackage{fancyvrb}-\newenvironment{code}{\comment}{\endcomment}-% \newenvironment{code}{\color{blue}\verbatim}{\endverbatim}--\begin{document}---% Definition of title page:-\title{Darcs User Manual}-\date{-\darcsVersion-} % icky newline before closing brace is to appease preproc.hs.-\author{David Roundy}--\maketitle--\tableofcontents--\chapter{Introduction}--This manual provides a stable documentation for using darcs.-To find more up-to-date and complementary information, please consult the-\htmladdnormallinkfoot{darcs wiki}{http://wiki.darcs.net}.--Darcs is a revision control system, along the lines of Subversion, Git or-Mercurial.  That means that it keeps track of various revisions and branches of your-project, allows for changes to propagate from one branch to another. Darcs has two-particularly distinctive features which differ from other revision control-systems:--\paragraph{Every source tree a branch}-The primary simplifying notion of darcs is that \emph{every} copy of your-source code is a full repository. This is dramatically different from Subversion,-in which the normal usage is for there to be one central repository from-which source code will be checked out.-This has several advantages, since you can harness the full-power of darcs in any scratch copy of your code, without committing your-possibly destabilizing changes to a central repository.--\paragraph{Darcs keeps track of changes rather than versions}--In the world of darcs, the source tree is \emph{not} the fundamental-object, but rather the patch is the fundamental object.  Rather than a-patch being defined in terms of the difference between two trees, a tree is-defined as the result of applying a given set of patches to an empty tree.-Moreover, these patches may be reordered without changing the tree.-This makes many operations, like cherry-picking or merging, much more natural.--\input{features.tex}--\chapter{Getting started}--This chapter will lead you through an example use of darcs, which hopefully-will allow you to get started using darcs with your project.--\section{Creating your repository}--Creating your repository in the first place just involves telling darcs to-create the special directory (called {\tt \_darcs}) in your project tree,-which will hold the revision information.  This is done by simply calling-from the root directory of your project:-\begin{verbatim}-$ cd my_project/-$ darcs initialize-\end{verbatim}-This creates the \verb|_darcs| directory and populates it with whatever-files and directories are needed to describe an empty project.  You now-need to tell darcs what files and directories in your project should be-under revision control.  You do this using the command \verb|darcs add|:-\begin{verbatim}-$ darcs add *.c Makefile.am configure.ac-\end{verbatim}-When you have added all your files (or at least, think you have), you will-want to record your changes.  ``Recording'' always includes adding a note-as to why the change was made, or what it does.  In this case, we'll just-note that this is the initial version.-\begin{verbatim}-$ darcs record --all-What is the patch name? Initial revision.-\end{verbatim}-Note that since we didn't specify a patch name on the command line we were-prompted for one.  If the environment variable `EMAIL' isn't set, you will-also be prompted for your email address.  Each patch that is recorded is-given a unique identifier consisting of the patch name, its creator's email-address, the date when it was created, and a random hash.--\section{Making changes}--Now that we have created our repository, make a change to one or more of-your files.  After making the modification run:-\begin{verbatim}-$ darcs whatsnew-\end{verbatim}-This should show you the modifications that you just made, in the darcs-patch format.  If you prefer to see your changes in a different format,-read Section~\ref{whatsnew}, which describes the whatsnew command in-detail.--Let's say you have now made a change to your project.  The next thing to do-is to record a patch.  Recording a patch consists of grouping together a-set of related changes, and giving them a name.  It also tags the patch-with the date it was recorded and your email address.--To record a patch simply type:-\begin{verbatim}-$ darcs record-\end{verbatim}-darcs will then prompt you with all the changes that you have made that-have not yet been recorded, asking you which ones you want to include in-the new patch.  Finally, darcs will ask you for a name for the patch.--You can now rerun whatsnew, and see that indeed the changes you have-recorded are no longer marked as new.--\section{Making your repository visible to others}-How do you let the world know about these wonderful changes?  Obviously,-they must be able to see your repository.  Currently the easiest way to do-this is is to look for-\htmladdnormallinkfoot{hosting services}{http://wiki.darcs.net/Hosting}-for darcs repositories.--You can also self-host your repositories by using any web server.-The recommended way to do-this (using apache in a UNIX environment) is to create a directory called-{\tt /var/www/repos}, and then put a symlink to your repository there:-\begin{verbatim}-$ cd /var/www/repos-$ ln -s /home/username/myproject .-\end{verbatim}--\section{Getting changes made to another repository}-Ok, so your repository is browsable using any web browser\ldots\ so-what? How does one get your changes into \emph{their} repository, where they can-do some good? It couldn't be easier.  One just \verb|cd| into their repository,-and there type:-\begin{verbatim}-$ darcs pull http://your.server.org/repos/yourproject-\end{verbatim}-Darcs will check to see if you have recorded any changes that aren't in their-current repository.  If so, it'll prompt them for each one, to see which ones-one want to add to their repository.  Note that you may see a different series-of prompts depending on your answers, since sometimes one patch depends on-another, so if you answer yes to the first one, you won't be prompted for-the second if the first depends on it.--Of course, maybe people don't even have a copy of your repository.  In that case-they'd want to do a-\begin{verbatim}-$ darcs get http://your.server.org/repos/yourproject-\end{verbatim}-which gets the whole repository.--Get, pull and push also work over ssh.  Ssh-paths are of the same form-accepted by scp, namely \verb|[username@]host:/path/to/repository|.--\section{Moving patches from one repository to another}--Darcs is flexible as to how you move patches from one repository to another.-This section will introduce all the ways you can get patches from one place-to another, starting with the simplest and moving to the most complicated.--\subsection{Push}--If you use ssh, you can use the push method to transfer changes.-Push can also be used when the target repository is local, in which case-ssh isn't needed.--Note that you can use push to administer a multiple-user repository.  You-just need to create a user for the repository (or repositories), and give-everyone with write access ssh access, perhaps using-\verb!.ssh/authorized_keys!.  Then they run-\begin{verbatim}-$ darcs push repouser@repo.server:repo/directory-\end{verbatim}--If you like this idea about creating a repository user to own a repository-which is writable by a number of users, you have one other option.--Push \verb!--apply-as! can run on either a local repository or one accessed-with ssh, but uses \verb!sudo! to run a darcs apply command (having created-a patch bundle as in send) as another user.  You can add the following line-in your \verb|sudoers| file to allow the users to apply their patches to a-centralized repository:-{\small-\begin{verbatim}-ALL   ALL = (repo-user) NOPASSWD: /usr/bin/darcs apply --all --repodir /repo/path*-\end{verbatim}-}-This method is ideal for a centralized repository when all the users have-accounts on the same computer, if you don't want your users to be able to-run arbitrary commands as repo-user.--\subsection{All pulls}--This method involves making each-repository readable (by http, ftp, nfs-mounted disk, or a public web hosting), and you-run \verb|darcs pull| in the repository you want to move the patch to.  This is nice,-as it doesn't require you to give write access to anyone else, and is-reasonably simple.--\subsection{Send and apply manually}--Sometimes the push method is impossible because the owner of the main repository-does not want or cannot create a user to write into it, and you cannot use the all-pull-method because you cannot set up a web server on your machine, perhaps because-it's behind a firewall or perhaps for security reasons, or because it is often-turned off.  In this case you can use-\verb|darcs send|-from that computer to generate a patch bundle for the remote-repository.  You can either let darcs email the patch for you, or save it-as a file and transfer it by hand.  Then in the destination repository-the owner of that repository runs \verb|darcs apply| to apply the patches contained-in the bundle.  This is also quite a simple method since, like the all-pull-method, it doesn't require that you give anyone write access to your-repository.  But it's less convenient, since the owner of the remote repository has-to keep track of the patch bundle (in the email, or whatever).--To use the send and apply method with email, the best is probably to create a-\verb!_darcs/prefs/email! file in the target repository containing the email-address of the maintainer.-This way anyone who sends to this repository will automatically send the-patch bundle to that email address.--If you receive many patches by email, you probably will benefit by running-darcs apply directly from your mail program.  You can place in your \verb!.muttrc!-the following:-\begin{verbatim}-auto_view text/x-patch text/x-darcs-patch-macro pager A "<pipe-entry>darcs apply --verbose --mark-conflicts \-        --reply droundy@abridgegame.org --repodir ~/darcs"-\end{verbatim}-which will allow you to view a sent patch, and then apply the patch directly from \verb!mutt!, sending a-confirmation email to the person who sent you the patch. The autoview line relies on on the following-lines, or something like them, being present in one's \verb!.mailcap!:-\begin{verbatim}-text/x-patch;                           cat; copiousoutput-text/x-darcs-patch;                     cat; copiousoutput-\end{verbatim}--\input{configuring_darcs.tex}--\input{best_practices.tex}--\chapter{Darcs commands}--The general format of a darcs command is-\begin{verbatim}-% darcs COMMAND OPTIONS ARGUMENTS ...-\end{verbatim}-Here \verb|COMMAND| is a command such as \verb|add| or \verb|record|, which of-course may have one or more arguments.  Options have the form-\verb!--option! or \verb!-o!, while arguments vary from command to-command.  There are many options which are common to a number of different-commands, which will be summarized here.--If you wish, you may use any unambiguous beginning of a command name as a-shortcut: for \verb!darcs record!, you could type \verb!darcs recor! or-\verb!darcs rec!, but not \verb!darcs re! since that could be confused with-\verb!darcs replace!, \verb!darcs revert! and \verb!darcs remove!.--In some cases, \verb|COMMAND| actually consists of two words, a-super-command and a subcommand.  For example, the ``display the-manifest'' command has the form \verb|darcs query manifest|.--\paragraph{Command overview}--Not all commands modify the ``patches'' of your repository (that-is, the named patches which other users can pull); some commands only-affect the copy of the source tree you're working on (your ``working-directory''), and some affect both. This table summarizes what you should-expect from each one and will hopefully serve as guide when you're having-doubts about which command to use.--\begin{center}-\footnotetext[1]{But it affects the repository and working directory targeted-  by the push}-\footnotetext[2]{As for the other end, see apply}-\begin{tabular}{|c|c|c|}-\hline-affects & patches & working directory\\-\hline-record & yes & no\\-\hline-unrecord & yes & no\\-\hline-rollback & yes & yes\\-\hline-revert & no & yes\\-\hline-unrevert & no & yes\\-\hline-pull & yes & yes\\-\hline-obliterate & yes & yes\\-\hline-apply & yes & yes\\-\hline-push\footnote{But it affects the repository and working directory targeted by-the push} & no & no\\-\hline-send\footnote{As for the other end, see apply} & no & no\\-\hline-put\footnote{Creates a new repository} & no & no\\-\hline-\end{tabular}-\end{center}--\section{Common options to darcs commands}--\begin{options}---help-\end{options}-Every \verb|COMMAND| accepts \verb!--help! as an argument, which tells it to-provide a bit of help.  Among other things, this help always provides an-accurate listing of the options available with that command, and is-guaranteed never to be out of sync with the version of darcs you actually-have installed (unlike this manual, which could be for an entirely-different version of darcs).-\begin{verbatim}-% darcs COMMAND --help-\end{verbatim}--\begin{options}---disable-\end{options}-Every {\tt COMMAND} accepts the \verb!--disable! option, which can be used in-\verb!_darcs/prefs/defaults! to disable some commands in the repository. This-can be helpful if you want to protect the repository from accidental use of-advanced commands like obliterate, unpull, unrecord or amend-record.--\begin{options}---verbose, --quiet, --normal-verbosity-\end{options}-Most commands also accept the \verb!--verbose! option, which tells darcs to-provide additional output.  The amount of verbosity varies from command to-command.  Commands that accept \verb!--verbose! also accept \verb!--quiet!,-which surpresses non-error output, and \verb!--normal-verbosity! which can be-used to restore the default verbosity if \verb!--verbose! or \verb!--quiet! is in-the defaults file.--\begin{options}---debug, --debug-http-\end{options}-Many commands also accept the \verb!--debug! option, which causes darcs to generate-additional output that may be useful for debugging its behavior, but which otherwise-would not be interesting. Option \verb!--debug-http! makes darcs output debugging-info for libcurl.--\begin{options}---repodir-\end{options}-Another common option is the \verb!--repodir! option, which allows you to-specify the directory of the repository in which to perform the command.-This option is used with commands, such as whatsnew, that ordinarily would-be performed within a repository directory, and allows you to use those-commands without actually being in the repository directory when calling the-command.  This is useful when running darcs in a pipe, as might be the case-when running \verb'apply' from a mailer.--\begin{options}---remote-repo-\end{options}--Some commands, such as \verb'pull' require a remote repository to be specified,-either from the command line or as a default.  The \verb!--remote-repo!-provides an alternative way to supply this remote repository path.  This flag-can be seen as temporarily ``replacing'' the default repository. Setting it-causes the command to ignore the default repository (it also does not affect,-i.e. overwrite the default repository).  On the other hand, if any other-repositories are supplied as command line arguments, this flag will be ignored-(and the default repository may be overwritten).---\paragraph{Selecting patches}\label{selecting}--Many commands operate on a patch or patches that have already been recorded.-There are a number of options that specify which patches are selected for-these operations: \verb!--patch!, \verb!--match!, \verb!--tag!, and variants-on these, which for \verb!--patch! are \verb!--patches!,-\verb!--from-patch!, and \verb!--to-patch!.  The \verb!--patch! and-\verb!--tag! forms simply take (POSIX extended, aka \verb!egrep!) regular-expressions and match them against tag and patch names.  \verb!--match!,-described below, allows more powerful patterns.--The plural forms of these options select all matching patches.  The singular-forms select the last matching patch.  The range (from and to) forms select-patches after or up to (both inclusive) the last matching patch.--These options use the current order of patches in the repository.  darcs may-reorder patches, so this is not necessarily the order of creation or the-order in which patches were applied.  However, as long as you are just-recording patches in your own repository, they will remain in order.--% NOTE --no-deps is implemented in SelectChanges.lhs, but documented here-% for concistency.-When a patch or a group of patches is selected, all patches they depend on-get silently selected too. For example: \verb!darcs pull --patches bugfix!-means ``pull all the patches with `bugfix' in their name, along with any-patches they require.''  If you really only want patches with `bugfix' in-their name, you should use the \verb!--no-deps! option, which makes darcs-exclude any matched patches from the selection which have dependencies that-are themselves not explicitly matched by the selection.--For \verb!unrecord!, \verb!unpull! and \verb!obliterate!, patches that-depend on the selected patches are silently included, or if-\verb!--no-deps! is used selected patches with dependencies on not selected-patches are excluded from the selection.---\subsection{Match}--Currently \verb!--match! accepts eight primitive match types, although-there are plans to expand it to match more patterns.  Also, note that the-syntax is still preliminary and subject to change.--The first match type accepts a literal string which is checked against-the patch name.  The syntax is-\begin{verbatim}-darcs annotate --summary --match 'exact foo+bar'-\end{verbatim}-This is useful for situations where a patch name contains characters that-could be considered special for regular expressions.--In this and the other match types, the argument must be enclosed in double-quotes if it contains spaces.  You can escape a quote in the argument with a-backslash; backslash escapes itself, but it is treated literally if followed-by a character other than a double quote or backslash, so it is typically not-necessary to escape a backslash.  No such escaping is necessary unless the-argument is enclosed in double quotes.--The second match type accepts a regular expression which is checked against-the patch name.  The syntax is-\begin{verbatim}-darcs annotate --summary --match 'name foo'-\end{verbatim}-Note that to match regexp metacharacters, such as \verb|(|, literally, they-must be escaped with backslash along with any embedded double quotes.  To-match a literal backslash it must be written quadrupled in general, but often-it need not be escaped, since backslash is only special in regexps when-followed by a metacharacter.  In the following example pairs, the first-literal is matched by the second sequence in the match name:-``\verb|"|'':``\verb|\"|'', ``\verb|\|'':``\verb|\\\\|'',-``\verb|\x|'':``\verb|\x|'', ``\verb|(|'':``\verb|\(|''.--The third match type matches the darcs hash for each patch:-\begin{verbatim}-darcs annotate --summary --match \-  'hash 20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef'-\end{verbatim}-Note you need to provide the full hash string as above.-This is intended to be used, for example, by programs allowing you to view-darcs repositories (e.g.\ CGI scripts like viewCVS).--The fourth match type accepts a regular expression which is checked against-the patch author.  The syntax is-\begin{verbatim}-darcs annotate --summary --match 'author foo'-\end{verbatim}--There is also support for matching by date.  This is done using commands such as-\begin{verbatim}-darcs annotate --summary --match 'date "last week"'-darcs annotate --summary --match 'date yesterday'-darcs annotate --summary --match 'date "today 14:00"'-darcs annotate --summary --match 'date "tea time yesterday"'-darcs annotate --summary --match 'date "3 days before last year at 17:00"'-darcs changes --from-match 'date "Sat Jun  30 11:31:30 EDT 2004"'-\end{verbatim}--Only English date specifications are supported---specifically you must use-English day and month names.  Also, only a limited set of time zones is-supported (compatible with GNU coreutils' date parsing).  Unrecognized zones-are treated as UTC, which may result in the timestamps printed in change-entries not being recognized by the date matching.  You can avoid this problem-on a POSIX-like system by running darcs in the UTC zone to get the times-initially, e.g.:-\begin{verbatim}-TZ=UTC darcs changes-\end{verbatim}--When matching on the ISO format, a partial date is treated as a range.-English dates can either refer to a specific day (``6 months ago',``day before-yesterday''), or to an interval-from some past date (``last month'') to the present.  Putting this all-together, if today is ``2004-07-24'' then the following matches should work:--\begin{tabular}{|ll|}-\hline-\textbf{date} & \textbf{patches selected} \\-\hline-2004          & from 2004-01-01 up to and including 2004-12-31 \\-2004-01       & from 2004-01-01 up to and including 2004-01-31 \\-2004-01-01    & during 2004-01-01 \\-\hline-today         & during 2004-07-24 (starting midnight in your timezone) \\-yesterday     & during 2004-07-23 \\-6 months ago  & during 2004-01-23 \\-\hline-last 6 months & since  2004-01-23 \\-last month    & since  2004-06-23 (not 2004-06-01!) \\-last week     & since  2004-07-16 \\-\hline-\end{tabular}--For more precise control, you may specify an interval, either-in a small subset of English or-of \htmladdnormallinkfoot{the ISO 8601 format}{http://www.w3.org/TR/NOTE-datetime}.-If you use the ISO format, note that durations, when-specified alone, are interpreted as being relative to the current date and time.-\begin{verbatim}-darcs annotate --summary --match 'date "between 2004-03-12 and last week"'-darcs annotate --summary --match 'date "after 2005"'-darcs annotate --summary --match 'date "in the last 3 weeks"'-darcs annotate --summary --match 'date "P3M/2006-03-17"'-darcs annotate --summary --match 'date "2004-01-02/2006-03-17"'-darcs annotate --summary --match 'date "P2M6D"'-\end{verbatim}--You may also prefer to combine date matching with a more specific pattern.-\begin{verbatim}-darcs annotate --summary --match 'date "last week" && name foo'-\end{verbatim}--The sixth match type accepts a regular expression which is checked against-file paths that the patch touches.  The syntax is-\begin{verbatim}-darcs annotate --summary --match 'touch foo/bar.c'-\end{verbatim}--The seventh match type accepts a regular expression which is checked-against every hunk. The syntax is-\begin{verbatim}-darcs annotate --summary --match 'hunk "^instance .* Foo where$"'-\end{verbatim}--The eight match type accepts a regular expression which is checked-against the long comment. The syntax is-\begin{verbatim}-darcs annotate --summary --match 'comment "remote repository"'-\end{verbatim}--The \verb!--match! pattern can include the logical operators \verb!&&!,-\verb!||! and \verb!not!, as well as grouping of patterns with parentheses.-For example-\begin{verbatim}-darcs annotate --summary --match 'name record && not name overrode'-\end{verbatim}--\begin{options}---ignore-times, --no-ignore-times-\end{options}-Darcs optimizes its operations by keeping track of the modification times-of your files.  This dramatically speeds up commands such as-\verb!whatsnew! and \verb!record! which would otherwise require reading-every file in the repository and comparing it with a reference version.  However,-there are times when this can cause problems, such as when running a series-of darcs commands from a script, in which case often a file will be-modified twice in the same second, which can lead to the second-modification going unnoticed.  The solution to such predicaments is the-\verb!--ignore-times! option, which instructs darcs not to trust the file-modification times, but instead to check each file's contents explicitly.---\begin{options}---author-\end{options}-\darcsEnv{DARCS_EMAIL}--\begin{options}---dont-compress, --compress-\end{options}-By default, darcs commands that write patches to disk will compress the-patch files.  If you don't want this, you can choose the-\verb!--dont-compress! option, which causes darcs not to compress the patch-file.--\begin{options}---dry-run-\end{options}-The \verb!--dry-run! option will cause darcs not to actually take the specified-action, but only print what would have happened.  Not all commands accept-\verb!--dry-run!, but those that do should accept the \verb!--summary!  option.--\begin{options}---summary, --no-summary-\end{options}-The \verb!--summary! option shows a summary of the patches that would have been-pulled/pushed/whatever. The format is similar to the output format of-\verb!cvs update! and looks like this:--\begin{verbatim}-A  ./added_but_not_recorded.c-A! ./added_but_not_recorded_conflicts.c-a  ./would_be_added_if_look_for_adds_option_was_used.h--M  ./modified.t -1 +1-M! ./modified_conflicts.t -1 +1--R  ./removed_but_not_recorded.c-R! ./removed_but_not_recorded_conflicts.c--\end{verbatim}--You can probably guess what the flags mean from the clever file names.-\begin{description}-\item{\texttt{A}} is for files that have been added but not recorded yet.-\item{\texttt{a}} is for files found using the \verb!--look-for-adds! option available for-\verb!whatsnew! and \verb!record!. They have not been added yet, but would be-added automatically if \verb!--look-for-adds! were used with the next-\verb!record! command.--\item{\texttt{M}} is for files that have been modified in the working directory but not-recorded yet. The number of added and subtracted lines is also shown.--\item{\texttt{R}}  is for files that have been removed, but the removal is not-recorded yet.-\end{description}-An exclamation mark appears next to any option that has a conflict.---\paragraph{Resolution of conflicts}\label{resolution}--To resolve conflicts using an external tool, you need to specify a command-to use, e.g.-\begin{verbatim}---external-merge 'opendiff %1 %2 -ancestor %a -merge %o'-\end{verbatim}-The \verb!%1! and \verb!%2!  are replaced with the two versions to be-merged, \verb!%a! is replaced with the common ancestor of the two versions.-Most importantly, \verb!%o! is replaced with the name of the output file-that darcs will require to be created holding the merged version.  The-above example works with the FileMerge.app tool that comes with Apple's-developer tools.  To use xxdiff, you would use-\begin{verbatim}---external-merge 'xxdiff -m -O -M %o %1 %a %2'-\end{verbatim}-To use \verb!kdiff3!, you can use-\begin{verbatim}---external-merge 'kdiff3 --output %o %a %1 %2'-\end{verbatim}-To use \verb!tortoiseMerge!, you can use-\begin{verbatim}---external-merge 'tortoiseMerge /base:"%a" /mine:"%1" /theirs:"%2" /merged:"%o"'-\end{verbatim}-(\verb!tortoiseMerge! is a nice merge tool that comes with TortoiseSVN and works well-on Windows.)--% Fixme: Is it actually a shell command on MS Windows?-Note that the command is split into space-separated words and the first one is-\verb!exec!ed with the rest as arguments---it is not a shell command. In particular,-on Windows this means that the first command path should not contain spaces and-you should make sure the command is in your \verb!PATH!.--The substitution of the \verb!%! escapes is done everywhere. If you need to prevent-substitution you can use a double percentage sign, i.e. \verb!%%a! is substituted with-\verb!%a!. Here is an example script to use the Emacs' Ediff package for merging.-% This is indented so that the leading #s don't confuse the preprocessor.-\begin{verbatim}- #! /bin/sh- # External merge command for darcs, using Emacs Ediff, via server if possible.- # It needs args %1 %2 %a %o, i.e. the external merge command is, say,- # `emerge3 %1 %2 %a %o'.- test $# -eq 4 || exit 1- form="(ediff-merge-files-with-ancestor"- while test $# -gt 0; do-     count=$count.-     if [ $count = .... ]; then-         form=$form\ nil         # Lisp STARTUP-HOOKS arg-     fi-     case $1 in                  # Worry about quoting -- escape " and \-         *[\"\\]* ) form=$form\ \"$(echo $1 | sed -e's/["\\]/\\\0/g')\" ;;-         *) form=$form\ \"$1\" ;;-     esac-     shift- done- form=$form')'- ( emacsclient --eval "$form" || # Emacs 22 server-   gnudoit "$form" ||            # XEmacs/Emacs 21 server-   emacs --eval "$form" ||       # Relatively slow to start up-   xemacs -eval "$form"          # Horribly slow to start up- ) 2>/dev/null-\end{verbatim}-It would be invoked like:-\begin{verbatim}---external-merge 'emerge3 %1 %2 %a %o'-\end{verbatim}--Note that if you do use an external merge tool, most likely you will want-to add to your defaults file-(\verb!_darcs/prefs/defaults! or \verb!~/.darcs/prefs!, see \ref{defaults},-on MS Windows~\ref{ms_win})-a line such as-\begin{verbatim}-ALL external-merge kdiff3 --output %o %a %1 %2-\end{verbatim}-or-\begin{verbatim}-ALL external-merge tortoiseMerge /base:"%a" /mine:"%1" /theirs:"%2" /merged:"%o"-\end{verbatim}--Note that the defaults file does not want quotes around the command.--\begin{options}---sendmail-command-\end{options}-\darcsEnv{SENDMAIL}--\subsection{Posthooks}--\begin{options}---posthook=COMMAND, --no-posthook-\end{options}-To provide a command that should be run whenever a darcs command completes-successfully, use \verb!--posthook! to specify the command.  This is useful-for people who want to have a command run whenever a patch is applied.  Using-\verb!--no-posthook! will disable running the command.-\begin{options}---run-posthook, --prompt-posthook-\end{options}-These options control prompting before running the posthook.  Use-\verb!--prompt-posthook! to have darcs prompt before running the-posthook command.  You may use --run-posthook to reenable the default-behavior of running user-specified posthooks.--Some darcs commands export to the posthook command information about the-changes being made.  In particular, three environment variables are defined.-\verb!DARCS_PATCHES! contains a human-readable summary of the patches being-acted upon. The format is the same as "darcs changes".  \verb!DARCS_PATCHES_XML!-Contains the same details, in the same XML format as "darcs changes". Finally,-\verb!DARCS_FILES! contains a list of the files affected, one file per line.-If your repository has filenames including newlines, you'll just have to-cope.  Note, however, that \emph{none} of these environment variables are-defined when running under windows.  Note also that we refuse to pass-environment variables greater in size than 10k, in order to avoid triggering-\verb!E2BIG! errors.---\subsection{Prehooks}--\begin{options}---prehook=COMMAND, --no-prehook-\end{options}-To provide a command that should be run before a darcs command is executed,- use \verb!--prehook! to specify the command.  An example use is-for people who want to have a command run whenever a patch is to be recorded, such as-translating line endings before recording patches.  Using-\verb!--no-prehook! will disable running the command.-\begin{options}---run-prehook, --prompt-prehook-\end{options}-These options control prompting before running the prehook.  See the-posthook documentation above for details.--\begin{options}---http-pipelining, --no-http-pipelining-\end{options}--When compiled with libcurl (version 7.18.0 and above), darcs can-use HTTP pipelining. It is enabled by default for libcurl-(version 7.19.1 and above). This option will make darcs enable or-disable HTTP pipelining, overwriting default. Note that if HTTP-pipelining is really used depends on the server.--\begin{options}---no-cache-\end{options}--Do not use patch caches.--\begin{options}---umask-\end{options}-By default, Darcs will use your current umask.  The option-\verb|--umask| will cause Darcs to switch to a different umask before-writing to the repository.--\begin{options}---dont-restrict-paths, --restrict-paths-\end{options}-By default darcs is only allowed to manage and modify files and directories-contained inside the current repository and not being part of any darcs-repository's meta data (including the current one). This is mainly for-security, to protect you from spoofed patches modifying arbitrary files-with sensitive data---say, in your home directory---or tampering with any-repository's meta data to switch off this safety guard.--But sometimes you may want to manage a group of ``sub'' repositories'-preference files with a global repository, or use darcs in some other-advanced way. The best way is probably to put-\verb!ALL dont-restrict-paths! in \verb!_darcs/prefs/defaults!. This turns-off all sanity checking for file paths in patches.--Path checking can be temporarily turned on with \verb!--restrict-paths! on-the command line, when pulling or applying unknown patches.--\begin{options}---allow-unrelated-repos-\end{options}-By default darcs checks and warns user if repositories are unrelated when-doing pull, push and send. This option makes darcs skip this check.---\section{Options apart from darcs commands}-\begin{options}---help-\end{options}-Calling darcs with just \verb|--help| as an argument gives a brief-summary of what commands are available.-\begin{options}---version, --exact-version-\end{options}-Calling darcs with the flag \verb|--version| tells you the version of-darcs you are using.  Calling darcs with the flag \verb|--exact-version|-gives the precise version of darcs, even if that version doesn't correspond-to a released version number.  This is helpful with bug reports, especially-when running with a ``latest'' version of darcs.-\begin{options}---commands-\end{options}-Similarly calling darcs with only \verb|--commands| gives a simple list-of available commands.  This latter arrangement is primarily intended for-the use of command-line autocompletion facilities, as are available in-bash.--\section{Getting help}--\darcsCommand{help}--\section{Creating repositories}--\darcsCommand{initialize}-\darcsCommand{get}--\section{Modifying the contents of a repository}--\darcsCommand{add}-\darcsCommand{remove}-\darcsCommand{move}-\darcsCommand{replace}--\section{Working with changes}--\darcsCommand{record}--\begin{options}---ask-deps-\end{options}--Each patch may depend on any number of previous patches.  If you choose to-make your patch depend on a previous patch, that patch is required to be-applied before your patch can be applied to a repository.  This can be used, for-example, if a piece of code requires a function to be defined, which was-defined in an earlier patch.--If you want to manually define any dependencies for your patch, you can use-the \verb!--ask-deps! flag, and darcs will ask you for the patch's-dependencies.--It is possible to record a patch which has no actual changes but which-has specific dependencies.  This type of patch can be thought of as a-``partial tag''.  The \verb!darcs tag! command will record a patch-with no actual changes but which depends on the entire current-inventory of the repository.  The \verb!darcs record --ask-deps! with-no selected changes will record a patch that depends on only those-patches selected via the \verb!--ask-deps! operation, resulting in a-patch which describes a set of patches; the presence of this primary-patch in a repository implies the presence of (at least) the-depended-upon patches.--\begin{options}---pipe-\end{options}--If you run record with the \verb!--pipe! option, you will be prompted for-the patch date, author, and the long comment. The long comment will extend-until the end of file or stdin is reached (ctrl-D on Unixy systems, ctrl-Z-on systems running a Microsoft OS).--This interface is intended for scripting darcs, in particular for writing-repository conversion scripts.  The prompts are intended mostly as a useful-guide (since scripts won't need them), to help you understand the format in-which to provide the input. Here's an example of what the \verb!--pipe!-prompts look like:--\begin{verbatim}- What is the date? Mon Nov 15 13:38:01 EST 2004- Who is the author? David Roundy- What is the log? One or more comment lines-\end{verbatim}---\begin{options}---interactive-\end{options}--By default, \verb!record! works interactively. Probably the only thing you need-to know about using this is that you can press \verb!?! at the prompt to be-shown a list of the rest of the options and what they do. The rest should be-clear from there. Here's a-``screenshot'' to demonstrate:--\begin{verbatim}-hunk ./hello.pl +2-+#!/usr/bin/perl-+print "Hello World!\n";-Shall I record this patch? (2/2) [ynWsfqadjk], or ? for help: ?-How to use record...-y: record this patch-n: don't record it-w: wait and decide later, defaulting to no--s: don't record the rest of the changes to this file-f: record the rest of the changes to this file--d: record selected patches-a: record all the remaining patches-q: cancel record--j: skip to next patch-k: back up to previous patch-h or ?: show this help--<Space>: accept the current default (which is capitalized)--\end{verbatim}-What you can't see in that ``screenshot'' is that \verb!darcs! will also try to use-color in your terminal to make the output even easier to read.--\darcsCommand{pull}--\begin{options}---intersection, --union [DEFAULT], --complement-\end{options}--If you provide more than one repository as an argument to pull, darcs'-behavior is determined by the presence of the \verb!--complement!,-\verb!--intersection!, and \verb!--union!  flags.--\begin{itemize}--\item The default (\verb!--union!) behavior is to pull any patches-that are in any of the specified repositories.--\item If you instead specify the \verb!--intersection! flag, darcs-will only pull those patches which are present in all source-repositories.--\item If you specify the \verb!--complement! flag, darcs will only-pull elements in the first repository that do not exist in any of the-remaining repositories.-\end{itemize}---\begin{options}---external-merge-\end{options}--You can use an external interactive merge tool to resolve conflicts with the-flag \verb!--external-merge!.  For more details see-subsection~\ref{resolution}.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to pull, as described in-subsection~\ref{selecting}.--\begin{options}---no-test, --test-\end{options}--If you specify the \verb!--test! option, pull will run the test (if a test-exists) on a scratch copy of the repository contents prior to actually performing-the pull.  If the test fails, the pull will be aborted.--\begin{options}---verbose-\end{options}--Adding the \verb!--verbose! option causes another section to appear in the-output which also displays a summary of patches that you have and the remote-repository lacks. Thus, the following syntax can be used to show you all the patch-differences between two repositories:--\begin{verbatim}-darcs pull --dry-run --verbose-\end{verbatim}--\darcsCommand{push}--For obvious reasons, you can only push to repositories to which you have-write access.  In addition, you can only push to repos that you access-either on the local file system or with ssh.  In order to apply with ssh,-darcs must also be installed on the remote computer.  The command invoked-to run ssh may be configured by the \verb!DARCS_SSH! environment variable-(see subsection~\ref{env:DARCS_SSH}).  The command invoked via ssh is always-\verb!darcs!, i.e.\ the darcs executable must be in the default path on-the remote machine.--Push works by creating a patch bundle, and then running darcs apply in the-target repository using that patch bundle.  This means that the default-options for \emph{apply} in the \emph{target} repository (such as, for-example, \verb!--test!) will affect the behavior of push.  This also means-that push is somewhat less efficient than pull.--When you receive an error message such as-\begin{verbatim}-bash: darcs: command not found-\end{verbatim}-then this means that the darcs on the remote machine could-not be started.  Make sure that the darcs executable is called-\verb!darcs! and is found in the default path.  The default path can-be different in interactive and in non-interactive shells.  Say-\begin{verbatim}-ssh login@remote.machine darcs-\end{verbatim}-to try whether the remote darcs can be found, or-\begin{verbatim}-ssh login@remote.machine 'echo $PATH'-\end{verbatim}-(note the single quotes) to check the default path.--\begin{options}---apply-as-\end{options}--If you give the \verb!--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-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,-inept or lazy users.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to push, as described in-subsection~\ref{selecting}.--When there are conflicts, the behavior of push is determined by the default-flags to \verb!apply! in the \emph{target} repository.  Most commonly, for-pushed-to repositories, you'd like to have \verb!--dont-allow-conflicts! as-a default option to apply (by default, it is already the default\ldots).  If-this is the case, when there are conflicts on push, darcs will fail with an-error message.  You can then resolve by pulling the conflicting patch,-recording a resolution and then pushing the resolution together with the-conflicting patch.--Darcs does not have an explicit way to tell you which patch conflicted, only the-file name. You may want to pull all the patches from the remote repository just-to be sure. If you don't want to do this in your working directory,-you can create another darcs working directory for this purpose.--If you want, you could set the target repository to use \verb!--allow-conflicts!.-In this case conflicting patches will be applied, but the conflicts will-not be marked in the working directory.--If, on the other hand, you have \verb!--mark-conflicts! specified as a-default flag for apply in the target repository, when there is a conflict,-it will be marked in the working directory of the target repository.  In-this case, you should resolve the conflict in the target repository itself.--\darcsCommand{send}--Do not confuse the \verb!--author! options with the return address-that \verb!darcs send! will set for your patch bundle.--For example, if you have two email addresses A and B:-\begin{description}-\item  If you use-\verb!--author A! but your machine is configured to send mail from-address B by default, then the return address on your message will be B.--\item If you use \verb!--from A! and your mail client supports setting the-From: address arbitrarily (some non-Unix-like mail clients, especially,-may not support this), then the return address will be A; if it does-not support this, then the return address will be B.--\item If you supply neither \verb!--from! nor \verb!--author!, then the return-address will be B.-\end{description}--In addition, unless you specify the sendmail command with-\verb!--sendmail-command!, darcs sends email using the default email-command on your computer. This default command is determined by the-\verb!configure! script. Thus, on some non-Unix-like OSes,-\verb!--from! is likely to not work at all.--\begin{options}---output, --to, --cc-\end{options}--The \verb!--output!, \verb!--output-auto-name!, and \verb!--to! flags determine-what darcs does with the patch bundle after creating it.  If you provide an-\verb!--output!  argument, the patch bundle is saved to that file.  If you-specify \verb!--output-auto-name!, the patch bundle is saved to a file with an-automatically generated name.  If you give one or more \verb!--to! arguments,-the bundle of patches is sent to those locations. The locations may either be email-addresses or urls that the patch should be submitted to via HTTP.--If you don't provide any of these options, darcs will look at the contents of-the \verb!_darcs/prefs/email! file in the target repository (if it exists), and-send the patch by email to that address.  In this case, you may use the-\verb!--cc! option to specify additional recipients without overriding the-default repository email address.--If \texttt{\_darcs/prefs/post} exists in the target repository, darcs will-upload to the URL contained in that file, which may either be a-\texttt{mailto:} URL, or an \texttt{http://} URL.  In the latter case, the-patch is posted to that URL.--If there is no email address associated with the repository, darcs will-prompt you for an email address.--\begin{options}---subject-\end{options}--Use the \verb!--subject! flag to set the subject of the e-mail to be sent.-If you don't provide a subject on the command line, darcs will make one up-based on names of the patches in the patch bundle.--\begin{options}---in-reply-to-\end{options}--Use the \verb!--in-reply-to! flag to set the In-Reply-To and References headers-of the e-mail to be sent. By default no additional headers are included so e-mail-will not be treated as reply by mail readers.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to send, as described in-subsection~\ref{selecting}.--\begin{options}---edit-description-\end{options}--If you want to include a description or explanation along with the bundle-of patches, you need to specify the \verb!--edit-description! flag, which-will cause darcs to open up an editor with which you can compose a message-to go along with your patches.--\begin{options}---sendmail-command-\end{options}--If you want to use a command different from the default one for sending email,-you need to specify a command line with the \verb!--sendmail-command! option. The-command line can contain some format specifiers which are replaced by the actual-values. Accepted format specifiers are \verb!%s! for subject, \verb!%t! for to,-\verb!%c! for cc, \verb!%b! for the body of the mail, \verb!%f! for from, \verb!%a!-for the patch bundle and the same specifiers in uppercase for the URL-encoded values.-Additionally you can add \verb!%<! to the end of the command line if the command-expects the complete email message on standard input. E.g.\ the command lines for evolution-and msmtp look like this:--\begin{verbatim}-evolution "mailto:%T?subject=%S&attach=%A&cc=%C&body=%B"-msmtp -t %<-\end{verbatim}--\darcsCommand{apply}--Darcs apply accepts a single argument, which is the name of the patch-file to be applied.  If you omit this argument, the patch is read from-standard input.  Darcs also interprets an argument of `\-' to mean it-should read the file from standard input. This allows you to use apply-with a pipe from your email program, for example.--\begin{options}---verify-\end{options}--\begin{options}---external-merge-\end{options}--You can use an external interactive merge tool to resolve conflicts with the-flag \verb!--external-merge!.  For more details see-subsection~\ref{resolution}.--\begin{options}---sendmail-command-\end{options}--If you want to use a command different from the default one for sending mail,-you need to specify a command line with the \verb!--sendmail-command! option.-The command line can contain the format specifier \verb!%t! for to-and you can add \verb!%<! to the end of the command line if the command-expects the complete mail on standard input. For example, the command line for-msmtp looks like this:--\begin{verbatim}-msmtp -t %<-\end{verbatim}---\section{Seeing what you've done}--\darcsCommand{whatsnew}-\darcsCommand{changes}--\section{More advanced commands}--\darcsCommand{tag}-\darcsCommand{setpref}-\darcsCommand{test}--If you like, you can configure your repository to be able to run a test-suite of some sort.  You can do this by using ``setpref'' to set the-``test'' value to be a command to run, e.g.-\begin{verbatim}-% darcs setpref test "sh configure && make && make test"-\end{verbatim}-Or, if you want to define a test specific to one copy of the repository,-you could do this by editing the file \verb!_darcs/prefs/prefs!.--\begin{options}---leave-test-directory, --remove-test-directory-\end{options}--Normally darcs deletes the directory in which the test was run afterwards.-Sometimes (especially when the test fails) you'd prefer to be able to be-able to examine the test directory after the test is run.  You can do this-by specifying the \verb!--leave-test-directory! flag.  Alas, there is no-way to make darcs leave the test directory only if the test fails.  The-opposite of \verb!--leave-test-directory! is-\verb!--remove-test-directory!, which could come in handy if you choose to-make \verb!--leave-test-directory! the default (see-section~\ref{defaults}).--\darcsCommand{repair}-\darcsCommand{optimize}--\begin{options}---reorder-patches-\end{options}--The \verb|--reorder-patches| option causes Darcs to create an optimal-ordering of its internal patch inventory. This may help to produce shorter-`context' lists when sending patches, and may improve performance for some-other operations as well.  You should not run \verb!--reorder-patches! on a-repository from which someone may be simultaneously pulling or getting, as-this could lead to repository corruption.--The \verb|--upgrade| option for \verb!darcs optimize! performs an inplace-upgrade of your repository to the latest \emph{compatible} format.  Right now-means that darcs 1 old-fashioned repositories will be upgraded to darcs-1-hashed repositories (and notably, not to darcs 2 repositories as that would not-be compatible; see \verb!darcs convert!).--\section{Undoing, redoing and running in circles}--\darcsCommand{amend-record}-\darcsCommand{rollback}-\darcsCommand{unrecord}--Unrecord can be thought of as undo-record.-If a record is followed by an unrecord, everything looks like before-the record; all the previously unrecorded changes are back, and can be-recorded again in a new patch. The unrecorded patch however is actually-removed from your repository, so there is no way to record it again to get-it back.\footnote{The patch file itself is not actually deleted, but its-context is lost, so it cannot be reliably read---your only choice would be-to go in by hand and read its contents.}.--If you want to remove-the changes from the working copy too (where they otherwise will show-up as unrecorded changes again), you'll also need to \verb!darcs revert!.-To do unrecord and revert in one go, you can use \verb!darcs obliterate!.--If you don't revert after unrecording, then the changes made by the-unrecorded patches are left in your working tree.  If these patches are-actually from another repository, interaction (either pushes or pulls) with-that repository may be massively slowed down, as darcs tries to cope with-the fact that you appear to have made a large number of changes that-conflict with those present in the other repository.  So if you really want-to undo the result of a \emph{pull} operation, use obliterate! Unrecord is-primarily intended for when you record a patch, realize it needs just one-more change, but would rather not have a separate patch for just that one-change.--\newcommand{\pullwarning}[1]{-\textbf{WARNING:} #1 should not be run when there is a possibility-that another user may be pulling from the same repository.  Attempting to do so-may cause repository corruption.}--\pullwarning{Unrecord}--\begin{options}---from-match, --from-patch, --from-tag, --last-\end{options}--Usually you only want to unrecord the latest changes,-and almost never would you want to unrecord changes before a tag---you-would have to have unrecorded the tag as well to do that.-Therefore, and for efficiency, darcs only prompts you for the latest patches,-after some optimal tag.--If you do want to unrecord more patches in one go,-there are the \verb!--from! and \verb!--last! options-to set the earliest patch selectable to unrecord.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to unrecord, as described in-subsection~\ref{selecting}.--With these options you can specify-what patch or patches to be prompted for by unrecord.-This is especially useful when you want to unrecord patches with dependencies,-since all the dependent patches (but no others) will be included in the choices.-Or if you use \verb!--no-deps! you won't be asked about patches that can't be-unrecorded due to depending patches.--Selecting patches can be slow, so darcs cuts the search at the last-optimized tag. Use the \verb!--from! or \verb!--last! options to search-more or fewer patches.--\darcsCommand{obliterate}--Obliterate deletes a patch from the repository \emph{and} removes those-changes from the working directory.  It is therefore a \emph{very-dangerous} command.  When there are no local changes, obliterate is-equivalent to an unrecord followed by a revert, except that revert can be-unreverted.  In the case of tags, obliterate removes the tag itself, not-any other patches.--Note that unpull was the old name for obliterate. Unpull is still an-hidden alias for obliterate.--\pullwarning{Obliterate}--\begin{options}---from-match, --from-patch, --from-tag, --last-\end{options}--Usually you only want to obliterate the latest changes, and almost never would-you want to obliterate changes before a tag---you would have to have obliterated-the tag as well to do that. Therefore, and for efficiency, darcs only-prompts you for the latest patches, after some optimal tag.--If you do want to obliterate more patches in one go, there are the-\verb!--from! and \verb!--last! options to set the earliest patch-selectable to obliterate.--\begin{options}---matches, --patches, --tags, --no-deps-\end{options}--The \verb!--patches!, \verb!--matches!, \verb!--tags!, and \verb!--no-deps!-options can be used to select which patches to obliterate, as described in-subsection~\ref{selecting}.--With these options you can specify what patch or patches to be prompted for-by obliterate. This is especially useful when you want to obliterate patches with-dependencies, since all the dependent patches (but no others) will be-included in the choices. Or if you use \verb!--no-deps! you won't be asked-about patches that can't be obliterated due to depending patches.--Selecting patches can be slow, so darcs cuts the search at the last-optimized tag. Use the \verb!--from! or \verb!--last! options to search-more or fewer patches.---\darcsCommand{revert}-\darcsCommand{unrevert}--\section{Advanced examination of the repository}--\darcsCommand{diff}-\darcsCommand{annotate}--%% FIXME: AFAICT -u does nothing.  Remove it from anno's options?-%% --twb, 2009-09-20-Giving the \verb!--unified! flag implies \verb!--human-readable!, and causes-the output to remain in a darcs-specific format that is similar to that produced-by \verb!diff --unified!.--If a directory name is given, annotate will output details of the last-modifying patch for each file in the directory and the directory itself. The-details look like this:--\begin{verbatim}- # Created by [bounce handling patch- # mark**20040526202216]  as ./test/m7/bounce_handling.pl-    bounce_handling.pl-\end{verbatim}--If a patch name and a directory are given, these details are output for the time after-that patch was applied.  If a directory and a tag name are given, the-details of the patches involved in the specified tagged version will be output.--If a file name is given, the last modifying patch details of that file will be output, along-with markup indicating patch details when each line was last (and perhaps next) modified.--If a patch name and a file name are given, these details are output for the time after-that patch was applied.--\begin{options}---creator-hash HASH-\end{options}--The \verb!--creator-hash! option should only be used in combination with a-file or directory to be annotated.  In this case, the name of that file or-directory is interpreted to be its name \emph{at the time it was created},-and the hash given along with \verb!--creator-hash! indicates the patch-that created the file or directory.  This allows you to (relatively) easily-examine a file even if it has been renamed multiple times.--\subsection{darcs show}--The show command provides access to several subcommands which can be-used to investigate the state of a repository.--\darcsCommand{show authors}-\darcsCommand{show contents}-\darcsCommand{show files}-\darcsCommand{show index}-\darcsCommand{show tags}-\darcsCommand{show repo}--\section{Rarely needed and obscure commands}--\darcsCommand{mark-conflicts}-\darcsCommand{trackdown}--Trackdown is helpful for locating when something was broken.  It creates-a temporary directory with the latest repository content in it and cd to it.-First, and only once, it runs the initialization command if any,-for example-\begin{verbatim}-'autoconf; ./configure >/dev/null'-\end{verbatim}-Then it runs the test command, for example-\begin{verbatim}-'make && cd tests && sh /tmp/test.sh'-\end{verbatim}-While the test command exits with an error return code, darcs-``unapplies'' one patch from the version controlled files to retrieve-an earlier version, and repeats the test command.  If the test command-finally succeeds, the name of the hunted down patch is found in the-output before the last test run.--The \verb!--bisect! variant of trackdown can be useful when the sought after-patch is likely buried deep in the repository history; however, it currently-requires an potentially expensive process of applying or unapplying half the-repository's patches at a time. You may often find the straightforward linear-trackdown to be more efficient in practice.--\subsubsection{Example usage}-If you want to find the last version of darcs that had a FIXME note in the-file Record.lhs, you could run-\begin{verbatim}-% darcs trackdown 'grep FIXME Record.lhs'-\end{verbatim}--To find the latest version that compiles, you can run-\begin{verbatim}-% darcs trackdown 'autoconf' './configure && make'-\end{verbatim}--Trackdown can also be used to see how other features of the code changed-with time.  For example-\begin{verbatim}-% darcs trackdown 'autoconf; ./configure' \-   "make darcs > /dev/null && cd ~/darcs && time darcs check && false"-\end{verbatim}-would let you see how long `darcs check' takes to run on each previous-version of darcs that will actually compile.  The ``\verb!&& false!''-ensures that trackdown keeps going.--\darcsCommand{dist}-\darcsCommand{put}-\darcsCommand{fetch}-\darcsCommand{convert}--A project cannot mix both patch formats.-By default, repositories created with `darcs initialize' are set-to use the `darcs-2' format (\ref{initialize}).-Cloning an existing repository with `darcs get' or `darcs put'-preserves the patch format used.--The `darcs-2' format improves on the `darcs-1' format in the following-ways:--\begin{itemize}-\item The `exponential merge' problem is \emph{far} less likely to-  occur (it can still be produced in deliberately pathological cases).-\item Identical primitive changes no longer conflict.  For example, if-  two patches both attempt to add a directory `tests', these patches-  will not conflict.-\end{itemize}--\appendix--\input{building_darcs.tex}--\input{gpl.tex}--\end{document}--
− doc/src/features.tex 
@@ -1,71 +0,0 @@-\section{Features}--\paragraph{Record changes locally}-In darcs, the equivalent of a svn ``commit'' is called record, because it-doesn't put the change into any remote or centralized repository.  Changes-are always recorded locally, meaning no net access is required in order to-work on your project and record changes as you make them.--\paragraph{Interactive records}-You can choose to perform an interactive record, in which case darcs will-prompt you for each change you have made and ask if you wish to record it.-Of course, you can tell darcs to record all the changes in a given file, or-to skip all the changes in a given file, or go back to a previous change,-or whatever.--\paragraph{Unrecord local changes}-As a corollary to the ``local'' nature of the record operation, if a change-hasn't yet been published to the world---that is, if the local repository-isn't accessible by others---you can safely unrecord a change (even if it-wasn't the most recently recorded change) and then re-record it-differently, for example if you forgot to add a file, introduced a bug or-realized that what you recorded as a single change was really two separate-changes.--\paragraph{Interactive everything else}-Most darcs commands support an interactive interface.  The ``revert''-command, for example, which undoes unrecorded changes has the same-interface as record, so you can easily revert just a single change.  Pull,-push, send and apply all allow you to view and interactively select which-changes you wish to pull, push, send or apply.--\paragraph{Test suites}-Darcs has support for integrating a test suite with a repository.  If you-choose to use this, you can define a test command (e.g.\ ``make check'') and-have darcs run that command on a clean copy of the project either prior to-recording a change or prior to applying changes---and to reject changes-that cause the test to fail.--\paragraph{Any old server}-Darcs does not require a specialized server in order to make a repository-available for read access.  You can use http, ftp, or even just a plain old-ssh server to access your darcs repository.--\paragraph{You decide write permissions}-Darcs doesn't try to manage write access.  That's your business.  Supported-push methods include direct ssh access (if you're willing to \emph{give}-direct ssh access away), using sudo to allow users who already have shell-access to only apply changes to the repository, or verification of-gpg-signed changes sent by email against a list of allowed keys.  In-addition, there is support for submission of patches by email that-are not automatically applied, but can easily be applied with a shell escape-from a mail reader.--\paragraph{File and directory moves}-Renames or moves of files and directories, of course are handled properly,-so when you rename a file or move it to a different directory, its history-is unbroken, and merges with repositories that don't have the file renamed-will work as expected.--\paragraph{Token replace}-You can use the ``darcs replace'' command to modify all occurrences of a-particular token (defined by a configurable set of characters that are-allowed in ``tokens'') in a file.  This has the advantage that merges with-changes that introduce new copies of the old token will have the effect of-changing it to the new token---which comes in handy when changing a-variable or function name that is used throughout a project.--\paragraph{Configurable defaults}-You can easily configure the default flags passed to any command on either-a per-repository or a per-user basis or a combination thereof.-
− doc/src/gpl.tex 
@@ -1,420 +0,0 @@-% This is the FSF GPL, reformatted as an appendix by David Roundy--% This file is intended to be included in another file.--\chapter{License}--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2, or (at your option)-any later version.--\label{gpl}-\section*{The GNU General Public License}--\begin{center}-Version 2, June 1991--Copyright \copyright\ 1989, 1991 Free Software Foundation, Inc.--\bigskip--51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA--\bigskip--Everyone is permitted to copy and distribute verbatim copies-of this license document, but changing it is not allowed.--\end{center}--\subsection*{Preamble}-\begin{quote}-The licenses for most software are designed to take away your freedom to-share and change it.  By contrast, the GNU General Public License is-intended to guarantee your freedom to share and change free software---to-make sure the software is free for all its users.  This General Public-License applies to most of the Free Software Foundation's software and to-any other program whose authors commit to using it.  (Some other Free-Software Foundation software is covered by the GNU Library General Public-License instead.)  You can apply it to your programs, too.--When we speak of free software, we are referring to freedom, not price.-Our General Public Licenses are designed to make sure that you have the-freedom to distribute copies of free software (and charge for this service-if you wish), that you receive source code or can get it if you want it,-that you can change the software or use pieces of it in new free programs;-and that you know you can do these things.--To protect your rights, we need to make restrictions that forbid anyone to-deny you these rights or to ask you to surrender the rights.  These-restrictions translate to certain responsibilities for you if you-distribute copies of the software, or if you modify it.--For example, if you distribute copies of such a program, whether gratis or-for a fee, you must give the recipients all the rights that you have.  You-must make sure that they, too, receive or can get the source code.  And-you must show them these terms so they know their rights.--We protect your rights with two steps: (1) copyright the software, and (2)-offer you this license which gives you legal permission to copy,-distribute and/or modify the software.--Also, for each author's protection and ours, we want to make certain that-everyone understands that there is no warranty for this free software.  If-the software is modified by someone else and passed on, we want its-recipients to know that what they have is not the original, so that any-problems introduced by others will not reflect on the original authors'-reputations.--Finally, any free program is threatened constantly by software patents.-We wish to avoid the danger that redistributors of a free program will-individually obtain patent licenses, in effect making the program-proprietary.  To prevent this, we have made it clear that any patent must-be licensed for everyone's free use or not licensed at all.--The precise terms and conditions for copying, distribution and-modification follow.-\end{quote}--\begin{center}-{\Large \sc GNU General Public License-\\\vspace{3mm}Terms and Conditions For Copying, Distribution and Modification}-\end{center}---\begin{enumerate}--\addtocounter{enumi}{-1}--\item --This License applies to any program or other work which contains a notice-placed by the copyright holder saying it may be distributed under the-terms of this General Public License.  The ``Program'', below, refers to-any such program or work, and a ``work based on the Program'' means either-the Program or any derivative work under copyright law: that is to say, a-work containing the Program or a portion of it, either verbatim or with-modifications and/or translated into another language.  (Hereinafter,-translation is included without limitation in the term ``modification''.)-Each licensee is addressed as ``you''.--Activities other than copying, distribution and modification are not-covered by this License; they are outside its scope.  The act of-running the Program is not restricted, and the output from the Program-is covered only if its contents constitute a work based on the-Program (independent of having been made by running the Program).-Whether that is true depends on what the Program does.--\item You may copy and distribute verbatim copies of the Program's source-  code as you receive it, in any medium, provided that you conspicuously-  and appropriately publish on each copy an appropriate copyright notice-  and disclaimer of warranty; keep intact all the notices that refer to-  this License and to the absence of any warranty; and give any other-  recipients of the Program a copy of this License along with the Program.--You may charge a fee for the physical act of transferring a copy, and you-may at your option offer warranty protection in exchange for a fee.--\item--You may modify your copy or copies of the Program or any portion-of it, thus forming a work based on the Program, and copy and-distribute such modifications or work under the terms of Section 1-above, provided that you also meet all of these conditions:--\begin{enumerate}--\item --You must cause the modified files to carry prominent notices stating that-you changed the files and the date of any change.--\item--You must cause any work that you distribute or publish, that in-whole or in part contains or is derived from the Program or any-part thereof, to be licensed as a whole at no charge to all third-parties under the terms of this License.--\item-If the modified program normally reads commands interactively-when run, you must cause it, when started running for such-interactive use in the most ordinary way, to print or display an-announcement including an appropriate copyright notice and a-notice that there is no warranty (or else, saying that you provide-a warranty) and that users may redistribute the program under-these conditions, and telling the user how to view a copy of this-License.  (Exception: if the Program itself is interactive but-does not normally print such an announcement, your work based on-the Program is not required to print an announcement.)--\end{enumerate}---These requirements apply to the modified work as a whole.  If-identifiable sections of that work are not derived from the Program,-and can be reasonably considered independent and separate works in-themselves, then this License, and its terms, do not apply to those-sections when you distribute them as separate works.  But when you-distribute the same sections as part of a whole which is a work based-on the Program, the distribution of the whole must be on the terms of-this License, whose permissions for other licensees extend to the-entire whole, and thus to each and every part regardless of who wrote it.--Thus, it is not the intent of this section to claim rights or contest-your rights to work written entirely by you; rather, the intent is to-exercise the right to control the distribution of derivative or-collective works based on the Program.--In addition, mere aggregation of another work not based on the Program-with the Program (or with a work based on the Program) on a volume of-a storage or distribution medium does not bring the other work under-the scope of this License.--\item-You may copy and distribute the Program (or a work based on it,-under Section 2) in object code or executable form under the terms of-Sections 1 and 2 above provided that you also do one of the following:--\begin{enumerate}--\item--Accompany it with the complete corresponding machine-readable-source code, which must be distributed under the terms of Sections-1 and 2 above on a medium customarily used for software interchange; or,--\item--Accompany it with a written offer, valid for at least three-years, to give any third party, for a charge no more than your-cost of physically performing source distribution, a complete-machine-readable copy of the corresponding source code, to be-distributed under the terms of Sections 1 and 2 above on a medium-customarily used for software interchange; or,--\item--Accompany it with the information you received as to the offer-to distribute corresponding source code.  (This alternative is-allowed only for noncommercial distribution and only if you-received the program in object code or executable form with such-an offer, in accord with Subsection b above.)--\end{enumerate}---The source code for a work means the preferred form of the work for-making modifications to it.  For an executable work, complete source-code means all the source code for all modules it contains, plus any-associated interface definition files, plus the scripts used to-control compilation and installation of the executable.  However, as a-special exception, the source code distributed need not include-anything that is normally distributed (in either source or binary-form) with the major components (compiler, kernel, and so on) of the-operating system on which the executable runs, unless that component-itself accompanies the executable.--If distribution of executable or object code is made by offering-access to copy from a designated place, then offering equivalent-access to copy the source code from the same place counts as-distribution of the source code, even though third parties are not-compelled to copy the source along with the object code.--\item-You may not copy, modify, sublicense, or distribute the Program-except as expressly provided under this License.  Any attempt-otherwise to copy, modify, sublicense or distribute the Program is-void, and will automatically terminate your rights under this License.-However, parties who have received copies, or rights, from you under-this License will not have their licenses terminated so long as such-parties remain in full compliance.--\item-You are not required to accept this License, since you have not-signed it.  However, nothing else grants you permission to modify or-distribute the Program or its derivative works.  These actions are-prohibited by law if you do not accept this License.  Therefore, by-modifying or distributing the Program (or any work based on the-Program), you indicate your acceptance of this License to do so, and-all its terms and conditions for copying, distributing or modifying-the Program or works based on it.--\item-Each time you redistribute the Program (or any work based on the-Program), the recipient automatically receives a license from the-original licensor to copy, distribute or modify the Program subject to-these terms and conditions.  You may not impose any further-restrictions on the recipients' exercise of the rights granted herein.-You are not responsible for enforcing compliance by third parties to-this License.--\item-If, as a consequence of a court judgment or allegation of patent-infringement or for any other reason (not limited to patent issues),-conditions are imposed on you (whether by court order, agreement or-otherwise) that contradict the conditions of this License, they do not-excuse you from the conditions of this License.  If you cannot-distribute so as to satisfy simultaneously your obligations under this-License and any other pertinent obligations, then as a consequence you-may not distribute the Program at all.  For example, if a patent-license would not permit royalty-free redistribution of the Program by-all those who receive copies directly or indirectly through you, then-the only way you could satisfy both it and this License would be to-refrain entirely from distribution of the Program.--If any portion of this section is held invalid or unenforceable under-any particular circumstance, the balance of the section is intended to-apply and the section as a whole is intended to apply in other-circumstances.--It is not the purpose of this section to induce you to infringe any-patents or other property right claims or to contest validity of any-such claims; this section has the sole purpose of protecting the-integrity of the free software distribution system, which is-implemented by public license practices.  Many people have made-generous contributions to the wide range of software distributed-through that system in reliance on consistent application of that-system; it is up to the author/donor to decide if he or she is willing-to distribute software through any other system and a licensee cannot-impose that choice.--This section is intended to make thoroughly clear what is believed to-be a consequence of the rest of this License.--\item-If the distribution and/or use of the Program is restricted in-certain countries either by patents or by copyrighted interfaces, the-original copyright holder who places the Program under this License-may add an explicit geographical distribution limitation excluding-those countries, so that distribution is permitted only in or among-countries not thus excluded.  In such case, this License incorporates-the limitation as if written in the body of this License.--\item-The Free Software Foundation may publish revised and/or new versions-of the General Public License from time to time.  Such new versions will-be similar in spirit to the present version, but may differ in detail to-address new problems or concerns.--Each version is given a distinguishing version number.  If the Program-specifies a version number of this License which applies to it and ``any-later version'', you have the option of following the terms and conditions-either of that version or of any later version published by the Free-Software Foundation.  If the Program does not specify a version number of-this License, you may choose any version ever published by the Free Software-Foundation.--\item-If you wish to incorporate parts of the Program into other free-programs whose distribution conditions are different, write to the author-to ask for permission.  For software which is copyrighted by the Free-Software Foundation, write to the Free Software Foundation; we sometimes-make exceptions for this.  Our decision will be guided by the two goals-of preserving the free status of all derivatives of our free software and-of promoting the sharing and reuse of software generally.--\begin{center}-{\Large\sc-No Warranty-}-\end{center}--\item-{\sc Because the program is licensed free of charge, there is no warranty-for the program, to the extent permitted by applicable law.  Except when-otherwise stated in writing the copyright holders and/or other parties-provide the program ``as is'' without warranty of any kind, either expressed-or implied, including, but not limited to, the implied warranties of-merchantability and fitness for a particular purpose.  The entire risk as-to the quality and performance of the program is with you.  Should the-program prove defective, you assume the cost of all necessary servicing,-repair or correction.}--\item-{\sc In no event unless required by applicable law or agreed to in writing-will any copyright holder, or any other party who may modify and/or-redistribute the program as permitted above, be liable to you for damages,-including any general, special, incidental or consequential damages arising-out of the use or inability to use the program (including but not limited-to loss of data or data being rendered inaccurate or losses sustained by-you or third parties or a failure of the program to operate with any other-programs), even if such holder or other party has been advised of the-possibility of such damages.}--\end{enumerate}---\begin{center}-{\Large\sc End of Terms and Conditions}-\end{center}--\subsection*{Appendix: How to Apply These Terms to Your New Programs}--If you develop a new program, and you want it to be of the greatest-possible use to the public, the best way to achieve this is to make it-free software which everyone can redistribute and change under these-terms.--  To do so, attach the following notices to the program.  It is safest to-  attach them to the start of each source file to most effectively convey-  the exclusion of warranty; and each file should have at least the-  ``copyright'' line and a pointer to where the full notice is found.--\begin{quote}-$<$one line to give the program's name and a brief idea of what it does.$>$ \\-Copyright (C) $<$year$>$  $<$name of author$>$ \\--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2 of the License, or-(at your option) any later version.--This program is distributed in the hope that it will be useful,-but WITHOUT ANY WARRANTY; without even the implied warranty of-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-GNU General Public License for more details.--You should have received a copy of the GNU General Public License-along with this program; if not, write to the Free Software-Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.-\end{quote}--Also add information on how to contact you by electronic and paper mail.--If the program is interactive, make it output a short notice like this-when it starts in an interactive mode:--\begin{quote}-Gnomovision version 69, Copyright (C) $<$year$>$  $<$name of author$>$ \\-Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. \\-This is free software, and you are welcome to redistribute it-under certain conditions; type `show c' for details.-\end{quote}---The hypothetical commands {\tt show w} and {\tt show c} should show the-appropriate parts of the General Public License.  Of course, the commands-you use may be called something other than {\tt show w} and {\tt show c};-they could even be mouse-clicks or menu items---whatever suits your-program.--You should also get your employer (if you work as a programmer) or your-school, if any, to sign a ``copyright disclaimer'' for the program, if-necessary.  Here is a sample; alter the names:--\begin{quote}-Yoyodyne, Inc., hereby disclaims all copyright interest in the program \\-`Gnomovision' (which makes passes at compilers) written by James Hacker. \\--$<$signature of Ty Coon$>$, 1 April 1989 \\-Ty Coon, President of Vice-\end{quote}---This General Public License does not permit incorporating your program-into proprietary programs.  If your program is a subroutine library, you-may consider it more useful to permit linking proprietary applications-with the library.  If this is what you want to do, use the GNU Library-General Public License instead of this License.
+ harness/Darcs/Test/Email.hs view
@@ -0,0 +1,105 @@+--  Copyright (C) 2002-2005,2007 David Roundy+--  Copyright (C) 2009 Reinier Lamers+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++-- | This module contains unit tests of the code in 'Darcs.Email'+--+-- These tests check whether the emails generated by darcs meet a few criteria.+-- We check for line length and non-ASCII characters. We apparently do not have+-- to check for CR-LF newlines because that's handled by sendmail.++module Darcs.Test.Email ( testSuite ) where++import Darcs.Prelude++import Data.Char ( isPrint )+import qualified Data.ByteString as B ( length, unpack, null, head,+                                        cons, empty, foldr, ByteString )+import qualified Data.ByteString.Char8 as BC ( unlines )+import Test.Framework ( Test, testGroup )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck.Instances.ByteString ()++import Darcs.Util.Printer ( text, renderPS, packedString )+import Darcs.UI.Email ( makeEmail, readEmail, formatHeader, prop_qp_roundtrip )+import Safe ( tailErr )++testSuite :: Test+testSuite = testGroup "Darcs.Email"+  [ emailParsing+  , emailHeaderNoLongLines+  , emailHeaderAsciiChars+  , emailHeaderLinesStart+  , emailHeaderNoEmptyLines+  , emailCodecRoundtrip+  ]++-- | Checks that darcs can read the emails it generates+emailParsing :: Test+emailParsing = testProperty "Checking that email can be parsed" $ \bs ->+    BC.unlines (B.empty:bs++[B.empty,B.empty]) ==+              readEmail (renderPS+                    $ makeEmail "reponame" [] (Just (text "contents\n"))+                                 Nothing+                                 (packedString $ BC.unlines bs) (Just "filename"))++-- | Check that formatHeader never creates lines longer than 78 characters+-- (excluding the carriage return and line feed)+emailHeaderNoLongLines :: Test+emailHeaderNoLongLines =+    testProperty "Checking email header line length" $ \field value ->+      let cleanField = cleanFieldString field+      in not $ any (>78) $ map B.length $ bsLines $ formatHeader cleanField value++-- Check that an email header does not contain non-ASCII characters+-- formatHeader doesn't escape field names, there is no such thing as non-ascii+-- field names afaik+emailHeaderAsciiChars :: Test+emailHeaderAsciiChars =+    testProperty "Checking email for illegal characters" $ \field value ->+      let cleanField = cleanFieldString field+      in not (any (>127) (B.unpack (formatHeader cleanField value)))++-- Check that header the second and later lines of a header start with a space+emailHeaderLinesStart :: Test+emailHeaderLinesStart =+    testProperty "Checking for spaces at start of folded email header lines" $ \field value ->+      let headerLines = bsLines (formatHeader cleanField value)+          cleanField  = cleanFieldString field+      in all (\l -> B.null l || B.head l == 32) (tailErr headerLines)++-- Checks that there are no lines in email headers with only whitespace+emailHeaderNoEmptyLines :: Test+emailHeaderNoEmptyLines =+    testProperty "Checking that there are no empty lines in email headers" $ \field value ->+      let headerLines = bsLines (formatHeader cleanField value)+          cleanField  = cleanFieldString field+          in all (not . B.null) headerLines --(not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines++emailCodecRoundtrip :: Test+emailCodecRoundtrip =+    testProperty "Checking that quoted printable en- then decoding is id" $ prop_qp_roundtrip++bsLines :: B.ByteString -> [B.ByteString]+bsLines = finalizeFold . B.foldr splitAtLines (B.empty, [])+  where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines)+        splitAtLines c  (thisLine, prevLines) = (B.cons c thisLine, prevLines)+        finalizeFold (lastLine, otherLines) = lastLine : otherLines++cleanFieldString :: String -> String+cleanFieldString = filter (\c -> isPrint c && c < '\x80' && c /= ':')+
+ harness/Darcs/Test/HashedStorage.hs view
@@ -0,0 +1,480 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Test.HashedStorage ( tests, unsafeMakeName ) where++import Prelude hiding ( filter, readFile, writeFile, lookup, (<$>) )+import qualified Prelude+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.ByteString.Char8 as BC+import System.Directory( doesFileExist, removeFile )+import Control.Monad ( when, forM_ )+import Control.Monad.Identity ( Identity, runIdentity )+import Control.Monad.Trans( lift )+import Control.Applicative( (<$>) )+import Codec.Archive.Zip( extractFilesFromArchive, toArchive )++import Data.Maybe+import Data.List( sort, intercalate, intersperse )++import Darcs.Repository.Inventory.Format ( peekPristineHash )+import Darcs.Repository.Paths ( hashedInventoryPath )++import Darcs.Util.Cache ( mkRepoCache )+import Darcs.Util.Path hiding ( setCurrentDirectory )+import Darcs.Util.Lock ( withPermDir )+import Darcs.Util.Tree hiding ( lookup )+import Darcs.Util.Index+import Darcs.Util.Tree.Hashed+import Darcs.Util.Hash+import Darcs.Util.Tree.Monad hiding ( tree, createDirectory )+import Darcs.Util.Tree.Plain++import System.Mem( performGC )++import qualified Data.Set as S++import Test.HUnit hiding ( path )+import Test.Framework( testGroup )+import qualified Test.Framework as TF ( Test )+import Test.QuickCheck+import Test.QuickCheck.Instances.ByteString ()++import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2++------------------------+-- Test Data+--++blobs :: [(AnchoredPath, BLC.ByteString)]+blobs = [ (unsafeFloatPath "foo_a", BLC.pack "a\n")+        , (unsafeFloatPath "foo_dir/foo_a", BLC.pack "a\n")+        , (unsafeFloatPath "foo_dir/foo_b", BLC.pack "b\n")+        , (unsafeFloatPath "foo_dir/foo_subdir/foo_a", BLC.pack "a\n")+        , (unsafeFloatPath "foo space/foo\nnewline", BLC.pack "newline\n")+        , (unsafeFloatPath "foo space/foo\\backslash", BLC.pack "backslash\n")+        , (unsafeFloatPath "foo space/foo_a", BLC.pack "a\n") ]++files :: [AnchoredPath]+files = map fst blobs++dirs :: [AnchoredPath]+dirs = [ unsafeFloatPath "foo_dir"+       , unsafeFloatPath "foo_dir/foo_subdir"+       , unsafeFloatPath "foo space" ]++emptyStub :: TreeItem IO+emptyStub = Stub (return emptyTree) Nothing++unsafeMakeName :: String -> Name+unsafeMakeName = either error id . makeName++testTree :: Tree IO+testTree =+    makeTree [ (unsafeMakeName "foo", emptyStub)+             , (unsafeMakeName "subtree", SubTree sub)+             , (unsafeMakeName "substub", Stub getsub Nothing) ]+    where sub = makeTree [ (unsafeMakeName "stub", emptyStub)+                         , (unsafeMakeName "substub", Stub getsub2 Nothing)+                         , (unsafeMakeName "x", SubTree emptyTree) ]+          getsub = return sub+          getsub2 = return $ makeTree [ (unsafeMakeName "file", File emptyBlob)+                                      , (unsafeMakeName "file2",+                                         File $ Blob (return $ BLC.pack "foo") Nothing) ]++equals_testdata :: Tree IO -> IO ()+equals_testdata t = sequence_ [+                     do isJust (findFile t p) @? show p ++ " in tree"+                        ours <- readBlob (fromJust $ findFile t p)+                        ours @?= stored+                     | (p, stored) <- blobs ] >>+                    sequence_ [ isJust (Prelude.lookup p blobs) @? show p ++ " extra in tree"+                                | (p, File _) <- list t ]++---------------------------+-- Test list+--++tests :: [TF.Test]+tests = [ testGroup "Darcs.Util.Hash" hash+        , testGroup "Darcs.Util.Tree" tree+        , testGroup "Darcs.Util.Index" index+        , testGroup "Darcs.Util.Tree.Monad" monad+        , testGroup "Hashed Storage" hashed ]++--------------------------+-- Tests+--++hashed :: [TF.Test]+hashed = [ testCase "plain has all files" have_files+         , testCase "pristine has all files" have_pristine_files+         , testCase "pristine has no extras" pristine_no_extra+         , testCase "pristine file contents match" pristine_contents+         , testCase "plain file contents match" plain_contents+         , testCase "writePlainTree works" write_plain ]+    where+      check_file t f = assertBool+                       ("path " ++ show f ++ " is missing in tree " ++ show t)+                       (isJust $ find t f)+      check_files = forM_ files . check_file++      pristine_no_extra = extractRepoAndRun $+       do+        t <- readDarcsPristine "." >>= expand+        forM_ (list t) $ \(path,_) -> assertBool (show path ++ " is extraneous in tree")+                                                 (path `elem` (dirs ++ files))+      have_files = extractRepoAndRun ( readPlainTree "." >>= expand >>= check_files )+      have_pristine_files = extractRepoAndRun ( readDarcsPristine "." >>= expand >>= check_files )++      pristine_contents = extractRepoAndRun $+       do+        t <- readDarcsPristine "." >>= expand+        equals_testdata t++      plain_contents = extractRepoAndRun $+       do+        t <- expand =<< filter nondarcs `fmap` readPlainTree "."+        equals_testdata t++      write_plain = extractRepoAndRun $+       do+        orig <- readDarcsPristine "." >>= expand+        writePlainTree orig "_darcs/plain"+        t <- expand =<< readPlainTree "_darcs/plain"+        equals_testdata t++index :: [TF.Test]+index = [ testCase "index versioning" check_index_versions+        , testCase "index listing" check_index+        , testCase "index content" check_index_content+        , testProperty "align bounded" prop_align_bounded+        , testProperty "align aligned" prop_align_aligned ]+    where pristine = readDarcsPristine "." >>= expand+          build_index =+            do x <- pristine+               exist <- doesFileExist "_darcs/index"+               performGC -- required in win32 to trigger file close+               when exist $ removeFile "_darcs/index"+               idx <- treeFromIndex =<< updateIndexFrom "_darcs/index" x+               return (x, idx)+          check_index = extractRepoAndRun $+            do (pris, idx) <- build_index+               (sort $ map fst $ list idx) @?= (sort $ map fst $ list pris)+          check_blob_pair p x y =+              do a <- readBlob x+                 b <- readBlob y+                 assertEqual ("content match on " ++ show p) a b+          check_index_content = extractRepoAndRun $+            do (_, idx) <- build_index+               plain <- readPlainTree "."+               x <- sequence $ zipCommonFiles check_blob_pair plain idx+               assertBool "files match" (length x > 0)+          check_index_versions = extractRepoAndRun $+            do performGC -- required in win32 to trigger file close+               Prelude.writeFile "_darcs/index" "nonsense index... do not crash!"+               valid <- indexFormatValid "_darcs/index"+               assertBool "index format invalid" $ not valid+          prop_align_bounded (bound, x) =+              bound > 0 && bound < 1024 && x >= 0 ==>+                    align bound x >= x && align bound x < x + bound+              where _types = (bound, x) :: (Int, Int)+          prop_align_aligned (bound, x) =+              bound > 0 && bound < 1024 && x >= 0 ==>+                    align bound x `rem` bound == 0+              where _types = (bound, x) :: (Int, Int)++tree :: [TF.Test]+tree = [ testCase "modifyTree" check_modify+       , testCase "complex modifyTree" check_modify_complex+       , testCase "modifyTree removal" check_modify_remove+       , testCase "expand" check_expand+       , testCase "expandPath" check_expand_path+       , testCase "expandPath of sub" check_expand_path_sub+       , testCase "diffTrees" check_diffTrees+       , testCase "diffTrees identical" check_diffTrees_ident+       , testProperty "expandPath" prop_expandPath+       , testProperty "shapeEq" prop_shape_eq+       , testProperty "expandedShapeEq" prop_expanded_shape_eq+       , testProperty "expand is identity" prop_expand_id+       , testProperty "filter True is identity" prop_filter_id+       , testProperty "filter False is empty" prop_filter_empty+       , testProperty "restrict both ways keeps shape" prop_restrict_shape_commutative+       , testProperty "restrict is a subtree of both" prop_restrict_subtree+       , testProperty "overlay keeps shape" prop_overlay_shape+       , testProperty "overlay is superset of over" prop_overlay_super ]+    where blob x = File $ Blob (return (BLC.pack x)) (Just $ sha256 $ BLC.pack x)+          name = unsafeMakeName+          check_modify =+              let t = makeTree [(name "foo", blob "bar")]+                  modify = modifyTree t (unsafeFloatPath "foo") (Just $ blob "bla")+               in do x <- readBlob $ fromJust $ findFile t (unsafeFloatPath "foo")+                     y <- readBlob $ fromJust $ findFile modify (unsafeFloatPath "foo")+                     assertEqual "old version" x (BLC.pack "bar")+                     assertEqual "new version" y (BLC.pack "bla")+                     assertBool "list has foo" $+                                isJust (Prelude.lookup (unsafeFloatPath "foo") $ list modify)+                     length (list modify) @?= 1+          check_modify_complex =+              let t = makeTree [ (name "foo", blob "bar")+                               , (name "bar", SubTree t1) ]+                  t1 = makeTree [ (name "foo", blob "bar") ]+                  modify = modifyTree t (unsafeFloatPath "bar/foo") (Just $ blob "bla")+               in do foo <- readBlob $ fromJust $ findFile t (unsafeFloatPath "foo")+                     foo' <- readBlob $ fromJust $ findFile modify (unsafeFloatPath "foo")+                     bar_foo <- readBlob $ fromJust $+                                findFile t (unsafeFloatPath "bar/foo")+                     bar_foo' <- readBlob $ fromJust $+                                 findFile modify (unsafeFloatPath "bar/foo")+                     assertEqual "old foo" foo (BLC.pack "bar")+                     assertEqual "old bar/foo" bar_foo (BLC.pack "bar")+                     assertEqual "new foo" foo' (BLC.pack "bar")+                     assertEqual "new bar/foo" bar_foo' (BLC.pack "bla")+                     assertBool "list has bar/foo" $+                                isJust (Prelude.lookup (unsafeFloatPath "bar/foo") $ list modify)+                     assertBool "list has foo" $+                                isJust (Prelude.lookup (unsafeFloatPath "foo") $ list modify)+                     length (list modify) @?= length (list t)+          check_modify_remove =+              let t1 = makeTree [(name "foo", blob "bar")]+                  t2 :: Tree Identity = makeTree [ (name "foo", blob "bar")+                                                 , (name "bar", SubTree t1) ]+                  modify1 = modifyTree t1 (unsafeFloatPath "foo") Nothing+                  modify2 = modifyTree t2 (unsafeFloatPath "bar") Nothing+                  file = findFile modify1 (unsafeFloatPath "foo")+                  subtree = findTree modify2 (unsafeFloatPath "bar")+               in do assertBool "file is gone" (isNothing file)+                     assertBool "subtree is gone" (isNothing subtree)++          no_stubs t = null [ () | (_, Stub _ _) <- list t ]+          path = unsafeFloatPath "substub/substub/file"+          badpath = unsafeFloatPath "substub/substub/foo"+          check_expand = do+            x <- expand testTree+            assertBool "no stubs in testTree" $ not (no_stubs testTree)+            assertBool "stubs in expanded tree" $ no_stubs x+            assertBool "path reachable" $ path `elem` (map fst $ list x)+            assertBool "badpath not reachable" $+                       badpath `notElem` (map fst $ list x)+          check_expand_path = do+            test_exp <- expand testTree+            t <- expandPath testTree path+            t' <- expandPath test_exp path+            t'' <- expandPath testTree $ unsafeFloatPath "substub/x"+            assertBool "path not reachable in testTree" $ path `notElem` (map fst $ list testTree)+            assertBool "path reachable in t" $ path `elem` (map fst $ list t)+            assertBool "path reachable in t'" $ path `elem` (map fst $ list t')+            assertBool "path reachable in t (with findFile)" $+                       isJust $ findFile t path+            assertBool "path reachable in t' (with findFile)" $+                       isJust $ findFile t' path+            assertBool "path not reachable in t''" $ path `notElem` (map fst $ list t'')+            assertBool "badpath not reachable in t" $+                       badpath `notElem` (map fst $ list t)+            assertBool "badpath not reachable in t'" $+                       badpath `notElem` (map fst $ list t')++          check_expand_path_sub = do+            t <- expandPath testTree $ unsafeFloatPath "substub"+            t' <- expandPath testTree $ unsafeFloatPath "substub/stub"+            t'' <- expandPath testTree $ unsafeFloatPath "subtree/stub"+            assertBool "leaf is not a Stub" $+                isNothing (findTree testTree $ unsafeFloatPath "substub")+            assertBool "leaf is not a Stub" $ isJust (findTree t $ unsafeFloatPath "substub")+            assertBool "leaf is not a Stub (2)" $ isJust (findTree t' $ unsafeFloatPath "substub/stub")+            assertBool "leaf is not a Stub (3)" $ isJust (findTree t'' $ unsafeFloatPath "subtree/stub")++          check_diffTrees = extractRepoAndRun $+                 do Prelude.writeFile "foo_dir/foo_a" "b\n"+                    working_plain <- filter nondarcs `fmap` readPlainTree "."+                    working <- treeFromIndex =<<+                                 updateIndexFrom "_darcs/index" working_plain+                    pristine <- readDarcsPristine "."+                    (working', pristine') <- diffTrees working pristine+                    let foo_work = findFile working' (unsafeFloatPath "foo_dir/foo_a")+                        foo_pris = findFile pristine' (unsafeFloatPath "foo_dir/foo_a")+                    working' `shapeEq` pristine'+                             @? show working' ++ " `shapeEq` " ++ show pristine'+                    assertBool "foo_dir/foo_a is in working'" $ isJust foo_work+                    assertBool "foo_dir/foo_a is in pristine'" $ isJust foo_pris+                    foo_work_c <- readBlob (fromJust foo_work)+                    foo_pris_c <- readBlob (fromJust foo_pris)+                    BLC.unpack foo_work_c @?= "b\n"+                    BLC.unpack foo_pris_c @?= "a\n"+                    assertEqual "working' tree is minimal" 2 (length $ list working')+                    assertEqual "pristine' tree is minimal" 2 (length $ list pristine')++          check_diffTrees_ident = do+            pristine <- readDarcsPristine "."+            (t1, t2) <- diffTrees pristine pristine+            assertBool "t1 is empty" $ null (list t1)+            assertBool "t2 is empty" $ null (list t2)++          prop_shape_eq x = no_stubs x ==> x `shapeEq` x+              where _types = x :: Tree Identity+          prop_expanded_shape_eq x = runIdentity $ expandedShapeEq x x+              where _types = x :: Tree Identity+          prop_expand_id x = no_stubs x ==> runIdentity (expand x) `shapeEq` x+              where _types = x :: Tree Identity+          prop_filter_id x = runIdentity $ expandedShapeEq x $ filter (\_ _ -> True) x+              where _types = x :: Tree Identity+          prop_filter_empty x = runIdentity $ expandedShapeEq emptyTree $ filter (\_ _ -> False) x+              where _types = x :: Tree Identity+          prop_restrict_shape_commutative (t1, t2) =+              no_stubs t1 && no_stubs t2 && not (restrict t1 t2 `shapeEq` emptyTree) ==>+                  restrict t1 t2 `shapeEq` restrict t2 t1+              where _types = (t1 :: Tree Identity, t2 :: Tree Identity)+          prop_restrict_subtree (t1, t2) =+              no_stubs t1 && not (restrict t1 t2 `shapeEq` emptyTree) ==>+                  let restricted = S.fromList (map fst $ list $ restrict t1 t2)+                      orig1 = S.fromList (map fst $ list t1)+                      orig2 = S.fromList (map fst $ list t2)+                   in and [restricted `S.isSubsetOf` orig1, restricted `S.isSubsetOf` orig2]+              where _types = (t1 :: Tree Identity, t2 :: Tree Identity)+          prop_overlay_shape (t1 :: Tree Identity, t2) =+              (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) ==>+              runIdentity $ (t1 `overlay` t2) `expandedShapeEq` t1+          prop_overlay_super (t1 :: Tree Identity, t2) =+              (Just LT == runIdentity (t2 `cmpExpandedShape` t1)) && no_stubs t2 ==>+              Just EQ == (runIdentity $ restrict t2 (t1 `overlay` t2) `cmpTree` t2)+          prop_expandPath (TreeWithPath t p) =+              notStub $ find (runIdentity $ expandPath t p) p+            where notStub (Just (Stub _ _)) = False+                  notStub Nothing = error "Did not exist."+                  notStub _ = True++hash :: [TF.Test]+hash = [ testProperty "decodeBase16 . encodeBase16 == Just" prop_base16 ]+    where prop_base16 x = (decodeBase16 . encodeBase16) x == Just x++monad :: [TF.Test]+monad = [ testCase "path expansion" check_virtual+        , testCase "rename" check_rename ]+    where check_virtual = virtualTreeMonad run testTree >> return ()+              where run = do file <- readFile (unsafeFloatPath "substub/substub/file")+                             file2 <- readFile (unsafeFloatPath "substub/substub/file2")+                             lift $ BLC.unpack file @?= ""+                             lift $ BLC.unpack file2 @?= "foo"+          check_rename = do (_, t) <- virtualTreeMonad run testTree+                            t' <- darcsAddMissingHashes =<< expand t+                            forM_ [ (p, i) | (p, i) <- list t' ] $ \(p,i) ->+                               assertBool ("have hash: " ++ show p) $ itemHash i /= Nothing+              where run = do rename (unsafeFloatPath "substub/substub/file") (unsafeFloatPath "substub/file2")++----------------------------------+-- Arbitrary instances+--++instance Arbitrary Hash where+    arbitrary = mkHash . BC.pack <$> sequence (replicate 32 arbitrary)++instance (Monad m) => Arbitrary (TreeItem m) where+  arbitrary = sized tree'+    where tree' 0 = oneof [ return (File emptyBlob), return (SubTree emptyTree) ]+          tree' n = oneof [ file n, subtree n ]+          file 0 = return (File emptyBlob)+          file _ = do content <- arbitrary+                      return (File $ Blob (return content) Nothing)+          subtree n = do branches <- choose (1, n)+                         let sub name = do t <- tree' ((n - 1) `div` branches)+                                           return (unsafeMakeName $ show name, t)+                         sublist <- mapM sub [0..branches]+                         oneof [ tree' 0+                               , return (SubTree $ makeTree sublist)+                               , return $ (Stub $ return (makeTree sublist)) Nothing ]++instance (Monad m) => Arbitrary (Tree m) where+  arbitrary = do item <- arbitrary+                 case item of+                   File _ -> arbitrary+                   Stub _ _ -> arbitrary+                   SubTree t -> return t++data TreeWithPath = TreeWithPath (Tree Identity) AnchoredPath deriving (Show)++instance Arbitrary TreeWithPath where+  arbitrary = do t <- arbitrary+                 p <- oneof $ return (AnchoredPath []) :+                             (map (return . fst) $ list (runIdentity $ expand t))+                 return $ TreeWithPath t p++---------------------------+-- Other instances+--++instance Show (Blob m) where+    show (Blob _ h) = "Blob " ++ show h++instance Show (TreeItem m) where+    show (File f) = "File (" ++ show f ++ ")"+    show (Stub _ h) = "Stub _ " ++ show h+    show (SubTree s) = "SubTree (" ++ show s ++ ")"++instance Show (Tree m) where+    show t = "Tree " ++ show (treeHash t) ++ " { " +++             (concat . intersperse ", " $ itemstrs) ++ " }"+        where itemstrs = map show $ listImmediate t++instance Show (Int -> Int) where+    show f = "[" ++ intercalate ", " (map val [1..20]) ++ " ...]"+        where val x = show x ++ " -> " ++ show (f x)++-----------------------+-- Test utilities+--++shapeEq :: Tree m -> Tree m -> Bool+shapeEq a b = Just EQ == cmpShape a b++expandedShapeEq :: Monad m => Tree m -> Tree m -> m Bool+expandedShapeEq a b = (Just EQ ==) <$> cmpExpandedShape a b++cmpcat :: [Maybe Ordering] -> Maybe Ordering+cmpcat (x:y:rest) | x == y = cmpcat (x:rest)+                  | x == Just EQ = cmpcat (y:rest)+                  | y == Just EQ = cmpcat (x:rest)+                  | otherwise = Nothing+cmpcat [x] = x+cmpcat [] = Just EQ -- empty things are equal++cmpTree :: Monad m => Tree m -> Tree m -> m (Maybe Ordering)+cmpTree x y = do x' <- expand x+                 y' <- expand y+                 con <- contentsEq x' y'+                 return $ cmpcat [cmpShape x' y', con]+    where contentsEq a b = cmpcat <$> sequence (zipTrees cmp a b)+          cmp _ (Just (File a)) (Just (File b)) = do a' <- readBlob a+                                                     b' <- readBlob b+                                                     return $ Just (compare a' b')+          cmp _ _ _ = return (Just EQ) -- neutral++cmpShape :: Tree m -> Tree m -> Maybe Ordering+cmpShape t r = cmpcat $ zipTrees cmp t r+    where cmp _ (Just a) (Just b) = a `item` b+          cmp _ Nothing (Just _) = Just LT+          cmp _ (Just _) Nothing = Just GT+          cmp _ Nothing Nothing = Just EQ+          item (File _) (File _) = Just EQ+          item (SubTree s) (SubTree p) = s `cmpShape` p+          item _ _ = Nothing++cmpExpandedShape :: (Monad m) => Tree m -> Tree m -> m (Maybe Ordering)+cmpExpandedShape a b = do x <- expand a+                          y <- expand b+                          return $ x `cmpShape` y++nondarcs :: AnchoredPath -> TreeItem m -> Bool+nondarcs (AnchoredPath (x:_)) _ | x == unsafeMakeName "_darcs" = False+                                     | otherwise = True+nondarcs (AnchoredPath []) _ = True++readDarcsPristine :: FilePath -> IO (Tree IO)+readDarcsPristine dir = do+  ph <- peekPristineHash <$> BC.readFile hashedInventoryPath+  readDarcsHashed (mkRepoCache dir) ph++extractRepoAndRun :: IO a -> IO a+extractRepoAndRun action = do+  zipFile <- toArchive . BLC.fromStrict <$> BC.readFile "harness/hstestdata.zip"+  withPermDir "_test_playground" $ \_ -> do+    extractFilesFromArchive [] zipFile+    action
+ harness/Darcs/Test/Misc.hs view
@@ -0,0 +1,173 @@+--  Copyright (C) 2002-2005,2007 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.Test.Misc ( testSuite ) where++import Darcs.Prelude++import Darcs.Util.ByteString+    ( unpackPSFromUTF8, fromHex2PS, fromPS2Hex+    , propHexConversion+    , prop_unlinesPS_linesPS_left_inverse+    , prop_linesPS_length+    , prop_unlinesPS_length+    , spec_betweenLinesPS+    , betweenLinesPS+    , linesPS, unlinesPS+    )+import Darcs.Util.Diff.Myers ( shiftBoundaries )++import Darcs.Test.Misc.CommandLine ( commandLineTestSuite )+import qualified Darcs.Test.Misc.Encoding as Encoding+import qualified Darcs.Test.Misc.Graph as Graph+import qualified Darcs.Test.Misc.URL as URL++import qualified Data.ByteString.Char8 as BC ( elem, unpack, pack )+import qualified Data.ByteString as B ( ByteString, empty, null )+import Data.Array.Base+import Data.Coerce ( coerce )+import Data.Maybe ( isJust )+import Control.Monad.ST+import Safe ( tailErr )+import Test.HUnit ( assertBool, assertEqual, assertFailure )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework ( Test, testGroup )+import Test.QuickCheck+import Test.QuickCheck.Instances.ByteString ()+++testSuite :: Test+testSuite = testGroup ""+ [ byteStringUtilsTestSuite+ , lcsTestSuite+ , commandLineTestSuite+ , Encoding.testSuite+ , Graph.testSuite+ , URL.testSuite+ ]+++-- ----------------------------------------------------------------------+-- * Darcs.Util.ByteString+-- ----------------------------------------------------------------------++byteStringUtilsTestSuite :: Test+byteStringUtilsTestSuite = testGroup "Darcs.Util.ByteString"+  [ testCase "UTF-8 packing and unpacking preserves 'hello world'"+           (assertBool "" (unpackPSFromUTF8 (BC.pack "hello world") == "hello world"))+  , testCase "Checking that hex packing and unpacking preserves 'hello world'"+           (assertEqual "" (fmap BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world"))+                           (Right "hello world"))+  , testProperty "Checking that hex conversion works" propHexConversion+  , testProperty "unlinesPS is left inverse of linesPS" prop_unlinesPS_linesPS_left_inverse+  , testProperty "linesPS is right inverse of unlinesPS" prop_linesPS_unlinesPS_right_inverse+  , testProperty "linesPS length property" prop_linesPS_length+  , testProperty "unlinesPS length property" prop_unlinesPS_length+  , testProperty "betweenLinesPS behaves like its spec" prop_betweenLinesPS+  ]++{- | 'SimpleLines' newtype wrapper for 'B.ByteString' tweaks the+probabilities in favor of newline characters and line collisions. With the+instance below the probability that betweenLinesPS succeeds in+prop_betweenLinesPS should be roughly 6%.++Unfortunately the QC adapter for test-framework does not display the+classification. To see it run++> ghci -isrc -iharness -XTypeSynonymInstances -XFlexibleInstances \+  -XFlexibleContexts -XRankNTypes -XBangPatterns harness/Darcs/Test/Misc.hs++and then manually issue++> quickCheck prop_betweenLinesPS+-}+newtype SimpleLines = SimpleLines { unwrapSimpleLines :: B.ByteString } deriving Show++instance Arbitrary SimpleLines where+  arbitrary = SimpleLines . BC.pack <$> listOf (elements ['a','b','\n'])++-- | A non-empty 'SimpleLines' without newlines.+newtype SimpleLine = SimpleLine B.ByteString deriving Show++instance Arbitrary SimpleLine where+  arbitrary = SimpleLine <$> (unwrapSimpleLines <$> arbitrary) `suchThat` condition+    where+      condition s = not (B.null s) && not (BC.elem '\n' s)++prop_betweenLinesPS :: SimpleLine -> SimpleLine -> SimpleLines -> Property+prop_betweenLinesPS (SimpleLine start) (SimpleLine end) (SimpleLines ps) =+  let result = betweenLinesPS start end ps in+  classify (isJust result) "non-trivial" $+  result == spec_betweenLinesPS start end ps++-- | A non-empty 'B.ByteString' without newlines.+newtype Line = Line B.ByteString deriving Show++instance Arbitrary Line where+  arbitrary = Line <$> arbitrary `suchThat` condition+    where+      condition s = not (B.null s) && not (BC.elem '\n' s)++prop_linesPS_unlinesPS_right_inverse :: [Line] -> Bool+prop_linesPS_unlinesPS_right_inverse x =+  let x' = coerce x in+    linesPS (unlinesPS x') == if null x' then [B.empty] else x'++-- ----------------------------------------------------------------------+-- * LCS+-- Here are a few quick tests of the shiftBoundaries function.+-- ----------------------------------------------------------------------++lcsTestSuite :: Test+lcsTestSuite = testGroup "LCS"+ [ testCase "lcs code" (mapM_ assertFailure showLcsTests)+ ]++showLcsTests :: [String]+showLcsTests = concatMap checkKnownShifts knownShifts+checkKnownShifts :: ([Int],[Int],String,String,[Int],[Int])+                   -> [String]+checkKnownShifts (ca, cb, sa, sb, ca', cb') = runST (+    do ca_arr <- newListArray (0, length ca) $ toBool (0:ca)+       cb_arr <- newListArray (0, length cb) $ toBool (0:cb)+       let p_a = listArray (0, length sa) $ B.empty:(toPS sa)+           p_b = listArray (0, length sb) $ B.empty:(toPS sb)+       shiftBoundaries ca_arr cb_arr p_a 1 1+       shiftBoundaries cb_arr ca_arr p_b 1 1+       ca_res <- fmap (fromBool . tailErr) $ getElems ca_arr+       cb_res <- fmap (fromBool . tailErr) $ getElems cb_arr+       return $ if ca_res  == ca' && cb_res == cb' then []+                else ["shiftBoundaries failed on "++sa++" and "++sb++" with "+                      ++(show (ca,cb))++" expected "++(show (ca', cb'))+                      ++" got "++(show (ca_res, cb_res))++"\n"])+ where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c])+       toBool = map (>0)+       fromBool = map (\b -> if b then 1 else 0)++knownShifts :: [([Int],[Int],String,String,[Int],[Int])]+knownShifts =+  [([0,0,0],[0,1,0,1,0],"aaa","aaaaa",+    [0,0,0],[0,0,0,1,1]),+   ([0,1,0],[0,1,1,0],"cd ","c a ",+    [0,1,0],[0,1,1,0]),+   ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}",+    [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end+   ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}",+    [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end+   ([],[1,1],"","aa",[],[1,1]),+   ([1,1],[],"aa","",[1,1],[])]
+ harness/Darcs/Test/Misc/CommandLine.hs view
@@ -0,0 +1,43 @@+module Darcs.Test.Misc.CommandLine+  (+    commandLineTestSuite+  ) where++import Darcs.Prelude++import Test.HUnit ( assertEqual, assertFailure )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework ( Test, testGroup )++import Darcs.Util.CommandLine ( parseCmd )++formatTable :: [(Char, String)]+formatTable = [('s',"<insert subject here>"),+               ('a',"<insert author here>"),+               ('d',"date")+              ]++testParser :: (String, ([String], Bool)) -> Test+testParser (s, ok) =+  testCase ("Parse: " ++ show s) $+    case parseCmd formatTable s of+      Left e -> assertFailure $ "Parser failed with: " ++ show e+      Right res -> assertEqual ("Parsing: " ++ show s) ok res++testCases :: [(String, ([String], Bool))]+testCases = [("a b",(["a","b"], False)),+             ("a b %<",(["a","b"], True)),+             ("a b %< ",(["a","b"], True)),+             ("\"arg0 contains spaces \\\"quotes\\\"\" b",+              (["arg0 contains spaces \"quotes\"","b"],False)),+             ("a %s %<",(["a","<insert subject here>"], True)),+             ("\"%d\"", (["date"], False)),+             ("\"d %d\"", (["d date"], False)),+             ("\\\a", (["\\\a"], False)),+             ("\"\\\a\"", (["\a"], False)),+             ("\"/foo:%d\"", (["/foo:date"], False))+            ]++commandLineTestSuite :: Test+commandLineTestSuite =+  testGroup "Darcs.Util.CommandLine" $ map testParser testCases
+ harness/Darcs/Test/Misc/Encoding.hs view
@@ -0,0 +1,43 @@+module Darcs.Test.Misc.Encoding ( testSuite ) where++import Darcs.Prelude++import qualified Data.ByteString as B+import Control.Monad+import Data.Word+import System.IO.Unsafe++import Darcs.Util.Encoding++import Test.Framework ( Test, testGroup )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck++decodeThenEncode :: B.ByteString -> B.ByteString+decodeThenEncode = unsafePerformIO . (decode >=> encode)++testSuite :: Test+testSuite = testGroup "Darcs.Util.Encoding"+ [ testProperty "decode then encode roundtrips" propDecodeThenEncodeRoundTrip+ ]++-- could use the bytestring-arbitrary package,+-- but the shrinking isn't as effective as 'shrinkList shrink'+newtype MyByteString = MBS { _mbsBytes :: [Word8] }+ deriving Show++instance Arbitrary MyByteString where+  arbitrary =+    MBS <$> frequency+      -- make sure we test some very long ByteStrings+      [ (1, sized (\n -> vectorOf (100*n) arbitrary))+      , (9, sized (\n -> vectorOf n arbitrary))+      ]+  shrink (MBS ws) = MBS <$> shrinkList shrink ws++toBS :: MyByteString -> B.ByteString+toBS (MBS ws) = B.pack ws++propDecodeThenEncodeRoundTrip :: MyByteString -> Bool+propDecodeThenEncodeRoundTrip mbs =+  let bstr = toBS mbs in decodeThenEncode bstr == bstr
+ harness/Darcs/Test/Misc/Graph.hs view
@@ -0,0 +1,58 @@+{- | Calculating the properties of graph algorithms scales very badly+because the specifications aren't optimised (naturally). Exhaustive testing+is a lot more effective than randomized testing in this case because it+avoids computations on large graphs. -}++{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Test.Misc.Graph ( testSuite ) where++import Darcs.Prelude++import Darcs.Util.Graph+  ( Graph+  , Component+  , genGraphs+  , genComponents+  , prop_ltmis_eq_bkmis+  , prop_ltmis_maximal_independent_sets+  , prop_ltmis_all_maximal_independent_sets+  , prop_components+  )++import Test.Framework+    ( Test+    , plusTestOptions+    , testGroup+    , topt_maximum_generated_tests+    )+import Test.Framework.Providers.LeanCheck ( testProperty )+import Test.LeanCheck++testSuite :: Test+testSuite =+  {- Unfortunately, test-framework is a bit limited in that it doesn't allow+  to scale the number of tests, just to set them to a fixed value. We opt to+  set it to 0x8000 which roughly covers the graphs up to size 6 and+  completes reasonably fast. The estimate is not precise because it doesn't+  account for graphs with more than one component; however, the overall+  error is not big because the majority of graphs have only one component,+  e.g. for graphs of size 6 the average number of components is 1.22. -}+  plusTestOptions (mempty { topt_maximum_generated_tests = Just 0x8000 }) $+  testGroup "Darcs.Util.Graph"+  [ testProperty "ltmis is equivalent to bkmis" prop_ltmis_eq_bkmis+  , testProperty+      "ltmis generates only maximal independent sets"+      prop_ltmis_maximal_independent_sets+  , testProperty+      "ltmis generates all maximal independent sets"+      prop_ltmis_all_maximal_independent_sets+  , testProperty+      "components generates all connected components"+      prop_components+  ]++instance Listable Graph where+  tiers = map genGraphs [0..]++instance Listable Component where+  tiers = map genComponents [0..]
+ harness/Darcs/Test/Misc/URL.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}+module Darcs.Test.Misc.URL ( testSuite ) where++import Darcs.Prelude++import Test.HUnit ( assertEqual )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework ( Test, testGroup )++import Darcs.Util.URL ( isValidLocalPath, isHttpUrl, isSshUrl )++cases :: [(String, Bool, Bool, Bool)]+cases =+  -- input                                local   http    ssh+  [ ("http://host.domain/path/to/repo",   False,  True,   False)+  , ("https://host.domain/path/to/repo",  False,  True,   False)+  , ("http://host.domain/path:to/repo",   False,  True,   False)+  , ("https://host.domain/path:to/repo",  False,  True,   False)+  , ("http://host.domain/",               False,  True,   False)+  , ("https://host.domain/",              False,  True,   False)+#ifdef WIN32+  -- local paths valid only on Windows+  , ("a:/",                               True,   False,  False)+  , ("b:/absolute/path",                  True,   False,  False)+  , ("c:relative/path",                   True,   False,  False)+  , ("d:.",                               True,   False,  False)+  , ("e:..",                              True,   False,  False)+  , ("f:./relative/path",                 True,   False,  False)+  , ("g:../relative/path",                True,   False,  False)+  , ("A:\\",                              True,   False,  False)+  , ("B:\\absolute\\path",                True,   False,  False)+  , ("C:relative\\path",                  True,   False,  False)+  , ("D:.",                               True,   False,  False)+  , ("E:..",                              True,   False,  False)+  , ("F:.\\relative\\path",               True,   False,  False)+  , ("G:..\\relative\\path",              True,   False,  False)+#else+  -- local paths valid only on Posix+  , ("/absolute/path:with/colons",        True,   False,  False)+  , ("relative/path:with/colons",         True,   False,  False)+  , ("./relative/path:with/colons",       True,   False,  False)+  , ("../relative/path:with/colons",      True,   False,  False)+#endif+  , ("/",                                 True,   False,  False)+  , ("/absolute/path",                    True,   False,  False)+  , ("/absolute/path",                    True,   False,  False)+  , ("relative/path",                     True,   False,  False)+  , (".",                                 True,   False,  False)+  , ("..",                                True,   False,  False)+  , ("./relative/path",                   True,   False,  False)+  , ("../relative/path",                  True,   False,  False)+  -- ssh "URL"s+  , ("user@host:/path/to/repo",           False,  False,  True)+  , ("host:/path/to/repo",                False,  False,  True)+  , ("user@host:/path:with/colons/",      False,  False,  True)+  , ("host:/path:with/colons/",           False,  False,  True)+  ]++test :: (String, Bool, Bool, Bool) -> Test+test (input, local, http, ssh) = testCase input $ do+  assertEqual "isValidLocalPath" (isValidLocalPath input) local+  assertEqual "isHttpUrl" (isHttpUrl input) http+  assertEqual "isSshUrl" (isSshUrl input) ssh++testSuite :: Test+testSuite = testGroup "Darcs.Util.URL" $ map test cases
+ harness/Darcs/Test/Patch.hs view
@@ -0,0 +1,111 @@+--  Copyright (C) 2002-2005,2007 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.Test.Patch ( testSuite ) where++import Darcs.Prelude++import Test.Framework ( Test, testGroup )++import Darcs.Patch.Witnesses.Show+import Darcs.Patch.FromPrim ( PrimOf )+import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim )+import Darcs.Patch.V1 ( RepoPatchV1 )+import Darcs.Patch.V2.RepoPatch ( RepoPatchV2 )+import Darcs.Patch.V3 ( RepoPatchV3 )+import Darcs.Patch.Commute ( Commute(..) )++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Named ()+import Darcs.Test.Patch.Arbitrary.PrimFileUUID()+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Arbitrary.RepoPatchV1 ()+import Darcs.Test.Patch.Arbitrary.RepoPatchV2 ()+import Darcs.Test.Patch.Arbitrary.RepoPatchV3 ()+import Darcs.Test.Patch.Arbitrary.PrimV1 ()+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.WithState ( ShrinkModel )++import qualified Darcs.Test.Patch.Depends+import qualified Darcs.Test.Patch.Info+import qualified Darcs.Test.Patch.Selection++import Darcs.Test.Patch.Properties++import qualified Darcs.Test.Patch.Rebase as Rebase+import qualified Darcs.Test.Patch.Unwind as Unwind++type Prim1 = V1.Prim+type Prim2 = V2.Prim++-- tests (either QuickCheck or Unit) that should be run on any type of patch+general_patchTests+  :: forall p+   . ( ArbitraryRepoPatch p, CheckedMerge p+     , PrimBased p, Commute (OnlyPrim p), ArbitraryPrim (OnlyPrim p)+     , ShrinkModel (PrimOf p)+     , Show1 (ModelOf (PrimOf p)), Show2 p+     )+  => [Test]+general_patchTests =+     [ testGroup "Rebase patches" $ Rebase.testSuite @p+     , testGroup "Unwind" $ Unwind.testSuite @p+     ]++-- | This is the big list of tests that will be run using testrunner.+testSuite :: [Test]+testSuite =+    [ primTests+    , repoPatchV1Tests+    , repoPatchV2Tests+    , repoPatchV3Tests+    , Darcs.Test.Patch.Depends.testSuite+    , Darcs.Test.Patch.Info.testSuite+    , Darcs.Test.Patch.Selection.testSuite+    ]+  where+    primTests = testGroup "Prim patches"+      [ testGroup "V1.Prim wrapper for Prim.V1" $ qc_prim @Prim1+      , testGroup "V2.Prim wrapper for Prim.V1" $ qc_prim @Prim2+      , testGroup "Prim.FileUUID" $ qc_prim @FileUUID.Prim+      , testGroup "NamedPrim over V2.Prim" $ qc_named_prim @Prim2+      , testGroup "NamedPrim over Prim.FileUUID" $ qc_named_prim @FileUUID.Prim+      ]+    repoPatchV1Tests = testGroup "RepoPatchV1"+      [ testGroup "using V1.Prim wrapper for Prim.V1" $+          unit_V1P1 ++ qc_V1P1 +++          general_patchTests @(RepoPatchV1 Prim1)+      ]+    repoPatchV2Tests = testGroup "RepoPatchV2"+      [ testGroup "using V2.Prim wrapper for Prim.V1" $+          unit_V2P1 ++ qc_V2 (undefined :: Prim2 wX wY) +++          general_patchTests @(RepoPatchV2 Prim2)+      , testGroup "using Prim.FileUUID" $+          qc_V2 (undefined :: FileUUID.Prim wX wY) +++          general_patchTests @(RepoPatchV2 FileUUID.Prim)+      ]+    repoPatchV3Tests = testGroup "RepoPatchV3"+      [ testGroup "using V2.Prim wrapper for Prim.V1" $+          qc_V3 (undefined :: Prim2 wX wY) +++          general_patchTests @(RepoPatchV3 Prim2)+      , testGroup "using Prim.FileUUID" $+          qc_V3 (undefined :: FileUUID.Prim wX wY) +++          general_patchTests @(RepoPatchV3 FileUUID.Prim)+      ]
+ harness/Darcs/Test/Patch/Arbitrary/Generic.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Arbitrary.Generic+  ( ArbitraryPrim(..)+  , ShrinkPrim+  , TestablePrim+  , PrimBased(..)+  , NullPatch(..)+  , RepoModel(..)+  , MightBeEmptyHunk(..)+  , MightHaveDuplicate(..)+  , nontrivialCommute+  , nontrivialTriple+  , nontrivialMerge+  , notDuplicatestriple+  ) where++import Darcs.Prelude++import Data.Constraint (Dict(..))++import Darcs.Test.Patch.Arbitrary.Shrink+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.V1Model+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Apply ( Apply, ApplyState )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Prim ( PrimCoalesce, PrimConstruct )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Show ( ShowPatchBasic )+import Darcs.Patch.Witnesses.Show++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 (RepoPatchV2) 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++nontrivialCommute :: (Commute p, Eq2 p) => Pair p wX wY -> Bool+nontrivialCommute (Pair (x :> y)) =+  case commute (x :> y) of+    Just (y' :> x') -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x)+    Nothing -> False++nontrivialMerge :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool+nontrivialMerge (x :\/: y) =+  case merge (x :\/: y) of+    y' :/\: x' -> not (y' `unsafeCompare` y) || not (x' `unsafeCompare` x)++nontrivialTriple :: (Eq2 p, Commute p) => (p :> p :> p) wX wY -> Bool+nontrivialTriple (a :> b :> c) =+  case commute (a :> b) of+    Nothing -> False+    Just (b' :> a') ->+      case commute (a' :> c) of+        Nothing -> False+        Just (c'' :> a'') ->+          case commute (b :> c) of+            Nothing -> False+            Just (c' :> b'') ->+              (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) &&+              (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) &&+              (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a'))++notDuplicatestriple :: MightHaveDuplicate p => (p :> p :> p) wX wY -> Bool+notDuplicatestriple (a :> b :> c) =+  not (hasDuplicate a || hasDuplicate b || hasDuplicate c)++class ( ArbitraryState prim+      , NullPatch prim+      , RepoModel (ModelOf prim)+      , Shrinkable prim+      )+      => ArbitraryPrim prim+    where+        -- hooks to disable certain kinds of tests for certain kinds of patches++        -- These tests depend on the PrimCoalesce class, which may not be+        -- implemented. By passing the implementation in explicitly only where+        -- it is available, we can avoid having to have dummy instances that+        -- won't be used.+        runCoalesceTests :: Maybe (Dict (PrimCoalesce prim))+        default runCoalesceTests :: PrimCoalesce prim => Maybe (Dict (PrimCoalesce prim))+        runCoalesceTests = Just Dict++        -- TODO in practice both hasPrimConstruct and usesV1Model will only work for V1 prims+        -- and their newtypes. Consider merging into one method.++        hasPrimConstruct :: Maybe (Dict (PrimConstruct prim))+        default hasPrimConstruct :: PrimConstruct prim => Maybe (Dict (PrimConstruct prim))+        hasPrimConstruct = Just Dict++        usesV1Model :: Maybe (Dict (ModelOf prim ~ V1Model))+        default usesV1Model :: ModelOf prim ~ V1Model => Maybe (Dict (ModelOf prim ~ V1Model))+        usesV1Model = Just Dict++type ShrinkPrim prim =+  ( ShrinkModel prim+  , PropagateShrink prim prim+  )++type TestablePrim prim =+  ( Apply prim, Commute prim, Invert prim, Eq2 prim+  , PatchListFormat prim, ShowPatchBasic prim, ReadPatch prim+  , RepoModel (ModelOf prim), ApplyState prim ~ RepoState (ModelOf prim)+  , ArbitraryPrim prim+  )++-- |Given a patch type that contains mergeable patches, such as+-- @RepoPatchV1 prim@ or @Named (RepoPatchV1 prim)@, construct the+-- equivalent conflict-free types, e.g. @prim@ / @Named prim@ respectively.+class ( Effect p, Show2 (OnlyPrim p), ArbitraryState (OnlyPrim p)+      , Shrinkable (OnlyPrim p), PropagateShrink (PrimOf p) (OnlyPrim p)+      , ModelOf p ~ ModelOf (OnlyPrim p)+      )+    => PrimBased p where+  type OnlyPrim p :: * -> * -> *+  primEffect :: OnlyPrim p wX wY -> FL (PrimOf p) wX wY+  liftFromPrim :: OnlyPrim p wX wY -> p wX wY++instance (Commute (OnlyPrim p), PrimBased p) => PrimBased (FL p) where+  type OnlyPrim (FL p) = FL (OnlyPrim p)+  primEffect = concatFL . mapFL_FL (primEffect @p)+  liftFromPrim = mapFL_FL liftFromPrim+
+ harness/Darcs/Test/Patch/Arbitrary/Named.hs view
@@ -0,0 +1,52 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Arbitrary.Named+  (+  ) where++import Darcs.Prelude++import Darcs.Test.Patch.Info ()+import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Shrink+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.WithState++import Darcs.Patch.Commute+import Darcs.Patch.Named+import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed++import Control.Applicative ( (<|>) )+import Test.QuickCheck++type instance ModelOf (Named prim) = ModelOf prim++instance ArbitraryState prim => ArbitraryState (Named prim) where+  arbitraryState rm = do+    info <- arbitrary+    Sealed (WithEndState prims rm') <- arbitraryState rm+    return $ Sealed $ WithEndState (NamedP info [] prims) rm'++instance (Commute p, Shrinkable p) => Shrinkable (Named p) where+  shrinkInternally (NamedP pi deps ps) =+    -- TODO this isn't quite right because other patches might+    -- explicitly depend on this one+    (\pi' -> NamedP pi' deps ps) <$> shrink pi+    <|>+    NamedP pi deps <$> shrinkInternally ps++  shrinkAtStart (NamedP pi deps ps) = mapFlipped (NamedP pi deps) <$> shrinkAtStart ps+  shrinkAtEnd (NamedP pi deps ps) = mapSeal (NamedP pi deps) <$> shrinkAtEnd ps++instance PropagateShrink prim p => PropagateShrink prim (Named p) where+  propagateShrink (prim :> NamedP pi deps ps) = do+    mps' :> mprim' <- propagateShrink (prim :> ps)+    return (mapMB_MB (NamedP pi deps) mps' :> mprim')++instance (Commute (OnlyPrim p), PrimBased p) => PrimBased (Named p) where+  type OnlyPrim (Named p) = Named (OnlyPrim p)++  primEffect (NamedP _ _ ps) = primEffect @(FL p) ps+  liftFromPrim (NamedP pi deps ps) = NamedP pi deps (liftFromPrim ps)
+ harness/Darcs/Test/Patch/Arbitrary/NamedPrim.hs view
@@ -0,0 +1,77 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE OverloadedStrings, UndecidableInstances #-}+module Darcs.Test.Patch.Arbitrary.NamedPrim ( aPatchId ) where++import Prelude ()+import Darcs.Prelude+import Test.QuickCheck ( arbitrarySizedNatural, suchThat, Gen )+import Test.QuickCheck.Gen ( chooseAny )++import Darcs.Patch.Prim.Named ( NamedPrim, namedPrim, PrimPatchId, unsafePrimPatchId )+import Darcs.Patch.Prim.WithName ( PrimWithName(..), wnPatch )+import Darcs.Util.Hash ( SHA1(..) )++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Shrink++import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Test.TestOnly.Instance ()++import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed++type instance ModelOf (NamedPrim p) = ModelOf p+instance+    ( RepoModel (ModelOf p)+    , ArbitraryState (NamedPrim p)+    , ArbitraryPrim p+    )+  => ArbitraryPrim (NamedPrim p) where+    runCoalesceTests = Nothing+    hasPrimConstruct = Nothing+    usesV1Model = Nothing++instance Shrinkable prim => Shrinkable (PrimWithName n prim) where+  shrinkInternally (PrimWithName n p) = PrimWithName n <$> shrinkInternally p+  shrinkAtEnd (PrimWithName n p) = mapSeal (PrimWithName n) <$> shrinkAtEnd p+  shrinkAtStart (PrimWithName n p) = mapFlipped (PrimWithName n) <$> shrinkAtStart p++instance MightBeEmptyHunk p => MightBeEmptyHunk (NamedPrim p) where+  isEmptyHunk = isEmptyHunk . wnPatch++instance MightHaveDuplicate (NamedPrim p)++instance NullPatch p => NullPatch (NamedPrim p) where+  nullPatch p = nullPatch (wnPatch p)++instance ArbitraryState prim => ArbitraryState (NamedPrim prim) where+  arbitraryState repo = do+    Sealed (WithEndState p repo') <- arbitraryState repo+    pid <- aPatchId+    return $ Sealed $ WithEndState (namedPrim pid p) repo'++  arbitraryStatePair repo = do+    Sealed (WithEndState (Pair (p1:>p2)) repo') <- arbitraryStatePair repo+    pid1 <- aPatchId+    pid2 <- aPatchId+    return $ Sealed $ WithEndState (Pair (namedPrim pid1 p1 :> namedPrim pid2 p2)) repo'++instance (ArbitraryState prim, RepoModel (ModelOf prim)) => ArbitraryWS (NamedPrim prim) where+  arbitraryWS = makeWS2Gen aSmallRepo++instance PropagateShrink prim1 prim2 => PropagateShrink prim1 (PrimWithName n2 prim2) where+  propagateShrink (p1 :> PrimWithName n2 p2) = do+    mp2' :> mp1' <- propagateShrink (p1 :> p2)+    return (mapMB_MB (PrimWithName n2) mp2' :> mp1')++aPatchId :: Gen PrimPatchId+aPatchId = unsafePrimPatchId <$> (arbitrarySizedNatural `suchThat` (> 0)) <*> aHash++aHash :: Gen SHA1+aHash =+  -- it's important to avoid hash collisions, so we use chooseAny rather+  -- than arbitrary so that the values generated are uniformly distributed+  SHA1 <$> chooseAny <*> chooseAny <*> chooseAny <*> chooseAny <*> chooseAny
+ harness/Darcs/Test/Patch/Arbitrary/PatchTree.hs view
@@ -0,0 +1,264 @@+-- UndecidableInstances was added because GHC 8.6 needed it+-- even though GHC 8.2 didn't+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}+module Darcs.Test.Patch.Arbitrary.PatchTree+  ( Tree(..)+  , TreeWithFlattenPos(..)+  , G2(..)+  , flattenOne+  , flattenTree+  , mapTree+  , commutePairFromTree+  , mergePairFromTree+  , commuteTripleFromTree+  , mergePairFromCommutePair+  , commutePairFromTWFP+  , mergePairFromTWFP+  , getPairs+  , getTriples+  , patchFromTree+  , canonizeTree+  ) where++import Darcs.Prelude++import Test.QuickCheck++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Util.QuickCheck ( bSized )++import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.FromPrim ( FromPrim(..), PrimOf )+import Darcs.Patch.Witnesses.Show++-- | A 'Tree' of patches 'p' starting at state 'wX' simulating+-- several branches of a repo. The end states of the branches+-- may of course differ.+data Tree p wX where+   NilTree :: Tree p wX+   SeqTree :: p wX wY -> Tree p wY -> Tree p wX+   ParTree :: Tree p wX -> Tree p wX -> Tree p wX++mapTree :: (forall wY wZ . p wY wZ -> q wY wZ) -> Tree p wX -> Tree q wX+mapTree _ NilTree = NilTree+mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)+mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)++instance Show2 p => Show (Tree p wX) where+   showsPrec _ NilTree = showString "NilTree"+   showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .+                               showsPrec2 (appPrec + 1) a . showString " " .+                               showsPrec (appPrec + 1) t+   showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .+                                 showsPrec (appPrec + 1) t1 . showString " " .+                                 showsPrec (appPrec + 1) t2++instance Show2 p => Show1 (Tree p)++instance Show2 p => Show1 (TreeWithFlattenPos p)++-- | The number of patches in a 'Tree'. This is the (common) length of all+-- elements of 'flattenTree'.+sizeTree :: Tree p wX -> Int+sizeTree NilTree = 0+sizeTree (SeqTree _ t) = 1 + sizeTree t+sizeTree (ParTree t1 t2) = sizeTree t1 + sizeTree t2++-- | The number of successive pairs in a flattened 'Tree'.+numPairs :: Tree p wX -> Int+numPairs t =+  case sizeTree t of+    0 -> 0+    s -> s - 1++-- | The number of successive triples in a flattened 'Tree'.+numTriples :: Tree p wX -> Int+numTriples t =+  case sizeTree t of+    0 -> 0+    1 -> 0+    s -> s - 2++newtype G2 l p wX wY = G2 { unG2 :: l (p wX wY) }++-- | All possible ways that the several branches of a 'Tree' can be+-- merged into a linear sequence.+flattenTree :: (Merge p) => Tree p wZ -> Sealed (G2 [] (FL p) wZ)+flattenTree NilTree = seal $ G2 $ return NilFL+flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t+flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2)) =+  seal $+  G2 $ do+    ps1 <- unG2 gpss1+    ps2 <- unG2 gpss2+    ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)+    -- We can't prove that the existential type in the result+    -- of merge will be the same for each pair of ps1 and ps2.+    map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']++-- | Generate a tree of patches, bounded by depth.+arbitraryTree :: ArbitraryState p => ModelOf p wX -> Int -> Gen (Tree p wX)+arbitraryTree rm depth+  | depth == 0 = return NilTree+    -- Note a probability of N for NilTree would imply ~(100*N)% of empty trees.+    -- For the purpose of this module empty trees are useless, but even when+    -- NilTree case is omitted there is still a small percentage of empty trees+    -- due to the generation of null-patches (empty-hunks) and the use of canonizeTree.+  | otherwise =+    frequency+      [ ( 1+        , do Sealed (WithEndState p rm') <- arbitraryState rm+             t <- arbitraryTree rm' (depth - 1)+             return (SeqTree p t))+      , ( 3+        , do t1 <- arbitraryTree rm (depth - 1)+             t2 <- arbitraryTree rm (depth - 1)+             return (ParTree t1 t2))+      ]++-- | Canonize a 'Tree', removing any dead branches.+canonizeTree :: NullPatch p => Tree p wX -> Tree p wX+canonizeTree NilTree = NilTree+canonizeTree (ParTree t1 t2)+    | NilTree <- canonizeTree t1 = canonizeTree t2+    | NilTree <- canonizeTree t2 = canonizeTree t1+    | otherwise = ParTree (canonizeTree t1) (canonizeTree t2)+canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t+                           | otherwise = SeqTree p (canonizeTree t)+++-- | Generate a patch to a certain state.+class ArbitraryStateIn s p where+  arbitraryStateIn :: s wX -> Gen (p wX)++instance (ArbitraryState p, s ~ ModelOf p) => ArbitraryStateIn s (Tree p) where+  -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).+  -- Note if we don't put a non-zero lower bound the first generated trees will+  -- always have depth 0.+  -- The minimum size of 3 means that we have a reasonable probability that the+  -- Tree has at least one triple.+  arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth++instance ( RepoModel model+         , ArbitraryPrim prim+         , model ~ ModelOf prim+         , ArbitraryState prim+         ) =>+         Arbitrary (Sealed (WithStartState model (Tree prim))) where+  arbitrary = do+    repo <- aSmallRepo+    Sealed . WithStartState repo <$>+      (canonizeTree <$> arbitraryStateIn repo) `suchThat` (\t -> numTriples t >= 1)++flattenOne :: (FromPrim p, Merge p) => Tree (PrimOf p) wX -> Sealed (FL p wX)+flattenOne NilTree = seal NilFL+flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromAnonymousPrim p :>: ps)+flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =+    case merge (ps1 :\/: ps2) of+      ps2' :/\: _ -> seal (ps1 +>+ ps2')++-- | A 'Tree' together with some number that is no greater than+-- the number of pairs in the 'Tree'.+data TreeWithFlattenPos p wX = TWFP Int (Tree p wX)++commutePairFromTWFP :: (FromPrim p, Merge p)+                    => (forall wY wZ . (p :> p) wY wZ -> t)+                    -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))+                    -> Maybe t+commutePairFromTWFP handlePair (Sealed (WithStartState _ (TWFP n t)))+    = unseal2 handlePair <$>+      let xs = unseal getPairs (flattenOne t)+      in if length xs > n && n >= 0 then Just (xs!!n) else Nothing++commutePairFromTree :: (FromPrim p, Merge p)+                    => (forall wY wZ . (p :> p) wY wZ -> t)+                    -> Sealed (WithStartState model (Tree (PrimOf p)))+                    -> Maybe t+commutePairFromTree handlePair (Sealed (WithStartState _ t))+   = unseal2 handlePair <$>+     let xs = unseal getPairs (flattenOne t)+     in if null xs then Nothing else Just (last xs)++commuteTripleFromTree :: (FromPrim p, Merge p)+                      => (forall wY wZ . (p :> p :> p) wY wZ -> t)+                      -> Sealed (WithStartState model (Tree (PrimOf p)))+                      -> Maybe t+commuteTripleFromTree handle (Sealed (WithStartState _ t))+   = unseal2 handle <$>+     case flattenOne t of+       Sealed ps ->+         let xs = getTriples ps+         in if null xs+            then Nothing+            else Just (last xs)++mergePairFromCommutePair :: Commute p+                         => (forall wY wZ . (p :\/: p) wY wZ -> t)+                         -> (forall wY wZ . (p :>   p) wY wZ -> t)+mergePairFromCommutePair handlePair (a :> b)+ = case commute (a :> b) of+     Just (b' :> _) -> handlePair (a :\/: b')+     Nothing -> handlePair (b :\/: b)++-- impredicativity problems mean we can't use (.) in the definitions below++mergePairFromTWFP :: (FromPrim p, Commute p, Merge p)+                  => (forall wY wZ . (p :\/: p) wY wZ -> t)+                  -> Sealed (WithStartState model (TreeWithFlattenPos (PrimOf p)))+                  -> Maybe t+mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)++mergePairFromTree :: (FromPrim p, Commute p, Merge p)+                  => (forall wY wZ . (p :\/: p) wY wZ -> t)+                  -> Sealed (WithStartState model (Tree (PrimOf p)))+                  -> Maybe t+mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)++patchFromCommutePair :: (forall wY wZ . p wY wZ -> t)+                     -> (forall wY wZ . (p :> p) wY wZ -> t)+patchFromCommutePair handle (_ :> b) = handle b++patchFromTree :: (FromPrim p, Merge p)+              => (forall wY wZ . p wY wZ -> t)+              -> Sealed (WithStartState model (Tree (PrimOf p)))+              -> Maybe t+patchFromTree x = commutePairFromTree (patchFromCommutePair x)+++instance Show2 p => Show (TreeWithFlattenPos p wX) where+   showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .+                            showsPrec (appPrec + 1) n . showString " " .+                            showsPrec1 (appPrec + 1) t++getPairs :: FL p wX wY -> [Sealed2 (p :> p)]+getPairs NilFL = []+getPairs (_:>:NilFL) = []+getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)++getTriples :: FL p wX wY -> [Sealed2 (p :> p :> p)]+getTriples NilFL = []+getTriples (_:>:NilFL) = []+getTriples (_:>:_:>:NilFL) = []+getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)++instance ( ArbitraryPrim prim+         , RepoModel (ModelOf prim)+         , model ~ ModelOf prim+         , ArbitraryState prim+         ) =>+         Arbitrary (Sealed (WithStartState model (TreeWithFlattenPos prim))) where+  arbitrary = do+    Sealed (WithStartState rm t) <- arbitrary+    case numPairs t of+      0 -> return $ Sealed $ WithStartState rm $ TWFP 0 NilTree+      num -> do+        n <- choose (0, num - 1)+        return $ Sealed $ WithStartState rm $ TWFP n t
+ harness/Darcs/Test/Patch/Arbitrary/PrimFileUUID.hs view
@@ -0,0 +1,167 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+module Darcs.Test.Patch.Arbitrary.PrimFileUUID where++import Prelude ()+import Darcs.Prelude++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Shrink+import Darcs.Test.Patch.RepoModel++import Test.QuickCheck+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Prim.FileUUID ()+import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Location(..), Hunk(..), UUID(..) )++import Darcs.Test.Patch.FileUUIDModel+import Darcs.Test.Util.QuickCheck ( notIn, maybeOf )++import qualified Data.ByteString as B+import Data.Maybe ( fromJust, isJust )+import qualified Data.Map as M++type instance ModelOf Prim = FileUUIDModel+instance ArbitraryPrim Prim where+    runCoalesceTests = Nothing+    hasPrimConstruct = Nothing+    usesV1Model = Nothing++-- TODO add some useful shrinking, at least to+-- shrinkAtEnd/shrinkAtStart+instance Shrinkable Prim where+  shrinkInternally _ = []+  shrinkAtEnd _ = []+  shrinkAtStart _ = []++instance MightBeEmptyHunk Prim+instance MightHaveDuplicate Prim++instance NullPatch Prim where+  nullPatch Identity = IsEq+  nullPatch (Hunk _ (H _ old new))+    | old == new = unsafeCoerceP IsEq+  nullPatch _ = NotEq++instance PropagateShrink Prim Prim where+  propagateShrink = propagatePrim++instance ShrinkModel Prim where+  -- no shrinking for now+  shrinkModelPatch _ = []++----------------------------------------------------------------------+-- * QuickCheck generators++aHunk :: B.ByteString -> Gen (Hunk wX wY)+aHunk content = do+  pos <- choose (0, B.length content)+  oldLen <- choose (0, B.length content - pos)+  new <- scale (`div` 8) aContent+  let old = B.take oldLen $ B.drop pos $ content+  return $ H pos old new++aTextHunk :: (UUID, Object Fail) -> Gen (Prim wX wY)+aTextHunk (uuid, (Blob text _)) =+  do h <- aHunk (unFail text)+     return $ Hunk uuid h+aTextHunk _ = error "impossible case"++aManifest :: UUID -> (UUID, Object Fail) -> Gen (Prim wX wY)+aManifest uuid (dirId, Directory dir) =+  do filename <- aFilename `notIn` (M.keys dir)+     return $ Manifest uuid (L dirId filename)+aManifest _ _ = error "impossible case"++aDemanifest :: UUID -> Location -> Gen (Prim wX wY)+aDemanifest uuid loc = return $ Demanifest uuid loc++-- | Generates any type of 'Prim' patch, except binary and setpref patches.+aPrim :: FileUUIDModel wX -> Gen (Sealed (WithEndState FileUUIDModel (Prim wX)))+aPrim repo+  = do mbFile <- maybeOf repoFiles -- some file, not necessarily manifested+       dir <- elements repoDirs -- some directory, not necessarily manifested+       -- note, the root directory always exists and is never manifested nor demanifested+       mbDemanifested <- maybeOf notManifested -- something not manifested+       mbManifested <- maybeOf manifested -- something manifested+       fresh <- anUUID `notIn` repoIds repo -- a fresh uuid+       let whenjust m x = if isJust m then x else 0+           whenfile = whenjust mbFile+           whendemanifested = whenjust mbDemanifested+           whenmanifested = whenjust mbManifested+       patch <- frequency+                  [ ( whenfile 12, aTextHunk $ fromJust mbFile ) -- edit an existing file+                  , ( 2, aTextHunk (fresh, Blob (return "") Nothing) ) -- edit a new file+                  , ( whendemanifested 2 -- manifest an existing object+                    , aManifest (fromJust mbDemanifested) dir+                    )+                  , ( whenmanifested 2+                    , uncurry aDemanifest $ fromJust mbManifested+                    )+                  ]+       let repo' = unFail $ repoApply repo patch+       return $ seal $ WithEndState patch repo'+  where+      manifested = [ (uuid, (L dirid name)) | (dirid, Directory dir) <- repoDirs+                                          , (name, uuid) <- M.toList dir ]+      notManifested = [ uuid | (uuid, _) <- nonRootObjects+                           , not (uuid `elem` map fst manifested) ]+      repoFiles = [ (uuid, Blob x y) | (uuid, Blob x y) <- repoObjects repo ]+      repoDirs  = [ (uuid, Directory x) | (uuid, Directory x) <- repoObjects repo ]+      nonRootObjects = filter notRoot $ repoObjects repo where+        notRoot (uuid, _) = uuid == rootId++----------------------------------------------------------------------+-- *** Pairs of primitive patches++-- Try to generate commutable pairs of hunks+hunkPair :: (UUID, Object Fail) -> Gen ((Prim :> Prim) wX wY)+hunkPair (uuid, (Blob file _)) =+  do h1@(H off1 old1 new1) <- aHunk (unFail file)+     (delta, content') <- selectChunk h1 (unFail file)+     H off2' old2 new2 <- aHunk content'+     let off2 = off2' + delta+     return (Hunk uuid (H off1 old1 new1) :> Hunk uuid (H off2 old2 new2))+  where+     selectChunk (H off old new) content = elements [prefix, suffix]+       where prefix = (0, B.take off content)+             suffix = (off + B.length new, B.drop (off + B.length old) content)+hunkPair _ = error "impossible case"++aPrimPair :: FileUUIDModel wX+          -> Gen (Sealed (WithEndState FileUUIDModel (Pair Prim wX)))+aPrimPair repo+  = do mbFile <- maybeOf repoFiles+       frequency+          [ ( if isJust mbFile then 1 else 0+            , do p1 :> p2 <- hunkPair $ fromJust mbFile+                 let repo'  = unFail $ repoApply repo  p1+                     repo'' = unFail $ repoApply repo' p2+                 return $ seal $ WithEndState (Pair (p1 :> p2)) repo''+            )+          , ( 1+            , do+                -- construct the underlying pair directly to avoid any+                -- risk of indirectly calling arbitraryStatePair (which+                -- would cause a loop).+                Sealed (WithEndState pair repo') <- arbitraryState repo+                return $ seal $ WithEndState (Pair pair) repo'+            )+          ]+  where+      repoFiles = [ (uuid, Blob x y) | (uuid, Blob x y) <- repoObjects repo ]++----------------------------------------------------------------------+-- Arbitrary instances++instance ArbitraryState Prim where+  arbitraryState = aPrim+  arbitraryStatePair = aPrimPair++instance ArbitraryWS Prim where+  arbitraryWS = makeWS2Gen aSmallRepo
+ harness/Darcs/Test/Patch/Arbitrary/PrimV1.hs view
@@ -0,0 +1,370 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Test.Patch.Arbitrary.PrimV1+    ( aPrim+    , aPrimPair+    ) where++import Prelude ()+import Darcs.Prelude++import qualified Darcs.Test.Patch.Arbitrary.Generic as T+import Darcs.Test.Patch.Arbitrary.Generic+    ( NullPatch(..)+    , MightBeEmptyHunk+    , MightHaveDuplicate+    , ArbitraryPrim+    )+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Arbitrary.Shrink++import Control.Applicative ( (<|>) )+import Test.QuickCheck+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Prim ( isIdentity )+import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk ) )+import qualified Darcs.Patch.Prim.V1.Core as Prim ( Prim( FP ) )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )++import Darcs.Test.Patch.V1Model+import Darcs.Util.Path+import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )++import Darcs.UI.Commands.Replace ( defaultToks )+import Darcs.Patch.Prim ( PrimPatch, PrimConstruct(..) )+import Darcs.Patch.Apply ( ApplyState )++import Control.Monad ( guard )+import qualified Data.ByteString.Char8 as BC+import Data.Maybe ( fromJust, isJust )++type Prim1 = V1.Prim+type Prim2 = V2.Prim++type instance ModelOf Prim1 = V1Model+type instance ModelOf Prim2 = V1Model++instance ArbitraryPrim Prim1+instance ArbitraryPrim Prim2++instance NullPatch Prim.Prim where+  nullPatch (Prim.FP _ fp) = nullPatch fp+  nullPatch p | IsEq <- isIdentity p = IsEq+  nullPatch _ = NotEq+deriving instance NullPatch Prim1+deriving instance NullPatch Prim2++instance NullPatch FilePatchType where+  nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe?+  nullPatch _ = NotEq++instance MightBeEmptyHunk Prim.Prim where+  isEmptyHunk (Prim.FP _ (Hunk _ [] [])) = True+  isEmptyHunk _ = False+deriving instance MightBeEmptyHunk Prim1+deriving instance MightBeEmptyHunk Prim2++instance MightHaveDuplicate Prim1+instance MightHaveDuplicate Prim2++-- TODO add some useful shrinking, at least to+-- shrinkAtEnd/shrinkAtStart+instance Shrinkable Prim.Prim where+  shrinkInternally _ = []+  shrinkAtEnd _ = []+  shrinkAtStart _ = []++deriving instance Shrinkable V1.Prim+deriving instance Shrinkable V2.Prim++----------------------------------------------------------------------+-- * QuickCheck generators++----------------------------------------------------------------------+-- ** FilePatchType generators++aHunk :: Content -> Gen (Int, [BC.ByteString], [BC.ByteString])+aHunk content+ = (sized $ \n ->+     do pos <- choose (1, contentLen+1)+        let prefixLen = pos-1+            restLen   = contentLen-prefixLen+        oldLen <- frequency+                      [ (75, choose (0, min restLen n))+                        -- produces small hunks common in real editing+                      , (25, choose (0, min 10 restLen))+                      ]+        -- newLen choice aims to cover all possibilities, that is,+        -- remove less/the same/more than added and empty the file.+        newLen <- frequency+                      [ ( 54+                        , choose (1,min 1 n)+                        )+                      , ( if oldLen /= 0 then 42 else 0+                        , choose (1,min 1 oldLen)+                        )+                      , ( if oldLen /= 0 then 2 else 0+                        , return oldLen+                        )+                      , ( if oldLen /= 0 then 2 else 0+                        , return 0+                        )+                      ]+        new <- vectorOf newLen aLine+        let old = take oldLen $ drop prefixLen $ content+        return (pos, old, new)) `suchThat` notEmptyHunk+  where+      contentLen = length content+      notEmptyHunk (_,old,new) = not (null old && null new)++aTokReplace :: Content -> Gen (String, String, String)+aTokReplace []+  = do w <- vectorOf 1 alpha+       w' <- vectorOf 1 alpha+       return (defaultToks, w, w')+aTokReplace content+  = do let fileWords = concatMap BC.words content+       wB <- elements fileWords+       w' <- alphaBS `notIn` fileWords+       return (defaultToks, BC.unpack wB, BC.unpack w')+  where+      alphaBS = do x <- alpha; return $ BC.pack [x]++----------------------------------------------------------------------+-- ** Prim generators++aHunkP :: PrimPatch prim => (AnchoredPath, File) -> Gen (prim wX wY)+aHunkP (path,file)+  = do (pos, old, new) <- aHunk content+       return $ hunk path pos old new+  where+      content = fileContent file++aTokReplaceP :: PrimPatch prim => (AnchoredPath,File) -> Gen (prim wX wY)+aTokReplaceP (path,file)+  = do (tokchars, old, new) <- aTokReplace content+       return $ tokreplace path tokchars old new+  where+      content = fileContent file++anAddFileP :: PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)+anAddFileP (path,dir)+  = do newFilename <- aFilename `notIn` existing+       let newPath = path `appendPath` newFilename+       return $ addfile newPath+  where+      existing = map fst $ filterFiles $ dirContent dir++aRmFileP :: PrimPatch prim+         => AnchoredPath   -- ^ Path of an empty file+         -> prim wX wY+aRmFileP path = rmfile path++anAddDirP :: PrimPatch prim => (AnchoredPath,Dir) -> Gen (prim wX wY)+anAddDirP (path,dir)+  = do newDirname <- aDirname `notIn` existing+       let newPath = path `appendPath` newDirname+       return $ adddir newPath+  where+      existing = map fst $ filterDirs $ dirContent dir++aRmDirP :: PrimPatch prim+        => AnchoredPath    -- ^ Path of an empty directory+        -> prim wX wY+aRmDirP path = rmdir path++aMoveP :: PrimPatch prim+       => Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (prim wX wY)+aMoveP nameGen oldPath (dirPath,dir)+  = do newName <- nameGen `notIn` existing+       let newPath = dirPath `appendPath` newName+       return $ move oldPath newPath+  where+      existing = map fst $ dirContent dir++aModelShrink :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelShrink repo =+  aModelShrinkName repo <|>+  aModelDeleteFile repo <|>+  aModelDeleteDir repo <|>+  aModelShrinkFileContent repo++shrinkPath :: AnchoredPath -> [AnchoredPath]+shrinkPath (AnchoredPath ps) = do+  ps' <- shrinkList shrinkName ps+  guard (not $ null ps')+  return $ AnchoredPath ps'++shrinkName :: Name -> [Name]+shrinkName n = do+  n' <- shrink (BC.unpack . encodeWhiteName $ n)+  guard (n' /= ".")+  guard (not $ null n')+  either (const []) (:[]) $ decodeWhiteName $ BC.pack n'++aModelShrinkName :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelShrinkName repo = do+  (oldPath, _) <- list repo+  newPath <- shrinkPath oldPath+  guard (newPath `notElem` map fst (list repo))+  return $ Sealed $ move oldPath newPath++aModelDeleteFile :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelDeleteFile repo = do+  (path, _) <- filterFiles (list repo)+  return $ Sealed $ rmfile path++aModelDeleteDir :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelDeleteDir repo = do+  (path, _) <- filterDirs (list repo)+  return $ Sealed $ rmdir path++aModelShrinkFileContent :: V1Model wX -> [Sealed (Prim.Prim wX)]+aModelShrinkFileContent repo = do+  (path, file) <- filterFiles (list repo)+  (pos, lineToRemove) <- zip [1..] $ fileContent file+  (return (Sealed $ hunk path pos [lineToRemove] [])+   <|>+   do+    smaller <- BC.pack <$> shrink (BC.unpack lineToRemove)+    return $ Sealed $ hunk path pos [lineToRemove] [smaller])+++-- | Generates any type of 'prim' patch, except binary and setpref patches.+aPrim :: forall prim wX . (PrimPatch prim, ApplyState prim ~ RepoState V1Model)+      => V1Model wX -> Gen (Sealed (WithEndState V1Model (prim wX)))+aPrim repo+  = do mbFile <- maybeOf repoFiles+       mbEmptyFile <- maybeOf $ filter (isEmpty . snd) repoFiles+       dir  <- elements (rootDir:repoDirs)+       mbOldDir <- maybeOf repoDirs+       mbEmptyDir <- maybeOf $ filter (isEmpty . snd) repoDirs+       patch <- frequency+                  [ ( if isJust mbFile then 12 else 0+                    , aHunkP $ fromJust mbFile+                    )+                  , ( if isJust mbFile then 6 else 0+                    , aTokReplaceP $ fromJust mbFile+                    )+                  , ( 2+                    , anAddFileP dir+                    )+                  , ( if isJust mbEmptyFile then 12 else 0+                    , return $ aRmFileP $ fst $ fromJust mbEmptyFile+                    )+                  , ( 2+                    , anAddDirP dir+                    )+                  , ( if isJust mbEmptyDir then 10 else 0+                    , return $ aRmDirP $ fst $ fromJust mbEmptyDir+                    )+                  , ( if isJust mbFile then 3 else 0+                    , aMoveP aFilename (fst $ fromJust mbFile) dir+                    )+                  , let oldPath = fst $ fromJust mbOldDir in+                    ( if isJust mbOldDir+                         && not (oldPath `isPrefix` fst dir)+                        then 4 else 0+                    , aMoveP aDirname oldPath dir+                    )+                  ]+       let repo' = unFail $ repoApply repo patch+       return $ seal $ WithEndState patch repo'+  where+      repoItems = list repo+      repoFiles = filterFiles repoItems+      repoDirs  = filterDirs repoItems+      rootDir   = (anchoredRoot,root repo)++----------------------------------------------------------------------+-- *** Pairs of primitive patches++-- Try to generate commutable pairs of hunks+hunkPairP :: PrimPatch prim => (AnchoredPath, File) -> Gen ((prim :> prim) wX wY)+hunkPairP (path,file)+  = do (l1, old1, new1) <- aHunk content+       (delta, content') <- selectChunk (Hunk l1 old1 new1) content+       (l2', old2, new2) <- aHunk content'+       let l2 = l2'+delta+       return (hunk path l1 old1 new1 :> hunk path l2 old2 new2)+  where+      content = fileContent file+      selectChunk (Hunk l old new) content_+        = elements [prefix, suffix]+        where+            start = l - 1+            prefix = (0, take start content_)+            suffix = (start + length new, drop (start + length old) content_)+      selectChunk _ _ = error "impossible case"++aPrimPair :: ( PrimPatch prim+             , ArbitraryState prim+             , ApplyState prim ~ RepoState V1Model+             , ModelOf prim ~ V1Model+             )+          => V1Model wX+          -> Gen (Sealed (WithEndState V1Model (Pair prim wX)))+aPrimPair repo+  = do mbFile <- maybeOf repoFiles+       frequency+          [ ( if isJust mbFile then 1 else 0+            , do p1 :> p2 <- hunkPairP $ fromJust mbFile+                 let repo'  = unFail $ repoApply repo p1+                     repo'' = unFail $ repoApply repo' p2+                 return $ seal $ WithEndState (Pair (p1 :> p2)) repo''+            )+          , ( 1+            , do+                -- construct the underlying pair directly to avoid any+                -- risk of indirectly calling arbitraryStatePair (which+                -- would cause a loop).+                Sealed (WithEndState pair repo') <- arbitraryState repo+                return $ seal $ WithEndState (Pair pair) repo'+            )+          ]+  where+      repoItems = list repo+      repoFiles = filterFiles repoItems++----------------------------------------------------------------------+-- Arbitrary instances++type instance ModelOf Prim.Prim = V1Model++instance ShrinkModel Prim.Prim where+  shrinkModelPatch s = aModelShrink s++-- Prim1++instance ArbitraryState Prim1 where+  arbitraryState = aPrim+  arbitraryStatePair = aPrimPair++instance ShrinkModel Prim1 where+  shrinkModelPatch s = map (mapSeal V1.Prim) $ shrinkModelPatch s++instance PropagateShrink Prim1 Prim1 where+  propagateShrink = propagatePrim++instance ArbitraryWS Prim1 where+  arbitraryWS = makeWS2Gen aSmallRepo++-- Prim2++instance ArbitraryState Prim2 where+  arbitraryState = aPrim+  arbitraryStatePair = aPrimPair++instance ShrinkModel Prim2 where+  shrinkModelPatch s = map (mapSeal V2.Prim) $ shrinkModelPatch s++instance PropagateShrink Prim2 Prim2 where+  propagateShrink = propagatePrim++instance ArbitraryWS Prim2 where+  arbitraryWS = makeWS2Gen aSmallRepo
+ harness/Darcs/Test/Patch/Arbitrary/RepoPatch.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE UndecidableInstances, ViewPatterns #-}+-- | Test case generator for patch with a Merge instance+module Darcs.Test.Patch.Arbitrary.RepoPatch+  ( withSingle+  , withPair+  , withTriple+  , withFork+  , withSequence+  , withAllSequenceItems+  , NotRepoPatchV1(..)+  , ArbitraryRepoPatch(..)+  ) where++import Darcs.Prelude++import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Arbitrary.Generic ( ArbitraryPrim(..), PrimBased )+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Test.Patch.Types.MergeableSequence ( mergeableSequenceToRL, MergeableSequence(..) )+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Ordered hiding ( Fork )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.V1 ( RepoPatchV1 )++import Data.Constraint+import Data.Void++data NotRepoPatchV1 p = NotRepoPatchV1 (forall prim . Dict (p ~ RepoPatchV1 prim) -> Void)++-- | Class to simplify type signatures and superclass constraints.+class+  ( RepoPatch p+  , ArbitraryPrim (PrimOf p)+  , ModelOf p ~ ModelOf (PrimOf p)+  , ApplyState p ~ RepoState (ModelOf p)+  ) => ArbitraryRepoPatch p where++  notRepoPatchV1 :: Maybe (NotRepoPatchV1 p)+++withSingle+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. p wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r+withSingle prop (Sealed2 (WithStartState2 _ ms))+  = case mergeableSequenceToRL ms of+      _ :<: pp -> Just (prop pp)+      _ -> Nothing++withPair+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. Pair p wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r+withPair prop (Sealed2 (WithStartState2 _ ms))+  = case mergeableSequenceToRL ms of+      _ :<: pp1 :<: pp2 -> Just (prop (Pair (pp1 :> pp2)))+      _ -> Nothing++withTriple+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. (p :> p :> p) wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r+withTriple prop (Sealed2 (WithStartState2 _ ms))+  = case mergeableSequenceToRL ms of+      _ :<: pp1 :<: pp2 :<: pp3 -> Just (prop (pp1 :> pp2 :> pp3))+      _ -> Nothing++withFork+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. (FL p :\/: FL p) wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> Maybe r+-- We can't use (MergeableSequence p:\/: MergeableSequence p) as the input because+-- the witnesses would be wrong, so just use MergeableSequence p and choose the+-- ParMS cases.+withFork prop (Sealed2 (WithStartState2 _ (ParMS ms1 ms2)))+  = Just (prop (reverseRL (mergeableSequenceToRL ms1) :\/: reverseRL (mergeableSequenceToRL ms2)))+withFork _ _ = Nothing++withSequence+  :: (CheckedMerge p, PrimBased p)+  => (forall wX wY. RL p wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> r+withSequence prop (Sealed2 (WithStartState2 _ ms))+  = prop (mergeableSequenceToRL ms)++withAllSequenceItems+  :: (CheckedMerge p, PrimBased p, Monoid r)+  => (forall wX wY. p wX wY -> r)+  -> Sealed2 (WithStartState2 (MergeableSequence p)) -> r+withAllSequenceItems prop (Sealed2 (WithStartState2 _ ms))+  = mconcat . mapRL prop . mergeableSequenceToRL $ ms+
+ harness/Darcs/Test/Patch/Arbitrary/RepoPatchV1.hs view
@@ -0,0 +1,79 @@+-- Copyright (C) 2002-2003,2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Arbitrary.RepoPatchV1 (Patch) where++import Prelude ()+import Darcs.Prelude++import Control.Exception ( try, evaluate, SomeException )+import System.IO.Unsafe++import Darcs.Patch+import Darcs.Patch.V1 ()+import Darcs.Patch.V1.Core ( RepoPatchV1(..) )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+++import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate, ArbitraryPrim, PrimBased(..) )+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge(..) )+import Darcs.Test.Patch.RepoModel ( RepoState, ModelOf )+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Test.Patch.WithState+  ( PropagateShrink(..)+  , ArbitraryState(..), WithEndState(..)+  )++type Patch = RepoPatchV1 V1.Prim++instance+  (ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))+  => ArbitraryRepoPatch (RepoPatchV1 prim)+  where++    notRepoPatchV1 = Nothing++instance PrimPatch prim => CheckedMerge (RepoPatchV1 prim) where+  validateMerge v =+    case unsafePerformIO (try (evaluate v)) of+      Left (_ :: SomeException) -> Nothing+      Right x -> Just x++instance MightHaveDuplicate (RepoPatchV1 prim)++type instance ModelOf (RepoPatchV1 prim) = ModelOf prim++instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) => PrimBased (RepoPatchV1 prim) where+  type OnlyPrim (RepoPatchV1 prim) = prim+  primEffect prim = prim :>: NilFL+  liftFromPrim = PP++-- TODO: this instance only exists because of the history of the V1 QuickCheck tests+-- (qc_V1P1 in D.T.Patch). The QuickCheck tests for V1, V2, V3 etc should be aligned+-- and this instance removed.+instance ArbitraryState prim => ArbitraryState (RepoPatchV1 prim) where+  arbitraryState repo = do+    Sealed (WithEndState prim repo') <- arbitraryState repo+    return (Sealed (WithEndState (PP prim) repo'))+  arbitraryStatePair repo = do+    Sealed (WithEndState (Pair (prim1 :> prim2)) repo') <- arbitraryStatePair repo+    return (Sealed (WithEndState (Pair (PP prim1 :> PP prim2)) repo'))
+ harness/Darcs/Test/Patch/Arbitrary/RepoPatchV2.hs view
@@ -0,0 +1,46 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Arbitrary.RepoPatchV2 () where++import Darcs.Prelude++import Control.Exception+import System.IO.Unsafe++import Darcs.Test.Patch.Arbitrary.Generic+    ( ArbitraryPrim+    , MightHaveDuplicate(..)+    , PrimBased(..)+    )+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge(..) )+import Darcs.Test.Patch.RepoModel ( RepoState, ModelOf )+import Darcs.Test.Patch.WithState ( PropagateShrink )+import Darcs.Patch+import Darcs.Patch.V2 ( RepoPatchV2 )+import Darcs.Patch.V2.RepoPatch ( isDuplicate, RepoPatchV2(Normal) )+import Darcs.Patch.Witnesses.Ordered++instance MightHaveDuplicate (RepoPatchV2 prim) where+  hasDuplicate = isDuplicate++type instance ModelOf (RepoPatchV2 prim) = ModelOf prim++instance ( ArbitraryPrim prim+         , PrimPatch prim+         , ApplyState prim ~ RepoState (ModelOf prim)+         ) =>+         ArbitraryRepoPatch (RepoPatchV2 prim) where+  notRepoPatchV1 = Just (NotRepoPatchV1 (\case {}))++instance PrimPatch prim => CheckedMerge (RepoPatchV2 prim) where+  validateMerge v =+    case unsafePerformIO (try (evaluate v)) of+      Left (_ :: SomeException) -> Nothing+      Right x -> Just x++instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) =>+         PrimBased (RepoPatchV2 prim) where+  type OnlyPrim (RepoPatchV2 prim) = prim+  primEffect = (:>: NilFL)+  liftFromPrim = Normal
+ harness/Darcs/Test/Patch/Arbitrary/RepoPatchV3.hs view
@@ -0,0 +1,39 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableInstances, PatternSynonyms #-}+module Darcs.Test.Patch.Arbitrary.RepoPatchV3 () where++import Darcs.Prelude++import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate(..), PrimBased(..), ArbitraryPrim )+import Darcs.Test.Patch.Arbitrary.NamedPrim ()+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Test.Patch.RepoModel ( RepoState, ModelOf )+import Darcs.Test.Patch.WithState ( PropagateShrink )++import Darcs.Patch+import Darcs.Patch.Prim.Named+import Darcs.Patch.Prim.WithName+import Darcs.Patch.V3 ( RepoPatchV3 )+import qualified Darcs.Patch.V3.Core as V3 ( RepoPatchV3(Prim) )++import Darcs.Patch.Witnesses.Ordered++instance MightHaveDuplicate (RepoPatchV3 prim) where+  hasDuplicate _ = False++type instance ModelOf (RepoPatchV3 prim) = ModelOf prim++instance+  (ArbitraryPrim prim, PrimPatch prim, ApplyState prim ~ RepoState (ModelOf prim))+  => ArbitraryRepoPatch (RepoPatchV3 prim)+  where++    notRepoPatchV1 = Just (NotRepoPatchV1 (\case {}))++instance PrimPatch prim => CheckedMerge (RepoPatchV3 prim)++instance (PrimPatch prim, ArbitraryPrim prim, PropagateShrink prim prim) => PrimBased (RepoPatchV3 prim) where+  type OnlyPrim (RepoPatchV3 prim) = NamedPrim prim+  primEffect p = wnPatch p :>: NilFL+  liftFromPrim = V3.Prim
+ harness/Darcs/Test/Patch/Arbitrary/Sealed.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Test.Patch.Arbitrary.Sealed+  ( ArbitraryS2(..)+  ) where++import Darcs.Patch.Witnesses.Sealed+  ( Sealed2(..)+  )++import Test.QuickCheck++class ArbitraryS2 p where+  arbitraryS2 :: Gen (Sealed2 p)+  shrinkS2 :: Sealed2 p -> [Sealed2 p]+  shrinkS2 _ = []++instance ArbitraryS2 p => Arbitrary (Sealed2 p) where+  arbitrary = arbitraryS2+  shrink = shrinkS2
+ harness/Darcs/Test/Patch/Arbitrary/Shrink.hs view
@@ -0,0 +1,53 @@+module Darcs.Test.Patch.Arbitrary.Shrink+  ( Shrinkable(..)+  ) where++import Darcs.Prelude++import Darcs.Patch.Commute+import Darcs.Patch.Permutations++import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed++-- |This class encapsulates the general concept of shrinking a patch+-- without using any information about the repository state the+-- patch is applied to.+class Shrinkable p where+  -- |Shrink a patch while preserving the start and end contexts.+  shrinkInternally :: p wX wY -> [p wX wY]+  -- |Shrink a patch, preserving the start context, but maybe not the end context.+  shrinkAtEnd :: p wX wY -> [Sealed (p wX)]+  -- |Shrink a patch, preserving the end context, but maybe not the start context.+  shrinkAtStart :: p wX wY -> [FlippedSeal p wY]++instance (Shrinkable p, Shrinkable q) => Shrinkable (p :> q) where+  shrinkInternally (p :> q) =+    ((:> q) <$> shrinkInternally p) +++    ((p :>) <$> shrinkInternally q)+  shrinkAtEnd (p :> q) = do+    Sealed q' <- shrinkAtEnd q+    return (Sealed (p :> q'))+  shrinkAtStart (p :> q) = do+    FlippedSeal p' <- shrinkAtStart p+    return (FlippedSeal (p' :> q))++instance (Commute p, Shrinkable p) => Shrinkable (FL p) where+  shrinkInternally NilFL = []+  shrinkInternally (p :>: ps) =+    ((:>: ps) <$> shrinkInternally p) ++ ((p :>: ) <$> shrinkInternally ps)++  shrinkAtStart ps = do+    q :> qs <- headPermutationsFL ps+    FlippedSeal qs:map (mapFlipped (:>: qs)) (shrinkAtStart q)++  shrinkAtEnd = map (mapSeal reverseRL) . shrinkAtEnd . reverseFL++instance (Commute p, Shrinkable p) => Shrinkable (RL p) where+  shrinkInternally = map reverseFL . shrinkInternally . reverseRL++  shrinkAtStart = map (mapFlipped reverseFL) . shrinkAtStart . reverseRL++  shrinkAtEnd ps = do+    qs :<: q <- headPermutationsRL ps+    Sealed qs:map (mapSeal (qs :<:)) (shrinkAtEnd q)
+ harness/Darcs/Test/Patch/Check.hs view
@@ -0,0 +1,322 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Darcs.Test.Patch.Check ( PatchCheck, doCheck, fileExists, dirExists,+                                removeFile, removeDir, createFile, createDir,+                                insertLine, deleteLine, isValid,+                                fileEmpty,+                                checkMove, modifyFile, FileContents(..),+                                inconsistent, handleInconsistent+                              ) where++import Prelude ()+import Darcs.Prelude++import qualified Data.ByteString as B (ByteString)+import Control.Monad.State ( State, evalState )+import Control.Monad.Trans.Maybe ( MaybeT(..) )+import Control.Monad.State.Class ( get, put, modify, MonadState )+import qualified Data.IntMap as M ( IntMap, mapKeys, delete, insert, empty, lookup, null )++import Darcs.Util.Path+    ( AnchoredPath+    , anchorPath+    , isPrefix+    , movedirfilename+    , parents+    )++-- | File contents are represented by a map from line numbers to line contents.+--   If for a certain line number, the line contents are Nothing, that means+--   that we are sure that that line exists, but we don't know its contents.+--   We must also store the greatest line number that is known to exist in a+--   file, to be able to exclude the possibility of it being empty without+--   knowing its contents.+data FileContents = FC { fcLines   :: M.IntMap B.ByteString+                       , fcMaxline :: Int+                       } deriving (Eq, Show)++data Prop+    = FileEx AnchoredPath+    | DirEx AnchoredPath+    | NotEx AnchoredPath+    | FileLines AnchoredPath FileContents+    deriving (Eq)++instance  Show Prop  where+    show (FileEx f) = "FileEx " ++ anchorPath "" f+    show (DirEx d)  = "DirEx " ++ anchorPath "" d+    show (NotEx f) = "NotEx" ++ anchorPath "" f+    show (FileLines f l)  = "FileLines " ++ anchorPath "" f ++ ": " ++ show l++-- | A simulated repository state. The repository is assumed to be+-- consistent, and it has two lists of properties: one list with properties+-- that hold for this repo, and one with properties that do not hold for this+-- repo. These two lists may not have any common elements: if they had, the+-- repository would be inconsistent.+data ValidState = P [Prop] [Prop] deriving Show++-- | PatchCheck is a 'State' monad with a simulated repository state, wrapped in+-- a 'MaybeT' to indicate failure ('Nothing') or success ('Just').+newtype PatchCheck a = PatchCheck { runPatchCheck :: MaybeT (State ValidState) a }+  deriving (Functor, Applicative, Monad, MonadState ValidState)++-- The existing instance definitions in Control.Monad.Except make it+-- impossible to provide an 'instance MonadError () (MaybeT m)'.++throwPC :: PatchCheck a+throwPC = PatchCheck $ MaybeT $ return Nothing++catchPC :: PatchCheck a -> PatchCheck a -> PatchCheck a+PatchCheck m `catchPC` h =+  PatchCheck $ MaybeT $ do+    a <- runMaybeT m+    case a of+      Nothing -> runMaybeT (runPatchCheck h)+      Just r -> return (Just r)++inconsistent :: PatchCheck ()+inconsistent = throwPC++-- | The @FileContents@ structure for an empty file+emptyFilecontents :: FileContents+emptyFilecontents = FC M.empty 0++-- | Returns a given value if the repository state is inconsistent, and performs+--   a given action otherwise.+handleInconsistent :: a            -- ^ The value to return if the state is inconsistent+                   -> PatchCheck a -- ^ The action to perform otherwise+                   -> PatchCheck a+handleInconsistent v a = a `catchPC` return v++doCheck :: PatchCheck a -> Bool+doCheck p =+  evalState (maybe False (const True) <$> runMaybeT (runPatchCheck p)) (P [] [])++isValid :: PatchCheck ()+isValid = return ()++has :: Prop -> [Prop] -> Bool+has = elem++modifyFile :: AnchoredPath+           -> (Maybe FileContents -> Maybe FileContents)+           -> PatchCheck ()+modifyFile f change = do+    fileExists f+    c <- fileContents f+    case change c of+      Nothing -> assertNot $ FileEx f -- shorthand for "FAIL"+      Just c' -> setContents f c'++insertLine :: AnchoredPath -> Int -> B.ByteString -> PatchCheck ()+insertLine f n l = do+    c <- fileContents f+    case c of+      Nothing -> assertNot $ FileEx f -- in this case, the repo is inconsistent+      Just c' -> do+        let lines'   = M.mapKeys (\k -> if k >= n then k+1 else k) (fcLines c')+            lines''  = M.insert n l lines'+            maxline' = max n (fcMaxline c')+        setContents f (FC lines'' maxline')++-- deletes a line from a hunk patch (third argument) in the given file (first+-- argument) at the given line number (second argument)+deleteLine :: AnchoredPath -> Int -> B.ByteString -> PatchCheck ()+deleteLine f n l = do+    c <- fileContents f+    case c of+      Nothing -> assertNot $ FileEx f+      Just c' ->+        let flines  = fcLines c'+            flines' = M.mapKeys (\k -> if k > n then k-1 else k)+                                (M.delete n flines)+            maxlinenum' | n <= fcMaxline c'  = fcMaxline c' - 1+                        | otherwise           = n - 1+            c'' = FC flines' maxlinenum'+            do_delete = setContents f c''+        in case M.lookup n flines of+          Nothing -> do_delete+          Just l' -> if l == l'+                       then do_delete+                       else assertNot $ FileEx f++setContents :: AnchoredPath -> FileContents -> PatchCheck ()+setContents f c = do+    P ks nots <- get+    let ks' = FileLines f c : filter (not . is_file_lines_for f) ks+    put (P ks' nots)+  where is_file_lines_for file prop = case prop of+                                        FileLines f' _ -> file == f'+                                        _              -> False++-- | Get (as much as we know about) the contents of a file in the current state.+--   Returns Nothing if the state is inconsistent.+fileContents :: AnchoredPath -> PatchCheck (Maybe FileContents)+fileContents f = do+      P ks _ <- get+      return (fic ks)+    where fic (FileLines f' c:_) | f == f' = Just c+          fic (_:ks) = fic ks+          fic [] = Just emptyFilecontents++-- | Checks if a file is empty+fileEmpty :: AnchoredPath          -- ^ Name of the file to check+          -> PatchCheck ()+fileEmpty f = do+  c <- fileContents f+  let empty = case c of+               Just c' -> fcMaxline c' == 0 && M.null (fcLines c')+               Nothing -> True+  if empty+     then setContents f emptyFilecontents+     -- Crude way to make it inconsistent and return false:+     else assertNot $ FileEx f++-- | Replace a filename by another in all paths.+doSwap :: AnchoredPath -> AnchoredPath -> PatchCheck ()+doSwap f f' = modify map_sw+  where sw (FileEx a) | f  `isPrefix` a = FileEx $ movedirfilename f f' a+                      | f' `isPrefix` a = FileEx $ movedirfilename f' f a+        sw (DirEx a) | f  `isPrefix` a = DirEx $ movedirfilename f f' a+                     | f' `isPrefix` a = DirEx $ movedirfilename f' f a+        sw (FileLines a c) | f  `isPrefix` a = FileLines (movedirfilename f f' a) c+                           | f' `isPrefix` a = FileLines (movedirfilename f' f a) c+        sw (NotEx a) | f `isPrefix` a = NotEx $ movedirfilename f f' a+                     | f' `isPrefix` a = NotEx $ movedirfilename f' f a+        sw p = p+        map_sw (P ks nots) = P (map sw ks) (map sw nots)++-- | Assert a property about the repository. If the property is already present+-- in the repo state, nothing changes, otherwise it is added to the list of+-- properties that hold for the repo state. If the property is in the list of+-- properties that do not hold for the repo, an inconsistency exception is+-- thrown.+assert :: Prop -> PatchCheck ()+assert p = do+    P ks nots <- get+    if has p nots+      then inconsistent+      else if has p ks+             then isValid+             else put (P (p:ks) nots)++-- | Like 'assert', but negatively: state that some property must not hold for+-- the current repo.+assertNot :: Prop -> PatchCheck ()+assertNot p = do+    P ks nots <- get+    if has p ks+      then inconsistent+      else if has p nots+             then isValid+             else put (P ks (p:nots))++-- | Remove a property from the list of properties that do not hold for this+-- repo (if it's there), and add it to the list of properties that hold.+changeToTrue :: Prop -> PatchCheck ()+changeToTrue p = modify filter_nots+  where filter_nots (P ks nots) = P (p:ks) (filter (p /=) nots)++-- | Remove a property from the list of properties that hold for this repo (if+-- it's in there), and add it to the list of properties that do not hold.+changeToFalse :: Prop -> PatchCheck ()+changeToFalse p = do+    modify filter_ks+    where filter_ks (P ks nots) = P (filter (p /=) ks) (p:nots)++assertFileExists :: AnchoredPath -> PatchCheck ()+assertFileExists f =   do assertNot $ NotEx f+                          assertNot $ DirEx f+                          assert $ FileEx f++assertDirExists :: AnchoredPath -> PatchCheck ()+assertDirExists d =   do assertNot $ NotEx d+                         assertNot $ FileEx d+                         assert $ DirEx d++assertExists :: AnchoredPath -> PatchCheck ()+assertExists f = assertNot $ NotEx f++assertNoSuch :: AnchoredPath -> PatchCheck ()+assertNoSuch f =   do assertNot $ FileEx f+                      assertNot $ DirEx f+                      assert $ NotEx f++createFile :: AnchoredPath -> PatchCheck ()+createFile fn = do+  superdirsExist fn+  assertNoSuch fn+  changeToTrue (FileEx fn)+  changeToFalse (NotEx fn)++createDir :: AnchoredPath -> PatchCheck ()+createDir fn = do+  substuffDontExist fn+  superdirsExist fn+  assertNoSuch fn+  changeToTrue (DirEx fn)+  changeToFalse (NotEx fn)++removeFile :: AnchoredPath -> PatchCheck ()+removeFile fn = do+  superdirsExist fn+  assertFileExists fn+  fileEmpty fn+  changeToFalse (FileEx fn)+  changeToTrue (NotEx fn)++removeDir :: AnchoredPath -> PatchCheck ()+removeDir fn = do+  substuffDontExist fn+  superdirsExist fn+  assertDirExists fn+  changeToFalse (DirEx fn)+  changeToTrue (NotEx fn)++checkMove :: AnchoredPath -> AnchoredPath -> PatchCheck ()+checkMove f f' = do+  superdirsExist f+  superdirsExist f'+  assertExists f+  assertNoSuch f'+  doSwap f f'++substuffDontExist :: AnchoredPath -> PatchCheck ()+substuffDontExist d = do+    P ks _ <- get+    if all noss ks+      then isValid+      else inconsistent+  where noss (FileEx f) = not (is_within_dir f)+        noss (DirEx f) = not (is_within_dir f)+        noss _ = True+        is_within_dir f = d `isPrefix` f && d /= f++superdirsExist :: AnchoredPath -> PatchCheck ()+superdirsExist fn = mapM_ assertDirExists (parents fn)++fileExists :: AnchoredPath -> PatchCheck ()+fileExists fn = do+  superdirsExist fn+  assertFileExists fn++dirExists :: AnchoredPath -> PatchCheck ()+dirExists fn = do+  superdirsExist fn+  assertDirExists fn
+ harness/Darcs/Test/Patch/Depends.hs view
@@ -0,0 +1,57 @@+module Darcs.Test.Patch.Depends ( testSuite ) where++import Darcs.Prelude++import Darcs.Patch.Depends+import Darcs.Patch.Set++import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..), RL(..)  )++import Darcs.Patch.V2 ( RepoPatchV2 )+import qualified Darcs.Patch.V2.Prim as V2++import Darcs.Patch.Named ( infopatch )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, info )+import Darcs.Patch.Info ( PatchInfo, rawPatchInfo )+import Darcs.Patch.Prim.V1.Core ( Prim(..), FilePatchType(..) )++import Darcs.Util.Path ( unsafeFloatPath )++import Darcs.Test.TestOnly.Instance ()++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit (assertFailure)++type Patch = RepoPatchV2 V2.Prim++testSuite :: Test+testSuite = testGroup "Darcs.Patch.Depends" $+  [ test1+  ]++data WA+data WB++test1 :: Test+test1 = testCase "findCommonWithThem: \"them\" patch contents should not be inspected" $ do+  let+    mkPatch :: PatchInfo -> FL V2.Prim wA wB -> PatchInfoAnd Patch wA wB+    mkPatch pi ps = piap pi (infopatch pi ps)++    p1info = rawPatchInfo "1999" "p1" "harness" [] False+    p1 = mkPatch p1info (V2.Prim (FP (unsafeFloatPath "foo") AddFile) :>: NilFL)+    set1 :: PatchSet Patch Origin WA+    set1 = PatchSet NilRL (NilRL :<: p1)++    p2info = rawPatchInfo "1999" "p2" "harness" [] False+    p2 = piap p2info (error "patch p2 content should not be read")+    p1' = piap p1info (error "patch p1' content should not be read")+    set2 :: PatchSet Patch Origin WB+    set2 = PatchSet NilRL (NilRL :<: p2 :<: p1')++  case findCommonWithThem set1 set2 of+    PatchSet NilRL (NilRL :<: p1res) :> NilFL+      | info p1res == p1info -> return ()+      | otherwise -> assertFailure $ "findCommonWithThem failed: got info " ++ show (info p1res)+    _ -> assertFailure $ "findCommonWithThem failed: unexpected structure"
+ harness/Darcs/Test/Patch/Examples/Set1.hs view
@@ -0,0 +1,440 @@+--  Copyright (C) 2002-2005,2007 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE OverloadedStrings #-}+module Darcs.Test.Patch.Examples.Set1+       ( knownCommutes, knownCantCommutes, knownMerges+       , knownMergeEquivs, knownCanons, mergePairs2+       , validPatches, commutePairs, mergePairs+       , primitiveTestPatches, testPatches, testPatchesNamed+       , primitiveCommutePairs ) where++import Prelude ()+import Darcs.Prelude+import System.IO.Unsafe ( unsafePerformIO )+import qualified Data.ByteString.Char8 as BC ( pack )+import qualified Data.ByteString as B ( empty )+import Data.String ( IsString(..) )++import Darcs.Patch+     ( commute, invert, merge+     , Named, infopatch+     , readPatch+     , adddir, addfile, hunk, binary, rmdir, rmfile, tokreplace )+import Darcs.Patch.Info ( patchinfo )+import Darcs.Patch.FromPrim ( PrimOf, FromPrim(..) )+import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import Darcs.Test.Patch.Properties.Check( checkAPatch )+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed ( unseal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )+import Darcs.Util.Path ( AnchoredPath, unsafeFloatPath )++instance IsString AnchoredPath where+  fromString = unsafeFloatPath++type Patch = V1.RepoPatchV1 V1.Prim++flFromPrim :: FromPrim p => PrimOf p wX wY -> FL p wX wY+flFromPrim p = fromAnonymousPrim p :>: NilFL++-- The unit tester function is really just a glorified map for functions that+-- return lists, in which the lists get concatenated (where map would end up+-- with a list of lists).++quickmerge :: (FL Patch :\/: FL Patch) wX wY -> FL Patch wY wZ+quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of+                        _ :/\: p1' -> unsafeCoercePEnd p1'++-- ----------------------------------------------------------------------+-- * Show/Read tests+-- ----------------------------------------------------------------------++-- | This test involves calling 'show' to print a string describing a patch,+--   and then using readPatch to read it back in, and making sure the patch we+--   read in is the same as the original.  Useful for making sure that I don't+--   have any stupid IO bugs.++-- ----------------------------------------------------------------------+-- * Canonization tests+-- ----------------------------------------------------------------------++knownCanons :: [(FL Patch wX wY,FL Patch wX wY)]+knownCanons =+    [(quickhunk 1 "abcde" "ab" :>: NilFL, quickhunk 3 "cde"   "" :>: NilFL),+     (quickhunk 1 "abcde" "bd" :>: NilFL,+      quickhunk 1 "a" "" :>:+      quickhunk 2 "c" "" :>:+      quickhunk 3 "e" "" :>: NilFL),+     (quickhunk 4 "a" "b" :>:+      quickhunk 1 "c" "d" :>: NilFL,+      quickhunk 1 "c" "d" :>:+      quickhunk 4 "a" "b" :>: NilFL),+     (quickhunk 1 "a" "" :>:+      quickhunk 1 "" "b" :>: NilFL,+      quickhunk 1 "a" "b" :>: NilFL),+     (quickhunk 1 "ab" "c" :>:+      quickhunk 1 "cd" "e" :>: NilFL,+      quickhunk 1 "abd" "e" :>: NilFL),+     (quickhunk 1 "abcde" "cde" :>: NilFL, quickhunk 1 "ab" "" :>: NilFL),+     (quickhunk 1 "abcde" "acde" :>: NilFL, quickhunk 2 "b" "" :>: NilFL)]++quickhunk :: (FromPrim p, PrimOf p ~ V1.Prim) => Int -> String -> String -> p wX wY+quickhunk l o n = fromAnonymousPrim $ hunk "test" l (map (\c -> BC.pack [c]) o)+                                             (map (\c -> BC.pack [c]) n)++quickhunkFL :: (FromPrim p, PrimOf p ~ V1.Prim) => Int -> String -> String -> FL p wX wY+quickhunkFL l o n = quickhunk l o n :>: NilFL++-- ----------------------------------------------------------------------+-- * Merge/unmgerge tests+-- ----------------------------------------------------------------------++-- | It should always be true that if two patches can be unmerged, then merging+--   the resulting patches should give them back again.+mergePairs :: [(FL Patch :\/: FL Patch) wX wY]+mergePairs =+  take 400 [(p1:\/:p2)|+            i <- [0..(length testPatches)-1],+            p1<-[testPatches!!i],+            p2<-drop i testPatches,+            checkAPatch (invert p2 :>: p1 :>: NilFL)]++-- ----------------------------------------------------------------------+-- * Commute/recommute tests+-- ----------------------------------------------------------------------++-- | Here we test to see if commuting patch A and patch B and then commuting+-- the result gives us patch A and patch B again.  The set of patches (A,B)+-- is chosen from the set of all pairs of test patches by selecting those which+-- commute with one another.+commutePairs :: [Pair (FL Patch) wX wY]+commutePairs =+  take 200 [Pair (p1:>p2)|+            p1<-testPatches,+            p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatches,+            commute (p1:>p2) /= Nothing]++primitiveCommutePairs :: [Pair (FL Patch) wX wY]+primitiveCommutePairs =+  [Pair (p2:>p1)|+   p1<-primitiveTestPatches,+   p2<-primitiveTestPatches,+   checkAPatch (p2:>:p1:>:NilFL),+   commute (p2:>p1) /= Nothing]++-- ----------------------------------------------------------------------+-- * Commute tests+-- ----------------------------------------------------------------------++-- | Here we provide a set of known interesting commutes.+knownCommutes :: [((FL Patch :> FL Patch) wX wY,(FL Patch :> FL Patch) wX wY)]+knownCommutes = [+                  (testhunk 2 [] ["B"]:>+                   testhunk 1 [] ["A"],+                   testhunk 1 [] ["A"]:>+                   testhunk 3 [] ["B"]),+                  (testhunk 2+                   ["hello world all that is old is good old_"]+                   ["I don't like old things"]:>+                   flFromPrim (tokreplace "test" "A-Za-z_" "old" "new"),+                   flFromPrim (tokreplace "test" "A-Za-z_" "old" "new"):>+                   testhunk 2+                   ["hello world all that is new is good old_"]+                   ["I don't like new things"]),+                  (testhunk 2 ["C"] ["D"]:>+                   testhunk 1 ["A"] ["B"],+                   testhunk 1 ["A"] ["B"]:>+                   testhunk 2 ["C"] ["D"]),+                  ((quickmerge (flFromPrim (addfile "hello"):\/:flFromPrim (addfile "hello"))):>+                   flFromPrim (rmfile "NwNSO"),+                   flFromPrim (rmfile "NwNSO"):>+                   (quickmerge (flFromPrim (addfile "hello"):\/:flFromPrim (addfile "hello")))),++                  (testhunk 1 [] ["a"]:>+                   quickmerge (testhunk 3 ["o"] ["n"]:\/:+                               testhunk 3 ["o"] ["v"]),+                   quickmerge (testhunk 2 ["o"] ["n"]:\/:+                               testhunk 2 ["o"] ["v"]):>+                   testhunk 1 [] ["a"]),++                  (testhunk 3 ["B"] []:>+                   testhunk 1 ["A"] [],+                   testhunk 1 ["A"] []:>+                   testhunk 2 ["B"] []),++                  (testhunk 2 ["B"] ["C"]:>+                   testhunk 1 ["A"] ["B"],+                   testhunk 1 ["A"] ["B"]:>+                   testhunk 2 ["B"] ["C"]),++                  (testhunk 3 ["B"] ["C"]:>+                   testhunk 1 ["A"] ["B"],+                   testhunk 1 ["A"] ["B"]:>+                   testhunk 3 ["B"] ["C"]),++                  (testhunk 2 ["B"] ["C","D"]:>+                   testhunk 1 ["A"] ["B","C"],+                   testhunk 1 ["A"] ["B","C"]:>+                   testhunk 3 ["B"] ["C","D"])]+  where testhunk l o n = flFromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)++knownCantCommutes :: [(FL Patch :> FL Patch) wX wY]+knownCantCommutes = [+                      (testhunk 1 [] ["A"]:>+                       testhunk 2 ["o"] ["n"]),+                      (testhunk 1 ["o"] ["n"]:>+                       testhunk 1 [] ["A"]),+                      (testhunk 1 [] ["a"]:>+                       quickmerge (testhunk 2 ["o"] ["n"]:\/:+                                   testhunk 2 ["o"] ["v"])),+                      (flFromPrim (addfile "test"):>+                       flFromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])))]+  where testhunk l o n = flFromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)++-- ----------------------------------------------------------------------+-- * Merge tests+-- ----------------------------------------------------------------------++-- | Here we provide a set of known interesting merges.+knownMerges :: [((FL Patch:\/:FL Patch) wX wY,FL Patch wY wZ)]+knownMerges = [+                (testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:\/:+                 testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"],+                 testhunk 3 [BC.pack "c"] [BC.pack "d",BC.pack "e"]),+                (testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:\/:+                 testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"],+                 testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]),+                (testhunk 3 [BC.pack "A"] []:\/:+                 testhunk 1 [BC.pack "B"] [],+                 testhunk 2 [BC.pack "A"] []),+                (flFromPrim (rmdir "./test/world"):\/:+                 flFromPrim (hunk "./world" 3 [BC.pack "A"] []),+                 flFromPrim (rmdir "./test/world")),++                ((quickhunk 1 "a" "bc" :>:+                  quickhunk 6 "d" "ef" :>: NilFL):\/:+                 (quickhunk 3 "a" "bc" :>:+                  quickhunk 8 "d" "ef" :>: NilFL),+                 (quickhunk 1 "a" "bc" :>:+                  quickhunk 7 "d" "ef" :>: NilFL)),++                (testhunk 1 [BC.pack "A"] [BC.pack "B"]:\/:+                 testhunk 2 [BC.pack "B"] [BC.pack "C"],+                 testhunk 1 [BC.pack "A"] [BC.pack "B"]),++                (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/:+                 testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"],+                 testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"])]+  where testhunk l o n = flFromPrim $ hunk "test" l o n++knownMergeEquivs :: [((FL Patch :\/: FL Patch) wX wY, FL Patch wY wZ)]+knownMergeEquivs = [++                     -- The following tests are going to be failed by the+                     -- Conflictor code as a cleanup.++                     --(addfile "test":\/:+                     -- adddir "test",+                     -- joinPatches (adddir "test" :>:+                     --              addfile "test-conflict" :>: NilFL)),+                     --(move "silly" "test":\/:+                     -- adddir "test",+                     -- joinPatches (adddir "test" :>:+                     --              move "silly" "test-conflict" :>: NilFL)),+                     --(addfile "test":\/:+                     -- move "old" "test",+                     -- joinPatches (addfile "test" :>:+                     --              move "old" "test-conflict" :>: NilFL)),+                     --(move "a" "test":\/:+                     -- move "old" "test",+                     -- joinPatches (move "a" "test" :>:+                     --              move "old" "test-conflict" :>: NilFL)),+                     (flFromPrim (hunk "test" 1 [] [BC.pack "A"]) :\/:+                       flFromPrim (hunk "test" 1 [] [BC.pack "B"]),+                       flFromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])),+                     (flFromPrim (hunk "test" 1 [] [BC.pack "a"]):\/:+                      flFromPrim (hunk "test" 1 [BC.pack "b"] []),+                      unsafeCoerceP NilFL),+                      --hunk "test" 1 [] [BC.pack "v v v v v v v",+                      --                  BC.pack "*************",+                      --                  BC.pack "a",+                      --                  BC.pack "b",+                      --                  BC.pack "^ ^ ^ ^ ^ ^ ^"]),+                     (quickhunkFL 4 "a"  "" :\/:+                      quickhunkFL 3 "a"  "",+                      quickhunkFL 3 "aa" ""),+                     ((quickhunk 1 "a" "bc" :>:+                       quickhunk 6 "d" "ef" :>: NilFL) :\/:+                       (quickhunk 3 "a" "bc" :>:+                        quickhunk 8 "d" "ef" :>: NilFL),+                      quickhunk 3 "a" "bc" :>:+                      quickhunk 8 "d" "ef" :>:+                      quickhunk 1 "a" "bc" :>:+                      quickhunk 7 "d" "ef" :>: NilFL),+                     (quickmerge (quickhunkFL 2 "" "bd":\/:quickhunkFL 2 "" "a") :\/:+                              quickmerge (quickhunkFL 2 "" "c":\/:quickhunkFL 2 "" "a"),+                              quickhunkFL 2 "" "abdc")+                     ]+++-- | It also is useful to verify that it doesn't matter which order we specify+--   the patches when we merge.+mergePairs2 :: [(FL Patch wX wY, FL Patch wX wZ)]+mergePairs2 = [(p1, p2) |+               p1<-primitiveTestPatches,+               p2<-primitiveTestPatches,+               checkAPatch (invert p1:>:p2:>:NilFL)+              ]++-- ----------------------------------------------------------------------+-- Patch test data+-- This is where we define the set of patches which we run our tests on.  This+-- should be kept up to date with as many interesting permutations of patch+-- types as possible.+-- ----------------------------------------------------------------------++testPatches :: [FL Patch wX wY]+testPatchesNamed :: [Named Patch wX wY]+testPatchesAddfile :: [FL Patch wX wY]+testPatchesRmfile :: [FL Patch wX wY]+testPatchesHunk :: [FL Patch wX wY]+primitiveTestPatches :: [FL Patch wX wY]+testPatchesBinary :: [FL Patch wX wY]+testPatchesCompositeNocom :: [FL Patch wX wY]+testPatchesComposite :: [FL Patch wX wY]+testPatchesTwoCompositeHunks :: [FL Patch wX wY]+testPatchesCompositeHunks :: [FL Patch wX wY]+testPatchesCompositeFourHunks :: [FL Patch wX wY]+testPatchesMerged :: [FL Patch wX wY]+validPatches :: [FL Patch wX wY]++testPatchesNamed =+  [ unsafePerformIO $ do+      info <- patchinfo "date is" "patch name" "David Roundy" []+      return $ infopatch info $ addfile "test" :>: NilFL+  , unsafePerformIO $ do+      info <-+        patchinfo+          "Sat Oct 19 08:31:13 EDT 2002"+          "This is another patch"+          "David Roundy"+          ["This log file has", "two lines in it"]+      return $ infopatch info $ rmfile "test" :>: NilFL+  ]+testPatchesAddfile = map flFromPrim+                       [addfile "test",adddir "test",addfile "test/test"]+testPatchesRmfile = map invert testPatchesAddfile+testPatchesHunk  =+    [flFromPrim (hunk file line old new) |+     file <- ["test"],+     line <- [1,2],+     old <- map (map BC.pack) partials,+     new <- map (map BC.pack) partials,+     old /= new+    ]+    where partials  = [["A"],["B"],[],["B","B2"]]++fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = error "impossible"++primitiveTestPatches = testPatchesAddfile +++                         testPatchesRmfile +++                         testPatchesHunk +++                         [unseal unsafeCoercePEnd.fromRight.readPatch $+                          BC.pack "move ./test/test ./hello",+                          unseal unsafeCoercePEnd.fromRight.readPatch $+                          BC.pack "move ./test ./hello"] +++                         testPatchesBinary++testPatchesBinary =+    [flFromPrim $ binary "./hello"+     (BC.pack $ "agadshhdhdsa75745457574asdgg" +++      "a326424677373735753246463gadshhdhdsaasdgg" +++      "a326424677373735753246463gadshhdhdsaasdgg" +++      "a326424677373735753246463gadshhdhdsaasdgg")+     (BC.pack $ "adafjttkykrehhtrththrthrthre" +++      "a326424677373735753246463gadshhdhdsaasdgg" +++      "a326424677373735753246463gadshhdhdsaasdgg" +++      "a326424677373735753246463gadshhdhdsaagg"),+     flFromPrim $ binary "./hello"+     B.empty+     (BC.pack "adafjttkykrere")]++testPatchesCompositeNocom =+    take 50 [p1+>+p2|+             p1<-primitiveTestPatches,+             p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) primitiveTestPatches,+             commute (p1:>p2) == Nothing]++testPatchesComposite =+    take 100 [p1+>+p2|+              p1<-primitiveTestPatches,+              p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) primitiveTestPatches,+              commute (p1:>p2) /= Nothing,+              commute (p1:>p2) /= Just (unsafeCoerceP p2:>unsafeCoerceP p1)]++testPatchesTwoCompositeHunks =+    take 100 [p1+>+p2|+              p1<-testPatchesHunk,+              p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk]++testPatchesCompositeHunks =+    take 100 [p1+>+p2+>+p3|+              p1<-testPatchesHunk,+              p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk,+              p3<-filter (\p->checkAPatch (p1:>:p2:>:p:>:NilFL)) testPatchesHunk]++testPatchesCompositeFourHunks =+    take 100 [p1+>+p2+>+p3+>+p4|+              p1<-testPatchesHunk,+              p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk,+              p3<-filter (\p->checkAPatch (p1:>:p2:>:p:>:NilFL)) testPatchesHunk,+              p4<-filter (\p->checkAPatch (p1:>:p2:>:p3:>:p:>:NilFL)) testPatchesHunk]++testPatchesMerged =+  take 200+    [p2+>+quickmerge (p1:\/:p2) |+     p1<-take 10 (drop 15 testPatchesCompositeHunks)++primitiveTestPatches+         ++take 10 (drop 15 testPatchesTwoCompositeHunks)+         ++ take 2 (drop 4 testPatchesCompositeFourHunks),+     p2<-take 10 testPatchesCompositeHunks++primitiveTestPatches+         ++take 10 testPatchesTwoCompositeHunks+         ++take 2 testPatchesCompositeFourHunks,+     checkAPatch (invert p1 :>: p2 :>: NilFL),+     commute (p2:>p1) /= Just (p1:>p2)+    ]++testPatches =  primitiveTestPatches +++                testPatchesComposite +++                testPatchesCompositeNocom +++                testPatchesMerged++-- ----------------------------------------------------------------------+-- * Check patch test+-- ----------------------------------------------------------------------++validPatches = [(quickhunk 4 "a" "b" :>:+                 quickhunk 1 "c" "d" :>: NilFL),+                (quickhunk 1 "a" "bc" :>:+                 quickhunk 1 "b" "d" :>: NilFL),+                (quickhunk 1 "a" "b" :>:+                 quickhunk 1 "b" "d" :>: NilFL)]++testPatches
+ harness/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs view
@@ -0,0 +1,503 @@+-- Copyright (C) 2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Darcs.Test.Patch.Examples.Set2Unwitnessed+       ( primPermutables, primPatches+       , commutables, commutablesFL+       , repov2Commutables , repov2Mergeables, repov2Triples+       , repov2NonduplicateTriples, repov2Patches, repov2PatchLoopExamples+       ) where++import Darcs.Prelude++import Data.Maybe ( catMaybes )+import qualified Data.ByteString.Char8 as BC ( pack )+import Data.String ( IsString(..) )++import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch ( invert, hunk )+import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.FromPrim ( fromAnonymousPrim )+import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Patch.V2 ( RepoPatchV2 )+-- import Darcs.Test.Patch.Test () -- for instance Eq Patch+-- import Darcs.Test.Patch.Examples.Set2Unwitnessed+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import qualified Darcs.Test.Patch.Arbitrary.Generic as W ( notDuplicatestriple )+import Darcs.Test.Patch.Arbitrary.RepoPatchV2 ()+import Darcs.Test.Patch.Arbitrary.PrimV1 ()+--import Darcs.Util.Printer ( greenText )+--import Darcs.Util.Printer.Color ( traceDoc )+--import Darcs.Util.Printer.Color ( errorDoc )+import Darcs.Util.Printer.Color () -- for instance Show Doc+import Darcs.Test.Patch.WSub+++import qualified Darcs.Patch.Witnesses.Ordered as W ( (:>), (:\/:) )+import qualified Data.ByteString as B ( ByteString )+import Darcs.Test.Patch.V1Model ( V1Model, Content+                                , makeRepo, makeFile)+import Darcs.Test.Patch.WithState ( WithStartState(..) )+import Darcs.Util.Path ( AnchoredPath, unsafeFloatPath, makeName )+import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim )+import Darcs.Patch.Merge ( Merge )+import Darcs.Test.Patch.Arbitrary.PatchTree+    ( Tree(..)+    , TreeWithFlattenPos(..)+    , commutePairFromTree, commuteTripleFromTree+    , mergePairFromCommutePair, commutePairFromTWFP+    , canonizeTree+    )++instance IsString AnchoredPath where+  fromString = unsafeFloatPath+++-- import Debug.Trace++type Patch = RepoPatchV2 Prim2++makeSimpleRepo :: String -> Content -> V1Model wX+makeSimpleRepo filename content =+    makeRepo [(either error id $ makeName filename, makeFile content)]++withStartState :: s wX -> p wX -> Sealed (WithStartState s p)+withStartState s p = seal (WithStartState s p)++w_tripleExamples :: (FromPrim p, Merge p, PrimPatchBase p)+                 => [Sealed2 (p W.:> p W.:> p)]+w_tripleExamples = catMaybes [commuteTripleFromTree seal2 $+                   withStartState (makeSimpleRepo "file" [])+                   (ParTree+                    (SeqTree (hunk "file" 1 [] [BC.pack "g"])+                     (SeqTree (hunk "file" 2 [] [BC.pack "j"])+                      (SeqTree (hunk "file" 1 [] [BC.pack "s"]) NilTree)))+                    (SeqTree (hunk "file" 1 [] [BC.pack "e"]) NilTree))+                  ,commuteTripleFromTree seal2 $+                   withStartState (makeSimpleRepo "file" [BC.pack "j"])+                   (ParTree+                    (SeqTree (hunk "file" 1 [] [BC.pack "s"])+                     (ParTree+                      (SeqTree (hunk "file" 2 [BC.pack "j"] []) NilTree)+                      (SeqTree (hunk "file" 2 [BC.pack "j"] []) NilTree)))+                    (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree))+                  ]+++w_mergeExamples :: (FromPrim p, Commute p, Merge p, PrimPatchBase p)+                => [Sealed2 (p W.:\/: p)]+w_mergeExamples = map (unseal2 (mergePairFromCommutePair seal2)) w_commuteExamples++w_commuteExamples :: (FromPrim p, Merge p, PrimPatchBase p) => [Sealed2 (p W.:> p)]+w_commuteExamples = catMaybes [+                   commutePairFromTWFP seal2 $+                   withStartState (makeSimpleRepo "file" [])+                   (TWFP 3+                    (ParTree+                     (SeqTree (hunk "file" 1 [] [BC.pack "h"]) NilTree)+                     (SeqTree (hunk "file" 1 [] [BC.pack "b"])+                       (SeqTree (hunk "file" 1 [] [BC.pack "f"])+                         (SeqTree (hunk "file" 1 [] [BC.pack "v"])+                           (SeqTree (hunk "file" 2 [BC.pack "f"] []) NilTree)))))),+                   commutePairFromTWFP seal2 $+                   withStartState+                   (makeSimpleRepo "file" [BC.pack "f",BC.pack "s",BC.pack "d"])+                   (TWFP 3+                    (ParTree+                     (SeqTree (hunk "file" 3 [BC.pack "d"] []) NilTree)+                     (ParTree+                      (SeqTree (hunk "file" 1 [BC.pack "f"] []) NilTree)+                      (SeqTree (hunk "file" 1 [BC.pack "f"] [])+                        (SeqTree (hunk "file" 1 [BC.pack "s",BC.pack "d"] [])+                          (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree)))))),+{-                   commutePairFromTWFP seal2 $+                   withStartState+                   (makeSimpleRepo "file" [BC.pack "f",BC.pack "u",+                                            BC.pack "s",BC.pack "d"])+                   (TWFP 5+                    (ParTree+                     (SeqTree (hunk "file" 5 [] [BC.pack "x"])+                      (SeqTree (hunk "file" 4 [BC.pack "d"] []) NilTree))+                     (ParTree+                      (SeqTree (hunk "file" 1 [BC.pack "f",BC.pack "u"] []) NilTree)+                      (SeqTree (hunk "file" 1 [BC.pack "f"] [])+                       (SeqTree (hunk "file" 1 [BC.pack "u",BC.pack "s",BC.pack "d"] [])+                        (SeqTree (hunk "file" 1 [] [BC.pack "a"])+                         (SeqTree (hunk "file" 1 [BC.pack "a"] []) NilTree))))))),-}+                   commutePairFromTree seal2 $+                   withStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"])+                   (ParTree+                    (SeqTree (hunk "file" 1 [BC.pack "n",BC.pack "t",BC.pack "h"] [])+                     NilTree)+                    (SeqTree (hunk "file" 3 [BC.pack "h"] [])+                     (SeqTree (hunk "file" 1 [BC.pack "n"] [])+                      (SeqTree (hunk "file" 1 [BC.pack "t"] []) NilTree)))),+                  commutePairFromTree seal2 $+                  withStartState (makeSimpleRepo "file" [])+                  (ParTree+                   (SeqTree (hunk "file" 1 [] [BC.pack "n"]) NilTree)+                   (SeqTree (hunk "file" 1 [] [BC.pack "i"])+                                (SeqTree (hunk "file" 1 [] [BC.pack "i"]) NilTree))),+                  commutePairFromTree seal2 $+                  withStartState (makeSimpleRepo "file" [])+                  (ParTree+                   (SeqTree (hunk "file" 1 [] [BC.pack "c"])+                     (ParTree+                       (SeqTree (hunk "file" 1 [BC.pack "c"] [BC.pack "r"]) NilTree)+                       (SeqTree (hunk "file" 1 [] [BC.pack "h"])+                        (SeqTree (hunk "file" 1 [] [BC.pack "d"]) NilTree))))+                   (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree)),+                  commutePairFromTWFP seal2 $+                  withStartState (makeSimpleRepo "file" [])+                  (TWFP 1+                  (ParTree+                   (ParTree+                    (SeqTree (hunk "file" 1 [] [BC.pack "t"]) NilTree)+                    (SeqTree (hunk "file" 1 [] [BC.pack "t"]) NilTree))+                   (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree))),+                   commutePairFromTWFP seal2 $+                   withStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r",+                                                            BC.pack "c",BC.pack "v"])+                   (TWFP 4+                    (ParTree+                     (SeqTree (hunk "file" 3 [BC.pack "c",BC.pack "v"] [])+                        (ParTree+                         (SeqTree (hunk "file" 2 [BC.pack "r"] [])+                          (SeqTree (hunk "fi le" 1 [BC.pack "f"] []) NilTree))+                         (SeqTree (hunk "file" 1 [BC.pack "f",BC.pack "r"] [])+                          (SeqTree (hunk "file" 1 [] [BC.pack "y"]) NilTree))))+                     (SeqTree (hunk "file" 4 [BC.pack "v"] []) NilTree))),+                   commutePairFromTree seal2 $+                   withStartState (makeSimpleRepo "file" [])+                   (ParTree+                    (SeqTree (hunk "file" 1 [] [BC.pack "z"]) NilTree)+                    (ParTree+                     (SeqTree (hunk "file" 1 [] [BC.pack "f"]) NilTree)+                     (ParTree+                      (SeqTree (hunk "file" 1 [] [BC.pack "r"]) NilTree)+                      (SeqTree (hunk "file" 1 [] [BC.pack "d"]) NilTree))))+                 , commutePairFromTree seal2 $+                   withStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"])+                   (ParTree+                    (ParTree+                     (SeqTree (hunk "file" 1 [BC.pack "t",BC.pack "r",BC.pack "h"] [])+                              NilTree)+                     (SeqTree (hunk "file" 1 [] [BC.pack "o"]) NilTree))+                    (SeqTree (hunk "file" 1 [BC.pack "t"] [])+                     (SeqTree (hunk "file" 2 [BC.pack "h"] []) NilTree)))+                 , commutePairFromTWFP seal2 $+                   withStartState (makeSimpleRepo "file" []) $+                   TWFP 2+                   (ParTree+                    (SeqTree (hunk "file" 1 [] [BC.pack "h"]) NilTree)+                    (SeqTree (hunk "file" 1 [] [BC.pack "y"])+                     (SeqTree (hunk "file" 2 [] [BC.pack "m"])+                      (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree))))+                 , commutePairFromTree seal2 $+                 withStartState (makeSimpleRepo "file" [])+                 (ParTree+                  (SeqTree (hunk "file" 1 [] [BC.pack "p"])+                   (SeqTree (hunk "file" 1 [BC.pack "p"] [])+                    (SeqTree (hunk "file" 1 [] [BC.pack "c"]) NilTree)))+                  (SeqTree (hunk "file" 1 [] [BC.pack "z"]) NilTree))+                 , commutePairFromTree seal2 $+                 withStartState (makeSimpleRepo "file" [])+                 (ParTree+                  (SeqTree (hunk "file" 1 [] [BC.pack "j" ])+                   (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree))+                  (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree))+                 , commutePairFromTree seal2 $+                 withStartState (makeSimpleRepo "file" [])+                 (ParTree+                  (SeqTree (hunk "file" 1 [] [BC.pack "v"]) NilTree)+                  (SeqTree (hunk "file" 1 [] [BC.pack "j" ])+                   (SeqTree (hunk "file" 1 [BC.pack "j"] []) NilTree)))+                 , commutePairFromTree seal2 $+                 withStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"])+                 (ParTree+                  (SeqTree (hunk "file" 1 [] [BC.pack "h"])+                   (ParTree+                    (SeqTree (hunk "file" 3 [BC.pack "c"] []) NilTree)+                    (SeqTree (hunk "file" 2 [BC.pack "x"] [])+                     (SeqTree (hunk "file" 1 [] [BC.pack "j"]) NilTree))))+                  (SeqTree (hunk "file" 1 [] [BC.pack "l"]) NilTree))+                 , commutePairFromTree seal2 $+                 withStartState (makeSimpleRepo "file" [])+                 (ParTree+                  (SeqTree (hunk "file" 1 [] (packStringLetters "s")) NilTree)+                  (SeqTree (hunk "file" 1 [] (packStringLetters "k"))+                   (SeqTree (hunk "file" 1 (packStringLetters "k") [])+                    (SeqTree (hunk "file" 1 [] (packStringLetters "m"))+                     (SeqTree (hunk "file" 1 (packStringLetters "m") []) NilTree)))))+                 ]++packStringLetters :: String -> [B.ByteString]+packStringLetters = map (BC.pack . (:[]))++w_repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim2))]+w_repov2PatchLoopExamples =+    [Sealed (WithStartState (makeSimpleRepo fx [])+     $ canonizeTree+     (ParTree+      (SeqTree (hunk fx 1 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd"))+       (ParTree+        (SeqTree (hunk fx 47 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh"))+         (ParTree+          (ParTree+           NilTree+           (ParTree+            (ParTree+             (ParTree+              (SeqTree (hunk fx 15 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps"))+               (ParTree+                NilTree+                (ParTree+                 (SeqTree (hunk fx 40 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro"))+                  (ParTree+                   (ParTree+                    (SeqTree (hunk fx 12 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg")) NilTree)+                    NilTree)+                   NilTree))+                 (SeqTree (hunk fx 25 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe")) NilTree))))+              (SeqTree (hunk fx 56 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq")) NilTree))+             (SeqTree (hunk fx 20 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx"))+              (SeqTree (hunk fx 26 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe"))+               (SeqTree (hunk fx 39 [] (packStringLetters "ji"))+                (ParTree+                 NilTree+                 (ParTree+                  NilTree+                  (ParTree+                   (ParTree+                    NilTree+                    (SeqTree (hunk fx 26 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj"))+                     (SeqTree (hunk fx 39 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp")) NilTree)))+                   (ParTree+                    NilTree+                    (SeqTree (hunk fx 44 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy"))+                     (ParTree+                      NilTree+                      (SeqTree (hunk fx 64 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp")) NilTree)))))))))))+            (ParTree+             NilTree+             NilTree)))+          NilTree))+        NilTree))+      (ParTree+       NilTree+       (SeqTree (hunk fx 1 [] (packStringLetters "ti"))+        (SeqTree (hunk fx 1 (packStringLetters "t") (packStringLetters "ybcop"))+         (SeqTree (hunk fx 2 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf"))+          (SeqTree (hunk fx 15 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc"))+           (SeqTree (hunk fx 51 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw"))+            (ParTree+             NilTree+             NilTree)))))))))]+  where+      fx :: IsString a => a+      fx = "F"++mergeExamples :: [Sealed2 (Patch :\/: Patch)]+mergeExamples = map (mapSeal2 fromW) w_mergeExamples++repov2PatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim2))]+repov2PatchLoopExamples = w_repov2PatchLoopExamples++commuteExamples :: [Sealed2 (Patch :> Patch)]+commuteExamples = map (mapSeal2 fromW) w_commuteExamples++tripleExamples :: [Sealed2 (Patch :> Patch :> Patch)]+tripleExamples = map (mapSeal2 fromW) w_tripleExamples++notDuplicatestriple :: (Patch :> Patch :> Patch) wX wY -> Bool+notDuplicatestriple = W.notDuplicatestriple . toW++quickhunk :: PrimPatch prim => Int -> String -> String -> prim wX wY+quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o)+                                (map (\c -> BC.pack [c]) n)++primPermutables :: [(Prim2 :> Prim2 :> Prim2) wX wY]+primPermutables =+    [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"]++mergeables :: [(Prim2 :\/: Prim2) wX wY]+mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c",+              quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c",+              quickhunk 0 "" "a" :\/: quickhunk 1 "" "b",+              quickhunk 0 "a" "" :\/: quickhunk 1 "" "b",+              quickhunk 0 "a" "" :\/: quickhunk 1 "b" "",+              quickhunk 0 "" "a" :\/: quickhunk 1 "b" ""+             ]++mergeablesFL :: [(FL Prim2 :\/: FL Prim2) wX wY]+mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables +++           [] --    [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL)+              --  :\/: (quickhunk 1 "a" "z" :>: NilFL),+              --  (quickhunk 1 "a" "b" :>: quickhunk 1 "b" "c" :>: NilFL)+              --  :\/: (quickhunk 1 "a" "z" :>: NilFL)]++mergeable2commutable :: Invert p => (p :\/: p) wX wY -> (p :> p) wX wY+mergeable2commutable (x :\/: y) = unsafeCoerceP (invert x) :> y++commutablesFL :: [(FL Prim2 :> FL Prim2) wX wY]+commutablesFL = map mergeable2commutable mergeablesFL+commutables :: [(Prim2 :> Prim2) wX wY]+commutables = map mergeable2commutable mergeables++primPatches :: [Prim2 wX wY]+primPatches = concatMap mergeable2patches mergeables+    where mergeable2patches (x:\/:y) = [x,y]++repov2Patches :: [Patch wX wY]+repov2Patches = concatMap commutable2patches repov2Commutables+    where commutable2patches (x:>y) = [x,y]++repov2Triples :: [(Patch :> Patch :> Patch) wX wY]+repov2Triples = [ob' :> oa2 :> a2'',+                 oa' :> oa2 :> a2'']+               ++ map (unseal2 unsafeCoerceP) tripleExamples+               ++ map (unseal2 unsafeCoerceP) (concatMap getTriples repov2FLs)+    where oa = fromAnonymousPrim $ quickhunk 1 "o" "aa"+          oa2 = oa+          a2 = fromAnonymousPrim $ quickhunk 2 "a34" "2xx"+          ob = fromAnonymousPrim $ quickhunk 1 "o" "bb"+          ob' :/\: oa' = merge (oa :\/: ob)+          a2' :/\: _ = merge (ob' :\/: a2)+          a2'' :/\: _ = merge (oa2 :\/: a2')++repov2NonduplicateTriples :: [(Patch :> Patch :> Patch) wX wY]+repov2NonduplicateTriples = filter (notDuplicatestriple) repov2Triples++repov2FLs :: [FL (Patch) wX wY]+repov2FLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL]+    where oa = fromAnonymousPrim $ quickhunk 1 "o" "a"+          ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL)++repov2Commutables :: [(Patch :> Patch) wX wY]+repov2Commutables = map (unseal2 unsafeCoerceP) commuteExamples+++                     map mergeable2commutable repov2Mergeables+++                     [invert oa :> ob'] ++ map (unseal2 unsafeCoerceP) (concatMap getPairs repov2FLs)+    where oa = fromAnonymousPrim $ quickhunk 1 "o" "a"+          ob = fromAnonymousPrim $ quickhunk 1 "o" "b"+          _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL)++repov2Mergeables :: [(Patch :\/: Patch) wX wY]+repov2Mergeables = map (\ (x :\/: y) -> fromAnonymousPrim x :\/: fromAnonymousPrim y) mergeables+                        ++ repov2IglooMergeables+                        ++ repov2QuickcheckMergeables+                        ++ map (unseal2 unsafeCoerceP) mergeExamples+                        ++ catMaybes (map pair2m (concatMap getPairs repov2FLs))+                        ++ [(oa :\/: od),+                            (oa :\/: a2'),+                            (ob' :\/: od''),+                            (oe :\/: od),+                            (of' :\/: oe'),+                            (ob' :\/: oe'),+                            (oa :\/: oe'),+                            (ob' :\/: oc'),+                            (b2' :\/: oc'''),+                            (ob' :\/: a2),+                            (b2' :\/: og'''),+                            (oc''' :\/: og'''),+                            (oc'' :\/: og''),+                            (ob'' :\/: og''),+                            (ob'' :\/: oc''),+                            (oc' :\/: od'')]+    where oa = fromAnonymousPrim $ quickhunk 1 "o" "aa"+          a2 = fromAnonymousPrim $ quickhunk 2 "a34" "2xx"+          og = fromAnonymousPrim $ quickhunk 3 "4" "g"+          ob = fromAnonymousPrim $ quickhunk 1 "o" "bb"+          b2 = fromAnonymousPrim $ quickhunk 2 "b" "2"+          oc = fromAnonymousPrim $ quickhunk 1 "o" "cc"+          od = fromAnonymousPrim $ quickhunk 7 "x" "d"+          oe = fromAnonymousPrim $ quickhunk 7 "x" "e"+          pf = fromAnonymousPrim $ quickhunk 7 "x" "f"+          od'' = fromAnonymousPrim $ quickhunk 8 "x" "d"+          ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL)+          a2' :/\: _ = merge (ob' :\/: a2)+          ob'' :/\: _ = merge (a2 :\/: ob')+          og' :/\: _ = merge (oa :\/: og)+          og'' :/\: _ = merge (a2 :\/: og')+          og''' :/\: _ = merge (ob' :\/: og')+          oc' :/\: _ = merge (oa :\/: oc)+          oc'' :/\: _ = merge (a2 :\/: oc)+          oc''' :/\: _ = merge (ob' :\/: oc')+          oe' :/\: _ = merge (od :\/: oe)+          of' :/\: _ = merge (od :\/: pf)+          pair2m :: Sealed2 (Patch :> Patch)+                 -> Maybe ((Patch :\/: Patch) wX wY)+          pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)+                                          return $ unsafeCoerceP (xx :\/: y')++repov2IglooMergeables :: [(Patch :\/: Patch) wX wY]+repov2IglooMergeables = [(a :\/: b),+                    (b :\/: c),+                    (a :\/: c),+                    (x :\/: a),+                    (y :\/: b),+                    (z :\/: c),+                    (x' :\/: y'),+                    (z' :\/: y'),+                    (x' :\/: z'),+                    (a :\/: a)]+    where a = fromAnonymousPrim $ quickhunk 1 "1" "A"+          b = fromAnonymousPrim $ quickhunk 2 "2" "B"+          c = fromAnonymousPrim $ quickhunk 3 "3" "C"+          x = fromAnonymousPrim $ quickhunk 1 "1BC" "xbc"+          y = fromAnonymousPrim $ quickhunk 1 "A2C" "ayc"+          z = fromAnonymousPrim $ quickhunk 1 "AB3" "abz"+          x' :/\: _ = merge (a :\/: x)+          y' :/\: _ = merge (b :\/: y)+          z' :/\: _ = merge (c :\/: z)++repov2QuickcheckMergeables :: [(Patch :\/: Patch) wX wY]+repov2QuickcheckMergeables = [-- invert k1 :\/: n1+                             --, invert k2 :\/: n2+                               hb :\/: k+                             , b' :\/: b'+                             , n' :\/: n'+                             , b :\/: d+                             , k' :\/: k'+                             , k3 :\/: k3+                             ] ++ catMaybes (map pair2m pairs)+    where hb = fromAnonymousPrim $ quickhunk 0 "" "hb"+          k = fromAnonymousPrim $ quickhunk 0 "" "k"+          n = fromAnonymousPrim $ quickhunk 0 "" "n"+          b = fromAnonymousPrim $ quickhunk 1 "b" ""+          d = fromAnonymousPrim $ quickhunk 2 "" "d"+          d':/\:_ = merge (b :\/: d)+          --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL)+          --k2 :>: n2 :>: NilFL :/\: _ =+          --    merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL)+          k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL)+          pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL)+          pair2m :: Sealed2 (Patch :> Patch)+                 -> Maybe ((Patch :\/: Patch) wX wY)+          pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)+                                          return $ unsafeCoerceP (xx :\/: y')++          i = fromAnonymousPrim $ quickhunk 0 "" "i"+          x = fromAnonymousPrim $ quickhunk 0 "" "x"+          xi = fromAnonymousPrim $ quickhunk 0 "xi" ""+          d3 :/\: _ = merge (xi :\/: d)+          _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL)+
+ harness/Darcs/Test/Patch/Examples/Unwind.hs view
@@ -0,0 +1,266 @@+-- BSD3+--+-- This file contains examples found during the development of Darcs.Patch.Unwind++{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -Wno-type-defaults #-}+{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+module Darcs.Test.Patch.Examples.Unwind where++import Darcs.Prelude++import Darcs.Patch.FromPrim+import Darcs.Patch.Info+import Darcs.Patch.Merge+import Darcs.Patch.Named+import Darcs.Patch.V1 ()+import Darcs.Patch.V1.Core+import Darcs.Patch.Prim.Class+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed++import Darcs.Util.Path+import Darcs.Util.Tree++import Darcs.Test.HashedStorage ( unsafeMakeName )+import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Named ()+import Darcs.Test.Patch.Arbitrary.PrimV1 ()+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Types.MergeableSequence+    ( MergeableSequence(..) )+import Darcs.Test.Patch.V1Model+import Darcs.Test.Patch.WithState+import Darcs.Test.TestOnly.Instance ()++#if MIN_VERSION_base(4,12,0) && !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif+import Data.ByteString.Char8 ( pack )+import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.Constraint+import Data.String++examples+  :: forall p+   . (ArbitraryRepoPatch p, ArbitraryPrim (OnlyPrim p))+   => [Sealed2 (WithStartState2 (MergeableSequence (Named p)))]+examples =+  case (hasPrimConstruct @(OnlyPrim p), usesV1Model @(PrimOf p), notRepoPatchV1 @p) of+    (Just Dict, Just Dict, Just _) -> [example1, example2, example3, example4]+    (Just Dict, Just Dict, Nothing) -> [example1, example2, example3]+    _ -> []++mkNamed :: String -> FL p wX wY -> Named p wX wY+mkNamed hash = NamedP (rawPatchInfo "" "" "" ["Ignore-this: "++hash] False) []++path :: String -> AnchoredPath+path s = AnchoredPath [unsafeMakeName s]++repo :: [(String, [BLC.ByteString])] -> V1Model wX+repo entries =+  makeRepo [ (unsafeMakeName s, RepoItem (File (makeBlob (BLC.unlines thelines))))+           | (s, thelines) <- entries+           ]++example1+  :: forall p+   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))+example1 =+  Sealed2+    (WithStartState2+      (repo [("a", [])])+      (ParMS+        (SeqMS+          NilMS+          (mkNamed "d4c5605cd6b83371fec990c1835c6416a187ba0"+            (hunk (path "a") 1 [] [pack "x"] :>: NilFL)))+        (SeqMS+          NilMS+          (mkNamed "bb201b95265f199e7fd98a7e2216a0add4fece68"+            (hunk (path "a") 1 [] [pack "y"] :>:+             hunk (path "a") 1 [pack "y"] [pack "z"] :>:+             NilFL)))))++example2+  :: forall p+   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))+example2 =+  let s3,s4 :: forall s . IsString s => [s]+      s3 = ["f"]+      s4 = ["g"]+  in+  Sealed2+    (WithStartState2+      (repo [("a", s3++s4)])+      (ParMS+        (ParMS+          (SeqMS+            NilMS+              (mkNamed "e8204d03b3f785675ce4bd676adbfe89c4979399"+                (hunk (path "a") 1 (map pack s3) [] :>: NilFL)))+          (SeqMS+            NilMS+              (mkNamed "ac22106fec2b81ae4f75039210f0601dbc9f677d"+                (hunk (path "a") 1 (map pack (s3++s4)) [] :>: NilFL))))+        (SeqMS+          NilMS+          (mkNamed "4f5a9665900931228596a8241ff03dea1a54805f"+            (+             hunk (path "a") (1 + length s3 + length s4) [] [pack "d"] :>:+             hunk (path "a") 1 (map pack s3) [] :>:+            NilFL)))))+++example3+  :: forall p+   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))+example3 =+  let+    s4 :: IsString s => [s]+    s4 = ["w"]+  in+  Sealed2+    (WithStartState2+      (repo [("a", s4)])+      (ParMS+        (SeqMS+          (ParMS+            (SeqMS NilMS+               (mkNamed "e631e70c43b4e609830053068eef382a4b2fec7"+                 (+                  hunk (path "a") (1+length s4) [] [pack "t"] :>:+                  NilFL+                 )))+            (SeqMS NilMS+               (mkNamed "cc39750d852a02487e2854be4c2b28f6cadf0957"+                 (+                  hunk (path "a") 1 (map pack (s4)) [] :>:+                  NilFL+                 ))))+          (mkNamed "3e2975afd211888617b20a58455926411f1ebaab"+            (+              hunk (path "a") (1+length s4) (map pack ([])) [pack "d"] :>:+              NilFL+            )))+        (SeqMS NilMS+          (mkNamed "441f412b978df5bd8febfe1f4baa5cb8d35f6e4c"+            (+             hunk (path "a") 1 (map pack []) [pack "U"] :>: +             hunk (path "a") 2 (map pack s4) [] :>:+             NilFL+          )+        )+      )+    ))++example4guts :: forall p prim . (PrimConstruct prim, ModelOf p ~ V1Model, OnlyPrim p ~ prim) => Sealed2 (WithStartState2 (MergeableSequence p))+example4guts =+  let+    s3,s5,s7,s9,s10,s11,s12 :: IsString a => [a]+    s3 = ["A","F","l"]+    s5 = ["w"]+    s7 = ["y"]+    s9 = ["u"]+    s10 = ["x"]+    s11 = ["S"]+    s12 = ["e"]+    off :: [[a]] -> Int+    off xs = 1 + sum (map length xs)+  in+   Sealed2+     (WithStartState2+       (repo [("a", s3++s5++s7)])+       (+         (NilMS+           `SeqMS` hunk (path "a") (off [s3,s5]) [] (map pack s10)+           `SeqMS` hunk (path "a") (off [s3,s5,s10,s7]) [] (map pack s11)+         )+         `ParMS`+         (NilMS+            `SeqMS` hunk (path "a") (off []) (map pack s3) (map pack s9)+            `SeqMS` hunk (path "a") (off []) (map pack (s9++s5++s7)) []+         )+         `ParMS`+         (NilMS+           `SeqMS` hunk (path "a") (off []) (map pack (s3)) []+           `SeqMS` hunk (path "a") (off []) [] (map pack s12)+         )+       )+     )+         ++example4+  :: forall p+   . (PrimConstruct (OnlyPrim p), ModelOf p ~ V1Model)+   => Sealed2 (WithStartState2 (MergeableSequence (Named p)))+example4 =+  case example4guts @p of+   Sealed2 (WithStartState2 model (((NilMS `SeqMS` a1 `SeqMS` a2) `ParMS` (NilMS `SeqMS` a3 `SeqMS` a4)) `ParMS` (NilMS `SeqMS` a5 `SeqMS` a6))) ->+     Sealed2+       (WithStartState2 model+         ((NilMS+            `SeqMS`+            mkNamed "91b78b39ea6649b6e43ea74a57070480c87d7053"+                   (a1 :>: NilFL)+            `SeqMS`+            mkNamed "80da177d495a63bc9d80b8c9bc56045b23b629f7"+                   (a2 :>: NilFL)+          )+          `ParMS`+          (NilMS+            `SeqMS`+            mkNamed "cdd591a73493d39bd763bd71acac4c1e3078a4a"+                   (a3 :>: a4 :>: NilFL)+          )+          `ParMS`+          (NilMS+            `SeqMS`+            mkNamed "9b7b08b417d62868eb92d2cac7512b899c32f722"+               (a5 :>: a6 :>: NilFL)+          )+         ))++-- like Identity but with a MonadFail instance, just to make it easier+-- to write 'brokenV1Merge' below+newtype ErrorFail a = ErrorFail { runErrorFail :: a }++instance Functor ErrorFail where+  fmap f = ErrorFail . f . runErrorFail+instance Applicative ErrorFail where+  pure = ErrorFail+  liftA2 f (ErrorFail v1) (ErrorFail v2) = ErrorFail (f v1 v2)+instance Monad ErrorFail where+  ErrorFail v >>= f = f v+#if MIN_VERSION_base(4,12,0)+instance MonadFail ErrorFail where+#endif+  fail = error++-- For now this code isn't used, it just demonstrates how example4 is broken in V1+-- x4;x5' =\/= x5;x4' but not (effect (x4;x5') =\/= effect (x5;x4'))+brokenV1Merge :: forall prim . (OnlyPrim (RepoPatchV1 prim) ~ prim, ModelOf (RepoPatchV1 prim) ~ V1Model, PrimPatch prim) => ()+brokenV1Merge =+  let+    x4, x4', x4'', x5, x5', x6, x6' :: Sealed2 (RepoPatchV1 prim)+    (x4, x4', x4'', x5, x5', x6, x6') =+      case example4guts @(RepoPatchV1 prim) of+        Sealed2+          (WithStartState2 _+            ((NilMS `SeqMS` a1 `SeqMS` a2) `ParMS` (NilMS `SeqMS` a3 `SeqMS` a4) `ParMS` (NilMS `SeqMS` a5 `SeqMS` a6))+          )+         -> runErrorFail $ do+          (a3' :>: a4' :>: NilFL) :/\: _ <- return $ merge ((PP a1 :>: PP a2 :>: NilFL) :\/: (PP a3 :>: PP a4 :>: NilFL))+          (a5' :>: a6' :>: NilFL) :/\: _ <- return $ merge ((PP a1 :>: PP a2 :>: a3' :>: NilFL) :\/: (PP a5 :>: PP a6 :>: NilFL))+          a5'' :/\: a4'' <- return $ merge (a4' :\/: a5')+          a6'' :/\: a4''' <- return $ merge (a4'' :\/: a6')+          return (Sealed2 a4', Sealed2 a4'', Sealed2 a4''', Sealed2 a5', Sealed2 a5'', Sealed2 a6', Sealed2 a6'')+  in x4 `seq` x4' `seq` x4'' `seq` x5 `seq` x5' `seq` x6 `seq` x6' `seq` ()
+ harness/Darcs/Test/Patch/FileUUIDModel.hs view
@@ -0,0 +1,205 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Repository model+module Darcs.Test.Patch.FileUUIDModel+  ( FileUUIDModel+  , Object(..)+  , repoApply+  , emptyFile+  , emptyDir+  , root, rootId+  , repoObjects, repoIds+  , aFilename, aDirname+  , aLine, aContent+  , aFile, aDir+  , aRepo+  , anUUID+  ) where+++import Prelude ()+import Darcs.Prelude++import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized )+import Darcs.Test.Patch.RepoModel++import Darcs.Patch.Apply( applyToState )+import Darcs.Patch.Prim.FileUUID.Core( UUID(..), Object(..) )+import Darcs.Patch.Prim.FileUUID.Apply( ObjectMap(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed, seal )+import Darcs.Patch.Witnesses.Show++import Darcs.Util.Path ( Name, makeName )++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.Map as M+import Data.Maybe ( fromJust )+import Test.QuickCheck+  ( Arbitrary(..)+  , Gen, choose, vectorOf, frequency, oneof )++----------------------------------------------------------------------+-- * Model definition++newtype FileUUIDModel wX = FileUUIDModel { _repoMap :: ObjectMap Fail }++----------------------------------------+-- Instances++instance Show (Object Fail) where+  show (Directory l) = show l+  show (Blob c _) = show c++instance Eq (Object Fail) where+  Blob _ (Just h1) == Blob _ (Just h2) = h1 == h2+  Blob (Right c1) _ == Blob (Right c2) _ = c1 == c2+  Directory m1 == Directory m2 = m1 == m2+  _ == _ = False++instance Show (FileUUIDModel wX) where+  show repo = "FileUUIDModel " ++ show (repoObjects repo)++instance Show1 FileUUIDModel++----------------------------------------------------------------------+-- * Constructors++objectMap :: (Monad m) => M.Map UUID (Object m) -> ObjectMap m+objectMap m = ObjectMap { getObject = get, putObject = put, listObjects = list }+  where list = return $ M.keys m+        put k o = return $ objectMap (M.insert k o m)+        get k = return $ M.lookup k m++emptyFile :: (Monad m) => Object m+emptyFile = Blob (return B.empty) Nothing++emptyDir :: Object m+emptyDir = Directory M.empty++----------------------------------------------------------------------+-- * Queries++rootId :: UUID+rootId = UUID "ROOT"++-- | The root directory of a repository.+root :: FileUUIDModel wX -> (UUID, Object Fail)+root (FileUUIDModel repo) = (rootId, fromJust $ unFail $ getObject repo rootId)++repoObjects :: FileUUIDModel wX -> [(UUID, Object Fail)]+repoObjects (FileUUIDModel repo) =+    [(uuid, obj uuid) | uuid <- unFail $ listObjects repo]+  where+    obj uuid = fromJust $ unFail $ getObject repo uuid++repoIds :: FileUUIDModel wX -> [UUID]+repoIds = map fst . repoObjects++-- | @isEmpty file@ <=> file content is empty+--   @isEmpty dir@  <=> dir has no child+isEmpty :: Object Fail -> Bool+isEmpty (Directory d) = M.null d+isEmpty (Blob f _) = B.null $ unFail f++nonEmptyRepoObjects :: FileUUIDModel wX -> [(UUID, Object Fail)]+nonEmptyRepoObjects = filter (not . isEmpty . snd) . repoObjects++----------------------------------------------------------------------+-- * QuickCheck generators++-- Testing code assumes that aFilename and aDirname generators +-- will always be able to generate a unique name given a list of+-- existing names. This should be OK as long as the number of possible+-- file/dirnames is much bigger than the number of files/dirs per repository.++-- 'Arbitrary' 'FileUUIDModel' instance is based on the 'aSmallRepo' generator.+++-- | Files are distinguish by ending their names with ".txt".+aFilename :: Gen Name+aFilename = do+  len <- choose (1,3)+  name <- vectorOf len alpha+  return $ either error id . makeName $ name ++ ".txt"++aDirname :: Gen Name+aDirname = do+  len <- choose (1,3)+  name <- vectorOf len alpha+  return $ either error id . makeName $ name++aWord :: Gen B.ByteString+aWord = do c <- alpha+           return $ BC.pack[c]++aLine :: Gen B.ByteString+aLine = do wordsNo <- choose (1,2)+           ws <- vectorOf wordsNo aWord+           return $ BC.unwords ws++aContent :: Gen B.ByteString+aContent = bSized 0 0.5 80 $ \k ->+             do n <- choose (0,k)+                BC.intercalate "\n" <$> vectorOf n aLine++aFile :: (Monad m) => Gen (Object m)+aFile = aContent >>= \c -> return $ Blob (return c) Nothing++aDir :: (Monad m) => [UUID] -> [UUID] -> Gen [(UUID, Object m)]+aDir [] _ = return []+aDir (dirid:dirids) fileids =+  do dirsplit <- choose (1, length dirids)+     filesplit <- choose (1, length fileids)+     let ids = take filesplit fileids+     files <- vectorOf filesplit aFile+     names <- vectorOf filesplit aFilename+     dirnames <- vectorOf dirsplit aDirname+     dirs <- subdirs (take dirsplit dirids)+                     (drop dirsplit dirids)+                     (drop filesplit fileids)+     return $ (dirid, Directory $ M.fromList $ names `zip` ids ++ dirnames `zip` dirids)+            : (fileids `zip` files) ++ dirs+  where subdirs [] _ _ = return []+        subdirs (uuid:uuids) dirs files = do+          dirsplit <- choose (1, length dirs)+          filesplit <- choose (1, length files)+          dir <- aDir (uuid : take dirsplit dirs) (take filesplit files)+          remaining <- subdirs uuids (drop dirsplit dirs) (drop filesplit files)+          return $ dir ++ remaining+++anUUID :: Gen UUID+anUUID = UUID . BC.pack <$> vectorOf 4 (oneof $ map return "0123456789")++-- | @aRepo filesNo dirsNo@ produces repositories with *at most* +-- @filesNo@ files and @dirsNo@ directories. +-- The structure of the repository is aleatory.+aRepo :: Int                    -- ^ Maximum number of files+      -> Int                    -- ^ Maximum number of directories+      -> Gen (FileUUIDModel wX)+aRepo maxFiles maxDirs = do+  ids <- uniques (maxFiles+maxDirs) anUUID+  let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0+  filesNo <- choose (minFiles,maxFiles)+  let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0+  dirsNo <- choose (minDirs,maxDirs)+  let (dirids, ids') = splitAt dirsNo ids+      fileids = take filesNo ids'+  objectmap <- aDir (rootId : dirids) fileids+  return $ FileUUIDModel $ objectMap $ M.fromList objectmap++-- | Generate small repositories.+-- Small repositories help generating (potentially) conflicting patches.+instance RepoModel FileUUIDModel where+  type RepoState FileUUIDModel = ObjectMap+  aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)]+                  dirsNo <- frequency [(3, return 1), (1, return 0)]+                  aRepo filesNo dirsNo+  repoApply (FileUUIDModel state) patch = FileUUIDModel <$> applyToState patch state+  showModel = show+  eqModel r1 r2 = nonEmptyRepoObjects r1 == nonEmptyRepoObjects r2++instance Arbitrary (Sealed FileUUIDModel) where+  arbitrary = seal <$> aSmallRepo
+ harness/Darcs/Test/Patch/Info.hs view
@@ -0,0 +1,225 @@+-- Copyright (C) 2009 Reinier Lamers+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- | This module contains tests for the code in Darcs.Patch.Info. Most of them+--   are about the UTF-8-encoding of patch metadata.++{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Test.Patch.Info ( testSuite ) where++import Prelude hiding ( pi )++import Control.Applicative ( (<|>) )+import qualified Data.ByteString as B ( ByteString, pack )+import qualified Data.ByteString.Char8 as BC ( pack, unpack )+import Data.List ( sort , isPrefixOf, partition )+import Data.Maybe ( isNothing )+import Data.Text as T ( find, any )+import Data.Text.Encoding ( decodeUtf8With )+import Data.Text.Encoding.Error ( lenientDecode )+import Data.Word ( Word32 )+import Numeric ( showHex )+import Test.QuickCheck ( Arbitrary(arbitrary), oneof, listOf, choose, shrink+                       , Gen, suchThat, scale )+import Test.QuickCheck.Gen ( chooseAny )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.Framework (Test, testGroup)+-- import Text.Show.Pretty ( ppShow )++import Darcs.Patch.Info+    ( PatchInfo(..), rawPatchInfo, showPatchInfo, readPatchInfo+    , piLog, piAuthor, piName, validLog, validAuthor+    , validLogPS, validAuthorPS, piDateString+    )+import Darcs.Test.TestOnly.Instance ()+import Darcs.Util.Parser ( parse )+import Darcs.Patch.Show ( ShowPatchFor(..) )+import Darcs.Util.ByteString+    ( decodeLocale, packStringToUTF8, unpackPSFromUTF8, linesPS )+import Darcs.Util.Printer ( renderPS )+import Darcs.Util.IsoDate (showIsoDateTime, theBeginning)++testSuite :: Test+testSuite = testGroup "Darcs.Patch.Info"+  [ metadataDecodingTest+  , metadataEncodingTest+  , packUnpackTest+  , parseUnparseTest+  ]++-- | A newtype wrapping String so we can make our own random generator for it.+newtype UnicodeString = UnicodeString { asString :: String }+        deriving (Show, Eq, Ord)++-- | A newtype wrapping PatchInfo that has a random generator that generates+--   both UTF-8-encoded and non-encoded PatchInfo's.+newtype UTF8OrNotPatchInfo = UTF8OrNotPatchInfo PatchInfo deriving (Eq, Ord)++-- | A newtype wrapping PatchInfo, which has a random generator that generates+--   only UTF-8-encoded PatchInfo's.+newtype UTF8PatchInfo = UTF8PatchInfo PatchInfo deriving (Eq, Ord)++-- Note that this instance only creates valid unicode strings. It does not+-- generate lone surrogates, for instance, as these would fail the+-- packUnpackTest below.+instance Arbitrary UnicodeString where+    -- 0x10ffff is the highest Unicode code point ; 0xd800 - 0xdfff are+    -- surrogates. '\xfffd' is excluded because it is used as a marker+    -- for UTF-8 test failure.+    arbitrary = UnicodeString `fmap` listOf (oneof [choose ('\0', '\xd799')+                                                   ,choose ('\xe000', '\xfffc')+                                                   ,choose ('\xfffe', '\x10ffff')])++instance Show UTF8PatchInfo where+    show = withUTF8PatchInfo rawPatchInfoShow+instance Show UTF8OrNotPatchInfo where+    show = withUTF8OrNotPatchInfo rawPatchInfoShow++-- | Shows a PatchInfo, outputting every byte and clearly marking what is what+rawPatchInfoShow :: PatchInfo -> String+rawPatchInfoShow = {- ppShow -} show++instance Arbitrary UTF8PatchInfo where+    arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8PatchInfo+    shrink (UTF8PatchInfo pi) = map UTF8PatchInfo (shrinkPatchInfo pi)++instance Arbitrary UTF8OrNotPatchInfo where+    arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8PatchInfo,+                                                  arbitraryUnencodedPatchInfo])+    shrink (UTF8OrNotPatchInfo pi) = map UTF8OrNotPatchInfo (shrinkPatchInfo pi)++-- Generate a random "Ignore-this:" line that makes sure that separately+-- generated PatchInfos are not equal+generateJunk :: Gen String+generateJunk =+  fmap (("Ignore-this: " ++) . concatMap (flip showHex "")) $+  sequence $ replicate 5 (chooseAny :: Gen Word32) ++-- | Generate arbitrary patch metadata.+-- Note : We must NOT use 'patchinfo' from Darcs.Patch.Info+-- with unsafePerformIO here because this breaks  the parse/unparse test+-- (the added junk will be different on each call).+arbitraryUTF8PatchInfo :: Gen PatchInfo+arbitraryUTF8PatchInfo = do+    let d = showIsoDateTime theBeginning+    n <- (asString `fmap` arbitrary) `suchThat` validLog+    a <- (asString `fmap` arbitrary) `suchThat` validAuthor+    l <- lines `fmap` scale (* 2) (asString <$> arbitrary)+    junk <- generateJunk+    i <- arbitrary+    return $ rawPatchInfo d n a (l ++ [junk]) i++-- | Generate arbitrary patch metadata that has totally arbitrary byte strings+--   as its name, date, author and log, as well as an arbitrary "legacy+--   inverted" setting.+arbitraryUnencodedPatchInfo :: Gen PatchInfo+arbitraryUnencodedPatchInfo = do+    let d = BC.pack (showIsoDateTime theBeginning)+    n <- arbitraryByteString `suchThat` validLogPS+    a <- arbitraryByteString `suchThat` validAuthorPS+    l <- linesPS `fmap` scale (* 2) arbitraryByteString+    junk <- generateJunk+    i <- arbitrary+    return (PatchInfo d n a (l ++ [BC.pack junk]) i)++arbitraryByteString :: Gen B.ByteString+arbitraryByteString = B.pack <$> listOf arbitrary++-- | Test that anything produced by the 'patchinfo' function is valid UTF-8+metadataEncodingTest :: Test+metadataEncodingTest =+    testProperty "Testing patch metadata encoding" propMetadataEncoding++propMetadataEncoding :: UTF8PatchInfo -> Bool+propMetadataEncoding (UTF8PatchInfo patchInfo) =+    encodingOK (_piAuthor patchInfo)+    && encodingOK (_piName patchInfo)+    && all encodingOK (_piLog patchInfo)+  where+    encodingOK = isNothing . T.find (=='\xfffd') . decodeUtf8With lenientDecode++-- | Test that metadata in patches are decoded as UTF-8 or locale depending on+-- whether they're valid UTF-8.+metadataDecodingTest :: Test+metadataDecodingTest = testProperty "Testing patch metadata decoding" propMetadataDecoding++propMetadataDecoding :: UTF8OrNotPatchInfo -> Bool+propMetadataDecoding (UTF8OrNotPatchInfo patchInfo) =+    utf8OrLocale (_piAuthor patchInfo) == piAuthor patchInfo+    && utf8OrLocale (_piName patchInfo) == piName patchInfo+    && map utf8OrLocale (_piLog patchInfo) `superset` piLog patchInfo+  where+    utf8OrLocale bs =+      if isValidUTF8 bs then unpackPSFromUTF8 bs else decodeLocale bs++isValidUTF8 :: B.ByteString -> Bool+isValidUTF8 = not . T.any (=='\xfffd') . decodeUtf8With lenientDecode++packUnpackTest :: Test+packUnpackTest = testProperty "Testing UTF-8 packing and unpacking" $+    \uString -> asString uString == (unpackPSFromUTF8 . packStringToUTF8) (asString uString)++superset :: Ord a => [a] -> [a] -> Bool+superset a b = sorted_superset (sort a) (sort b)+  where sorted_superset (x:xs) (y:ys) | x == y = sorted_superset xs ys+                                      | x <  y = sorted_superset xs (y:ys)+                                      | otherwise = False+        sorted_superset []     (_:_)           = False+        sorted_superset _      []              = True++withUTF8PatchInfo :: (PatchInfo -> a) -> UTF8PatchInfo -> a+withUTF8PatchInfo f mpi = case mpi of+                            UTF8PatchInfo pinf -> f pinf+withUTF8OrNotPatchInfo :: (PatchInfo -> a) -> UTF8OrNotPatchInfo -> a+withUTF8OrNotPatchInfo f mpi = case mpi of+                                 UTF8OrNotPatchInfo pinf -> f pinf++parseUnparseTest :: Test+parseUnparseTest = testProperty "parse . show == id" propParseUnparse++parsePatchInfo :: B.ByteString -> Either String PatchInfo+parsePatchInfo = fmap fst . parse readPatchInfo++unparsePatchInfo :: PatchInfo -> B.ByteString+unparsePatchInfo = renderPS . showPatchInfo ForStorage++-- Once generated, we assume that shrinking will preserve UTF8ness etc,+-- so we reuse this function for all the various Arbitrary instances+shrinkPatchInfo :: PatchInfo -> [PatchInfo]+shrinkPatchInfo pi =+  go shrink return return return <|>+  go return shrink return return <|>+  go return return shrink return <|>+  go return return return shrink+  where+    go f1 f2 f3 f4 = do+      sn <- f1 (piName pi)+      sa <- f2 (piAuthor pi)+      sl <- f3 logLines+      i <- f4 (_piLegacyIsInverted pi)+      return $ rawPatchInfo (piDateString pi) sn sa (sl ++ junkLines) i+    -- We need to be careful to preserve the junk lines to prevent creating+    -- two identical PatchInfos from different ones, which would break darcs' invariants+    -- and cause a genuine failure to be shrunk into a spurious one.+    (junkLines, logLines) = partition (isPrefixOf "Ignore-this:") . map BC.unpack . _piLog $ pi++instance Arbitrary PatchInfo where+    arbitrary = arbitraryUnencodedPatchInfo+    shrink = shrinkPatchInfo++propParseUnparse :: PatchInfo -> Bool+propParseUnparse pi = Right pi == parsePatchInfo (unparsePatchInfo pi)
+ harness/Darcs/Test/Patch/Merge/Checked.hs view
@@ -0,0 +1,92 @@+module Darcs.Test.Patch.Merge.Checked+  ( CheckedMerge(..), checkedMerger+  ) where++import Darcs.Prelude++import Darcs.Patch.Commute+import Darcs.Patch.CommuteFn+import Darcs.Patch.Effect+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Invert+import Darcs.Patch.Merge+import Darcs.Patch.Named+import Darcs.Patch.Permutations ( (=\~/=) )++import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), (:>)(..)+    )++import GHC.Stack++class+  (Merge p, Effect p, Eq2 p, Eq2 (PrimOf p), Commute p, Commute (PrimOf p), Invert (PrimOf p))+  => CheckedMerge p+  where++  -- |V1 and V2 merges can produce invalid patches. We use 'checkedMerger' to+  -- validate all merges and fail if there is a problem. When generating tests+  -- we might want to continue after a failure instead of reporting it, so we+  -- can test some other property on all *valid* V1/V2 patches.+  --+  -- This hook allows V1/V2 patches to catch such errors using unsafePerformIO.+  -- Type type is generic to allow arbitrary structures containing mergers to+  -- be checked - e.g. a tuple of two merge results.+  --+  -- There are three reasonable ways of implementing validateMerge. The default+  -- is 'Just' which means no validation.+  --+  -- For repo patch types that might have errors, use unsafePerformIO with try and+  -- evaluate to catch errors and convert them into Nothing.+  --+  -- Finally for compound patch types like Named, FL etc, just delegate to+  -- validateMerge of the underlying patch type.+  --+  -- We could do all this in the Maybe monad right through, but that would+  -- pollute all the generic code with a monad that is only needed because of bugs+  -- in "older" patch implementations+  validateMerge :: a -> Maybe a+  validateMerge = Just++instance CheckedMerge p => CheckedMerge (Named p) where+  validateMerge = validateMerge @p++instance CheckedMerge p => CheckedMerge (FL p) where+  validateMerge = validateMerge @p++checkedMerger :: (HasCallStack, CheckedMerge p) => MergeFn p p -> MergeFn p p+checkedMerger fn pair = let res = fn pair in checkMerge pair res `seq` res++checkMerge+  :: (HasCallStack, CheckedMerge p)+  => (p :\/: p) wX wY+  -> (p :/\: p) wX wY+  -> ()+checkMerge (p :\/: q) (q' :/\: p')+  -- TODO this check doesn't work at the moment - try to enable it and see if it makes+  -- sense to keep or not.+  -- The convoluted guard False==True is to avoid a warning as the pattern match checker+  -- knows that False makes a guard unreachable.+  | False==True, NotEq <- (p :>: q' :>: NilFL) =\~/= (q :>: p' :>: NilFL) =+      error "internal error: merge didn't produce equivalent sequences"+  | NotEq <- squashes (effect p +>+ effect q' +>+ invert (effect q +>+ effect p')) =+      error "internal error: merge didn't produce equivalent effects"+  | otherwise = ()++squashCons :: (Commute p, Eq2 p, Invert p) => p wX wY -> FL p wY wZ -> FL p wX wZ+squashCons p NilFL = p :>: NilFL+squashCons p (q :>: qs)+  | IsEq <- invert p =\/= q = qs+  | Just (q' :> p') <- commute (p :> q) = q' :>: squashCons p' qs+  | otherwise = p :>: q :>: qs++squash :: (Commute p, Eq2 p, Invert p) => FL p wX wY -> FL p wX wY+squash NilFL = NilFL+squash (p :>: ps) = squashCons p (squash ps)++squashes :: (Commute p, Eq2 p, Invert p) => FL p wX wY -> EqCheck wX wY+squashes ps =+  case squash ps of+    NilFL -> IsEq+    _ -> NotEq
+ harness/Darcs/Test/Patch/Properties.hs view
@@ -0,0 +1,464 @@+--  Copyright (C) 2002-2005,2007 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++-- UndecidableInstances was added because GHC 8.6 needed it+-- even though GHC 8.2 didn't+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Properties+  ( unit_V1P1+  , unit_V2P1+  , qc_V1P1+  , qc_V2+  , qc_V3+  , qc_prim+  , qc_named_prim+  ) where++import Darcs.Prelude++import Data.Constraint ( Dict(..) )+import Data.Maybe ( fromMaybe )+import Test.Framework ( Test )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.QuickCheck( Arbitrary(..) )++import Darcs.Test.Util.TestResult ( TestResult, maybeFailed )+import Darcs.Test.Patch.Utils+    ( PropList+    , TestCheck(..)+    , TestCondition(..)+    , TestGenerator(..)+    , properties+    , testCases+    , testConditional+    )++import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq ( Eq2, unsafeCompare )+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.FromPrim ( PrimOf, FromPrim(..) )+import Darcs.Patch.Prim ( PrimPatch, coalesce )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim )+import Darcs.Patch.Prim.Named ( NamedPrim )+import Darcs.Patch.V1 ( RepoPatchV1 )+import Darcs.Patch.V2.RepoPatch ( isConsistent, isForward, RepoPatchV2 )+import Darcs.Patch.V3 ( RepoPatchV3 )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.Show ( ShowPatchBasic )+import Darcs.Patch.Apply( Apply, ApplyState )+import Darcs.Patch.Merge ( Merge )++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.Named ()+import Darcs.Test.Patch.Arbitrary.PatchTree+import Darcs.Test.Patch.Arbitrary.PrimFileUUID()+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Arbitrary.RepoPatchV1 ()+import Darcs.Test.Patch.Arbitrary.RepoPatchV2 ()+import Darcs.Test.Patch.Arbitrary.RepoPatchV3 ()+import Darcs.Test.Patch.Arbitrary.PrimV1 ()+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Test.Patch.WithState+    ( PropagateShrink+    , ShrinkModel+    , WithState(..)+    , ArbitraryWS(..)+    )++import qualified Darcs.Test.Patch.Examples.Set1 as Ex+import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU++import Darcs.Test.Patch.Properties.Check( Check(..) )+import Darcs.Test.Patch.Properties.Generic ( PatchProperty, MergeProperty, SequenceProperty )+import qualified Darcs.Test.Patch.Properties.Generic as PropG+import qualified Darcs.Test.Patch.Properties.RepoPatch as PropR+import qualified Darcs.Test.Patch.Properties.RepoPatchV3 as PropR3+import qualified Darcs.Test.Patch.Properties.GenericUnwitnessed as PropU+import qualified Darcs.Test.Patch.Properties.V1Set1 as Prop1+import qualified Darcs.Test.Patch.Properties.V1Set2 as Prop2++import Darcs.Test.Patch.Types.Triple (Triple(..))++import qualified Darcs.Test.Patch.WSub as WSub++type Prim2 = V2.Prim++unit_V1P1:: [Test]+unit_V1P1 =+  [ 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" PropG.mergeEitherWayValid Ex.mergePairs+  , testCases "merge properties: merge swap" PropG.mergeEitherWay Ex.mergePairs+  , testCases "primitive patch IO functions" (Prop1.tShowRead unsafeCompare) Ex.primitiveTestPatches+  , testCases "IO functions (test patches)" (Prop1.tShowRead unsafeCompare) 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]+unit_V2P1 =+  [ testCases "coalesce commute" (PropU.coalesceCommute WSub.coalesce) ExU.primPermutables+  , testCases "prim recommute" (PropU.recommute WSub.commute) ExU.commutables+  , testCases "square commute law" (PropU.squareCommuteLaw WSub.commute) ExU.commutables+  , testCases "prim inverses commute" (PropU.commuteInverses WSub.commute) ExU.commutables+  , testCases "FL prim recommute" (PropU.recommute WSub.commute) ExU.commutablesFL+  , testCases "FL square commute law" (PropU.squareCommuteLaw WSub.commute) ExU.commutablesFL+  , testCases "FL prim inverses commute" (PropU.commuteInverses WSub.commute) $ ExU.commutablesFL+  , testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(Prim2 WSub.:> Prim2) wX wY])+  , testCases "read and show work on Prim" PropU.showRead ExU.primPatches+  , testCases "read and show work on RepoPatchV2" PropU.showRead ExU.repov2Patches+  , testCases "example flattenings work" (PropR.propConsistentTreeFlattenings fromPrim2) ExU.repov2PatchLoopExamples+  , testCases "V2 merge input consistent" (PropU.mergeArgumentsConsistent isConsistent) ExU.repov2Mergeables+  , testCases "V2 merge input is forward" (PropU.mergeArgumentsConsistent isForward) ExU.repov2Mergeables+  , testCases "V2 merge output is forward" (PropU.mergeConsistent isForward) ExU.repov2Mergeables+  , testCases "V2 merge output consistent" (PropU.mergeConsistent isConsistent) ExU.repov2Mergeables+  , testCases "V2 merge either way" PropU.mergeEitherWay ExU.repov2Mergeables+  , testCases "V2 merge and commute" PropU.mergeCommute ExU.repov2Mergeables++  , testCases "V2 recommute" (PropU.recommute WSub.commute) ExU.repov2Commutables+  , testCases "V2 inverses commute" (PropU.commuteInverses WSub.commute) ExU.repov2Commutables+  , testCases "V2 permutivity" (PropU.permutivity WSub.commute) ExU.repov2NonduplicateTriples+  ]+  where+    fromPrim2 :: PropR.FromPrimT RepoPatchV2 Prim2+    fromPrim2 = fromAnonymousPrim++arbitraryThing :: TestGenerator thing (Sealed2 thing)+arbitraryThing = TestGenerator (\f p -> Just (unseal2 f p))++arbitraryWSThing :: TestGenerator thing (Sealed2 (WithState thing))+arbitraryWSThing = TestGenerator (\f wsp -> Just (unseal2 (f . wsPatch) wsp))++qc_prim :: forall prim.+           ( TestablePrim prim+           , Show2 prim+           , Show1 (ModelOf prim)+           , MightBeEmptyHunk prim+           , MightHaveDuplicate prim+           , ArbitraryWS prim+           ) => [Test]+qc_prim =+  [testProperty "prim pair coverage" (unseal2 (PropG.propPrimPairCoverage @prim . wsPatch))] +++  -- The following fails because of setpref patches:+  -- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc)+  (case runCoalesceTests @prim of+    Just Dict ->+      [ testProperty "prim coalesce effect preserving"+        (unseal2 $ PropG.coalesceEffectPreserving (fmap maybeToFL . coalesce) :: Sealed2 (WithState (Pair prim)) -> TestResult)+      ]+    Nothing -> [])+    ++ concat+  [ pair_properties         @prim      "arbitrary"    arbitraryWSThing+  , pair_properties         @(FL prim) "arbitrary FL" arbitraryWSThing+  , coalesce_properties     @prim      "arbitrary"    arbitraryWSThing+  , prim_commute_properties @prim      "arbitrary"    arbitraryWSThing+  , prim_commute_properties @(FL prim) "arbitrary FL" arbitraryWSThing+  , patch_properties        @prim      "arbitrary"    arbitraryWSThing+  , patch_properties        @(FL prim) "arbitrary FL" arbitraryWSThing+  , patch_repo_properties   @prim      "arbitrary"    arbitraryThing+  , patch_repo_properties   @(FL prim) "arbitrary FL" arbitraryThing+  , pair_repo_properties    @prim      "arbitrary"    arbitraryThing+  , pair_repo_properties    @(FL prim) "arbitrary FL" arbitraryThing+  , triple_properties       @prim      "arbitrary"    arbitraryWSThing+  , [ testProperty "readPatch/showPatch"+      (unseal2 $ (PropG.showRead . wsPatch) :: Sealed2 (WithState prim) -> TestResult)+    , testProperty "readPatch/showPatch (FL)"+      (unseal2 $ (PropG.showRead . wsPatch) :: Sealed2 (WithState (FL prim)) -> TestResult)+    ]+  ]++qc_named_prim :: forall prim.+                 ( TestablePrim prim+                 , Show2 prim+                 , Show1 (ModelOf (NamedPrim prim))+                 , MightBeEmptyHunk prim+                 ) => [Test]+qc_named_prim =+  qc_prim @(NamedPrim prim) +++  [ testProperty+      "prim inverse doesn't commute"+      (unseal2 $ (PropG.inverseDoesntCommute . wsPatch) :: Sealed2 (WithState (NamedPrim prim)) -> TestResult)+  ]+++qc_V1P1 :: [Test]+qc_V1P1 =+  repoPatchProperties @(RepoPatchV1 V1.Prim) +++  [ testProperty "commuting by patch and its inverse is ok" (Prop2.propCommuteInverse . mapSeal2 (getPair . wsPatch))+  , testProperty "a patch followed by its inverse is identity" (Prop2.propPatchAndInverseIsIdentity . mapSeal2 (getPair . wsPatch))+  , testProperty "'simple smart merge'" Prop2.propSimpleSmartMergeGoodEnough+  , testProperty "commutes are equivalent" (Prop2.propCommuteEquivalency . mapSeal2 (getPair . wsPatch))+  , testProperty "merges are valid" Prop2.propMergeValid+  , testProperty "inverses being valid" (Prop2.propInverseValid . mapSeal2 wsPatch)+  , testProperty "other inverse being valid" (Prop2.propOtherInverseValid . mapSeal2 wsPatch)+  -- 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" (Prop2.propCommuteEitherOrder . mapSeal2 (getTriple . wsPatch))+  , testProperty "commute either way" (Prop2.propCommuteEitherWay . mapSeal2 (getPair . wsPatch))+  , testProperty "the double commute" (Prop2.propCommuteTwice . mapSeal2 (getPair . wsPatch))+  , testProperty "merges commute and are well behaved" Prop2.propMergeIsCommutableAndCorrect+  , testProperty "merges can be swapped" Prop2.propMergeIsSwapable+  ]++qc_V2 :: forall prim wXx wYy.+         ( PrimPatch prim+         , Show1 (ModelOf prim)+         , ShrinkModel prim+         , PropagateShrink prim prim+         , ArbitraryPrim prim+         , RepoState (ModelOf prim) ~ ApplyState prim+         )+      => prim wXx wYy -> [Test]+qc_V2 _ =+  [ testProperty "with quickcheck that patches are consistent"+    (withSingle consistent)+  ]+  ++ repoPatchProperties @(RepoPatchV2 prim)+  ++ concat+  [ merge_properties   @(RepoPatchV2 prim) "tree" (TestGenerator mergePairFromTree)+  , merge_properties   @(RepoPatchV2 prim) "twfp" (TestGenerator mergePairFromTWFP)+  , pair_properties    @(RepoPatchV2 prim) "tree" (TestGenerator (\handle -> commutePairFromTree (handle . Pair)))+  , pair_properties    @(RepoPatchV2 prim) "twfp" (TestGenerator (\handle -> commutePairFromTWFP (handle . Pair)))+  , patch_properties   @(RepoPatchV2 prim) "tree" (TestGenerator patchFromTree)+  , triple_properties  @(RepoPatchV2 prim) "tree" (TestGenerator (\handle -> commuteTripleFromTree (handle . Triple)))+  ]+  where+    consistent :: RepoPatchV2 prim wX wY -> TestResult+    consistent = maybeFailed . isConsistent++qc_V3 :: forall prim wXx wYy.+         ( PrimPatch prim+         , Show1 (ModelOf prim)+         , ShrinkModel prim+         , PropagateShrink prim prim+         , ArbitraryPrim prim+         , RepoState (ModelOf prim) ~ ApplyState prim+         )+      => prim wXx wYy+      -> [Test]+qc_V3 _ =+  [ testProperty "repo invariants"+    (withSequence (PropR3.prop_repoInvariants :: SequenceProperty (RepoPatchV3 prim)))+  ]+  ++ repoPatchProperties @(RepoPatchV3 prim)+  ++ difficultRepoPatchProperties @(RepoPatchV3 prim)++repoPatchProperties :: forall p.+                       ( ArbitraryRepoPatch p+                       , Show2 p+                       , Show1 (ModelOf p)+                       , CheckedMerge p+                       , ShrinkModel (PrimOf p)+                       , PrimBased p+                       )+                    => [Test]+repoPatchProperties =+  [ testProperty "readPatch/showPatch"+      (withSingle (PropG.showRead :: PatchProperty p))+  , testProperty "readPatch/showPatch (RL)"+      (withSequence (PropG.showRead :: SequenceProperty p))+{- we no longer support inversion for RepoPatches+  , testProperty "invert involution"+      (withSingle (PropG.invertInvolution :: PatchProperty p))+  , testProperty "inverse composition"+      (withPair (PropG.inverseComposition :: PairProperty p))+-}+  , testProperty "resolutions don't conflict"+      (withSequence (PropR.propResolutionsDontConflict :: SequenceProperty p))+  ]++-- | These properties regularly fail for RepoPatchV2 with the standard test+-- case generator when we crank up the number of tests (to e.g. 10000).+difficultRepoPatchProperties :: forall p.+                       ( ArbitraryRepoPatch p+                       , ShrinkModel (PrimOf p)+                       , Show2 p+                       , CheckedMerge p+                       , MightHaveDuplicate p+                       , Show1 (ModelOf p)+                       , PrimBased p+                       )+                    => [Test]+difficultRepoPatchProperties =+  [ testProperty "reorderings are consistent"+      (PropR.propConsistentReorderings @p)+{- we no longer support inversion for RepoPatches+  , testProperty "inverses commute"+      (withPair (PropG.commuteInverses com))+  , testConditional "nontrivial inverses commute"+      (withPair nontrivialCommute)+      (withPair (PropG.commuteInverses com))+-}+  , testProperty "recommute"+      (withPair (PropG.recommute com))+  , testConditional "nontrivial recommute"+      (fromMaybe False . withPair nontrivialCommute)+      (withPair (PropG.recommute com))+  , testConditional "permutivity"+      (fromMaybe False . withTriple notDuplicatestriple)+      (withTriple (PropG.permutivity com))+  , testConditional "nontrivial permutivity"+      (fromMaybe False . withTriple (\t -> nontrivialTriple t && notDuplicatestriple t))+      (withTriple (PropG.permutivity com))+  , testProperty "merge either way"+      (withFork (PropG.mergeEitherWay :: MergeProperty p))+{- this test relies on inversion and is thereore only valid for prims+  , testProperty "merge either way valid"+      (withFork (PropG.mergeEitherWayValid :: MergeProperty p))+-}+  , testConditional "nontrivial merge either way"+      (fromMaybe False . withFork nontrivialMerge)+      (withFork (PropG.mergeEitherWay :: MergeProperty p))+  , testProperty "merge commute"+      (withFork (PropG.mergeCommute :: MergeProperty p))+  , testProperty "resolutions are invariant under reorderings"+      (withSequence (PropR.propResolutionsOrderIndependent :: SequenceProperty p))+  ]+  where+    com :: (p :> p) wA wB -> Maybe ((p :> p) wA wB)+    com = commute++pair_properties :: forall p gen+                 . ( Show gen, Arbitrary gen, MightHaveDuplicate p+                   , Commute p, Invert p, ShowPatchBasic p, Eq2 p+                   )+                => PropList (Pair p) gen+pair_properties genname gen =+  properties gen "commute" genname+  [ ("recommute"              , TestCondition (const True)     , TestCheck (PropG.recommute commute)           )+  , ("nontrivial recommute"   , TestCondition nontrivialCommute, TestCheck (PropG.recommute commute)           )+  , ("inverses commute"       , TestCondition (const True)     , TestCheck (PropG.commuteInverses commute)     )+  , ("nontrivial inverses"    , TestCondition nontrivialCommute, TestCheck (PropG.commuteInverses commute)     )+  , ("inverse composition"    , TestCondition (const True)     , TestCheck PropG.inverseComposition            )+  ]++coalesce_properties :: forall p gen+                     . ( Show gen, Arbitrary gen, TestablePrim p+                       , MightBeEmptyHunk p+                       )+                    => PropList (Triple p) gen+coalesce_properties genname gen =+  properties gen "commute" genname+   (case runCoalesceTests @p of+      Just Dict ->+        [ ( "coalesce commutes with commute"+          , TestCondition (const True)+          , TestCheck (PropG.coalesceCommute (fmap maybeToFL . coalesce) . getTriple))+        ]+      Nothing -> [])++-- The following properties do not hold for "RepoPatchV2" patches (conflictors and+-- duplicates, specifically) .+prim_commute_properties :: forall p gen+                            . (Show gen, Arbitrary gen, Commute p, Invert p, ShowPatchBasic p, Eq2 p)+                           => PropList (Pair p) gen+prim_commute_properties genname gen =+  properties gen "commute" genname+  [ ("square commute law", TestCondition (const True)     , TestCheck (PropG.squareCommuteLaw commute))+  , ("nontrivial square commute law", TestCondition nontrivialCommute, TestCheck (PropG.squareCommuteLaw commute))+  ]++patch_properties :: forall p gen .+                    ( Show gen+                    , Arbitrary gen+                    , Invert p+                    , Eq2 p+                    , ShowPatchBasic p+                    )+                 => PropList p gen+patch_properties genname gen =+  properties gen "patch" genname+  [ ("inverse . inverse is id"  , TestCondition (const True)     , TestCheck PropG.invertInvolution)+  ]++patch_repo_properties+  :: forall p gen+   . ( Show gen, Arbitrary gen+     , Invert p, Apply p, ShowPatchBasic p+     , RepoModel (ModelOf p)+     , RepoState (ModelOf p) ~ ApplyState p+     )+  =>  PropList (WithState p) gen+patch_repo_properties genname gen =+  properties gen "patch/repo" genname+  [ ("invert rollback"          , TestCondition (const True)     , TestCheck PropG.invertRollback)+  ]++merge_properties :: forall p gen .+                    ( Show gen, Arbitrary gen, Commute p+                    , Invert p, Eq2 p, Merge p, ShowPatchBasic p+                    , MightHaveDuplicate p, Check p+                    )+                 => PropList (p :\/: p) gen+merge_properties genname gen =+  properties gen "merge" genname+  [ ("merge either way"           , TestCondition (const True)   , TestCheck PropG.mergeEitherWay      )+  , ("merge either way valid"     , TestCondition (const True)   , TestCheck PropG.mergeEitherWayValid )+  , ("nontrivial merge either way", TestCondition nontrivialMerge, TestCheck PropG.mergeEitherWay      )+  , ("merge commute"              , TestCondition (const True)   , TestCheck PropG.mergeCommute        )+  ]++triple_properties :: forall p gen .+                     ( Show gen, Arbitrary gen, Commute p+                     , Eq2 p, ShowPatchBasic p+                     , MightHaveDuplicate p+                     )+                  => PropList (Triple p) gen+triple_properties genname gen =+  properties gen "triple" genname+  [ ( "permutivity"+    , TestCondition (notDuplicatestriple . getTriple)+    , TestCheck (PropG.permutivity commute . getTriple) )+  , ( "nontrivial permutivity"+    , TestCondition (\(Triple t) -> nontrivialTriple t && notDuplicatestriple t)+    , TestCheck (PropG.permutivity commute . getTriple) )+  ]++pair_repo_properties+  :: forall p gen .+     ( Show gen+     , Arbitrary gen+     , Commute p+     , Apply p+     , ShowPatchBasic p+     , MightBeEmptyHunk p+     , RepoModel (ModelOf p)+     , RepoState (ModelOf p) ~ ApplyState p+     )+  => PropList (WithState (Pair p)) gen+pair_repo_properties genname gen =+  properties gen "patch/repo" genname+    [ ( "commute is effect preserving"+      , TestCondition (const True)+      , TestCheck (PropG.effectPreserving commute))+    ]+
+ harness/Darcs/Test/Patch/Properties/Check.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Darcs.Test.Patch.Properties.Check ( Check(..), checkAPatch ) where++import Prelude ()+import Darcs.Prelude+import Control.Monad ( liftM )++import Darcs.Test.Patch.Check ( PatchCheck,+                                checkMove, removeDir, createDir,+                                isValid, insertLine, fileEmpty, fileExists,+                                deleteLine, modifyFile, createFile, removeFile,+                                doCheck, inconsistent, FileContents(..)+                              )+import Darcs.Patch.RegChars ( regChars )+import Darcs.Util.ByteString ( linesPS )+import qualified Data.ByteString as B ( ByteString, null, concat )+import qualified Data.ByteString.Char8 as BC ( break, pack )+import qualified Data.IntMap as M ( mapMaybe )++import Darcs.Patch ( invert, effect, PrimPatch )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.V1 ( )+import Darcs.Patch.V1.Core ( RepoPatchV1(..) )+import Darcs.Patch.V2.RepoPatch ( RepoPatchV2, isConsistent )+import Darcs.Patch.V3.Core ( RepoPatchV3 )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )+import qualified Darcs.Patch.Prim.FileUUID as FileUUID ( Prim )+import Darcs.Patch.Prim.WithName ( PrimWithName(..) )+import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) )+import Darcs.Patch.Witnesses.Ordered++type Prim1 = V1.Prim+type Prim2 = V2.Prim++class Check p where+   checkPatch :: p wX wY -> PatchCheck ()++instance Check p => Check (FL p) where+   checkPatch NilFL = isValid+   checkPatch (p :>: ps) = checkPatch p >> checkPatch ps++instance Check p => Check (p:>p) where+   checkPatch (p1 :> p2) = checkPatch p1 >> checkPatch p2++checkAPatch :: (Invert p, Check p) => p wX wY -> Bool+checkAPatch p = doCheck $ do checkPatch p+                             checkPatch $ invert p++instance PrimPatch prim => Check (RepoPatchV2 prim) where+  checkPatch p = maybe isValid (const inconsistent) $ isConsistent p++instance (PrimPatch prim, Check prim) => Check (RepoPatchV1 prim) where+  checkPatch = checkPatch . effect++instance Check prim => Check (RepoPatchV3 name prim) where+  checkPatch = checkPatch . effect++deriving instance Check Prim1+deriving instance Check Prim2++instance Check prim => Check (PrimWithName name prim) where+  checkPatch = checkPatch . wnPatch++instance Check FileUUID.Prim where+  checkPatch _ = isValid -- XXX++instance Check Prim where++   checkPatch (FP f RmFile) = removeFile f+   checkPatch (FP f AddFile) =  createFile f+   -- This is stupid but was designed that way ages ago:+   -- empty hunks commute with everything, so the file need+   -- not even exist, nor the line in the file.+   -- We nowadays strictly avoid generating empty hunks, in+   -- darcs itself as well as in the test case generators.+   checkPatch (FP _ (Hunk _ [] [])) = error "encountered empty hunk"+   checkPatch (FP f (Hunk line old new)) = do+       fileExists f+       mapM_ (deleteLine f line) old+       mapM_ (insertLine f line) (reverse new)+   checkPatch (FP f (TokReplace t old new)) =+       modifyFile f (tryTokPossibly t old new)+   -- note that the above isn't really a sure check, as it leaves PSomethings+   -- and PNothings which may have contained new...+   checkPatch (FP f (Binary o n)) = do+       fileExists f+       mapM_ (deleteLine f 1) (linesPS o)+       fileEmpty f+       mapM_ (insertLine f 1) (reverse $ linesPS n)++   checkPatch (DP d AddDir) = createDir d+   checkPatch (DP d RmDir) = removeDir d++   checkPatch (Move f f') = checkMove f f'+   checkPatch (ChangePref _ _ _) = isValid++tryTokPossibly :: String -> String -> String+                -> (Maybe FileContents) -> (Maybe FileContents)+tryTokPossibly t o n = liftM $ \contents ->+        let lines' = M.mapMaybe (liftM B.concat+                                  . tryTokInternal t (BC.pack o) (BC.pack n))+                                (fcLines contents)+        in contents { fcLines = lines' }++tryTokInternal :: String -> B.ByteString -> B.ByteString+                 -> B.ByteString -> Maybe [B.ByteString]+tryTokInternal _ _ _ s | B.null s = Just []+tryTokInternal t o n s =+    case BC.break (regChars t) s of+    (before,s') ->+        case BC.break (not . regChars t) s' of+        (tok,after) ->+            case tryTokInternal t o n after of+            Nothing -> Nothing+            Just rest ->+                if tok == o+                then Just $ before : n : rest+                else if tok == n+                     then Nothing+                     else Just $ before : tok : rest
+ harness/Darcs/Test/Patch/Properties/Generic.hs view
@@ -0,0 +1,671 @@+--  Copyright (C) 2007 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.Test.Patch.Properties.Generic+    ( invertInvolution+    , inverseComposition+    , invertRollback+    , recommute+    , commuteInverses+    , effectPreserving+    , inverseDoesntCommute+    , permutivity+    , squareCommuteLaw+    , mergeEitherWay+    , showRead+    , mergeEitherWayValid+    , mergeCommute+    , mergeConsistent+    , mergeArgumentsConsistent+    , coalesceEffectPreserving+    , coalesceCommute+    , PatchProperty+    , MergeProperty+    , SequenceProperty+    , propPrimPairCoverage+    ) where++import Darcs.Prelude++import Darcs.Test.Patch.RepoModel+    ( ModelOf+    , RepoModel+    , RepoState+    , eqModel+    , maybeFail+    , repoApply+    , showModel+    )+import Darcs.Test.Util.TestResult+    ( TestResult+    , failed+    , maybeFailed+    , rejected+    , succeeded+    )+import Darcs.Test.Patch.WithState ( WithState(..) )+import Darcs.Test.Patch.Arbitrary.Generic+    ( MightBeEmptyHunk(..)+    , MightHaveDuplicate(..)+    , TestablePrim+    )+import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check )++import Control.Monad ( msum )++import Darcs.Patch.Witnesses.Show ( Show2(..), show2 )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Show+    ( ShowPatchBasic, displayPatch, showPatch, ShowPatchFor(ForStorage) )+import Darcs.Patch ()+import Darcs.Patch.Apply ( Apply, ApplyState )+import Darcs.Patch.Commute ( Commute, commute, commuteFL )+import Darcs.Patch.CommuteFn ( CommuteFn )+import Darcs.Patch.Merge ( Merge(merge) )+import Darcs.Patch.Read ( readPatch )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+    ( (:/\:)(..)+    , (:>)(..)+    , (:\/:)(..)+    , FL(..)+    , RL(..)+    , mapFL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Util.Printer ( Doc, renderPS, redText, greenText, ($$), text, vcat )+--import Darcs.ColorPrinter ( traceDoc )++import Test.QuickCheck (Property, checkCoverage, cover)++type PatchProperty p = forall wA wB. p wA wB -> TestResult+-- type PairProperty p = forall wA wB. (p :> p) wA wB -> TestResult+type MergeProperty p = forall wA wB. (FL p :\/: FL p) wA wB -> TestResult+type SequenceProperty p = forall wA wB. RL p wA wB -> TestResult++-- | @A^^=A@+invertInvolution :: (Invert p, Eq2 p, ShowPatchBasic p) => p wA wB -> TestResult+invertInvolution p =+  let p' = invert (invert p)+  in case p =\/= p' of+    IsEq  -> succeeded+    NotEq ->+      failed $ redText "p /= p^^, where"+      $$ text "##p=" $$ displayPatch p+      $$ text "##p^^=" $$ displayPatch p'++displayPatchFL :: ShowPatchBasic p => FL p wX wY -> Doc+displayPatchFL = vcat . mapFL displayPatch++-- | @(AB)^ = B^A^@+inverseComposition :: (Invert p, Eq2 p, ShowPatchBasic p)+                   => Pair p wX wY -> TestResult+inverseComposition (Pair (a :> b)) =+  let ab = a:>:b:>:NilFL+      iab = invert ab+      ibia = invert b:>:invert a:>:NilFL+  in case iab =\/= ibia of+    IsEq -> succeeded+    NotEq ->+      failed $ redText "ab^ /= b^a^, where"+      $$ text "##ab=" $$ displayPatchFL ab+      $$ text "##(ab)^=" $$ displayPatchFL iab+      $$ text "##b^a^=" $$ displayPatchFL ibia++-- | @ apply A x = y ==> apply A^ y = x@+invertRollback+  :: ( ApplyState p ~ RepoState model+     , Invert p+     , Apply p+     , ShowPatchBasic p+     , RepoModel model+     , model ~ ModelOf p+     )+  => WithState p wA wB+  -> TestResult+invertRollback (WithState a x b) =+  case maybeFail $ repoApply b (invert x) of+    Nothing -> failed $ redText "x^ not applicable to b."+    Just a' ->+      if a' `eqModel` a+        then+          succeeded+        else+          failed $+            redText "##original repo a:" $$ text (showModel a) $$+            redText "##with patch x:" $$ displayPatch x $$+            redText "##results in b:" $$ text (showModel b) $$+            redText "##but (invert x):" $$ displayPatch (invert x) $$+            redText "##applied to b is a':" $$ text (showModel a') $$+            redText "##which is not equal to a."++-- | recommute   AB ↔ B′A′ if and only if B′A′ ↔ AB+recommute :: (ShowPatchBasic p, Eq2 p, MightHaveDuplicate p)+          => CommuteFn p p+          -> Pair p wA wB -> TestResult+recommute c (Pair (x :> y)) =+    case c (x :> y) of+    Nothing -> rejected+    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, where x" $$ displayPatch x $$+                              redText ":> y" $$ displayPatch y $$+                              redText "y'" $$ displayPatch y' $$+                              redText ":> x'" $$ displayPatch x')+         Just (x'' :> y'') ->+             case y'' =/\= y of+             NotEq -> failed (redText "y'' =/\\= y failed, where x" $$ displayPatch x $$+                              redText ":> y" $$ displayPatch y $$+                              redText "y'" $$ displayPatch y' $$+                              redText ":> x'" $$ displayPatch x' $$+                              redText "x''" $$ displayPatch x'' $$+                              redText ":> y''" $$ displayPatch y'')+             IsEq -> case x'' =/\= x of+                     NotEq -> failed (+                              redText "x'' /= x, where x" $$ displayPatch x $$+                              redText ":> y" $$ displayPatch y $$+                              redText "y'" $$ displayPatch y' $$+                              redText ":> x'" $$ displayPatch x' $$+                              redText "x''" $$ displayPatch x'' $$+                              redText ":> y''" $$ displayPatch y'')+                     IsEq -> succeeded++-- | commuteInverses   AB ↔ B′A′ if and only if B⁻¹A⁻¹ ↔ A′⁻¹B′⁻¹+commuteInverses :: (Invert p, ShowPatchBasic p, Eq2 p)+                => CommuteFn p p+                -> Pair p wA wB -> TestResult+commuteInverses c (Pair (x :> y)) =+    case c (x :> y) of+    Nothing ->+      -- check that inverse commute neither+      case c (invert y :> invert x) of+        Just _ -> failed $+          redText "second commute did not fail"+          $$ redText "x" $$ displayPatch x+          $$ redText "y" $$ displayPatch y+          $$ redText "invert y" $$ displayPatch (invert y)+          $$ redText "invert x" $$ displayPatch (invert x)+        Nothing -> succeeded+    Just (y' :> x') ->+        case c (invert y :> invert x) of+        Nothing -> failed $ redText "second commute failed" $$+                            redText "x" $$ displayPatch x $$ redText "y" $$ displayPatch y $$+                            redText "invert y" $$ displayPatch (invert y) $$ redText "invert x" $$ displayPatch (invert x)+        Just (ix' :> iy') ->+            case invert ix' =/\= x' of+            NotEq -> failed $ redText "invert ix' /= x'" $$+                              redText "x" $$ displayPatch x $$+                              redText "y" $$ displayPatch y $$+                              redText "y'" $$ displayPatch y' $$+                              redText "x'" $$ displayPatch x' $$+                              redText "ix'" $$ displayPatch ix' $$+                              redText "iy'" $$ displayPatch iy' $$+                              redText "invert ix'" $$ displayPatch (invert ix') $$+                              redText "invert iy'" $$ displayPatch (invert iy')+            IsEq -> case y' =\/= invert iy' of+                    NotEq -> failed $ redText "y' /= invert iy'" $$ displayPatch iy' $$ displayPatch y'+                    IsEq -> succeeded++-- | effect preserving  AB <--> B'A' then effect(AB) = effect(B'A')+effectPreserving+  :: ( Apply p+     , MightBeEmptyHunk p+     , RepoModel model+     , model ~ ModelOf p+     , ApplyState p ~ RepoState model+     , ShowPatchBasic p+     )+  => CommuteFn p p+  -> WithState (Pair p) wA wB+  -> TestResult+effectPreserving _ (WithState _ (Pair (x :> _)) _)+  | isEmptyHunk x = rejected+effectPreserving c (WithState r (Pair (x :> y)) r') =+  case c (x :> y) of+    Nothing -> rejected+    Just (y' :> x') ->+      case maybeFail $ repoApply r y' of+        Nothing ->+          failed+          $  redText "##x" $$ displayPatch x+          $$ redText "##y" $$ displayPatch y+          $$ redText "##y'" $$ displayPatch y'+          $$ redText "##x'" $$ displayPatch x'+          $$ redText "##y' is not applicable to r"+          $$ displayModel r+        Just r_y' ->+          case maybeFail $ repoApply r_y' x' of+            Nothing ->+              failed+              $  redText "##x" $$ displayPatch x+              $$ redText "##y" $$ displayPatch y+              $$ redText "##y'" $$ displayPatch y'+              $$ redText "##x'" $$ displayPatch x'+              $$ redText "##x' is not applicable to r_y'"+              $$ displayModel r_y'+            Just r_y'x' ->+              if r_y'x' `eqModel` r'+                then succeeded+                else+                  failed+                  $  redText "##x" $$ displayPatch x+                  $$ redText "##y" $$ displayPatch y+                  $$ redText "##y'" $$ displayPatch y'+                  $$ redText "##x'" $$ displayPatch x'+                  $$ redText "##r_y'x'"+                  $$ displayModel r_y'x'+                  $$ redText "##is not equal to r'"+                  $$ displayModel r'+  where+    displayModel = text . showModel++-- | squareCommuteLaw   If AB ↔ B′A′ then A⁻¹B′ ↔ BA′⁻¹+squareCommuteLaw+  :: (Invert p, ShowPatchBasic p, Eq2 p)+  => CommuteFn p p+  -> Pair p wA wB+  -> TestResult+squareCommuteLaw c (Pair (x :> y)) =+  case c (x :> y) of+    Nothing -> rejected+    Just (y' :> x') ->+      case c (invert x :> y') of+        Nothing ->+          failed $+          redText "-------- original (x :> y)" $$+          displayPatch x $$ redText ":>" $$ displayPatch y $$+          redText "-------- result (y' :> x')" $$+          displayPatch y' $$ redText ":>" $$ displayPatch x' $$+          redText "-------- failed commute (invert x :> y')" $$+          displayPatch (invert x) $$ redText ":>" $$ displayPatch y'+        Just (y'' :> ix') ->+          case y'' =\/= y of+            NotEq ->+              failed $ redText "y'' /= y" $$+              redText "x" $$ displayPatch x $$+              redText "y" $$ displayPatch y $$+              redText "y'" $$ displayPatch y' $$+              redText "x'" $$ displayPatch x' $$+              redText "y''" $$ displayPatch y'' $$+              redText "ix'" $$ displayPatch ix'+            IsEq ->+              case x' =\/= invert ix' of+                NotEq ->+                  failed $ redText "x' /= invert ix'" $$+                  redText "x" $$ displayPatch x $$+                  redText "y" $$ displayPatch y $$+                  redText "y'" $$ displayPatch y' $$+                  redText "x'" $$ displayPatch x' $$+                  redText "invert x" $$ displayPatch (invert x) $$+                  redText "y'" $$ displayPatch y' $$+                  redText "invert ix'" $$ displayPatch (invert ix')+                IsEq -> succeeded++permutivity :: (ShowPatchBasic p, Eq2 p)+            => CommuteFn p p+            -> (p :> p :> p) wA wB -> TestResult+permutivity c (x :> y :> z) =+  case c (x :> y) of+   Nothing -> rejected+   Just (y1 :> x1) ->+    case c (y :> z) of+    Nothing -> rejected+    Just (z2 :> y2) ->+      case c (x :> z2) of+      Nothing ->+        case c (x1 :> z) of+          Just _ -> failed $ redText "##partial permutivity:" $$+            redText "##x" $$ displayPatch x $$+            redText "##y" $$ displayPatch y $$+            redText "##z" $$ displayPatch z $$+            redText "##y1" $$ displayPatch y1 $$+            redText "##x1" $$ displayPatch x1 $$+            redText "##z2" $$ displayPatch z2 $$+            redText "##y2" $$ displayPatch y2 $$+            redText "##x :> z2 does not commute, whereas x1 :> z does"+          Nothing -> succeeded+      Just (z3 :> x3) ->+        case c (x1 :> z) of+          Nothing ->+            failed $ redText "##permutivity1:" $$+              redText "##x" $$ displayPatch x $$+              redText "##y" $$ displayPatch y $$+              redText "##z" $$ displayPatch z $$+              redText "##y1" $$ displayPatch y1 $$+              redText "##y2" $$ displayPatch y2 $$+              redText "##failed commute with z of" $$+              redText "##x1" $$ displayPatch x1 $$+              redText "##whereas x commutes with" $$+              redText "##z2" $$ displayPatch z2+          Just (z4 :> x4) ->+            --traceDoc (greenText "third commuted" $$+            --          greenText "about to commute" $$+            --          greenText "y1" $$ displayPatch y1 $$+            --          greenText "z4" $$ displayPatch z4) $+            case c (y1 :> z4) of+            Nothing ->+              failed $ redText "##permutivity2:" $$+                redText "##failed to commute y1 with z4, where" $$+                redText "##x" $$ displayPatch x $$+                redText "##y" $$ displayPatch y $$+                redText "##z" $$ displayPatch z $$+                redText "##y1" $$ displayPatch y1 $$+                redText "##x1" $$ displayPatch x1 $$+                redText "##z2" $$ displayPatch z2 $$+                redText "##y2" $$ displayPatch y2 $$+                redText "##z3" $$ displayPatch z3 $$+                redText "##x3" $$ displayPatch x3 $$+                redText "##z4" $$ displayPatch z4 $$+                redText "##x4" $$ displayPatch x4+            Just (z3_ :> y4)+                | IsEq <- z3_ =\/= z3 ->+                     --traceDoc (greenText "passed z3") $ error "foobar test" $+                     case c (y4 :> x4) of+                     Nothing -> failed $+                        redText "##permutivity5: input was" $$+                        redText "##x" $$ displayPatch x $$+                        redText "##y" $$ displayPatch y $$+                        redText "##z" $$ displayPatch z $$+                        redText "##z3" $$ displayPatch z3 $$+                        redText "##z4" $$ displayPatch z4 $$+                        redText "##failed commute of" $$+                        redText "##y4" $$ displayPatch y4 $$+                        redText "##x4" $$ displayPatch x4 $$+                        redText "##whereas commute of x and y give" $$+                        redText "##y1" $$ displayPatch y1 $$+                        redText "##x1" $$ displayPatch x1+                     Just (x3_ :> y2_)+                          | NotEq <- x3_ =\/= x3 ->+                              failed $+                                redText "##permutivity6: x3_ /= x3" $$+                                redText "##x3_" $$ displayPatch x3_ $$+                                redText "##x3" $$ displayPatch x3+                          | NotEq <- y2_ =/\= y2 ->+                              failed $+                                redText "##permutivity7: y2_ /= y2" $$+                                redText "##y2_" $$ displayPatch y2_ $$+                                redText "##y2" $$ displayPatch y2+                          | otherwise -> succeeded+                | otherwise ->+                    failed $ redText "##permutivity failed" $$+                             redText "##z3" $$ displayPatch z3 $$+                             redText "##z3_" $$ displayPatch z3_++mergeArgumentsConsistent :: (ShowPatchBasic p) =>+                              (forall wX wY . p wX wY -> Maybe Doc)+                           -> (p :\/: p) wA wB -> TestResult+mergeArgumentsConsistent isConsistent (x :\/: y) =+  maybeFailed $+    msum [(\z -> redText "mergeArgumentsConsistent x" $$ displayPatch x $$ z) `fmap` isConsistent x,+          (\z -> redText "mergeArgumentsConsistent y" $$ displayPatch y $$ z) `fmap` isConsistent y]++mergeConsistent :: (ShowPatchBasic p, Merge p) =>+                           (forall wX wY . p wX wY -> Maybe Doc)+                        -> (p :\/: p) wA wB -> TestResult+mergeConsistent isConsistent (x :\/: y) =+    case merge (x :\/: y) of+    y' :/\: x' ->+      maybeFailed $+        msum [(\z -> redText "mergeConsistent x" $$ displayPatch x $$ z) `fmap` isConsistent x,+              (\z -> redText "mergeConsistent y" $$ displayPatch y $$ z) `fmap` isConsistent y,+              (\z -> redText "mergeConsistent x'" $$ displayPatch x' $$ z $$+                     redText "where x' comes from x" $$ displayPatch x $$+                     redText "and y" $$ displayPatch y) `fmap` isConsistent x',+              (\z -> redText "mergeConsistent y'" $$ displayPatch y' $$ z) `fmap` isConsistent y']++-- merge (A\/B) = B'/\A' <==> merge (B\/A) = A'/\B'+--  or, equivalently,+-- merge . swap_par = swap_antipar . merge+--  where swap_par  (A\/B) = B\/A and swap_antipar (A/\B) = B/\A+-- It should not be needed to test this, since it follows from+-- mergeCommute and recommute.+mergeEitherWay :: (Eq2 p, ShowPatchBasic p, Merge p)+               => (p :\/: p) wX wY -> TestResult+mergeEitherWay (x :\/: y) =+  case merge (x :\/: y) of+    y' :/\: x' ->+      case merge (y :\/: x) of+        x'' :/\: y''+          | IsEq <- x'' =\/= x'+          , IsEq <- y'' =\/= y' -> succeeded+          | otherwise ->+            failed $+              redText "##x" $$ displayPatch x $$+              redText "##y" $$ displayPatch y $$+              redText "##y'" $$ displayPatch y' $$+              redText "##x'" $$ displayPatch x' $$+              redText "##x''" $$ displayPatch x'' $$+              redText "##y''" $$ displayPatch y'' $$+              redText "##x'' /= x' or y'' /= y'"++-- merge (A\/B) = B'/\A' ==> AB' <--> BA'+mergeCommute :: (Eq2 p, ShowPatchBasic p, Commute p, Merge p, MightHaveDuplicate p)+             => (p :\/: p) wX wY -> TestResult+mergeCommute (x :\/: y) =+    case merge (x :\/: y) of+    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" $$ displayPatch x $$+                            redText "y" $$ displayPatch y $$+                            redText "x'" $$ displayPatch x' $$+                            redText "y'" $$ displayPatch y'+        Just (y_ :> x'_)+            | IsEq <- y_ =\/= y,+              IsEq <- x'_ =\/= x' ->+                      case commute (y :> x') of+                      Nothing -> failed $ redText "mergeCommute 2 failed" $$+                                          redText "x" $$ displayPatch x $$+                                          redText "y" $$ displayPatch y $$+                                          redText "x'" $$ displayPatch x' $$+                                          redText "y'" $$ displayPatch y'+                      Just (x_ :> y'_)+                           | IsEq <- x_ =\/= x,+                             IsEq <- y'_ =\/= y' -> succeeded+                           | otherwise -> failed $ redText "mergeCommute 3" $$+                                                   redText "x" $$ displayPatch x $$+                                                   redText "y" $$ displayPatch y $$+                                                   redText "x'" $$ displayPatch x' $$+                                                   redText "y'" $$ displayPatch y' $$+                                                   redText "x_" $$ displayPatch x_ $$+                                                   redText "y'_" $$ displayPatch y'_+            | otherwise -> failed $ redText "mergeCommute 4" $$+                                    redText "x" $$ displayPatch x $$+                                    redText "y" $$ displayPatch y $$+                                    redText "x'" $$ displayPatch x' $$+                                    redText "y'" $$ displayPatch y' $$+                                    redText "x'_" $$ displayPatch x'_ $$+                                    redText "y_" $$ displayPatch y_+++-- | coalesce effect preserving+coalesceEffectPreserving+            :: TestablePrim prim+            => (forall wX wY . (prim :> prim) wX wY -> Maybe (FL prim wX wY))+            -> WithState (Pair prim) wA wB -> TestResult+coalesceEffectPreserving j (WithState r (Pair (a :> b)) r') =+  case j (a :> b) of+       Nothing -> rejected+       Just x  -> case maybeFail $ repoApply r x of+                       Nothing  -> failed $ redText "x is not applicable to r."+                                        $$ text (showModel r)+                                        $$ displayPatch x+                                        $$ redText "a:>b"+                                        $$ displayPatch a $$ displayPatch b+                                        $$ redText "r'="+                                        $$ text (showModel r')+                       Just r_x -> if r_x `eqModel` r'+                                      then succeeded+                                      else failed $ redText "r_x /= r', r="+                                        $$ text (showModel r)+                                        $$ redText "a:>b="+                                        $$ displayPatch a $$ displayPatch b+                                        $$ redText "x="+                                        $$ displayPatch x+                                        $$ redText "r'="+                                        $$ text (showModel r')+                                        $$ redText "r_x="+                                        $$ text (showModel r_x)++coalesceCommute+          :: (TestablePrim 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+    Just x  ->+      case commuteFL (a :> b :>: c :>: NilFL) of+        Just (b' :>: c' :>: NilFL :> a') ->+          case commuteFL (a :> x) of+            Just (x' :> a'') ->+              case a'' =/\= a' of+                NotEq ->+                  failed $ greenText "a'' =/\\= a' failed"+                    $$ display1+                    $$ display2+                IsEq ->+                  case j (b' :> c') of+                    Nothing ->+                      failed $ greenText "coalesce (b':>c') failed"+                        $$ display1+                        $$ display2+                    Just x'' ->+                      case x' =\/= x'' of+                        NotEq ->+                          failed $ greenText "x' =\\/= x'' failed"+                            $$ display1+                            $$ display2+                            $$ display3+                        IsEq -> succeeded+                      where+                        display3 = redText "## coalesce (b':>c') => x''"+                                   $$ displayPatch x''+              where+                display2 =+                     redText "## commute (a:>x) => x'" $$ displayPatch x'+                  $$ redText "## :> a''" $$ displayPatch a''+            _ -> failed $ greenText "commute a x failed" $$ display1+          where+            display1 =+                 redText "## a" $$ displayPatch a+              $$ redText "## b" $$ displayPatch b+              $$ redText "## c" $$ displayPatch c+              $$ redText "## coalesce (b:>c) => x" $$ displayPatch x+              $$ redText "## commute (a:>b:>c) => a'" $$ displayPatch a'+              $$ redText "## b'" $$ displayPatch b'+              $$ redText "## c'" $$ displayPatch c'+        _ -> rejected++-- note: we would normally use displayPatch in the failure message+-- but that would be very misleading here+showRead :: (Show2 p, Eq2 p, ReadPatch p, ShowPatchBasic p) => p wA wB -> TestResult+showRead p =+  let ps = renderPS (showPatch ForStorage p)+   in case readPatch ps of+        Left e -> failed (redText "unable to read " $$ showPatch ForStorage p $$ text e)+        Right (Sealed p')+          | IsEq <- p' =\/= p -> succeeded+          | otherwise ->+            failed $+            redText "##trouble reading patch p" $$ showPatch ForStorage p $$+            redText "##reads as p'" $$+            showPatch ForStorage p' $$+            redText "##aka" $$+            greenText (show2 p) $$+            redText "##and" $$+            greenText (show2 p')++-- vim: fileencoding=utf-8 :++mergeEitherWayValid+  :: (Check p, Merge p, Invert p, ShowPatchBasic p)+  => (p :\/: p) wX wY+  -> TestResult+mergeEitherWayValid (p1 :\/: p2) =+  case merge (p1 :\/: p2) of+    _ :/\: p1' ->+      case p2 :>: p1' :>: NilFL of+        combo2 ->+          case merge (p2 :\/: p1) of+            _ :/\: p2' ->+              case p1 :>: p2' :>: NilFL of+                combo1+                  | not $ checkAPatch combo1 ->+                      failed $ text "combo1 invalid: p1="+                      $$ displayPatch p1+                      $$ text "p2="+                      $$ displayPatch p2+                      $$ text "combo1="+                      $$ vcat (mapFL displayPatch combo1)+                  | checkAPatch (invert combo1 :>: combo2 :>: NilFL) ->+                      succeeded+                  | otherwise ->+                      failed $ text "merge both ways invalid: p1="+                      $$ displayPatch p1+                      $$ text "p2="+                      $$ displayPatch p2+                      $$ text "combo1="+                      $$ vcat (mapFL displayPatch combo1)+                      $$ text "combo2="+                      $$ vcat (mapFL displayPatch combo2)++inverseDoesntCommute :: (ShowPatchBasic p, Invert p, Commute p)+                     => p wY1 wY2 -> TestResult+inverseDoesntCommute x =+  case commute (x :> invert x) of+    Nothing -> succeeded+    Just (ix' :> x') -> failed $ redText "x:" $$ displayPatch x+      $$ redText "commutes with x^ to ix':" $$ displayPatch ix'+      $$ redText "x':" $$ displayPatch x'++-- This property is just to check the coverage of pairs,+-- it doesn't test any actual property.+propPrimPairCoverage :: forall prim wX wY . (Eq2 prim, Commute prim) => Pair prim wX wY -> Property+propPrimPairCoverage (Pair pq) =+  checkCoverage $+  -- The coverage percentages should pass reliably, but+  -- could be dropped a bit if not.+  let theKind = classifyCommute pq (commute pq) in+    cover 20 (theKind == Failed) "Not Commutable" $+    cover 60 (theKind /= Failed) "Commutable" $+    cover 20 (theKind == Changed) "Representation Changed" $+    True++data CommuteKind = Failed | Unchanged | Changed+  deriving (Eq, Show)++classifyCommute :: Eq2 prim => (prim :> prim) wX wY -> Maybe ((prim :> prim) wX wY) -> CommuteKind+classifyCommute _ Nothing = Failed+classifyCommute (p :> q) (Just (q' :> p'))+  | unsafeCompare p p' && unsafeCompare q q' = Unchanged+  | otherwise = Changed
+ harness/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs view
@@ -0,0 +1,90 @@+module Darcs.Test.Patch.Properties.GenericUnwitnessed where++import Darcs.Prelude++import qualified Darcs.Test.Patch.Properties.Generic as W+     ( permutivity+     , mergeConsistent, mergeArgumentsConsistent, mergeEitherWay+     , mergeCommute, squareCommuteLaw, coalesceCommute, commuteInverses+     , recommute+     , showRead )+import Darcs.Test.Patch.Arbitrary.Generic ( MightHaveDuplicate )+import Darcs.Test.Patch.Arbitrary.PrimV1 ()++import Darcs.Test.Patch.Types.Pair ( Pair(..) )+import Darcs.Test.Patch.WSub+import Darcs.Test.Util.TestResult++import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Show ( ShowPatchBasic, displayPatch )+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Merge ( Merge )+import Darcs.Util.Printer ( Doc, redText, ($$) )+++permutivity :: (ShowPatchBasic wp, Eq2 wp, WSub wp p)+            => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+            -> (p :> p :> p) wA wB -> TestResult+permutivity f = W.permutivity (fmap toW . f . fromW) . toW++mergeEitherWay :: (ShowPatchBasic wp, Eq2 wp, Merge wp, WSub wp p) => (p :\/: p) wX wY -> TestResult+mergeEitherWay = W.mergeEitherWay . toW++commuteInverses :: (Invert wp, ShowPatchBasic wp, Eq2 wp, WSub wp p)+                 => (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+                 -> (p :> p) wA wB -> TestResult+commuteInverses f = W.commuteInverses (fmap toW . f . fromW) . Pair . toW++recommute :: (ShowPatchBasic wp, MightHaveDuplicate wp, Eq2 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) . Pair . toW++mergeCommute :: ( MightHaveDuplicate wp+                , ShowPatchBasic wp+                , Eq2 wp+                , Commute wp+                , Merge wp+                , WSub wp p+                )+             => (p :\/: p) wX wY+             -> TestResult+mergeCommute = W.mergeCommute . toW++mergeConsistent :: (Merge wp, ShowPatchBasic wp, WSub wp p) =>+                           (forall wX wY . p wX wY -> Maybe Doc)+                        -> (p :\/: p) wA wB -> TestResult+mergeConsistent f = W.mergeConsistent (f . fromW) . toW++mergeArgumentsConsistent :: (ShowPatchBasic wp, WSub wp p) =>+                              (forall wX wY . p wX wY -> Maybe Doc)+                           -> (p :\/: p) wA wB -> TestResult+mergeArgumentsConsistent f = W.mergeArgumentsConsistent (f . fromW) . toW++showRead :: (ShowPatchBasic p, ReadPatch p, Eq2 p, Show2 p) => p wX wY -> TestResult+showRead = W.showRead++squareCommuteLaw :: (Invert wp, ShowPatchBasic wp, Eq2 wp, WSub wp p) =>+                             (forall wX wY . (p :> p) wX wY -> Maybe ((p :> p) wX wY))+                          -> (p :> p) wA wB -> TestResult+squareCommuteLaw f = W.squareCommuteLaw (fmap toW . f . fromW) . Pair . toW+++coalesceCommute :: (forall wX wY . (Prim2 :> Prim2) wX wY -> Maybe (FL Prim2 wX wY))+                -> (Prim2 :> Prim2 :> Prim2) wA wB -> TestResult+coalesceCommute f = W.coalesceCommute (fmap toW . f . fromW) . toW++commuteFails :: ShowPatchBasic p+             => ((p :> p) wX wY -> Maybe ((p :> p) wX wY))+             -> (p :> p) wX wY+             -> TestResult+commuteFails c (x :> y) = case c (x :> y) of+                            Nothing -> succeeded+                            Just (y' :> x') ->+                              failed $ redText "x" $$ displayPatch x $$+                                       redText ":> y" $$ displayPatch y $$+                                       redText "y'" $$ displayPatch y' $$+                                       redText ":> x'" $$ displayPatch x'
+ harness/Darcs/Test/Patch/Properties/RepoPatch.hs view
@@ -0,0 +1,157 @@+module Darcs.Test.Patch.Properties.RepoPatch+    ( propConsistentTreeFlattenings+    , propConsistentReorderings+    , propResolutionsDontConflict+    , propResolutionsOrderIndependent+    , FromPrimT+    ) where++import Prelude ()+import Darcs.Prelude++import Data.Maybe ( catMaybes )+import Safe ( tailErr )++import Darcs.Test.Patch.Arbitrary.Generic ( PrimBased )+import Darcs.Test.Patch.Arbitrary.PatchTree+  ( Tree, flattenTree, G2(..), mapTree )+import Darcs.Test.Patch.Merge.Checked ( CheckedMerge )+import Darcs.Test.Patch.Types.MergeableSequence ( MergeableSequence, mergeableSequenceToRL )+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState+                                  , Fail, maybeFail, ModelOf )+import Darcs.Test.Util.TestResult ( TestResult, failed, rejected, succeeded )++import Darcs.Util.Printer ( text, redText, ($$), vsep )++import Darcs.Patch.Conflict ( Conflict(..), ConflictDetails(..), Unravelled )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Merge ( Merge, mergeList )+import Darcs.Patch.Permutations ( permutationsRL, (=\~/=) )+import Darcs.Patch.RepoPatch ( Commute, RepoPatch )+import Darcs.Patch.Show ( displayPatch )++import Darcs.Patch.Witnesses.Eq ( Eq2, isIsEq )+import Darcs.Patch.Witnesses.Ordered ( RL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, Sealed2(..) )+import Darcs.Patch.Witnesses.Show ( Show2 )++assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool+assertEqualFst (x,bx) (y,by)+    | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True+    | Nothing <- maybeFail x, Nothing <- maybeFail y = True+    | otherwise = error ("Not really equal:\n" ++ showx ++ "\nand\n" ++ showy+                         ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by)+      where showx | Just x' <- maybeFail x = showModel x'+                  | otherwise = "Nothing"+            showy | Just y' <- maybeFail y = showModel y'+                  | otherwise = "Nothing"++type FromPrimT rp p = forall wX wY. p wX wY -> rp p wX wY++-- | This property states that any flattening of a 'Tree' of prim patches,+-- when applied to the start state, produces the same end state.+propConsistentTreeFlattenings :: forall rp prim model.+                                 ( RepoModel model+                                 , RepoState model ~ ApplyState prim+                                 , ApplyState (rp prim) ~ ApplyState prim+                                 , Merge (rp prim)+                                 , Apply (rp prim)+                                 , Show2 (rp prim) )+                              => FromPrimT rp prim+                              -> Sealed (WithStartState model (Tree prim))+                              -> TestResult+propConsistentTreeFlattenings fromPrim (Sealed (WithStartState start t)) =+  case flattenTree (mapTree fromPrim t) of+    Sealed (G2 flat') ->+      -- Limit the number of tree flattenings to something sane, as+      -- the length of the original list can grow exponentially.+      let flat = take 20 flat' in+      case map (start `repoApply`) flat of+        rms ->+          if and $ zipWith assertEqualFst (zip rms flat) (tailErr $ zip rms flat)+            then succeeded+            else failed $ redText "oops"++-- | This property states that all reorderings of a sequence of patches,+-- when applied to the same state, give the same result state.+propConsistentReorderings :: ( RepoPatch p+                             , RepoModel (ModelOf p)+                             , RepoState (ModelOf p) ~ ApplyState p+                             , CheckedMerge p+                             , PrimBased p+                             )+                          => Sealed2 (WithStartState2 (MergeableSequence p))+                          -> TestResult+propConsistentReorderings (Sealed2 (WithStartState2 start ms)) =+  case mapM (repoApply start) $ permutationsRL ps of+    Left e -> failed $ redText "could not apply all reorderings:" $$ text (show e)+    Right [] -> error "we should have at least one permutation!"+    Right [_] -> rejected -- only one permutation -> nothing to test+    Right results -> eql results+  where+    eql [] = error "impossible"+    eql [_] = succeeded+    eql (r1:r2:rs)+      | r1 `eqModel` r2 = eql (r2:rs)+      | otherwise =+          failed+          $ redText "result states differ: r1="+          $$ text (showModel r1)+          $$ redText "r2="+          $$ text (showModel r2)+    ps = mergeableSequenceToRL ms++-- | This property states that the standard conflict resolutions for a+-- sequence of patches are independent of any reordering of the sequence.+propResolutionsOrderIndependent :: RepoPatch p => RL p wX wY -> TestResult+propResolutionsOrderIndependent ps =+    check $ map withConflictParts pss+  where+    withConflictParts qs =+      (Sealed qs, map conflictParts $ resolveConflicts NilRL qs)+    pss = permutationsRL ps+    check [] = error "we should have at least one permutation!"+    check [_] = rejected+    check xs = eql xs+    eql [] = error "impossible"+    eql [_] = succeeded+    eql ((ps1,r1):(ps2,r2):rs)+      | listEqBy eqUnravelled r1 r2 = eql ((ps2,r2):rs)+      | otherwise =+          failed $ vsep+            [ redText "resolutions differ: r1="+            , text (show r1)+            , redText "r2="+            , text (show r2)+            , text "for patches"+            , unseal displayPatch ps1+            , text "versus"+            , unseal displayPatch ps2+            ]++-- | Equality for 'Unravelled' is modulo order of patches.+eqUnravelled :: (Commute p, Eq2 p) => Unravelled p wX -> Unravelled p wX -> Bool+eqUnravelled = listEqBy eq where+  eq (Sealed ps) (Sealed qs) = isIsEq $ ps =\~/= qs++-- | Generic list equality with explicitly given comparison for elements.+listEqBy :: (a -> a -> Bool) -> [a] -> [a] -> Bool+listEqBy _ [] [] = True+listEqBy eq (x:xs) (y:ys) = x `eq` y && listEqBy eq xs ys+listEqBy _ _ _ = False++-- | This property states that the standard conflict resolutions for a+-- sequence of patches do not themselves conflict with each other.+propResolutionsDontConflict :: RepoPatch p => RL p wX wY -> TestResult+propResolutionsDontConflict patches =+  case mergeList $ catMaybes $ map conflictMangled $ resolveConflicts NilRL patches of+    Right _ -> succeeded+    Left (Sealed ps, Sealed qs) ->+      failed+        $ redText "resolutions conflict:"+        $$ displayPatch ps+        $$ redText "conflicts with"+        $$ displayPatch qs+        $$ redText "for sequence"+        $$ displayPatch patches
+ harness/Darcs/Test/Patch/Properties/RepoPatchV3.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE PatternSynonyms #-}+module Darcs.Test.Patch.Properties.RepoPatchV3+    ( prop_repoInvariants+    ) where++import Prelude ()+import Darcs.Prelude+import qualified Data.Set as S++import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed )+import Darcs.Test.TestOnly.Instance ()++import Darcs.Patch.Commute+import Darcs.Patch.Ident+import Darcs.Patch.Invert+import Darcs.Patch.Permutations ( headPermutationsRL, partitionRL' )+import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Patch.Show ( displayPatch, ShowPatchFor(..) )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.V3 ( RepoPatchV3 )+import Darcs.Patch.V3.Contexted+import Darcs.Patch.V3.Core ( pattern PrimP, pattern ConflictorP )++import Darcs.Util.Printer++-- * Repo Invariants++-- What we mean with "repo" here is a flattened version i.e. with named patches+-- replaced by their content, disregarding explicit dependencies. This is why+-- we represent them with a plain 'RL' of 'RepoPatchV3'.++prop_repoInvariants :: PrimPatch p => RL (RepoPatchV3 p) wX wY -> TestResult+prop_repoInvariants NilRL = succeeded+prop_repoInvariants (ps :<: p) =+    prop_repoInvariants ps <>+    prop_positiveId p <>+    prop_uniqueId ps p <>+    prop_consistentConflictor p <>+    prop_onlyFirstConflictorReverts ps p <>+    prop_conflictsCommutePastConflictor ps p <>+    prop_containedCtxEq (ps :<: p)+  where+    -- each patch in a repo has a positive identity+    prop_positiveId x+      | positiveId (ident x) = succeeded+      | otherwise = failed $ text "prop_positiveId"+    -- each patch in a repo has a unique identity+    prop_uniqueId xs x+      | ident x `notElem` mapRL ident xs = succeeded+      | otherwise = failed $ text "prop_uniqueId"++prop_consistentConflictor :: (Invert prim, Commute prim)+                          => RepoPatchV3 prim wX1 wX2 -> TestResult+prop_consistentConflictor (ConflictorP _ x p)+  | all prop_ctxInvariants (p : S.toList x)+  , prop_ctxPositive p+  , all prop_ctxPositive x = succeeded+  | otherwise = failed $ text "prop_consistentConflictor"+prop_consistentConflictor _ = succeeded++-- | This property states that a 'Conflictor' reverts only prims that have not+-- already been reverted by any earlier 'Conflictor'. In other words, the set+-- of 'PatchId's of reverted prims does not intersect with the set of those of+-- preceding 'Conflictor'.+prop_onlyFirstConflictorReverts :: PrimPatch p+                                => RL (RepoPatchV3 p) wX wY+                                -> RepoPatchV3 p wY wZ+                                -> TestResult+prop_onlyFirstConflictorReverts ps p+  | S.null doubly_reverted = succeeded+  | otherwise = failed+      $ text "undone patches are already undone:"+      $$ vcat (map (showId ForStorage) (S.toList doubly_reverted))+      $$ text "in the sequence:"+      $$ vcat (mapRL displayPatch (ps :<: p))+  where+    doubly_reverted = S.intersection this_rids preceding_rids+    this_rids = revertedIds p+    preceding_rids = S.unions (mapRL revertedIds ps)+    revertedIds (ConflictorP r _ _) = S.map invertId (idsFL r)+    revertedIds _ = S.empty++-- | This property states that the patches that a conflictor at the+-- end of a repo conflicts with are in the patches preceding it,+-- that these patches together commute past the conflictor, thereby+-- turning the conflictor into a 'Prim' patch.+-- Note that this does not mean that each of them separately commutes+-- past the conflictor, since there may be dependencies among them.+prop_conflictsCommutePastConflictor :: PrimPatch p+                                    => RL (RepoPatchV3 p) wX wY+                                    -> RepoPatchV3 p wY wZ+                                    -> TestResult+prop_conflictsCommutePastConflictor ps p+  | not (xids `S.isSubsetOf` rids)+  = failed+      $ text "conflicting patches not found in repo:"+      $$ vcat (mapRL displayPatch (ps :<: p))+  | not (revertedIds p `S.isSubsetOf` rids)+  = failed+      $ text "undone patches not found in repo:"+      $$ vcat (mapRL displayPatch (ps :<: p))+  | otherwise =+      case partitionRL' ((`S.member` xids) . ident) ps of+        _ :> dragged :> xs ->+          -- If there are patches that are not directly conflicting with p,+          -- but depend on ones that do, these must also commute with p.+          case commuteRL (reverseFL dragged +<+ xs :> p) of+            Just (PrimP _ :> _) -> succeeded+            Just _ ->+              failed+                $ text "commuting conflicts past conflictor does not result in a Prim:"+                $$ displayPatch (ps :<: p)+            Nothing ->+              failed+                $ text "cannot commute conflicts past conflictor:"+                $$ displayPatch (ps :<: p)+  where+    xids = conflictIds p+    rids = idsRL ps+    conflictIds (ConflictorP _ x _) = S.map ctxId x+    conflictIds _ = S.empty+    revertedIds (ConflictorP r _ _) = S.map invertId (idsFL r)+    revertedIds _ = S.empty++-- | This is 'prop_ctxEq' checked for any pair of 'Contexted' patches+-- from an 'RL' of 'RepoPatchV3' that we can bring into a common context.+prop_containedCtxEq :: PrimPatch p => RL (RepoPatchV3 p) wX wY -> TestResult+prop_containedCtxEq =+    allSucceeded . map propCtxEq . pairs . concatMap contextedIn . headPermutationsRL+  where+    pairs :: [a] -> [(a,a)]+    pairs xs = [(x,y) | x <- xs, y <- xs]+    contextedIn (_ :<: ConflictorP _ x p) = p : S.toList x+    contextedIn _ = []+    propCtxEq (cp, cq)+      | prop_ctxEq cp cq = succeeded+      | otherwise =+          failed+          $ text "prop_ctxEq: cp="+          $$ showCtx ForStorage cp+          $$ text "cq="+          $$ showCtx ForStorage cq+    allSucceeded = foldr (<>) succeeded++idsFL :: Ident p => FL p wX wY -> S.Set (PatchId p)+idsFL = S.fromList . mapFL ident++idsRL :: Ident p => RL p wX wY -> S.Set (PatchId p)+idsRL = S.fromList . mapRL ident
+ harness/Darcs/Test/Patch/Properties/V1Set1.hs view
@@ -0,0 +1,142 @@+module Darcs.Test.Patch.Properties.V1Set1+       ( checkMerge, checkMergeEquiv, checkMergeSwap, checkCanon+       , checkCommute, checkCantCommute+       , tShowRead+       , tTestCheck ) where++import Darcs.Prelude++import Darcs.Patch+     ( commute, invert, merge, effect+     , readPatch, showPatch+     , canonizeFL )+import Darcs.Patch.FromPrim ( fromAnonymousPrim )+import Darcs.Patch.Merge ( Merge )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor(..) )+import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import Darcs.Test.Patch.Properties.Check ( checkAPatch )+import Darcs.Util.Printer ( renderPS )+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Patch.Witnesses.Unsafe( unsafeCoercePEnd )+import Darcs.Test.Util.TestResult+import qualified Darcs.Util.Diff as D (DiffAlgorithm(..))+import Darcs.Util.Printer ( text )+++type Patch = V1.RepoPatchV1 V1.Prim+++quickmerge :: (Merge p) => (p :\/: p ) wX wY -> p wY wZ+quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of+                        _ :/\: p1' -> unsafeCoercePEnd p1'++-- ----------------------------------------------------------------------------+-- A number of "comparison" properties: these carry out some operation on+-- inputs (first value in the pair) and compare the results with a known+-- expected value (the second value in the pair).+--++checkMerge :: ((FL Patch:\/: FL Patch) wX wY, FL Patch wY wZ) -> TestResult+checkMerge (p1:\/:p2,p1') =+   case merge (p1:\/:p2) of+   _ :/\: p1a ->+       if isIsEq (p1a =\/= p1')+       then succeeded+       else failed $ text $ "Merge gave wrong value!\n"++show p1++show p2+            ++"I expected\n"++show p1'+            ++"but found instead\n"++show p1a++checkMergeEquiv :: ((FL Patch:\/:FL Patch) wX wY,FL Patch wY wZ) -> TestResult+checkMergeEquiv (p1:\/: p2, pe) =+    case quickmerge (p1:\/:p2) of+    p1' -> if checkAPatch (invert p1 :>: p2 :>: p1' :>: invert pe :>: NilFL)+           then succeeded+           else failed $ text $ "Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2+                 ++"in other words\n" ++ show (p1 :\/: p2)+                 ++"merges as\n" ++ show (merge $ p1 :\/: p2)+                 ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2)+                 ++"which is equivalent to\n" ++ show (effect p1')+                 ++ "should all work out to\n"+                 ++ show pe++checkMergeSwap :: (FL Patch wX wY, FL Patch wX wZ) -> TestResult+checkMergeSwap (p1, p2) =+    case merge (p2:\/:p1) of+    _ :/\: p2' ->+        case merge (p1:\/:p2) of+        _ :/\: p1' ->+            case commute (p1 :> p2') of+            Just (_ :> p1'b) ->+                if not $ p1'b `unsafeCompare` p1'+                then failed $ text $ "Merge swapping problem with...\np1 "+++                      show p1++"merged with\np2 "+++                      show p2++"p1' is\np1' "+++                      show p1'++"p1'b is\np1'b  "+++                      show p1'b+                else succeeded+            Nothing -> failed $ text $ "Merge commuting problem with...\np1 "+++                        show p1++"merged with\np2 "+++                        show p2++"gives\np2' "+++                        show p2'++"which doesn't commute with p1.\n"++checkCanon :: forall wX wY . (FL Patch wX wY, FL Patch wX wY) -> TestResult+checkCanon (p1,p2) =+    if isIsEq $ p1_myers =\/= p2+    then if isIsEq $ p1_patience =\/= p2+         then succeeded+         else failed $ text $ "Canonization with Patience Diff failed:\n"++show p1++"canonized is\n"+               ++ show p1_patience+               ++"which is not\n"++show p2+    else failed $ text $ "Canonization with Myers Diff failed:\n"++show p1++"canonized is\n"+          ++ show p1_myers+          ++"which is not\n"++show p2+    where p1_myers = mapFL_FL fromAnonymousPrim $ canonizeFL D.MyersDiff $ effect p1+          p1_patience = mapFL_FL fromAnonymousPrim $ canonizeFL D.PatienceDiff $ effect p1++checkCommute :: ((FL Patch :> FL Patch) wX wY, (FL Patch :> FL Patch) wX wY) -> TestResult+checkCommute (p2 :> p1,p1' :> p2') =+   case commute (p2 :> p1) of+   Just (p1a :> p2a) ->+       if (p1a :> p2a) == (p1' :> p2')+       then succeeded+       else failed $ text $ "Commute gave wrong value!\n"++show p1++"\n"++show p2+             ++"should be\n"++show p2'++"\n"++show p1'+             ++"but is\n"++show p2a++"\n"++show p1a+   Nothing -> failed $ text $ "Commute failed!\n"++show p1++"\n"++show p2+   <>+   case commute (p1' :> p2') of+   Just (p2a :> p1a) ->+       if (p2a :> p1a) == (p2 :> p1)+       then succeeded+       else failed $ text $ "Commute gave wrong value!\n"++show p2a++"\n"++show p1a+             ++"should have been\n"++show p2'++"\n"++show p1'+   Nothing -> failed $ text $ "Commute failed!\n"++show p2'++"\n"++show p1'++checkCantCommute :: (FL Patch :> FL Patch) wX wY -> TestResult+checkCantCommute (p2 :> p1) =+    case commute (p2 :> p1) of+    Nothing -> succeeded+    _ -> failed $ text $ show p1 ++ "\n\n" ++ show p2 +++          "\nArgh, these guys shouldn't commute!\n"++-- ----------------------------------------------------------------------------+-- A few "test" properties, doing things with input patches and giving a OK/not+-- OK type of answer.++tShowRead :: (Show2 p, ReadPatch p, ShowPatchBasic p)+          => (forall wX wY wW wZ . p wX wY -> p wW wZ -> Bool) -> forall wX wY . p wX wY -> TestResult+tShowRead eq p =+    case readPatch $ renderPS $ showPatch ForStorage p of+    Right (Sealed p') -> if p' `eq` p then succeeded+                        else failed $ text $ "Failed to read shown:  "++(show2 p)++"\n"+    Left e -> failed $ text $ unlines ["Failed to read at all:  "++show2 p, e]++tTestCheck :: forall wX wY . FL Patch wX wY -> TestResult+tTestCheck p = if checkAPatch p+                 then succeeded+                 else failed $ text $ "Failed the check:  "++show p++"\n"
+ harness/Darcs/Test/Patch/Properties/V1Set2.hs view
@@ -0,0 +1,195 @@+-- Copyright (C) 2002-2003,2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Test.Patch.Properties.V1Set2+    ( propCommuteInverse, propPatchAndInverseIsIdentity+    , propSimpleSmartMergeGoodEnough, propCommuteEquivalency+    , propMergeValid, propInverseValid, propOtherInverseValid+    , propCommuteEitherOrder+    , propCommuteEitherWay, propCommuteTwice+    , propMergeIsCommutableAndCorrect, propMergeIsSwapable+    -- TODO: these are exported temporarily to mark them as used+    -- Figure out whether to enable or remove the tests.+    , propUnravelThreeMerge, propUnravelSeqMerge+    , propUnravelOrderIndependent+    ) where++import Prelude ()+import Darcs.Prelude++import Test.QuickCheck+import Data.Maybe ( isJust )++import Darcs.Test.Patch.Properties.Check ( Check, checkAPatch )++import Darcs.Patch ( invert, commute, merge )+import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.V1.Commute ( unravel, merger )+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+    ( Sealed(Sealed), unseal+    , Sealed2(..)+    )+import Darcs.Patch.Witnesses.Unsafe++import Darcs.Test.Patch.Arbitrary.RepoPatchV1 (Patch)++propInverseValid :: Sealed2 (FL Patch) -> Bool+propInverseValid (Sealed2 p1) = checkAPatch (invert p1:>:p1:>:NilFL)+propOtherInverseValid :: Sealed2 (FL Patch) -> Bool+propOtherInverseValid (Sealed2 p1) = checkAPatch (p1:>:invert p1:>:NilFL)++propCommuteTwice :: Sealed2 (FL Patch :> FL Patch) -> Property+propCommuteTwice (Sealed2 (p1:>p2)) =+    (doesCommute p1 p2) ==> (Just (p1:>p2) == (commute (p1:>p2) >>= commute))+doesCommute :: (Eq2 p, Invert p, Commute p, Check p) => p wX wY -> p wY wZ -> Bool+doesCommute p1 p2 =+    commute (p1:>p2) /= Nothing && checkAPatch (p1:>:p2:>:NilFL)+propCommuteEquivalency :: Sealed2 (FL Patch :> FL Patch) -> Property+propCommuteEquivalency (Sealed2 (p1:>p2)) =+    (doesCommute p1 p2) ==>+    case commute (p1:>p2) of+    Just (p2':>p1') -> checkAPatch (p1:>:p2:>:invert p1':>:invert p2':>:NilFL)+    _ -> error "impossible case"++propCommuteEitherWay :: Sealed2 (FL Patch :> FL Patch) -> Property+propCommuteEitherWay (Sealed2 (p1:>p2)) =+    doesCommute p1 p2 ==> doesCommute (invert p2) (invert p1)++propCommuteEitherOrder :: Sealed2 (FL Patch :> FL Patch :> FL Patch) -> Property+propCommuteEitherOrder (Sealed2 (p1:>p2:>p3)) =+    checkAPatch (p1:>:p2:>:p3:>:NilFL) &&+    doesCommute p1 (p2+>+p3) &&+    doesCommute p2 p3 ==>+    case commute (p1:>p2) of+    Nothing -> False+    Just (p2':>p1') ->+        case commute (p1':>p3) of+        Nothing -> False+        Just (p3':>_) ->+            case commute (p2':>p3') of+            Nothing -> False+            Just (p3'' :> _) ->+                case commute (p2:>p3) of+                Nothing -> False+                Just (p3'a:>_) ->+                    case commute (p1:>p3'a) of+                    Just (p3''a:>_) -> isIsEq (p3''a =\/= p3'')+                    Nothing -> False++propPatchAndInverseIsIdentity :: Sealed2 (FL Patch :> FL Patch) -> Property+propPatchAndInverseIsIdentity (Sealed2 (p1:>p2)) =+    checkAPatch (p1:>:p2:>:NilFL) && (commute (p1:>p2) /= Nothing) ==>+    case commute (p1:>p2) of+    Just (p2':>_) -> case commute (invert p1:>p2') of+                    Nothing -> True -- This is a subtle distinction.+                    Just (p2'':>_) -> isIsEq (p2'' =\/= p2)+    Nothing -> error "impossible case"++propMergeIsCommutableAndCorrect :: Sealed2 (FL Patch :\/: FL Patch) -> Property+propMergeIsCommutableAndCorrect (Sealed2 (p1:\/:p2)) =+    checkAPatch (invert p1:>:p2:>:NilFL) ==>+    case merge (p2:\/:p1) of+    p1' :/\: p2' ->+        case commute (p1:>p2') of+        Nothing -> False+        Just (p2'':>p1'') -> isIsEq (p2'' =\/= p2) && isIsEq (p1' =/\= p1'')+propMergeIsSwapable :: Sealed2 (FL Patch :\/: FL Patch) -> Property+propMergeIsSwapable (Sealed2 (p1:\/:p2)) =+    checkAPatch (invert p1:>:p2:>:NilFL) ==>+    case merge (p2:\/:p1) of+    p1' :/\: p2' ->+           case merge (p1:\/:p2) of+           p2''' :/\: p1''' -> isIsEq (p1' =\/= p1''') && isIsEq (p2' =\/= p2''')++propMergeValid :: Sealed2 (FL Patch :\/: FL Patch) -> Property+propMergeValid (Sealed2 (p1:\/:p2)) =+    checkAPatch (invert p1:>:p2:>:NilFL) ==>+    case merge (p2:\/:p1) of+    _ :/\: p2' ->+        checkAPatch (invert p1:>:p2:>:invert p2:>:p1:>:p2':>:NilFL)++propSimpleSmartMergeGoodEnough :: Sealed2 (FL Patch :\/: FL Patch) -> Property+propSimpleSmartMergeGoodEnough (Sealed2 (p1:\/:p2)) =+    checkAPatch (invert p1:>:p2:>:NilFL) ==>+    case simpleSmartMerge (p1 :\/: p2) of+      Nothing -> True+      Just (Sealed p1'a)+       -> isJust ((do+                    p1o :> _ <- commute (p2 :> p1'a)+                    IsEq <- return $ p1o =\/= p1+                    Sealed p2'a <- simpleSmartMerge (p2 :\/: p1)+                    p2b :> p1'b <- commute (p1 :> p2'a)+                    IsEq <- return $ p2 =\/= p2b+                    IsEq <- return $ p1'a =\/= p1'b+                    return ()) :: Maybe ())++simpleSmartMerge :: (Commute p, Invert p) => (p :\/: p) wX wY -> Maybe (Sealed (p wY))+simpleSmartMerge (p1 :\/: p2) =+  case commute (invert p2 :> p1) of+  Just (p1':>_) -> Just (Sealed p1')+  Nothing -> Nothing++-- | The conflict resolution code (glump) begins by "unravelling" the merger+-- into a set of sequences of patches.  Each sequence of patches corresponds+-- to one non-conflicted patch that got merged together with the others.  The+-- result of the unravelling of a series of merges must obviously be+-- independent of the order in which those merges are performed.  This+-- unravelling code (which uses the unwind code mentioned above) uses probably+-- the second most complicated algorithm.  Fortunately, if we can successfully+-- unravel the merger, almost any function of the unravelled merger satisfies+-- the two constraints mentioned above that the conflict resolution code must+-- satisfy.+propUnravelThreeMerge :: Patch wX wY -> Patch wX wZ -> Patch wX wW -> Property+propUnravelThreeMerge p1 p2 p3 =+    checkAPatch (invert p1:>:p2:>:invert p2:>:p3:>:NilFL) ==>+    (unravel $ unseal unsafeCoercePEnd $ merger "0.0"+         (unseal unsafeCoercePEnd (merger "0.0" p2 p3))+         (unseal unsafeCoercePEnd (merger "0.0" p2 p1))) ==+    (unravel $ unseal unsafeCoercePEnd $ merger "0.0"+         (unseal unsafeCoercePEnd (merger "0.0" p1 p3))+         (unseal unsafeCoercePEnd (merger "0.0" p1 p2)))++propUnravelSeqMerge :: Patch wX wY -> Patch wX wZ -> Patch wZ wW -> Property+propUnravelSeqMerge p1 p2 p3 =+    checkAPatch (invert p1:>:p2:>:p3:>:NilFL) ==>+    (unravel $ unseal unsafeCoercePEnd $ merger "0.0"+                   p3+                   (unseal unsafeCoercePEnd $ merger "0.0" p2 p1)) ==+    (unravel $ unseal unsafeCoercePEnd $ merger "0.0"+                      (unseal unsafeCoercePEnd $ merger "0.0" p2 p1)+                      p3)++propUnravelOrderIndependent :: Patch wX wY -> Patch wX wZ -> Property+propUnravelOrderIndependent p1 p2 =+    checkAPatch (invert p1:>:p2:>:NilFL) ==>+    (unravel $ unseal unsafeCoercePEnd $ merger "0.0" p2 p1) ==+    (unravel $ unseal unsafeCoerceP $ merger "0.0" p1 p2)++-- |In order for merges to work right with commuted patches, inverting a patch+-- past a patch and its inverse had golly well better give you the same patch+-- back again.+propCommuteInverse :: Sealed2 (FL Patch :> FL Patch) -> Property+propCommuteInverse (Sealed2 (p1 :> p2)) =+    doesCommute p1 p2 ==> case commute (p1 :> p2) of+                           Nothing -> error "impossible case"+                           Just (_ :> p1') ->+                               case commute (p1' :> invert p2) of+                               Nothing -> False+                               Just (_ :> p1'') -> isIsEq (p1'' =/\= p1)
+ harness/Darcs/Test/Patch/Rebase.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE EmptyDataDecls #-}+module Darcs.Test.Patch.Rebase ( testSuite ) where++import Darcs.Prelude++import Control.Monad ( unless )+import Data.Maybe++import Test.Framework ( Test )+import Test.Framework.Providers.HUnit ( testCase )+import Test.HUnit ( assertFailure )++import Darcs.Patch+import Darcs.Patch.Info+import Darcs.Patch.Named+import Darcs.Patch.Summary+import Darcs.Patch.Rebase.Fixup+import Darcs.Patch.Rebase.Change+import Darcs.Patch.Witnesses.Ordered++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.TestOnly.Instance ()++import Darcs.Util.Path ( unsafeFloatPath )++testSuite :: forall p . (RepoPatch p, ArbitraryPrim (PrimOf p)) => [Test]+testSuite =+    if isJust (hasPrimConstruct @(PrimOf p))+        then+           [ duplicateConflictedEffect @p+           ]+        else+           [+           ]++data WX++duplicateConflictedEffect :: forall p . RepoPatch p => Test+duplicateConflictedEffect =+    testCase "duplicate in rebase fixup has a conflicted effect" $+        unless (all (/= Okay) cStatuses) $+            assertFailure ("unexpected conflicted effect: " ++ show cEffect)+    where+        corePrim = addfile (unsafeFloatPath "file")+        rebase :: RebaseChange (PrimOf p) WX WX+        rebase =+          RC (PrimFixup (invert corePrim) :>: NilFL)+             (NamedP dummyPatchInfo [] (corePrim :>: NilFL))+        dummyPatchInfo = rawPatchInfo "1999" "dummy" "harness" [] False+        cEffect = conflictedEffect rebase+        cStatuses = map (\(IsC status _) -> status) cEffect
+ harness/Darcs/Test/Patch/RepoModel.hs view
@@ -0,0 +1,30 @@+module Darcs.Test.Patch.RepoModel where++import Darcs.Prelude++import Control.Exception ( SomeException )++import Darcs.Patch.Apply ( Apply, ApplyState )+import Darcs.Patch.Witnesses.Ordered ( FL, RL )++import Test.QuickCheck ( Gen )++type Fail = Either SomeException++unFail :: Fail t -> t+unFail = either (error.show) id++maybeFail :: Fail a -> Maybe a+maybeFail = either (const Nothing) Just++class RepoModel model where+  type RepoState model :: (* -> *) -> *+  showModel :: model x -> String+  eqModel :: model x -> model x -> Bool+  aSmallRepo :: Gen (model x)+  repoApply :: (Apply p, ApplyState p ~ RepoState model) => model x -> p x y -> Fail (model y)++type family ModelOf (p :: * -> * -> *) :: * -> *++type instance ModelOf (FL p) = ModelOf p+type instance ModelOf (RL p) = ModelOf p
+ harness/Darcs/Test/Patch/Selection.hs view
@@ -0,0 +1,62 @@+-- Copyright (C) 2016 G. Hoffmann++module Darcs.Test.Patch.Selection ( testSuite ) where++import Darcs.Prelude++import Test.Framework (Test, testGroup)+import Test.Framework.Providers.HUnit ( testCase )++import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..)  )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++import Darcs.Patch.V2 ( RepoPatchV2 )+import qualified Darcs.Patch.V2.Prim as V2++import Darcs.UI.SelectChanges+    ( PatchSelectionOptions(..)+    , selectionConfig+    , runSelection+    , WhichChanges(..)+    )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch )+import Darcs.Patch.Info ( rawPatchInfo )+import Darcs.UI.Options.All+    ( Verbosity(..), WithSummary(..)+    , SelectDeps(..), MatchFlag(..) )++import Darcs.Test.TestOnly.Instance ()++-- A test module for interactive patch selection.++type Patch = RepoPatchV2 V2.Prim++testSuite :: Test+testSuite = testGroup "Darcs.Patch.Selection" $+  [ dontReadContents whch | whch <- [Last, LastReversed, First, FirstReversed] ]++dontReadContents :: WhichChanges -> Test+dontReadContents whch =+    testCase ("Matching on patch metadata does not open patch contents: " ++ show whch)+      $ do+   let -- here is an FL of patches whose metadata can be read but whose contents+       -- should NEVER be read, otherwise something really bad would happen.+       launchNuclearMissilesPatches = unsafeCoerceP $ lnmPatches [ "P " ++ show i | i <- [1..5::Int] ]+       lnmPatches [] = NilFL+       lnmPatches (n:names) = buildPatch n  :>: lnmPatches names+       buildPatch :: String -> PatchInfoAnd Patch wX wY+       buildPatch name = patchInfoAndPatch (rawPatchInfo "1999" name "harness" [] False) (error "Patch content read!")+       pso = PatchSelectionOptions+           { verbosity = Quiet+           , matchFlags = [OnePatch "."]  -- match on every patch+           , interactive = False+           , selectDeps = AutoDeps+           , withSummary = NoSummary+           }+       context = selectionConfig whch "select" pso Nothing Nothing+   (unselected :> selected) <- runSelection launchNuclearMissilesPatches context+   -- Forcing selection to happen (at least to the point of knowing whether unselected+   -- and unselected are NilFL or not) should not evaluate the `undefined` inside of our+   -- patches, ie, we don't need to read too much.+   unselected `seq` selected `seq` return ()+
+ harness/Darcs/Test/Patch/Types/MergeableSequence.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Types.MergeableSequence+  ( MergeableSequence(..)+  , arbitraryMergeableSequence+  , mergeableSequenceToRL+  ) where++import Darcs.Prelude++import Control.Applicative ( (<|>) )+import Test.QuickCheck++import Darcs.Test.Patch.Arbitrary.Generic ( PrimBased(..) )+import Darcs.Test.Patch.Arbitrary.Shrink+import Darcs.Test.Patch.Merge.Checked+import Darcs.Test.Patch.Types.Merged ( Merged, typedMerge )+import Darcs.Test.Patch.WithState+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Util.QuickCheck ( bSized )+import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Apply ( Apply, ApplyState )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase, PrimOf )+import Darcs.Patch.Prim ( sortCoalesceFL, PrimCoalesce )+import Darcs.Patch.Witnesses.Show++-- | This type provides a concrete, pre-merged representation of a sequence+-- of patches that might have conflicts once merged. The structure also allows+-- for conflict resolutions, e.g. in @SeqMS (ParMS x y) z@, @z@ could be a+-- resolution patch.+-- Working with the pre-merged patches makes it easier to manipulate the test+-- case, e.g. for shrinking.+-- Note that although MergeableSequence is parameterised on a patch type @p@+-- that needs to support merging, it only explicitly contains primitive+-- patches. The merged patches are constructed on-the-fly when the structure+-- is used. It's necessary to fix the structure to a specific mergeable patch+-- type because otherwise the merged patches could vary, invalidating the+-- context of conflict resolution patches like @z@.+data MergeableSequence p wX wY where+  NilMS :: MergeableSequence p wX wX+  SeqMS+    :: MergeableSequence p wX wY+    -> OnlyPrim p wY wZ+    -> MergeableSequence p wX wZ+  ParMS+    :: MergeableSequence p wX wA+    -> MergeableSequence p wX wB+    -> MergeableSequence p wX (Merged wA wB)++instance PrimPatchBase p => PrimPatchBase (MergeableSequence p) where+  type PrimOf (MergeableSequence p) = PrimOf p++instance (CheckedMerge p, PrimBased p) => Effect (MergeableSequence p) where+  effect NilMS = NilFL+  effect (SeqMS ps p) = effect ps +>+ primEffect @p p+  effect (ParMS ms1 ms2) =+    let ps1 = mergeableSequenceToRL ms1+        ps2 = mergeableSequenceToRL ms2+    in case typedMerge (reverseRL ps1 :\/:reverseRL ps2) of+      (ps2', _) -> effect ms1 +>+ effect ps2'+++instance+  ( PropagateShrink prim (OnlyPrim p)+  , CheckedMerge p, Effect p, PrimOf p ~ prim+  , Invert prim, PrimCoalesce prim+  , PrimBased p+  )+  => PropagateShrink prim (MergeableSequence p) where+  -- Note that the result of propagateShrink is always either+  -- Just (Just2 _ :> _) or Nothing, so we don't need to worry about+  -- the Just (Nothing2 :> _) case in recursive calls.+  propagateShrink (prim :> NilMS) = Just (Just2 NilMS :> Just2 prim)+  propagateShrink (prim :> SeqMS ps p) = do+    Just2 ps' :> mprim' <- propagateShrink (prim :> ps)+    mp' :> mprim'' <- propagateShrinkMaybe (mprim' :> p)+    let result = case mp' of+          Just2 p' -> SeqMS ps' p'+          Nothing2 -> ps'+    return (Just2 result :> mprim'')+  propagateShrink+    ((prim :: prim wA wB) :>+       ParMS (ms1 :: MergeableSequence p wB wD1) (ms2 :: MergeableSequence p wB wD2)) = do+    Just2 (ms1' :: MergeableSequence p wA wC1) :> (mprim1' :: Maybe2 prim wC1 wD1)+      <- propagateShrink (prim :> ms1)+    Just2 (ms2' :: MergeableSequence p wA wC2) :> (mprim2' :: Maybe2 prim wC2 wD2)+      <- propagateShrink (prim :> ms2)+    let+      ms' :: MergeableSequence p wA (Merged wC1 wC2)+      ms' = parMS ms1' ms2'+      ps1  :: FL p wB wD1+      ps2  :: FL p wB wD2+      mergedps1 :: FL p wD2 (Merged wD1 wD2)+      mergedps2 :: FL p wD1 (Merged wD1 wD2)+      ps1' :: FL p wA wC1+      ps2' :: FL p wA wC2+      mergedps1' :: FL p wC2 (Merged wC1 wC2)+      mergedps2' :: FL p wC1 (Merged wC1 wC2)+      ps1  = reverseRL (mergeableSequenceToRL ms1)+      ps2  = reverseRL (mergeableSequenceToRL ms2)+      ps1' = reverseRL (mergeableSequenceToRL ms1')+      ps2' = reverseRL (mergeableSequenceToRL ms2')+      (mergedps2 , mergedps1 ) = typedMerge (ps1  :\/: ps2 )+      (mergedps2', mergedps1') = typedMerge (ps1' :\/: ps2')+      -- Unless the shrinking prim disappears on both branches of the merge,+      -- we'll need to try to recalculate it for the result of the merge - trying+      -- to use propagateShrink a second time wouldn't guarantee the right+      -- contexts. (This is a bit complicated to see, hence all the type signatures+      -- in this function.)+      recalcShrink+        :: prim wX wY+        -> FL p wY (Merged wD1 wD2)+        -> FL p wX (Merged wC1 wC2)+        -> Maybe (Maybe2 prim (Merged wC1 wC2) (Merged wD1 wD2))+      recalcShrink primIn m1 m2 =+        case sortCoalesceFL (invert (effect m2) +>+ primIn :>: effect m1) of+          NilFL -> Just Nothing2+          prim' :>: NilFL -> Just (Just2 prim')+          -- If we don't get 0 or 1 prims, we can't use this result given the type+          -- of propagateShrink as a whole. If that was changed to return an FL we+          -- could use it, but at the cost of more complexity elsewhere.+          _ -> Nothing+    mprim' :: Maybe2 prim (Merged wC1 wC2) (Merged wD1 wD2)+      <-+      case (mprim1', mprim2') of+        (Nothing2, Nothing2) -> Just Nothing2+        (Just2 prim1', _) | Just prim'' <- recalcShrink prim1' mergedps2 mergedps2' -> Just prim''+        (_, Just2 prim2') | Just prim'' <- recalcShrink prim2' mergedps1 mergedps1' -> Just prim''+        _ -> Nothing+    return (Just2 ms' :> mprim')++instance (Show2 p, PrimBased p) => Show (MergeableSequence p wX wY) where+  showsPrec _d NilMS = showString "NilMS"+  showsPrec d (SeqMS ms p) =+    showParen (d > appPrec) $ showString "SeqMS " . showsPrec2 (appPrec + 1) ms . showString " " . showsPrec2 (appPrec + 1) p+  showsPrec d (ParMS ms1 ms2) =+    showParen (d > appPrec) $ showString "ParMS " . showsPrec2 (appPrec + 1) ms1 . showString " " . showsPrec2 (appPrec + 1) ms2++instance (Show2 p, PrimBased p) => Show1 (MergeableSequence p wX)+instance (Show2 p, PrimBased p) => Show2 (MergeableSequence p)++type instance ModelOf (MergeableSequence p) = ModelOf p++parMS+  :: MergeableSequence p wX wA+  -> MergeableSequence p wX wB+  -> MergeableSequence p wX (Merged wA wB)+parMS NilMS ms = unsafeCoercePEnd ms+parMS ms NilMS = unsafeCoercePEnd ms+parMS ms1 ms2 = ParMS ms1 ms2++instance Shrinkable (OnlyPrim p) => Shrinkable (MergeableSequence p) where+  shrinkInternally NilMS = []+  shrinkInternally (SeqMS ms p) =+    SeqMS ms <$> shrinkInternally p+      <|>+    flip SeqMS p <$> shrinkInternally ms+  shrinkInternally (ParMS ms1 ms2) =+    parMS ms1 <$> shrinkInternally ms2+      <|>+    flip parMS ms2 <$> shrinkInternally ms1++  shrinkAtStart NilMS = []+  shrinkAtStart (SeqMS NilMS p) = mapFlipped (SeqMS NilMS) <$> shrinkAtStart p+  shrinkAtStart (ParMS {}) = []+  shrinkAtStart (SeqMS (ParMS {}) p) = [FlippedSeal (SeqMS NilMS p)]+  shrinkAtStart (SeqMS ms p) = mapFlipped (flip SeqMS p) <$> shrinkAtStart ms++  shrinkAtEnd NilMS = []+  shrinkAtEnd (SeqMS ms p) =+    Sealed ms:map (mapSeal (SeqMS ms)) (shrinkAtEnd p)+  shrinkAtEnd (ParMS ms1 ms2) =+    do+      Sealed ms2' <- shrinkAtEnd ms2+      return $ Sealed $ parMS ms1 ms2'+     <|>+    do+      Sealed ms1' <- shrinkAtEnd ms1+      return $ Sealed $ parMS ms1' ms2++mergeableSequenceToRL+  :: (CheckedMerge p, PrimBased p)+  => MergeableSequence p wX wY+  -> RL p wX wY+mergeableSequenceToRL NilMS = NilRL+mergeableSequenceToRL (SeqMS ms p) = mergeableSequenceToRL ms :<: liftFromPrim p+mergeableSequenceToRL (ParMS ms1 ms2) =+  let+    ps1 = mergeableSequenceToRL ms1+    ps2 = mergeableSequenceToRL ms2+  in+    case typedMerge (reverseRL ps1 :\/: reverseRL ps2) of+      (ps2', _) -> ps1 +<<+ ps2'++-- | Generate an arbitrary sequence of patches, using a generator+-- for the underlying patch type and merging.+-- The sequence uses a given start state and is bounded by a+-- given depth.+arbitraryMergeableSequence+  :: forall model p wX+   . ( RepoModel model+     , CheckedMerge p+     , PrimBased p+     , Apply p, ApplyState p ~ RepoState model+     )+  => (forall wA . model wA -> Gen (Sealed (WithEndState model (OnlyPrim p wA))))+  -> model wX+  -> Int+  -> Gen (Sealed (WithEndState model (MergeableSequence p wX)))+arbitraryMergeableSequence arbitrarySingle = go+  where+    go rm depth+      | depth == 0 = return $ Sealed $ WithEndState NilMS rm+      | otherwise =+        frequency+          [ ( 1+            , do Sealed (WithEndState ms rm') <- go rm (depth - 1)+                 Sealed (WithEndState p rm'') <- arbitrarySingle rm'+                 return $ Sealed $ WithEndState (SeqMS ms p) rm'')+          , ( 3+            , do Sealed (WithEndState ms1 _) <- go rm ((depth + 1) `div` 2)+                 Sealed (WithEndState ms2 _) <- go rm (depth `div` 2)+                 let ps1 = mergeableSequenceToRL ms1+                     ps2 = mergeableSequenceToRL ms2+                 case validateMerge @p (typedMerge (reverseRL ps1 :\/:reverseRL ps2)) of+                   Nothing -> go rm depth+                   Just (ps2', _) ->+                     return $+                       Sealed $+                       WithEndState (parMS ms1 ms2) $ unFail $ repoApply rm (ps1 +>>+ ps2')+            )+          ]++instance+  ( RepoModel model+  , Apply p, ApplyState p ~ RepoState model+  , model ~ ModelOf (OnlyPrim p)+  , model ~ ModelOf p+  , CheckedMerge p+  , PrimBased p+  )+  => ArbitraryState (MergeableSequence p) where+  arbitraryState rm = bSized 3 0.035 9 $ arbitraryMergeableSequence arbitraryState rm
+ harness/Darcs/Test/Patch/Types/Merged.hs view
@@ -0,0 +1,31 @@+module Darcs.Test.Patch.Types.Merged+  ( Merged+  , typedMerge+  ) where++import Darcs.Test.Patch.Merge.Checked+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Merge ( Merge(..), mergerFLFL )++-- | A witness type that makes the result witness of merging explicit:+--+--  wB    ----> Merged wA wB+--   ^           ^+--   |           |+--   |           |+--  wBase ----> wA+--+-- It's quite ad hoc, for example we don't define a type for 'wBase'.+data Merged wA wB++-- | A wrapper around 'merge' for FL that checks each individual merge,+-- and also returns a more strongly typed witness than the usual existential.+typedMerge+  :: CheckedMerge p+  => (FL p :\/: FL p) wA wB+  -> (FL p wA (Merged wA wB), FL p wB (Merged wA wB))+typedMerge (p :\/: q) =+  case mergerFLFL (checkedMerger merge) (p :\/: q) of+    (q' :/\: p') -> (unsafeCoercePEnd q', unsafeCoercePEnd p')+
+ harness/Darcs/Test/Patch/Types/Pair.hs view
@@ -0,0 +1,15 @@+module Darcs.Test.Patch.Types.Pair ( Pair(..) ) where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Show++import Darcs.Test.Patch.RepoModel++newtype Pair p wX wY = Pair { getPair :: (p :> p) wX wY }+  deriving Show++instance Show2 p => Show2 (Pair p)++type instance ModelOf (Pair p) = ModelOf p
+ harness/Darcs/Test/Patch/Types/Triple.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.Types.Triple+  ( Triple(..)+  ) where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.WithState+    ( ArbitraryState(..)+    , WithEndState(..)+    , ArbitraryWS(..)+    , makeWS2Gen+    )++newtype Triple p wX wY = Triple { getTriple :: (p :> p :> p) wX wY }+  deriving Show++instance Show2 p => Show2 (Triple p)++type instance ModelOf (Triple p) = ModelOf p++instance ArbitraryState p => ArbitraryState (Triple p) where+  arbitraryState sIn = do+    Sealed (WithEndState p sOut) <- arbitraryState sIn+    return (Sealed (WithEndState (Triple p) sOut))++instance (RepoModel (ModelOf p), ArbitraryState p) => ArbitraryWS (Triple p) where+  arbitraryWS = makeWS2Gen aSmallRepo
+ harness/Darcs/Test/Patch/Unwind.hs view
@@ -0,0 +1,58 @@+module Darcs.Test.Patch.Unwind+  ( testSuite+  ) where++import Darcs.Prelude++import Darcs.Patch+import Darcs.Patch.Commute+import Darcs.Patch.Unwind+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Show++import Darcs.Test.Patch.Arbitrary.Generic+import Darcs.Test.Patch.Arbitrary.RepoPatch+import Darcs.Test.Patch.Examples.Unwind+import Darcs.Test.Patch.Merge.Checked+import Darcs.Test.Patch.Properties.Generic+import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.WithState+import Darcs.Test.Util.TestResult ( TestResult, succeeded, assertNotFailed )++import Test.Framework ( Test )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Providers.QuickCheck2 ( testProperty )++-- This property could be generalised over all instances of Unwind (not+-- just Named), but in practice it is only interesting for Named, for which+-- the fullUnwind implementation is non-trivial.+propUnwindNamedSucceeds+  :: (Unwind p, PrimPatchBase p)+  => Named p wX wY+  -> TestResult+propUnwindNamedSucceeds p =+  case fullUnwind p of+    Unwound before ps after ->+      lengthFL before `seq` ps `seq` lengthRL after `seq` succeeded++numberedTestCases :: forall a . String -> (a -> TestResult) -> [a] -> [Test]+numberedTestCases text runTest = zipWith numbered [1..]+  where+    numbered :: Int -> a -> Test+    numbered n testItem = testCase (text ++ " " ++ show n) (assertNotFailed $ runTest testItem)++testSuite+  :: forall p+   . ( ArbitraryRepoPatch p, PrimBased p, ArbitraryPrim (OnlyPrim p)+     , ShrinkModel (PrimOf p)+     , Show1 (ModelOf (PrimOf p)), Show2 p+     , CheckedMerge p, Commute (OnlyPrim p)+     )+  => [Test]+testSuite =+    -- TODO these need to take the patch type, currently hard-coded to V1+    numberedTestCases "full unwind example" (withAllSequenceItems propUnwindNamedSucceeds) (examples @p)+      +++  [ testProperty "unwind named succeeds"+     (withAllSequenceItems (propUnwindNamedSucceeds :: PatchProperty (Named p)))+  ]
+ harness/Darcs/Test/Patch/Utils.hs view
@@ -0,0 +1,91 @@+module Darcs.Test.Patch.Utils+    ( testConditional+    , testConditionalMaybe+    , testStringList+    , TestGenerator(..)+    , TestCondition(..)+    , TestCheck(..)+    , PropList+    , properties+    , testCases+    ) where++import Darcs.Prelude++import Data.Maybe ( fromMaybe )++import Test.Framework ( Test, TestName )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.HUnit ( assertFailure )+import Test.QuickCheck ( Arbitrary, Testable, (==>) )++import Darcs.Test.Util.TestResult++-- | Turns a condition and a test function into a conditional quickcheck+--   property that can be run by test-framework.+testConditional+  :: (Arbitrary a, Show a, Testable prop) => TestName     -- ^ Test name+                                          -> (a -> Bool)  -- ^ Condition+                                          -> (a -> prop)  -- ^ Test function+                                          -> Test+testConditional name cond t = testProperty name t'+    where t' x = cond x ==> t x++testConditionalMaybe+  :: (Arbitrary a, Show a, Testable prop)+  => TestName -- ^ Test name+  -> (a -> Maybe Bool) -- ^ Condition+  -> (a -> prop) -- ^ Test function+  -> Test+testConditionalMaybe name cond t = testProperty name t'+  where+    cond' x =+      case cond x of+        Nothing -> False+        Just b -> b+    t' x = cond' x ==> t x++-- | Utility function to run old tests that return a list of error messages,+--   with the empty list meaning success.+testStringList :: String -> [String] -> Test+testStringList name test = testCase name $ mapM_ assertFailure test++-- | Run a test function on a set of data, using HUnit. The test function should+--   return @Nothing@ upon success and a @Just x@ upon failure.+testCases :: String             -- ^ The test name+          -> (a -> TestResult)  -- ^ The test function+          -> [a]                -- ^ The test data+          -> Test+testCases name test datas = testCase name (mapM_ (assertNotFailed . test) datas)++newtype TestGenerator thing gen =+  TestGenerator (forall t. (forall wX wY. thing wX wY -> t) -> (gen -> Maybe t))++newtype TestCondition thing =+  TestCondition (forall wX wY. thing wX wY -> Bool)++newtype TestCheck thing t =+  TestCheck (forall wX wY. thing wX wY -> t)++type PropList what gen = String -> TestGenerator what gen -> [Test]++properties :: forall thing gen. (Show gen, Arbitrary gen)+           => TestGenerator thing gen+           -> String -> String+           -> forall t. (Testable t) => [(String, TestCondition thing, TestCheck thing t)]+           -> [Test]+properties (TestGenerator gen) prefix genname tests =+  [cond name condition check | (name, condition, check) <- tests]+  where+    cond ::+         forall testable. (Testable testable)+      => String+      -> TestCondition thing+      -> TestCheck thing testable+      -> Test+    cond t (TestCondition c) (TestCheck p) =+      testConditional+        (prefix ++ " (" ++ genname ++ "): " ++ t)+        (fromMaybe False . gen c)+        (gen p)
+ harness/Darcs/Test/Patch/V1Model.hs view
@@ -0,0 +1,276 @@+-- | Repository model+module Darcs.Test.Patch.V1Model+  ( V1Model(..)+  , RepoItem(..), File, Dir, Content+  , makeRepo, emptyRepo+  , makeFile, emptyFile+  , emptyDir+  , isFile, isDir+  , fileContent, dirContent+  , isEmpty+  , root+  , filterFiles, filterDirs+  , find+  , list+  , aFilename, aDirname+  , aLine, aContent+  , aFile, aDir+  , aRepo+  ) where+++import Prelude ()+import Darcs.Prelude++import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized )+import Darcs.Test.Patch.RepoModel++import Darcs.Patch.Apply( applyToTree )+import Darcs.Patch.Witnesses.Sealed ( Sealed, seal )+import Darcs.Patch.Witnesses.Show++import Darcs.Util.Path+import Darcs.Util.Tree( Tree, TreeItem )+import Darcs.Util.Tree.Hashed ( darcsUpdateHashes )+import qualified Darcs.Util.Tree as T++import Control.Arrow ( second )+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.Map as M+import Test.QuickCheck+  ( Arbitrary(..)+  , Gen, choose, vectorOf, frequency )++-- import Text.Show.Pretty ( ppShow )++----------------------------------------------------------------------+-- * Model definition++-- | A repository is an abstraction build in top of a 'Tree'.+-- NB: Repository preferences are not supported yet.+newtype V1Model wX = V1Model {+                           repoTree :: Tree Fail+                         }++-- | Repository items may be text files or directories.+-- NB: Binary files are not supported yet.+newtype RepoItem = RepoItem {+                      treeItem :: TreeItem Fail+                   }++type File = RepoItem+type Dir  = RepoItem++type Content = [B.ByteString]++----------------------------------------+-- Instances++data FlatItem = Dir FilePath | File FilePath [String]+  deriving Show++flattenTree :: Tree Fail -> [FlatItem]+flattenTree = map flattenEntry . T.list where+  flattenEntry (fn, T.SubTree _) = Dir (BC.unpack (flatten fn))+  flattenEntry (fn, T.File blob) = File (BC.unpack (flatten fn))+    (map BLC.unpack $ BLC.lines $ unFail $ T.readBlob blob)+  flattenEntry (_, _) = error "impossible case"++instance Show (V1Model wX) where+  show repo = "V1Model " ++ show (flattenTree (repoTree repo))++instance Show1 V1Model++----------------------------------------+-- Utils++bs2lbs :: B.ByteString -> BL.ByteString+bs2lbs bs = BL.fromChunks [bs]++lbs2bs :: BL.ByteString -> B.ByteString+lbs2bs = B.concat . BL.toChunks++content2lbs :: Content -> BL.ByteString+content2lbs = BLC.unlines . map bs2lbs++lbs2content :: BL.ByteString -> Content+lbs2content = map lbs2bs . BLC.lines++----------------------------------------------------------------------+-- * Constructors++makeRepo :: [(Name, RepoItem)] -> V1Model wX+makeRepo = V1Model . T.makeTree . map (second treeItem)++emptyRepo :: V1Model wX+emptyRepo = V1Model T.emptyTree++makeFile :: Content -> File+makeFile = RepoItem . T.File . T.makeBlob . content2lbs++emptyFile :: File+emptyFile = RepoItem $ T.File T.emptyBlob++emptyDir :: Dir+emptyDir = RepoItem $ T.SubTree T.emptyTree++----------------------------------------------------------------------+-- * Queries++nullRepo :: V1Model wX -> Bool+nullRepo = M.null . T.items . repoTree++isFile :: RepoItem -> Bool+isFile (RepoItem (T.File _)) = True+isFile _other                = False++isDir :: RepoItem -> Bool+isDir (RepoItem (T.SubTree _)) = True+isDir _other                   = False++fileContent :: File -> Content+fileContent (RepoItem (T.File blob))+  = lbs2content $ unFail $ T.readBlob blob+fileContent _other+  = error "fileContent: Not a file."++dirContent :: Dir -> [(Name, RepoItem)]+dirContent (RepoItem (T.SubTree subtree))+  = map (second RepoItem) $ M.toList $ T.items subtree+dirContent _other+  = error "dirContent: Not a directory."++-- | @isEmpty file@ <=> file content is empty+--   @isEmpty dir@  <=> dir has no child+isEmpty :: RepoItem -> Bool+isEmpty item+  | isFile item = null $ fileContent item+  | isDir item  = null $ dirContent item+  | otherwise   = undefined++-- | The root directory of a repository.+root :: V1Model wX -> Dir+root = RepoItem . T.SubTree . repoTree++find :: V1Model wX -> AnchoredPath -> Maybe RepoItem+find (V1Model tree) path = RepoItem <$> T.find tree path++-- | List repository items.+-- NB: It does not include the root directory.+list :: V1Model wX -> [(AnchoredPath, RepoItem)]+list (V1Model tree) = map (second RepoItem) $ T.list tree++----------------------------------------------------------------------+-- ** Filtering++filterFiles :: [(n, RepoItem)] -> [(n, File)]+filterFiles = filter (isFile . snd)++filterDirs :: [(n, RepoItem)] -> [(n, Dir)]+filterDirs = filter (isDir . snd)++----------------------------------------------------------------------+-- * Comparing repositories++diffRepos :: V1Model wX -> V1Model wY -> (V1Model wU, V1Model wV)+diffRepos repo1 repo2 =+  let (diff1,diff2) = unFail $ T.diffTrees hashedTree1 hashedTree2+    in (V1Model diff1, V1Model diff2)+  where+      hashedTree1, hashedTree2 :: Tree Fail+      hashedTree1 = unFail $ darcsUpdateHashes $ repoTree repo1+      hashedTree2 = unFail $ darcsUpdateHashes $ repoTree repo2+++----------------------------------------------------------------------+-- * Patch application++----------------------------------------------------------------------+-- * QuickCheck generators++-- Testing code assumes that aFilename and aDirname generators+-- will always be able to generate a unique name given a list of+-- existing names. This should be OK as long as the number of possible+-- file/dirnames is much bigger than the number of files/dirs per repository.++-- 'Arbitrary' 'V1Model' instance is based on the 'aSmallRepo' generator.+++-- | Files are distinguish by ending their names with ".txt".+aFilename :: Gen Name+aFilename = do len <- choose (1,maxLength)+               name <- vectorOf len alpha+               return $ either error id $ makeName (name ++ ".txt")+  where+      maxLength = 3++aDirname :: Gen Name+aDirname = do len <- choose (1,maxLength)+              name <- vectorOf len alpha+              return $ either error id $ makeName name+  where+      maxLength = 3++aWord :: Gen B.ByteString+aWord = do c <- alpha+           return $ BC.pack[c]++aLine :: Gen B.ByteString+aLine = do wordsNo <- choose (1,2)+           ws <- vectorOf wordsNo aWord+           return $ BC.unwords ws++aContent :: Gen Content+aContent = bSized 0 0.5 80 $ \k ->+             do n <- choose (0,k)+                vectorOf n aLine++aFile :: Gen File+aFile = makeFile <$> aContent++-- | See 'aRepo', the same applies for 'aDir'.+aDir :: Int                -- ^ Maximum number of files+        -> Int             -- ^ Maximum number of directories+        -> Gen Dir+aDir filesL dirL = root <$> aRepo filesL dirL++-- | @aRepo filesNo dirsNo@ produces repositories with *at most*+-- @filesNo@ files and @dirsNo@ directories.+-- The structure of the repository is aleatory.+aRepo :: Int                -- ^ Maximum number of files+        -> Int              -- ^ Maximum number of directories+        -> Gen (V1Model wX)+aRepo maxFiles maxDirs+  = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0+       filesNo <- choose (minFiles,maxFiles)+       let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0+       dirsNo <- choose (minDirs,maxDirs)+            -- NB: Thanks to laziness we don't need to care about division by zero+            -- since if dirsNo == 0 then neither filesPerDirL nor subdirsPerDirL will+            -- be evaluated.+       let filesPerDirL   = (maxFiles-filesNo) `div` dirsNo+           subdirsPerDirL = (maxDirs-dirsNo) `div` dirsNo+       files <- vectorOf filesNo aFile+       filenames <- uniques filesNo aFilename+       dirs <- vectorOf dirsNo (aDir filesPerDirL subdirsPerDirL)+       dirnames <- uniques dirsNo aDirname+       return $ makeRepo (filenames `zip` files ++ dirnames `zip` dirs)++-- | Generate small repositories.+-- Small repositories help generating (potentially) conflicting patches.+instance RepoModel V1Model where+  type RepoState V1Model = Tree+  showModel m = show {- ppShow -} m+  aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)]+                  dirsNo <- frequency [(3, return 1), (1, return 0)]+                  aRepo filesNo dirsNo+  repoApply (V1Model tree) patch = V1Model <$> applyToTree patch tree+  eqModel repo1 repo2 = let (diff1,diff2) = diffRepos repo1 repo2+                         in nullRepo diff1 && nullRepo diff2+++instance Arbitrary (Sealed V1Model) where+  arbitrary = seal <$> aSmallRepo
+ harness/Darcs/Test/Patch/WSub.hs view
@@ -0,0 +1,139 @@+{-# LANGUAGE FunctionalDependencies, UndecidableInstances #-}+module Darcs.Test.Patch.WSub where++{-+The Examples.Set2Unwitnessed module builds a lot of test cases by pattern matching+on the results of merge/commute in where clauses. This would+be very painful to switch to using witnesses properly, because+we'd have to make them use case in series.++So instead we give up on witnesses for this module, but instead+of preprocessor hacks which make incompatible code with the rest+of darcs, we build a fresh set of witnesses constructors (FL etc)+which aren't actually GADTs or existentials. So the pattern matching+works as before, but we need to translate back and forth a lot.++We call the normal darcs constructors the 'W' variants.+-}++import Darcs.Prelude++import qualified Darcs.Test.Patch.Arbitrary.PatchTree as W+     ( getPairs, getTriples )++import qualified Darcs.Patch as W ( commute )+import qualified Darcs.Patch.Merge as W ( merge, mergeFL )+import qualified Darcs.Patch.Prim as W ( coalesce )++import qualified Darcs.Patch.Witnesses.Ordered as W+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart, unsafeCoercePEnd )++import Darcs.Patch.Merge ( Merge )+import Darcs.Patch.V2 ( RepoPatchV2 )+import qualified Darcs.Patch.V2.Prim as V2+import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Invert ( Invert(..) )++type Prim2 = V2.Prim+++infixr 5 :>:+infixr 5 +>++infixr 1 :>+infix 1 :/\:+infix 1 :\/:++data FL p wX wY where+   NilFL :: FL p wX wY+   (:>:) :: p wX wY -> FL p wX wY -> FL p wX wY++(+>+) :: FL p wX wY -> FL p wX wY -> FL p wX wY+NilFL +>+ ps = ps+(p :>: ps) +>+ qs = p :>: (ps +>+ qs)++data (p :> q) wX wY where+   (:>) :: p wX wY -> q wX wY -> (p :> q) wX wY++data (p :\/: q) wX wY where+   (:\/:) :: p wX wY -> q wX wY -> (p :\/: q) wX wY++data (p :/\: q) wX wY where+   (:/\:) :: p wX wY -> q wX wY -> (p :/\: q) wX wY++class WSub wp p | p -> wp, wp -> p where+   fromW :: wp wX wY -> p wX wY+   toW :: p wX wY -> wp wX wY++instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:\/: wp2) (p1 :\/: p2) where+   fromW (x W.:\/: y) = unsafeCoerceP (fromW x) :\/: unsafeCoerceP (fromW y)+   toW (x :\/: y) = unsafeCoerceP (toW x) W.:\/: unsafeCoerceP (toW y)++instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:/\: wp2) (p1 :/\: p2) where+   fromW (x W.:/\: y) = unsafeCoerceP (fromW x) :/\: unsafeCoerceP (fromW y)+   toW (x :/\: y) = unsafeCoerceP (toW x) W.:/\: unsafeCoerceP (toW y)++instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:> wp2) (p1 :> p2) where+   fromW (x W.:> y) = unsafeCoercePEnd (fromW x) :> unsafeCoercePStart (fromW y)+   toW (x :> y) = unsafeCoercePEnd (toW x) W.:> unsafeCoercePStart (toW y)++instance WSub wp p => WSub (W.FL wp) (FL p) where+   fromW W.NilFL = unsafeCoerceP NilFL+   fromW (x W.:>: xs) = unsafeCoercePEnd (fromW x) :>: unsafeCoercePStart (fromW xs)++   toW NilFL = unsafeCoerceP W.NilFL+   toW (x :>: xs) = unsafeCoercePEnd (toW x) W.:>: unsafeCoercePStart (toW xs)++instance WSub (RepoPatchV2 prim) (RepoPatchV2 prim) where+   fromW = id+   toW = id++instance WSub Prim2 Prim2 where+   fromW = id+   toW = id++instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :> q) wX wY) where+   show = show . toW++instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :> q)++instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :\/: q) wX wY) where+   show = show . toW++instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :\/: q)++instance (WSub wp p, Show2 wp) => Show (FL p wX wY) where+   show = show . toW++instance (WSub wp p, Show2 wp) => Show2 (FL p)++instance (WSub wp p, Commute wp, Eq2 wp) => Eq2 (FL p) where+   unsafeCompare x y = unsafeCompare (toW x) (toW y)++instance (WSub wp p, Invert wp) => Invert (FL p) where+   invert = fromW . invert . toW++instance (WSub wp p, Commute wp) => Commute (FL p) where+   commute (xs W.:> ys) = do ys' W.:> xs' <- W.commute (toW xs W.:> toW ys)+                             return (fromW ys' W.:> fromW xs')++mergeFL :: (WSub wp p, Merge wp) => (p :\/: FL p) wX wY -> (FL p :/\: p) wX wY+mergeFL = fromW . W.mergeFL . toW++merge :: (WSub wp p, Merge wp) => (p :\/: p) wX wY -> (p :/\: p) wX wY+merge = fromW . W.merge . toW++commute :: (WSub wp p, Commute wp) => (p :> p) wX wY -> Maybe ((p :> p) wX wY)+commute = fmap fromW . W.commute . toW++getPairs :: FL (RepoPatchV2 Prim2) wX wY -> [Sealed2 (RepoPatchV2 Prim2 :> RepoPatchV2 Prim2)]+getPairs = map (mapSeal2 fromW) . W.getPairs . toW++getTriples :: FL (RepoPatchV2 Prim2) wX wY -> [Sealed2 (RepoPatchV2 Prim2 :> RepoPatchV2 Prim2 :> RepoPatchV2 Prim2)]+getTriples = map (mapSeal2 fromW) . W.getTriples . toW++coalesce :: (Prim2 :> Prim2) wX wY -> Maybe (FL Prim2 wX wY)+coalesce = fmap (fromW . maybeToFL) . W.coalesce . toW
+ harness/Darcs/Test/Patch/WithState.hs view
@@ -0,0 +1,339 @@+{-# OPTIONS_GHC -Wno-orphans #-}+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Test.Patch.WithState where++import Darcs.Prelude++import Darcs.Patch.Apply+import Darcs.Patch.Commute+import Darcs.Patch.Effect+import Darcs.Patch.FromPrim+import Darcs.Patch.Invert+import Darcs.Patch.Prim.Class+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Maybe+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show+import Test.QuickCheck ( Gen, sized, choose )++import Darcs.Test.Patch.RepoModel+import Darcs.Test.Patch.Arbitrary.Sealed+import Darcs.Test.Patch.Arbitrary.Shrink+import Darcs.Test.Patch.Types.Pair ( Pair(..) )++import Data.Maybe++----------------------------------------------------------------------+-- * WithState++data WithState p wX wY = WithState {+                              wsStartState :: (ModelOf p) wX+                            , wsPatch      :: p wX wY+                            , wsEndState   :: (ModelOf p) wY+                            }++type instance ModelOf (WithState p) = ModelOf p++instance (Show1 (ModelOf p), Show2 p) => Show (WithState p wX wY) where+  showsPrec d (WithState s p s')+    = showParen (d > appPrec) $ showString "WithState "+                              . showsPrec1 (appPrec+1) s+                              . showString " "+                              . showsPrec2 (appPrec+1) p+                              . showString " "+                              . showsPrec1 (appPrec+1) s'++instance (Show1 (ModelOf p), Show2 p) => Show1 (WithState p wA)++instance (Show1 (ModelOf p), Show2 p) => Show2 (WithState p)++class ArbitraryWS p where+  arbitraryWS :: Gen (Sealed2 (WithState p))+  shrinkWS :: Sealed2 (WithState p) -> [Sealed2 (WithState p)]+  shrinkWS _ = []++instance ArbitraryWS p => ArbitraryS2 (WithState p) where+  arbitraryS2 = arbitraryWS+  shrinkS2 = shrinkWS++instance (ArbitraryState p1, ArbitraryState p2, ModelOf p1 ~ ModelOf p2, RepoModel (ModelOf p1)) => ArbitraryS2 (p1 :\/: p2) where+  arbitraryS2 = do+    repo <- aSmallRepo+    Sealed (WithEndState p1 _) <- arbitraryState repo+    Sealed (WithEndState p2 _) <- arbitraryState repo+    return (Sealed2 (p1 :\/: p2))++arbitraryWSPair :: (RepoModel (ModelOf p), ArbitraryState p) => Gen (Sealed2 (WithState (Pair p)))+arbitraryWSPair = do+  repo <- aSmallRepo+  Sealed (WithEndState pp repo') <- arbitraryStatePair repo+  return $ seal2 $ WithState repo pp repo'++instance (RepoModel (ModelOf p), ArbitraryState p) => ArbitraryWS (Pair p) where+  arbitraryWS = arbitraryWSPair+  shrinkWS _ = []++instance (RepoModel (ModelOf p), ArbitraryState p) => ArbitraryWS (FL p) where+  arbitraryWS = makeWS2Gen aSmallRepo++-- | This is only used for the legacy 'Tree' based test generator, where the+-- @p@ parameter gets instantiated to @'Tree' p@ (which has no definite end+-- state).+data WithStartState s p wX = WithStartState {+                                 wssStartState :: s wX+                               , wssPatch      :: p wX+                               }+    deriving Eq++instance (Show1 s, Show1 p) => Show (WithStartState s p wX) where+   showsPrec d (WithStartState s p) = showParen (d > appPrec) $ showString "WithStartState " .+                                      showsPrec1 (appPrec + 1) s . showString " " .+                                      showsPrec1 (appPrec + 1) p++instance (Show1 s, Show1 p) => Show1 (WithStartState s p)++-- |'WithStartState2' is like 'WithStartState' but for patches that have both witnesses.+data WithStartState2 p wX wY =+  WithStartState2+  { wss2StartState :: ModelOf p wX+  , wss2Patch      :: p wX wY+  }++instance (Show1 (ModelOf p), Show2 p) => Show (WithStartState2 p wX wY) where+  showsPrec d (WithStartState2 s p) =+    showParen (d > appPrec) $ showString "WithStartState2 " .+    showsPrec1 (appPrec + 1) s . showString " " .+    showsPrec2 (appPrec + 1) p++instance (Show1 (ModelOf p), Show2 p) => Show1 (WithStartState2 p wX)+instance (Show1 (ModelOf p), Show2 p) => Show2 (WithStartState2 p)++-- | A combination of a patch and its final state. The state, in this module, is+--   typically represented by a 'RepoModel' value. The @px@ type is typically a+--   patch type applied to its pre-state, e.g. @Prim x@.+data WithEndState s px wY = WithEndState {+                                wesPatch    :: px wY+                              , wesEndState :: s wY+                              }+    deriving Eq++instance (Show1 s, Show1 p) => Show (WithEndState s p wX) where+   showsPrec d (WithEndState p s) = showParen (d > appPrec) $ showString "WithEndState " .+                                    showsPrec1 (appPrec + 1) p . showString " " .+                                    showsPrec1 (appPrec + 1) s+++instance (Show1 s, Show1 p) => Show1 (WithEndState s p)+++----------------------------------------------------------------------+-- * ArbitraryState generators++-- | A type class to generate arbitrary values, threading a state through the+--   arbitrary calls. So this can be used to generate a patch that comes after+--   another patch. The post-state of the generated patch is hidden by the+--   'Sealed'.+class ArbitraryState p where+  arbitraryState :: ModelOf p wX -> Gen (Sealed (WithEndState (ModelOf p) (p wX)))++  -- |This member is to allow specialising generation of pairs,+  -- e.g. to increase the frequency of commutable ones.+  arbitraryStatePair :: ModelOf p wX -> Gen (Sealed (WithEndState (ModelOf p) (Pair p wX)))+  -- default implementation doesn't do anything special+  arbitraryStatePair s = do+    -- use the :> instance+    Sealed (WithEndState pair s') <- arbitraryState s+    return $ seal $ WithEndState (Pair pair) s'++instance ArbitraryState p => ArbitraryState (WithState p) where+  arbitraryState s = do Sealed (WithEndState x s') <- arbitraryState s+                        return $ seal $ WithEndState (WithState s x s') s'++-- this instance is only useful if ModelOf p ~ ModelOf q+type instance ModelOf (p :> q) = ModelOf p++instance (ArbitraryState p, ArbitraryState q, ModelOf p ~ ModelOf q) => ArbitraryState (p :> q) where+  arbitraryState s = do+    Sealed (WithEndState p1 s') <- arbitraryState s+    Sealed (WithEndState p2 s'') <- arbitraryState s'+    return $ seal $ WithEndState (p1 :> p2) s'' ++arbitraryFL ::+     ArbitraryState p+  => forall wX. Int -> ModelOf p wX -> Gen (Sealed (WithEndState (ModelOf p) (FL p wX)))+arbitraryFL 0 s = return $ seal $ WithEndState NilFL s+arbitraryFL n s = do Sealed (WithEndState x s') <- arbitraryState s+                     Sealed (WithEndState xs s'') <- arbitraryFL (n-1) s'+                     return $ seal $ WithEndState (x :>: xs) s''++instance ArbitraryState p => ArbitraryState (FL p) where+  arbitraryState s = sized $ \n -> do k <- choose (0, min 2 (n `div` 5))+                                      arbitraryFL k s+++makeSGen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed (p wX))+makeSGen stGen = do s <- stGen+                    Sealed (WithEndState p _) <- arbitraryState s+                    return $ seal p++makeWS2Gen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed2 (WithState p))+makeWS2Gen stGen = do s <- stGen+                      Sealed (WithEndState wsP _) <- arbitraryState s+                      return $ seal2 wsP++makeWSGen :: ArbitraryState p => Gen (ModelOf p wX) -> Gen (Sealed (WithState p wX))+makeWSGen stGen = do s <- stGen+                     Sealed (WithEndState wsP _) <- arbitraryState s+                     return $ seal wsP++-- | A class to help with shrinking complex test cases by simplifying+-- the starting state of the test case. See also 'PropagateShrink'.+class ShrinkModel prim where+  -- |Given a repository state, produce a patch that simplifies the+  -- repository state. The inverse of the patch can be passed as the+  -- "shrinking fixup" to 'propagateShrink'.+  --+  -- Imagine that we start with+  --+  --    s wX1 --p1 wX1 wY1--> s wY1+  --+  -- If we shrink the state to @s wX2@:+  --+  --    s wX2 <--prim wX1 wX2-- s wX1+  --+  -- then we hope that 'propagateShrink' will produce a simpler version of @p1@,+  -- @p2@, that starts from the simpler state @s wX2@:+  --+  --                        p2 wX2 wY2+  --               s wX2 ----------------> s wY2+  --                |                        |+  --                |                        |+  --    invert prim |                        | (discard)+  --                |                        |+  --                V                        V+  --               s wX1 ----------------> s wY1+  --                        p1 wX1 wY1+  shrinkModelPatch :: ModelOf prim wX -> [Sealed (prim wX)]++checkOK :: Fail a -> [a]+checkOK = maybe [] (\x -> [x]) . maybeFail++shrinkModel+  :: forall s prim wX+   . (Apply prim, ApplyState prim ~ RepoState s, ModelOf prim ~ s, RepoModel s, ShrinkModel prim)+  => s wX -> [Sealed (WithEndState s (prim wX))]+shrinkModel s = do+  Sealed prim <- shrinkModelPatch s+  endState <- checkOK $ repoApply s prim+  return $ Sealed $ WithEndState prim endState++-- | A class to help with shrinking complex test cases. The idea is that the+-- "starting state" of the test case is shrunk and this results in a "fixup"+-- primitive that goes from the shrunk starting state to the original starting+-- state. This so-called "shrinking fixup" is then propagated through the test+-- case to generate a new test case that starts at the shrunk starting state.+-- The shrinking fixup is typically generated via the 'ShrinkModel' class.+class PropagateShrink prim p where+  -- Given a test patch (of type @p@) and a shrinking fixup (of type @prim@),+  -- try to propagate the shrinking fixup past the test patch.+  -- The @Maybe2 p@ return type allows the fixup to eliminate the shrinking+  -- patch entirely, and vice versa the @Maybe2 prim@ allows the shrinking fixup+  -- to disappear (for example it might be cancelled out by something in the test+  -- patch).+  -- We don't use @FL p@, because that would only really be useful for a "stuck"+  -- fixup - one that doesn't eliminate or commute - and that implies that+  -- the state shrink isn't actually shrinking the real test case.+  propagateShrink :: (prim :> p) wX wY -> Maybe ((Maybe2 p :> Maybe2 prim) wX wY)++propagateShrinkKeep+  :: PropagateShrink prim p+  => (prim :> p) wX wY+  -> Maybe ((p :> Maybe2 prim) wX wY)+propagateShrinkKeep inp = do+  Just2 p' :> mprim' <- propagateShrink inp+  return (p' :> mprim')++propagateShrinkMaybe+  :: PropagateShrink prim p+  => (Maybe2 prim :> p) wX wY+  -> Maybe ((Maybe2 p :> Maybe2 prim) wX wY)+propagateShrinkMaybe (Nothing2 :> p) = Just (Just2 p :> Nothing2)+propagateShrinkMaybe (Just2 prim :> p) = propagateShrink (prim :> p)++-- |Shrink a test case wrapped with 'WithStartState2' by shrinking the start state+-- of the test case with 'ShrinkModel' and then propagating the shrink through the+-- patch type of the test case.+shrinkState+  :: forall s prim p+   . ( Invert prim, Apply prim, RepoModel s+     , ShrinkModel prim, PropagateShrink prim p+     , ApplyState prim ~ RepoState s+     , ModelOf p ~ s+     , ModelOf prim ~ s+     )+  => Sealed2 (WithStartState2 p)+  -> [Sealed2 (WithStartState2 p)]+shrinkState (Sealed2 (WithStartState2 s p)) = do+  Sealed (WithEndState fixup shrunkState) <- shrinkModel @s @prim s+  p' :> _ <- maybeToList $ propagateShrinkKeep (invert fixup :> p)+  return $ Sealed2 $ WithStartState2 shrunkState p'++shrinkAtStartState+  :: ( Shrinkable p, RepoModel (ModelOf p), Effect p+     , prim ~ PrimOf p, Invert prim, Apply prim+     , ApplyState prim ~ RepoState (ModelOf p)+     )+  => WithStartState2 p wX wY+  -> [FlippedSeal (WithStartState2 p) wY]+shrinkAtStartState (WithStartState2 s p) = do+  FlippedSeal p' <- shrinkAtStart p+  endState <- checkOK $ repoApply s (effect p)+  newState <- checkOK $ repoApply endState (invert (effect p'))+  return $ FlippedSeal (WithStartState2 newState p')++instance+  ( ArbitraryState p, Shrinkable p, RepoModel s+  , s ~ ModelOf p+  , s ~ ModelOf prim+  , Effect p+  , Apply prim, ApplyState prim ~ RepoState s+  , prim ~ PrimOf p, Invert prim, ShrinkModel prim, PropagateShrink prim p+  )+  => ArbitraryS2 (WithStartState2 p) where+  arbitraryS2 = do+    repo <- aSmallRepo @s+    Sealed (WithEndState p _) <- arbitraryState repo+    return (Sealed2 (WithStartState2 repo p))+  shrinkS2 w@(Sealed2 (WithStartState2 repo p)) =+    map (Sealed2 . WithStartState2 repo) (shrinkInternally p) +++    map (unseal (Sealed2 . WithStartState2 repo)) (shrinkAtEnd p) +++    map (unsealFlipped Sealed2) (shrinkAtStartState (WithStartState2 repo p)) +++    shrinkState @s @prim @p w++propagatePrim+  :: (Eq2 prim, PrimCoalesce prim, Invert prim, Commute prim)+  => (prim :> prim) wX wY -> Maybe ((Maybe2 prim :> Maybe2 prim) wX wY)+propagatePrim (p1 :> p2)+  | IsEq <- invert p1 =\/= p2 = Just (Nothing2 :> Nothing2)+  | Just (p2' :> p1') <- commute (p1 :> p2) = Just (Just2 p2' :> Just2 p1')+  | Just p' <- primCoalesce p1 p2 = Just (Just2 p' :> Nothing2)+  | otherwise = Nothing++instance (PropagateShrink prim p, PropagateShrink prim q)+  => PropagateShrink prim (p :> q) where++  propagateShrink (prim :> (p :> q)) = do+    Just2 mp' :> mprim' <- propagateShrink (prim :> p)+    Just2 mq' :> mprim'' <- propagateShrinkMaybe (mprim' :> q)+    return (Just2 (mp' :> mq') :> mprim'')++instance PropagateShrink prim p => PropagateShrink prim (FL p) where+  propagateShrink (prim :> NilFL) = Just (Just2 NilFL :> Just2 prim)+  propagateShrink (prim :> (p :>: ps)) = do+    mp' :> mprim' <- propagateShrink (prim :> p)+    Just2 ps' :> mprim'' <- propagateShrinkMaybe (mprim' :> ps)+    let result = case mp' of+          Nothing2 -> ps'+          Just2 p' -> p' :>: ps'+    return (Just2 result :> mprim'')
+ harness/Darcs/Test/Repository/Inventory.hs view
@@ -0,0 +1,168 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Test.Repository.Inventory where++import Darcs.Prelude++import Darcs.Repository.Inventory+    ( Inventory(..)+    , HeadInventory+    , ValidHash+    , InventoryHash+    , PatchHash+    , PristineHash+    , parseInventory+    , showInventory+    , skipPristineHash+    , peekPristineHash+    , pokePristineHash+    , prop_inventoryParseShow+    , prop_peekPokePristineHash+    , prop_skipPokePristineHash+    )+import Darcs.Patch.Info ( rawPatchInfo )+import Darcs.Util.Hash ( sha256strict )+import Darcs.Util.Printer ( renderPS )+import Darcs.Util.ValidHash ( decodeValidHash, fromHash, fromSizeAndHash )++import Darcs.Test.Patch.Info ()++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.Maybe ( fromJust )+import Test.Framework ( Test, testGroup )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.HUnit ( Assertion, (@=?) )+import Test.QuickCheck+import Test.QuickCheck.Instances.ByteString ()++testSuite :: Test+testSuite = testGroup "Darcs.Repository.Inventory"+ [ testProperty "parse/show roundtrips" prop_inventoryParseShow+ , testProperty "peek gets back what we poked" prop_peekPokePristineHash+ , testProperty "skip/poke roundtrips" prop_skipPokePristineHash+ , testCase "example1" (testInventory rawHeadInv1 headInv1)+ , testCase "example2" (testInventory rawHeadInv2 headInv2)+ ]++instance Arbitrary Inventory where+  arbitrary = uncurry Inventory <$> arbitrary++instance Arbitrary InventoryHash where+  arbitrary = arbitraryHash+instance Arbitrary PatchHash where+  arbitrary = arbitraryHash+instance Arbitrary PristineHash where+  arbitrary = arbitraryHash++arbitraryHash :: ValidHash h => Gen h+arbitraryHash = do+  content       <- arbitrary+  size_prefixed <- arbitrary+  let size = B.length content+      hash = sha256strict content+  if size_prefixed && size < 1000000000+    then return (fromSizeAndHash size hash)+    else return (fromHash hash)++testInventory :: B.ByteString -> HeadInventory -> Assertion+testInventory raw (hash,inv) = do+  hash @=? peekPristineHash raw+  let rest = skipPristineHash raw+  Right inv @=? parseInventory rest+  rest @=? renderPS (showInventory inv)+  raw @=? renderPS (pokePristineHash hash rest)++mkValidHash :: ValidHash a => String -> a+mkValidHash = fromJust . decodeValidHash++headInv1 :: HeadInventory+headInv1 =+  ( mkValidHash "57fb9c1abbed1c0b880e2fffebe32a2163762b87e67e9bf4dcd3168e5abcad83"+  , Inventory+      { inventoryParent = Nothing+      , inventoryPatches =+          [ ( rawPatchInfo+                "20180311141206"+                "Add d/f and e."+                "tester"+                [ "Ignore-this: b541ff7ea385297c8ad07fe58016efa8" ]+                False+            , mkValidHash+                "0000000154-703d7811c2e3f1e1aa81e4be5fab31a291cc18158ec8a75733b6faa5fb406286"+            )+          , ( rawPatchInfo+                "20180311141206"+                "Move d/f to e/f."+                "tester"+                [ "Ignore-this: b71452c8a91c573f7e7fa2e8eb34afd1" ]+                False+            , mkValidHash+                "0000000106-4b1bc6db02d2eea04efe888b64ce853a416c14ae1ae43550b0137f11a8a8dfee"+            )+          ]+      }+  )++rawHeadInv1 :: B.ByteString+rawHeadInv1 = BC.pack+  "pristine:57fb9c1abbed1c0b880e2fffebe32a2163762b87e67e9bf4dcd3168e5abcad83\n\+  \[Add d/f and e.\n\+  \tester**20180311141206\n\+  \ Ignore-this: b541ff7ea385297c8ad07fe58016efa8\n\+  \] \n\+  \hash: 0000000154-703d7811c2e3f1e1aa81e4be5fab31a291cc18158ec8a75733b6faa5fb406286\n\+  \[Move d/f to e/f.\n\+  \tester**20180311141206\n\+  \ Ignore-this: b71452c8a91c573f7e7fa2e8eb34afd1\n\+  \] \n\+  \hash: 0000000106-4b1bc6db02d2eea04efe888b64ce853a416c14ae1ae43550b0137f11a8a8dfee\n\+  \"++headInv2 :: HeadInventory+headInv2 =+  ( mkValidHash "f2f70f1326252fc53077d7cd71769f405618829ba40a8f00f112ac97213f5f4b"+  , Inventory+      { inventoryParent =+          Just+            (mkValidHash+               "0000220070-6ef010a955c38fc4301787092979994bafd366eb50152b66e089deff649d35da")+      , inventoryPatches =+          [ ( rawPatchInfo+                "20160429142058"+                "TAG 2.12.0"+                "Guillaume Hoffmann <guillaumh@gmail.com>"+                [ "Ignore-this: 5c8cbe0424942686a2168f9e6fd8e35d" ]+                False+            , mkValidHash+                "0000088075-e1cc4489099cfff1df5875a8146dc012110c156f3dad839f4632d62ee2331e43"+            )+          , ( rawPatchInfo+                "20160429143015"+                "bump version to 2.13.0"+                "Guillaume Hoffmann <guillaumh@gmail.com>"+                [ "Ignore-this: 7468e30e96f3bf833f4e374e9cc7e515" ]+                False+            , mkValidHash+                "0000000198-0f5455b7c229e132a2fc2173dcce2b567f806c1d3eb1c37fd9fe8d8e42ef4fc9"+            )+          ]+      }+  )++rawHeadInv2 :: B.ByteString+rawHeadInv2 = BC.pack+  "pristine:f2f70f1326252fc53077d7cd71769f405618829ba40a8f00f112ac97213f5f4b\n\+  \Starting with inventory:\n\+  \0000220070-6ef010a955c38fc4301787092979994bafd366eb50152b66e089deff649d35da\n\+  \[TAG 2.12.0\n\+  \Guillaume Hoffmann <guillaumh@gmail.com>**20160429142058\n\+  \ Ignore-this: 5c8cbe0424942686a2168f9e6fd8e35d\n\+  \] \n\+  \hash: 0000088075-e1cc4489099cfff1df5875a8146dc012110c156f3dad839f4632d62ee2331e43\n\+  \[bump version to 2.13.0\n\+  \Guillaume Hoffmann <guillaumh@gmail.com>**20160429143015\n\+  \ Ignore-this: 7468e30e96f3bf833f4e374e9cc7e515\n\+  \] \n\+  \hash: 0000000198-0f5455b7c229e132a2fc2173dcce2b567f806c1d3eb1c37fd9fe8d8e42ef4fc9\n\+  \"
+ harness/Darcs/Test/Shell.hs view
@@ -0,0 +1,289 @@+{-# LANGUAGE CPP, OverloadedStrings, ExtendedDefaultRules, RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module Darcs.Test.Shell+    ( Format(..)+    , DiffAlgorithm(..)+    , UseIndex(..)+    , UseCache(..)+    , findShell+    ) where++import Darcs.Prelude++import Control.Exception ( SomeException )+import Data.Data ( Data, Typeable )+import Data.Text ( Text, pack, unpack )+import qualified Data.Text as T+import qualified Shelly ( FilePath, run )+import Shelly+    ( Sh+    , catch_sh+    , cd+    , cp+    , fromText+    , get_env_text+    , initOutputHandles+    , lastExitCode+    , lastStderr+    , mkdir+    , mkdir_p+    , onCommandHandles+    , pwd+    , setenv+    , shelly+    , silently+    , sub+    , toTextIgnore+    , withTmpDir+    , writefile+    , (</>)+    )+import qualified System.FilePath as Native ( searchPathSeparator, splitSearchPath )+import System.FilePath ( makeRelative, takeBaseName, takeDirectory )+import qualified System.FilePath.Posix as Posix ( searchPathSeparator )+import System.IO ( hSetBinaryMode )+import Test.Framework.Providers.API+    ( Test(..)+    , TestResultlike(..)+    , Testlike(..)+    , liftIO+    , runImprovingIO+    , yieldImprovement+    )++data Format = Darcs1 | Darcs2 | Darcs3 deriving (Show, Eq, Typeable, Data)+data DiffAlgorithm = Myers | Patience deriving (Show, Eq, Typeable, Data)+data UseIndex = NoIndex | WithIndex deriving (Show, Eq, Typeable, Data)+data UseCache = NoCache | WithCache deriving (Show, Eq, Typeable, Data)++data ShellTest = ShellTest+  { format :: Format+  , testfile :: FilePath+  , testdir :: Maybe FilePath -- ^ only if you want to set it explicitly+  , darcspath :: FilePath+  , ghcflags :: String+  , diffalgorithm :: DiffAlgorithm+  , useindex :: UseIndex+  , usecache :: UseCache+  } deriving (Typeable)++data Running = Running deriving Show+data Result = Success | Skipped | Failed String++instance Show Result where+  show Success = "Success"+  show Skipped = "Skipped"+  show (Failed f) = unlines (map ("| " ++) $ lines f)++instance TestResultlike Running Result where+  testSucceeded Success = True+  testSucceeded Skipped = True+  testSucceeded _ = False++instance Testlike Running Result ShellTest where+  testTypeName _ = "Shell"+  runTest _ test =+    runImprovingIO $ do+      yieldImprovement Running+      liftIO (shelly $ runtest test)++-- | Environment variable values may need translating depending on whether we+-- are setting them directly or writing out a shell script to set them, and+-- depending on the kind of value and the platform. This type captures the+-- different kinds of values.+data EnvItem+  = EnvString String+    -- ^ A normal string that won't need conversion+  | EnvFilePath Shelly.FilePath+    -- ^ A path on disk that may need conversion for the platform+  | EnvSearchPath [Shelly.FilePath]+    -- ^ A list of paths on disk, for the PATH variable++runtest' :: ShellTest -> Text -> Sh Result+runtest' ShellTest{..} srcdir =+  do+    wd <- pwd+    p  <- unpack <$> get_env_text "PATH"+    let pathToUse =+          map (fromText . pack) $ takeDirectory darcspath : Native.splitSearchPath p+    let env =+          [ ("HOME"                      , EnvFilePath wd)+          -- in case someone has XDG_CACHE_HOME set:+          , ("XDG_CACHE_HOME"            , EnvFilePath (wd </> ".cache"))+          , ("TESTDATA", EnvFilePath (srcdir </> "tests" </> "data"))+          , ("TESTBIN", EnvFilePath (srcdir </> "tests" </> "bin"))+          , ("DARCS_TESTING_PREFS_DIR"   , EnvFilePath $ wd </> ".darcs")+          , ("EMAIL"                     , EnvString "tester")+          , ("GIT_AUTHOR_NAME"           , EnvString "tester")+          , ("GIT_AUTHOR_EMAIL"          , EnvString "tester")+          , ("GIT_COMMITTER_NAME"        , EnvString "tester")+          , ("GIT_COMMITTER_EMAIL"       , EnvString "tester")+          , ("DARCS_DONT_COLOR"          , EnvString "1")+          , ("DARCS_DONT_ESCAPE_ANYTHING", EnvString "1")+          , ("PATH"                      , EnvSearchPath pathToUse)+          -- the DARCS variable is passed to the tests purely so they can+          -- double-check that the darcs on the path is the expected one,+          -- so is passed as a string directly without any translation+          , ("DARCS"                     , EnvString darcspath)+          , ("GHC_FLAGS"                 , EnvString ghcflags)+          , ("GHC_VERSION", EnvString $ show (__GLASGOW_HASKELL__ :: Int))+          -- https://www.joshkel.com/2018/01/18/symlinks-in-windows/+          , ("MSYS"                      , EnvString "winsymlinks:nativestrict")+          ]+    -- we write the variables to a shell script and source them from there in+    -- ./lib, so that it's easy to reproduce a test failure after running the+    -- harness with -d.+    writefile "env" $ T.unlines $ map+      (\(k, v) -> T.concat ["export ", k, "=", envItemForScript v])+      env+    -- just in case the test script doesn't source ./lib:+    mapM_ (\(k, v) -> setenv k (envItemForEnv v)) env++    mkdir ".darcs"+    writefile ".darcs/defaults" defaults+    _ <-+      onCommandHandles (initOutputHandles (\h -> hSetBinaryMode h True))+        $ Shelly.run "bash" ["test"]+    return Success+  `catch_sh` \(_ :: SomeException) -> do+               code <- lastExitCode+               case code of+                 200 -> return Skipped+                 _   -> Failed <$> unpack <$> lastStderr+  where+    defaults =+      pack+        $  unlines+        $  [ "ALL " ++ fmtstr+           , "send no-edit-description"+           , "ALL " ++ uif+           , "ALL " ++ daf+           ]+        ++ ucf+    fmtstr = case format of+      Darcs3 -> "darcs-3"+      Darcs2 -> "darcs-2"+      Darcs1 -> "darcs-1"+    daf = case diffalgorithm of+      Patience -> "patience"+      Myers    -> "myers"+    uif = case useindex of+      WithIndex -> "no-ignore-times"+      NoIndex   -> "ignore-times"+    ucf = case usecache of+      WithCache -> []+      NoCache   -> ["ALL no-cache"]++    -- convert an 'EnvItem' to a string you can put in the environment directly+    envItemForEnv :: EnvItem -> Text+    envItemForEnv (EnvString   v) = pack v+    envItemForEnv (EnvFilePath v) = toTextIgnore v+    envItemForEnv (EnvSearchPath vs) =+      T.intercalate (T.singleton Native.searchPathSeparator) $ map toTextIgnore vs++    -- convert an 'EnvItem' to a string that will evaluate to the right value+    -- when embedded in a bash script+    envItemForScript :: EnvItem -> Text+    envItemForScript (EnvString   v) = quoteForShell (pack v)+    envItemForScript (EnvFilePath v) = filePathForScript v+    envItemForScript (EnvSearchPath vs) =+      -- note the use of the Posix search path separator (':') regardless of platform+      T.intercalate (T.singleton Posix.searchPathSeparator)+        $ map filePathForScript vs++    -- add quotes around a 'Shelly.FilePath'+    quotedFilePath :: Shelly.FilePath -> Text+    quotedFilePath = quoteForShell . toTextIgnore++    quoteForShell :: Text -> Text+    quoteForShell = surround '\'' . T.replace "'" "'\\''"+      where surround c t = T.cons c $ T.snoc t c++    -- convert a 'Shelly.FilePath' into a string that will evaluate to the right+    -- value when put in a bash script+    filePathForScript :: Shelly.FilePath -> Text+#ifdef WIN32+    -- we have a native Windows path, but we are going to put it in an bash+    -- script run in an environment like msys2 which works with an illusion+    -- of a Unix style filesystem. Calling cygpath at runtime does the+    -- necessary translation.+    filePathForScript v = T.concat ["$(cygpath ", quotedFilePath v, ")"]+#else+    filePathForScript v = quotedFilePath v+#endif++runtest :: ShellTest -> Sh Result+runtest test@ShellTest{..} =+  withTmp $ \dir -> do+    cp "tests/lib" dir+    cp "tests/network/sshlib" dir+    cp "tests/network/httplib" dir+    cp (fromText $ pack $ testfile) (dir </> "test")+    srcdir <- pwd+    silently $ sub $ cd dir >> runtest' test (toTextIgnore srcdir)+  where+    withTmp =+      case testdir of+        Just dir ->+          \job -> do+            let d =+                  dir </> show format </> show diffalgorithm </>+                  show useindex </>+                  show usecache </>+                  takeTestName testfile+            mkdir_p d+            job d+        Nothing -> withTmpDir++findShell+  :: FilePath+  -> [FilePath]+  -> Maybe FilePath+  -> String+  -> [DiffAlgorithm]+  -> [Format]+  -> [UseIndex]+  -> [UseCache]+  -> IO [Test]+findShell dp files tdir ghcflags diffAlgorithms repoFormats useindexs usecaches =+  do+    return+      [ shellTest+          ShellTest+            { format = fmt+            , testfile = file+            , testdir = tdir+            , darcspath = dp+            , ghcflags = ghcflags+            , diffalgorithm = da+            , useindex = ui+            , usecache = uc+            }+      | file <- files+      , fmt <- repoFormats+      , da <- diffAlgorithms+      , ui <- useindexs+      , uc <- usecaches+      ]++shellTest :: ShellTest -> Test+shellTest test@ShellTest{..} = Test name test+  where+    name =+      concat+        [ unpack (toTextIgnore (takeTestName testfile))+        , " ("+        , show format+        , ","+        , show diffalgorithm+        , ","+        , show useindex+        , ","+        , show usecache+        , ")"+        ]++takeTestName :: FilePath -> Shelly.FilePath+takeTestName n =+  let n' = makeRelative "tests" n+   in takeBaseName (takeDirectory n') </> takeBaseName n'
+ harness/Darcs/Test/TestOnly/Instance.hs view
@@ -0,0 +1,6 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Test.TestOnly.Instance where++import Darcs.Test.TestOnly++instance TestOnly
+ harness/Darcs/Test/UI.hs view
@@ -0,0 +1,13 @@+module Darcs.Test.UI ( testSuite ) where++import qualified Darcs.Test.UI.Commands.Test ( testSuite )+import qualified Darcs.Test.UI.Commands.Convert.Export ( testSuite )++import Test.Framework ( Test, testGroup )++testSuite :: Test+testSuite =+  testGroup "Darcs.UI"+    [ Darcs.Test.UI.Commands.Test.testSuite+    , Darcs.Test.UI.Commands.Convert.Export.testSuite+    ]
+ harness/Darcs/Test/UI/Commands/Convert/Export.hs view
@@ -0,0 +1,14 @@+module Darcs.Test.UI.Commands.Convert.Export ( testSuite ) where++import Darcs.Prelude+import Darcs.UI.Commands.Convert.Export ( cleanPatchAuthor, cleanPatchAuthorTestCases )++import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework ( Test, testGroup )+import Test.HUnit ( (@?=) )++testSuite :: Test+testSuite = testGroup "Darcs.UI.Commands.Convert.Export"+  [ testGroup "cleanPatchAuthor" $ flip map cleanPatchAuthorTestCases $ \(input, expected) ->+      testCase (show input) $ cleanPatchAuthor input @?= expected+  ]
+ harness/Darcs/Test/UI/Commands/Test.hs view
@@ -0,0 +1,13 @@+module Darcs.Test.UI.Commands.Test ( testSuite ) where++import qualified Darcs.Test.UI.Commands.Test.Commutable ( testSuite )+import qualified Darcs.Test.UI.Commands.Test.Simple ( testSuite )++import Test.Framework ( Test, testGroup )++testSuite :: Test+testSuite =+  testGroup "Darcs.UI.Commands.Test"+    [ Darcs.Test.UI.Commands.Test.Simple.testSuite+    , Darcs.Test.UI.Commands.Test.Commutable.testSuite+    ]
+ harness/Darcs/Test/UI/Commands/Test/Commutable.hs view
@@ -0,0 +1,252 @@+module Darcs.Test.UI.Commands.Test.Commutable ( testSuite ) where++import Darcs.Prelude+import qualified Darcs.Util.IndexedMonad as Indexed++import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Set ( Origin )+import Darcs.Patch.Witnesses.Ordered+  ( (:>)(..) , FL(..) , RL(..) , consGapFL , mapFL , reverseFL )+import Darcs.Patch.Witnesses.Sealed+  ( Sealed(..), unseal, mapSeal, Sealed2(..)+  , FreeLeft, unFreeLeft, Gap(..)+  )++import Darcs.UI.Commands.Test.Impl+  ( TestRunner(..), TestResult(..), TestResultValid(..), TestFailure(..)+  , runStrategy, StrategyResultRaw(..)+  , PatchSeq(..), patchTreeToFL+  )+import qualified Darcs.UI.Options.All as O++import Darcs.Test.UI.Commands.Test.IndexedApply ( IndexedApply(..) )++import Test.Framework ( Test, testGroup )+import Test.Framework.Providers.HUnit ( testCase )+import Test.HUnit ( assertEqual )++testSuite :: Test+testSuite =+  testGroup "Darcs.UI.Commands.Test.Commutable"+    [ testGroup "Generic test cases" $ map genericTestCases [O.Linear, O.Bisect, O.Backoff]+    ]+++genericTestCases :: O.TestStrategy -> Test+genericTestCases testStrategy =+  testGroup (show testStrategy) $ map (expectedResult testStrategy)+    [ ("Unminimisable sequence",+           ([StdDeps CreateTest, StdDeps BreakTest],+            Blame [1],+            Blame [1]+           )+      )+    , ("Simple minimisation",+           ([StdDeps CreateTest, StdDeps BreakCompile, StdDeps BreakTest, StdDeps FixCompile],+            Blame [1,2,3],+            Blame [2])+      )+    , ("Longer minimisation",+           ([ StdDeps CreateTest, StdDeps BreakCompile, StdDeps Irrelevant, StdDeps Irrelevant+            , StdDeps BreakTest, StdDeps Irrelevant, StdDeps Irrelevant, StdDeps FixCompile+            ],+            Blame [1..7],+            Blame [4])+      )+    , ("Simple internal dependency",+           ([ StdDeps CreateTest+            , ExtraDeps 1 [] BreakCompile+            , ExtraDeps 2 [1] Irrelevant+            , StdDeps BreakTest+            , StdDeps FixCompile+            ],+            Blame [1..4],+            Blame [3])+      )+    , ("Simple internal dependency with extra patch",+           ([ StdDeps CreateTest+            , ExtraDeps 1 [] BreakCompile+            , ExtraDeps 2 [1] Irrelevant+            , StdDeps BreakTest+            , StdDeps Irrelevant+            , StdDeps FixCompile+            ],+            Blame [1..5],+            Blame [3])+      )+    , ("Complex dependencies",+           ([ StdDeps CreateTest+            , ExtraDeps 1 []  BreakCompile+            , ExtraDeps 2 [1] Irrelevant+            , ExtraDeps 3 []  Irrelevant+            , ExtraDeps 4 [3] BreakTest+            , ExtraDeps 5 [2] Irrelevant+            , ExtraDeps 6 [2] FixCompile+            ],+            Blame [1..6],+            Blame [4])+      )+    , ("Joined blame sequence",+           ([ StdDeps CreateTest+            , ExtraDeps 1 []  BreakCompile+            , ExtraDeps 2 [1]  BreakTest+            , ExtraDeps 3 [2] FixCompile+            ],+            Blame [1,2,3],+            Blame [1,2,3])+      )+    ]+++type ExpectedResult =+  ( [WithDeps Transition]+  -- result without shrinking+  , StrategyResultRaw [Int]+  -- result with shrinking+  , StrategyResultRaw [Int]+  )++expectedResult :: O.TestStrategy -> (String, ExpectedResult) -> Test+expectedResult testStrategy (testName, (testDetails, expectedNoShrinkingResult, expectedShrinkingResult)) =+  testCase testName $ do+    let+      noShrinkingResult = runStrategyOn testStrategy O.NoShrinkFailure testDetails+      shrinkingResult = runStrategyOn testStrategy O.ShrinkFailure testDetails+    assertEqual "Unexpected result without shrinking" expectedNoShrinkingResult noShrinkingResult+    assertEqual "Unexpected result with shrinking" expectedShrinkingResult shrinkingResult+++runStrategyOn :: O.TestStrategy -> O.ShrinkFailure -> [WithDeps Transition] -> StrategyResultRaw [Int]+runStrategyOn testStrategy shrinkFailure transitions =+  let initialState = TS CompileWorking TestNonExistent+      finalState = foldl (flip applyTransition) initialState (map withDepsContents transitions) in+  unseal (fmap toPatchNums . fst . flip runTestingMonad finalState . runStrategy testStrategy shrinkFailure)+         (genPatchSequence initialState transitions)++toPatchNums :: Sealed2 (PatchSeq Patch) -> [Int]+toPatchNums (Sealed2 ps) = mapFL (\(Patch n _ _) -> n) (patchTreeToFL ps)++genPatchSequence :: TestingState -> [WithDeps Transition] -> Sealed (RL Patch Origin)+genPatchSequence initialState transitions =+  mapSeal reverseFL $ unFreeLeft $ doGen 0 initialState transitions+  where+    doGen :: Int -> TestingState -> [WithDeps Transition] -> FreeLeft (FL Patch)+    doGen _ _ [] = emptyGap NilFL+    doGen n startingState (t:ts) =+      consGapFL (patch n t)+         (doGen (n+1) (applyTransition (withDepsContents t) startingState) ts)+++data Transition =+    CreateTest | RemoveTest+  | BreakTest | FixTest+  | BreakCompile | FixCompile+  | Irrelevant+  deriving Show++type Deps = (Maybe Int, [Int])++data WithDeps a = StdDeps a | ExtraDeps Int [Int] a++withDepsContents :: WithDeps a -> a+withDepsContents (StdDeps v) = v+withDepsContents (ExtraDeps _ _ v) = v++data TestStatus = TestNonExistent | TestWorking | TestBroken+  deriving Show++data CompileStatus = CompileWorking | CompileBroken+  deriving Show++data TestingState =+  TS+  { tsCompile :: CompileStatus+  , tsTest :: TestStatus+  }+  deriving Show+++invertTransition :: Transition -> Transition+invertTransition CreateTest   = RemoveTest+invertTransition RemoveTest   = CreateTest+invertTransition BreakTest    = FixTest+invertTransition FixTest      = BreakTest+invertTransition BreakCompile = FixCompile+invertTransition FixCompile   = BreakCompile+invertTransition Irrelevant   = Irrelevant++commutableTransition :: (Transition, Transition) -> Bool+commutableTransition (Irrelevant, _) = True+commutableTransition (_, Irrelevant) = True+commutableTransition (t1, t2) = (forTest t1 && forCompile t2) || (forCompile t1 && forTest t2)+  where+    forTest CreateTest = True+    forTest RemoveTest = True+    forTest BreakTest  = True+    forTest FixTest    = True+    forTest _          = False+    forCompile BreakCompile = True+    forCompile FixCompile   = True+    forCompile _ = False++applyTransition :: Transition -> TestingState -> TestingState+applyTransition Irrelevant  s = s+applyTransition CreateTest s@TS { tsTest = TestNonExistent } = s { tsTest = TestWorking     }+applyTransition RemoveTest s@TS { tsTest = TestWorking     } = s { tsTest = TestNonExistent }+applyTransition BreakTest  s@TS { tsTest = TestWorking     } = s { tsTest = TestBroken      }+applyTransition FixTest    s@TS { tsTest = TestBroken      } = s { tsTest = TestWorking     }+applyTransition BreakCompile s@TS { tsCompile = CompileWorking } = s { tsCompile = CompileBroken  }+applyTransition FixCompile   s@TS { tsCompile = CompileBroken  } = s { tsCompile = CompileWorking }+applyTransition transition state =+  error $ "Invalid transition " ++ show transition ++ " applied to state " ++ show state++data Patch wX wY = Patch Int Deps Transition++patch :: Int -> WithDeps Transition -> Patch wX wY+patch n (StdDeps t) = Patch n (Nothing, []) t+patch n (ExtraDeps name deps t) = Patch n (Just name, deps) t++instance Invert Patch where+  invert (Patch n deps t) = Patch n deps (invertTransition t)++instance Commute Patch where+  commute (Patch n1 d1@(name1, _) t1 :> Patch n2 d2@(_, deps2) t2)+    | name1 `elem` map Just deps2 = Nothing+    | commutableTransition (t1, t2) = Just (Patch n2 d2 t2 :> Patch n1 d1 t1)+    | otherwise = Nothing++toTestResult :: TestingState -> TestResult wX+toTestResult (TS { tsCompile = CompileBroken }                           ) = Untestable+toTestResult (TS { tsCompile = CompileWorking, tsTest = TestNonExistent }) = Untestable+toTestResult (TS { tsCompile = CompileWorking, tsTest = TestWorking     }) = Testable Success+toTestResult (TS { tsCompile = CompileWorking, tsTest = TestBroken      }) = Testable (Failure (TestFailure 1))++data TestingMonad wX wY a = TestingMonad { runTestingMonad :: TestingState -> (a, TestingState) }++instance Indexed.Monad TestingMonad where+  return v = TestingMonad (\n -> (v, n))+  m >>= f = TestingMonad (\n1 -> let (a, n2) = runTestingMonad m n1 in runTestingMonad (f a) n2)+  m1 >> m2 = TestingMonad (\n1 -> let (_, n2) = runTestingMonad m1 n1 in runTestingMonad m2 n2)++instance IndexedApply Patch where+  type ApplyState Patch = TestingMonad++  apply (Patch _ _ transition) =+    TestingMonad $ \s -> ((), applyTransition transition s)++  unapply (Patch _ _ transition) =+    TestingMonad $ \s -> ((), applyTransition (invertTransition transition) s)++instance TestRunner TestingMonad where+  type ApplyPatchReqs TestingMonad p = (IndexedApply p, ApplyState p ~ TestingMonad)+  type DisplayPatchReqs TestingMonad p = p ~ Patch++  writeMsg _ = Indexed.return ()+  mentionPatch _ = Indexed.return ()+  finishedTesting v = TestingMonad (\_ -> (v, error "something tried to read final testing state"))++  getCurrentTestResult = TestingMonad (\n -> (toTestResult n, n))++  applyPatch = apply+  unapplyPatch = unapply
+ harness/Darcs/Test/UI/Commands/Test/IndexedApply.hs view
@@ -0,0 +1,36 @@+module Darcs.Test.UI.Commands.Test.IndexedApply+  ( IndexedApply(..)    +  ) where++import Darcs.Util.IndexedMonad++import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )++import Darcs.UI.Commands.Test.Impl ( PatchSeq(..) )++-- our own indexed monad Apply class+class IndexedApply p where+  type ApplyState p :: * -> * -> * -> *+  apply :: Monad (ApplyState p) => p wX wY -> ApplyState p wX wY ()+  unapply :: Monad (ApplyState p) => p wX wY -> ApplyState p wY wX ()++instance IndexedApply p => IndexedApply (FL p) where+  type ApplyState (FL p) = ApplyState p+  apply NilFL = return ()+  apply (p :>: ps) = apply p >> apply ps+  unapply NilFL = return ()+  unapply (p :>: ps) = unapply ps >> unapply p++instance IndexedApply p => IndexedApply (RL p) where+  type ApplyState (RL p) = ApplyState p+  apply NilRL = return ()+  apply (ps :<: p) = apply ps >> apply p+  unapply NilRL = return ()+  unapply (ps :<: p) = unapply p >> unapply ps++instance IndexedApply p => IndexedApply (PatchSeq p) where+  type ApplyState (PatchSeq p) = ApplyState p+  apply (Single p) = apply p+  apply (Joined p1 p2) = apply p1 >> apply p2+  unapply (Single p) = unapply p+  unapply (Joined p1 p2) = unapply p2 >> unapply p1
+ harness/Darcs/Test/UI/Commands/Test/Simple.hs view
@@ -0,0 +1,221 @@+module Darcs.Test.UI.Commands.Test.Simple ( testSuite ) where++import Darcs.Prelude+import qualified Darcs.Util.IndexedMonad as Indexed++import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Set ( Origin )+import Darcs.Patch.Witnesses.Ordered+  ( RL(..), FL(..), consGapFL, reverseFL, mapFL, (:>)(..) )+import Darcs.Patch.Witnesses.Sealed+  ( Sealed(..), unseal, mapSeal, Sealed2(..)+  , FreeLeft, unFreeLeft, Gap(..)+  )+import Darcs.Patch.Witnesses.Show ( Show2(..) )++import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands.Test.Impl+  ( TestRunner(..), TestResult(..), TestResultValid(..), TestFailure(..)+  , runStrategy, StrategyResultRaw(..)+  , PatchSeq(..), patchTreeToFL+  )++import Darcs.Test.UI.Commands.Test.IndexedApply ( IndexedApply(..) )++import Data.Constraint ( Dict(..) )+import Test.Framework.Providers.HUnit ( testCase )+import Test.Framework.Providers.QuickCheck2 ( testProperty )+import Test.Framework ( Test, testGroup )+import Test.HUnit ( assertEqual )+import Test.QuickCheck ( Arbitrary(..), Gen, Property, property, Discard(..), forAll, forAllShrink )+import Test.QuickCheck.Gen ( listOf, listOf1, frequency, elements )++testSuite :: Test+testSuite =+  testGroup "Darcs.UI.Commands.Test.Simple"+    [ testGroup "Generic test cases" $ map genericTestCases [O.Linear, O.Bisect, O.Backoff]+    , testGroup "Randomised tests of linear" [linearRandomised]+    , testGroup "Randomised tests against linear" $ map genericRandomised [O.Bisect, O.Backoff]+    ]++genericTestCases :: O.TestStrategy -> Test+genericTestCases testStrategy =+  testGroup (show testStrategy) $ map (expectedResult testStrategy)+    [ ("Sequence ending in success", ((U, [S]), NoFailureOnHead))+    , ("Sequence with no passes (1)", ((U, [F]), NoPasses))+    , ("Sequence with no passes (2)", ((F, [F]), NoPasses))+    , ("Sequence with simple failure (1)", ((S, [F]), Blame [0]))+    , ("Sequence with simple failure (2)", ((S, [S,S,F,F]), Blame [2]))+    , ("Sequence with untestable states", ((S, [S,S,U,U,F,F]), Blame [2,3,4]))+    , ("Sequence with initial untestable states", ((U, [U,U,U,U,U,U,U,S,S,U,U,F,F]), Blame [9,10,11]))+    ]++type ExpectedResult = ((TestingState, [TestingState]), StrategyResultRaw [Int])++expectedResult :: O.TestStrategy -> (String, ExpectedResult) -> Test+expectedResult testStrategy (testName, (testDetails, expectedTestResult)) =+  testCase testName $ do+  -- whether we try to shrink or not is irrelevant as nothing will commute+    let result = runStrategyOn testStrategy O.NoShrinkFailure testDetails+    assertEqual "Unexpected result" expectedTestResult result++genericRandomised :: O.TestStrategy -> Test+genericRandomised testStrategy =+  testGroup (show testStrategy)+    [ testProperty "simple sequence" (simpleSequence testStrategy)+    , testProperty "multi sequence" (multiSequence testStrategy)+    ]++linearRandomised :: Test+linearRandomised =+  testGroup (show O.Linear)+    [ testProperty "blame is found when possible" (findBlame O.Linear)+    ]++simpleSequence :: O.TestStrategy -> SimpleSequenceDefinition -> Bool+simpleSequence testStrategy sequenceDef =+  let s = ssdToTestDetails sequenceDef in+  runStrategyOn O.Linear O.NoShrinkFailure s == runStrategyOn testStrategy O.NoShrinkFailure s++-- tests that if we stick multiple sequences each with a single "blame sequence"+-- together, the strategy finds one of those sequences+multiSequence :: O.TestStrategy -> Property+multiSequence testStrategy =+  forAllShrink (listOf1 arbitraryBlameSSD) shrink $ \sequenceDefs ->+    let+      allTestDetails = map ssdToTestDetails sequenceDefs+      mergeDetails (i1, s1) (i2, s2) = (i1, s1 ++ [i2] ++ s2)+      adjustedResults _ [] = Just []+      adjustedResults n (x:xs) =+        case (runStrategyOn O.Linear O.NoShrinkFailure x, adjustedResults (n + 1 + length (snd x)) xs) of+          (Blame ps, Just ys) -> Just (Blame (map (+n) ps) : ys)+          _ -> Nothing+    in+      case adjustedResults 0 allTestDetails of+        Nothing -> property Discard+        Just [] -> property Discard+        Just res -> property $+                       runStrategyOn testStrategy O.NoShrinkFailure (foldr1 mergeDetails allTestDetails) `elem` res++findBlame :: O.TestStrategy -> Property+findBlame testStrategy =+  forAll arbitraryBlameSSD $ \s ->+    case runStrategyOn testStrategy O.NoShrinkFailure (ssdToTestDetails s) of+      Blame _ -> True+      _ -> False++-- a sequence of test results guaranteed to be monotonic in success/failure+data SimpleSequenceDefinition =+  SimpleSequenceDefinition+  { successPart :: [TestingState] -- contains either S or U+  , middlePart  :: TestingState   -- either S, F or U - exists to guarantee the joined list is non-empty+  , failurePart :: [TestingState] -- contains either F or U+  }+  deriving Show++ssdToTestDetails :: SimpleSequenceDefinition -> (TestingState, [TestingState])+ssdToTestDetails ssd =+  case successPart ssd ++ [middlePart ssd] ++ failurePart ssd of+    x:xs -> (x, xs)+    _ -> error "internal error: impossible empty list in ssdToTestDetails"++instance Arbitrary SimpleSequenceDefinition where+  arbitrary = do+    s <- listOf (frequency [(1, r S), (3, r U)])+    m <- frequency [(1, r S), (5, r U), (1, r F)]+    f <- listOf (frequency [(1, r F), (3, r U)])+    return $ SimpleSequenceDefinition s m f+   where r = return++  shrink (SimpleSequenceDefinition s m f) =+    map (SimpleSequenceDefinition s m) (shrink f) +++    map (\s' -> SimpleSequenceDefinition s' m f) (shrink s)++-- an arbitrary that's guaranteed to produce a sequence that results in Blame xxx+arbitraryBlameSSD :: Gen SimpleSequenceDefinition+arbitraryBlameSSD = do+  s1 <- listOf (frequency [(1, r S), (3, r U)])+  s2 <- listOf (frequency [(1, r S), (3, r U)])+  m <- frequency [(1, r S), (5, r U), (1, r F)]+  f <- listOf (frequency [(1, r F), (3, r U)])+  return $ SimpleSequenceDefinition (s1 ++ [S] ++ s2) m (f ++ [F])+ where r = return++instance Arbitrary TestingState where+  arbitrary = elements [S, U, F]+  shrink _ = []++data TestingState = S | U | F+   deriving (Eq, Show)++data TrivialPatch wX wY = TrivialPatch Int TestingState TestingState+  deriving Show++instance Show2 TrivialPatch where+  showDict2 = Dict++runStrategyOn :: O.TestStrategy -> O.ShrinkFailure -> (TestingState, [TestingState]) -> StrategyResultRaw [Int]+runStrategyOn testStrategy shrinkFailure (initialState, patchStates) =+  let finalState = last (initialState:patchStates) in+  unseal (fmap toPatchNums . fst . flip runTestingMonad finalState . runStrategy testStrategy shrinkFailure)+         (genPatchSequence initialState patchStates)++toPatchNums :: (Sealed2 (PatchSeq TrivialPatch)) -> [Int]+toPatchNums (Sealed2 ps) = mapFL (\(TrivialPatch n _ _) -> n) (patchTreeToFL ps)++genPatchSequence :: TestingState -> [TestingState] -> Sealed (RL TrivialPatch Origin)+genPatchSequence initialState patchStates =+  mapSeal reverseFL $ unFreeLeft $ doGen 0 initialState patchStates+  where+    doGen :: Int -> TestingState -> [TestingState] -> FreeLeft (FL TrivialPatch)+    doGen _ _ [] = emptyGap NilFL+    doGen n startingState (nextState:states) =+      consGapFL (TrivialPatch n startingState nextState) (doGen (n+1) nextState states)++instance Invert TrivialPatch where+  invert (TrivialPatch num ov nv) = TrivialPatch num nv ov++instance Commute TrivialPatch where+  commute (_ :> _) = Nothing++data TestingMonad wX wY a = TestingMonad { runTestingMonad :: TestingState -> (a, TestingState) }++instance Indexed.Monad TestingMonad where+  return v = TestingMonad (\n -> (v, n))+  m >>= f = TestingMonad (\n1 -> let (a, n2) = runTestingMonad m n1 in runTestingMonad (f a) n2)+  m1 >> m2 = TestingMonad (\n1 -> let (_, n2) = runTestingMonad m1 n1 in runTestingMonad m2 n2)++toTestResult :: TestingState -> TestResult wX+toTestResult S = Testable Success+toTestResult U = Untestable+toTestResult F = Testable (Failure (TestFailure 1))++instance IndexedApply TrivialPatch where+  type ApplyState TrivialPatch = TestingMonad+  apply (TrivialPatch num old new) =+    TestingMonad $ \st ->+      if st == old+        then ((), new)+        else error $ "state mismatch for patch " ++ show num+                          ++ ", expected " ++ show old ++ ", got " ++ show st++  unapply (TrivialPatch num old new) =+    TestingMonad $ \st ->+      if st == new+        then ((), old)+        else error $ "state mismatch for patch " ++ show num+                          ++ ", expected " ++ show new ++ ", got " ++ show st++instance TestRunner TestingMonad where+  type ApplyPatchReqs TestingMonad p = (IndexedApply p, ApplyState p ~ TestingMonad)+  type DisplayPatchReqs TestingMonad p = p ~ TrivialPatch++  writeMsg _ = Indexed.return ()+  mentionPatch _ = Indexed.return ()+  finishedTesting v = TestingMonad (\_ -> (v, error "something tried to read final testing state"))++  getCurrentTestResult = TestingMonad (\n -> (toTestResult n, n))++  applyPatch = apply+  unapplyPatch = unapply
+ harness/Darcs/Test/Util/QuickCheck.hs view
@@ -0,0 +1,60 @@++module Darcs.Test.Util.QuickCheck+  ( upper+  , lower+  , alpha+  , notIn+  , uniques+  , maybeOf+  , bSized+  )+  where+++import Prelude ()+import Darcs.Prelude++import Test.QuickCheck.Gen++++-- | An uppercase alphabetic character.+upper :: Gen Char+upper = choose ('A','Z')++-- | A lowercase alphabetic character.+lower :: Gen Char+lower = choose ('a','z')++-- | An alphabetic character.+alpha :: Gen Char+alpha = oneof [upper, lower]++-- | @gen `notIn` xs@ generate a @x@ that is not in @xs@.+notIn :: Eq a => Gen a -> [a] -> Gen a+gen `notIn` xs = gen `suchThat` (`notElem` xs)++-- | @uniques k gen@ generates a list of @k@ unique values.+uniques :: Eq a => Int -> Gen a -> Gen [a]+uniques k gen = go k []+  where+    go 0 xs = return xs+    go n xs = do x <- gen `notIn` xs+                 go (n-1) (x:xs)++-- | Try to arbitrarily pick some element of the list.+maybeOf :: [a] -> Gen (Maybe a)+maybeOf [] = return Nothing+maybeOf xs = Just <$> elements xs+++-- | A bounded sized combinator.+bSized :: Int       -- ^ Lower bound+        -> Double   -- ^ Increment+        -> Int      -- ^ Upper bound+        -> (Int -> Gen a) -> Gen a+bSized low inc upp mkGen = sized $ mkGen . resize'+  where+    resize' :: Int -> Int+    resize' n = let x = fromIntegral n+                 in min upp (floor(inc*x) + low)
+ harness/Darcs/Test/Util/TestResult.hs view
@@ -0,0 +1,77 @@+module Darcs.Test.Util.TestResult+  ( TestResult+  , succeeded+  , failed+  , rejected+  , maybeFailed+  , assertNotFailed+  , isFailed+  ) where++import Darcs.Prelude++import Darcs.Util.Printer (Doc)+import Darcs.Util.Printer.Color (unsafeRenderStringColored)++import qualified Test.QuickCheck.Property as Q+import qualified Test.HUnit as H++-- |Indicate the result of a test, which could be success,+-- failure (with a reason), or that the test couldn't run (rejected),+-- perhaps because the input data didn't meet some pre-condition.+-- The Monoid instance combines results by failing if either result+-- failed, rejecting if both results are rejected, and otherwise+-- succeeding.+data TestResult+  = TestSucceeded+  | TestFailed Doc+  | TestRejected++instance Show TestResult where+  show TestSucceeded = "TestSucceeded"+  show (TestFailed reason) = "TestFailed: " ++ unsafeRenderStringColored reason+  show TestRejected = "TestRejected"++succeeded :: TestResult+succeeded = TestSucceeded++failed :: Doc -> TestResult+failed = TestFailed++rejected :: TestResult+rejected = TestRejected++instance Semigroup TestResult where+  -- Succeed even if one of the arguments is rejected.+  t@(TestFailed _) <> _s = t+  _t <> s@(TestFailed _) = s+  TestRejected <> s = s+  t <> TestRejected = t+  TestSucceeded <> TestSucceeded = TestSucceeded++instance Monoid TestResult where+  mempty = TestRejected+  mappend = (<>)++-- | 'Nothing' is considered success whilst 'Just' is considered failure.+maybeFailed :: Maybe Doc -> TestResult+maybeFailed Nothing = succeeded+maybeFailed (Just errMsg) = failed errMsg++isFailed :: TestResult -> Bool+isFailed (TestFailed _) = True+isFailed _other = False++-- | Convert 'TestResult' to HUnit testable assertion+assertNotFailed :: TestResult -> H.Assertion+assertNotFailed TestSucceeded = return ()+assertNotFailed TestRejected = return ()+assertNotFailed (TestFailed msg) = H.assertString (unsafeRenderStringColored msg)++-- | 'Testable' instance is defined by converting 'TestResult' to+-- 'QuickCheck.Property.Result'+instance Q.Testable TestResult where+  property TestSucceeded = Q.property Q.succeeded+  property (TestFailed errorMsg) =+    Q.property (Q.failed {Q.reason = unsafeRenderStringColored errorMsg})+  property TestRejected = Q.property Q.rejected
+ harness/hstestdata.zip view

binary file changed (absent → 16669 bytes)

+ harness/test.hs view
@@ -0,0 +1,232 @@+{-# OPTIONS_GHC -fno-warn-missing-fields #-}+module Main ( main, run, defaultConfig, Config(..) ) where++import Darcs.Prelude++import qualified Darcs.Test.Email+import qualified Darcs.Test.HashedStorage+import qualified Darcs.Test.Misc+import qualified Darcs.Test.Patch+import qualified Darcs.Test.Repository.Inventory+import Darcs.Test.Shell+import qualified Darcs.Test.UI+import Darcs.Util.Exception ( die )++import Control.Monad ( filterM, unless, when )+import Data.List ( isPrefixOf, isSuffixOf, sort )+import GHC.IO.Encoding ( textEncodingName )+import System.Console.CmdArgs hiding ( args )+import System.Console.CmdArgs.Explicit ( process )+import System.Directory ( doesFileExist, doesPathExist, exeExtension, listDirectory )+import System.Environment.FindBin ( getProgPath )+import System.FilePath ( isAbsolute, takeBaseName, takeDirectory, (</>) )+import System.IO ( BufferMode(NoBuffering), hSetBuffering, localeEncoding, stdout )+import Test.Framework+    ( ColorMode(..)+    , RunnerOptions'(..)+    , Seed(..)+    , TestOptions'(..)+    , defaultMainWithOpts+    )++data Config = Config { suites :: String+                     , formats :: String+                     , diffalgs :: String+                     , index :: String+                     , cache :: String+                     , full :: Bool+                     , darcs :: String+                     , tests :: [String]+                     , testDir :: Maybe FilePath+                     , ghcFlags :: String+                     , plain :: Bool+                     , hideSuccesses :: Bool+                     , threads :: Int+                     , qcCount :: Int+                     , replay :: Maybe Int+                     }+            deriving (Data, Typeable, Eq, Show)+++defaultConfigAnn :: Annotate Ann+defaultConfigAnn+ = record Config{}+     [ suites        := "snu"    += help "Select which test suites to run: (s=shell, n=network, u=unit, f=failing, h=hashed) [snu]" += typ "SET"+     , formats       := "123"    += help "Select which darcs formats to test: (1=darcs-1, 2=darcs-2, 3=darcs-3) [123]" += name "f" += typ "SET"+     , diffalgs      := "p"      += help "Select which diff alorithms to use (p=patience, m=myers) [p]" += name "a" += typ "SET"+     , index         := "y"      += help "Select whether to use the index (n=no, y=yes) [y]" += typ "SET"+     , cache         := "y"      += help "Select whether to use the cache (n=no, y=yes) [y]" += typ "SET"+     , full          := False    += help "Shortcut for -s=snu -f=123 -a=mp -c=yn -i=yn"+     , 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"+     , ghcFlags      := ""       += help "GHC flags to use when compiling tests" += typ "FLAGS" += name "g"+     , 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"+     , replay        := Nothing  += help "Replay QC tests with given seed" += typ "SEED"+     ]+   += summary "Darcs test harness"+   += program "darcs-test"++defaultConfig :: Config+defaultConfig =+  case process (cmdArgsMode_ defaultConfigAnn) [] of+    Right r -> cmdArgsValue r+    Left _ -> error "impossible"++-- | Find the darcs executable to test+findDarcs :: IO FilePath+findDarcs = do+  path <- getProgPath+  let darcsExe = "darcs" ++ exeExtension+      candidates =+        -- if darcs-test lives in foo/something, look for foo/darcs[.exe] for+        -- example if we've done cabal install -ftest, there'll be a darcs-test+        -- and darcs in the cabal installation folder+        [path </> darcsExe] +++        -- if darcs-test lives in foo/darcs-test/something, look for+        -- foo/darcs/darcs[.exe] for example after cabal build we can run+        -- .../build/darcs-test/darcs-test and it'll find the darcs in+        -- .../build/darcs/darcs+        [ takeDirectory path </> "darcs" </> darcsExe+        | takeBaseName path == "darcs-test"+        ] +++        -- some versions of cabal produce more complicated structures:+        -- t/darcs-test/build/darcs-test/darcs-test and x/darcs/build/darcs/darcs+        [ takeDirectory path </> ".." </> ".." </> ".." </> "x" </> "darcs" </>+            "build" </> "darcs" </> darcsExe+        | takeBaseName path == "darcs-test"+        ] +++        [ takeDirectory path </> ".." </> ".." </> ".." </> ".." </> "x" </>+            "darcs" </> "noopt" </> "build" </> "darcs" </> darcsExe+        | takeBaseName path == "darcs-test"+        ]+  availableCandidates <- filterM doesFileExist candidates+  case availableCandidates of+    (result:_) -> do+      putStrLn $ "Using darcs executable in " ++ takeDirectory result+      return result+    [] ->+      die ("No darcs specified or found nearby. Tried:\n" ++ unlines candidates)++run :: Config -> IO ()+run conf = do+    case testDir conf of+       Nothing -> return ()+       Just d  -> do+          e <- doesPathExist d+          when e $ die ("Directory " ++ d ++ " already exists. Cowardly exiting")++    let hashed   = 'h' `elem` suites conf+        failing  = 'f' `elem` suites conf+        shell    = 's' `elem` suites conf+        network  = 'n' `elem` suites conf+        unit     = 'u' `elem` suites conf++        darcs1   = '1' `elem` formats conf+        darcs2   = '2' `elem` formats conf+        darcs3   = '3' `elem` formats conf++        myers    = 'm' `elem` diffalgs conf+        patience = 'p' `elem` diffalgs conf++        noindex   = 'n' `elem` index conf+        withindex = 'y' `elem` index conf++        nocache   = 'n' `elem` cache conf+        withcache = 'y' `elem` cache conf++    darcsBin <-+      case darcs conf of+        "" -> findDarcs+        v -> return v+    when (shell || network || failing) $ do+      unless (isAbsolute $ darcsBin) $+        die ("Argument to --darcs should be an absolute path")+      unless (exeExtension `isSuffixOf` darcsBin) $+        putStrLn $+          "Warning: --darcs flag does not end with " ++ exeExtension +++          " - some tests may fail (case does matter)"++    putStrLn $ "Locale encoding is " ++ textEncodingName localeEncoding++    let repoFormat    = (if darcs1 then (Darcs1:) else id)+                      . (if darcs2 then (Darcs2:) else id)+                      . (if darcs3 then (Darcs3:) else id)+                      $ []+    let diffAlgorithm = (if myers then (Myers:) else id)+                      . (if patience then (Patience:) else id)+                      $ []+    let useIndex      = (if noindex then (NoIndex:) else id)+                      . (if withindex then (WithIndex:) else id)+                      $ []+    let useCache      = (if nocache then (NoCache:) else id)+                      . (if withcache then (WithCache:) else id)+                      $ []++    let findTestFiles dir = select . map (dir </>) <$> listDirectory dir+          where+            filter_failing =+              if failing+                then id+                else filter $ not . ("failing-" `isPrefixOf`) . takeBaseName+            select = sort . filter_failing . filter (".sh" `isSuffixOf`)++    stests <-+      if shell+        then do+          files <- findTestFiles "tests"+          findShell darcsBin files (testDir conf) (ghcFlags conf) diffAlgorithm+            repoFormat useIndex useCache+        else return []+    ntests <-+      if network+        then do+          files <- findTestFiles "tests/network"+          findShell darcsBin files (testDir conf) (ghcFlags conf) diffAlgorithm+            repoFormat useIndex useCache+        else return []+    let utests =+          if unit then+            [ Darcs.Test.Email.testSuite+            , Darcs.Test.Misc.testSuite+            , Darcs.Test.Repository.Inventory.testSuite+            , Darcs.Test.UI.testSuite+            ] +++            Darcs.Test.Patch.testSuite+          else []+        hstests = if hashed then Darcs.Test.HashedStorage.tests else []++    let testRunnerOptions = RunnerOptions+          { ropt_threads = Just (threads conf)+          , ropt_test_options = Just $ TestOptions+              { topt_seed = FixedSeed <$> replay conf+              , topt_maximum_generated_tests = Just (qcCount conf)+              , topt_maximum_unsuitable_generated_tests = Just (7 * qcCount conf)+              , topt_maximum_test_size = Nothing+              , topt_maximum_test_depth = Nothing+              , topt_timeout = Nothing+              }+          , ropt_test_patterns =+              if null (tests conf) then Nothing else Just (map read (tests conf))+          , ropt_xml_output = Nothing+          , ropt_xml_nested = Nothing+          , ropt_color_mode = if plain conf then Just ColorNever else Nothing+          , ropt_hide_successes = Just (hideSuccesses conf)+          , ropt_list_only = Nothing+          }+    defaultMainWithOpts (stests ++ utests ++ ntests ++ hstests) testRunnerOptions++main :: IO ()+main = do hSetBuffering stdout NoBuffering+          clp  <- cmdArgs_ defaultConfigAnn+          run $+            if full clp then clp+              { formats  = "123"+              , diffalgs = "mp"+              , index = "yn"+              , cache = "yn"+              }+            else clp
release/distributed-context view
@@ -1,1 +1,1 @@-Just "\nContext:\n\n[TAG 2.8.5\nGanesh Sittampalam <ganesh@earth.li>**20140825204639\n Ignore-this: 4e6c90569ceab19a231cdd4c5089b4c2\n] \n"+Just "\nContext:\n\n\n[TAG 2.18.5\nBen Franksen <ben.franksen@online.de>**20250109111244\n Ignore-this: 36f2bddc159da3a5f0cfbbba1df3ad0b466282a42d11ed2c643934ebf4710029e639affd3e5aa1b4\n] \n"
+ shelly/LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2017, Petr Rockai <me@mornfall.net>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Petr Rockai nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ shelly/src/Shelly.hs view
@@ -0,0 +1,1473 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable, OverloadedStrings,+             FlexibleInstances, IncoherentInstances, CPP,+             TypeFamilies, ExistentialQuantification #-}++-- | A module for shell-like programming in Haskell.+-- Shelly's focus is entirely on ease of use for those coming from shell scripting.+-- However, it also tries to use modern libraries and techniques to keep things efficient.+--+-- The functionality provided by+-- this module is (unlike standard Haskell filesystem functionality)+-- thread-safe: each Sh maintains its own environment and its own working+-- directory.+--+-- Recommended usage includes putting the following at the top of your program,+-- otherwise you will likely need either type annotations or type conversions+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE ExtendedDefaultRules #-}+-- > {-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- > import Shelly+-- > import qualified Data.Text as T+-- > default (T.Text)+module Shelly+       (+         -- * Entering Sh.+         Sh, ShIO, shelly, shellyNoDir, shellyFailDir, asyncSh, sub+         , silently, verbosely, escaping, print_stdout, print_stderr, print_commands+         , onCommandHandles+         , tracing, errExit+         , log_stdout_with, log_stderr_with++         -- * Running external commands.+         , run, run_, runFoldLines, cmd, FoldCallback+         , bash, bash_, bashPipeFail+         , (-|-), lastStderr, setStdin, lastExitCode+         , command, command_, command1, command1_+         , sshPairs,sshPairsPar, sshPairs_,sshPairsPar_, sshPairsWithOptions+         , sshCommandText, SshMode(..)+         , ShellCmd(..), CmdArg (..)++         -- * Running commands Using handles+         , runHandle, runHandles, transferLinesAndCombine, transferFoldHandleLines+         , StdHandle(..), StdStream(..)++         -- * Handle manipulation+         , HandleInitializer, StdInit(..), initOutputHandles, initAllHandles++         -- * Modifying and querying environment.+         , setenv, get_env, get_env_text, getenv, get_env_def, get_env_all, get_environment, appendToPath, prependToPath++         -- * Environment directory+         , cd, chdir, chdir_p, pwd++         -- * Printing+         , echo, echo_n, echo_err, echo_n_err, inspect, inspect_err+         , tag, trace, show_command++         -- * Querying filesystem.+         , ls, lsT, test_e, test_f, test_d, test_s, test_px, which++         -- * Filename helpers+         , absPath, (</>), (<.>), canonic, canonicalize, relPath, relativeTo, path+         , hasExt++         -- * Manipulating filesystem.+         , mv, rm, rm_f, rm_rf, cp, cp_r, mkdir, mkdir_p, mkdirTree++         -- * reading/writing Files+         , readfile, readBinary, writefile, writeBinary, appendfile, touchfile, withTmpDir++         -- * exiting the program+         , exit, errorExit, quietExit, terror++         -- * Exceptions+         , bracket_sh, catchany, catch_sh, handle_sh, handleany_sh, finally_sh, ShellyHandler(..), catches_sh, catchany_sh+         , ReThrownException(..)+         , RunFailed(..)++         -- * convert between Text and FilePath+         , toTextIgnore, toTextWarn, FP.fromText++         -- * Utility Functions+         , whenM, unlessM, time, sleep++         -- * Re-exported for your convenience+         , liftIO, when, unless, FilePath, (<$>)++         -- * internal functions for writing extensions+         , get, put++         -- * find functions+         , find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter+         , followSymlink+         ) where++import Shelly.Base+import Shelly.Find+import Control.Monad ( when, unless, void, forM, filterM, liftM2 )+import Control.Monad.Trans ( MonadIO )+import Control.Monad.Reader (ask)+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706+import Prelude hiding ( readFile, FilePath, catch)+#else+import Prelude hiding ( readFile, FilePath)+#endif+import Data.Char ( isAlphaNum, isSpace )+import Data.Typeable+import Data.IORef+import Data.Sequence (Seq, (|>))+import Data.Foldable (toList)+import Data.Maybe+import System.IO ( hClose, stderr, stdout, openTempFile)+import System.IO.Error (isPermissionError, catchIOError, isEOFError, isIllegalOperation)+import System.Exit+import System.Environment+import Control.Applicative+import Control.Exception+import Control.Concurrent+import Control.Concurrent.Async (async, wait, Async)+import Data.Time.Clock( getCurrentTime, diffUTCTime  )++import qualified Data.Text.IO as TIO+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Encoding.Error as TE+import System.Process( CmdSpec(..), StdStream(CreatePipe, UseHandle), CreateProcess(..), createProcess, waitForProcess, terminateProcess, ProcessHandle, StdStream(..) )++import qualified Data.Text as T+import qualified Data.ByteString as BS+import Data.ByteString (ByteString)++#if !MIN_VERSION_base(4,13,0)+import Data.Monoid (mempty, mappend, (<>))+#endif++import Filesystem.Path.CurrentOS hiding (concat, fromText, (</>), (<.>))+import Filesystem hiding (canonicalizePath)+import qualified Filesystem.Path.CurrentOS as FP++import System.Directory ( setPermissions, getPermissions, Permissions(..), getTemporaryDirectory )+import Data.Char (isDigit)++import Data.Tree(Tree(..))+import qualified Data.Set as S+import qualified Data.List as L++searchPathSeparator :: Char+#if defined(mingw32_HOST_OS)+searchPathSeparator = ';'+#else+searchPathSeparator = ':'+#endif++{- GHC won't default to Text with this, even with extensions!+ - see: http://hackage.haskell.org/trac/ghc/ticket/6030+class CmdArgs a where+  toTextArgs :: a -> [Text]++instance CmdArgs Text       where toTextArgs t = [t]+instance CmdArgs FilePath   where toTextArgs t = [toTextIgnore t]+instance CmdArgs [Text]     where toTextArgs = id+instance CmdArgs [FilePath] where toTextArgs = map toTextIgnore++instance CmdArgs (Text, Text) where+  toTextArgs (t1,t2) = [t1, t2]+instance CmdArgs (FilePath, FilePath) where+  toTextArgs (fp1,fp2) = [toTextIgnore fp1, toTextIgnore fp2]+instance CmdArgs (Text, FilePath) where+  toTextArgs (t1, fp1) = [t1, toTextIgnore fp1]+instance CmdArgs (FilePath, Text) where+  toTextArgs (fp1,t1) = [toTextIgnore fp1, t1]++cmd :: (CmdArgs args) => FilePath -> args -> Sh Text+cmd fp args = run fp $ toTextArgs args+-}++-- | Argument converter for the variadic argument version of 'run' called 'cmd'.+-- Useful for a type signature of a function that uses 'cmd'+class CmdArg a where toTextArg :: a -> Text+instance CmdArg Text     where toTextArg = id+instance CmdArg FilePath where toTextArg = toTextIgnore+instance CmdArg String   where toTextArg = T.pack++-- | For the variadic function 'cmd'+--+-- partially applied variadic functions require type signatures+class ShellCmd t where+    cmdAll :: FilePath -> [Text] -> t++instance ShellCmd (Sh Text) where+    cmdAll = run++instance (s ~ Text, Show s) => ShellCmd (Sh s) where+    cmdAll = run++-- note that Sh () actually doesn't work for its case (_<- cmd) when there is no type signature+instance ShellCmd (Sh ()) where+    cmdAll = run_++instance (CmdArg arg, ShellCmd result) => ShellCmd (arg -> result) where+    cmdAll fp acc x = cmdAll fp (acc ++ [toTextArg x])++instance (CmdArg arg, ShellCmd result) => ShellCmd ([arg] -> result) where+    cmdAll fp acc x = cmdAll fp (acc ++ map toTextArg x)++++-- | variadic argument version of 'run'.+-- Please see the documenation for 'run'.+--+-- The syntax is more convenient, but more importantly it also allows the use of a FilePath as a command argument.+-- So an argument can be a Text or a FilePath without manual conversions.+-- a FilePath is automatically converted to Text with 'toTextIgnore'.+--+-- Convenient usage of 'cmd' requires the following:+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > {-# LANGUAGE ExtendedDefaultRules #-}+-- > {-# OPTIONS_GHC -fno-warn-type-defaults #-}+-- > import Shelly+-- > import qualified Data.Text as T+-- > default (T.Text)+--+cmd :: (ShellCmd result) => FilePath -> result+cmd fp = cmdAll fp []++-- | Helper to convert a Text to a FilePath. Used by '(</>)' and '(<.>)'+class ToFilePath a where+  toFilePath :: a -> FilePath++instance ToFilePath FilePath where toFilePath = id+instance ToFilePath Text     where toFilePath = FP.fromText+instance ToFilePath String   where toFilePath = FP.fromText . T.pack+++-- | uses System.FilePath.CurrentOS, but can automatically convert a Text+(</>) :: (ToFilePath filepath1, ToFilePath filepath2) => filepath1 -> filepath2 -> FilePath+x </> y = toFilePath x FP.</> toFilePath y++-- | uses System.FilePath.CurrentOS, but can automatically convert a Text+(<.>) :: (ToFilePath filepath) => filepath -> Text -> FilePath+x <.> y = toFilePath x FP.<.> y+++toTextWarn :: FilePath -> Sh Text+toTextWarn efile = case toText efile of+    Left f -> encodeError f >> return f+    Right f -> return f+  where+    encodeError f = echo ("non-unicode file name: " <> f)++-- | Transfer from one handle to another+-- For example, send contents of a process output to stdout.+-- does not close the write handle.+--+-- Also, return the complete contents being streamed line by line.+transferLinesAndCombine :: Handle -> (Text -> IO ()) -> IO Text+transferLinesAndCombine readHandle putWrite =+  transferFoldHandleLines mempty (|>) readHandle putWrite >>=+    return . lineSeqToText++lineSeqToText :: Seq Text -> Text+-- extra append puts a newline at the end+lineSeqToText = T.intercalate "\n" . toList . flip (|>) ""++type FoldCallback a = (a -> Text -> a)++-- | Transfer from one handle to another+-- For example, send contents of a process output to stdout.+-- does not close the write handle.+--+-- Also, fold over the contents being streamed line by line+transferFoldHandleLines :: a -> FoldCallback a -> Handle -> (Text -> IO ()) -> IO a+transferFoldHandleLines start foldLine readHandle putWrite = go start+  where+    go acc = do+        mLine <- filterIOErrors $ TIO.hGetLine readHandle+        case mLine of+            Nothing -> return acc+            Just line -> putWrite line >> go (foldLine acc line)++filterIOErrors :: IO a -> IO (Maybe a)+filterIOErrors action = catchIOError+               (fmap Just action)+               (\e -> if isEOFError e || isIllegalOperation e -- handle was closed+                       then return Nothing+                       else ioError e)++foldHandleLines :: a -> FoldCallback a -> Handle -> IO a+foldHandleLines start foldLine readHandle = go start+  where+    go acc = do+      mLine <- filterIOErrors $ TIO.hGetLine readHandle+      case mLine of+        Nothing -> return acc+        Just line -> go $ foldLine acc line++-- | same as 'trace', but use it combinator style+tag :: Sh a -> Text -> Sh a+tag action msg = do+  trace msg+  action++put :: State -> Sh ()+put newState = do+  stateVar <- ask+  liftIO (writeIORef stateVar newState)++runCommandNoEscape :: [StdHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle)+runCommandNoEscape handles st exe args = liftIO $ shellyProcess handles st $+    ShellCommand $ T.unpack $ T.intercalate " " (toTextIgnore exe : args)++runCommand :: [StdHandle] -> State -> FilePath -> [Text] -> Sh (Handle, Handle, Handle, ProcessHandle)+runCommand handles st exe args = findExe exe >>= \fullExe ->+  liftIO $ shellyProcess handles st $+    RawCommand (encodeString fullExe) (map T.unpack args)+  where+    findExe :: FilePath -> Sh FilePath+    findExe+#if defined(mingw32_HOST_OS) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 708)+      fp+#else+      _fp+#endif+      = do+        mExe <- whichEith exe+        case mExe of+          Right execFp -> return execFp+          -- windows looks in extra places besides the PATH, so just give+          -- up even if the behavior is not properly specified anymore+          --+          -- non-Windows < 7.8 has a bug for read-only file systems+          -- https://github.com/yesodweb/Shelly.hs/issues/56+          -- it would be better to specifically detect that bug+#if defined(mingw32_HOST_OS) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 708)+          Left _ -> return fp+#else+          Left err -> liftIO $ throwIO $ userError err+#endif+++++shellyProcess :: [StdHandle] -> State -> CmdSpec -> IO (Handle, Handle, Handle, ProcessHandle)+shellyProcess reusedHandles st cmdSpec =  do+    (createdInH, createdOutH, createdErrorH, pHandle) <- createProcess CreateProcess {+          cmdspec = cmdSpec+        , cwd = Just $ encodeString $ sDirectory st+        , env = Just $ sEnvironment st+        , std_in  = createUnless mInH+        , std_out = createUnless mOutH+        , std_err = createUnless mErrorH+        , close_fds = False+#if MIN_VERSION_process(1,1,0)+        , create_group = False+#endif+#if MIN_VERSION_process(1,2,0)+        , delegate_ctlc = False+#endif+#if MIN_VERSION_process(1,3,0)+        , detach_console = False+        , create_new_console = False+        , new_session = False+#endif+#if MIN_VERSION_process(1,4,0)+        , child_group = Nothing+        , child_user = Nothing+#endif+#if MIN_VERSION_process(1,5,0)+        , use_process_jobs = False+#endif+        }+    return ( just $ createdInH <|> toHandle mInH+           , just $ createdOutH <|> toHandle mOutH+           , just $ createdErrorH <|> toHandle mErrorH+           , pHandle+           )+  where+    just :: Maybe a -> a+    just Nothing  = error "error in shelly creating process"+    just (Just j) = j++    toHandle (Just (UseHandle h)) = Just h+    toHandle _ = error "shellyProcess/toHandle: internal error"++    createUnless Nothing = CreatePipe+    createUnless (Just stream) = stream++    mInH    = getStream mIn reusedHandles+    mOutH   = getStream mOut reusedHandles+    mErrorH = getStream mError reusedHandles++    getStream :: (StdHandle -> Maybe StdStream) -> [StdHandle] -> Maybe StdStream+    getStream _ [] = Nothing+    getStream mHandle (h:hs) = mHandle h <|> getStream mHandle hs++    mIn, mOut, mError :: (StdHandle -> Maybe StdStream)+    mIn (InHandle h) = Just h+    mIn _ = Nothing+    mOut (OutHandle h) = Just h+    mOut _ = Nothing+    mError (ErrorHandle h) = Just h+    mError _ = Nothing++{-+-- | use for commands requiring usage of sudo. see 'run_sudo'.+--  Use this pattern for priveledge separation+newtype Sudo a = Sudo { sudo :: Sh a }++-- | require that the caller explicitly state 'sudo'+run_sudo :: Text -> [Text] -> Sudo Text+run_sudo cmd args = Sudo $ run "/usr/bin/sudo" (cmd:args)+-}++-- | Same as a normal 'catch' but specialized for the Sh monad.+catch_sh :: (Exception e) => Sh a -> (e -> Sh a) -> Sh a+catch_sh action handler = do+    ref <- ask+    liftIO $ catch (runSh action ref) (\e -> runSh (handler e) ref)++-- | Same as a normal 'handle' but specialized for the Sh monad.+handle_sh :: (Exception e) => (e -> Sh a) -> Sh a -> Sh a+handle_sh handler action = do+    ref <- ask+    liftIO $ handle (\e -> runSh (handler e) ref) (runSh action ref)+++-- | Same as a normal 'finally' but specialized for the 'Sh' monad.+finally_sh :: Sh a -> Sh b -> Sh a+finally_sh action handler = do+    ref <- ask+    liftIO $ finally (runSh action ref) (runSh handler ref)++bracket_sh :: Sh a -> (a -> Sh b) -> (a -> Sh c) -> Sh c+bracket_sh acquire release main = do+  ref <- ask+  liftIO $ bracket (runSh acquire ref)+                   (\resource -> runSh (release resource) ref)+                   (\resource -> runSh (main resource) ref)++++-- | You need to wrap exception handlers with this when using 'catches_sh'.+data ShellyHandler a = forall e . Exception e => ShellyHandler (e -> Sh a)++-- | Same as a normal 'catches', but specialized for the 'Sh' monad.+catches_sh :: Sh a -> [ShellyHandler a] -> Sh a+catches_sh action handlers = do+    ref <- ask+    let runner a = runSh a ref+    liftIO $ catches (runner action) $ map (toHandler runner) handlers+  where+    toHandler :: (Sh a -> IO a) -> ShellyHandler a -> Handler a+    toHandler runner (ShellyHandler handler) = Handler (\e -> runner (handler e))++-- | Catch any exception in the Sh monad.+catchany_sh :: Sh a -> (SomeException -> Sh a) -> Sh a+catchany_sh = catch_sh++-- | Handle any exception in the Sh monad.+handleany_sh :: (SomeException -> Sh a) -> Sh a -> Sh a+handleany_sh = handle_sh++-- | Change current working directory of Sh. This does *not* change the+-- working directory of the process we are running it. Instead, Sh keeps+-- track of its own working directory and builds absolute paths internally+-- instead of passing down relative paths.+cd :: FilePath -> Sh ()+cd = traceCanonicPath ("cd " <>) >=> cd'+  where+    cd' dir = do+        unlessM (test_d dir) $ errorExit $ "not a directory: " <> tdir+        modify $ \st -> st { sDirectory = dir, sPathExecutables = Nothing }+      where+        tdir = toTextIgnore dir++-- | 'cd', execute a Sh action in the new directory and then pop back to the original directory+chdir :: FilePath -> Sh a -> Sh a+chdir dir action = do+  d <- gets sDirectory+  cd dir+  action `finally_sh` cd d++-- | 'chdir', but first create the directory if it does not exit+chdir_p :: FilePath -> Sh a -> Sh a+chdir_p d action = mkdir_p d >> chdir d action+++-- | apply a String IO operations to a Text FilePath+{-+liftStringIO :: (String -> IO String) -> FilePath -> Sh FilePath+liftStringIO f = liftIO . f . unpack >=> return . pack++-- | @asString f = pack . f . unpack@+asString :: (String -> String) -> FilePath -> FilePath+asString f = pack . f . unpack+-}++pack :: String -> FilePath+pack = decodeString++-- | Move a file. The second path could be a directory, in which case the+-- original file is moved into that directory.+-- wraps system-fileio 'FileSystem.rename', which may not work across FS boundaries+mv :: FilePath -> FilePath -> Sh ()+mv from' to' = do+  trace $ "mv " <> toTextIgnore from' <> " " <> toTextIgnore to'+  from <- absPath from'+  to <- absPath to'+  to_dir <- test_d to+  let to_loc = if not to_dir then to else to FP.</> filename from+  liftIO $ rename from to_loc+    `catchany` (\e -> throwIO $+      ReThrownException e (extraMsg to_loc from)+    )+  where+    extraMsg t f = "during copy from: " ++ encodeString f ++ " to: " ++ encodeString t++-- | Get back [Text] instead of [FilePath]+lsT :: FilePath -> Sh [Text]+lsT = ls >=> mapM toTextWarn++-- | Obtain the current (Sh) working directory.+pwd :: Sh FilePath+pwd = gets sDirectory `tag` "pwd"++-- | exit 0 means no errors, all other codes are error conditions+exit :: Int -> Sh a+exit 0 = liftIO exitSuccess `tag` "exit 0"+exit n = liftIO (exitWith (ExitFailure n)) `tag` ("exit " <> T.pack (show n))++-- | echo a message and exit with status 1+errorExit :: Text -> Sh a+errorExit msg = echo msg >> exit 1++-- | for exiting with status > 0 without printing debug information+quietExit :: Int -> Sh a+quietExit 0 = exit 0+quietExit n = throw $ QuietExit n++-- | fail that takes a Text+terror :: Text -> Sh a+terror = fail . T.unpack++-- | Create a new directory (fails if the directory exists).+mkdir :: FilePath -> Sh ()+mkdir = traceAbsPath ("mkdir " <>) >=>+        liftIO . createDirectory False++-- | Create a new directory, including parents (succeeds if the directory+-- already exists).+mkdir_p :: FilePath -> Sh ()+mkdir_p = traceAbsPath ("mkdir -p " <>) >=>+          liftIO . createTree++-- | Create a new directory tree. You can describe a bunch of directories as+-- a tree and this function will create all subdirectories. An example:+--+-- > exec = mkTree $+-- >           "package" # [+-- >                "src" # [+-- >                    "Data" # leaves ["Tree", "List", "Set", "Map"]+-- >                ],+-- >                "test" # leaves ["QuickCheck", "HUnit"],+-- >                "dist/doc/html" # []+-- >            ]+-- >         where (#) = Node+-- >               leaves = map (# [])+--+mkdirTree :: Tree FilePath -> Sh ()+mkdirTree = mk . unrollPath+    where mk :: Tree FilePath -> Sh ()+          mk (Node a ts) = do+            b <- test_d a+            unless b $ mkdir a+            chdir a $ mapM_ mkdirTree ts++          unrollPath :: Tree FilePath -> Tree FilePath+          unrollPath (Node v ts) = unrollRoot v $ map unrollPath ts+              where unrollRoot x = foldr1 phi $ map Node $ splitDirectories x+                    phi a b = a . return . b+++isExecutable :: FilePath -> IO Bool+isExecutable f = (executable `fmap` getPermissions (encodeString f)) `catch` (\(_ :: IOError) -> return False)++-- | Get a full path to an executable by looking at the @PATH@ environement+-- variable. Windows normally looks in additional places besides the+-- @PATH@: this does not duplicate that behavior.+which :: FilePath -> Sh (Maybe FilePath)+which fp = either (const Nothing) Just <$> whichEith fp++-- | Get a full path to an executable by looking at the @PATH@ environement+-- variable. Windows normally looks in additional places besides the+-- @PATH@: this does not duplicate that behavior.+whichEith :: FilePath -> Sh (Either String FilePath)+whichEith originalFp = whichFull+#if defined(mingw32_HOST_OS)+    $ case extension originalFp of+        Nothing -> originalFp <.> "exe"+        Just _ -> originalFp+#else+    originalFp+#endif+  where+    whichFull fp = do+      (trace . mappend "which " . toTextIgnore) fp >> whichUntraced+      where+        whichUntraced | absolute fp            = checkFile+                      | dotSlash splitOnDirs   = checkFile+                      | length splitOnDirs > 0 = lookupPath  >>= leftPathError+                      | otherwise              = lookupCache >>= leftPathError++        splitOnDirs = splitDirectories fp+        dotSlash ("./":_) = True+        dotSlash _ = False++        checkFile :: Sh (Either String FilePath)+        checkFile = do+            exists <- liftIO $ isFile fp+            return $ if exists then Right fp else+              Left $ "did not find file: " <> encodeString fp++        leftPathError :: Maybe FilePath -> Sh (Either String FilePath)+        leftPathError Nothing  = Left <$> pathLookupError+        leftPathError (Just x) = return $ Right x++        pathLookupError :: Sh String+        pathLookupError = do+          pATH <- get_env_text "PATH"+          return $+            "shelly did not find " `mappend` encodeString fp `mappend`+            " in the PATH: " `mappend` T.unpack pATH++        lookupPath :: Sh (Maybe FilePath)+        lookupPath = (pathDirs >>=) $ findMapM $ \dir -> do+            let fullFp = dir </> fp+            res <- liftIO $ isExecutable fullFp+            return $ if res then Just fullFp else Nothing++        lookupCache :: Sh (Maybe FilePath)+        lookupCache = do+            pathExecutables <- cachedPathExecutables+            return $ fmap (flip (</>) fp . fst) $+                L.find (S.member fp . snd) pathExecutables+++        pathDirs = mapM absPath =<< ((map FP.fromText . filter (not . T.null) . T.split (== searchPathSeparator)) `fmap` get_env_text "PATH")++        cachedPathExecutables :: Sh [(FilePath, S.Set FilePath)]+        cachedPathExecutables = do+          mPathExecutables <- gets sPathExecutables+          case mPathExecutables of+              Just pExecutables -> return pExecutables+              Nothing -> do+                dirs <- pathDirs+                executables <- forM dirs (\dir -> do+                    files <- (liftIO . listDirectory) dir `catch_sh` (\(_ :: IOError) -> return [])+                    exes <- fmap (map snd) $ liftIO $ filterM (isExecutable . fst) $+                      map (\f -> (f, filename f)) files+                    return $ S.fromList exes+                  )+                let cachedExecutables = zip dirs executables+                modify $ \x -> x { sPathExecutables = Just cachedExecutables }+                return $ cachedExecutables+++-- | A monadic findMap, taken from MissingM package+findMapM :: Monad m => (a -> m (Maybe b)) -> [a] -> m (Maybe b)+findMapM _ [] = return Nothing+findMapM f (x:xs) = do+    mb <- f x+    if (isJust mb)+      then return mb+      else findMapM f xs++-- | A monadic-conditional version of the 'unless' guard.+unlessM :: Monad m => m Bool -> m () -> m ()+unlessM c a = c >>= \res -> unless res a++-- | Does a path point to an existing filesystem object?+test_e :: FilePath -> Sh Bool+test_e = absPath >=> \f ->+  liftIO $ do+    file <- isFile f+    if file then return True else isDirectory f++-- | Does a path point to an existing file?+test_f :: FilePath -> Sh Bool+test_f = absPath >=> liftIO . isFile++-- | Test that a file is in the PATH and also executable+test_px :: FilePath -> Sh Bool+test_px exe = do+  mFull <- which exe+  case mFull of+    Nothing -> return False+    Just full -> liftIO $ isExecutable full++-- | A swiss army cannon for removing things. Actually this goes farther than a+-- normal rm -rf, as it will circumvent permission problems for the files we+-- own. Use carefully.+-- Uses 'removeTree'+rm_rf :: FilePath -> Sh ()+rm_rf infp = do+  f <- traceAbsPath ("rm -rf " <>) infp+  isDir <- (test_d f)+  if not isDir then whenM (test_f f) $ rm_f f+    else+      (liftIO_ $ removeTree f) `catch_sh` (\(e :: IOError) ->+        when (isPermissionError e) $ do+          find f >>= mapM_ (\file -> liftIO_ $ fixPermissions (encodeString file) `catchany` \_ -> return ())+          liftIO $ removeTree f+        )+  where fixPermissions file =+          do permissions <- liftIO $ getPermissions file+             let deletable = permissions { readable = True, writable = True, executable = True }+             liftIO $ setPermissions file deletable++-- | Remove a file. Does not fail if the file does not exist.+-- Does fail if the file is not a file.+rm_f :: FilePath -> Sh ()+rm_f = traceAbsPath ("rm -f " <>) >=> \f ->+  whenM (test_e f) $ liftIO $ removeFile f++-- | Remove a file.+-- Does fail if the file does not exist (use 'rm_f' instead) or is not a file.+rm :: FilePath -> Sh ()+rm = traceAbsPath ("rm " <>) >=>+  -- TODO: better error message for removeFile (give filename)+  liftIO . removeFile++-- | Set an environment variable. The environment is maintained in Sh+-- internally, and is passed to any external commands to be executed.+setenv :: Text -> Text -> Sh ()+setenv k v = if k == path_env then setPath v else setenvRaw k v++setenvRaw :: Text -> Text -> Sh ()+setenvRaw k v = modify $ \x -> x { sEnvironment = wibble $ sEnvironment x }+  where+    (kStr, vStr) = (T.unpack k, T.unpack v)+    wibble environment = (kStr, vStr) : filter ((/=kStr) . fst) environment++setPath :: Text -> Sh ()+setPath newPath = do+  modify $ \x -> x{ sPathExecutables = Nothing }+  setenvRaw path_env newPath++path_env :: Text+path_env = "PATH"++-- | add the filepath onto the PATH env variable+appendToPath :: FilePath -> Sh ()+appendToPath = traceAbsPath ("appendToPath: " <>) >=> \filepath -> do+  tp <- toTextWarn filepath+  pe <- get_env_text path_env+  setPath $ pe <> T.singleton searchPathSeparator <> tp++-- | prepend the filepath to the PATH env variable+-- similar to `appendToPath` but gives high priority to the filepath instead of low priority.+prependToPath :: FilePath -> Sh ()+prependToPath = traceAbsPath ("prependToPath: " <>) >=> \filepath -> do+  tp <- toTextWarn filepath+  pe <- get_env_text path_env+  setPath $ tp <> T.singleton searchPathSeparator <> pe++get_environment :: Sh [(String, String)]+get_environment = gets sEnvironment+{-# DEPRECATED get_environment "use get_env_all" #-}++-- | get the full environment+get_env_all :: Sh [(String, String)]+get_env_all = gets sEnvironment++-- | Fetch the current value of an environment variable.+-- if non-existant or empty text, will be Nothing+get_env :: Text -> Sh (Maybe Text)+get_env k = do+  mval <- return . fmap T.pack . lookup (T.unpack k) =<< gets sEnvironment+  return $ case mval of+    Nothing  -> Nothing+    Just val -> if (not $ T.null val) then Just val else Nothing++-- | deprecated+getenv :: Text -> Sh Text+getenv k = get_env_def k ""+{-# DEPRECATED getenv "use get_env or get_env_text" #-}++-- | Fetch the current value of an environment variable. Both empty and+-- non-existent variables give empty string as a result.+get_env_text :: Text -> Sh Text+get_env_text = get_env_def ""++-- | Fetch the current value of an environment variable. Both empty and+-- non-existent variables give the default Text value as a result+get_env_def :: Text -> Text -> Sh Text+get_env_def d = get_env >=> return . fromMaybe d+{-# DEPRECATED get_env_def "use fromMaybe DEFAULT get_env" #-}++-- | Apply a single initializer to the two output process handles (stdout and stderr)+initOutputHandles :: HandleInitializer -> StdInit+initOutputHandles f = StdInit (const $ return ()) f f++-- | Apply a single initializer to all three standard process handles (stdin, stdout and stderr)+initAllHandles :: HandleInitializer -> StdInit+initAllHandles f = StdInit f f f++-- | When running an external command, apply the given initializers to+-- the specified handles for that command.+-- This can for example be used to change the encoding of the+-- handles or set them into binary mode.+onCommandHandles :: StdInit -> Sh a -> Sh a+onCommandHandles initHandles a =+    sub $ modify (\x -> x { sInitCommandHandles = initHandles }) >> a++-- | Create a sub-Sh in which external command outputs are not echoed and+-- commands are not printed.+-- See 'sub'.+silently :: Sh a -> Sh a+silently a = sub $ modify (\x -> x+                                { sPrintStdout = False+                                , sPrintStderr = False+                                , sPrintCommands = False+                                }) >> a++-- | Create a sub-Sh in which external command outputs are echoed and+-- Executed commands are printed+-- See 'sub'.+verbosely :: Sh a -> Sh a+verbosely a = sub $ modify (\x -> x+                                 { sPrintStdout = True+                                 , sPrintStderr = True+                                 , sPrintCommands = True+                                 }) >> a++-- | Create a sub-Sh in which stdout is sent to the user-defined+-- logger.  When running with 'silently' the given log will not be+-- called for any output. Likewise the log will also not be called for+-- output from 'run_' and 'bash_' commands.+log_stdout_with :: (Text -> IO ()) -> Sh a -> Sh a+log_stdout_with logger a = sub $ modify (\s -> s { sPutStdout = logger })+                                 >> a++-- | Create a sub-Sh in which stderr is sent to the user-defined+-- logger.  When running with 'silently' the given log will not be+-- called for any output. However, unlike 'log_stdout_with' the log+-- will be called for output from 'run_' and 'bash_' commands.+log_stderr_with :: (Text -> IO ()) -> Sh a -> Sh a+log_stderr_with logger a = sub $ modify (\s -> s { sPutStderr = logger })+                                 >> a++-- | Create a sub-Sh with stdout printing on or off+-- Defaults to True.+print_stdout :: Bool -> Sh a -> Sh a+print_stdout shouldPrint a =+  sub $ modify (\x -> x { sPrintStdout = shouldPrint }) >> a++-- | Create a sub-Sh with stderr printing on or off+-- Defaults to True.+print_stderr :: Bool -> Sh a -> Sh a+print_stderr shouldPrint a =+  sub $ modify (\x -> x { sPrintStderr = shouldPrint }) >> a+++-- | Create a sub-Sh with command echoing on or off+-- Defaults to False, set to True by 'verbosely'+print_commands :: Bool -> Sh a -> Sh a+print_commands shouldPrint a = sub $ modify (\st -> st { sPrintCommands = shouldPrint }) >> a++-- | Enter a sub-Sh that inherits the environment+-- The original state will be restored when the sub-Sh completes.+-- Exceptions are propagated normally.+sub :: Sh a -> Sh a+sub a = do+  oldState <- get+  modify $ \st -> st { sTrace = T.empty }+  a `finally_sh` restoreState oldState+  where+    restoreState oldState = do+      newState <- get+      put oldState {+         -- avoid losing the log+         sTrace  = sTrace oldState <> sTrace newState+         -- latest command execution: not make sense to restore these to old settings+       , sCode   = sCode newState+       , sStderr = sStderr newState+         -- it is questionable what the behavior of stdin should be+       , sStdin  = sStdin newState+       }++-- | Create a sub-Sh where commands are not traced+-- Defaults to True.+-- You should only set to False temporarily for very specific reasons+tracing :: Bool -> Sh a -> Sh a+tracing shouldTrace action = sub $ do+  modify $ \st -> st { sTracing = shouldTrace }+  action++-- | Create a sub-Sh with shell character escaping on or off.+-- Defaults to @True@.+--+-- Setting to @False@ allows for shell wildcard such as * to be expanded by the shell along with any other special shell characters.+-- As a side-effect, setting to @False@ causes changes to @PATH@ to be ignored:+-- see the 'run' documentation.+escaping :: Bool -> Sh a -> Sh a+escaping shouldEscape action = sub $ do+  modify $ \st -> st { sCommandEscaping = shouldEscape }+  action++-- | named after bash -e errexit. Defaults to @True@.+-- When @True@, throw an exception on a non-zero exit code.+-- When @False@, ignore a non-zero exit code.+-- Not recommended to set to @False@ unless you are specifically checking the error code with 'lastExitCode'.+errExit :: Bool -> Sh a -> Sh a+errExit shouldExit action = sub $ do+  modify $ \st -> st { sErrExit = shouldExit }+  action++-- | 'find'-command follows symbolic links. Defaults to @False@.+-- When @True@, follow symbolic links.+-- When @False@, never follow symbolic links.+followSymlink :: Bool -> Sh a -> Sh a+followSymlink enableFollowSymlink action = sub $ do+  modify $ \st -> st { sFollowSymlink = enableFollowSymlink }+  action+++defReadOnlyState :: ReadOnlyState+defReadOnlyState = ReadOnlyState { rosFailToDir = False }++-- | Deprecated now, just use 'shelly', whose default has been changed.+-- Using this entry point does not create a @.shelly@ directory in the case+-- of failure. Instead it logs directly into the standard error stream (@stderr@).+shellyNoDir :: MonadIO m => Sh a -> m a+shellyNoDir = shelly' ReadOnlyState { rosFailToDir = False }+{-# DEPRECATED shellyNoDir "Just use shelly. The default settings have changed" #-}++-- | Using this entry point creates a @.shelly@ directory in the case+-- of failure where errors are recorded.+shellyFailDir :: MonadIO m => Sh a -> m a+shellyFailDir = shelly' ReadOnlyState { rosFailToDir = True }++-- | Enter a Sh from (Monad)IO. The environment and working directories are+-- inherited from the current process-wide values. Any subsequent changes in+-- processwide working directory or environment are not reflected in the+-- running Sh.+shelly :: MonadIO m => Sh a -> m a+shelly = shelly' defReadOnlyState++shelly' :: MonadIO m => ReadOnlyState -> Sh a -> m a+shelly' ros action = do+  environment <- liftIO getEnvironment+  dir <- liftIO getWorkingDirectory+  let def  = State { sCode = 0+                   , sStdin = Nothing+                   , sStderr = T.empty+                   , sPutStdout = TIO.hPutStrLn stdout+                   , sPutStderr = TIO.hPutStrLn stderr+                   , sPrintStdout = True+                   , sPrintStderr = True+                   , sPrintCommands = False+                   , sInitCommandHandles = initAllHandles (const $ return ())+                   , sCommandEscaping = True+                   , sEnvironment = environment+                   , sTracing = True+                   , sTrace = T.empty+                   , sDirectory = dir+                   , sPathExecutables = Nothing+                   , sErrExit = True+                   , sReadOnly = ros+                   , sFollowSymlink = False+                   }+  stref <- liftIO $ newIORef def+  let caught =+        action `catches_sh` [+              ShellyHandler (\ex ->+                case ex of+                  ExitSuccess   -> liftIO $ throwIO ex+                  ExitFailure _ -> throwExplainedException ex+              )+            , ShellyHandler (\ex -> case ex of+                                     QuietExit n -> liftIO $ throwIO $ ExitFailure n)+            , ShellyHandler (\(ex::SomeException) -> throwExplainedException ex)+          ]+  liftIO $ runSh caught stref+  where+    throwExplainedException :: Exception exception => exception -> Sh a+    throwExplainedException ex = get >>= errorMsg >>= liftIO . throwIO . ReThrownException ex++    errorMsg st =+      if not (rosFailToDir $ sReadOnly st) then ranCommands else do+          d <- pwd+          sf <- shellyFile+          let logFile = d</>shelly_dir</>sf+          (writefile logFile trc >> return ("log of commands saved to: " <> encodeString logFile))+            `catchany_sh` (\_ -> ranCommands)++      where+        trc = sTrace st+        ranCommands = return . mappend "Ran commands: \n" . T.unpack $ trc++    shelly_dir = ".shelly"+    shellyFile = chdir_p shelly_dir $ do+      fs <- ls "."+      return $ pack $ show (nextNum fs) <> ".txt"++    nextNum :: [FilePath] -> Int+    nextNum [] = 1+    nextNum fs = (+ 1) . maximum . map (readDef 1 . filter isDigit . encodeString . filename) $ fs++-- from safe package+readDef :: Read a => a -> String -> a+readDef def = fromMaybe def . readMay+  where+    readMay :: Read a => String -> Maybe a+    readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of+                  [x] -> Just x+                  _ -> Nothing++data RunFailed = RunFailed FilePath [Text] Int Text deriving (Typeable)++instance Show RunFailed where+  show (RunFailed exe args code errs) =+    let codeMsg = case code of+          127 -> ". exit code 127 usually means the command does not exist (in the PATH)"+          _ -> ""+    in "error running: " ++ T.unpack (show_command exe args) +++         "\nexit status: " ++ show code ++ codeMsg ++ "\nstderr: " ++ T.unpack errs++instance Exception RunFailed++show_command :: FilePath -> [Text] -> Text+show_command exe args =+    T.intercalate " " $ map quote (toTextIgnore exe : args)+  where+    quote t | T.any (== '\'') t = t+    quote t | T.any isSpace t = surround '\'' t+    quote t | otherwise = t++-- quote one argument+quoteOne :: Text -> Text+quoteOne t =+    surround '\'' $ T.replace "'" "'\\''" t+++-- returns a string that can be executed by a shell.+-- NOTE: all parts are treated literally, which means that+-- things like variable expansion will not be available.+quoteCommand :: FilePath -> [Text] -> Text+quoteCommand exe args =+    T.intercalate " " $ map quoteOne (toTextIgnore exe : args)++surround :: Char -> Text -> Text+surround c t = T.cons c $ T.snoc t c++data SshMode = ParSsh | SeqSsh++-- | same as 'sshPairs', but returns ()+sshPairs_ :: Text -> [(FilePath, [Text])] -> Sh ()+sshPairs_ _ [] = return ()+sshPairs_ server cmds = sshPairs' run_ server cmds++-- | same as 'sshPairsP', but returns ()++sshPairsPar_ :: Text -> [(FilePath, [Text])] -> Sh ()+sshPairsPar_ _ [] = return ()+sshPairsPar_ server cmds = sshPairsPar' run_ server cmds++-- | run commands over SSH.+-- An ssh executable is expected in your path.+-- Commands are in the same form as 'run', but given as pairs+--+-- > sshPairs "server-name" [("cd", "dir"), ("rm",["-r","dir2"])]+--+-- This interface is crude, but it works for now.+--+-- Please note this sets 'escaping' to False, and the remote commands are+-- quoted with single quotes, in a way such that the remote commands will see+-- the literal values you passed, this means that no variable expansion and+-- alike will done on either the local shell or the remote shell, and that+-- if there are a single or double quotes in your arguments, they need not+-- to be quoted manually.+--+-- Internally the list of commands are combined with the string @&&@ before given to ssh.+sshPairs :: Text -> [(FilePath, [Text])] -> Sh Text+sshPairs _ [] = return ""+sshPairs server cmds = sshPairsWithOptions' run server [] cmds SeqSsh++-- | Same as sshPairs, but combines commands with the string @&@, so they will be started in parallell.+sshPairsPar :: Text -> [(FilePath, [Text])] -> Sh Text+sshPairsPar _ [] = return ""+sshPairsPar server cmds = sshPairsWithOptions' run server [] cmds ParSsh++sshPairsPar' :: (FilePath -> [Text] -> Sh a) -> Text -> [(FilePath, [Text])] -> Sh a+sshPairsPar' run' server actions = sshPairsWithOptions' run' server [] actions ParSsh++sshPairs' :: (FilePath -> [Text] -> Sh a) -> Text -> [(FilePath, [Text])] -> Sh a+sshPairs' run' server actions = sshPairsWithOptions' run' server [] actions SeqSsh++-- | Like 'sshPairs', but allows for arguments to the call to ssh.+sshPairsWithOptions :: Text                  -- ^ Server name.+                    -> [Text]                -- ^ Arguments to ssh (e.g. ["-p","22"]).+                    -> [(FilePath, [Text])]  -- ^ Pairs of commands to run on the remote.+                    -> Sh Text               -- ^ Returns the standard output.+sshPairsWithOptions _ _ [] = return ""+sshPairsWithOptions server sshargs cmds = sshPairsWithOptions' run server sshargs cmds SeqSsh++sshPairsWithOptions' :: (FilePath -> [Text] -> Sh a) -> Text -> [Text] -> [(FilePath, [Text])] -> SshMode  -> Sh a+sshPairsWithOptions' run' server sshargs actions mode = escaping False $ do+    run' "ssh" ([server] ++ sshargs ++ [sshCommandText actions mode])++sshCommandText :: [(FilePath, [Text])] -> SshMode -> Text+sshCommandText actions mode =+    quoteOne (foldl1 joiner (map (uncurry quoteCommand) actions))+  where+    joiner memo next = case mode of+        SeqSsh -> memo <> " && " <> next+        ParSsh -> memo <> " & " <> next++data QuietExit = QuietExit Int deriving (Show, Typeable)+instance Exception QuietExit++-- | Shelly's wrapper around exceptions thrown in its monad+data ReThrownException e = ReThrownException e String deriving (Typeable)+instance Exception e => Exception (ReThrownException e)+instance Exception e => Show (ReThrownException e) where+  show (ReThrownException ex msg) = "\n" +++    msg ++ "\n" ++ "Exception: " ++ show ex++-- | Execute an external command.+-- Takes the command name and arguments.+--+-- You may prefer using 'cmd' instead, which is a variadic argument version+-- of this function.+--+-- 'stdout' and 'stderr' are collected. The 'stdout' is returned as+-- a result of 'run', and complete stderr output is available after the fact using+-- 'lastStderr'+--+-- All of the stdout output will be loaded into memory.+-- You can avoid this if you don't need stdout by using 'run_',+-- If you want to avoid the memory and need to process the output then use 'runFoldLines' or 'runHandle' or 'runHandles'.+--+-- By default shell characters are escaped and+-- the command name is a name of a program that can be found via @PATH@.+-- Shelly will look through the @PATH@ itself to find the command.+--+-- When 'escaping' is set to @False@, shell characters are allowed.+-- Since there is no longer a guarantee that a single program name is+-- given, Shelly cannot look in the @PATH@ for it.+-- a @PATH@ modified by setenv is not taken into account when finding the exe name.+-- Instead the original Haskell program @PATH@ is used.+-- On a Posix system the @env@ command can be used to make the 'setenv' PATH used when 'escaping' is set to False. @env echo hello@ instead of @echo hello@+--+run :: FilePath -> [Text] -> Sh Text+run fp args = return . lineSeqToText =<< runFoldLines mempty (|>) fp args++-- | Like `run`, but it invokes the user-requested program with _bash_.+bash :: FilePath -> [Text] -> Sh Text+bash fp args = escaping False $ run "bash" $ bashArgs fp args++bash_ :: FilePath -> [Text] -> Sh ()+bash_ fp args = escaping False $ run_ "bash" $ bashArgs fp args++bashArgs :: FilePath -> [Text] -> [Text]+bashArgs fp args = ["-c", "'" <> sanitise (toTextIgnore fp : args) <> "'"]+  where+    sanitise = T.replace "'" "\'" . T.intercalate " "++-- | Use this with `bash` to set _pipefail_+--+-- > bashPipeFail $ bash "echo foo | echo"+bashPipeFail :: (FilePath -> [Text] -> Sh a) -> FilePath -> [Text] -> Sh a+bashPipeFail runner fp args = runner "set -o pipefail;" (toTextIgnore fp : args)++-- | bind some arguments to run for re-use. Example:+--+-- > monit = command "monit" ["-c", "monitrc"]+-- > monit ["stop", "program"]+command :: FilePath -> [Text] -> [Text] -> Sh Text+command com args more_args = run com (args ++ more_args)++-- | bind some arguments to 'run_' for re-use. Example:+--+-- > monit_ = command_ "monit" ["-c", "monitrc"]+-- > monit_ ["stop", "program"]+command_ :: FilePath -> [Text] -> [Text] -> Sh ()+command_ com args more_args = run_ com (args ++ more_args)++-- | bind some arguments to run for re-use, and require 1 argument. Example:+--+-- > git = command1 "git" []; git "pull" ["origin", "master"]+command1 :: FilePath -> [Text] -> Text -> [Text] -> Sh Text+command1 com args one_arg more_args = run com (args ++ [one_arg] ++ more_args)++-- | bind some arguments to run for re-use, and require 1 argument. Example:+--+-- > git_ = command1_ "git" []; git "pull" ["origin", "master"]+command1_ :: FilePath -> [Text] -> Text -> [Text] -> Sh ()+command1_ com args one_arg more_args = run_ com (args ++ [one_arg] ++ more_args)++-- | the same as 'run', but return @()@ instead of the stdout content+-- stdout will be read and discarded line-by-line+run_ :: FilePath -> [Text] -> Sh ()+run_ exe args = do+    state <- get+    if sPrintStdout state+      then runWithColor_+      else runFoldLines () (\_ _ -> ()) exe args+  where+    -- same a runFoldLines except Inherit Stdout+    -- That allows color to show up+    runWithColor_ =+        runHandles exe args [OutHandle Inherit] $ \inH _ errH -> do+          state <- get+          errs <- liftIO $ do+            hClose inH -- setStdin was taken care of before the process even ran+            errVar <- (putHandleIntoMVar mempty (|>) errH (sPutStderr state) (sPrintStderr state))+            lineSeqToText `fmap` wait errVar+          modify $ \state' -> state' { sStderr = errs }+          return ()++liftIO_ :: IO a -> Sh ()+liftIO_ = void . liftIO++-- | Similar to 'run' but gives the raw stdout handle in a callback.+-- If you want even more control, use 'runHandles'.+runHandle :: FilePath -- ^ command+          -> [Text] -- ^ arguments+          -> (Handle -> Sh a) -- ^ stdout handle+          -> Sh a+runHandle exe args withHandle = runHandles exe args [] $ \_ outH errH -> do+    state <- get+    errVar <- liftIO $+      (putHandleIntoMVar mempty (|>) errH (sPutStderr state) (sPrintStderr state))+    res <- withHandle outH+    errs <- liftIO $ lineSeqToText `fmap` wait errVar+    modify $ \state' -> state' { sStderr = errs }+    return res++-- | Similar to 'run' but gives direct access to all input and output handles.+--+-- Be careful when using the optional input handles.+-- If you specify Inherit for a handle then attempting to access the handle in your+-- callback is an error+runHandles :: FilePath -- ^ command+           -> [Text] -- ^ arguments+           -> [StdHandle] -- ^ optionally connect process i/o handles to existing handles+           -> (Handle -> Handle -> Handle -> Sh a) -- ^ stdin, stdout and stderr+           -> Sh a+runHandles exe args reusedHandles withHandles = do+    -- clear stdin before beginning command execution+    origstate <- get+    let mStdin = sStdin origstate+    put $ origstate { sStdin = Nothing, sCode = 0, sStderr = T.empty }+    state <- get++    let cmdString = show_command exe args+    when (sPrintCommands state) $ echo cmdString+    trace cmdString++    let doRun = if sCommandEscaping state then runCommand else runCommandNoEscape++    bracket_sh+      (doRun reusedHandles state exe args)+      (\(_,_,_,procH) -> (liftIO $ terminateProcess procH))+      (\(inH,outH,errH,procH) -> do++        liftIO $ do+          inInit (sInitCommandHandles state) inH+          outInit (sInitCommandHandles state) outH+          errInit (sInitCommandHandles state) errH++        liftIO $ case mStdin of+          Just input -> TIO.hPutStr inH input+          Nothing -> return ()++        result <- withHandles inH outH errH++        (ex, code) <- liftIO $ do+          ex' <- waitForProcess procH++          -- TODO: specifically catch our own error for Inherit pipes+          hClose outH `catchany` (const $ return ())+          hClose errH `catchany` (const $ return ())+          hClose inH `catchany` (const $ return ())++          return $ case ex' of+            ExitSuccess -> (ex', 0)+            ExitFailure n -> (ex', n)++        modify $ \state' -> state' { sCode = code }++        case (sErrExit state, ex) of+          (True,  ExitFailure n) -> do+              newState <- get+              liftIO $ throwIO $ RunFailed exe args n (sStderr newState)+          _                      -> return result+      )+++-- | used by 'run'. fold over stdout line-by-line as it is read to avoid keeping it in memory+-- stderr is still being placed in memory under the assumption it is always relatively small+runFoldLines :: a -> FoldCallback a -> FilePath -> [Text] -> Sh a+runFoldLines start cb exe args =+  runHandles exe args [] $ \inH outH errH -> do+    state <- get+    (errVar, outVar) <- liftIO $ do+      hClose inH -- setStdin was taken care of before the process even ran+      liftM2 (,)+          (putHandleIntoMVar mempty (|>) errH (sPutStderr state) (sPrintStderr state))+          (putHandleIntoMVar start cb outH (sPutStdout state) (sPrintStdout state))+    errs <- liftIO $ lineSeqToText `fmap` wait errVar+    modify $ \state' -> state' { sStderr = errs }+    liftIO $ wait outVar+++putHandleIntoMVar :: a -> FoldCallback a+                  -> Handle -- ^ out handle+                  -> (Text -> IO ()) -- ^ in handle+                  -> Bool  -- ^ should it be printed while transfered?+                  -> IO (Async a)+putHandleIntoMVar start cb outH putWrite shouldPrint = liftIO $ async $ do+  if shouldPrint+    then transferFoldHandleLines start cb outH putWrite+    else foldHandleLines start cb outH+++-- | The output of last external command. See 'run'.+lastStderr :: Sh Text+lastStderr = gets sStderr++-- | The exit code from the last command.+-- Unless you set 'errExit' to False you won't get a chance to use this: a non-zero exit code will throw an exception.+lastExitCode :: Sh Int+lastExitCode = gets sCode++-- | set the stdin to be used and cleared by the next 'run'.+setStdin :: Text -> Sh ()+setStdin input = modify $ \st -> st { sStdin = Just input }++-- | Pipe operator. set the stdout the first command as the stdin of the second.+-- This does not create a shell-level pipe, but hopefully it will in the future.+-- To create a shell level pipe you can set @escaping False@ and use a pipe @|@ character in a command.+(-|-) :: Sh Text -> Sh b -> Sh b+one -|- two = do+  res <- print_stdout False one+  setStdin res+  two++-- | Copy a file, or a directory recursively.+-- uses 'cp'+cp_r :: FilePath -> FilePath -> Sh ()+cp_r from' to' = do+    from <- absPath from'+    fromIsDir <- (test_d from)+    if not fromIsDir then cp from' to' else do+       trace $ "cp -r " <> toTextIgnore from <> " " <> toTextIgnore to'+       to <- absPath to'+       toIsDir <- test_d to++       when (from == to) $ liftIO $ throwIO $ userError $ show $ "cp_r: " <>+         toTextIgnore from <> " and " <> toTextIgnore to <> " are identical"++       finalTo <- if not toIsDir then mkdir to >> return to else do+                   let d = to </> dirname (addTrailingSlash from)+                   mkdir_p d >> return d++       ls from >>= mapM_ (\item -> cp_r (from FP.</> filename item) (finalTo FP.</> filename item))++-- | Copy a file. The second path could be a directory, in which case the+-- original file name is used, in that directory.+cp :: FilePath -> FilePath -> Sh ()+cp from' to' = do+  from <- absPath from'+  to <- absPath to'+  trace $ "cp " <> toTextIgnore from <> " " <> toTextIgnore to+  to_dir <- test_d to+  let to_loc = if to_dir then to FP.</> filename from else to+  liftIO $ copyFile from to_loc `catchany` (\e -> throwIO $+      ReThrownException e (extraMsg to_loc from)+    )+  where+    extraMsg t f = "during copy from: " ++ encodeString f ++ " to: " ++ encodeString t++++-- | Create a temporary directory and pass it as a parameter to a Sh+-- computation. The directory is nuked afterwards.+withTmpDir :: (FilePath -> Sh a) -> Sh a+withTmpDir act = do+  trace "withTmpDir"+  dir <- liftIO getTemporaryDirectory+  tid <- liftIO myThreadId+  (pS, fhandle) <- liftIO $ openTempFile dir ("tmp" ++ filter isAlphaNum (show tid))+  let p = pack pS+  liftIO $ hClose fhandle -- required on windows+  rm_f p+  mkdir p+  act p `finally_sh` rm_rf p++-- | Write a Text to a file.+writefile :: FilePath -> Text -> Sh ()+writefile f' bits = do+  f <- traceAbsPath ("writefile " <>) f'+  liftIO (TIO.writeFile (encodeString f) bits)++writeBinary :: FilePath -> ByteString -> Sh ()+writeBinary f' bytes = do+  f <- traceAbsPath ("writeBinary " <>) f'+  liftIO (BS.writeFile (encodeString f) bytes)++-- | Update a file, creating (a blank file) if it does not exist.+touchfile :: FilePath -> Sh ()+touchfile = traceAbsPath ("touch " <>) >=> flip appendfile ""++-- | Append a Text to a file.+appendfile :: FilePath -> Text -> Sh ()+appendfile f' bits = do+  f <- traceAbsPath ("appendfile " <>) f'+  liftIO (TIO.appendFile (encodeString f) bits)++readfile :: FilePath -> Sh Text+readfile = traceAbsPath ("readfile " <>) >=> \fp ->+  readBinary fp >>=+    return . TE.decodeUtf8With TE.lenientDecode++-- | wraps ByteSting readFile+readBinary :: FilePath -> Sh ByteString+readBinary = traceAbsPath ("readBinary " <>)+         >=> liftIO . BS.readFile . encodeString++-- | flipped hasExtension for Text+hasExt :: Text -> FilePath -> Bool+hasExt = flip hasExtension++-- | Run a Sh computation and collect timing information.+--   The value returned is the amount of _real_ time spent running the computation+--   in seconds, as measured by the system clock.+--   The precision is determined by the resolution of `getCurrentTime`.+time :: Sh a -> Sh (Double, a)+time what = sub $ do+  trace "time"+  t <- liftIO getCurrentTime+  res <- what+  t' <- liftIO getCurrentTime+  return (realToFrac $ diffUTCTime t' t, res)++-- | threadDelay wrapper that uses seconds+sleep :: Int -> Sh ()+sleep = liftIO . threadDelay . (1000 * 1000 *)++-- | spawn an asynchronous action with a copy of the current state+asyncSh :: Sh a -> Sh (Async a)+asyncSh proc = do+  state <- get+  liftIO $ async $ shelly (put state >> proc)++-- helper because absPath can throw exceptions+-- This helps give clear tracing messages+tracePath :: (FilePath -> Sh FilePath) -- ^ filepath conversion+          -> (Text -> Text) -- ^ tracing statement+          -> FilePath+          -> Sh FilePath -- ^ converted filepath+tracePath convert tracer infp =+  (convert infp >>= \fp -> traceIt fp >> return fp)+  `catchany_sh` (\e -> traceIt infp >> liftIO (throwIO e))+    where traceIt = trace . tracer . toTextIgnore++traceAbsPath :: (Text -> Text) -> FilePath -> Sh FilePath+traceAbsPath = tracePath absPath++traceCanonicPath :: (Text -> Text) -> FilePath -> Sh FilePath+traceCanonicPath = tracePath canonic
+ shelly/src/Shelly/Base.hs view
@@ -0,0 +1,331 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE InstanceSigs#-}+-- | I started exposing multiple module (starting with one for finding)+-- Base prevented circular dependencies+-- However, Shelly went back to exposing a single module+module Shelly.Base+  (+    Sh(..), ShIO, runSh, State(..), ReadOnlyState(..), StdHandle(..),+    HandleInitializer, StdInit(..),+    FilePath, Text,+    relPath, path, absPath, canonic, canonicalize,+    test_d, test_s,+    unpack, gets, get, modify, trace,+    ls, lsRelAbs,+    toTextIgnore,+    echo, echo_n, echo_err, echo_n_err, inspect, inspect_err,+    catchany,+    liftIO, (>=>),+    eitherRelativeTo, relativeTo, maybeRelativeTo,+    whenM+    -- * utilities not yet exported+    , addTrailingSlash+  ) where++#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 706+import Prelude hiding (FilePath, catch)+#else+import Prelude hiding (FilePath)+#endif++import Data.Text (Text)+import System.Process( StdStream(..) )+import System.IO ( Handle, hFlush, stderr, stdout )++import Control.Monad (when, (>=>))+import Control.Monad.Base+import Control.Monad.Trans.Control+#if !MIN_VERSION_base(4,13,0)+import Control.Applicative (Applicative, (<$>))+#endif+import Filesystem (isDirectory, listDirectory)+import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )+import Filesystem.Path.CurrentOS (FilePath, encodeString, relative)+import qualified Filesystem.Path.CurrentOS as FP+import qualified Filesystem as FS+import Data.IORef (readIORef, modifyIORef, IORef)+#if !MIN_VERSION_base(4,13,0)+import Data.Monoid (mappend)+#endif+import qualified Data.Text as T+import qualified Data.Text.IO as TIO+import Control.Exception (SomeException, catch, throwIO, Exception)+import Data.Maybe (fromMaybe)+import qualified Control.Monad.Catch as Catch+import Control.Monad.Trans ( MonadIO, liftIO )+import Control.Monad.Reader.Class (MonadReader, ask)+import Control.Monad.Trans.Reader (runReaderT, ReaderT(..))+import qualified Data.Set as S+import Data.Typeable (Typeable)++-- | ShIO is Deprecated in favor of 'Sh', which is easier to type.+type ShIO a = Sh a+{-# DEPRECATED ShIO "Use Sh instead of ShIO" #-}++newtype Sh a = Sh {+      unSh :: ReaderT (IORef State) IO a+  } deriving (Applicative, Monad, MonadIO, MonadReader (IORef State), Functor, Catch.MonadMask)++#if MIN_VERSION_base(4,13,0)+instance MonadFail Sh where+  fail = liftIO . fail+#endif++instance MonadBase IO Sh where+    liftBase = Sh . ReaderT . const++instance MonadBaseControl IO Sh where+#if MIN_VERSION_monad_control(1,0,0)+    type StM Sh a = StM (ReaderT (IORef State) IO) a+    liftBaseWith f =+        Sh $ liftBaseWith $ \runInBase -> f $ \k ->+            runInBase $ unSh k+    restoreM = Sh . restoreM+#else+    newtype StM Sh a = StMSh (StM (ReaderT (IORef State) IO) a)+    liftBaseWith f =+        Sh $ liftBaseWith $ \runInBase -> f $ \k ->+            liftM StMSh $ runInBase $ unSh k+    restoreM (StMSh m) = Sh . restoreM $ m+#endif++instance Catch.MonadThrow Sh where+  throwM = liftIO . Catch.throwM++instance Catch.MonadCatch Sh where+  catch (Sh (ReaderT m)) c =+      Sh $ ReaderT $ \r -> m r `Catch.catch` \e -> runSh (c e) r++runSh :: Sh a -> IORef State -> IO a+runSh = runReaderT . unSh++data ReadOnlyState = ReadOnlyState { rosFailToDir :: Bool }+data State = State+   { sCode :: Int -- ^ exit code for command that ran+   , sStdin :: Maybe Text -- ^ stdin for the command to be run+   , sStderr :: Text -- ^ stderr for command that ran+   , sDirectory :: FilePath -- ^ working directory+   , sPutStdout :: Text -> IO ()   -- ^ by default, hPutStrLn stdout+   , sPrintStdout :: Bool   -- ^ print stdout of command that is executed+   , sPutStderr :: Text -> IO ()   -- ^ by default, hPutStrLn stderr+   , sPrintStderr :: Bool   -- ^ print stderr of command that is executed+   , sPrintCommands :: Bool -- ^ print command that is executed+   , sInitCommandHandles :: StdInit -- ^ initializers for the standard process handles+                                    -- when running a command+   , sCommandEscaping :: Bool -- ^ when running a command, escape shell characters such as '*' rather+                              -- than passing to the shell for expansion+   , sEnvironment :: [(String, String)]+   , sPathExecutables :: Maybe [(FilePath, S.Set FilePath)] -- ^ cache of executables in the PATH+   , sTracing :: Bool -- ^ should we trace command execution+   , sTrace :: Text -- ^ the trace of command execution+   , sErrExit :: Bool -- ^ should we exit immediately on any error+   , sReadOnly :: ReadOnlyState+   , sFollowSymlink :: Bool -- ^ 'find'-command follows symlinks.+   }++data StdHandle = InHandle StdStream+               | OutHandle StdStream+               | ErrorHandle StdStream++-- | Initialize a handle before using it+type HandleInitializer = Handle -> IO ()++-- | A collection of initializers for the three standard process handles+data StdInit =+    StdInit {+      inInit :: HandleInitializer,+      outInit :: HandleInitializer,+      errInit :: HandleInitializer+    }++-- | A monadic-conditional version of the "when" guard.+whenM :: Monad m => m Bool -> m () -> m ()+whenM c a = c >>= \res -> when res a++-- | Makes a relative path relative to the current Sh working directory.+-- An absolute path is returned as is.+-- To create an absolute path, use 'absPath'+relPath :: FilePath -> Sh FilePath+relPath fp = do+  wd  <- gets sDirectory+  rel <- eitherRelativeTo wd fp+  return $ case rel of+    Right p -> p+    Left  p -> p++eitherRelativeTo :: FilePath -- ^ anchor path, the prefix+                 -> FilePath -- ^ make this relative to anchor path+                 -> Sh (Either FilePath FilePath) -- ^ Left is canonic of second path+eitherRelativeTo relativeFP fp = do+  let fullFp = relativeFP FP.</> fp+  let relDir = addTrailingSlash relativeFP+  stripIt relativeFP fp $+    stripIt relativeFP fullFp $+      stripIt relDir fp $+        stripIt relDir fullFp $ do+          relCan <- canonic relDir+          fpCan  <- canonic fullFp+          stripIt relCan fpCan $ return $ Left fpCan+  where+    stripIt rel toStrip nada =+      case FP.stripPrefix rel toStrip of+        Just stripped ->+          if stripped == toStrip then nada+            else return $ Right stripped+        Nothing -> nada++-- | make the second path relative to the first+-- Uses 'Filesystem.stripPrefix', but will canonicalize the paths if necessary+relativeTo :: FilePath -- ^ anchor path, the prefix+           -> FilePath -- ^ make this relative to anchor path+           -> Sh FilePath+relativeTo relativeFP fp =+  fmap (fromMaybe fp) $ maybeRelativeTo relativeFP fp++maybeRelativeTo :: FilePath -- ^ anchor path, the prefix+                 -> FilePath -- ^ make this relative to anchor path+                 -> Sh (Maybe FilePath)+maybeRelativeTo relativeFP fp = do+  epath <- eitherRelativeTo relativeFP fp+  return $ case epath of+             Right p -> Just p+             Left _ -> Nothing+++-- | add a trailing slash to ensure the path indicates a directory+addTrailingSlash :: FilePath -> FilePath+addTrailingSlash p =+  if FP.null (FP.filename p) then p else+    p FP.</> FP.empty++-- | makes an absolute path.+-- Like 'canonicalize', but on an exception returns 'absPath'+canonic :: FilePath -> Sh FilePath+canonic fp = do+  p <- absPath fp+  liftIO $ canonicalizePath p `catchany` \_ -> return p++-- | Obtain a (reasonably) canonic file path to a filesystem object. Based on+-- "canonicalizePath" in system-fileio.+canonicalize :: FilePath -> Sh FilePath+canonicalize = absPath >=> liftIO . canonicalizePath++-- | bugfix older version of canonicalizePath (system-fileio <= 0.3.7) loses trailing slash+canonicalizePath :: FilePath -> IO FilePath+canonicalizePath p = let was_dir = FP.null (FP.filename p) in+   if not was_dir then FS.canonicalizePath p+     else addTrailingSlash `fmap` FS.canonicalizePath p++data EmptyFilePathError = EmptyFilePathError deriving Typeable+instance Show EmptyFilePathError where+    show _ = "Empty filepath"+instance Exception EmptyFilePathError++-- | Make a relative path absolute by combining with the working directory.+-- An absolute path is returned as is.+-- To create a relative path, use 'relPath'.+absPath :: FilePath -> Sh FilePath+absPath p | FP.null p = liftIO $ throwIO EmptyFilePathError+          | relative p = (FP.</> p) <$> gets sDirectory+          | otherwise = return p++-- | deprecated+path :: FilePath -> Sh FilePath+path = absPath+{-# DEPRECATED path "use absPath, canonic, or relPath instead" #-}++-- | Does a path point to an existing directory?+test_d :: FilePath -> Sh Bool+test_d = absPath >=> liftIO . isDirectory++-- | Does a path point to a symlink?+test_s :: FilePath -> Sh Bool+test_s = absPath >=> liftIO . \f -> do+  stat <- getSymbolicLinkStatus (encodeString f)+  return $ isSymbolicLink stat++unpack :: FilePath -> String+unpack = encodeString++gets :: (State -> a) -> Sh a+gets f = f <$> get++get :: Sh State+get = do+  stateVar <- ask+  liftIO (readIORef stateVar)++modify :: (State -> State) -> Sh ()+modify f = do+  state <- ask+  liftIO (modifyIORef state f)++-- | internally log what occurred.+-- Log will be re-played on failure.+trace :: Text -> Sh ()+trace msg =+  whenM (gets sTracing) $ modify $+    \st -> st { sTrace = sTrace st `mappend` msg `mappend` "\n" }++-- | List directory contents. Does *not* include \".\" and \"..\", but it does+-- include (other) hidden files.+ls :: FilePath -> Sh [FilePath]+-- it is important to use path and not absPath so that the listing can remain relative+ls fp = do+  trace $ "ls " `mappend` toTextIgnore fp+  fmap fst $ lsRelAbs fp++lsRelAbs :: FilePath -> Sh ([FilePath], [FilePath])+lsRelAbs f = absPath f >>= \fp -> do+  filt <- if not (relative f) then return return+             else do+               wd <- gets sDirectory+               return (relativeTo wd)+  absolute <- liftIO $ listDirectory fp+  relativized <- mapM filt absolute+  return (relativized, absolute)++-- | silently uses the Right or Left value of "Filesystem.Path.CurrentOS.toText"+toTextIgnore :: FilePath -> Text+toTextIgnore fp = case FP.toText fp of+                    Left  f -> f+                    Right f -> f++-- | a print lifted into 'Sh'+inspect :: (Show s) => s -> Sh ()+inspect x = do+  (trace . T.pack . show) x+  liftIO $ print x++-- | a print lifted into 'Sh' using stderr+inspect_err :: (Show s) => s -> Sh ()+inspect_err x = do+  let shown = T.pack $ show x+  trace shown+  echo_err shown++-- | Echo text to standard (error, when using _err variants) output. The _n+-- variants do not print a final newline.+echo, echo_n, echo_err, echo_n_err :: Text -> Sh ()+echo       msg = traceEcho msg >> liftIO (TIO.putStrLn msg >> hFlush stdout)+echo_n     msg = traceEcho msg >> liftIO (TIO.putStr msg >> hFlush stdout)+echo_err   msg = traceEcho msg >> liftIO (TIO.hPutStrLn stderr msg >> hFlush stdout)+echo_n_err msg = traceEcho msg >> liftIO (TIO.hPutStr stderr msg >> hFlush stderr)++traceEcho :: Text -> Sh ()+traceEcho msg = trace ("echo " `mappend` "'" `mappend` msg `mappend` "'")++-- | A helper to catch any exception (same as+-- @... `catch` \(e :: SomeException) -> ...@).+catchany :: IO a -> (SomeException -> IO a) -> IO a+catchany = catch+
+ shelly/src/Shelly/Find.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+-- | File finding utiliites for Shelly+-- The basic 'find' takes a dir and gives back a list of files.+-- If you don't just want a list, use the folding variants like 'findFold'.+-- If you want to avoid traversing certain directories, use the directory filtering variants like 'findDirFilter'+module Shelly.Find+ (+   find, findWhen, findFold, findDirFilter, findDirFilterWhen, findFoldDirFilter+ ) where++import Prelude hiding (FilePath)+import Shelly.Base+import Control.Monad (foldM)+#if !MIN_VERSION_base(4,13,0)+import Data.Monoid (mappend)+#endif+import System.PosixCompat.Files( getSymbolicLinkStatus, isSymbolicLink )+import Filesystem (isDirectory)+import Filesystem.Path.CurrentOS (encodeString)++-- | List directory recursively (like the POSIX utility "find").+-- listing is relative if the path given is relative.+-- If you want to filter out some results or fold over them you can do that with the returned files.+-- A more efficient approach is to use one of the other find functions.+find :: FilePath -> Sh [FilePath]+find = findFold (\paths fp -> return $ paths ++ [fp]) []++-- | 'find' that filters the found files as it finds.+-- Files must satisfy the given filter to be returned in the result.+findWhen :: (FilePath -> Sh Bool) -> FilePath -> Sh [FilePath]+findWhen = findDirFilterWhen (const $ return True)++-- | Fold an arbitrary folding function over files froma a 'find'.+-- Like 'findWhen' but use a more general fold rather than a filter.+findFold :: (a -> FilePath -> Sh a) -> a -> FilePath -> Sh a+findFold folder startValue = findFoldDirFilter folder startValue (const $ return True)++-- | 'find' that filters out directories as it finds+-- Filtering out directories can make a find much more efficient by avoiding entire trees of files.+findDirFilter :: (FilePath -> Sh Bool) -> FilePath -> Sh [FilePath]+findDirFilter filt = findDirFilterWhen filt (const $ return True)++-- | similar 'findWhen', but also filter out directories+-- Alternatively, similar to 'findDirFilter', but also filter out files+-- Filtering out directories makes the find much more efficient+findDirFilterWhen :: (FilePath -> Sh Bool) -- ^ directory filter+                  -> (FilePath -> Sh Bool) -- ^ file filter+                  -> FilePath -- ^ directory+                  -> Sh [FilePath]+findDirFilterWhen dirFilt fileFilter = findFoldDirFilter filterIt [] dirFilt+  where+    filterIt paths fp = do+      yes <- fileFilter fp+      return $ if yes then paths ++ [fp] else paths++-- | like 'findDirFilterWhen' but use a folding function rather than a filter+-- The most general finder: you likely want a more specific one+findFoldDirFilter :: (a -> FilePath -> Sh a) -> a -> (FilePath -> Sh Bool) -> FilePath -> Sh a+findFoldDirFilter folder startValue dirFilter dir = do+  absDir <- absPath dir+  trace ("find " `mappend` toTextIgnore absDir)+  filt <- dirFilter absDir+  if not filt then return startValue+    -- use possible relative path, not absolute so that listing will remain relative+    else do+      (rPaths, aPaths) <- lsRelAbs dir +      foldM traverse' startValue (zip rPaths aPaths)+  where+    traverse' acc (relativePath, absolutePath) = do+      -- optimization: don't use Shelly API since our path is already good+      isDir <- liftIO $ isDirectory absolutePath+      sym   <- liftIO $ fmap isSymbolicLink $ getSymbolicLinkStatus (encodeString absolutePath)+      newAcc <- folder acc relativePath+      follow <- fmap sFollowSymlink get+      if isDir && (follow || not sym)+        then findFoldDirFilter folder newAcc +                dirFilter relativePath+        else return newAcc
− src/ByteStringUtils.hs 
@@ -1,547 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE BangPatterns, ForeignFunctionInterface, CPP, ScopedTypeVariables #-}---------------------------------------------------------------------------------- |--- Module      :  ByteStringUtils--- Copyright   :  (c) The University of Glasgow 2001,---                    David Roundy 2003-2005--- License : GPL (I'm happy to also license this file BSD style but don't---           want to bother distributing two license files with darcs.------ Maintainer  :  droundy@abridgegame.org--- Stability   :  experimental--- Portability :  portable------ GZIp and MMap IO for ByteStrings, encoding utilities, and miscellaneous--- functions for Data.ByteString-----module ByteStringUtils (--        unsafeWithInternals,-        unpackPSFromUTF8,-        packStringToUTF8,--        -- IO with mmap or gzip-        gzReadFilePS,-        mmapFilePS,-        gzWriteFilePS,-        gzWriteFilePSs,-        gzReadStdin,--        -- gzip handling-        isGZFile,-        gzDecompress,--        -- list utilities-        dropSpace,-        breakSpace,-        linesPS,-        unlinesPS,-        hashPS,-        breakFirstPS,-        breakLastPS,-        substrPS,-        readIntPS,-        isFunky,-        fromHex2PS,-        fromPS2Hex,-        betweenLinesPS,-        breakAfterNthNewline,-        breakBeforeNthNewline,-        intercalate,--        -- encoding and unicode utilities-        isAscii,-        decodeLocale,-        encodeLocale,-        decodeString-    ) where--import Prelude hiding ( catch )-import qualified Data.ByteString            as B-import qualified Data.ByteString.Char8      as BC-import qualified Data.ByteString.Internal   as BI-import Data.ByteString (intercalate)-import Data.ByteString.Internal (fromForeignPtr)--#if defined (HAVE_MMAP)-import Control.Exception.Extensible ( catch, SomeException )-#endif-import System.IO-import System.IO.Unsafe         ( unsafePerformIO )--import Encoding ( decode, encode )--import Foreign.Storable         ( peekElemOff, peek )-import Foreign.Marshal.Array    ( advancePtr )-import Foreign.C.Types          ( CInt(..) )--import Data.Bits                ( rotateL )-import Data.Char                ( ord, isSpace )-import Data.Word                ( Word8 )-import Data.Int                 ( Int32 )-import qualified Data.Text as T ( pack, unpack )-import Data.Text.Encoding       ( encodeUtf8, decodeUtf8With )-import Data.Text.Encoding.Error ( lenientDecode )-import Control.Monad            ( when )--import Foreign.Ptr              ( plusPtr, Ptr )-import Foreign.ForeignPtr       ( withForeignPtr )--#ifdef DEBUG_PS-import Foreign.ForeignPtr       ( addForeignPtrFinalizer )-import Foreign.Ptr              ( FunPtr )-#endif--import qualified Data.ByteString.Lazy as BL-import qualified Codec.Compression.GZip as GZ-import qualified Codec.Compression.Zlib.Internal as ZI-import Darcs.Global ( addCRCWarning )--#ifdef HAVE_MMAP-import System.IO.MMap( mmapFileByteString )-import System.Mem( performGC )-import System.Posix.Files( fileSize, getSymbolicLinkStatus )-#endif---- -------------------------------------------------------------------------------- obsolete debugging code---- -------------------------------------------------------------------------------- unsafeWithInternals---- | Do something with the internals of a PackedString. Beware of--- altering the contents!-unsafeWithInternals :: B.ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a-unsafeWithInternals ps f- = case BI.toForeignPtr ps of-   (fp,s,l) -> withForeignPtr fp $ \p -> f (p `plusPtr` s) l---- | readIntPS skips any whitespace at the beginning of its argument, and--- reads an Int from the beginning of the PackedString.  If there is no--- integer at the beginning of the string, it returns Nothing, otherwise it--- just returns the int read, along with a B.ByteString containing the--- remainder of its input.--readIntPS :: B.ByteString -> Maybe (Int, B.ByteString)-readIntPS = BC.readInt . BC.dropWhile isSpace---- -------------------------------------------------------------------------------- Destructor functions (taking PackedStrings apart)---- | Decodes a 'ByteString' containing UTF-8 to a 'String'. Decoding errors are---   flagged with the U+FFFD character.-unpackPSFromUTF8 :: B.ByteString -> String-unpackPSFromUTF8  = T.unpack . decodeUtf8With lenientDecode--packStringToUTF8 :: String -> B.ByteString-packStringToUTF8 = encodeUtf8 . T.pack----------------------------------------------------------------------------- A reimplementation of Data.ByteString.Char8.dropSpace, but--- specialised to darcs' need for a 4 way isspace.------ TODO: if it is safe to use the expanded definition of isSpaceWord8--- provided by Data.ByteString.Char8, then all this can go.---- A locale-independent isspace(3) so patches are interpreted the same everywhere.--- ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r')-isSpaceWord8 :: Word8 -> Bool-isSpaceWord8 w =-    w == 0x20 ||    -- ' '-    w == 0x09 ||    -- '\t'-    w == 0x0A ||    -- '\n'-    w == 0x0D       -- '\r'-{-# INLINE isSpaceWord8 #-}--firstnonspace :: Ptr Word8 -> Int -> Int -> IO Int-firstnonspace !ptr !n !m-    | n >= m    = return n-    | otherwise = do w <- peekElemOff ptr n-                     if isSpaceWord8 w then firstnonspace ptr (n+1) m else return n--firstspace :: Ptr Word8 -> Int -> Int -> IO Int-firstspace !ptr !n !m-    | n >= m    = return n-    | otherwise = do w <- peekElemOff ptr n-                     if (not . isSpaceWord8) w then firstspace ptr (n+1) m else return n---- | 'dropSpace' efficiently returns the 'ByteString' argument with--- white space Chars removed from the front. It is more efficient than--- calling dropWhile for removing whitespace. I.e.------ > dropWhile isSpace == dropSpace----dropSpace :: B.ByteString -> B.ByteString-dropSpace (BI.PS x s l) = BI.inlinePerformIO $ withForeignPtr x $ \p -> do-    i <- firstnonspace (p `plusPtr` s) 0 l-    return $! if i == l then B.empty else BI.PS x (s+i) (l-i)-{-# INLINE dropSpace #-}---- | 'breakSpace' returns the pair of ByteStrings when the argument is--- broken at the first whitespace byte. I.e.------ > break isSpace == breakSpace----breakSpace :: B.ByteString -> (B.ByteString,B.ByteString)-breakSpace (BI.PS x s l) = BI.inlinePerformIO $ withForeignPtr x $ \p -> do-    i <- firstspace (p `plusPtr` s) 0 l-    return $! case () of {_-        | i == 0    -> (B.empty, BI.PS x s l)-        | i == l    -> (BI.PS x s l, B.empty)-        | otherwise -> (BI.PS x s i, BI.PS x (s+i) (l-i))-    }-{-# INLINE breakSpace #-}----------------------------------------------------------------------------{-# INLINE isFunky #-}-isFunky :: B.ByteString -> Bool-isFunky ps = case BI.toForeignPtr ps of-   (x,s,l) ->-    unsafePerformIO $ withForeignPtr x $ \p->-    (/=0) `fmap` has_funky_char (p `plusPtr` s) (fromIntegral l)--foreign import ccall unsafe "fpstring.h has_funky_char" has_funky_char-    :: Ptr Word8 -> CInt -> IO CInt------------------------------------------------------------------------------ ByteString rewrites break (=='x') to breakByte 'x'---  break ((==) x) = breakChar x---  break (==x) = breakChar x-----{--{-# INLINE breakOnPS #-}-breakOnPS :: Char -> B.ByteString -> (B.ByteString, B.ByteString)-breakOnPS c p = case BC.elemIndex c p of-                Nothing -> (p, BC.empty)-                Just n  -> (B.take n p, B.drop n p)--}--{-# INLINE hashPS #-}-hashPS :: B.ByteString -> Int32-hashPS ps =-   case BI.toForeignPtr ps of-   (x,s,l) ->-    unsafePerformIO $ withForeignPtr x $ \p->-    hash (p `plusPtr` s) l--hash :: Ptr Word8 -> Int -> IO Int32-hash ptr len = f (0 :: Int32) ptr len- where f h _ 0 = return h-       f h p n = do x <- peek p-                    let !h' =  (fromIntegral x) + (rotateL h 8)-                    f h' (p `advancePtr` 1) (n-1)--{-# INLINE substrPS #-}-substrPS :: B.ByteString -> B.ByteString -> Maybe Int-substrPS tok str-    | B.null tok = Just 0-    | B.length tok > B.length str = Nothing-    | otherwise = do n <- BC.elemIndex (BC.head tok) str-                     let ttok = B.tail tok-                         reststr = B.drop (n+1) str-                     if ttok == B.take (B.length ttok) reststr-                        then Just n-                        else ((n+1)+) `fmap` substrPS tok reststr------------------------------------------------------------------------------ TODO: replace breakFirstPS and breakLastPS with definitions based on--- ByteString's break/breakEnd-{-# INLINE breakFirstPS #-}-breakFirstPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)-breakFirstPS c p = case BC.elemIndex c p of-                   Nothing -> Nothing-                   Just n -> Just (B.take n p, B.drop (n+1) p)--{-# INLINE breakLastPS #-}-breakLastPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)-breakLastPS c p = case BC.elemIndexEnd c p of-                  Nothing -> Nothing-                  Just n -> Just (B.take n p, B.drop (n+1) p)---- TODO: rename-{-# INLINE linesPS #-}-linesPS :: B.ByteString -> [B.ByteString]-linesPS ps-     | B.null ps = [B.empty]-     | otherwise = BC.split '\n' ps--{- QuickCheck property:--import Test.QuickCheck-import qualified Data.ByteString.Char8 as BC-import Data.Char-instance Arbitrary BC.ByteString where-    arbitrary = fmap BC.pack arbitrary-instance Arbitrary Char where-  arbitrary = chr `fmap` choose (32,127)-deepCheck = check (defaultConfig { configMaxTest = 10000})-testLines =  deepCheck (\x -> (linesPS x == linesPSOld x))-linesPSOld ps = case  BC.elemIndex '\n' ps of-             Nothing -> [ps]-             Just n -> B.take n ps : linesPS (B.drop (n+1) ps) -}--{-| This function acts exactly like the "Prelude" unlines function, or like-"Data.ByteString.Char8" 'unlines', but with one important difference: it will-produce a string which may not end with a newline! That is:--> unlinesPS ["foo", "bar"]--evaluates to \"foo\\nbar\", not \"foo\\nbar\\n\"! This point should hold true for-'linesPS' as well.--TODO: rename this function. -}-unlinesPS :: [B.ByteString] -> B.ByteString-unlinesPS [] = BC.empty-unlinesPS x  = BC.init $ BC.unlines x-{-# INLINE unlinesPS #-}-{- QuickCheck property:--testUnlines = deepCheck (\x -> (unlinesPS x == unlinesPSOld x))-unlinesPSOld ss = BC.concat $ intersperse_newlines ss-    where intersperse_newlines (a:b:s) = a : newline : intersperse_newlines (b:s)-          intersperse_newlines s = s-          newline = BC.pack "\n" -}---- -------------------------------------------------------------------------------- gzReadFilePS---- |Decompress the given bytestring into a lazy list of chunks, along with a boolean--- flag indicating (if True) that the CRC was corrupted.--- Inspecting the flag will cause the entire list of chunks to be evaluated (but if--- you throw away the list immediately this should run in constant space).-gzDecompress :: Maybe Int -> BL.ByteString -> ([B.ByteString], Bool)-gzDecompress mbufsize =-    -- This is what the code would be without the bad CRC recovery logic:-    -- return . BL.toChunks . GZ.decompressWith decompressParams-    toListWarn . ZI.decompressWithErrors ZI.gzipFormat decompressParams-  where-        decompressParams = case mbufsize of-                              Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize }-                              Nothing -> GZ.defaultDecompressParams--        toListWarn :: ZI.DecompressStream -> ([B.ByteString], Bool)-        toListWarn = foldDecompressStream (\x ~(xs, b) -> (x:xs, b)) ([], False) handleBad--        -- cut and paste from Zlib since it's not currently exported (interface not yet certain)-        foldDecompressStream :: (B.ByteString -> a -> a) -> a-                             -> (ZI.DecompressError -> String -> a)-                             -> ZI.DecompressStream -> a-        foldDecompressStream chunk end err = fold-                   where-                       fold ZI.StreamEnd               = end-                       fold (ZI.StreamChunk bs stream) = chunk bs (fold stream)-                       fold (ZI.StreamError code msg)  = err code msg--        -- For a while a bug in darcs caused gzip files with good data but bad CRCs to be-        -- produced. Trap bad CRC messages, run the specified action to report that it happened,-        -- but continue on the assumption that the data is valid.-        handleBad ZI.DataError "incorrect data check" = ([], True)-        handleBad _ msg = error msg--isGZFile :: FilePath -> IO (Maybe Int)-isGZFile f = do-    h <- openBinaryFile f ReadMode-    header <- B.hGet h 2-    if header /= BC.pack "\31\139"-       then do hClose h-               return Nothing-       else do hSeek h SeekFromEnd (-4)-               len <- hGetLittleEndInt h-               hClose h-               return (Just len)---- | Read an entire file, which may or may not be gzip compressed, directly--- into a 'B.ByteString'.-gzReadFilePS :: FilePath -> IO B.ByteString-gzReadFilePS f = do-    mlen <- isGZFile f-    case mlen of-       Nothing -> mmapFilePS f-       Just len ->-            do -- Passing the length to gzDecompress means that it produces produces one chunk,-               -- which in turn means that B.concat won't need to copy data.-               -- If the length is wrong this will just affect efficiency, not correctness-               let doDecompress buf = let (res, bad) = gzDecompress (Just len) buf-                                      in do when bad $ addCRCWarning f-                                            return res-               compressed <- (BL.fromChunks . return) `fmap` mmapFilePS f-               B.concat `fmap` doDecompress compressed--hGetLittleEndInt :: Handle -> IO Int-hGetLittleEndInt h = do-    b1 <- ord `fmap` hGetChar h-    b2 <- ord `fmap` hGetChar h-    b3 <- ord `fmap` hGetChar h-    b4 <- ord `fmap` hGetChar h-    return $ b1 + 256*b2 + 65536*b3 + 16777216*b4--gzWriteFilePS :: FilePath -> B.ByteString -> IO ()-gzWriteFilePS f ps = gzWriteFilePSs f [ps]--gzWriteFilePSs :: FilePath -> [B.ByteString] -> IO ()-gzWriteFilePSs f pss  =-    BL.writeFile f $ GZ.compress $ BL.fromChunks pss---- | Read standard input, which may or may not be gzip compressed, directly--- into a 'B.ByteString'.-gzReadStdin :: IO B.ByteString-gzReadStdin = do header <- B.hGet stdin 2-                 rest   <- B.hGetContents stdin-                 let allStdin = B.concat [header,rest]-                 return $-                  if header /= BC.pack "\31\139"-                   then allStdin-                   else let decompress = fst . gzDecompress Nothing-                            compressed = BL.fromChunks [allStdin]-                        in-                        B.concat $ decompress compressed---- -------------------------------------------------------------------------------- mmapFilePS---- | Like readFilePS, this reads an entire file directly into a--- 'B.ByteString', but it is even more efficient.  It involves directly--- mapping the file to memory.  This has the advantage that the contents of--- the file never need to be copied.  Also, under memory pressure the page--- may simply be discarded, wile in the case of readFilePS it would need to--- be written to swap.  If you read many small files, mmapFilePS will be--- less memory-efficient than readFilePS, since each mmapFilePS takes up a--- separate page of memory.  Also, you can run into bus errors if the file--- is modified.  NOTE: as with 'readFilePS', the string representation in--- the file is assumed to be ISO-8859-1.--mmapFilePS :: FilePath -> IO B.ByteString-#ifdef HAVE_MMAP-mmapFilePS f = do-  x <- mmapFileByteString f Nothing-   `catch` (\(_ :: SomeException) -> do-                     size <- fileSize `fmap` getSymbolicLinkStatus f-                     if size == 0-                        then return B.empty-                        else performGC >> mmapFileByteString f Nothing)-  return x-#else-mmapFilePS = B.readFile-#endif---- ---------------------------------------------------------------------------- fromPS2Hex--foreign import ccall unsafe "static fpstring.h conv_to_hex" conv_to_hex-    :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()--fromPS2Hex :: B.ByteString -> B.ByteString-fromPS2Hex ps = case BI.toForeignPtr ps of-          (x,s,l) ->-           BI.unsafeCreate (2*l) $ \p -> withForeignPtr x $ \f ->-           conv_to_hex p (f `plusPtr` s) $ fromIntegral l---- ---------------------------------------------------------------------------- fromHex2PS--foreign import ccall unsafe "static fpstring.h conv_from_hex" conv_from_hex-    :: Ptr Word8 -> Ptr Word8 -> CInt -> IO ()--fromHex2PS :: B.ByteString -> B.ByteString-fromHex2PS ps = case BI.toForeignPtr ps of-          (x,s,l) ->-           BI.unsafeCreate (l `div` 2) $ \p -> withForeignPtr x $ \f ->-           conv_from_hex p (f `plusPtr` s) (fromIntegral $ l `div` 2)---- ---------------------------------------------------------------------------- betweenLinesPS---- | betweenLinesPS returns the B.ByteString between the two lines given,--- or Nothing if they do not appear.--betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString-               -> Maybe (B.ByteString)-betweenLinesPS start end ps- = case break (start ==) (linesPS ps) of-       (_, _:rest@(bs1:_)) ->-           case BI.toForeignPtr bs1 of-            (ps1,s1,_) ->-             case break (end ==) rest of-               (_, bs2:_) -> case BI.toForeignPtr bs2 of (_,s2,_) -> Just $ fromForeignPtr ps1 s1 (s2 - s1)-               _ -> Nothing-       _ -> Nothing---- ---------------------------------------------------------------------------- breakAfterNthNewline--breakAfterNthNewline :: Int -> B.ByteString-                        -> Maybe (B.ByteString, B.ByteString)-breakAfterNthNewline 0 the_ps | B.null the_ps = Just (B.empty, B.empty)-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---- ---------------------------------------------------------------------------- breakBeforeNthNewline--breakBeforeNthNewline :: Int -> B.ByteString -> (B.ByteString, B.ByteString)-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---- | Test if a ByteString is made of ascii characters-isAscii :: B.ByteString -> Bool-isAscii = B.all (\w -> w < 128)---- | Decode a ByteString to a String according to the current locale--- unsafePerformIO in the locale function is ratified by the fact that GHC 6.12--- and above also supply locale conversion with functions with a pure type.--- Unrecognized byte sequences in the input are skipped.-decodeLocale :: B.ByteString -> String-decodeLocale = unsafePerformIO . decode---- | Encode a String to a ByteString with latin1 (i.e., the values of the--- characters become the values of the bytes; if a character value is greater--- than 255, its byte becomes the character value modulo 256)-encodeLatin1 :: String -> B.ByteString-encodeLatin1 = B.pack . (map (fromIntegral . ord))---- | Encode a String to a ByteString according to the current locale-encodeLocale :: String -> B.ByteString-encodeLocale = unsafePerformIO . encode---- | Take a @String@ that represents byte values and re-decode it acording to--- the current locale.-decodeString :: String -> String-decodeString = decodeLocale . encodeLatin1--
− src/CommandLine.hs 
@@ -1,140 +0,0 @@--- Copyright (C) 2005 Benedikt Schmidt------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- |--- Module      : CommandLine--- Copyright   : 2005 Benedikt Schmidt--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable------ |A parser for commandlines, returns an arg list and expands--- format strings given in a translation table. Additionally--- the commandline can end with "%<" specifying that the command--- expects input on stdin.------ Some tests for the parser.------ > formatTable = [('s',"<insert subject here>"),--- >                ('a',"<insert author here>")]--- >--- > testParser :: (Show a, Eq a) => Parser a -> String -> a -> a--- > testParser p s ok = case parse p "" s of--- >                     Left e -> error $ "Parser failed with: " ++ (show e)--- >                     Right res -> if res == ok--- >                                  then res--- >                                  else error $ "Parser failed: got "--- >                                         ++ (show res) ++ ", expected "--- >                                         ++ (show ok)--- >--- > testCases = [("a b",(["a","b"], False)),--- >              ("a b %<",(["a","b"], True)),--- >              ("a b %< ",(["a","b"], True)),--- >              ("\"arg0 contains spaces \\\"quotes\\\"\" b",--- >               (["arg0 contains spaces \"quotes\"","b"],False)),--- >              ("a %s %<",(["a","<insert subject here>"], True))]--- >--- > runTests = map (uncurry $ testParser (commandline formatTable)) testCases--module CommandLine-    ( parseCmd-    , addUrlencoded-    ) where--import Control.Arrow ( (***) )-import Data.Char ( ord, intToDigit, toUpper )-import Data.List ( find )-import Text.ParserCombinators.Parsec---- | assoc list mapping characters to strings--- eg (c,s) means that %c is replaced by s-type FTable = [(Char,String)]--commandline :: FTable -> Parser ([String], Bool)-commandline ftable = consumeAll $ do-    l <- sepEndBy1 (arg ftable) (try separator)-    redir <- formatRedir-    spaces-    return (l,redir)--arg :: FTable -> Parser String-arg ftable = quotedArg ftable <|> unquotedArg ftable--unquotedArg :: FTable -> Parser String-unquotedArg ftable = try (format ftable) <|> many1 (noneOf " \t\"%")--quotedArg :: FTable -> Parser String-quotedArg ftable = between quoteChar quoteChar $ quoteContent ftable-  where-    quoteChar = char '"'--quoteContent :: FTable -> Parser String-quoteContent ftable = do s1 <- escape-                               <|> try (format ftable)-                               <|> many1 (noneOf "\"\\%")-                         s2 <- quoteContent ftable-                         return $ s1 ++ s2-                     <|> return ""--formatRedir :: Parser Bool-formatRedir = (string "%<" >> return True)-              <|> return False--format :: FTable -> Parser String-format ftable = do _ <- char '%'-                   c <- oneOf (map fst ftable)-                   return $ expandFormat ftable c--escape :: Parser String-escape = do _ <- char '\\'-            c <- anyChar-            return [c]--consumeAll :: Parser a -> Parser a-consumeAll p = do r <- p-                  eof-                  return r--separator :: Parser ()-separator = skipMany1 space--expandFormat :: FTable -> Char -> String-expandFormat ftable c = case find ((==c) . fst) ftable of-                            Just (_,s) -> s-                            Nothing -> error "impossible"---- | parse a commandline returning a list of strings--- (intended to be used as argv) and a bool value which--- specifies if the command expects input on stdin--- format specifiers with a mapping in ftable are accepted--- and replaced by the given strings. E.g. if the ftable is--- [('s',"Some subject")], then "%s" is replaced by "Some subject"-parseCmd :: FTable -> String -> Either ParseError ([String],Bool)-parseCmd ftable = parse (commandline ftable) ""--urlEncode :: String -> String-urlEncode s = concatMap escapeC s-    where escapeC x = if allowed x then [x] else '%' : intToHex (ord x)-          intToHex i = map intToDigit [i `div` 16, i `mod` 16]-          allowed x = x `elem` allowedChars-          allowedChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "!'()*-.~"---- | for every mapping (c,s), add a mapping with uppercase c--- and the urlencoded string s-addUrlencoded :: FTable -> FTable-addUrlencoded ftable = ftable ++ map (toUpper *** urlEncode) ftable
− src/Crypt/SHA256.hs 
@@ -1,45 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---- |--- Module:    Data.Digest.SHA256--- Copyright: Zooko O'Whielacronx--- License:   GPL------ Stability: experimental---- ByteString-based, zero-copying binding to Crypto++'s sha interface---- thanks to Don Stewart <dons@galois.com>, Matthew Sackman--- <matthew@wellquite.org>, Brian O'Sullivan, lispy, Adam Langley--module Crypt.SHA256 ( sha256sum ) where--import Foreign hiding ( unsafePerformIO )-import Foreign.C.Types-import Numeric (showHex)-import Foreign.C.String ( withCString )-import Data.ByteString.Unsafe (unsafeUseAsCStringLen)-import qualified Data.ByteString as B-import System.IO.Unsafe ( unsafePerformIO )--sha256sum :: B.ByteString -> String-sha256sum p = unsafePerformIO $-              withCString (take 64 $ repeat 'x') $ \digestCString ->-              unsafeUseAsCStringLen p $ \(ptr,n) ->-              do let digest = castPtr digestCString :: Ptr Word8-                 c_sha256 ptr (fromIntegral n) digest-                 go digest 0 []-  where -- print it in 0-padded hex format-        go :: Ptr Word8 -> Int -> [String] -> IO String-        go q n acc | seq q n >= 32 = return $ concat (reverse acc)-                   | otherwise = do w <- peekElemOff q n-                                    go q (n+1) (draw w : acc)-        draw w = case showHex w [] of-                 [x] -> ['0', x]-                 x   -> x---- void sha256sum(const unsigned char *d, size_t n, unsigned char *md);----foreign import ccall unsafe "sha2.h darcs_sha256" c_sha256-    :: Ptr CChar -> CSize -> Ptr Word8 -> IO ()-
− src/Crypt/sha2.c 
@@ -1,949 +0,0 @@-/*- * FIPS 180-2 SHA-224/256/384/512 implementation- * Last update: 02/02/2007- * Issue date:  04/30/2005- *- * Copyright (C) 2005, 2007 Olivier Gay <olivier.gay@a3.epfl.ch>- * All rights reserved.- *- * Redistribution and use in source and binary forms, with or without- * modification, are permitted provided that the following conditions- * are met:- * 1. Redistributions of source code must retain the above copyright- *    notice, this list of conditions and the following disclaimer.- * 2. Redistributions in binary form must reproduce the above copyright- *    notice, this list of conditions and the following disclaimer in the- *    documentation and/or other materials provided with the distribution.- * 3. Neither the name of the project nor the names of its contributors- *    may be used to endorse or promote products derived from this software- *    without specific prior written permission.- *- * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE- * ARE DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS- * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)- * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY- * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF- * SUCH DAMAGE.- */--#if 0-#define UNROLL_LOOPS /* Enable loops unrolling */-#endif--#include <string.h>--#include "sha2.h"--#define SHFR(x, n)    (x >> n)-#define ROTR(x, n)   ((x >> n) | (x << ((sizeof(x) << 3) - n)))-#define ROTL(x, n)   ((x << n) | (x >> ((sizeof(x) << 3) - n)))-#define CH(x, y, z)  ((x & y) ^ (~x & z))-#define MAJ(x, y, z) ((x & y) ^ (x & z) ^ (y & z))--#define SHA256_F1(x) (ROTR(x,  2) ^ ROTR(x, 13) ^ ROTR(x, 22))-#define SHA256_F2(x) (ROTR(x,  6) ^ ROTR(x, 11) ^ ROTR(x, 25))-#define SHA256_F3(x) (ROTR(x,  7) ^ ROTR(x, 18) ^ SHFR(x,  3))-#define SHA256_F4(x) (ROTR(x, 17) ^ ROTR(x, 19) ^ SHFR(x, 10))--#define SHA512_F1(x) (ROTR(x, 28) ^ ROTR(x, 34) ^ ROTR(x, 39))-#define SHA512_F2(x) (ROTR(x, 14) ^ ROTR(x, 18) ^ ROTR(x, 41))-#define SHA512_F3(x) (ROTR(x,  1) ^ ROTR(x,  8) ^ SHFR(x,  7))-#define SHA512_F4(x) (ROTR(x, 19) ^ ROTR(x, 61) ^ SHFR(x,  6))--#define UNPACK32(x, str)                      \-{                                             \-    *((str) + 3) = (uint8) ((x)      );       \-    *((str) + 2) = (uint8) ((x) >>  8);       \-    *((str) + 1) = (uint8) ((x) >> 16);       \-    *((str) + 0) = (uint8) ((x) >> 24);       \-}--#define PACK32(str, x)                        \-{                                             \-    *(x) =   ((uint32) *((str) + 3)      )    \-           | ((uint32) *((str) + 2) <<  8)    \-           | ((uint32) *((str) + 1) << 16)    \-           | ((uint32) *((str) + 0) << 24);   \-}--#define UNPACK64(x, str)                      \-{                                             \-    *((str) + 7) = (uint8) ((x)      );       \-    *((str) + 6) = (uint8) ((x) >>  8);       \-    *((str) + 5) = (uint8) ((x) >> 16);       \-    *((str) + 4) = (uint8) ((x) >> 24);       \-    *((str) + 3) = (uint8) ((x) >> 32);       \-    *((str) + 2) = (uint8) ((x) >> 40);       \-    *((str) + 1) = (uint8) ((x) >> 48);       \-    *((str) + 0) = (uint8) ((x) >> 56);       \-}--#define PACK64(str, x)                        \-{                                             \-    *(x) =   ((uint64) *((str) + 7)      )    \-           | ((uint64) *((str) + 6) <<  8)    \-           | ((uint64) *((str) + 5) << 16)    \-           | ((uint64) *((str) + 4) << 24)    \-           | ((uint64) *((str) + 3) << 32)    \-           | ((uint64) *((str) + 2) << 40)    \-           | ((uint64) *((str) + 1) << 48)    \-           | ((uint64) *((str) + 0) << 56);   \-}--/* Macros used for loops unrolling */--#define SHA256_SCR(i)                         \-{                                             \-    w[i] =  SHA256_F4(w[i -  2]) + w[i -  7]  \-          + SHA256_F3(w[i - 15]) + w[i - 16]; \-}--#define SHA512_SCR(i)                         \-{                                             \-    w[i] =  SHA512_F4(w[i -  2]) + w[i -  7]  \-          + SHA512_F3(w[i - 15]) + w[i - 16]; \-}--#define SHA256_EXP(a, b, c, d, e, f, g, h, j)               \-{                                                           \-    t1 = wv[h] + SHA256_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \-         + sha256_k[j] + w[j];                              \-    t2 = SHA256_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]);       \-    wv[d] += t1;                                            \-    wv[h] = t1 + t2;                                        \-}--#define SHA512_EXP(a, b, c, d, e, f, g ,h, j)               \-{                                                           \-    t1 = wv[h] + SHA512_F2(wv[e]) + CH(wv[e], wv[f], wv[g]) \-         + sha512_k[j] + w[j];                              \-    t2 = SHA512_F1(wv[a]) + MAJ(wv[a], wv[b], wv[c]);       \-    wv[d] += t1;                                            \-    wv[h] = t1 + t2;                                        \-}--static uint32 sha224_h0[8] =-            {0xc1059ed8, 0x367cd507, 0x3070dd17, 0xf70e5939,-             0xffc00b31, 0x68581511, 0x64f98fa7, 0xbefa4fa4};--static uint32 sha256_h0[8] =-            {0x6a09e667, 0xbb67ae85, 0x3c6ef372, 0xa54ff53a,-             0x510e527f, 0x9b05688c, 0x1f83d9ab, 0x5be0cd19};--static uint64 sha384_h0[8] =-            {0xcbbb9d5dc1059ed8ULL, 0x629a292a367cd507ULL,-             0x9159015a3070dd17ULL, 0x152fecd8f70e5939ULL,-             0x67332667ffc00b31ULL, 0x8eb44a8768581511ULL,-             0xdb0c2e0d64f98fa7ULL, 0x47b5481dbefa4fa4ULL};--static uint64 sha512_h0[8] =-            {0x6a09e667f3bcc908ULL, 0xbb67ae8584caa73bULL,-             0x3c6ef372fe94f82bULL, 0xa54ff53a5f1d36f1ULL,-             0x510e527fade682d1ULL, 0x9b05688c2b3e6c1fULL,-             0x1f83d9abfb41bd6bULL, 0x5be0cd19137e2179ULL};--static uint32 sha256_k[64] =-            {0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5,-             0x3956c25b, 0x59f111f1, 0x923f82a4, 0xab1c5ed5,-             0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3,-             0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174,-             0xe49b69c1, 0xefbe4786, 0x0fc19dc6, 0x240ca1cc,-             0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da,-             0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7,-             0xc6e00bf3, 0xd5a79147, 0x06ca6351, 0x14292967,-             0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13,-             0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85,-             0xa2bfe8a1, 0xa81a664b, 0xc24b8b70, 0xc76c51a3,-             0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070,-             0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5,-             0x391c0cb3, 0x4ed8aa4a, 0x5b9cca4f, 0x682e6ff3,-             0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208,-             0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2};--static uint64 sha512_k[80] =-            {0x428a2f98d728ae22ULL, 0x7137449123ef65cdULL,-             0xb5c0fbcfec4d3b2fULL, 0xe9b5dba58189dbbcULL,-             0x3956c25bf348b538ULL, 0x59f111f1b605d019ULL,-             0x923f82a4af194f9bULL, 0xab1c5ed5da6d8118ULL,-             0xd807aa98a3030242ULL, 0x12835b0145706fbeULL,-             0x243185be4ee4b28cULL, 0x550c7dc3d5ffb4e2ULL,-             0x72be5d74f27b896fULL, 0x80deb1fe3b1696b1ULL,-             0x9bdc06a725c71235ULL, 0xc19bf174cf692694ULL,-             0xe49b69c19ef14ad2ULL, 0xefbe4786384f25e3ULL,-             0x0fc19dc68b8cd5b5ULL, 0x240ca1cc77ac9c65ULL,-             0x2de92c6f592b0275ULL, 0x4a7484aa6ea6e483ULL,-             0x5cb0a9dcbd41fbd4ULL, 0x76f988da831153b5ULL,-             0x983e5152ee66dfabULL, 0xa831c66d2db43210ULL,-             0xb00327c898fb213fULL, 0xbf597fc7beef0ee4ULL,-             0xc6e00bf33da88fc2ULL, 0xd5a79147930aa725ULL,-             0x06ca6351e003826fULL, 0x142929670a0e6e70ULL,-             0x27b70a8546d22ffcULL, 0x2e1b21385c26c926ULL,-             0x4d2c6dfc5ac42aedULL, 0x53380d139d95b3dfULL,-             0x650a73548baf63deULL, 0x766a0abb3c77b2a8ULL,-             0x81c2c92e47edaee6ULL, 0x92722c851482353bULL,-             0xa2bfe8a14cf10364ULL, 0xa81a664bbc423001ULL,-             0xc24b8b70d0f89791ULL, 0xc76c51a30654be30ULL,-             0xd192e819d6ef5218ULL, 0xd69906245565a910ULL,-             0xf40e35855771202aULL, 0x106aa07032bbd1b8ULL,-             0x19a4c116b8d2d0c8ULL, 0x1e376c085141ab53ULL,-             0x2748774cdf8eeb99ULL, 0x34b0bcb5e19b48a8ULL,-             0x391c0cb3c5c95a63ULL, 0x4ed8aa4ae3418acbULL,-             0x5b9cca4f7763e373ULL, 0x682e6ff3d6b2b8a3ULL,-             0x748f82ee5defb2fcULL, 0x78a5636f43172f60ULL,-             0x84c87814a1f0ab72ULL, 0x8cc702081a6439ecULL,-             0x90befffa23631e28ULL, 0xa4506cebde82bde9ULL,-             0xbef9a3f7b2c67915ULL, 0xc67178f2e372532bULL,-             0xca273eceea26619cULL, 0xd186b8c721c0c207ULL,-             0xeada7dd6cde0eb1eULL, 0xf57d4f7fee6ed178ULL,-             0x06f067aa72176fbaULL, 0x0a637dc5a2c898a6ULL,-             0x113f9804bef90daeULL, 0x1b710b35131c471bULL,-             0x28db77f523047d84ULL, 0x32caab7b40c72493ULL,-             0x3c9ebe0a15c9bebcULL, 0x431d67c49c100d4cULL,-             0x4cc5d4becb3e42b6ULL, 0x597f299cfc657e2aULL,-             0x5fcb6fab3ad6faecULL, 0x6c44198c4a475817ULL};--/* SHA-256 functions */--static void sha256_transf(sha256_ctx *ctx, const unsigned char *message,-                          unsigned int block_nb)-{-    uint32 w[64];-    uint32 wv[8];-    uint32 t1, t2;-    const unsigned char *sub_block;-    int i;--#ifndef UNROLL_LOOPS-    int j;-#endif--    for (i = 0; i < (int) block_nb; i++) {-        sub_block = message + (i << 6);--#ifndef UNROLL_LOOPS-        for (j = 0; j < 16; j++) {-            PACK32(&sub_block[j << 2], &w[j]);-        }--        for (j = 16; j < 64; j++) {-            SHA256_SCR(j);-        }--        for (j = 0; j < 8; j++) {-            wv[j] = ctx->h[j];-        }--        for (j = 0; j < 64; j++) {-            t1 = wv[7] + SHA256_F2(wv[4]) + CH(wv[4], wv[5], wv[6])-                + sha256_k[j] + w[j];-            t2 = SHA256_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]);-            wv[7] = wv[6];-            wv[6] = wv[5];-            wv[5] = wv[4];-            wv[4] = wv[3] + t1;-            wv[3] = wv[2];-            wv[2] = wv[1];-            wv[1] = wv[0];-            wv[0] = t1 + t2;-        }--        for (j = 0; j < 8; j++) {-            ctx->h[j] += wv[j];-        }-#else-        PACK32(&sub_block[ 0], &w[ 0]); PACK32(&sub_block[ 4], &w[ 1]);-        PACK32(&sub_block[ 8], &w[ 2]); PACK32(&sub_block[12], &w[ 3]);-        PACK32(&sub_block[16], &w[ 4]); PACK32(&sub_block[20], &w[ 5]);-        PACK32(&sub_block[24], &w[ 6]); PACK32(&sub_block[28], &w[ 7]);-        PACK32(&sub_block[32], &w[ 8]); PACK32(&sub_block[36], &w[ 9]);-        PACK32(&sub_block[40], &w[10]); PACK32(&sub_block[44], &w[11]);-        PACK32(&sub_block[48], &w[12]); PACK32(&sub_block[52], &w[13]);-        PACK32(&sub_block[56], &w[14]); PACK32(&sub_block[60], &w[15]);--        SHA256_SCR(16); SHA256_SCR(17); SHA256_SCR(18); SHA256_SCR(19);-        SHA256_SCR(20); SHA256_SCR(21); SHA256_SCR(22); SHA256_SCR(23);-        SHA256_SCR(24); SHA256_SCR(25); SHA256_SCR(26); SHA256_SCR(27);-        SHA256_SCR(28); SHA256_SCR(29); SHA256_SCR(30); SHA256_SCR(31);-        SHA256_SCR(32); SHA256_SCR(33); SHA256_SCR(34); SHA256_SCR(35);-        SHA256_SCR(36); SHA256_SCR(37); SHA256_SCR(38); SHA256_SCR(39);-        SHA256_SCR(40); SHA256_SCR(41); SHA256_SCR(42); SHA256_SCR(43);-        SHA256_SCR(44); SHA256_SCR(45); SHA256_SCR(46); SHA256_SCR(47);-        SHA256_SCR(48); SHA256_SCR(49); SHA256_SCR(50); SHA256_SCR(51);-        SHA256_SCR(52); SHA256_SCR(53); SHA256_SCR(54); SHA256_SCR(55);-        SHA256_SCR(56); SHA256_SCR(57); SHA256_SCR(58); SHA256_SCR(59);-        SHA256_SCR(60); SHA256_SCR(61); SHA256_SCR(62); SHA256_SCR(63);--        wv[0] = ctx->h[0]; wv[1] = ctx->h[1];-        wv[2] = ctx->h[2]; wv[3] = ctx->h[3];-        wv[4] = ctx->h[4]; wv[5] = ctx->h[5];-        wv[6] = ctx->h[6]; wv[7] = ctx->h[7];--        SHA256_EXP(0,1,2,3,4,5,6,7, 0); SHA256_EXP(7,0,1,2,3,4,5,6, 1);-        SHA256_EXP(6,7,0,1,2,3,4,5, 2); SHA256_EXP(5,6,7,0,1,2,3,4, 3);-        SHA256_EXP(4,5,6,7,0,1,2,3, 4); SHA256_EXP(3,4,5,6,7,0,1,2, 5);-        SHA256_EXP(2,3,4,5,6,7,0,1, 6); SHA256_EXP(1,2,3,4,5,6,7,0, 7);-        SHA256_EXP(0,1,2,3,4,5,6,7, 8); SHA256_EXP(7,0,1,2,3,4,5,6, 9);-        SHA256_EXP(6,7,0,1,2,3,4,5,10); SHA256_EXP(5,6,7,0,1,2,3,4,11);-        SHA256_EXP(4,5,6,7,0,1,2,3,12); SHA256_EXP(3,4,5,6,7,0,1,2,13);-        SHA256_EXP(2,3,4,5,6,7,0,1,14); SHA256_EXP(1,2,3,4,5,6,7,0,15);-        SHA256_EXP(0,1,2,3,4,5,6,7,16); SHA256_EXP(7,0,1,2,3,4,5,6,17);-        SHA256_EXP(6,7,0,1,2,3,4,5,18); SHA256_EXP(5,6,7,0,1,2,3,4,19);-        SHA256_EXP(4,5,6,7,0,1,2,3,20); SHA256_EXP(3,4,5,6,7,0,1,2,21);-        SHA256_EXP(2,3,4,5,6,7,0,1,22); SHA256_EXP(1,2,3,4,5,6,7,0,23);-        SHA256_EXP(0,1,2,3,4,5,6,7,24); SHA256_EXP(7,0,1,2,3,4,5,6,25);-        SHA256_EXP(6,7,0,1,2,3,4,5,26); SHA256_EXP(5,6,7,0,1,2,3,4,27);-        SHA256_EXP(4,5,6,7,0,1,2,3,28); SHA256_EXP(3,4,5,6,7,0,1,2,29);-        SHA256_EXP(2,3,4,5,6,7,0,1,30); SHA256_EXP(1,2,3,4,5,6,7,0,31);-        SHA256_EXP(0,1,2,3,4,5,6,7,32); SHA256_EXP(7,0,1,2,3,4,5,6,33);-        SHA256_EXP(6,7,0,1,2,3,4,5,34); SHA256_EXP(5,6,7,0,1,2,3,4,35);-        SHA256_EXP(4,5,6,7,0,1,2,3,36); SHA256_EXP(3,4,5,6,7,0,1,2,37);-        SHA256_EXP(2,3,4,5,6,7,0,1,38); SHA256_EXP(1,2,3,4,5,6,7,0,39);-        SHA256_EXP(0,1,2,3,4,5,6,7,40); SHA256_EXP(7,0,1,2,3,4,5,6,41);-        SHA256_EXP(6,7,0,1,2,3,4,5,42); SHA256_EXP(5,6,7,0,1,2,3,4,43);-        SHA256_EXP(4,5,6,7,0,1,2,3,44); SHA256_EXP(3,4,5,6,7,0,1,2,45);-        SHA256_EXP(2,3,4,5,6,7,0,1,46); SHA256_EXP(1,2,3,4,5,6,7,0,47);-        SHA256_EXP(0,1,2,3,4,5,6,7,48); SHA256_EXP(7,0,1,2,3,4,5,6,49);-        SHA256_EXP(6,7,0,1,2,3,4,5,50); SHA256_EXP(5,6,7,0,1,2,3,4,51);-        SHA256_EXP(4,5,6,7,0,1,2,3,52); SHA256_EXP(3,4,5,6,7,0,1,2,53);-        SHA256_EXP(2,3,4,5,6,7,0,1,54); SHA256_EXP(1,2,3,4,5,6,7,0,55);-        SHA256_EXP(0,1,2,3,4,5,6,7,56); SHA256_EXP(7,0,1,2,3,4,5,6,57);-        SHA256_EXP(6,7,0,1,2,3,4,5,58); SHA256_EXP(5,6,7,0,1,2,3,4,59);-        SHA256_EXP(4,5,6,7,0,1,2,3,60); SHA256_EXP(3,4,5,6,7,0,1,2,61);-        SHA256_EXP(2,3,4,5,6,7,0,1,62); SHA256_EXP(1,2,3,4,5,6,7,0,63);--        ctx->h[0] += wv[0]; ctx->h[1] += wv[1];-        ctx->h[2] += wv[2]; ctx->h[3] += wv[3];-        ctx->h[4] += wv[4]; ctx->h[5] += wv[5];-        ctx->h[6] += wv[6]; ctx->h[7] += wv[7];-#endif /* !UNROLL_LOOPS */-    }-}--static void sha256_init(sha256_ctx *ctx)-{-#ifndef UNROLL_LOOPS-    int i;-    for (i = 0; i < 8; i++) {-        ctx->h[i] = sha256_h0[i];-    }-#else-    ctx->h[0] = sha256_h0[0]; ctx->h[1] = sha256_h0[1];-    ctx->h[2] = sha256_h0[2]; ctx->h[3] = sha256_h0[3];-    ctx->h[4] = sha256_h0[4]; ctx->h[5] = sha256_h0[5];-    ctx->h[6] = sha256_h0[6]; ctx->h[7] = sha256_h0[7];-#endif /* !UNROLL_LOOPS */--    ctx->len = 0;-    ctx->tot_len = 0;-}--static void sha256_update(sha256_ctx *ctx, const unsigned char *message,-                          unsigned int len)-{-    unsigned int block_nb;-    unsigned int new_len, rem_len, tmp_len;-    const unsigned char *shifted_message;--    tmp_len = SHA256_BLOCK_SIZE - ctx->len;-    rem_len = len < tmp_len ? len : tmp_len;--    memcpy(&ctx->block[ctx->len], message, rem_len);--    if (ctx->len + len < SHA256_BLOCK_SIZE) {-        ctx->len += len;-        return;-    }--    new_len = len - rem_len;-    block_nb = new_len / SHA256_BLOCK_SIZE;--    shifted_message = message + rem_len;--    sha256_transf(ctx, ctx->block, 1);-    sha256_transf(ctx, shifted_message, block_nb);--    rem_len = new_len % SHA256_BLOCK_SIZE;--    memcpy(ctx->block, &shifted_message[block_nb << 6],-           rem_len);--    ctx->len = rem_len;-    ctx->tot_len += (block_nb + 1) << 6;-}--static void sha256_final(sha256_ctx *ctx, unsigned char *digest)-{-    unsigned int block_nb;-    unsigned int pm_len;-    unsigned int len_b;--#ifndef UNROLL_LOOPS-    int i;-#endif--    block_nb = (1 + ((SHA256_BLOCK_SIZE - 9)-                     < (ctx->len % SHA256_BLOCK_SIZE)));--    len_b = (ctx->tot_len + ctx->len) << 3;-    pm_len = block_nb << 6;--    memset(ctx->block + ctx->len, 0, pm_len - ctx->len);-    ctx->block[ctx->len] = 0x80;-    UNPACK32(len_b, ctx->block + pm_len - 4);--    sha256_transf(ctx, ctx->block, block_nb);--#ifndef UNROLL_LOOPS-    for (i = 0 ; i < 8; i++) {-        UNPACK32(ctx->h[i], &digest[i << 2]);-    }-#else-   UNPACK32(ctx->h[0], &digest[ 0]);-   UNPACK32(ctx->h[1], &digest[ 4]);-   UNPACK32(ctx->h[2], &digest[ 8]);-   UNPACK32(ctx->h[3], &digest[12]);-   UNPACK32(ctx->h[4], &digest[16]);-   UNPACK32(ctx->h[5], &digest[20]);-   UNPACK32(ctx->h[6], &digest[24]);-   UNPACK32(ctx->h[7], &digest[28]);-#endif /* !UNROLL_LOOPS */-}--void darcs_sha256(const unsigned char *message, unsigned int len, unsigned char *digest)-{-    sha256_ctx ctx;--    sha256_init(&ctx);-    sha256_update(&ctx, message, len);-    sha256_final(&ctx, digest);-}--/* SHA-512 functions */--static void sha512_transf(sha512_ctx *ctx, const unsigned char *message,-                          unsigned int block_nb)-{-    uint64 w[80];-    uint64 wv[8];-    uint64 t1, t2;-    const unsigned char *sub_block;-    int i, j;--    for (i = 0; i < (int) block_nb; i++) {-        sub_block = message + (i << 7);--#ifndef UNROLL_LOOPS-        for (j = 0; j < 16; j++) {-            PACK64(&sub_block[j << 3], &w[j]);-        }--        for (j = 16; j < 80; j++) {-            SHA512_SCR(j);-        }--        for (j = 0; j < 8; j++) {-            wv[j] = ctx->h[j];-        }--        for (j = 0; j < 80; j++) {-            t1 = wv[7] + SHA512_F2(wv[4]) + CH(wv[4], wv[5], wv[6])-                + sha512_k[j] + w[j];-            t2 = SHA512_F1(wv[0]) + MAJ(wv[0], wv[1], wv[2]);-            wv[7] = wv[6];-            wv[6] = wv[5];-            wv[5] = wv[4];-            wv[4] = wv[3] + t1;-            wv[3] = wv[2];-            wv[2] = wv[1];-            wv[1] = wv[0];-            wv[0] = t1 + t2;-        }--        for (j = 0; j < 8; j++) {-            ctx->h[j] += wv[j];-        }-#else-        PACK64(&sub_block[  0], &w[ 0]); PACK64(&sub_block[  8], &w[ 1]);-        PACK64(&sub_block[ 16], &w[ 2]); PACK64(&sub_block[ 24], &w[ 3]);-        PACK64(&sub_block[ 32], &w[ 4]); PACK64(&sub_block[ 40], &w[ 5]);-        PACK64(&sub_block[ 48], &w[ 6]); PACK64(&sub_block[ 56], &w[ 7]);-        PACK64(&sub_block[ 64], &w[ 8]); PACK64(&sub_block[ 72], &w[ 9]);-        PACK64(&sub_block[ 80], &w[10]); PACK64(&sub_block[ 88], &w[11]);-        PACK64(&sub_block[ 96], &w[12]); PACK64(&sub_block[104], &w[13]);-        PACK64(&sub_block[112], &w[14]); PACK64(&sub_block[120], &w[15]);--        SHA512_SCR(16); SHA512_SCR(17); SHA512_SCR(18); SHA512_SCR(19);-        SHA512_SCR(20); SHA512_SCR(21); SHA512_SCR(22); SHA512_SCR(23);-        SHA512_SCR(24); SHA512_SCR(25); SHA512_SCR(26); SHA512_SCR(27);-        SHA512_SCR(28); SHA512_SCR(29); SHA512_SCR(30); SHA512_SCR(31);-        SHA512_SCR(32); SHA512_SCR(33); SHA512_SCR(34); SHA512_SCR(35);-        SHA512_SCR(36); SHA512_SCR(37); SHA512_SCR(38); SHA512_SCR(39);-        SHA512_SCR(40); SHA512_SCR(41); SHA512_SCR(42); SHA512_SCR(43);-        SHA512_SCR(44); SHA512_SCR(45); SHA512_SCR(46); SHA512_SCR(47);-        SHA512_SCR(48); SHA512_SCR(49); SHA512_SCR(50); SHA512_SCR(51);-        SHA512_SCR(52); SHA512_SCR(53); SHA512_SCR(54); SHA512_SCR(55);-        SHA512_SCR(56); SHA512_SCR(57); SHA512_SCR(58); SHA512_SCR(59);-        SHA512_SCR(60); SHA512_SCR(61); SHA512_SCR(62); SHA512_SCR(63);-        SHA512_SCR(64); SHA512_SCR(65); SHA512_SCR(66); SHA512_SCR(67);-        SHA512_SCR(68); SHA512_SCR(69); SHA512_SCR(70); SHA512_SCR(71);-        SHA512_SCR(72); SHA512_SCR(73); SHA512_SCR(74); SHA512_SCR(75);-        SHA512_SCR(76); SHA512_SCR(77); SHA512_SCR(78); SHA512_SCR(79);--        wv[0] = ctx->h[0]; wv[1] = ctx->h[1];-        wv[2] = ctx->h[2]; wv[3] = ctx->h[3];-        wv[4] = ctx->h[4]; wv[5] = ctx->h[5];-        wv[6] = ctx->h[6]; wv[7] = ctx->h[7];--        j = 0;--        do {-            SHA512_EXP(0,1,2,3,4,5,6,7,j); j++;-            SHA512_EXP(7,0,1,2,3,4,5,6,j); j++;-            SHA512_EXP(6,7,0,1,2,3,4,5,j); j++;-            SHA512_EXP(5,6,7,0,1,2,3,4,j); j++;-            SHA512_EXP(4,5,6,7,0,1,2,3,j); j++;-            SHA512_EXP(3,4,5,6,7,0,1,2,j); j++;-            SHA512_EXP(2,3,4,5,6,7,0,1,j); j++;-            SHA512_EXP(1,2,3,4,5,6,7,0,j); j++;-        } while (j < 80);--        ctx->h[0] += wv[0]; ctx->h[1] += wv[1];-        ctx->h[2] += wv[2]; ctx->h[3] += wv[3];-        ctx->h[4] += wv[4]; ctx->h[5] += wv[5];-        ctx->h[6] += wv[6]; ctx->h[7] += wv[7];-#endif /* !UNROLL_LOOPS */-    }-}--static void sha512_init(sha512_ctx *ctx)-{-#ifndef UNROLL_LOOPS-    int i;-    for (i = 0; i < 8; i++) {-        ctx->h[i] = sha512_h0[i];-    }-#else-    ctx->h[0] = sha512_h0[0]; ctx->h[1] = sha512_h0[1];-    ctx->h[2] = sha512_h0[2]; ctx->h[3] = sha512_h0[3];-    ctx->h[4] = sha512_h0[4]; ctx->h[5] = sha512_h0[5];-    ctx->h[6] = sha512_h0[6]; ctx->h[7] = sha512_h0[7];-#endif /* !UNROLL_LOOPS */--    ctx->len = 0;-    ctx->tot_len = 0;-}--static void sha512_update(sha512_ctx *ctx, const unsigned char *message,-                          unsigned int len)-{-    unsigned int block_nb;-    unsigned int new_len, rem_len, tmp_len;-    const unsigned char *shifted_message;--    tmp_len = SHA512_BLOCK_SIZE - ctx->len;-    rem_len = len < tmp_len ? len : tmp_len;--    memcpy(&ctx->block[ctx->len], message, rem_len);--    if (ctx->len + len < SHA512_BLOCK_SIZE) {-        ctx->len += len;-        return;-    }--    new_len = len - rem_len;-    block_nb = new_len / SHA512_BLOCK_SIZE;--    shifted_message = message + rem_len;--    sha512_transf(ctx, ctx->block, 1);-    sha512_transf(ctx, shifted_message, block_nb);--    rem_len = new_len % SHA512_BLOCK_SIZE;--    memcpy(ctx->block, &shifted_message[block_nb << 7],-           rem_len);--    ctx->len = rem_len;-    ctx->tot_len += (block_nb + 1) << 7;-}--static void sha512_final(sha512_ctx *ctx, unsigned char *digest)-{-    unsigned int block_nb;-    unsigned int pm_len;-    unsigned int len_b;--#ifndef UNROLL_LOOPS-    int i;-#endif--    block_nb = 1 + ((SHA512_BLOCK_SIZE - 17)-                     < (ctx->len % SHA512_BLOCK_SIZE));--    len_b = (ctx->tot_len + ctx->len) << 3;-    pm_len = block_nb << 7;--    memset(ctx->block + ctx->len, 0, pm_len - ctx->len);-    ctx->block[ctx->len] = 0x80;-    UNPACK32(len_b, ctx->block + pm_len - 4);--    sha512_transf(ctx, ctx->block, block_nb);--#ifndef UNROLL_LOOPS-    for (i = 0 ; i < 8; i++) {-        UNPACK64(ctx->h[i], &digest[i << 3]);-    }-#else-    UNPACK64(ctx->h[0], &digest[ 0]);-    UNPACK64(ctx->h[1], &digest[ 8]);-    UNPACK64(ctx->h[2], &digest[16]);-    UNPACK64(ctx->h[3], &digest[24]);-    UNPACK64(ctx->h[4], &digest[32]);-    UNPACK64(ctx->h[5], &digest[40]);-    UNPACK64(ctx->h[6], &digest[48]);-    UNPACK64(ctx->h[7], &digest[56]);-#endif /* !UNROLL_LOOPS */-}--void darcs_sha512(const unsigned char *message, unsigned int len,-            unsigned char *digest)-{-    sha512_ctx ctx;--    sha512_init(&ctx);-    sha512_update(&ctx, message, len);-    sha512_final(&ctx, digest);-}--/* SHA-384 functions */--static void sha384_init(sha384_ctx *ctx)-{-#ifndef UNROLL_LOOPS-    int i;-    for (i = 0; i < 8; i++) {-        ctx->h[i] = sha384_h0[i];-    }-#else-    ctx->h[0] = sha384_h0[0]; ctx->h[1] = sha384_h0[1];-    ctx->h[2] = sha384_h0[2]; ctx->h[3] = sha384_h0[3];-    ctx->h[4] = sha384_h0[4]; ctx->h[5] = sha384_h0[5];-    ctx->h[6] = sha384_h0[6]; ctx->h[7] = sha384_h0[7];-#endif /* !UNROLL_LOOPS */--    ctx->len = 0;-    ctx->tot_len = 0;-}--static void sha384_update(sha384_ctx *ctx, const unsigned char *message,-                          unsigned int len)-{-    unsigned int block_nb;-    unsigned int new_len, rem_len, tmp_len;-    const unsigned char *shifted_message;--    tmp_len = SHA384_BLOCK_SIZE - ctx->len;-    rem_len = len < tmp_len ? len : tmp_len;--    memcpy(&ctx->block[ctx->len], message, rem_len);--    if (ctx->len + len < SHA384_BLOCK_SIZE) {-        ctx->len += len;-        return;-    }--    new_len = len - rem_len;-    block_nb = new_len / SHA384_BLOCK_SIZE;--    shifted_message = message + rem_len;--    sha512_transf(ctx, ctx->block, 1);-    sha512_transf(ctx, shifted_message, block_nb);--    rem_len = new_len % SHA384_BLOCK_SIZE;--    memcpy(ctx->block, &shifted_message[block_nb << 7],-           rem_len);--    ctx->len = rem_len;-    ctx->tot_len += (block_nb + 1) << 7;-}--static void sha384_final(sha384_ctx *ctx, unsigned char *digest)-{-    unsigned int block_nb;-    unsigned int pm_len;-    unsigned int len_b;--#ifndef UNROLL_LOOPS-    int i;-#endif--    block_nb = (1 + ((SHA384_BLOCK_SIZE - 17)-                     < (ctx->len % SHA384_BLOCK_SIZE)));--    len_b = (ctx->tot_len + ctx->len) << 3;-    pm_len = block_nb << 7;--    memset(ctx->block + ctx->len, 0, pm_len - ctx->len);-    ctx->block[ctx->len] = 0x80;-    UNPACK32(len_b, ctx->block + pm_len - 4);--    sha512_transf(ctx, ctx->block, block_nb);--#ifndef UNROLL_LOOPS-    for (i = 0 ; i < 6; i++) {-        UNPACK64(ctx->h[i], &digest[i << 3]);-    }-#else-    UNPACK64(ctx->h[0], &digest[ 0]);-    UNPACK64(ctx->h[1], &digest[ 8]);-    UNPACK64(ctx->h[2], &digest[16]);-    UNPACK64(ctx->h[3], &digest[24]);-    UNPACK64(ctx->h[4], &digest[32]);-    UNPACK64(ctx->h[5], &digest[40]);-#endif /* !UNROLL_LOOPS */-}--void darcs_sha384(const unsigned char *message, unsigned int len,-            unsigned char *digest)-{-    sha384_ctx ctx;--    sha384_init(&ctx);-    sha384_update(&ctx, message, len);-    sha384_final(&ctx, digest);-}--/* SHA-224 functions */--static void sha224_init(sha224_ctx *ctx)-{-#ifndef UNROLL_LOOPS-    int i;-    for (i = 0; i < 8; i++) {-        ctx->h[i] = sha224_h0[i];-    }-#else-    ctx->h[0] = sha224_h0[0]; ctx->h[1] = sha224_h0[1];-    ctx->h[2] = sha224_h0[2]; ctx->h[3] = sha224_h0[3];-    ctx->h[4] = sha224_h0[4]; ctx->h[5] = sha224_h0[5];-    ctx->h[6] = sha224_h0[6]; ctx->h[7] = sha224_h0[7];-#endif /* !UNROLL_LOOPS */--    ctx->len = 0;-    ctx->tot_len = 0;-}--static void sha224_update(sha224_ctx *ctx, const unsigned char *message,-                          unsigned int len)-{-    unsigned int block_nb;-    unsigned int new_len, rem_len, tmp_len;-    const unsigned char *shifted_message;--    tmp_len = SHA224_BLOCK_SIZE - ctx->len;-    rem_len = len < tmp_len ? len : tmp_len;--    memcpy(&ctx->block[ctx->len], message, rem_len);--    if (ctx->len + len < SHA224_BLOCK_SIZE) {-        ctx->len += len;-        return;-    }--    new_len = len - rem_len;-    block_nb = new_len / SHA224_BLOCK_SIZE;--    shifted_message = message + rem_len;--    sha256_transf(ctx, ctx->block, 1);-    sha256_transf(ctx, shifted_message, block_nb);--    rem_len = new_len % SHA224_BLOCK_SIZE;--    memcpy(ctx->block, &shifted_message[block_nb << 6],-           rem_len);--    ctx->len = rem_len;-    ctx->tot_len += (block_nb + 1) << 6;-}--static void sha224_final(sha224_ctx *ctx, unsigned char *digest)-{-    unsigned int block_nb;-    unsigned int pm_len;-    unsigned int len_b;--#ifndef UNROLL_LOOPS-    int i;-#endif--    block_nb = (1 + ((SHA224_BLOCK_SIZE - 9)-                     < (ctx->len % SHA224_BLOCK_SIZE)));--    len_b = (ctx->tot_len + ctx->len) << 3;-    pm_len = block_nb << 6;--    memset(ctx->block + ctx->len, 0, pm_len - ctx->len);-    ctx->block[ctx->len] = 0x80;-    UNPACK32(len_b, ctx->block + pm_len - 4);--    sha256_transf(ctx, ctx->block, block_nb);--#ifndef UNROLL_LOOPS-    for (i = 0 ; i < 7; i++) {-        UNPACK32(ctx->h[i], &digest[i << 2]);-    }-#else-   UNPACK32(ctx->h[0], &digest[ 0]);-   UNPACK32(ctx->h[1], &digest[ 4]);-   UNPACK32(ctx->h[2], &digest[ 8]);-   UNPACK32(ctx->h[3], &digest[12]);-   UNPACK32(ctx->h[4], &digest[16]);-   UNPACK32(ctx->h[5], &digest[20]);-   UNPACK32(ctx->h[6], &digest[24]);-#endif /* !UNROLL_LOOPS */-}--void darcs_sha224(const unsigned char *message, unsigned int len,-            unsigned char *digest)-{-    sha224_ctx ctx;--    sha224_init(&ctx);-    sha224_update(&ctx, message, len);-    sha224_final(&ctx, digest);-}--#ifdef TEST_VECTORS--/* FIPS 180-2 Validation tests */--#include <stdio.h>-#include <stdlib.h>--void test(const unsigned char *vector, unsigned char *digest,-          unsigned int digest_size)-{-    unsigned char output[2 * SHA512_DIGEST_SIZE + 1];-    int i;--    output[2 * digest_size] = '\0';--    for (i = 0; i < (int) digest_size ; i++) {-       sprintf((char *) output + 2 * i, "%02x", digest[i]);-    }--    printf("H: %s\n", output);-    if (strcmp((char *) vector, (char *) output)) {-        fprintf(stderr, "Test failed.\n");-        exit(EXIT_FAILURE);-    }-}--int main()-{-    static const unsigned char *vectors[4][3] =-    {   /* SHA-224 */-        {-        "23097d223405d8228642a477bda255b32aadbce4bda0b3f7e36c9da7",-        "75388b16512776cc5dba5da1fd890150b0c6455cb4f58b1952522525",-        "20794655980c91d8bbb4c1ea97618a4bf03f42581948b2ee4ee7ad67",-        },-        /* SHA-256 */-        {-        "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad",-        "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1",-        "cdc76e5c9914fb9281a1c7e284d73e67f1809a48a497200e046d39ccc7112cd0",-        },-        /* SHA-384 */-        {-        "cb00753f45a35e8bb5a03d699ac65007272c32ab0eded1631a8b605a43ff5bed"-        "8086072ba1e7cc2358baeca134c825a7",-        "09330c33f71147e83d192fc782cd1b4753111b173b3b05d22fa08086e3b0f712"-        "fcc7c71a557e2db966c3e9fa91746039",-        "9d0e1809716474cb086e834e310a4a1ced149e9c00f248527972cec5704c2a5b"-        "07b8b3dc38ecc4ebae97ddd87f3d8985",-        },-        /* SHA-512 */-        {-        "ddaf35a193617abacc417349ae20413112e6fa4e89a97ea20a9eeee64b55d39a"-        "2192992a274fc1a836ba3c23a3feebbd454d4423643ce80e2a9ac94fa54ca49f",-        "8e959b75dae313da8cf4f72814fc143f8f7779c6eb9f7fa17299aeadb6889018"-        "501d289e4900f7e4331b99dec4b5433ac7d329eeb6dd26545e96e55b874be909",-        "e718483d0ce769644e2e42c7bc15b4638e1f98b13b2044285632a803afa973eb"-        "de0ff244877ea60a4cb0432ce577c31beb009c5c2c49aa2e4eadb217ad8cc09b"-        }-    };--    static const unsigned char message1[] = "abc";-    static const unsigned char message2a[] = "abcdbcdecdefdefgefghfghighijhi"-                                             "jkijkljklmklmnlmnomnopnopq";-    static const unsigned char message2b[] =-                                      "abcdefghbcdefghicdefghijdefghijkefghij"-                                      "klfghijklmghijklmnhijklmnoijklmnopjklm"-                                      "nopqklmnopqrlmnopqrsmnopqrstnopqrstu";-    unsigned char *message3;-    unsigned int message3_len  = 1000000;-    unsigned char digest[SHA512_DIGEST_SIZE];--    message3 = malloc(message3_len);-    if (message3 == NULL) {-        fprintf(stderr, "Can't allocate memory\n");-        return -1;-    }-    memset(message3, 'a', message3_len);--    printf("SHA-2 FIPS 180-2 Validation tests\n\n");-    printf("SHA-224 Test vectors\n");--    sha224(message1, strlen((char *) message1), digest);-    test(vectors[0][0], digest, SHA224_DIGEST_SIZE);-    sha224(message2a, strlen((char *) message2a), digest);-    test(vectors[0][1], digest, SHA224_DIGEST_SIZE);-    sha224(message3, message3_len, digest);-    test(vectors[0][2], digest, SHA224_DIGEST_SIZE);-    printf("\n");--    printf("SHA-256 Test vectors\n");--    sha256(message1, strlen((char *) message1), digest);-    test(vectors[1][0], digest, SHA256_DIGEST_SIZE);-    sha256(message2a, strlen((char *) message2a), digest);-    test(vectors[1][1], digest, SHA256_DIGEST_SIZE);-    sha256(message3, message3_len, digest);-    test(vectors[1][2], digest, SHA256_DIGEST_SIZE);-    printf("\n");--    printf("SHA-384 Test vectors\n");--    sha384(message1, strlen((char *) message1), digest);-    test(vectors[2][0], digest, SHA384_DIGEST_SIZE);-    sha384(message2b, strlen((char *) message2b), digest);-    test(vectors[2][1], digest, SHA384_DIGEST_SIZE);-    sha384(message3, message3_len, digest);-    test(vectors[2][2], digest, SHA384_DIGEST_SIZE);-    printf("\n");--    printf("SHA-512 Test vectors\n");--    sha512(message1, strlen((char *) message1), digest);-    test(vectors[3][0], digest, SHA512_DIGEST_SIZE);-    sha512(message2b, strlen((char *) message2b), digest);-    test(vectors[3][1], digest, SHA512_DIGEST_SIZE);-    sha512(message3, message3_len, digest);-    test(vectors[3][2], digest, SHA512_DIGEST_SIZE);-    printf("\n");--    printf("All tests passed.\n");--    return 0;-}--#endif /* TEST_VECTORS */
− src/Crypt/sha2.h 
@@ -1,88 +0,0 @@-/*- * FIPS 180-2 SHA-224/256/384/512 implementation- * Last update: 02/02/2007- * Issue date:  04/30/2005- *- * Copyright (C) 2005, 2007 Olivier Gay <olivier.gay@a3.epfl.ch>- * All rights reserved.- *- * Redistribution and use in source and binary forms, with or without- * modification, are permitted provided that the following conditions- * are met:- * 1. Redistributions of source code must retain the above copyright- *    notice, this list of conditions and the following disclaimer.- * 2. Redistributions in binary form must reproduce the above copyright- *    notice, this list of conditions and the following disclaimer in the- *    documentation and/or other materials provided with the distribution.- * 3. Neither the name of the project nor the names of its contributors- *    may be used to endorse or promote products derived from this software- *    without specific prior written permission.- *- * THIS SOFTWARE IS PROVIDED BY THE PROJECT AND CONTRIBUTORS ``AS IS'' AND- * ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE- * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE- * ARE DISCLAIMED.  IN NO EVENT SHALL THE PROJECT OR CONTRIBUTORS BE LIABLE- * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL- * DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS- * OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)- * HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT- * LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY- * OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF- * SUCH DAMAGE.- */--#ifndef SHA2_H-#define SHA2_H--#define SHA224_DIGEST_SIZE ( 224 / 8)-#define SHA256_DIGEST_SIZE ( 256 / 8)-#define SHA384_DIGEST_SIZE ( 384 / 8)-#define SHA512_DIGEST_SIZE ( 512 / 8)--#define SHA256_BLOCK_SIZE  ( 512 / 8)-#define SHA512_BLOCK_SIZE  (1024 / 8)-#define SHA384_BLOCK_SIZE  SHA512_BLOCK_SIZE-#define SHA224_BLOCK_SIZE  SHA256_BLOCK_SIZE--#ifndef SHA2_TYPES-#define SHA2_TYPES-typedef unsigned char uint8;-typedef unsigned int  uint32;-typedef unsigned long long uint64;-#endif--#ifdef __cplusplus-extern "C" {-#endif--typedef struct {-    unsigned int tot_len;-    unsigned int len;-    unsigned char block[2 * SHA256_BLOCK_SIZE];-    uint32 h[8];-} sha256_ctx;--typedef struct {-    unsigned int tot_len;-    unsigned int len;-    unsigned char block[2 * SHA512_BLOCK_SIZE];-    uint64 h[8];-} sha512_ctx;--typedef sha512_ctx sha384_ctx;-typedef sha256_ctx sha224_ctx;--void darcs_sha224(const unsigned char *message, unsigned int len,-                  unsigned char *digest);-void darcs_sha256(const unsigned char *message, unsigned int len,-                  unsigned char *digest);-void darcs_sha384(const unsigned char *message, unsigned int len,-                  unsigned char *digest);-void darcs_sha512(const unsigned char *message, unsigned int len,-                  unsigned char *digest);--#ifdef __cplusplus-}-#endif--#endif /* !SHA2_H */
− src/Darcs/Annotate.hs 
@@ -1,262 +0,0 @@-{-# LANGUAGE OverloadedStrings, TypeSynonymInstances, MultiParamTypeClasses #-}---- Copyright (C) 2010 Petr Rockai------ 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--- SOFTWARE.---- |--- Module      : Darcs.Annotate--- Copyright   : 2010 Petr Rockai--- License     : MIT--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Darcs.Annotate-    (-      annotate-    , annotateDirectory-    , format-    , machineFormat-    ) where--import Prelude hiding ( pi )--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.Map as M-import qualified Data.Vector as V--import Data.List( nub, groupBy )-import Data.Maybe( isJust, catMaybes, isNothing )--import Control.Monad.State ( modify, when, gets, State, execState )-import Control.Applicative( (<$>) )--import Darcs.Patch.ApplyMonad( ApplyMonad(..) )-import Darcs.Patch.FileName( FileName, movedirfilename, fn2ps, ps2fn )-import Darcs.Patch.Apply ( Apply, apply, ApplyState )-import Darcs.Patch.Info ( PatchInfo(..), humanFriendly, piAuthor, makeFilename )-import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd )-import Darcs.Witnesses.Ordered--import Storage.Hashed.Tree( Tree )-import Lcs( getChanges )-import Printer( renderString )-import ByteStringUtils ( linesPS, unlinesPS )--#include "gadts.h"-#include "impossible.h"---data FileOrDirectory = File-                     | Directory-                       deriving (Show, Eq)--data Annotated = Annotated-    { annotated   :: V.Vector (Maybe PatchInfo, B.ByteString)-    , current     :: [(Int, B.ByteString)]-    , path        :: Maybe FileName-    , what        :: FileOrDirectory-    , currentInfo :: PatchInfo-    } deriving Show---type AnnotatedM = State Annotated---- XXX: No explicit method nor default method for 'editFile', 'editDirectory'-instance ApplyMonad AnnotatedM Tree where-  type ApplyMonadBase AnnotatedM = AnnotatedM--  nestedApply _ _ = undefinedFun "nestedApply"-  liftApply _ _   = undefinedFun "liftApply"-  getApplyState   = undefinedFun "getApplyState"-  putApplyState _ = undefinedFun "putApplyState"-  mReadFilePS     = undefinedFun "mReadFilePS"--  mDoesFileExist _      = return True-  mDoesDirectoryExist _ = return True-  mCreateDirectory _    = return ()-  mCreateFile _         = return ()--  mRemoveFile f = do-      p <- gets path-      when (p == Just f) $ modify (\x -> x { path = Nothing })-      updateDirectory f--  mRemoveDirectory = mRemoveFile--  mRename a b = do-      p <- gets path-      w <- gets what-      when (isJust p) $-          modify $ \st -> st { path = Just $ movedirfilename a b (fromJust p) }-      when (w == Directory) $ do-          let fix (i, x) = (i, fn2ps $ movedirfilename a b (ps2fn x))-          modify $ \st -> st { current = map fix $ current st }--  mModifyFilePS f job = do-      p <- gets path-      when (p == Just f) $ updateFile (fmap linesPS . job . unlinesPS)--  mModifyFilePSs f job = do-      p <- gets path-      when (p == Just f) $ updateFile job--undefinedFun :: Monad m-             => String-             -> m a-undefinedFun name = fail $ name ++ " undefined for Annotated"---updateFile :: ([B.ByteString]-           -> AnnotatedM [B.ByteString])-           -> AnnotatedM ()-updateFile job = (==File) <$> gets what >>= flip when go-  where-    go = do-        before <- map snd `fmap` gets current-        after <- job before-        reannotate $ getChanges before after--    reannotate [] = return ()-    reannotate ((off, remove, add):rest) = do-        i <- gets currentInfo-        c <- gets current-        a <- gets annotated-        modify $ \s -> s { current = take off c ++ [ (-1, x) | x <- add ] ++-                                     drop (off + length remove) c-                         , annotated = merge i a $ take (length remove) $ drop off c-                         }-        reannotate rest--    merge i a l = a V.// [ (line, (Just i, B.empty))-                         | (line, _) <- l, line >= 0 && line < V.length a]---updateDirectory :: FileName -> AnnotatedM ()-updateDirectory p = (==Directory) <$> gets what >>= flip when go-  where-    go = do let line = fn2ps p-            files <- gets current-            case filter ((==line) . snd) files of-              [match@(ident, _)] -> reannotate ident match line-              _ -> return ()-    reannotate ident match line =-      modify $ \x -> x { annotated = annotated x V.// [ (ident, update line $ currentInfo x) ]-                       , current = filter (/= match) $ current x }-    update line inf = (Just inf, BC.concat [ " -- created as: ", line ])---complete :: Annotated -> Bool-complete x = (V.all (isJust . fst) $ annotated x) || (isNothing $ path x)---annotate' :: (Apply p, ApplyState p ~ Tree)-          => FL (PatchInfoAnd p) C(x y)-          -> Annotated-          -> Annotated-annotate' NilFL ann = ann-annotate' (p :>: ps) ann-    | complete ann = ann-    | otherwise = annotate' ps $ execState (apply p) (ann { currentInfo = info p })---annotate :: (Apply p, ApplyState p ~ Tree)-         => FL (PatchInfoAnd p) C(x y)-         -> FileName-         -> B.ByteString-         -> Annotated-annotate patches inipath inicontent = annotate' patches initial-  where-    initial = Annotated { path = Just inipath-                        , currentInfo = error "There is no currentInfo."-                        , current = zip [0..] (linesPS inicontent)-                        , what = File-                        , annotated = V.replicate (length $ breakLines inicontent)-                                                      (Nothing, B.empty)-                        }---annotateDirectory :: (Apply p, ApplyState p ~ Tree)-                  => FL (PatchInfoAnd p) C(x y)-                  -> FileName-                  -> [FileName]-                  -> Annotated-annotateDirectory patches inipath inicontent = annotate' patches initial-  where-    initial = Annotated { path = Just inipath-                        , currentInfo = error "There is no currentInfo."-                        , current = zip [0..] (map fn2ps inicontent)-                        , what = Directory-                        , annotated = V.replicate (length inicontent) (Nothing, B.empty)-                        }---machineFormat :: B.ByteString -> Annotated -> String-machineFormat d a = unlines [ case i of-                                 Just inf -> makeFilename inf-                                 Nothing -> -- make unknowns uniform, for easier parsing-                                   "19700101000000-0000-0000000000000000000000000000000000000000.gz"-                              ++ " | " ++ BC.unpack line ++ " " ++ BC.unpack add-                            | ((i, add), line) <- zip (V.toList $ annotated a) (breakLines d) ]---format :: B.ByteString-       -> Annotated-       -> String-format d a = pi_list ++ "\n" ++ file-  where-    pi_list = unlines $ [ show n ++ ": " ++ renderString (humanFriendly i)-                        | (n :: Int, i) <- zip [1..] pis ]--    file = concat [ annotation (fst $ head chunk) ++ " | " ++ line (head chunk) ++-                    "\n" ++ unlines [ indent 25 (" | " ++ line l) | l <- tail chunk ]-                  | chunk <- file_ann ]--    pis = nub $ catMaybes . map fst $ V.toList (annotated a)--    pi_map = M.fromList (zip pis [1 :: Int ..])--    file_ann = groupBy (\x y -> fst x == fst y) $ zip (V.toList $ annotated a) (breakLines d)--    line ((_, add), l) = BC.unpack $ BC.concat [l, " ", add]--    annotation (Just i, _) | Just n <- M.lookup i pi_map =-        pad 20 (piMail i) ++ " " ++ pad 4 ("#" ++ show n)-    annotation _ = pad 25 "unknown"--    pad n str = replicate (n - length str) ' ' ++ (take n str)--    indent n str = replicate n ' ' ++ str--    piMail pi-        | '<' `elem` piAuthor pi = takeWhile (/= '>') . drop 1 . dropWhile (/= '<') $ piAuthor pi-        | otherwise = piAuthor pi---breakLines :: BC.ByteString-           -> [BC.ByteString]-breakLines s = case BC.split '\n' s of-    [] -> []-    split | BC.null (last split) -> init split-          | otherwise -> split-
− src/Darcs/ArgumentDefaults.hs 
@@ -1,79 +0,0 @@---  Copyright (C) 2003 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.ArgumentDefaults ( getDefaultFlags ) where-import Data.Maybe ( listToMaybe, mapMaybe )--import Darcs.Arguments ( DarcsFlag,-                         atomicOptions, DarcsAtomicOption( .. ), DarcsOption ( .. ),-                         applyDefaults,-                         arein )-import Darcs.Commands ( CommandControl( CommandData ),-                        commandAlloptions )-import Darcs.Commands.Help ( commandControlList )-import Darcs.Repository.Prefs ( getGlobal, getPreflist )--getDefaultFlags :: String -> [DarcsOption] -> [DarcsFlag] -> IO [DarcsFlag]-getDefaultFlags com com_opts already = do-    repo_defs   <- defaultContent $ getPreflist "defaults"-    global_defs <- defaultContent $ getGlobal   "defaults"-    let repo_flags = getFlagsFrom com com_opts already repo_defs-        global_flags = getFlagsFrom com com_opts-                                          (already++repo_flags) global_defs-    return $ applyDefaults com_opts     -- hard-coded defaults (respects user preferences)-           $ repo_flags ++ global_flags -- user preferences--getFlagsFrom :: String -> [DarcsOption] -> [DarcsFlag] -> [(String,String,String)] -> [DarcsFlag]-getFlagsFrom com com_opts already defs =-    options_for com_defs com_opts com_opts ++-    options_for all_defs com_opts all_opts-    where com_defs = filter (\ (c,_,_) -> c == com) defs-          all_defs = filter (\ (c,_,_) -> c == "ALL") defs-          options_for d o ao = concatMap (findOption o ao already) d-          all_opts = concatMap get_opts commandControlList-          get_opts (CommandData c) = let (o1, o2) = commandAlloptions c-                                      in o1 ++ o2-          get_opts _                = []--findOption :: [DarcsOption] -> [DarcsOption] -> [DarcsFlag] -> (String,String,String) -> [DarcsFlag]-findOption opts all_opts already (c, f, d) =-    if null $ mapMaybe choose_option all_opts-    then error $ "Bad default option: command '"++c++"' has no option '"++f++"'."-    else concat $ mapMaybe choose_option opts-    where choose_atomic_option (DarcsNoArgOption _ fls o _)-              | f `elem` fls = if null d-                               then Just [o]-                               else error $ "Bad default option: '"++f-                                        ++"' takes no argument, but '"++d-                                        ++"' argument given."-          choose_atomic_option (DarcsArgOption _ fls o _ _)-              | f `elem` fls = if null d-                               then error $ "Bad default option: '"++f-                                        ++"' requires an argument, but no "-                                        ++"argument given."-                               else Just [o d]-          choose_atomic_option _ = Nothing-          choose_option o-              | o `arein` already = Just []-              | otherwise = listToMaybe $ mapMaybe choose_atomic_option $ atomicOptions o--defaultContent :: IO [String] -> IO [(String,String,String)]-defaultContent = fmap (mapMaybe (doline . words))-    where doline (c:a:r) = Just (c, drop_dashdash a, unwords r)-          doline _ = Nothing-          drop_dashdash ('-':'-':a) = a-          drop_dashdash a = a
− src/Darcs/Arguments.hs 
@@ -1,1596 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}--#include "gadts.h"--module Darcs.Arguments ( DarcsFlag( .. ), flagToString, applyDefaults, nubOptions,-                         maxCount,-                         isin, arein,-                         setEnvDarcsPatches, setEnvDarcsFiles,-                         fixFilePathOrStd, fixUrl, fixUrlFlag,-                         fixSubPaths, maybeFixSubPaths,-                         DarcsAtomicOption( .. ), atomicOptions,-                         DarcsOption( .. ), optionFromDarcsOption,-                         help, listOptions, listFiles,-                         anyVerbosity, disable, restrictPaths,-                         notest, test, workingRepoDir,-                         remoteRepo,-                         leaveTestDir,-                         possiblyRemoteRepoDir, getRepourl,-                         listRegisteredFiles, listUnregisteredFiles,-                         author, getAuthor, getEasyAuthor, getSendmailCmd,-                         fileHelpAuthor, environmentHelpEmail,-                         patchnameOption, distnameOption,-                         logfile, rmlogfile, fromOpt, subject, getSubject,-                         charset, getCharset,-                         inReplyTo, getInReplyTo,-                         target, ccSend, ccApply, getCc, output, outputAutoName,-                         recursive, patchFormatChoices,-                         upgradeFormat, useWorkingDir,-                         askdeps, ignoretimes, lookforadds,-                         askLongComment, keepDate, sendmailCmd,-                         environmentHelpSendmail,-                         sign, verify, editDescription,-                         reponame, creatorhash,-                         applyConflictOptions, reply,-                         pullConflictOptions, useExternalMerge,-                         depsSel, nocompress,-                         uncompressNocompress, repoCombinator,-                         optionsLatex, reorderPatches,-                         noskipBoring, allowProblematicFilenames,-                         applyas, humanReadable, machineReadable,-                         changesReverse, onlyToFiles,-                         changesFormat, matchOneContext, matchOneNontag,-                         matchMaxcount,-                         sendToContext,-                         getContext,-                         pipeInteractive, allInteractive,-                         allPipeInteractive,-                         summary, unified, tokens,-                         partial,-                         diffCmdFlag, diffflags, unidiff, xmloutput,-                         pauseForGui,-                         forceReplace, dryRun, dryRunNoxml,-                         printDryRunMessageAndExit, showFriendly,-                         matchOne, matchSeveral, matchRange,-                         matchSeveralOrRange, happyForwarding,-                         matchSeveralOrLast,-                         setDefault,-                         setScriptsExecutableOption, bisect,-                         sibling, flagsToSiblings, relink,-                         files, directories, pending,-                         posthookCmd, posthookPrompt,-                         getPosthookCmd,-                         prehookCmd, prehookPrompt,-                         getPrehookCmd, nullFlag,-                         umaskOption,-                         storeInMemory,-                         patchSelectFlag,-                         networkOptions, noCache,-                         allowUnrelatedRepos,-                         checkOrRepair, justThisRepo, optimizePristine,-                         optimizeHTTP, getOutput, makeScriptsExecutable,-                         usePacks, recordRollback, amendUnrecord-                      ) where-import System.Console.GetOpt-import System.Directory ( doesDirectoryExist )--import Storage.Hashed.AnchoredPath( anchorPath )-import Storage.Hashed.Plain( readPlainTree )-import Storage.Hashed.Tree( list, expand, emptyTree )--import Data.List ( (\\), nub, intercalate )-import Data.Maybe ( fromMaybe, listToMaybe, maybeToList, isNothing, catMaybes,-                    mapMaybe )-import System.Exit ( ExitCode(ExitSuccess), exitWith )-import Control.Monad ( when, unless )-import Control.Applicative( (<$>) )-import Data.Char ( isDigit )-#ifndef WIN32-import Printer ( renderString )-import System.Posix.Env ( setEnv )-import Darcs.Patch ( listTouchedFiles )-import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )-#endif--import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( RepoPatch, Patchy, showNicely, description, xmlSummary )-import Darcs.Patch.Info ( toXml )-import Darcs.Witnesses.Ordered ( FL, mapFL )-import qualified Darcs.Patch ( summary )-import Darcs.Utils ( askUser, askUserListItem, maybeGetEnv, firstJustIO,-                     catchall,-                     withCurrentDirectory )-import Darcs.Repository.Prefs ( getPreflist, getGlobal, globalPrefsDirDoc )-import Darcs.Repository.State ( restrictBoring, applyTreeFilter, readRecordedAndPending )-import Darcs.Repository( setScriptsExecutablePatches )-import Darcs.URL ( isFile )-import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd, SubPath, toFilePath,-                        makeSubPathOf, ioAbsolute, ioAbsoluteOrStd,-                        makeAbsolute, makeAbsoluteOrStd )-import Darcs.Patch.MatchData ( patchMatch )-import Darcs.Flags ( DarcsFlag(..), maxCount, defaultFlag )-import Darcs.Repository ( withRepository, RepoJob(..) )-import Darcs.Global ( darcsdir )-import Darcs.Lock ( writeLocaleFile )-import Printer ( Doc, putDocLn, text, vsep, ($$), vcat, insertBeforeLastline,-                 prefix )-import ByteStringUtils ( decodeString )-import Storage.Hashed.Tree( Tree )-#include "impossible.h"--data FlagContent = NoContent | AbsoluteContent AbsolutePath | AbsoluteOrStdContent AbsolutePathOrStd | StringContent String-                   deriving (Eq, Show, Ord)---- getContent is very tedious to write, but this is the only way (that--- I know of) to guarantee that it works for all flags (which then--- guarantees that isAnAbsolute, isa, flagToString, etc also work--- properly)---- | 'getContentString' returns the content of a flag, if any.--- For instance, the content of @Author \"Louis Aragon\"@ is @StringContent--- \"Louis Aragon\"@, while the content of @Pipe@ is @NoContent@-getContent :: DarcsFlag -> FlagContent-getContent (PatchName s) = StringContent s-getContent (Output s) = AbsoluteOrStdContent s-getContent Verbose = NoContent-getContent Help = NoContent-getContent ListOptions = NoContent-getContent Test = NoContent-getContent NoTest = NoContent-getContent OnlyChangesToFiles = NoContent-getContent ChangesToAllFiles = NoContent-getContent LeaveTestDir = NoContent-getContent NoLeaveTestDir = NoContent-getContent Timings = NoContent-getContent Debug = NoContent-getContent DebugVerbose = NoContent-getContent DebugHTTP = NoContent-getContent NormalVerbosity = NoContent-getContent Quiet = NoContent-getContent (Target s) = StringContent s-getContent (Cc s) = StringContent s-getContent (Subject s) = StringContent s-getContent (Charset s) = StringContent s-getContent (InReplyTo s) = StringContent s-getContent (SendmailCmd s) = StringContent s-getContent (Author s) = StringContent s-getContent (OnePatch s) = StringContent s-getContent (SeveralPatch s) = StringContent s-getContent (AfterPatch s) = StringContent s-getContent (UpToPatch s) = StringContent s-getContent (TagName s) = StringContent s-getContent (LastN s) = StringContent (show s)-getContent (MaxCount s) = StringContent (show s)-getContent (OneTag s) = StringContent s-getContent (AfterTag s) = StringContent s-getContent (UpToTag s) = StringContent s-getContent (Context s) = AbsoluteContent s-getContent GenContext = NoContent-getContent (LogFile s) = AbsoluteContent s-getContent (OutputAutoName s) = AbsoluteContent s-getContent NumberPatches = NoContent-getContent (PatchIndexRange _ _) = NoContent -- FIXME this doesn't fit into a neat category-getContent Count = NoContent-getContent All = NoContent-getContent Recursive = NoContent-getContent NoRecursive = NoContent-getContent Reorder = NoContent-getContent RestrictPaths = NoContent-getContent DontRestrictPaths = NoContent-getContent AskDeps = NoContent-getContent NoAskDeps = NoContent-getContent RmLogFile = NoContent-getContent DontRmLogFile = NoContent-getContent (DistName s) = StringContent s-getContent (CreatorHash s) = StringContent s-getContent (SignAs s) = StringContent s-getContent (SignSSL s) = StringContent s-getContent (Verify s) = AbsoluteContent s-getContent (VerifySSL s) = AbsoluteContent s-getContent IgnoreTimes = NoContent-getContent DontIgnoreTimes = NoContent-getContent LookForAdds = NoContent-getContent NoLookForAdds = NoContent-getContent AnyOrder = NoContent-getContent Intersection = NoContent-getContent Unified = NoContent-getContent NonUnified = NoContent-getContent Union = NoContent-getContent Complement = NoContent-getContent Sign = NoContent-getContent NoSign = NoContent-getContent HappyForwarding = NoContent-getContent NoHappyForwarding = NoContent-getContent (RemoteDarcsOpt s) = StringContent s-getContent (Toks s) = StringContent s-getContent (WorkRepoDir s) = StringContent s-getContent (WorkRepoUrl s) = StringContent s-getContent (RemoteRepo s) = StringContent s-getContent (NewRepo s) = StringContent s-getContent (Reply s) = StringContent s-getContent EditDescription = NoContent-getContent NoEditDescription = NoContent-getContent EditLongComment = NoContent-getContent NoEditLongComment = NoContent-getContent PromptLongComment = NoContent-getContent KeepDate = NoContent-getContent NoKeepDate = NoContent-getContent AllowConflicts = NoContent-getContent MarkConflicts = NoContent-getContent NoAllowConflicts = NoContent-getContent SkipConflicts = NoContent-getContent Boring = NoContent-getContent SkipBoring = NoContent-getContent AllowCaseOnly = NoContent-getContent DontAllowCaseOnly = NoContent-getContent AllowWindowsReserved = NoContent-getContent DontAllowWindowsReserved = NoContent-getContent DontGrabDeps = NoContent-getContent DontPromptForDependencies = NoContent-getContent PromptForDependencies = NoContent-getContent Compress = NoContent-getContent NoCompress = NoContent-getContent UnCompress = NoContent-getContent MachineReadable = NoContent-getContent HumanReadable = NoContent-getContent Pipe = NoContent-getContent Interactive = NoContent-getContent Summary = NoContent-getContent NoSummary = NoContent-getContent (ApplyAs s) = StringContent s-getContent (DiffCmd s) = StringContent s-getContent (ExternalMerge s) = StringContent s-getContent PauseForGui = NoContent-getContent NoPauseForGui = NoContent-getContent (DiffFlags s) = StringContent s-getContent (OnePattern _) = NoContent -- FIXME!!!-getContent (SeveralPattern _) = NoContent -- FIXME!!!-getContent (UpToPattern _) = NoContent -- FIXME!!!-getContent (AfterPattern _) = NoContent -- FIXME!!!-getContent Reverse = NoContent-getContent Forward = NoContent-getContent Complete = NoContent-getContent Lazy = NoContent-getContent (FixFilePath _ _) = NoContent -- FIXME!!!-getContent XMLOutput = NoContent-getContent ForceReplace = NoContent-getContent NonApply = NoContent-getContent NonVerify = NoContent-getContent NonForce = NoContent-getContent DryRun = NoContent-getContent (SetDefault _) = NoContent-getContent (NoSetDefault _) = NoContent-getContent Disable = NoContent-getContent SetScriptsExecutable = NoContent-getContent DontSetScriptsExecutable = NoContent-getContent Bisect = NoContent-getContent UseHashedInventory = NoContent-getContent UseFormat2 = NoContent-getContent NoUpdateWorking = NoContent-getContent UpgradeFormat = NoContent-getContent Relink = NoContent-getContent Files = NoContent-getContent NoFiles = NoContent-getContent Directories = NoContent-getContent NoDirectories = NoContent-getContent Pending = NoContent-getContent NoPending = NoContent-getContent NoPosthook = NoContent-getContent AskPosthook = NoContent-getContent (Sibling s) = AbsoluteContent s-getContent (PosthookCmd s) = StringContent s-getContent RunPosthook = NoContent-getContent NoPrehook = NoContent-getContent RunPrehook = NoContent-getContent AskPrehook = NoContent-getContent StoreInMemory = NoContent-getContent ApplyOnDisk = NoContent-getContent NoHTTPPipelining = NoContent-getContent Packs = NoContent-getContent NoPacks = NoContent-getContent NoCache = NoContent-getContent NullFlag = NoContent-getContent (PrehookCmd s) = StringContent s-getContent (UMask s) = StringContent s-getContent AllowUnrelatedRepos = NoContent-getContent Check = NoContent-getContent Repair = NoContent-getContent JustThisRepo = NoContent-getContent OptimizePristine = NoContent-getContent OptimizeHTTP = NoContent-getContent RecordRollback = NoContent-getContent NoRecordRollback = NoContent-getContent AmendUnrecord = NoContent-getContent NoAmendUnrecord = NoContent-getContent UseWorkingDir = NoContent-getContent UseNoWorkingDir = NoContent--getContentString :: DarcsFlag -> Maybe String-getContentString f =-   do StringContent s <- Just $ getContent f-      return s---- | @a `'isa'` b@ tests whether @a@ is flag @b@ with a string argument.--- @b@ typically is a Flag constructor expecting a string--- For example, @(Author \"Ted Hughes\") `isa` Author@ returns true.-isa :: DarcsFlag -> (String -> DarcsFlag) -> Bool-a `isa` b = case getContentString a of-            Nothing -> False-            Just s -> a == b s---- | @a `'isAnAbsolute'` b@ tests whether @a@ is flag @b@ with an absolute path argument.--- @b@ typically is a Flag constructor expecting an absolute path argument--- For example, @(Context contextfile) `isAnAbsolute` Context@ returns true.-isAnAbsolute :: DarcsFlag -> (AbsolutePath -> DarcsFlag) -> Bool-isAnAbsolute f x = case getContent f of-                  AbsoluteContent s -> f == x s-                  _ -> False---- | @a `'isAnAbsoluteOrStd'` b@ tests whether @a@ is flag @b@ with a path argument.--- @b@ typically is a Flag constructor expecting a path argument--- For example, @(Output o) `isAnAbsoluteOrStd` @ returns true.-isAnAbsoluteOrStd :: DarcsFlag -> (AbsolutePathOrStd -> DarcsFlag) -> Bool-isAnAbsoluteOrStd f x = case getContent f of-                          AbsoluteOrStdContent s -> f == x s-                          _ -> False--isin :: DarcsAtomicOption -> [DarcsFlag] -> Bool-(DarcsInternalOption f)             `isin` fs = f `elem` fs-(DarcsNoArgOption _ _ f _)          `isin` fs = f `elem` fs-(DarcsArgOption _ _ f _ _)          `isin` fs = any (`isa` f) fs-(DarcsAbsPathOption _ _ f _ _)      `isin` fs = any (`isAnAbsolute` f) fs-(DarcsAbsPathOrStdOption _ _ f _ _) `isin` fs = any (`isAnAbsoluteOrStd` f) fs-(DarcsOptAbsPathOption _ _ _ f _ _) `isin` fs = any (`isAnAbsolute` f) fs--arein :: DarcsOption -> [DarcsFlag] -> Bool-o `arein` fs = any (`isin` fs) (atomicOptions o)---- | A type for darcs' options. The value contains the command line--- switch(es) for the option, a help string, and a function to build a--- @DarcsFlag@ from the command line arguments.  for each constructor,--- 'shortSwitches' represents the list of short command line switches--- which invoke the option, longSwitches the list of long command line--- switches, optDescr the description of the option, and argDescr the description--- of its argument, if any. mkFlag is a function which makes a @DarcsFlag@ from--- the arguments of the option.-data DarcsAtomicOption-    = DarcsArgOption [Char] [String] (String->DarcsFlag) String String-    -- ^ @DarcsArgOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@-    -- The constructor for options with a string argument, such as-    -- @--tag@--    | DarcsAbsPathOption [Char] [String] (AbsolutePath -> DarcsFlag) String String-    -- ^ @DarcsAbsPathOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@-    -- The constructor for options with an absolute path argument, such as-    -- @--sibling@--    | DarcsAbsPathOrStdOption [Char] [String] (AbsolutePathOrStd -> DarcsFlag) String String-    -- ^ @DarcsAbsPathOrStdOption shortSwitches longSwitches mkFlag ArgDescr OptDescr@-    -- The constructor for options with a path argument, such as @-o@--    | DarcsOptAbsPathOption [Char] [String] String (AbsolutePath -> DarcsFlag) String String-    -- ^ @DarcsOptAbsPathOrStdOption shortSwitches longSwitches defaultPath-    -- mkFlag ArgDescr OptDescr@ where defaultPath is a default value-    -- for the Path, as a string to be parsed as if it had been given-    -- on the command line.-    -- The constructor for options with an optional path argument, such as @-O@--    | DarcsNoArgOption [Char] [String] DarcsFlag String-    -- ^ @DarcsNoArgOption shortSwitches longSwitches mkFlag optDescr@-    -- The constructon fon options with no arguments.--    | DarcsInternalOption DarcsFlag-    -- ^ @DarcsInternalOption@-    -- An option just for internal use (e.g. defaulting), not directly available to the user.---data DarcsOption-    = DarcsSingleOption DarcsAtomicOption-    | DarcsMultipleChoiceOption [DarcsAtomicOption]-    -- ^ A constructor for grouping related options together, such as-    -- @--hashed@ and @--darcs-2@.--    | DarcsMutuallyExclusive [DarcsAtomicOption]          -- choices-                             ([DarcsFlag] -> [DarcsFlag]) -- setter--type NoArgPieces = (DarcsFlag -> String -> DarcsAtomicOption, DarcsFlag , String)--mkMutuallyExclusive :: [NoArgPieces] -- ^ before-                    -> NoArgPieces   -- ^ default-                    -> [NoArgPieces] -- ^ after-                    -> DarcsOption-mkMutuallyExclusive os1 od_ os2 =-  DarcsMutuallyExclusive (map option (os1 ++ (od : os2)))-                         (defaultFlag (map flag (os1 ++ os2)) (flag od))- where-  od = third (++ " [DEFAULT]") od_-  flag (_,f,_) = f-  option (x,y,z) = x y z-  third f (x,y,z) = (x,y,f z)--nubOptions :: [DarcsOption] -> [DarcsFlag] -> [DarcsFlag]-nubOptions [] opts = opts-nubOptions (DarcsMutuallyExclusive ch _:options) opts = nubOptions options $ collapse opts-  where collapse (x:xs) | x `elem` flags ch = x : clear xs-                        | otherwise = x : collapse xs-        collapse [] = []-        clear (x:xs) | x `elem` flags ch = clear xs-                     | otherwise = x : clear xs-        clear [] = []-        flags (DarcsNoArgOption _ _ fl _:xs) = fl : flags xs-        flags (DarcsInternalOption fl:xs) = fl : flags xs-        flags (_:xs) = flags xs-        flags [] = []-nubOptions (_:options) opts = nubOptions options opts--applyDefaults :: [DarcsOption] -> [DarcsFlag] -> [DarcsFlag]-applyDefaults opts = foldr (.) id (mapMaybe getSetter opts)- where-  getSetter (DarcsMutuallyExclusive _ f) = Just f-  getSetter _ = Nothing--optionFromDarcsAtomicOption :: AbsolutePath -> DarcsAtomicOption -> Maybe (OptDescr DarcsFlag)-optionFromDarcsAtomicOption _ (DarcsInternalOption _) = Nothing-optionFromDarcsAtomicOption _ (DarcsNoArgOption a b c h) = Just $ Option a b (NoArg c) h-optionFromDarcsAtomicOption _ (DarcsArgOption a b c n h) = Just $ Option a b (ReqArg c n) h-optionFromDarcsAtomicOption wd (DarcsAbsPathOrStdOption a b c n h) =-  Just $ Option a b (ReqArg (c . makeAbsoluteOrStd wd) n) h-optionFromDarcsAtomicOption wd (DarcsAbsPathOption a b c n h) =-  Just $ Option a b (ReqArg (c . makeAbsolute wd) n) h-optionFromDarcsAtomicOption wd (DarcsOptAbsPathOption a b d c n h) =-  Just $ Option a b (OptArg (c . makeAbsolute wd . fromMaybe d) n) h--atomicOptions :: DarcsOption -> [DarcsAtomicOption]-atomicOptions (DarcsSingleOption x) = [x]-atomicOptions (DarcsMultipleChoiceOption xs) = xs-atomicOptions (DarcsMutuallyExclusive xs _) = xs--optionFromDarcsOption :: AbsolutePath -> DarcsOption -> [OptDescr DarcsFlag]-optionFromDarcsOption wd = mapMaybe (optionFromDarcsAtomicOption wd) . atomicOptions---- | 'concat_option' creates a DarcsMultipleChoiceOption from a list of--- option, flattening any DarcsMultipleChoiceOption in the list.-concatOptions :: [DarcsOption] -> DarcsOption-concatOptions = DarcsMultipleChoiceOption . concatMap atomicOptions--extractFixPath :: [DarcsFlag] -> Maybe (AbsolutePath, AbsolutePath)-extractFixPath [] = Nothing-extractFixPath ((FixFilePath repo orig):_)  = Just (repo, orig)-extractFixPath (_:fs) = extractFixPath fs--fixFilePath :: [DarcsFlag] -> FilePath -> IO AbsolutePath-fixFilePath opts f = case extractFixPath opts of-                       Nothing -> bug "Can't fix path in fixFilePath"-                       Just (_,o) -> withCurrentDirectory o $ ioAbsolute f--fixFilePathOrStd :: [DarcsFlag] -> FilePath -> IO AbsolutePathOrStd-fixFilePathOrStd opts f =-    case extractFixPath opts of-      Nothing -> bug "Can't fix path in fixFilePathOrStd"-      Just (_,o) -> withCurrentDirectory o $ ioAbsoluteOrStd f--fixUrlFlag :: [DarcsFlag] -> DarcsFlag -> IO DarcsFlag-fixUrlFlag opts (RemoteRepo f) = RemoteRepo `fmap` fixUrl opts f-fixUrlFlag _ f = return f--fixUrl :: [DarcsFlag] -> String -> IO String-fixUrl opts f = if isFile f-                then toFilePath `fmap` fixFilePath opts f-                else return f---- | @maybeFixSubPaths files@ tries to turn the file paths in its argument into--- @SubPath@s.------ When converting a relative path to an absolute one, this function first tries--- to interpret the relative path with respect to the current working directory.--- If that fails, it tries to interpret it with respect to the repository--- directory. Only when that fails does it put a @Nothing@ in the result at the--- position of the path that cannot be converted.------ It is intended for validating file arguments to darcs commands.-maybeFixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [Maybe SubPath]-maybeFixSubPaths flags fs = withCurrentDirectory o $ do-  fixedFs <- mapM fixit fs-  let bads = snd . unzip . filter (isNothing . fst) $ zip fixedFs fs-  unless (null bads) . putStrLn $ "Ignoring non-repository paths: " ++-    intercalate ", " bads-  return fixedFs- where-    (r,o) = case extractFixPath flags of-            Just xxx -> xxx-            Nothing -> bug "Can't fix path in fixSubPaths"-    fixit p = do ap <- ioAbsolute p-                 case makeSubPathOf r ap of-                   Just sp -> return $ Just sp-                   Nothing -> withCurrentDirectory r $ do-                     absolutePathByRepodir <- ioAbsolute p-                     return $ makeSubPathOf r absolutePathByRepodir---- | @fixSubPaths files@ returns the @SubPath@s for the paths in @files@ that--- are inside the repository, preserving their order. Paths in @files@ that are--- outside the repository directory are not in the result.------ When converting a relative path to an absolute one, this function first tries--- to interpret the relative path with respect to the current working directory.--- If that fails, it tries to interpret it with respect to the repository--- directory. Only when that fails does it omit the path from the result.------ It is intended for validating file arguments to darcs commands.-fixSubPaths :: [DarcsFlag] -> [FilePath] -> IO [SubPath]-fixSubPaths flags fs = nub . catMaybes <$> (maybeFixSubPaths flags $-  filter (not . null) fs)---- | 'list_option' is an option which lists the command's arguments-listOptions :: DarcsOption-listOptions = DarcsSingleOption $ DarcsNoArgOption [] ["list-options"] ListOptions-               "simply list the command's arguments"--flagToString :: [DarcsOption] -> DarcsFlag -> Maybe String-flagToString x f = listToMaybe $ mapMaybe f2o $ concatMap atomicOptions x-    where f2o (DarcsArgOption _ (s:_) c _ _) =-            do arg <- getContentString f-               if c arg == f-                  then return $ unwords [('-':'-':s), arg]-                  else Nothing-          f2o (DarcsNoArgOption _ (s:_) f' _) | f == f' = Just ('-':'-':s)-          f2o _ = Nothing--pipeInteractive, allPipeInteractive, allInteractive,-  humanReadable, machineReadable,-  diffflags, allowProblematicFilenames, noskipBoring,-  askLongComment, matchOneNontag, changesReverse, creatorhash,-  changesFormat, matchOneContext, happyForwarding, sendToContext,-  diffCmdFlag, storeInMemory, useExternalMerge,-  pauseForGui,-  pullConflictOptions, target, ccSend, ccApply, applyConflictOptions, reply, xmloutput,-  distnameOption, patchnameOption, editDescription,-  output, outputAutoName, unidiff, repoCombinator,-  unified, summary, uncompressNocompress, subject, charset, inReplyTo,-  nocompress, matchSeveralOrRange, matchSeveralOrLast,-  author, askdeps, lookforadds, ignoretimes, test, notest, help, forceReplace,-  allowUnrelatedRepos,-  matchOne, matchRange, matchSeveral, sendmailCmd,-  logfile, rmlogfile, leaveTestDir, fromOpt,  recordRollback, amendUnrecord-      :: DarcsOption--sign, applyas, verify :: DarcsOption--help = DarcsSingleOption $ DarcsNoArgOption ['h'] ["help"] Help-       "shows brief description of command and its arguments"--disable :: DarcsOption-disable = DarcsSingleOption $ DarcsNoArgOption [] ["disable"] Disable-        "disable this command"--anyVerbosity :: [DarcsOption]-anyVerbosity =[DarcsMultipleChoiceOption-                [DarcsNoArgOption [] ["debug"] Debug-                 "give only debug output",-                 DarcsNoArgOption [] ["debug-verbose"] DebugVerbose-                 "give debug and verbose output",-                 DarcsNoArgOption [] ["debug-http"] DebugHTTP-                 "give debug output for libcurl",-                 DarcsNoArgOption ['v'] ["verbose"] Verbose-                 "give verbose output",-                 DarcsNoArgOption ['q'] ["quiet"] Quiet-                 "suppress informational output",-                 DarcsNoArgOption [] ["standard-verbosity"] NormalVerbosity-                 "neither verbose nor quiet output"],-               DarcsSingleOption-                (DarcsNoArgOption [] ["timings"] Timings "provide debugging timings information")]--workingRepoDir :: DarcsOption-workingRepoDir = DarcsSingleOption $ DarcsArgOption [] ["repodir"] WorkRepoDir "DIRECTORY"-             "specify the repository directory in which to run"--possiblyRemoteRepoDir :: DarcsOption-possiblyRemoteRepoDir = DarcsSingleOption $ DarcsArgOption [] ["repo"] WorkRepoUrl "URL"-             "specify the repository URL"---- | 'getRepourl' takes a list of flags and returns the url of the--- repository specified by @Repodir \"directory\"@ in that list of flags, if any.--- This flag is present if darcs was invoked with @--repodir=DIRECTORY@-getRepourl :: [DarcsFlag] -> Maybe String-getRepourl [] = Nothing-getRepourl (WorkRepoUrl d:_) | not (isFile d) = Just d-getRepourl (_:fs) = getRepourl fs---- | 'remoteRepo' is the option used to specify the URL of the remote--- repository to work with-remoteRepo :: DarcsOption-remoteRepo = DarcsSingleOption $ DarcsArgOption [] ["remote-repo"] RemoteRepo "URL"-             "specify the remote repository URL to work with"--patchnameOption = DarcsSingleOption $ DarcsArgOption ['m'] ["name"]-                   (PatchName . decodeString) "PATCHNAME" "name of patch"--sendToContext = DarcsSingleOption $ DarcsAbsPathOption [] ["context"] Context "FILENAME"-                  "send to context stored in FILENAME"--matchOneContext =-    DarcsMultipleChoiceOption-    [DarcsArgOption [] ["to-match"] mp "PATTERN"-     "select changes up to a patch matching PATTERN",-     DarcsArgOption [] ["to-patch"] OnePatch "REGEXP"-     "select changes up to a patch matching REGEXP",-     __tag,-     DarcsAbsPathOption [] ["context"] Context "FILENAME"-     "version specified by the context in FILENAME"-    ]-    where mp s = OnePattern (patchMatch s)--matchOne = DarcsMultipleChoiceOption [__match, __patch, __tag, __index]-                                            -- [NOTE --index removed from matchOneNontag because issue1926]-                                            -- The --index option was removed for 2.5 release because it isn't handled-                                            -- by amend-record (see issue1926).-                                            ---                                            -- At this moment, amend-record is the only command that uses 'matchOneNontag',-                                            -- so there is no other command affected.-matchOneNontag  = DarcsMultipleChoiceOption [__match, __patch {- , __index -} ]-matchSeveral    = DarcsMultipleChoiceOption [__matches, __patches, __tags]-matchRange      = concatOptions $ [ matchTo, matchFrom-                                  , DarcsMultipleChoiceOption [__match, __patch, __last, __indexes] ]-matchSeveralOrRange = concatOptions [ matchTo, matchFrom-                                    , DarcsMultipleChoiceOption [ __last, __indexes, __matches, __patches, __tags] ]-matchSeveralOrLast  = concatOptions [ matchFrom-                                    , DarcsMultipleChoiceOption [ __last, __matches, __patches, __tags] ]--matchTo, matchFrom :: DarcsOption-matchTo = DarcsMultipleChoiceOption-            [DarcsArgOption [] ["to-match"] uptop "PATTERN"-             "select changes up to a patch matching PATTERN",-             DarcsArgOption [] ["to-patch"] UpToPatch "REGEXP"-             "select changes up to a patch matching REGEXP",-             DarcsArgOption [] ["to-tag"] UpToTag "REGEXP"-             "select changes up to a tag matching REGEXP"]-    where uptop s = UpToPattern (patchMatch s)-matchFrom = DarcsMultipleChoiceOption-              [DarcsArgOption [] ["from-match"] fromp "PATTERN"-               "select changes starting with a patch matching PATTERN",-               DarcsArgOption [] ["from-patch"] AfterPatch "REGEXP"-               "select changes starting with a patch matching REGEXP",-               DarcsArgOption [] ["from-tag"] AfterTag "REGEXP"-               "select changes starting with a tag matching REGEXP"]-    where fromp s = AfterPattern (patchMatch s)--__tag, __tags, __patch, __patches, __match, __matches, __last, __index, __indexes :: DarcsAtomicOption--__tag = DarcsArgOption ['t'] ["tag"] OneTag "REGEXP"-       "select tag matching REGEXP"-__tags = DarcsArgOption ['t'] ["tags"] OneTag "REGEXP"-        "select tags matching REGEXP"--__patch = DarcsArgOption ['p'] ["patch"] OnePatch "REGEXP"-         "select a single patch matching REGEXP"-__patches = DarcsArgOption ['p'] ["patches"] SeveralPatch "REGEXP"-           "select patches matching REGEXP"--__match = DarcsArgOption [] ["match"] mp "PATTERN"-         "select a single patch matching PATTERN"-  where mp s = OnePattern (patchMatch s)-__matches = DarcsArgOption [] ["matches"] mp "PATTERN"-           "select patches matching PATTERN"-  where mp s = SeveralPattern (patchMatch s)--__last = DarcsArgOption [] ["last"] lastn "NUMBER"-         "select the last NUMBER patches"-    where lastn = LastN . numberString--__index = DarcsArgOption ['n'] ["index"] indexrange "N" "select one patch"-    where indexrange s = if all isDigit s-                         then PatchIndexRange (read s) (read s)-                         else PatchIndexRange 0 0--__indexes = DarcsArgOption ['n'] ["index"] indexrange "N-M" "select a range of patches"-    where indexrange s = if all isokay s-                         then if '-' `elem` s-                              then let x1 = takeWhile (/= '-') s-                                       x2 = reverse $ takeWhile (/= '-') $ reverse s-                                   in PatchIndexRange (read x1) (read x2)-                              else PatchIndexRange (read s) (read s)-                         else PatchIndexRange 0 0-          isokay c = isDigit c || c == '-'--matchMaxcount :: DarcsOption-matchMaxcount = DarcsSingleOption $ DarcsArgOption [] ["max-count"] mc "NUMBER"-         "return only NUMBER results"-    where mc = MaxCount . numberString----- | 'getContext' takes a list of flags and returns the context--- specified by @Context c@ in that list of flags, if any.--- This flag is present if darcs was invoked with @--context=FILE@-getContext :: [DarcsFlag] -> Maybe AbsolutePath-getContext xs = listToMaybe [ c | Context c <- xs ]--notest = DarcsMultipleChoiceOption-         [DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script",-          DarcsNoArgOption [] ["test"] Test "run the test script"]-test = DarcsMultipleChoiceOption-          [DarcsNoArgOption [] ["test"] Test "run the test script",-           DarcsNoArgOption [] ["no-test"] NoTest "don't run the test script"]-leaveTestDir = DarcsMultipleChoiceOption-                 [DarcsNoArgOption [] ["leave-test-directory"]-                  LeaveTestDir "don't remove the test directory",-                  DarcsNoArgOption [] ["remove-test-directory"]-                  NoLeaveTestDir "remove the test directory"]--recordRollback = DarcsMultipleChoiceOption-                 [DarcsNoArgOption [] ["record"]-                  RecordRollback "record the rollback patch (default)",-                  DarcsNoArgOption [] ["no-record"]-                  NoRecordRollback "don't record the rollback patch (only roll back in working dir)"]--amendUnrecord = DarcsMultipleChoiceOption-                [DarcsNoArgOption [] ["add"]-                 NoAmendUnrecord "add the changes to patch (default)",-                 DarcsNoArgOption [] ["unrecord"]-                 AmendUnrecord "subtract the changes from patch"]--ignoretimes =-    DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["ignore-times"] IgnoreTimes-                         "don't trust the file modification times"-    ,DarcsNoArgOption [] ["no-ignore-times"] DontIgnoreTimes-                      "trust modification times to find modified files [DEFAULT]"-    ]--lookforadds =-    DarcsMultipleChoiceOption-    [DarcsNoArgOption ['l'] ["look-for-adds"] LookForAdds-     "look for (non-boring) files that could be added",-     DarcsNoArgOption [] ["dont-look-for-adds","no-look-for-adds"] NoLookForAdds-     "don't look for any files that could be added [DEFAULT]"]--askdeps =-    DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["ask-deps"] AskDeps-     "ask for extra dependencies",-     DarcsNoArgOption [] ["no-ask-deps"] NoAskDeps-     "don't ask for extra dependencies"]--askLongComment =-    DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["edit-long-comment"] EditLongComment-     "edit the long comment by default",-     DarcsNoArgOption [] ["skip-long-comment"] NoEditLongComment-     "don't give a long comment",-     DarcsNoArgOption [] ["prompt-long-comment"] PromptLongComment-     "prompt for whether to edit the long comment"]--keepDate :: DarcsOption-keepDate =-    DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["keep-date"] KeepDate-     "keep the date of the original patch",-     DarcsNoArgOption [] ["no-keep-date"] NoKeepDate-     "use the current date for the amended patch"-    ]--logfile = DarcsSingleOption $ DarcsAbsPathOption [] ["logfile"] LogFile "FILE"-          "give patch name and comment in file"--rmlogfile = DarcsMultipleChoiceOption-            [DarcsNoArgOption [] ["delete-logfile"] RmLogFile-            "delete the logfile when done",-             DarcsNoArgOption [] ["no-delete-logfile"] DontRmLogFile-            "keep the logfile when done [DEFAULT]"]--author = DarcsSingleOption $-  DarcsArgOption ['A'] ["author"] (Author . decodeString) "EMAIL" "specify author id"-fromOpt = DarcsSingleOption $-  DarcsArgOption [] ["from"] (Author . decodeString) "EMAIL" "specify email address"--fileHelpAuthor :: [String]-fileHelpAuthor = [- "Each patch is attributed to its author, usually by email address (for",- "example, `Fred Bloggs <fred@example.net>').  Darcs looks in several",- "places for this author string: the --author option, the files",- "_darcs/prefs/author (in the repository) and " ++ globalPrefsDirDoc ++ "author (in your",- "home directory), and the environment variables $DARCS_EMAIL and",- "$EMAIL.  If none of those exist, Darcs will prompt you for an author",- "string and write it to _darcs/prefs/author.  Note that if if you have more",- "than one email address, note that you can put them all in " ++ globalPrefsDirDoc ++ "author,",- "one author per line.  Darcs will still prompt you for an author, but it",- "allows you to select from the list, or to type in an alternative."- ]--environmentHelpEmail :: ([String], [String])-environmentHelpEmail = (["DARCS_EMAIL","EMAIL"], fileHelpAuthor)---- | 'getAuthor' takes a list of flags and returns the author of the--- change specified by @Author \"Leo Tolstoy\"@ in that list of flags, if any.--- Otherwise, if @Pipe@ is present, asks the user who is the author and--- returns the answer. If neither are present, try to guess the author,--- from @_darcs/prefs@, and if it's not possible, ask the user.-getAuthor :: [DarcsFlag] -> IO String-getAuthor (Author a:_) = return a-getAuthor (Pipe:_) = askUser "Who is the author? "-getAuthor (_:flags) = getAuthor flags-getAuthor [] = do-  easy_author <- getEasyAuthor-  case easy_author of-    [a] -> return a-    []  -> askForAuthor shortPrompt longPrompt-    as  -> askForAuthor (fancyPrompt as) (fancyPrompt as)- where-  shortPrompt = askUser "What is your email address? "-  longPrompt  = askUser "What is your email address (e.g. Fred Bloggs <fred@example.net>)? "-  fancyPrompt xs =-    do putDocLn $ text "" $$-                  text "You have saved the following email addresses to your global settings:"-       str <- askUserListItem "Please select an email address for this repository: " (xs ++ ["Other"])-       if str == "Other"-          then longPrompt-          else return str-  askForAuthor askfn1 askfn2 = do-      aminrepo <- doesDirectoryExist (darcsdir++"/prefs")-      if aminrepo then do-          putDocLn $-            text "Each patch is attributed to its author, usually by email address (for" $$-            text "example, `Fred Bloggs <fred@example.net>').  Darcs could not determine" $$-            text "your email address, so you will be prompted for it." $$-            text "" $$-            text ("Your address will be stored in " ++ darcsdir ++ "/prefs/author.") $$-            text "It will be used for all patches recorded in this repository." $$-            text ("If you move that file to " ++ globalPrefsDirDoc ++ "author, it will be used for patches") $$-            text "you record in ALL repositories."-          add <- askfn1-          writeLocaleFile (darcsdir ++ "/prefs/author") $-                          unlines ["# " ++ line | line <- fileHelpAuthor] ++ "\n" ++ add-          return add-        else askfn2---- | 'getEasyAuthor' tries to get the author name first from the repository preferences,--- then from global preferences, then from environment variables.  Returns @[]@--- if it could not get it.  Note that it may only return multiple possibilities when--- reading from global preferences-getEasyAuthor :: IO [String]-getEasyAuthor = fmap (map decodeString) $-  firstNotNullIO [ (take 1 . nonblank) `fmap` getPreflist "author"-                 , nonblank    `fmap` getGlobal "author"-                 , maybeToList `fmap` maybeGetEnv "DARCS_EMAIL"-                 , maybeToList `fmap` maybeGetEnv "EMAIL"-                 ]- where-  nonblank = filter (not . null)-  -- this could perhaps be simplified with Control.Monad-  -- but note that we do NOT want to concatenate the results-  firstNotNullIO [] = return []-  firstNotNullIO (e:es) = do-    v <- e `catchall` return []-    if null v then firstNotNullIO es else return v--nocompress = DarcsMultipleChoiceOption [__compress, __dontCompress]-uncompressNocompress = DarcsMultipleChoiceOption [__compress, __dontCompress, __uncompress]--__compress, __dontCompress, __uncompress :: DarcsAtomicOption-__compress = DarcsNoArgOption [] ["compress"] Compress-            "create compressed patches"-__dontCompress = DarcsNoArgOption [] ["dont-compress","no-compress"] NoCompress-                  "don't create compressed patches"-__uncompress = DarcsNoArgOption [] ["uncompress"] UnCompress-               "uncompress patches"--summary = DarcsMultipleChoiceOption-          [DarcsNoArgOption ['s'] ["summary"] Summary "summarize changes",-           DarcsNoArgOption [] ["no-summary"] NoSummary "don't summarize changes"]-unified = DarcsMultipleChoiceOption-          [DarcsNoArgOption ['u'] ["unified"] Unified-          "output changes in a darcs-specific format similar to diff -u",-           DarcsNoArgOption  [] ["no-unified"] NonUnified-          "output changes in darcs' usual format"]--unidiff = DarcsMultipleChoiceOption-          [DarcsNoArgOption ['u'] ["unified"] Unified-          "pass -u option to diff [DEFAULT]",-           DarcsNoArgOption  [] ["no-unified"] NonUnified-          "output patch in diff's dumb format"]--diffCmdFlag = DarcsSingleOption $-  DarcsArgOption [] ["diff-command"] DiffCmd "COMMAND" "specify diff command (ignores --diff-opts)"--pauseForGui = DarcsMultipleChoiceOption-    [ DarcsNoArgOption-        []-        ["pause-for-gui"]-        PauseForGui-        "pause for an external diff or merge command to finish [DEFAULT]"-    , DarcsNoArgOption-        []-        ["no-pause-for-gui"]-        NoPauseForGui-        "return immediately after external diff or merge command finishes"-    ]--storeInMemory = DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["store-in-memory"] StoreInMemory-     "do patch application in memory rather than on disk",-     DarcsNoArgOption [] ["no-store-in-memory"] ApplyOnDisk-     "do patch application on disk [DEFAULT]"]--target = DarcsSingleOption $-  DarcsArgOption [] ["to"] Target "EMAIL" "specify destination email"-ccSend = DarcsSingleOption $-  DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s)"-ccApply = DarcsSingleOption $-  DarcsArgOption [] ["cc"] Cc "EMAIL" "mail results to additional EMAIL(s). Requires --reply"---- |'getCc' takes a list of flags and returns the addresses to send a copy of--- the patch bundle to when using @darcs send@.--- looks for a cc address specified by @Cc \"address\"@ in that list of flags.--- Returns the addresses as a comma separated string.-getCc :: [DarcsFlag] -> String-getCc fs = lt $ mapMaybe whatcc fs-            where whatcc (Cc t) = Just t-                  whatcc _ = Nothing-                  lt [t] = t-                  lt [t,""] = t-                  lt (t:ts) = t++" , "++lt ts-                  lt [] = ""--subject = DarcsSingleOption $ DarcsArgOption [] ["subject"] Subject "SUBJECT" "specify mail subject"---- |'getSubject' takes a list of flags and returns the subject of the mail--- to be sent by @darcs send@. Looks for a subject specified by--- @Subject \"subject\"@ in that list of flags, if any.--- This flag is present if darcs was invoked with @--subject=SUBJECT@-getSubject :: [DarcsFlag] -> Maybe String-getSubject (Subject s:_) = Just s-getSubject (_:fs) = getSubject fs-getSubject [] = Nothing--charset = DarcsSingleOption $ DarcsArgOption [] ["charset"] Charset "CHARSET" "specify mail charset"--getCharset :: [DarcsFlag] -> Maybe String-getCharset (Charset s:_) = Just s-getCharset (_:fs) = getCharset fs-getCharset [] = Nothing--inReplyTo = DarcsSingleOption $ DarcsArgOption [] ["in-reply-to"] InReplyTo "EMAIL" "specify in-reply-to header"-getInReplyTo :: [DarcsFlag] -> Maybe String-getInReplyTo (InReplyTo s:_) = Just s-getInReplyTo (_:fs) = getInReplyTo fs-getInReplyTo [] = Nothing--output = DarcsSingleOption $ DarcsAbsPathOrStdOption ['o'] ["output"] Output "FILE"-         "specify output filename"--outputAutoName = DarcsSingleOption $-                   DarcsOptAbsPathOption ['O'] ["output-auto-name"] "." OutputAutoName "DIRECTORY"-                   "output to automatically named file in DIRECTORY, default: current directory"--getOutput :: [DarcsFlag] -> FilePath -> Maybe AbsolutePathOrStd-getOutput (Output a:_) _ = return a-getOutput (OutputAutoName a:_) f = return $ makeAbsoluteOrStd a f-getOutput (_:flags) f = getOutput flags f-getOutput [] _ = Nothing--editDescription = mkMutuallyExclusive [] yes [no]- where-  yes = ( DarcsNoArgOption [] ["edit-description"]-        , EditDescription-        , "edit the patch bundle description" )-  no  = ( DarcsNoArgOption [] ["dont-edit-description","no-edit-description"]-        , NoEditDescription-        , "don't edit the patch bundle description" )--distnameOption = DarcsSingleOption $-  DarcsArgOption ['d'] ["dist-name"] DistName "DISTNAME" "name of version"--recursive :: String -> DarcsOption-recursive h-    = DarcsMultipleChoiceOption-      [DarcsNoArgOption ['r'] ["recursive"] Recursive h,-       DarcsNoArgOption [] ["not-recursive","no-recursive"] NoRecursive ("don't "++h)]--patchFormatChoices :: DarcsOption-patchFormatChoices =-    DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["hashed"] UseHashedInventory-                          "Some new features. Compatible with older repos",-     DarcsNoArgOption [] ["darcs-2"] UseFormat2-                          "All features. Related repos must use same format [DEFAULT]."]--useWorkingDir :: DarcsOption-useWorkingDir =-  DarcsMultipleChoiceOption-  [ DarcsNoArgOption [] ["with-working-dir"] UseWorkingDir-                         "Create a working directory (normal repository)",-    DarcsNoArgOption [] ["no-working-dir"] UseNoWorkingDir-                           "Do not create a working directory (bare repository)"]--upgradeFormat :: DarcsOption-upgradeFormat = DarcsSingleOption $-    DarcsNoArgOption [] ["upgrade"] UpgradeFormat-         "upgrade repository to latest compatible format"--xmloutput = DarcsSingleOption $-  DarcsNoArgOption [] ["xml-output"] XMLOutput "generate XML formatted output"--creatorhash = DarcsSingleOption $-  DarcsArgOption [] ["creator-hash"] CreatorHash "HASH" "specify hash of creator patch (see docs)"--sign = DarcsMultipleChoiceOption-       [DarcsNoArgOption [] ["sign"] Sign-        "sign the patch with your gpg key",-        DarcsArgOption [] ["sign-as"] SignAs "KEYID"-        "sign the patch with a given keyid",-        DarcsArgOption [] ["sign-ssl"] SignSSL "IDFILE"-        "sign the patch using openssl with a given private key",-        DarcsNoArgOption [] ["dont-sign","no-sign"] NoSign-        "don't sign the patch"]-applyas = DarcsMultipleChoiceOption-           [DarcsArgOption [] ["apply-as"] ApplyAs "USERNAME"-            "apply patch as another user using sudo",-            DarcsNoArgOption [] ["no-apply-as"] NonApply-            "don't use sudo to apply as another user [DEFAULT]"]--happyForwarding = DarcsMultipleChoiceOption-                   [DarcsNoArgOption [] ["happy-forwarding"] HappyForwarding-                   "forward unsigned messages without extra header",-                    DarcsNoArgOption [] ["no-happy-forwarding"] NoHappyForwarding-                   "don't forward unsigned messages without extra header [DEFAULT]"]--setDefault :: Bool -> DarcsOption-setDefault wantYes-  | wantYes   = mkMutuallyExclusive [yes,no] defaultyes []-  | otherwise = mkMutuallyExclusive [yes,no] defaultno  []- where-  yes = ( DarcsNoArgOption [] ["set-default"], SetDefault True-        , "set default repository" ++ defaultText wantYes )-  no  = ( DarcsNoArgOption [] ["no-set-default"], NoSetDefault True-        , "don't set default repository" ++ defaultText (not wantYes) )-  defaultyes = ( \f _ -> DarcsInternalOption f, SetDefault False, "" )-  defaultno = ( \f _ -> DarcsInternalOption f, NoSetDefault False, "" )-  defaultText True = " [DEFAULT]"-  defaultText False = ""--verify = DarcsMultipleChoiceOption-         [DarcsAbsPathOption [] ["verify"] Verify "PUBRING"-          "verify that the patch was signed by a key in PUBRING",-          DarcsAbsPathOption [] ["verify-ssl"] VerifySSL "KEYS"-          "verify using openSSL with authorized keys from file KEYS",-          DarcsNoArgOption [] ["no-verify"] NonVerify-          "don't verify patch signature"]--reponame :: DarcsOption-reponame = DarcsSingleOption $-           DarcsArgOption [] ["repo-name","repodir"] NewRepo "DIRECTORY"-           "path of output directory" --repodir is there for compatibility-                                      --should be removed eventually-depsSel :: DarcsOption-depsSel = DarcsMultipleChoiceOption-       [DarcsNoArgOption [] ["no-deps"] DontGrabDeps-        "don't automatically fulfill dependencies",-        DarcsNoArgOption [] ["dont-prompt-for-dependencies"] DontPromptForDependencies-        "don't ask about patches that are depended on by matched patches (with --match or --patch)",-        DarcsNoArgOption [] ["prompt-for-dependencies"] PromptForDependencies-        "prompt about patches that are depended on by matched patches [DEFAULT]"]--tokens :: DarcsOption-tokens = DarcsSingleOption $-         DarcsArgOption [] ["token-chars"] Toks "\"[CHARS]\""-         "define token to contain these characters"--partial :: DarcsOption-partial       = DarcsMultipleChoiceOption [__lazy, __complete]--__lazy, __complete :: DarcsAtomicOption-__lazy = DarcsNoArgOption [] ["lazy"] Lazy-              "get patch files only as needed"-__complete = DarcsNoArgOption [] ["complete"] Complete-             "get a complete copy of the repository"--forceReplace = DarcsMultipleChoiceOption-                [DarcsNoArgOption ['f'] ["force"] ForceReplace-                 "proceed with replace even if 'new' token already exists",-                 DarcsNoArgOption [] ["no-force"]-                 NonForce "don't force the replace if it looks scary"]--reply = DarcsSingleOption $-  DarcsArgOption [] ["reply"] Reply "FROM" "reply to email-based patch using FROM address"-applyConflictOptions-    = DarcsMultipleChoiceOption-      [DarcsNoArgOption [] ["mark-conflicts"]-       MarkConflicts "mark conflicts",-       DarcsNoArgOption [] ["allow-conflicts"]-       AllowConflicts "allow conflicts, but don't mark them",-       DarcsNoArgOption [] ["no-resolve-conflicts"] NoAllowConflicts-       "equivalent to --dont-allow-conflicts, for backwards compatibility",-       DarcsNoArgOption [] ["dont-allow-conflicts","no-allow-conflicts"]-       NoAllowConflicts "fail if there are patches that would create conflicts [DEFAULT]",-       DarcsNoArgOption [] ["skip-conflicts"]-       SkipConflicts "filter out any patches that would create conflicts"-      ]-pullConflictOptions-    = DarcsMultipleChoiceOption-      [DarcsNoArgOption [] ["mark-conflicts"]-       MarkConflicts "mark conflicts [DEFAULT]",-       DarcsNoArgOption [] ["allow-conflicts"]-       AllowConflicts "allow conflicts, but don't mark them",-       DarcsNoArgOption [] ["dont-allow-conflicts","no-allow-conflicts"]-       NoAllowConflicts "fail if there are patches that would create conflicts",-       DarcsNoArgOption [] ["skip-conflicts"]-       SkipConflicts "filter out any patches that would create conflicts"-      ]-useExternalMerge = DarcsSingleOption $-  DarcsArgOption [] ["external-merge"] ExternalMerge "COMMAND"-    "use external tool to merge conflicts"---- NOTE: I'd rather work to have no uses of dryRunNoxml, so that any time--- --dry-run is a possibility, automated users can examine the results more--- easily with --xml.-dryRunNoxml :: DarcsOption-dryRunNoxml = DarcsSingleOption $-  DarcsNoArgOption [] ["dry-run"] DryRun "don't actually take the action"--dryRun :: [DarcsOption]-dryRun = [dryRunNoxml, xmloutput]---- | @'showFriendly' flags patch@ returns a 'Doc' representing the right--- way to show @patch@ given the list @flags@ of flags darcs was invoked with.-showFriendly :: Patchy p => [DarcsFlag] -> p C(x y) -> Doc-showFriendly opts p | Verbose `elem` opts = showNicely p-                    | Summary `elem` opts = Darcs.Patch.summary p-                    | otherwise           = description p---- | @'printDryRunMessageAndExit' action opts patches@ prints a string--- representing the action that would be taken if the @--dry-run@ option--- had not been passed to darcs. Then darcs exits successfully.--- @action@ is the name of the action being taken, like @\"push\"@--- @opts@ is the list of flags which were sent to darcs--- @patches@ is the sequence of patches which would be touched by @action@.-printDryRunMessageAndExit :: (RepoPatch p, ApplyState p ~ Tree) => String -> [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> IO ()-printDryRunMessageAndExit action opts patches =-     do when (DryRun `elem` opts) $ do-          putInfo $ text $ "Would " ++ action ++ " the following changes:"-          putDocLn $ put_mode-          putInfo $ text $ ""-          putInfo $ text $ "Making no changes:  this is a dry run."-          exitWith ExitSuccess-        when (All `elem` opts && Summary `elem` opts) $ do-          putInfo $ text $ "Will " ++ action ++ " the following changes:"-          putDocLn $ put_mode-     where put_mode = if XMLOutput `elem` opts-                      then (text "<patches>" $$-                            vcat (mapFL (indent . xml_info) patches) $$-                            text "</patches>")-                      else (vsep $ mapFL (showFriendly opts) patches)-           putInfo = if XMLOutput `elem` opts then \_ -> return () else putDocLn-           xml_info pl-              | Summary `elem` opts = xml_with_summary pl-              | otherwise = (toXml . info) pl--           xml_with_summary hp-               | Just p <- hopefullyM hp = insertBeforeLastline-                                            (toXml $ info hp) (indent $ xmlSummary p)-           xml_with_summary hp = toXml (info hp)-           indent = prefix "    "---noskipBoring = DarcsMultipleChoiceOption-                [DarcsNoArgOption [] ["boring"]-                 Boring "don't skip boring files",-                 DarcsNoArgOption [] ["no-boring"]-                 SkipBoring "skip boring files [DEFAULT]"]--allowProblematicFilenames = DarcsMultipleChoiceOption-                [DarcsNoArgOption [] ["case-ok"] AllowCaseOnly-                 "don't refuse to add files differing only in case"-                ,DarcsNoArgOption [] ["no-case-ok"] DontAllowCaseOnly-                 "refuse to add files whose name differ only in case [DEFAULT]"-                ,DarcsNoArgOption [] ["reserved-ok"] AllowWindowsReserved-                 "don't refuse to add files with Windows-reserved names"-                ,DarcsNoArgOption [] ["no-reserved-ok"] DontAllowWindowsReserved-                 "refuse to add files with Windows-reserved names [DEFAULT]"]--diffflags = DarcsSingleOption $-            DarcsArgOption [] ["diff-opts"]-            DiffFlags "OPTIONS" "options to pass to diff"--changesFormat = concatOptions $-                 [DarcsMultipleChoiceOption [-                   DarcsNoArgOption [] ["context"]-                    GenContext "give output suitable for get --context" ],-                  xmloutput,-                  humanReadable,-                  DarcsMultipleChoiceOption [-                  DarcsNoArgOption [] ["number"] NumberPatches "number the changes",-                  DarcsNoArgOption [] ["count"] Count "output count of changes" ]-                 ]-changesReverse = DarcsMultipleChoiceOption-                  [DarcsNoArgOption [] ["reverse"] Reverse-                   "show changes in reverse order"-                  ,DarcsNoArgOption [] ["no-reverse"] Forward-                   "show changes in the usual order [DEFAULT]"]--onlyToFiles :: DarcsOption-onlyToFiles = DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["only-to-files"] OnlyChangesToFiles-     "show only changes to specified files",-     DarcsNoArgOption [] ["no-only-to-files"] ChangesToAllFiles-     "show changes to all files [DEFAULT]"]---humanReadable = DarcsSingleOption $-  DarcsNoArgOption [] ["human-readable"] HumanReadable "give human-readable output"--machineReadable = DarcsSingleOption $-  DarcsNoArgOption [] ["machine-readable"] MachineReadable "give machine-readable output"--pipe :: DarcsAtomicOption-pipe =-  DarcsNoArgOption [] ["pipe"] Pipe "ask user interactively for the patch metadata"--interactive :: DarcsAtomicOption-interactive =-    DarcsNoArgOption ['i'] ["interactive"] Interactive-                         "prompt user interactively"--allPatches :: DarcsAtomicOption-allPatches =-  DarcsNoArgOption ['a'] ["all"] All "answer yes to all patches"--allInteractive = DarcsMultipleChoiceOption [allPatches, interactive]--allPipeInteractive-    = DarcsMultipleChoiceOption [allPatches,pipe,interactive]--pipeInteractive =-    DarcsMultipleChoiceOption [pipe, interactive]--repoCombinator =-    DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["intersection"] Intersection-     "take intersection of all repositories",-     DarcsNoArgOption [] ["union"] Union-     "take union of all repositories [DEFAULT]",-     DarcsNoArgOption [] ["complement"] Complement-     "take complement of repositories (in order listed)"]---- | Get a list of all non-boring files and directories in the working copy.-listFiles :: IO [String]-listFiles =  do nonboring <- restrictBoring emptyTree-                working <- expand =<< applyTreeFilter nonboring <$> readPlainTree "."-                return $ map (anchorPath "" . fst) $ list working---- | 'listUnregisteredFiles' returns the list of all non-boring unregistered--- files in the repository.-listUnregisteredFiles :: IO [String]-listUnregisteredFiles =-    do unregd <- listFiles-       regd <- listRegisteredFiles-       return $ unregd \\ regd -- (inefficient)---- | 'listRegisteredFiles' returns the list of all registered files in the repository.-listRegisteredFiles :: IO [String]-listRegisteredFiles =-    do recorded <- expand =<< withRepository [] (RepoJob readRecordedAndPending)-       return $ map (anchorPath "" . fst) $ list recorded--optionsLatex :: [DarcsOption] -> String-optionsLatex opts = "\\begin{tabular}{lll}\n"++-                     unlines (map optionListLatex opts)++-                     "\\end{tabular}\n"--latexHelp :: String -> String-latexHelp h-    = "\\begin{minipage}{7cm}\n\\raggedright\n" ++ h ++ "\\end{minipage}\n"--optionListLatex :: DarcsOption -> String-optionListLatex (DarcsSingleOption o) = optionLatex o-optionListLatex (DarcsMultipleChoiceOption os) = unlines (map optionLatex os)-optionListLatex (DarcsMutuallyExclusive os _) = unlines (map optionLatex os)--optionLatex :: DarcsAtomicOption -> String-optionLatex (DarcsInternalOption _) = ""-optionLatex (DarcsNoArgOption a b _ h) =-    showShortOptions a ++ showLongOptions b ++ latexHelp h ++ "\\\\"-optionLatex (DarcsArgOption a b _ arg h) =-    showShortOptions a ++-    showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\"-optionLatex (DarcsAbsPathOrStdOption a b _ arg h) =-    showShortOptions a ++-    showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\"-optionLatex (DarcsAbsPathOption a b _ arg h) =-    showShortOptions a ++-    showLongOptions (map (++(" "++arg)) b) ++ latexHelp h ++ "\\\\"-optionLatex (DarcsOptAbsPathOption a b _ _ arg h) =-    showShortOptions a ++-    showLongOptions (map (++("[="++arg++"]")) b) ++ latexHelp h ++ "\\\\"--showShortOptions :: [Char] -> String-showShortOptions [] = "&"-showShortOptions [c] = "\\verb!-"++[c]++"! &"-showShortOptions (c:cs) = "\\verb!-"++[c]++"!,"++showShortOptions cs--showLongOptions :: [String] -> String-showLongOptions [] = " &"-showLongOptions [s] = "\\verb!--" ++ s ++ "! &"-showLongOptions (s:ss)-    = "\\verb!--" ++ s ++ "!,"++ showLongOptions ss--setScriptsExecutableOption :: DarcsOption-setScriptsExecutableOption = DarcsMultipleChoiceOption-                              [DarcsNoArgOption [] ["set-scripts-executable"] SetScriptsExecutable-                               "make scripts executable",-                               DarcsNoArgOption [] ["dont-set-scripts-executable","no-set-scripts-executable"] DontSetScriptsExecutable-                               "don't make scripts executable"]--bisect :: DarcsOption-bisect = DarcsSingleOption $ DarcsNoArgOption [] ["bisect"] Bisect-         "binary instead of linear search"--relink, sibling :: DarcsOption-relink = DarcsSingleOption $ DarcsNoArgOption [] ["relink"] Relink-         "relink random internal data to a sibling"--sibling = DarcsSingleOption $-  DarcsAbsPathOption [] ["sibling"] Sibling "URL"-          "specify a sibling directory"---- | 'flagsToSiblings' collects the contents of all @Sibling@ flags in a list of flags.-flagsToSiblings :: [DarcsFlag] -> [AbsolutePath]-flagsToSiblings ((Sibling s) : l) = s : (flagsToSiblings l)-flagsToSiblings (_ : l) = flagsToSiblings l-flagsToSiblings [] = []--reorderPatches :: DarcsOption-reorderPatches = DarcsSingleOption $ DarcsNoArgOption [] ["reorder-patches"] Reorder-                  "reorder the patches in the repository"--sendmailCmd = DarcsSingleOption $-  DarcsArgOption [] ["sendmail-command"] SendmailCmd "COMMAND" "specify sendmail command"--environmentHelpSendmail :: ([String], [String])-environmentHelpSendmail = (["SENDMAIL"], [- "On Unix, the `darcs send' command relies on sendmail(8).  The",- "`--sendmail-command' or $SENDMAIL environment variable can be used to",- "provide an explicit path to this program; otherwise the standard",- "locations /usr/sbin/sendmail and /usr/lib/sendmail will be tried."])--- FIXME: mention the following also:--- * sendmail(8) is not sendmail-specific;--- * nowadays, desktops often have no MTA or an unconfigured MTA -----   which is awful, because it accepts mail but doesn't relay it;--- * in this case, can be a sendmail(8)-emulating wrapper on top of an---   MUA that sends mail directly to a smarthost; and--- * on a multi-user system without an MTA and on which you haven't---   got root, can be msmtp.---- |'getSendmailCmd' takes a list of flags and returns the sendmail command--- to be used by @darcs send@. Looks for a command specified by--- @SendmailCmd \"command\"@ in that list of flags, if any.--- This flag is present if darcs was invoked with @--sendmail-command=COMMAND@--- Alternatively the user can set @$S@@ENDMAIL@ which will be used as a fallback if present.-getSendmailCmd :: [DarcsFlag] -> IO String-getSendmailCmd (SendmailCmd a:_) = return a-getSendmailCmd (_:flags) = getSendmailCmd flags-getSendmailCmd [] =   do easy_sendmail <- firstJustIO [ maybeGetEnv "SENDMAIL" ]-                         case easy_sendmail of-                            Just a -> return a-                            Nothing -> return ""--files :: DarcsOption-files = DarcsMultipleChoiceOption-        [DarcsNoArgOption [] ["files"] Files-         "include files in output [DEFAULT]",-         DarcsNoArgOption [] ["no-files"] NoFiles-         "don't include files in output"]--directories :: DarcsOption-directories = DarcsMultipleChoiceOption-              [DarcsNoArgOption [] ["directories"] Directories-               "include directories in output [DEFAULT]",-               DarcsNoArgOption [] ["no-directories"] NoDirectories-               "don't include directories in output"]--pending :: DarcsOption-pending = DarcsMultipleChoiceOption-              [DarcsNoArgOption [] ["pending"] Pending-               "reflect pending patches in output [DEFAULT]",-               DarcsNoArgOption [] ["no-pending"] NoPending-               "only included recorded patches in output"]--nullFlag :: DarcsOption        -- "null" is already taken-nullFlag = DarcsSingleOption $ DarcsNoArgOption ['0'] ["null"] NullFlag-       "separate file names by NUL characters"---- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables--- with info about the given patches, for use in post-hooks.-setEnvDarcsPatches :: (RepoPatch p, ApplyState p ~ Tree) => FL (PatchInfoAnd p) C(x y) -> IO ()-#ifndef WIN32-setEnvDarcsPatches ps = do-  let k = "Defining set of chosen patches"-  beginTedious k-  tediousSize k 3-  finishedOneIO k "DARCS_PATCHES"-  setEnvCautiously "DARCS_PATCHES" (renderString $ Darcs.Patch.summary ps)-  finishedOneIO k "DARCS_PATCHES_XML"-  setEnvCautiously "DARCS_PATCHES_XML"-                       (renderString $ text "<patches>" $$-                        vcat (mapFL (toXml . info) ps) $$-                        text "</patches>")-  finishedOneIO k "DARCS_FILES"-  setEnvCautiously "DARCS_FILES" (unlines$ listTouchedFiles ps)-  endTedious k---- | Set some environment variable to the given value, unless said value--- is longer than 10K characters, in which case do nothing.-setEnvCautiously :: String -> String -> IO ()-setEnvCautiously e v | toobig (10*1024) v = return ()-                     | otherwise = setEnv e v True-    where toobig :: Int -> [a] -> Bool-          toobig 0 _ = True-          toobig _ [] = False-          toobig n (_:xs) = toobig (n-1) xs-#else-setEnvDarcsPatches _ = return ()-#endif---- | Set the DARCS_FILES environment variable to the files touched by the--- given patch, one per line, for use in post-hooks.-setEnvDarcsFiles :: Patchy p => p C(x y) -> IO ()-#ifndef WIN32-setEnvDarcsFiles ps = setEnvCautiously "DARCS_FILES" (unlines $ listTouchedFiles ps)-#else-setEnvDarcsFiles _ = return ()-#endif--posthookCmd :: DarcsOption-posthookCmd = DarcsMultipleChoiceOption-               [DarcsArgOption [] ["posthook"] PosthookCmd-                "COMMAND" "specify command to run after this darcs command",-                DarcsNoArgOption [] ["no-posthook"] NoPosthook-                "don't run posthook command"]--posthookPrompt :: DarcsOption-posthookPrompt = DarcsMultipleChoiceOption-                  [DarcsNoArgOption [] ["prompt-posthook"] AskPosthook-                   "prompt before running posthook [DEFAULT]",-                   DarcsNoArgOption [] ["run-posthook"] RunPosthook-                   "run posthook command without prompting"]---- | 'getPosthookCmd' takes a list of flags and returns the posthook command---  specified by @PosthookCmd a@ in that list of flags, if any.-getPosthookCmd :: [DarcsFlag] -> Maybe String-getPosthookCmd (PosthookCmd a:_) = Just a-getPosthookCmd (NoPosthook:_) = Nothing-getPosthookCmd (_:flags) = getPosthookCmd flags-getPosthookCmd [] = Nothing--prehookCmd :: DarcsOption-prehookCmd = DarcsMultipleChoiceOption-               [DarcsArgOption [] ["prehook"] PrehookCmd-                "COMMAND" "specify command to run before this darcs command",-                DarcsNoArgOption [] ["no-prehook"] NoPrehook-                "don't run prehook command"]--prehookPrompt :: DarcsOption-prehookPrompt = DarcsMultipleChoiceOption-                  [DarcsNoArgOption [] ["prompt-prehook"] AskPrehook-                   "prompt before running prehook [DEFAULT]",-                   DarcsNoArgOption [] ["run-prehook"] RunPrehook-                   "run prehook command without prompting"]---- | 'getPrehookCmd' takes a list of flags and returns the prehook command---  specified by @PrehookCmd a@ in that list of flags, if any.-getPrehookCmd :: [DarcsFlag] -> Maybe String-getPrehookCmd (PrehookCmd a:_) = Just a-getPrehookCmd (NoPrehook:_) = Nothing-getPrehookCmd (_:flags) = getPrehookCmd flags-getPrehookCmd [] = Nothing--networkOptions :: [DarcsOption]-networkOptions =-   [ DarcsMultipleChoiceOption-       [ DarcsNoArgOption [] ["no-http-pipelining"] NoHTTPPipelining-                          "disable HTTP pipelining"-       ]-   , remoteDarcs ]--remoteDarcs :: DarcsOption-remoteDarcs = DarcsSingleOption $-  DarcsArgOption [] ["remote-darcs"] RemoteDarcsOpt "COMMAND"-                "name of the darcs executable on the remote server"--noCache :: DarcsOption-noCache = DarcsSingleOption $-  DarcsNoArgOption [] ["no-cache"] NoCache-                          "don't use patch caches"--optimizePristine :: DarcsOption-optimizePristine = DarcsSingleOption $-  DarcsNoArgOption [] ["pristine"] OptimizePristine-                          "optimize hashed pristine layout"--optimizeHTTP :: DarcsOption-optimizeHTTP = DarcsSingleOption $-  DarcsNoArgOption [] ["http"] OptimizeHTTP-                          "optimize repository for getting over network"--usePacks :: DarcsOption-usePacks = DarcsMultipleChoiceOption-  [ DarcsNoArgOption [] ["packs"] Packs "use repository packs [DEFAULT]"-  , DarcsNoArgOption [] ["no-packs"] NoPacks-      "don't use repository packs"-  ]--umaskOption :: DarcsOption-umaskOption = DarcsSingleOption $-    DarcsArgOption [] ["umask"] UMask "UMASK"-        "specify umask to use when writing"--restrictPaths :: DarcsOption-restrictPaths =-    DarcsMultipleChoiceOption-    [DarcsNoArgOption [] ["restrict-paths"] RestrictPaths-     "don't allow darcs to touch external files or repo metadata",-     DarcsNoArgOption [] ["dont-restrict-paths","no-restrict-paths"] DontRestrictPaths-     "allow darcs to modify any file or directory (unsafe)"]--allowUnrelatedRepos = DarcsSingleOption $-    DarcsNoArgOption [] ["ignore-unrelated-repos"] AllowUnrelatedRepos-                         "do not check if repositories are unrelated"--justThisRepo :: DarcsOption-justThisRepo = DarcsSingleOption $-    DarcsNoArgOption [] ["just-this-repo"] JustThisRepo-                        "Limit the check or repair to the current repo"--check, repair, checkOrRepair :: DarcsOption-check = DarcsSingleOption $-    DarcsNoArgOption [] ["check"] Check-                        "Specify checking mode"-repair = DarcsSingleOption $-    DarcsNoArgOption [] ["repair"] Repair-                        "Specify repair mode"-checkOrRepair = concatOptions [check, repair]---- | @'patchSelectFlag' f@ holds whenever @f@ is a way of selecting--- patches such as @PatchName n@.-patchSelectFlag :: DarcsFlag -> Bool-patchSelectFlag All = True-patchSelectFlag (PatchName _) = True-patchSelectFlag (OnePatch _) = True-patchSelectFlag (SeveralPatch _) = True-patchSelectFlag (AfterPatch _) = True-patchSelectFlag (UpToPatch _) = True-patchSelectFlag (TagName _) = True-patchSelectFlag (LastN _) = True-patchSelectFlag (OneTag _) = True-patchSelectFlag (AfterTag _) = True-patchSelectFlag (UpToTag _) = True-patchSelectFlag (OnePattern _) = True-patchSelectFlag (SeveralPattern _) = True-patchSelectFlag (AfterPattern _) = True-patchSelectFlag (UpToPattern _) = True-patchSelectFlag _ = False---- | The integer corresponding to a string, if it's only composed of digits.---   Otherwise, -1.-numberString :: String -> Int-numberString "" = -1-numberString s = if all isDigit s then read s else (-1)--makeScriptsExecutable :: Patchy p => [DarcsFlag] -> p C(x y) -> IO ()-makeScriptsExecutable opts p =-  when (SetScriptsExecutable `elem` opts) $ setScriptsExecutablePatches p
− src/Darcs/Bug.hs 
@@ -1,27 +0,0 @@--- Reporting bugs in darcs.  See also impossible.h.-module Darcs.Bug ( _bug, _bugDoc, _impossible, _fromJust-                 ) where--import Printer ( Doc, errorDoc, text, ($$) )--type BugStuff = (String, Int, String, String)--_bug :: BugStuff -> String -> a-_bug bs s = _bugDoc bs (text s)--_bugDoc :: BugStuff -> Doc -> a-_bugDoc bs s = errorDoc $-   text ("bug at " ++ _bugLoc bs) $$ s $$-   text ("See http://wiki.darcs.net/BugTracker/Reporting " ++-         "for help on bug reporting.")--_bugLoc :: BugStuff -> String-_bugLoc (file, line, date, time) = file++":"++show line++" compiled "++time++" "++date--_impossible :: BugStuff -> a-_impossible bs = _bug bs $ "Impossible case at "++_bugLoc bs--_fromJust :: BugStuff -> Maybe a -> a-_fromJust bs mx =-  case mx of Nothing -> _bug bs $ "fromJust error at "++_bugLoc bs-             Just x  -> x
− src/Darcs/ColorPrinter.hs 
@@ -1,285 +0,0 @@-{-# OPTIONS -fno-warn-orphans #-}-module Darcs.ColorPrinter ( errorDoc, traceDoc, assertDoc, fancyPrinters ) where--import Prelude hiding ( catch )-import Control.Exception ( catch, IOException )-import Debug.Trace ( trace )-import System.IO ( stderr )-import Darcs.External (getTermNColors)-import Printer (Printer, Printers, Printers'(..), Printable(..), Color(..),-                invisiblePrinter, (<>), (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat,-                unsafeText, unsafePackedString,-                renderStringWith, prefix )-import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr )-import Data.Bits ( bit, xor )-import System.Environment ( getEnv )-import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd)-import qualified Data.ByteString       as B (null, init)-import System.IO.Unsafe ( unsafePerformIO )-import System.IO ( hIsTerminalDevice, Handle )-import Text.Printf ( printf )--dollar, cr :: Doc-dollar = unsafeBothText "$"-cr     = unsafeBothText "\r"--errorDoc :: Doc -> a-errorDoc = error . show--traceDoc :: Doc -> a -> a-traceDoc d = trace (show d)--assertDoc :: Maybe Doc -> a -> a-assertDoc Nothing x = x-assertDoc (Just e) _ = errorDoc e--instance Show Doc where-    show = renderStringWith (fancyPrinters stderr)---- policy--- | the 'Policy' type is a record containing the variables which control--- how 'Doc's will be rendered on some output.-data Policy = Policy { poColor :: Bool    -- ^ overall use of color-                     , poEscape :: Bool   -- ^ overall use of escaping-                     , poLineColor :: Bool -- ^ overall use of colored lines (only hunks for now)-                     , poAltColor :: Bool -- ^ alternative to color (bold, inverse)-                     , poIsprint :: Bool  -- ^ don't escape isprints-                     , po8bit  :: Bool    -- ^ don't escape 8-bit chars-                     , poNoEscX :: String   -- ^ extra chars to never escape-                     , poEscX :: String   -- ^ extra chars to always escape-                     , poTrailing :: Bool -- ^ escape trailing spaces-                     , poCR :: Bool       -- ^ ignore \r at end of lines-                     , poSpace :: Bool    -- ^ escape spaces (used with poTrailing)-                     }--{-# NOINLINE getPolicy #-}--- | 'getPolicy' returns a suitable policy for a given handle.--- The policy is chosen according to environment variables, and to the--- type of terminal which the handle represents-getPolicy :: Handle -> Policy-getPolicy handle = unsafePerformIO $- do isTerminal <- hIsTerminalDevice handle-    nColors <- if isTerminal then getTermNColors else return 0--    envDontEscapeAnything  <- getEnvBool "DARCS_DONT_ESCAPE_ANYTHING"-    envDontEscapeIsprint   <- getEnvBool "DARCS_DONT_ESCAPE_ISPRINT"-    envUseIsprint          <- getEnvBool "DARCS_USE_ISPRINT" -- for backwards-compatibility-    envDontEscape8bit      <- getEnvBool "DARCS_DONT_ESCAPE_8BIT"--    envDontEscapeExtra  <- getEnvString "DARCS_DONT_ESCAPE_EXTRA"-    envEscapeExtra      <- getEnvString "DARCS_ESCAPE_EXTRA"--    envDontEscapeTrailingSpace  <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_SPACES"-    envDontEscapeTrailingCR     <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_CR"--    envDontColor         <- getEnvBool "DARCS_DONT_COLOR"-    envAlwaysColor       <- getEnvBool "DARCS_ALWAYS_COLOR"-    envAlternativeColor  <- getEnvBool "DARCS_ALTERNATIVE_COLOR"-    envDoColorLines    <- getEnvBool "DARCS_DO_COLOR_LINES"--    let haveColor = envAlwaysColor || (isTerminal && (nColors > 4))-        doColor   = not envDontColor && haveColor--    return Policy { poColor    = doColor,-                    poEscape   = not envDontEscapeAnything,-                    poLineColor= doColor && envDoColorLines,-                    poIsprint  = envDontEscapeIsprint || envUseIsprint,-                    po8bit     = envDontEscape8bit,-                    poNoEscX   = envDontEscapeExtra,-                    poEscX     = envEscapeExtra,-                    poTrailing = not envDontEscapeTrailingSpace,-                    poCR       = envDontEscapeTrailingCR,-                    poAltColor = haveColor && envAlternativeColor,--                    poSpace = False-                  }- where-  getEnvBool s = safeGetEnv s >>= return.(/= "0")-  safeGetEnv s = getEnv s `catch` \(_ :: IOException) -> return "0"-  getEnvString s = getEnv s `catch` \(_ :: IOException) -> return ""----- printers---- | @'fancyPrinters' h@ returns a set of printers suitable for outputting--- to @h@-fancyPrinters :: Printers-fancyPrinters h = let policy = getPolicy h in-                      Printers { colorP = colorPrinter policy,-                             invisibleP = invisiblePrinter,-                             hiddenP = colorPrinter policy Green,-                             userchunkP = userchunkPrinter policy,-                             defP       = escapePrinter policy,-                             lineColorT = lineColorTrans policy,-                             lineColorS = lineColorSuffix policy-                           }---- | @'lineColorTrans' policy@ tries to color a Doc, according to policy po.--- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise--- does nothing.-lineColorTrans :: Policy -> Color -> Doc -> Doc-lineColorTrans po | poLineColor po = \c d -> prefix (setColor c) d <?> unsafeBothText resetColor-                  | otherwise      = const id--lineColorSuffix :: Policy -> [Printable] -> [Printable]-lineColorSuffix po | poLineColor po = \d -> S resetColor : d-                   | otherwise      = id--colorPrinter :: Policy -> Color -> Printer-colorPrinter po | poColor po = \c -> unDoc . color po c . Doc . escapePrinter po{poColor=False}-                | otherwise  = const $ escapePrinter po--userchunkPrinter :: Policy -> Printer-userchunkPrinter po p- | not (poEscape po)   = simplePrinter p- | not (poTrailing po) = escapePrinter po p- | otherwise           = unDoc $ pr p- where-  pr (S s)       = prString s-  pr (Both _ ps) = prPS ps-  pr (PS ps)     = prPS ps--  prPS ps = let (leadPS, trailPS) = BC.spanEnd isSpace ps-            in if B.null trailPS-                then Doc $ escapePrinter po p-                else Doc (escapePrinter po (PS leadPS))-                  <> Doc (escapePrinter po{poSpace=True} (PS trailPS))-                  <> markEscape po dollar--  prString s = let (trail',lead') = span isSpace (reverse s)-                   lead = reverse lead'-                   trail = reverse trail'-               in if (not.null) trail-                   then Doc (escapePrinter po (S lead))-                     <> Doc (escapePrinter po{poSpace=True} (S trail))-                     <> markEscape po dollar-                   else Doc (escapePrinter po p)--escapePrinter :: Policy -> Printer-escapePrinter po- | (not.poEscape) po = simplePrinter- | otherwise         = unDoc . crepr- where-  crepr p | poCR po && isEndCR p = epr (initPR p) <> cr-          | otherwise            = epr p--  epr (S s)      = escape po s-  epr (PS ps)    = if BC.any (not.noEscape po) ps-                   then escape po (BC.unpack ps)-                   else unsafePackedString ps-  epr (Both s _) = escape po s--  isEndCR (S s)        = not (null s) && last s == '\r'-  isEndCR (PS ps)      = not (B.null ps) && BC.last ps == '\r'-  isEndCR (Both _ ps)  = not (B.null ps) && BC.last ps == '\r'--  initPR (S s)       = S $ init s-  initPR (PS ps)     = PS $ B.init ps-  initPR (Both s ps) = Both (init s) (B.init ps)----- | @'escape' policy string@ escapes @string@ according to the rules--- defined in 'policy', turning it into a 'Doc'.-escape :: Policy -> String -> Doc-escape _ "" = unsafeText ""-escape po s = hcat $ escape' s- where-   escape' "" = []-   escape' s'@(c:_) | mundane c =-     let (printables, rest) = span mundane s' in-     (unsafeText printables):(escape' rest)-   escape' (c:rest) = (emph . unsafeText $ quoteChar c):(escape' rest)-   mundane c = (noEscape po c) || (c == ' ')-   emph = (markEscape po)----- | @'noEscape' policy c@ tells wether @c@ will be left as-is--- when escaping according to @policy@-noEscape :: Policy -> Char -> Bool-noEscape po c | poSpace po && isSpace c = False-noEscape po c | c `elem` poEscX po = False-noEscape po c | c `elem` poNoEscX po = True-noEscape _ '\t' = True  -- tabs will likely be converted to spaces-noEscape _ '\n' = True-noEscape po c = if (poIsprint po) then isPrint c-                                   else isPrintableAscii c-                 ||  c >= '\x80' && po8bit po---- | 'isPrintableAscii' tells wether a character is a printable character--- of the ascii range.-isPrintableAscii :: Char -> Bool-isPrintableAscii c = isAscii c && isPrint c----- | 'quoteChar' represents a special character as a string.---   * @quoteChar '^c'@ (where @^c@ is a control character) is @"^c"@---   * Otherwise, @quoteChar@ returns "\hex", where 'hex' is the---     hexadecimal number of the character.-quoteChar :: Char -> String-quoteChar c- | isControl c && isPrintableAscii cHat = ['^', cHat]- | otherwise = sHex- where-  cHat = chr $ (bit 6 `xor`) $ ord c-  sHex = "<U+" ++ printf "%04X" c ++ ">"----- make colors and highlightings---- | @'markEscape' policy doc@ marks @doc@ with the appropriate--- marking for escaped characters according to @policy@-markEscape :: Policy -> Doc -> Doc-markEscape po  | poAltColor po  = makeInvert-               | poColor po     = makeColor Red-               | otherwise      = makeAsciiart---- | @'color' policy color doc@ colors @doc@ with color @color@ if--- @policy@ is not set to use an alternative to color. In that case,--- it makes the text bold instead.-color :: Policy -> Color -> Doc -> Doc-color po | poAltColor po = \_ -> makeBold-         | otherwise     = makeColor--makeColor, makeColor' :: Color -> Doc -> Doc--makeColor' = withColor . setColor---- memoized version of makeColor'-makeColor Blue    = makeColor' Blue-makeColor Red     = makeColor' Red-makeColor Green   = makeColor' Green-makeColor Cyan    = makeColor' Cyan-makeColor Magenta = makeColor' Magenta--setColor :: Color -> String-setColor Blue    = "\x1B[01;34m" -- bold blue-setColor Red     = "\x1B[01;31m" -- bold red-setColor Green   = "\x1B[01;32m" -- bold green-setColor Cyan    = "\x1B[36m"    -- light cyan-setColor Magenta = "\x1B[35m"    -- light magenta---- | @'makeAsciiart' doc@ tries to make @doc@ (usually a--- single escaped char) stand out with the help of only plain--- ascii, i.e., no color or font style.-makeAsciiart :: Doc -> Doc-makeAsciiart x = unsafeBothText "[_" <> x <> unsafeBothText "_]"---- | the string to reset the terminal's color.-resetColor :: String-resetColor = "\x1B[00m"---- | @'withColor' color doc@ returns a colorized version of @doc@.--- @color@ is a string that represents a color, given by 'setColor'-withColor :: String -> Doc -> Doc-withColor c =-   let c' = unsafeBothText c-       r' = unsafeBothText resetColor-   in \x -> c' <> x <> r'----- | 'makeBold' boldens a doc.-makeBold :: Doc -> Doc--- | 'makeInvert' returns an invert video version of a doc.-makeInvert :: Doc -> Doc-makeBold   = withColor "\x1B[01m"-makeInvert = withColor "\x1B[07m"
− src/Darcs/Commands.hs 
@@ -1,242 +0,0 @@---  Copyright (C) 2002,2003,2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands ( CommandControl( CommandData, HiddenCommand, GroupName ),-                       DarcsCommand( DarcsCommand, commandProgramName, commandName,-                                     commandHelp, commandDescription,-                                     commandBasicOptions, commandAdvancedOptions,-                                     commandCommand,-                                     commandPrereq,-                                     commandExtraArgHelp,-                                     commandExtraArgs,-                                     commandArgdefaults,-                                     commandGetArgPossibilities,-                                     SuperCommand,-                                     commandSubCommands ),-                       commandAlias, commandStub,-                       commandOptions, commandAlloptions,-                       disambiguateCommands, CommandArgs(..),-                       getCommandHelp, getCommandMiniHelp,-                       getSubcommands,-                       usage, usageHelper, subusage, chompNewline,-                       extractCommands,-                       superName,-                       nodefaults,-                       putInfo, putVerbose, putWarning, abortRun-                     ) where--import System.Console.GetOpt( OptDescr, usageInfo )-import Control.Monad (when, unless)--import Data.List ( sort, isPrefixOf )-import Darcs.Arguments ( DarcsFlag(Quiet,Verbose, DryRun), DarcsOption, disable, help,-                         anyVerbosity, noCache, posthookCmd, posthookPrompt,-                         prehookCmd, prehookPrompt, optionFromDarcsOption )-import Darcs.RepoPath ( AbsolutePath, rootDirectory )-import Printer ( Doc, putDocLn, hPutDocLn, text, (<+>), errorDoc )-import System.IO ( stderr )--extractCommands, extractHiddenCommands :: [CommandControl] -> [DarcsCommand]-extractCommands cs = concatMap (\x -> case x of { CommandData cmd_d -> [cmd_d]; _ -> []}) cs-extractHiddenCommands cs = concatMap (\x -> case x of { HiddenCommand cmd_d -> [cmd_d]; _ -> []}) cs--data CommandControl = CommandData DarcsCommand-                    | HiddenCommand DarcsCommand-                    | GroupName String--data DarcsCommand =-    DarcsCommand {commandProgramName, commandName, commandHelp, commandDescription :: String,-                  commandExtraArgs :: Int,-                  commandExtraArgHelp :: [String],-                  commandCommand :: [DarcsFlag] -> [String] -> IO (),-                  commandPrereq :: [DarcsFlag] -> IO (Either String ()),-                  commandGetArgPossibilities :: IO [String],-                  commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String],-                  commandBasicOptions :: [DarcsOption],-                  commandAdvancedOptions :: [DarcsOption]}-  | SuperCommand {commandProgramName, commandName, commandHelp, commandDescription :: String,-                  commandPrereq :: [DarcsFlag] -> IO (Either String ()),-                  commandSubCommands :: [CommandControl]}--commandAlloptions :: DarcsCommand -> ([DarcsOption], [DarcsOption])-commandAlloptions DarcsCommand { commandBasicOptions = opts1-                                , commandAdvancedOptions = opts2 }-    = (opts1 ++ [disable, help],-       anyVerbosity ++ opts2 ++-                [noCache-                ,posthookCmd, posthookPrompt-                ,prehookCmd, prehookPrompt])----  Supercommands cannot be disabled.-commandAlloptions SuperCommand { } = ([help],[])----  Obtain options suitable as input to---  System.Console.Getopt, including the --disable option (which is---  not listed explicitly in the DarcsCommand definitions).-commandOptions :: AbsolutePath -> DarcsCommand -> ([OptDescr DarcsFlag], [OptDescr DarcsFlag])-commandOptions cwd c = (convert basic, convert advanced)- where (basic, advanced) = commandAlloptions c-       convert = concatMap (optionFromDarcsOption cwd)--nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]-nodefaults _ _ xs = return xs--getSubcommands :: DarcsCommand -> [CommandControl]-getSubcommands c@(SuperCommand {}) = commandSubCommands c-getSubcommands _ = []--commandAlias :: String -> Maybe DarcsCommand -> DarcsCommand -> DarcsCommand-commandAlias n msuper c =-  c { commandName = n-    , commandDescription = "Alias for `" ++ commandProgramName c ++ " " ++ cmdName ++ "'."-    , commandHelp = "The `" ++ commandProgramName c ++ " " ++ n ++ "' command is an alias for " ++-                     "`" ++ commandProgramName c ++ " " ++ cmdName ++ "'.\n" ++-                     commandHelp c-    }- where-  cmdName = unwords . map commandName . maybe id (:) msuper $ [ c ]--commandStub :: String -> String -> String -> DarcsCommand -> DarcsCommand-commandStub n h d c =-  c { commandName = n-    , commandHelp = h-    , commandDescription = d-    , commandCommand = \_ _ -> putStr h-    }--usage :: [CommandControl] -> String-usage cs = "Usage: darcs COMMAND ...\n\nCommands:\n" ++-           usageHelper cs ++ "\n" ++-           "Use 'darcs COMMAND --help' for help on a single command.\n" ++-           "Use 'darcs --version' to see the darcs version number.\n" ++-           "Use 'darcs --exact-version' to get the exact version of this darcs instance.\n" ++-           "Use 'darcs help patterns' for help on patch matching.\n" ++-           "Use 'darcs help environment' for help on environment variables.\n" ++-           "\n" ++-           "Check bug reports at http://bugs.darcs.net/\n"--subusage :: DarcsCommand -> String-subusage super =-    (usageInfo-     ("Usage: " ++ commandProgramName super ++ " "++commandName super++" SUBCOMMAND ... " ++-      "\n\n"++ commandDescription super++-      "\n\nSubcommands:\n" ++ usageHelper (getSubcommands super) ++ "\nOptions:")-     (optionFromDarcsOption rootDirectory help))-    ++ "\n" ++ commandHelp super--usageHelper :: [CommandControl] -> String-usageHelper [] = ""-usageHelper (HiddenCommand _:cs) = usageHelper cs-usageHelper ((CommandData c):cs) = "  "++padSpaces (commandName c) 15 ++-                      chompNewline (commandDescription c)++"\n"++usageHelper cs-usageHelper ((GroupName n):cs) = "\n" ++ n ++ "\n" ++ usageHelper cs--chompNewline :: String -> String-chompNewline "" = ""-chompNewline s = if last s == '\n' then init s else s--padSpaces :: String -> Int -> String-padSpaces s n = s ++ replicate (n - length s) ' '--superName :: Maybe DarcsCommand -> String-superName Nothing  = ""-superName (Just x) = commandName x ++ " "--getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String-getCommandMiniHelp msuper cmd =-  getCommandHelpCore msuper cmd ++-  "\n\nSee " ++ commandProgramName cmd ++ " help "-  ++ (maybe "" (\c -> commandName c ++ " ") msuper)-  ++ commandName cmd ++ " for details."--getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> String-getCommandHelp msuper cmd =-    unlines (reverse basicR)-    ++ (if null advanced then ""-        else "\nAdvanced options:\n" ++ unlines (reverse advancedR))-    ++ "\n" ++ commandHelp cmd-    where -- we could just call usageInfo twice, but then the advanced-          -- options might not line up with the basic ones (no short flags)-          (advancedR, basicR) =-             splitAt (length advanced) $ reverse $ lines combinedUsage-          combinedUsage = usageInfo-            (getCommandHelpCore msuper cmd ++ subcommands ++ "\n\nOptions:")-            (basic ++ advanced)-          (basic, advanced) = commandOptions rootDirectory cmd-          subcommands =-            case msuper of-            Nothing -> case getSubcommands cmd of-                       [] -> []-                       s  -> "\n\nSubcommands:\n" ++ (usageHelper s)-            -- we don't want to list subcommands if we're already specifying them-            Just _  -> ""--getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> String-getCommandHelpCore msuper cmd =-    "Usage: " ++ commandProgramName cmd ++ " "++superName msuper++commandName cmd++-    " [OPTION]... " ++ unwords args_help ++-    "\n"++ commandDescription cmd-    where args_help = case cmd of-            (DarcsCommand {}) ->-              commandExtraArgHelp cmd-            _ -> []--data CommandArgs = CommandOnly      DarcsCommand-                 | SuperCommandOnly DarcsCommand-                 | SuperCommandSub  DarcsCommand DarcsCommand---- Parses a darcs command line with potentially abbreviated commands-disambiguateCommands :: [CommandControl] -> String -> [String]-                      -> Either String (CommandArgs, [String])-disambiguateCommands allcs cmd args =- do c <- extract cmd allcs-    case (getSubcommands c, args) of-      ([], _)         -> return (CommandOnly c, args)-      (_ ,[])         -> return (SuperCommandOnly c, args)-      (subcs, (a:as)) -> case extract a subcs of-                         Left _   -> return (SuperCommandOnly c, args)-                         Right sc -> return (SuperCommandSub c sc, as)--extract :: String -> [CommandControl] -> Either String DarcsCommand-extract cmd cs =- case [ c | c <- extractCommands cs, cmd `isPrefixOf` commandName c ] ++-      [ h | h <- extractHiddenCommands cs,    cmd == commandName h ] of-   []  -> Left $ "No such command '" ++ cmd ++ "'\n"-   [c] -> Right c-   cs' -> Left $ "Ambiguous command...\n\n" ++-                    "The command '"++cmd++"' could mean one of:\n" ++-                    unwords (sort $ map commandName cs')--amVerbose :: [DarcsFlag] -> Bool-amVerbose = elem Verbose--amQuiet :: [DarcsFlag] -> Bool-amQuiet = elem Quiet--putVerbose :: [DarcsFlag] -> Doc -> IO ()-putVerbose opts = when (amVerbose opts) . putDocLn--putInfo :: [DarcsFlag] -> Doc -> IO ()-putInfo opts = unless (amQuiet opts) . putDocLn--putWarning :: [DarcsFlag] -> Doc -> IO ()-putWarning opts = unless (amQuiet opts) . hPutDocLn stderr--abortRun :: [DarcsFlag] -> Doc -> IO ()-abortRun opts msg = if DryRun `elem` opts-                    then putInfo opts $ text "NOTE:" <+> msg-                    else errorDoc msg
− src/Darcs/Commands/Add.hs 
@@ -1,341 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.---- |--- Module      : Darcs.Commands.Add--- Copyright   : 2002-2004 David Roundy--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Darcs.Commands.Add-    (-      add-    , expandDirs-    ) where---#include "gadts.h"-#include "impossible.h"--import Prelude hiding ( catch )--import Control.Exception ( catch, IOException )-import Control.Monad ( when, unless, liftM )-import Data.List ( (\\), nub )-import Data.Maybe ( isNothing, maybeToList )-import Printer ( text )-import Storage.Hashed.Tree ( Tree, findTree, expand )-import Storage.Hashed.AnchoredPath ( floatPath, anchorPath, parents )-import System.FilePath.Posix ( takeDirectory, (</>) )-import System.Posix.Files ( isRegularFile, isDirectory, isSymbolicLink )-import System.Directory ( getPermissions, readable )--import qualified System.FilePath.Windows as WindowsFilePath--import Darcs.Arguments (  noskipBoring, allowProblematicFilenames,-                          recursive, workingRepoDir, dryRunNoxml, umaskOption,-                          listFiles, listUnregisteredFiles,-                          DarcsFlag ( Recursive, DryRun, Verbose, Quiet ),-                          fixSubPaths,-                      )-import Darcs.Commands ( DarcsCommand(..), putVerbose, putWarning, nodefaults)-import Darcs.Flags ( includeBoring, doAllowCaseOnly, doAllowWindowsReserved )-import Darcs.Patch ( Patchy, PrimPatch, applyToTree, addfile, adddir )-import Darcs.Patch.Apply ( ApplyState )-import Darcs.RepoPath ( SubPath, toFilePath, simpleSubPath, toPath )-import Darcs.Repository.State ( readRecordedAndPending )-import Darcs.Repository ( amInHashedRepository, withRepoLock, RepoJob(..), addToPending )-import Darcs.Repository.Prefs ( darcsdirFilter, boringFileFilter )-import Darcs.Utils ( treeHas, treeHasDir, treeHasAnycase, getFileStatus, withCurrentDirectory, nubsort )-import Darcs.Witnesses.Ordered ( FL(..), (+>+), nullFL )-import Darcs.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )---addDescription :: String-addDescription = "Add one or more new files or directories."---addHelp :: String-addHelp =-    "Generally a repository contains both files that should be version\n" ++-    "controlled (such as source code) and files that Darcs should ignore\n" ++-    "(such as executables compiled from the source code).  The `darcs add'\n" ++-    "command is used to tell Darcs which files to version control.\n" ++-    "\n" ++-    "When an existing project is first imported into a Darcs repository, it\n" ++-    "is common to run `darcs add -r *' or `darcs record -l' to add all\n" ++-    "initial source files into darcs.\n"++-    "\n" ++-    "Adding symbolic links (symlinks) is not supported.\n\n"---addHelp' :: String-addHelp' =-    "Darcs will ignore all files and folders that look `boring'.  The\n" ++-    "--boring option overrides this behaviour.\n" ++-    "\n" ++-    "Darcs will not add file if another file in the same folder has the\n" ++-    "same name, except for case.  The --case-ok option overrides this\n" ++-    "behaviour.  Windows and OS X usually use filesystems that do not allow\n" ++-    "files a folder to have the same name except for case (for example,\n" ++-    "`ReadMe' and `README').  If --case-ok is used, the repository might be\n" ++-    "unusable on those systems!\n\n"---add :: DarcsCommand-add = DarcsCommand-    {-      commandProgramName          = "darcs"-    , commandName                 = "add"-    , commandHelp                 = addHelp ++ addHelp'-    , commandDescription          = addDescription-    , commandExtraArgs            = -1-    , commandExtraArgHelp         = [ "<FILE or DIRECTORY> ..." ]-    , commandCommand              = addCmd-    , commandPrereq               = amInHashedRepository-    , commandGetArgPossibilities  = listUnregisteredFiles-    , commandArgdefaults          = nodefaults-    , commandAdvancedOptions      = [umaskOption]-    , commandBasicOptions =-        [-          noskipBoring-        , allowProblematicFilenames-        , recursive "add contents of subdirectories"-        , workingRepoDir-        , dryRunNoxml-        ]-    }---addCmd :: [DarcsFlag]-       -> [String]-       -> IO ()-addCmd opts args-  | null args = putStrLn $ "Nothing specified, nothing added." ++-      "Maybe you wanted to say `darcs add --recursive .'?"-  | otherwise = do-      fs <- fixSubPaths opts args-      case fs of-        [] -> fail "No valid arguments were given"-        _ -> addFiles opts fs---addFiles :: [DarcsFlag]  -- ^ Command options-         -> [SubPath]-         -> IO ()-addFiles opts origfiles = withRepoLock opts $ RepoJob $ \repository -> do-    -- TODO do not expand here, and use findM/findIO or such later-    -- (needs adding to hashed-storage first though)-    cur <- expand =<< readRecordedAndPending repository-    let parlist = getParents cur (map toFilePath origfiles)-    flist' <- if Recursive `elem` opts-              then expandDirs origfiles-              else return origfiles-    let flist = nubsort (parlist ++ toFilePath `map` flist')-    -- refuse to add boring files recursively:-    nboring <- if includeBoring opts-               then return darcsdirFilter-               else boringFileFilter-    let fixedOpts = if DryRun `elem` opts then Verbose:opts else opts-    mapM_ (putWarning fixedOpts . text . ((msgSkipping msgs ++ " boring file ")++)) $-        flist \\ nboring flist-    Sealed ps <- fmap unFreeLeft $ addp msgs fixedOpts cur $ nboring flist-    when (nullFL ps && not (null origfiles) && not (Quiet `elem` opts)) $-        fail "No files were added"-    unless gotDryRun $ addToPending repository ps-  where-    gotDryRun = DryRun `elem` opts-    msgs-        | gotDryRun = dryRunMessages-        | otherwise = normalMessages---addp :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree)-     => AddMessages-     -> [DarcsFlag]-     -> Tree IO-     -> [FilePath]-     -> IO (FreeLeft (FL prim))-addp msgs opts cur0 files = do-    (ps, dups) <--        foldr-             (\f rest cur accPS accDups -> do-                    addResult <- addp' cur f-                    case addResult of-                        -- If a single file fails to add, stop further processing.-                        (_, Nothing, Nothing) -> return ([], [])-                        (cur', mp, mdup) -> rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups))-            (\_ ps dups -> return (reverse ps, dups))-            files-            cur0 [] []-    let uniq_dups = nub dups-        caseMsg =-            if gotAllowCaseOnly then ":"-                else ";\nnote that to ensure portability we don't allow\n" ++-                     "files that differ only in case. Use --case-ok to override this:"-    unless (null dups) $ do-       dupMsg <--         case uniq_dups of-         [f] -> do-           isDir <- doesDirectoryReallyExist f-           if isDir-             then return $-               "The following directory " ++-               msgIs msgs ++ " already in the repository"-             else return $-               "The following file " ++-               msgIs msgs ++ " already in the repository"-         fs   -> do-           areDirs <- mapM doesDirectoryReallyExist fs-           if and areDirs-             then return $-               "The following directories " ++-               msgAre msgs ++ " already in the repository"-             else-               (if or areDirs-                  then return $-                    "The following files and directories " ++-                    msgAre msgs ++ " already in the repository"-                  else return $-                    "The following files " ++-                    msgAre msgs ++ " already in the repository")-       putWarning opts . text $ dupMsg ++ caseMsg-       mapM_ (putWarning opts . text) uniq_dups-    return $ foldr (joinGap (+>+)) (emptyGap NilFL) ps-  where-    addp' :: Tree IO-          -> FilePath-          -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)-    addp' cur f = do-      already_has <- (if gotAllowCaseOnly then treeHas else treeHasAnycase) cur f-      mstatus <- getFileStatus f-      case (already_has, is_badfilename, mstatus) of-        (True, _, _) -> return (cur, Nothing, Just f)-        (_, True, _) -> do-            putWarning opts . text $-              "The filename " ++ f ++ " is invalid under Windows.\n" ++-              "Use --reserved-ok to allow it."-            return add_failure-        (_, _, Just s)-            | isDirectory s    -> trypatch $ freeGap (adddir f :>: NilFL)-            | isRegularFile s  -> trypatch $ freeGap (addfile f :>: NilFL)-            | isSymbolicLink s -> do-                putWarning opts . text $-                    "Sorry, file " ++ f ++-                    " is a symbolic link, which is unsupported by darcs."-                return add_failure-        _ -> do-            putWarning opts . text $ "File "++ f ++" does not exist!"-            return add_failure-        where-          is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid f)-          add_failure = (cur, Nothing, Nothing)-          trypatch :: FreeLeft (FL prim)-                   -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe FilePath)-          trypatch p = do-              perms <- getPermissions f-              if not $ readable perms-                then do-                    putWarning opts . text $-                        msgSkipping msgs ++ " '" ++ f ++ "': permission denied "-                    return (cur, Nothing, Nothing)-                else trypatch' p-          trypatch' p = do-              Sealed p' <- return $ unFreeLeft p-              ok <- treeHasDir cur parentdir-              if ok-                then do-                    tree <- applyToTree p' cur-                    putVerbose opts . text $-                        msgAdding msgs ++ " '" ++ f ++ "'"-                    return (tree, Just p, Nothing)-                else do-                    putWarning opts . text $-                        msgSkipping msgs ++ " '" ++ f ++-                            "' ... couldn't add parent directory '" ++-                            parentdir ++ "' to repository"-                    return (cur, Nothing, Nothing)-              `catch` \(e :: IOException) -> do-                  putWarning opts . text $-                      msgSkipping msgs ++ " '" ++ f ++ "' ... " ++ show e-                  return (cur, Nothing, Nothing)-          parentdir = takeDirectory f-    gotAllowCaseOnly = doAllowCaseOnly opts-    gotAllowWindowsReserved = doAllowWindowsReserved opts---data AddMessages = AddMessages-    {-      msgSkipping  :: String-    , msgAdding    :: String-    , msgIs        :: String-    , msgAre       :: String-    }---normalMessages :: AddMessages-normalMessages = AddMessages-    {-      msgSkipping  = "Skipping"-    , msgAdding    = "Adding"-    , msgIs        = "is"-    , msgAre       = "are"-    }---dryRunMessages :: AddMessages-dryRunMessages = AddMessages-    {-      msgSkipping  = "Would skip"-    , msgAdding    = "Would add"-    , msgIs        = "would be"-    , msgAre       = "would be"-    }---doesDirectoryReallyExist :: FilePath -> IO Bool-doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f---expandDirs :: [SubPath]-           -> IO [SubPath]-expandDirs fs =-    liftM (map (fromJust . simpleSubPath)) $-      concat `fmap` mapM (expandOne . toPath) fs---expandOne :: FilePath-          -> IO [FilePath]-expandOne "" = listFiles-expandOne f = do-    isdir <- doesDirectoryReallyExist f-    if not isdir-      then return [f]-      else do-        fs <- withCurrentDirectory f listFiles-        return $ f: map (f </>) fs---getParents :: Tree IO-           -> [FilePath]-           -> [FilePath]-getParents cur = map (anchorPath "") . go . map floatPath-  where-    go fs = filter (isNothing . findTree cur) $ concatMap parents fs-
− src/Darcs/Commands/AmendRecord.hs 
@@ -1,332 +0,0 @@---  Copyright (C) 2004,2007 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.---- |--- Module      : Darcs.Commands.AmendRecord--- Copyright   : 2004, 2007 David Roundy--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Darcs.Commands.AmendRecord-    (-      amendrecord-    , amendunrecord-    ) where---#include "gadts.h"--import Data.Maybe ( isJust, isNothing )-import Data.List ( intersect )-import Control.Applicative ( (<$>) )-import Control.Monad ( when, unless )-import System.Directory ( removeFile )-import System.Exit ( ExitCode(..), exitWith )--import Darcs.Arguments ( DarcsFlag ( All, AmendUnrecord, Unified ),-                         fixSubPaths, setEnvDarcsFiles,-                        allInteractive, ignoretimes,-                        askLongComment, askdeps, keepDate, author, patchnameOption,-                        leaveTestDir, nocompress, lookforadds,-                         workingRepoDir,-                        matchOneNontag, umaskOption,-                         test, listRegisteredFiles,-                        getEasyAuthor, setScriptsExecutableOption, amendUnrecord-                        , unified-                      )-import Darcs.Commands ( DarcsCommand(..), commandAlias, nodefaults )-import Darcs.Commands.Record ( getDate, getLog, askAboutDepends )-import Darcs.Commands.Util ( announceFiles )-import Darcs.Flags ( DarcsFlag(Author, LogFile, PatchName, AskDeps,-                               EditLongComment, PromptLongComment, KeepDate)-                   , isInteractive-                   , diffingOpts, compression, removeFromAmended )-import Darcs.Lock ( worldReadableTemp )-import Darcs.Patch ( RepoPatch, description, PrimOf, fromPrims,-                     infopatch, getdeps, adddeps, effect, invertFL-                   )-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Info ( piAuthor, piName, piLog, piDateString,-                          PatchInfo, patchinfo, isInverted, isTag, invertName,-                        )-import Darcs.Patch.Prim ( canonizeFL )-import Darcs.Patch.Split ( primSplitter )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully, info, patchDesc )-import Darcs.RepoPath ( toFilePath, SubPath() )-import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withGutsOf,-                    tentativelyRemovePatches, tentativelyAddPatch, finalizeRepositoryChanges,-                    amInHashedRepository-                        , invalidateIndex, unrecordedChanges-                        , testTentative-                        , readRecorded-                  )-import Darcs.Repository.Prefs ( globalPrefsDirDoc )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..),-                             selectionContextPrim,-                             runSelection,-                             withSelectedPatchFromRepo )-import Darcs.Utils ( askUser, clarifyErrors, PromptConfig(..), promptChar )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+), nullFL, reverseRL )--import Printer ( putDocLn )-import Storage.Hashed.Tree( Tree )---amendrecordDescription :: String-amendrecordDescription = "Improve a patch before it leaves your repository."---amendrecordHelp :: String-amendrecordHelp =-    "Amend-record updates a `draft' patch with additions or improvements,\n" ++-    "resulting in a single `finished' patch.  This is better than recording\n" ++-    "the additions and improvements as separate patches, because then\n" ++-    "whenever the `draft' patch is copied between repositories, you would\n" ++-    "need to make sure all the extra patches are copied, too.\n" ++-    "\n" ++-    "Do not copy draft patches between repositories, because a finished\n" ++-    "patch cannot be copied into a repository that contains a draft of the\n" ++-    "same patch.  If this has already happened, `darcs obliterate' can be\n" ++-    "used to remove the draft patch.\n" ++-    "\n" ++-    -- FIXME: is the following still true in Darcs 2.1? --twb-    "Do not run amend-record in repository that other developers can pull\n" ++-    "from, because if they pull while an amend-record is in progress, their\n" ++-    "repository may be corrupted.\n" ++-    "\n" ++-    "When recording a draft patch, it is a good idea to start the name with\n" ++-    "`DRAFT:' so that other developers know it is not finished.  When\n" ++-    "finished, remove it with `darcs amend-record --edit-long-comment'.\n" ++-    "To change the patch name without starting an editor, use --patch-name.\n" ++-    "\n" ++-    "Like `darcs record', if you call amend-record with files as arguments,\n" ++-    "you will only be asked about changes to those files.  So to amend a\n" ++-    "patch to foo.c with improvements in bar.c, you would run:\n" ++-    "\n" ++-    "    darcs amend-record --match 'touch foo.c' bar.c\n" ++-    "\n" ++-    "It is usually a bad idea to amend another developer's patch.  To make\n" ++-    "amend-record only ask about your own patches by default, you can add\n" ++-    "something like `amend-record match David Roundy' to " ++ globalPrefsDirDoc ++-    "defaults, \n" ++-    "where `David Roundy' is your name.\n"---amendrecord :: DarcsCommand-amendrecord = DarcsCommand-    {-      commandProgramName          = "darcs"-    , commandName                 = "amend-record"-    , commandHelp                 = amendrecordHelp-    , commandDescription          = amendrecordDescription-    , commandExtraArgs            = -1-    , commandExtraArgHelp         = ["[FILE or DIRECTORY]..."]-    , commandCommand              = amendrecordCmd-    , commandPrereq               = amInHashedRepository-    , commandGetArgPossibilities  = listRegisteredFiles-    , commandArgdefaults          = nodefaults-    , commandAdvancedOptions =-        [-          nocompress-        , ignoretimes-        , umaskOption-        , setScriptsExecutableOption-        ]-    , commandBasicOptions =-        [-          matchOneNontag-        , test-        , leaveTestDir-        , allInteractive-        , author-        , patchnameOption-        , askdeps-        , askLongComment-        , keepDate-        , lookforadds-        , workingRepoDir-        , amendUnrecord-        , unified-        ]-    }---amendunrecord :: DarcsCommand-amendunrecord = (commandAlias "amend-unrecord" Nothing amendrecord)-    { commandCommand = \fs -> commandCommand amendrecord (AmendUnrecord : fs)-    , commandDescription = "Alias for `darcs " ++ commandName amendrecord ++-      " --unrecord '.\n" ++-      "This allows changes already recorded in the patch to be removed."-    }---amendrecordCmd :: [DarcsFlag]-               -> [String]-               -> IO ()-amendrecordCmd opts [] = doAmendRecord opts Nothing-amendrecordCmd opts args = do-    files <- fixSubPaths opts args-    if null files-      then fail "No valid arguments were given, nothing to do."-      else doAmendRecord opts $ Just files---doAmendRecord :: [DarcsFlag] -> Maybe [SubPath] -> IO ()-doAmendRecord opts files =-    withRepoLock opts $ RepoJob $ \(repository :: Repository p C(r u r)) -> do-    withSelectedPatchFromRepo "amend" repository opts $ \ (_ :> oldp) -> do-        announceFiles files "Amending changes in"-            -- auxiliary function needed because the witness types differ for the isTag case-        pristine <- readRecorded repository-        let go :: FORALL(u1) FL (PrimOf p) C(r u1) -> IO ()-            go NilFL | not (hasEditMetadata opts) = putStrLn "No changes!"-            go ch =-              do let context = selectionContextPrim "add"-                                      (intersect [All,Unified] opts)-                                      (Just primSplitter)-                                      (map toFilePath <$> files)-                                      (Just pristine)-                 (chosenPatches :> _) <- runSelection (selectChanges First ch) context-                 addChangesToPatch opts repository oldp chosenPatches-        if not (isTag (info oldp))-              -- amending a normal patch-           then if removeFromAmended opts-                   then do let sel = selectChanges Last (effect oldp)-                               context = selectionContextPrim "unrecord"-                                             (intersect [All,Unified] opts)-                                             (Just primSplitter)-                                             (map toFilePath <$> files)-                                             (Just pristine)-                           (_ :> chosenPrims) <- runSelection sel context-                           let invPrims = reverseRL (invertFL chosenPrims)-                           addChangesToPatch opts repository oldp invPrims-                   else go =<< unrecordedChanges (diffingOpts opts) repository files-              -- amending a tag-           else if hasEditMetadata opts && isNothing files-                        -- the user is not trying to add new changes to the tag so there is-                        -- no reason to warn.-                   then go NilFL-                        -- the user is trying to add new changes to a tag.-                   else do if hasEditMetadata opts-                                -- the user already knows that it is possible to edit tag metadata,-                                -- note that s/he is providing editing options!-                             then putStrLn "You cannot add new changes to a tag."-                                -- the user may not be aware that s/he can edit tag metadata.-                             else putStrLn "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend-record)."-                           go NilFL---addChangesToPatch :: forall p C(r u t x y) . (RepoPatch p, ApplyState p ~ Tree)-                  => [DarcsFlag]-                  -> Repository p C(r u t)-                  -> PatchInfoAnd p C(x t)-                  -> FL (PrimOf p) C(t y)-                  -> IO ()-addChangesToPatch opts repository oldp chs =-    if (nullFL chs && not (hasEditMetadata opts))-    then putStrLn "You don't want to record anything!"-    else do-         invalidateIndex repository-         withGutsOf repository $ do-           repository' <- tentativelyRemovePatches repository (compression opts)-                                                   (oldp :>: NilFL)-           (mlogf, newp) <- updatePatchHeader opts repository' oldp chs-           setEnvDarcsFiles newp-           repository'' <- tentativelyAddPatch repository' (compression opts) newp-           let failmsg = maybe "" (\lf -> "\nLogfile left in "++lf++".") mlogf-           rc <- testTentative repository-           when (rc /= ExitSuccess) $ do-               when (not $ isInteractive opts) $ exitWith rc `clarifyErrors` failmsg-               putStrLn $ "Looks like you have a bad patch: '" ++ patchDesc newp ++ "'"-               let prompt = "Shall I amend it anyway?"-               yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])-               case yn of-                 'y' -> return ()-                 _ -> exitWith rc `clarifyErrors` failmsg-           finalizeRepositoryChanges repository'' `clarifyErrors` failmsg-           maybe (return ()) removeFile mlogf-           putStrLn "Finished amending patch:"-           putDocLn $ description newp---updatePatchHeader :: forall p C(x y r u t) . (RepoPatch p, ApplyState p ~ Tree)-                  => [DarcsFlag]-                  -> Repository p C(r u t)-                  -> PatchInfoAnd p C(t x)-                  -> FL (PrimOf p) C(x y)-                  -> IO (Maybe String, PatchInfoAnd p C(t y))-updatePatchHeader opts repository oldp chs = do--    let newchs = canonizeFL (effect oldp +>+ chs)--    let old_pdeps = getdeps $ hopefully oldp-    newdeps <- if AskDeps `elem` opts-               then askAboutDepends repository newchs opts old_pdeps-               else return old_pdeps--    let old_pinf = info oldp-        prior    = (piName old_pinf, piLog old_pinf)-        make_log = worldReadableTemp "darcs-amend-record"-        old_author = piAuthor old_pinf-    date <- if KeepDate `elem` opts then return (piDateString old_pinf) else getDate opts-    warnIfHijacking opts old_author-    (new_name, new_log, mlogf) <- getLog opts (Just prior) make_log chs-    let new_author = case getAuthor opts of-                     Just a  -> a-                     Nothing -> piAuthor old_pinf-        maybe_invert = if isInverted old_pinf then invertName else id-    new_pinf <- maybe_invert `fmap` patchinfo date new_name-                                              new_author new_log--    let newp = n2pia (adddeps (infopatch new_pinf (fromPrims newchs)) newdeps)--    return (mlogf, newp)---warnIfHijacking :: [DarcsFlag]-                -> String-                -> IO ()-warnIfHijacking opts old_author = do-    authors_here <- getEasyAuthor-    let edit_author = isJust (getAuthor opts)-    unless (edit_author || any (== old_author) authors_here) $ do-      yorn <- askUser $-          "You're not " ++ old_author ++"! Amend anyway? "-      case yorn of ('y':_) -> return ()-                   _       -> exitWith ExitSuccess---hasEditMetadata :: [DarcsFlag]-                -> Bool-hasEditMetadata []                    = False-hasEditMetadata (Author _:_)          = True-hasEditMetadata (LogFile _:_)         = True-hasEditMetadata (PatchName _:_)       = True-hasEditMetadata (EditLongComment:_)   = True-hasEditMetadata (PromptLongComment:_) = True-hasEditMetadata (AskDeps:_)           = True-hasEditMetadata (_:fs)                = hasEditMetadata fs---getAuthor :: [DarcsFlag]-          -> Maybe String-getAuthor (Author a:_)  = Just a-getAuthor (_:as)        = getAuthor as-getAuthor []            = Nothing-
− src/Darcs/Commands/Annotate.hs 
@@ -1,151 +0,0 @@---  Copyright (C) 2003 David Roundy, 2010-2011 Petr Rockai------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.-{-# LANGUAGE CPP, OverloadedStrings #-}-{-# OPTIONS_GHC -cpp #-}--module Darcs.Commands.Annotate ( annotate ) where--import Control.Monad ( when )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(..), workingRepoDir,-                         summary, unified, machineReadable,-                        creatorhash,-                        fixSubPaths,-                        listRegisteredFiles,-                        matchOne,-                      )-import Darcs.Flags ( isUnified )-import Storage.Hashed.Plain( readPlainTree )-import Darcs.Repository.State ( readRecorded )-import Darcs.Repository ( Repository, amInHashedRepository, withRepository, RepoJob(..), readRepo )-import Darcs.Patch.Set ( newset2RL )-import Darcs.Patch ( RepoPatch, Named, patch2patchinfo, invertRL )-import Darcs.Patch.Apply( ApplyState )-import qualified Darcs.Patch ( summary )-import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate )-import Data.ByteString.Lazy ( toChunks )-import Darcs.PrintPatch ( printPatch, contextualPrintPatch )-import Darcs.Patch.ApplyMonad( withFileNames )-import Darcs.Patch.FileName( fp2fn )-import System.FilePath( (</>) )-import Darcs.RepoPath( toFilePath )-import Darcs.Patch.Info ( humanFriendly, showPatchInfo )-import Darcs.Match ( matchPatch, haveNonrangeMatch, getFirstMatch, getOnePatchset, getNonrangeMatchS )-import Darcs.Lock ( withTempDir )-import Darcs.Witnesses.Sealed ( Sealed2(..), Sealed(..), seal )-import qualified Darcs.Annotate as A-import Printer ( putDocLn, Doc )--import Storage.Hashed.Tree( Tree, TreeItem(..), readBlob, list, expand )-import Storage.Hashed.Monad( findM, virtualTreeIO )-import Storage.Hashed.AnchoredPath( floatPath, anchorPath )-#include "gadts.h"-#include "impossible.h"--annotateDescription :: String-annotateDescription = "Display which patch last modified something."--annotateHelp :: String-annotateHelp =- "The `darcs annotate' command provides two unrelated operations.  When\n" ++- "called on a file, it will find the patch that last modified each line\n" ++- "in that file.  When called on a patch (e.g. using --patch), it will\n" ++- "print the internal representation of that patch.\n" ++- "\n" ++- "The --summary option will result in a summarized patch annotation,\n" ++- "similar to `darcs whatsnew'.  It has no effect on file annotations.\n" ++- "\n" ++- "By default, output is in a human-readable format.  The --machine-readable\n" ++- "option can be used to generate output for machine postprocessing.\n"--annotate :: DarcsCommand-annotate = DarcsCommand {commandProgramName = "darcs",-                         commandName = "annotate",-                         commandHelp = annotateHelp,-                         commandDescription = annotateDescription,-                         commandExtraArgs = -1,-                         commandExtraArgHelp = ["[FILE or DIRECTORY]..."],-                         commandCommand = annotateCmd,-                         commandPrereq = amInHashedRepository,-                         commandGetArgPossibilities = listRegisteredFiles,-                         commandArgdefaults = nodefaults,-                         commandAdvancedOptions = [],-                         commandBasicOptions = [summary,unified,-                                                 machineReadable,-                                                 matchOne, creatorhash,-                                                 workingRepoDir]}--annotateCmd :: [DarcsFlag] -> [String] -> IO ()-annotateCmd opts files = withRepository opts (RepoJob (annotate' opts files))--annotate' :: (RepoPatch p, ApplyState p ~ Tree)-          => [DarcsFlag] -> [String] -> Repository p C(r u r) -> IO ()--annotate' opts [] repository = do-  when (not $ haveNonrangeMatch opts) $-      fail $ "Annotate requires either a patch pattern or a " ++-               "file or directory argument."-  Sealed2 p <- matchPatch opts `fmap` readRepo repository-  if Summary `elem` opts-     then do putDocLn $ showpi $ patch2patchinfo p-             putDocLn $ show_summary p-     else if isUnified opts-          then withTempDir "context" $ \_ ->-               do getFirstMatch repository opts-                  c <- readPlainTree "."-                  contextualPrintPatch c p-          else printPatch p-    where showpi | MachineReadable `elem` opts = showPatchInfo-                 | otherwise                   = humanFriendly-          show_summary :: RepoPatch p => Named p C(x y) -> Doc-          show_summary = Darcs.Patch.summary--annotate' opts [""] repository = annotate' opts [] repository-annotate' opts args@[_] repository = do-  r <- readRepo repository-  (origpath:_) <- fixSubPaths opts args-  recorded <- readRecorded repository--  (Sealed patches, initial, path) <--    if haveNonrangeMatch opts-       then do Sealed x <- getOnePatchset repository opts-               let fn = [fp2fn $ toFilePath origpath]-                   nonRangeMatch = getNonrangeMatchS opts r-                   (_, [path], _) = withFileNames Nothing fn nonRangeMatch-               initial <- snd `fmap` virtualTreeIO (getNonrangeMatchS opts r) recorded-               return $ (seal $ newset2RL x, initial, toFilePath path)-       else return $ (seal $ newset2RL r, recorded, toFilePath origpath)--  found <- findM initial (floatPath $ toFilePath path)-  -- TODO need to decide about the --machine flag-  let fmt = if MachineReadable `elem` opts then A.machineFormat else A.format-  case found of-    Nothing -> fail $ "No such file or directory: " ++ toFilePath path-    Just (SubTree s) -> do-      s' <- expand s-      let subs = map (fp2fn . (path </>) . anchorPath "" . fst) $ list s'-          showPath (n, File _) = BC.pack (path </> n)-          showPath (n, _) = BC.concat [BC.pack (path </> n), "/"]-      putStrLn $ fmt (BC.intercalate "\n" $ map showPath $-                        map (\(x,y) -> (anchorPath "" x, y)) $ list s') $-        A.annotateDirectory (invertRL patches) (fp2fn $ "./" ++ path) subs-    Just (File b) -> do con <- BC.concat `fmap` toChunks `fmap` readBlob b-                        putStrLn $ fmt con $ A.annotate (invertRL patches) (fp2fn $ "./" ++ path) con-    Just (Stub _ _) -> impossible--annotate' _ _ _ = fail "annotate accepts at most one argument"
− src/Darcs/Commands/Apply.hs 
@@ -1,395 +0,0 @@---  Copyright (C) 2003-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}--module Darcs.Commands.Apply ( apply, getPatchBundle ) where-import System.Exit ( ExitCode(..), exitWith )-import Prelude hiding ( catch )-import System.IO ( hClose, stdout, stderr )-import Control.Exception.Extensible-                 ( catch, fromException, SomeException, throwIO )-import Control.Monad ( when )--import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefullyM, info )-import Darcs.SignalHandler ( withSignalsBlocked )-import Darcs.Commands ( DarcsCommand(..), putVerbose )-import Darcs.CommandsAux ( checkPaths )-import Darcs.Arguments-    ( DarcsFlag( All, Interactive, Reply )-    , allInteractive-    , applyConflictOptions-    , changesReverse-    , dryRun-    , fixFilePathOrStd-    , getCc-    , getSendmailCmd-    , happyForwarding-    , ignoretimes-    , leaveTestDir-    , listFiles-    , makeScriptsExecutable-    , matchSeveral-    , nocompress-    , notest-    , pauseForGui-    , printDryRunMessageAndExit-    , reply-    , restrictPaths-    , sendmailCmd-    , setEnvDarcsPatches-    , setScriptsExecutableOption-    , umaskOption-    , useExternalMerge-    , verify-    , workingRepoDir-    )-import Darcs.Flags(doHappyForwarding, doReverse, isInteractive)--import qualified Darcs.Arguments as DarcsArguments ( ccApply )-import Darcs.RepoPath ( toFilePath, useAbsoluteOrStd )-import Darcs.Repository ( Repository, SealedPatchSet, withRepoLock, RepoJob(..), amInHashedRepository,-                          tentativelyMergePatches,-                    readRepo,-                    finalizeRepositoryChanges,-                    testTentative,-                    applyToWorking, invalidateIndex-                  )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Patch.Set ( newset2RL )-import Darcs.Patch ( RepoPatch, description, PrimOf )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Info ( PatchInfo, humanFriendly )-import Darcs.Utils ( PromptConfig(..), promptChar )-import Darcs.Witnesses.Ordered ( FL, RL(..), (:\/:)(..), (:>)(..),-                       mapFL, mapRL, nullFL, reverseFL )-import ByteStringUtils ( linesPS, unlinesPS, gzReadFilePS, gzReadStdin )-import Data.List( (\\) )-import qualified Data.ByteString as B (ByteString, null, init, take, drop)-import qualified Data.ByteString.Char8 as BC (unpack, last, pack)--import Darcs.External ( sendEmail, sendEmailDoc, resendEmail,-                  verifyPS )-import Darcs.Email ( readEmail )-import Darcs.Lock ( withStdoutTemp, readBinFile )-import Darcs.Patch.Depends ( findUncommon, findCommonWithThem )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..),-                             runSelection, selectionContext,-                             filterOutConflicts )-import Darcs.Patch.Bundle ( scanBundle )-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Printer ( packedString, vcat, text, empty, renderString )-import Storage.Hashed.Tree( Tree )--#include "impossible.h"--#include "gadts.h"--applyDescription :: String-applyDescription = "Apply a patch bundle created by `darcs send'."--applyHelp :: String-applyHelp =- "The `darcs apply' command takes a patch bundle and attempts to insert\n" ++- "it into the current repository.  In addition to invoking it directly\n" ++- "on bundles created by `darcs send', it is used internally by `darcs\n" ++- "push' and `darcs put' on the remote end of an SSH connection.\n" ++- "\n" ++- "If no file is supplied, the bundle is read from standard input.\n" ++- "\n" ++- "If given an email instead of a patch bundle, Darcs will look for the\n" ++- "bundle as a MIME attachment to that email.  Currently this will fail\n" ++- "if the MIME boundary is rewritten, such as in Courier and Mail.app.\n" ++- "\n" ++- "If the `--reply noreply@example.net' option is used, and the bundle is\n" ++- "attached to an email, Darcs will send a report (indicating success or\n" ++- "failure) to the sender of the bundle (the To field).  The argument to\n" ++- "noreply is the address the report will appear to originate FROM.\n" ++- "\n" ++- "The --cc option will cause the report to be CC'd to another address,\n" ++- "for example `--cc reports@lists.example.net,admin@lists.example.net'.\n" ++- "Using --cc without --reply is undefined.\n" ++- "\n" ++- "If gpg(1) is installed, you can use `--verify pubring.gpg' to reject\n" ++- "bundles that aren't signed by a key in pubring.gpg.\n" ++- "\n" ++- "If --test is supplied and a test is defined (see `darcs setpref'), the\n" ++- "bundle will be rejected if the test fails after applying it.  In that\n" ++- "case, the rejection email from --reply will include the test output.\n"--stdindefault :: a -> [String] -> IO [String]-stdindefault _ [] = return ["-"]-stdindefault _ x = return x-apply :: DarcsCommand-apply = DarcsCommand {commandProgramName = "darcs",-                      commandName = "apply",-                      commandHelp = applyHelp ++ "\n" ++ applyHelp',-                      commandDescription = applyDescription,-                      commandExtraArgs = 1,-                      commandExtraArgHelp = ["<PATCHFILE>"],-                      commandCommand = applyCmd,-                      commandPrereq = amInHashedRepository,-                      commandGetArgPossibilities = listFiles,-                      commandArgdefaults = const stdindefault,-                      commandAdvancedOptions =-                        [ reply-                        , DarcsArguments.ccApply-                        , happyForwarding-                        , sendmailCmd-                        , ignoretimes-                        , nocompress-                        , setScriptsExecutableOption-                        , umaskOption-                        , restrictPaths-                        , changesReverse-                        , pauseForGui-                        ],-                      commandBasicOptions = [verify,-                                              allInteractive]++dryRun++-                                              [matchSeveral,-                                               applyConflictOptions,-                                               useExternalMerge,-                                               notest,-                                               leaveTestDir,-                                               workingRepoDir]}--applyCmd :: [DarcsFlag] -> [String] -> IO ()-applyCmd _ [""] = fail "Empty filename argument given to apply!"-applyCmd opts [unfixed_patchesfile] = withRepoLock opts $ RepoJob $ \repository -> do-  when (unfixed_patchesfile == "-") $ do -    -- for darcs users who try out 'darcs apply' without any arguments-    putVerbose opts $ text "reading patch bundle from stdin..."-  patchesfile <- fixFilePathOrStd opts unfixed_patchesfile-  ps <- useAbsoluteOrStd (gzReadFilePS . toFilePath) gzReadStdin patchesfile-  let from_whom = getFrom ps-  us <- readRepo repository-  either_them <- getPatchBundle opts ps-  Sealed them-     <- case either_them of-          Right t -> return t-          Left er -> do forwarded <- considerForwarding opts ps-                        if forwarded-                          then exitWith ExitSuccess-                          else fail er-  common :> _ <- return $ findCommonWithThem us them--  -- all patches that are in "them" and not in "common" need to be available; check that-  let common_i = mapRL info $ newset2RL common-      them_i = mapRL info $ newset2RL them-      required = them_i \\ common_i -- FIXME quadratic?-      check :: RL (PatchInfoAnd p) C(x y) -> [PatchInfo] -> IO ()-      check (p :<: ps') bad = case hopefullyM p of-        Nothing | info p `elem` required -> check ps' (info p : bad)-        _ -> check ps' bad-      check NilRL [] = return ()-      check NilRL bad = fail . renderString $ vcat $ map humanFriendly bad ++-                        [ text "\nFATAL: Cannot apply this bundle. We are missing the above patches." ]--  check (newset2RL them) []--  (us':\/:them') <- return $ findUncommon us them-  (hadConflicts, Sealed their_ps) <- filterOutConflicts opts (reverseFL us') repository them'-  when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."-  when (nullFL their_ps) $-       do putStr $ "All these patches have already been applied.  " ++-                     "Nothing to do.\n"-          exitWith ExitSuccess-  let context = selectionContext "apply" fixed_opts Nothing Nothing-      selector = selectChanges $ if doReverse opts-                                 then FirstReversed-                                 else First-  (to_be_applied :> _) <- runSelection (selector their_ps) context-  applyItNow opts from_whom repository us' to_be_applied-    where fixed_opts = if Interactive `elem` opts-                         then opts-                         else All : opts-applyCmd _ _ = impossible--applyItNow :: FORALL(p r u t x z) (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)-           => [DarcsFlag] -> String -> Repository p C(r u t)-           -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x z) -> IO ()-applyItNow opts from_whom repository us' to_be_applied = do-   printDryRunMessageAndExit "apply" opts to_be_applied-   when (nullFL to_be_applied) $-        do putStrLn "You don't want to apply any patches, so I'm exiting!"-           exitWith ExitSuccess-   checkPaths opts to_be_applied-   redirectOutput opts from_whom $ do-    putVerbose opts $ text "Will apply the following patches:"-    putVerbose opts . vcat $ mapFL description to_be_applied-    setEnvDarcsPatches to_be_applied-    Sealed pw <- tentativelyMergePatches repository "apply" opts us' to_be_applied-    invalidateIndex repository-    rc <- testTentative repository-    when (rc /= ExitSuccess) $ do-        when (not $ isInteractive opts) $ exitWith rc-        putStrLn $ "Looks like those patches do not pass the tests."-        let prompt = "Shall I apply them anyway?"-        yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])-        case yn of-          'y' -> return ()-          _ -> exitWith rc-    withSignalsBlocked $ do finalizeRepositoryChanges repository-                            _ <- applyToWorking repository opts pw `catch` \(e :: SomeException) ->-                                fail ("Error applying patch to working dir:\n" ++ show e)-                            makeScriptsExecutable opts pw-                            return ()-    putStrLn "Finished applying..."--getPatchBundle :: RepoPatch p => [DarcsFlag] -> B.ByteString-                 -> IO (Either String (SealedPatchSet p C(Origin)))-getPatchBundle opts fps = do-    mps <- verifyPS opts $ readEmail fps-    mops <- verifyPS opts fps-    case (mps, mops) of-      (Nothing, Nothing) ->-          return $ Left "Patch bundle not properly signed, or gpg failed."-      (Just ps, Nothing) -> return $ scanBundle ps-      (Nothing, Just ps) -> return $ scanBundle ps-      -- We use careful_scan_bundle only below because in either of the two-      -- above case we know the patch was signed, so it really shouldn't-      -- need stripping of CRs.-      (Just ps1, Just ps2) -> case careful_scan_bundle ps1 of-                              Left _ -> return $ careful_scan_bundle ps2-                              Right x -> return $ Right x-          where careful_scan_bundle ps =-                    case scanBundle ps of-                    Left e -> case scanBundle $ stripCrPS ps of-                              Right x -> Right x-                              _ -> Left e-                    x -> x-                stripCrPS :: B.ByteString -> B.ByteString-                stripCrPS ps = unlinesPS $ map stripline $ linesPS ps-                stripline p | B.null p = p-                            | BC.last p == '\r' = B.init p-                            | otherwise = p--applyHelp' :: String-applyHelp' =- "A patch bundle may introduce unresolved conflicts with existing\n" ++- "patches or with the working tree.  By default, Darcs will add conflict\n" ++- "markers (see `darcs mark-conflicts').\n" ++- "\n" ++- "The --external-merge option lets you resolve these conflicts\n" ++- "using an external merge tool.  In the option, '%a' is replaced with\n" ++- "the common ancestor (merge base), '%1' with the first version, '%2'\n" ++- "with the second version, and '%o' with the path where your resolved\n" ++- "content should go.  For example, to use the xxdiff visual merge tool\n" ++- "you'd specify: --external-merge='xxdiff -m -O -M %o %1 %a %2'\n" ++- "\n" ++- "The --allow-conflicts option will skip conflict marking; this is\n" ++- "useful when you want to treat a repository as just a bunch of patches,\n" ++- "such as using `darcs pull --union' to download of your co-workers\n" ++- "patches before going offline.\n" ++- "\n" ++- "This can mess up unrecorded changes in the working tree, forcing you\n" ++- "to resolve the conflict immediately.  To simply reject bundles that\n" ++- "introduce unresolved conflicts, using the --dont-allow-conflicts\n" ++- "option.  Making this the default in push-based workflows is strongly\n" ++- "recommended.\n" ++- "\n" ++- "Unlike most Darcs commands, `darcs apply' defaults to --all.  Use the\n" ++- "--interactive option to pick which patches to apply from a bundle.\n"--getFrom :: B.ByteString -> String-getFrom ps = readFrom $ linesPS ps-    where readFrom [] = ""-          readFrom (x:xs)-           | B.take 5 x == fromStart = BC.unpack $ B.drop 5 x-           | otherwise = readFrom xs--redirectOutput :: forall a . [DarcsFlag] -> String -> IO a -> IO a-redirectOutput opts to doit = ro opts-    where-  cc = getCc opts-  ro [] = doit-  ro (Reply f:_) =-    withStdoutTemp $ \tempf-> do {a <- doit;-                                  hClose stdout;-                                  hClose stderr;-                                  return a;-                                 } `catch` (sendit tempf)-        where sendit :: FilePath -> SomeException -> IO a-              sendit tempf e | Just ExitSuccess <- fromException e =-                do sendSanitizedEmail opts f to "Patch applied" cc tempf-                   throwIO e-              sendit tempf e | Just (_ :: ExitCode) <- fromException e =-                do sendSanitizedEmail opts f to "Patch failed!" cc tempf-                   throwIO ExitSuccess-              sendit tempf e =-                do sendSanitizedEmail opts f to "Darcs error applying patch!" cc $-                             tempf ++ "\n\nCaught exception:\n"++-                             show e++"\n"-                   throwIO ExitSuccess-  ro (_:fs) = ro fs---- |sendSanitizedEmail sends a sanitized email using the given sendmailcmd--- It takes @DacrsFlag@ options a file with the mail contents,--- To:, Subject:, CC:, and mail body-sendSanitizedEmail :: [DarcsFlag] -> String -> String -> String -> String -> String -> IO ()-sendSanitizedEmail opts file to subject cc mailtext =-    do scmd <- getSendmailCmd opts-       body <- sanitizeFile mailtext-       sendEmail file to subject cc scmd body---- sanitizeFile is used to clean up the stdout/stderr before sticking it in--- an email.--sanitizeFile :: FilePath -> IO String-sanitizeFile f = sanitize `fmap` readBinFile f-    where sanitize s = wash $ remove_backspaces "" s-          wash ('\000':s) = "\\NUL" ++ wash s-          wash ('\026':s) = "\\EOF" ++ wash s-          wash (c:cs) = c : wash cs-          wash [] = []-          remove_backspaces rev_sofar "" = reverse rev_sofar-          remove_backspaces (_:rs) ('\008':s) = remove_backspaces rs s-          remove_backspaces "" ('\008':s) = remove_backspaces "" s-          remove_backspaces rs (s:ss) = remove_backspaces (s:rs) ss--forwardingMessage :: B.ByteString-forwardingMessage = BC.pack $-    "The following patch was either unsigned, or signed by a non-allowed\n"++-    "key, or there was a GPG failure.\n"--considerForwarding :: [DarcsFlag] -> B.ByteString -> IO Bool-considerForwarding opts m = cf opts (getCc opts)-    where cf [] _ = return False-          cf (Reply t:_) cc =-              case break is_from (linesPS m) of-              (m1, f:m2) ->-                  let m_lines = forwardingMessage:m1 ++ m2-                      m' = unlinesPS m_lines-                      f' = BC.unpack (B.drop 5 f) in-                      if t == f' || t == init f'-                      then return False -- Refuse possible email loop.-                      else do-                        scmd <- getSendmailCmd opts-                        if doHappyForwarding opts-                         then resendEmail t scmd m-                         else sendEmailDoc f' t "A forwarded darcs patch" cc-                                           scmd (Just (empty,empty))-                                           (packedString m')-                        return True-              _ -> return False -- Don't forward emails lacking headers!-          cf (_:fs) cc = cf fs cc-          is_from l = B.take 5 l == fromStart--fromStart :: B.ByteString-fromStart = BC.pack "From:"
− src/Darcs/Commands/Changes.hs 
@@ -1,362 +0,0 @@---  Copyright (C) 2003-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}--#include "gadts.h"--module Darcs.Commands.Changes ( changes, log ) where-import Prelude hiding ( log, catch )-import Unsafe.Coerce (unsafeCoerce)--import Data.List ( intersect, sort, nub, find )-import Data.Maybe ( fromMaybe, fromJust, isJust )-import Control.Arrow ( second )-import Control.Exception ( catch, IOException )-import Control.Monad.State.Strict-import Control.Applicative ((<$>))--import Darcs.Patch.PatchInfoAnd ( hopefullyM, info )-import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )-import Darcs.Arguments ( DarcsFlag(GenContext, HumanReadable, MachineReadable,-                                   Interactive, Count,-                                   NumberPatches, XMLOutput, Summary,-                                   Verbose, Debug),-                         fixSubPaths, changesFormat,-                         possiblyRemoteRepoDir, getRepourl,-                         workingRepoDir, onlyToFiles,-                         summary, changesReverse,-                         matchSeveralOrRange,-                         matchMaxcount, maxCount,-                         allInteractive, showFriendly,-                         networkOptions-                      )-import Darcs.Flags ( doReverse, showChangesOnlyToFiles, UseIndex(..), ScanKnown(..) )-import Darcs.RepoPath ( SubPath(), toFilePath )-import Darcs.Patch.FileName ( fp2fn, fn2fp, normPath )-import Darcs.Repository ( PatchSet, PatchInfoAnd,-                          withRepositoryDirectory, RepoJob(..), findRepository,-                          readRepo, unrecordedChanges )-import Darcs.Patch.Set ( PatchSet(..), newset2RL )-import Darcs.Patch.Info ( toXml, showPatchInfo, escapeXML, PatchInfo )-import Darcs.Patch.Depends ( findCommonWithThem )-import Darcs.Patch.Bundle( contextPatches )-import Darcs.Patch.TouchesFiles ( lookTouch )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( RepoPatch, invert, xmlSummary, description,-                     effectOnFilePaths, listTouchedFiles, effect )-import Darcs.Witnesses.Eq ( EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(NilFL), RL(..), filterFLFL, filterRL,-                                 reverseFL, (:>)(..), mapRL )-import Darcs.Match ( firstMatch, secondMatch,-               matchAPatchread, haveNonrangeMatch,-               matchFirstPatchset, matchSecondPatchset,-             )-import Printer ( Doc, putDocLnWith, simplePrinters, (<+>), prefix, text, vcat,-                 vsep, (<>), ($$), errorDoc, insertBeforeLastline )-import Darcs.ColorPrinter ( fancyPrinters )-import Progress ( setProgressMode, debugMessage )-import Darcs.SelectChanges ( viewChanges )-import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..), seal2 )-import Storage.Hashed.Tree( Tree )--changesDescription :: String-changesDescription = "List patches in the repository."--changesHelp :: String-changesHelp =- "The `darcs changes' command lists the patches that constitute the\n" ++- "current repository or, with --repo, a remote repository.  Without\n" ++- "options or arguments, ALL patches will be listed.\n" ++- "\n" ++ changesHelp' ++- "\n" ++ changesHelp''--changes :: DarcsCommand-changes = DarcsCommand {commandProgramName = "darcs",-                        commandName = "changes",-                        commandHelp = changesHelp,-                        commandDescription = changesDescription,-                        commandExtraArgs = -1,-                        commandExtraArgHelp = ["[FILE or DIRECTORY]..."],-                        commandGetArgPossibilities = return [],-                        commandCommand = changesCmd,-                        commandPrereq = findRepository,-                        commandArgdefaults = nodefaults,-                        commandAdvancedOptions = networkOptions,-                        commandBasicOptions = [matchSeveralOrRange,-                                                 matchMaxcount,-                                                 onlyToFiles,-                                                 changesFormat,-                                                 summary,-                                                 changesReverse,-                                                 possiblyRemoteRepoDir,-                                                 workingRepoDir,-                                                 allInteractive]}--changesCmd :: [DarcsFlag] -> [String] -> IO ()-changesCmd opts args-  | GenContext `elem` opts = if not . null $ args-      then fail "changes --context cannot accept other arguments"-      else changesContext opts-  | null args = showChanges opts Nothing-  | otherwise = do-      fs <- fixSubPaths opts args-      case fs of-        [] -> putStrLn "No valid arguments were given, nothing to do."-        _ -> showChanges opts . Just . nub $ sort fs--showChanges :: [DarcsFlag] -> Maybe [SubPath] -> IO ()-showChanges opts files =-  let repodir = fromMaybe "." (getRepourl opts) in-  withRepositoryDirectory opts repodir $ RepoJob $ \repository -> do-  unless (Debug `elem` opts) $ setProgressMode False-  Sealed unrec <- case files of-    Nothing -> return $ Sealed NilFL-    Just _ -> Sealed `fmap` unrecordedChanges (UseIndex, ScanKnown) repository files-                  `catch` \(_ :: IOException) -> return (Sealed NilFL) -- this is triggered when repository is remote-  let normfp = fn2fp . normPath . fp2fn-      undoUnrecordedOnFPs = effectOnFilePaths (invert unrec)-      recFiles = map normfp . undoUnrecordedOnFPs . map toFilePath <$> files-      filtered_changes p = maybe_reverse $ getChangesInfo opts recFiles p-  debugMessage "About to read the repository..."-  patches <- readRepo repository-  debugMessage "Done reading the repository."-  if Interactive `elem` opts-    then do let (fp_and_fs, _, _) = filtered_changes patches-                fp = map fst fp_and_fs-            viewChanges opts fp-    else do when (isJust files && not (XMLOutput `elem` opts)) $-                 putStrLn $ "Changes to "++unwords (fromJust recFiles)++":\n"-            debugMessage "About to print the changes..."-            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-            putDocLnWith printers $ changelog opts ps $ filtered_changes patches-  where maybe_reverse (xs,b,c) = if doReverse opts-                                 then (reverse xs, b, c)-                                 else (xs, b, c)----- FIXME: this prose is unreadable. --twb, 2009-08-changesHelp' :: String-changesHelp' =- "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" ++- "renamed.\n" ++- "\n" ++- "When given a --from-tag, --from-patch or --from-match, only changes\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" ++- "The --last and --max-count options both limit the number of patches\n" ++- "listed.  The former applies BEFORE other filters, whereas the latter\n" ++- "applies AFTER other filters.  For example `darcs changes foo.c\n" ++- "--max-count 3' will print the last three patches that affect foo.c,\n" ++- "whereas `darcs changes --last 3 foo.c' will, of the last three\n" ++- "patches, print only those that affect foo.c.\n"--getChangesInfo :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Maybe [FilePath]-               -> PatchSet p C(x y)-               -> ( [(Sealed2 (PatchInfoAnd p), [FilePath])]-                  , [(FilePath, FilePath)]-                  , Maybe Doc )-getChangesInfo opts plain_fs ps =-    case (sp1s, sp2s) of-      (Sealed p1s, Sealed p2s) ->-          case findCommonWithThem p2s p1s of-            _ :> us ->-              let ps' = filterRL pf (reverseFL us) in-                case plain_fs of-                  Nothing -> foldr (\x xs -> (x, []) -:- xs) ([], [], Nothing) $-                    maybe id take (maxCount opts) ps'-                  Just fs -> let fs' = map (\x -> "./" ++ x) fs in-                    filterPatchesByNames (maxCount opts) fs' ps'-  where sp1s = if firstMatch opts-               then matchFirstPatchset opts ps-               else Sealed $ PatchSet NilRL NilRL-        sp2s = if secondMatch opts-               then matchSecondPatchset opts ps-               else Sealed $ ps-        pf = if haveNonrangeMatch opts-             then matchAPatchread opts-             else \_ -> True---- | Take a list of filenames and patches and produce a list of patches that--- actually touch the given files with a list of touched file names, a list of--- original-to-current filepath mappings, indicating the original names of the--- affected files and possibly an error. Additionaly, the function takes a--- "depth limit" -- maxcount, that could be Nothing (return everything) or--- "Just n" -- returns at most n patches touching the file (starting from the--- beginning of the patch list).-filterPatchesByNames :: (RepoPatch p, ApplyState p ~ Tree) =>-                           Maybe Int -- ^ maxcount-                        -> [FilePath] -- ^ filenames-                        -> [Sealed2 (PatchInfoAnd p)] -- ^ patchlist-                        -> ([(Sealed2 (PatchInfoAnd p),[FilePath])], [(FilePath, FilePath)], Maybe Doc)-filterPatchesByNames maxcount fns patches = removeNonRenames $-    evalState (filterPatchesByNames' fns patches) (maxcount, initRenames) where-        removeNonRenames (ps, renames, doc) = (ps, removeIds renames, doc)-        removeIds = filter (\(a, b) -> a /= b)-        initRenames = map (\x -> (x, x)) fns-        returnFinal = (\renames -> ([], renames, Nothing)) <$> gets snd-        filterPatchesByNames' [] _ = returnFinal-        filterPatchesByNames' _ [] = returnFinal-        filterPatchesByNames' fs (s2hp@(Sealed2 hp) : ps) = do-            (count, renames) <- get-            let stopNow = case count of-                                Nothing -> False-                                Just c -> c <= 0-            if stopNow-                then returnFinal-                else case hopefullyM hp of-                    Nothing -> do-                        let err = text "Can't find changes prior to:"-                                  $$ description hp-                        return ([], renames, Just err)-                    Just p ->-                        case lookTouch (Just renames) fs (invert p) of-                            (True, affected, [], renames') -> do-                                return ([(s2hp, affected)], renames', Nothing)-                            (True, affected, fs', renames') -> do-                                let sub1Mb c = (subtract 1) <$> c-                                modify $ \(c, _) -> (sub1Mb c, renames')-                                rest <- filterPatchesByNames' fs' ps-                                return $ (s2hp, affected) -:- rest-                            (False, _, fs', renames') -> do-                                modify $ second (const renames')-                                filterPatchesByNames' fs' ps---- | Note, lazy pattern matching is required to make functions like--- filterPatchesByNames lazy in case you are only not interested in--- the first element. E.g.:------   let (fs, _, _) = filterPatchesByNames ...-(-:-) :: a -> ([a],b,c) -> ([a],b,c)-x -:- ~(xs,y,z) = (x:xs,y,z)--changelog :: forall p C(start x)-           . (RepoPatch p, ApplyState p ~ Tree)-          => [DarcsFlag] -> PatchSet p C(start x)-          -> ([(Sealed2 (PatchInfoAnd p), [FilePath])], [(FilePath, FilePath)], Maybe Doc)-          -> Doc-changelog opts patchset (pis_and_fs, createdAsFs, mbErr)-    | Count `elem` opts = text $ show $ length pis_and_fs-    | MachineReadable `elem` opts =-        maybe (vsep $ map (unseal2 (showPatchInfo.info)) pis) errorDoc mbErr-    | XMLOutput `elem` opts =-         text "<changelog>"-      $$ vcat created_as_xml-      $$ vcat actual_xml_changes-      $$ text "</changelog>"-    | Summary `elem` opts || Verbose `elem`  opts =-        mbAppendErr $ vsep (map (number_patch change_with_summary) pis_and_fs)-    | otherwise = mbAppendErr $ vsep (map (number_patch description') pis_and_fs)-    where mbAppendErr = maybe id (\err -> ($$ err)) mbErr-          change_with_summary :: (Sealed2 (PatchInfoAnd p), [FilePath]) -> Doc-          change_with_summary (Sealed2 hp, fs)-              | Just p <- hopefullyM hp = if showChangesOnlyToFiles opts-                                          then description hp $$ text "" $$-                                               indent (showFriendly opts (filterFLFL xx $ effect p))-                                          else showFriendly opts p-              | otherwise = description hp-                            $$ indent (text "[this patch is unavailable]")-              where xx x = case listTouchedFiles x of-                             ys | null $ ys `intersect` fs -> unsafeCoerce IsEq-                             -- in that case, the change does not affect the patches we are-                             -- looking at, so we ignore the difference between the two states.-                             -- It's all read-only anyway.-                             _ -> NotEq-          xml_with_summary (Sealed2 hp)-              | Just p <- hopefullyM hp = insertBeforeLastline-                                           (toXml $ info hp) (indent $ xmlSummary p)-          xml_with_summary (Sealed2 hp) = toXml (info hp)-          indent = prefix "    "-          actual_xml_changes = if Summary `elem` opts-                               then map xml_with_summary pis-                               else map (toXml . (unseal2 info)) pis--          created_as_xml = map create createdAsFs where-            create rename@(_, as) = createdAsXml (first_change_of as) rename-            -- We need to reorder the patches when they haven't been reversed-            -- already, so that we find the *first* patch that modifies a given-            -- file, not the last (by default, the list is oldest->newest).-            reorderer = if not (doReverse opts) then reverse else id-            oldest_first_pis_and_fs = reorderer pis_and_fs-            couldnt_find fn = error $ "Couldn't find first patch affecting " ++-                                      fn ++ " in pis_and_fs"-            mb_first_change_of fn = find ((fn `elem`) . snd) oldest_first_pis_and_fs-            find_first_change_of fn = fromMaybe (couldnt_find fn)-              (mb_first_change_of fn)-            first_change_of = unseal2 info . fst . find_first_change_of-          number_patch f x = if NumberPatches `elem` opts-                             then case get_number (fst x) of-                                  Just n -> text (show n++":") <+> f x-                                  Nothing -> f x-                             else f x-          get_number :: Sealed2 (PatchInfoAnd p) -> Maybe Int-          get_number (Sealed2 y) = gn 1 (newset2RL patchset)-              where iy = info y-                    gn :: Int -> RL (PatchInfoAnd p) C(start y) -> Maybe Int-                    gn n (b:<:bs) | seq n (info b) == iy = Just n-                                  | otherwise = gn (n+1) bs-                    gn _ NilRL = Nothing-          pis = map fst pis_and_fs-          description' = unseal2 description . fst---- FIXME: this prose is unreadable. --twb, 2009-08-changesHelp'' :: String-changesHelp'' =- "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" ++- "\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" ++- "character and was recorded in a non-UTF8 locale.\n" ++- "\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" ++- "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"--changesContext :: [DarcsFlag] -> IO ()-changesContext opts = do-  let repodir = fromMaybe "." $ getRepourl opts-  withRepositoryDirectory opts repodir $ RepoJob $ \repository -> do-  (_ :> ps') <- contextPatches `fmap` readRepo repository-  let ps = mapRL (\p -> (seal2 p, [])) ps'-  unless fancy $ putStrLn "\nContext:\n"-  putDocLnWith simplePrinters $ changelog opts' emptyset (ps, [], Nothing)-    where opts' = if fancy then opts else MachineReadable : opts-          fancy = HumanReadable `elem` opts || XMLOutput `elem` opts-          emptyset = PatchSet NilRL NilRL--log :: DarcsCommand-log = commandAlias "log" Nothing changes--createdAsXml :: PatchInfo -> (String, String) -> Doc-createdAsXml pinfo (current, createdAs) =-    text "<created_as current_name='"-       <> escapeXML current-       <> text "' original_name='"-       <> escapeXML createdAs-       <> text "'>"-    $$    toXml pinfo-    $$    text "</created_as>"
− src/Darcs/Commands/Check.hs 
@@ -1,167 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.Check ( check, repair ) where--import Prelude hiding ( catch )--import Control.Monad ( when, unless )-import Control.Applicative( (<$>) )-import Control.Exception ( catch, IOException )-import System.Exit ( ExitCode(..), exitWith )-import System.Directory( renameFile )--import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo )-import Darcs.Arguments ( DarcsFlag(Quiet),-                         test, umaskOption,-                        leaveTestDir, workingRepoDir, ignoretimes-                      )-import Darcs.Flags(willIgnoreTimes)-import Darcs.Repository.Repair( replayRepository, checkIndex,-                                replayRepositoryInTemp,-                                RepositoryConsistency(..) )-import Darcs.Repository ( Repository, amInHashedRepository, withRepository,-                          testRecorded, readRecorded, RepoJob(..),-                          withRepoLock, replacePristine, writePatchSet )-import Darcs.Patch ( RepoPatch, showPatch, PrimOf )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft )-import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.Diff( treeDiff )-import Printer ( text, ($$), (<+>) )-import Storage.Hashed.Tree( Tree )--#include "gadts.h"--checkDescription :: String-checkDescription = "Check the repository for consistency."--checkHelp :: String-checkHelp =- "This command verifies that the patches in the repository, when applied\n" ++- "successively to an empty tree, result in the pristine tree.  If not,\n" ++- "the differences are printed and Darcs exits unsucessfully (with a\n" ++- "non-zero exit status).\n" ++- "\n" ++- "If a regression test is defined (see `darcs setpref') it will be run\n" ++- "by `darcs check'.  Use the --no-test option to disable this.\n"--check :: DarcsCommand-check = DarcsCommand {commandProgramName = "darcs",-                      commandName = "check",-                      commandHelp = checkHelp,-                      commandDescription = checkDescription,-                      commandExtraArgs = 0,-                      commandExtraArgHelp = [],-                      commandCommand = checkCmd,-                      commandPrereq = amInHashedRepository,-                      commandGetArgPossibilities = return [],-                      commandArgdefaults = nodefaults,-                      commandAdvancedOptions = [],-                      commandBasicOptions = [ test,-                                              leaveTestDir,-                                              workingRepoDir,-                                               ignoretimes-                                             ]}--checkCmd :: [DarcsFlag] -> [String] -> IO ()-checkCmd opts _ = withRepository opts (RepoJob (check' opts))--check'-  :: forall p C(r u t) . (RepoPatch p, ApplyState p ~ Tree)-  => [DarcsFlag] -> Repository p C(r u t) -> IO ()-check' opts repository = do-    state <- replayRepositoryInTemp repository opts-    failed <--      case state of-        RepositoryConsistent -> do-          putInfo opts $ text "The repository is consistent!"-          rc <- testRecorded repository-          when (rc /= ExitSuccess) $ exitWith rc-          return False-        BrokenPristine newpris -> do-          brokenPristine newpris-          return True-        BrokenPatches newpris _ -> do-          brokenPristine newpris-          putInfo opts $ text "Found broken patches."-          return True-    bad_index <- case willIgnoreTimes opts of-                   False -> not <$> checkIndex repository (Quiet `elem` opts)-                   True -> return False-    when bad_index $ putInfo opts $ text "Bad index."-    exitWith $ if failed || bad_index then ExitFailure 1 else ExitSuccess-   where-     brokenPristine newpris = do-         putInfo opts $ text "Looks like we have a difference..."-         mc' <- (fmap Just $ readRecorded repository) `catch` (\(_ :: IOException) -> return Nothing)-         case mc' of-           Nothing -> do putInfo opts $ text "cannot compute that difference, try repair"-                         putInfo opts $ text "" $$ text "Inconsistent repository"-                         return ()-           Just mc -> do-               ftf <- filetypeFunction-               Sealed (diff :: FL (PrimOf p) C(r r2)) <- unFreeLeft `fmap` treeDiff ftf newpris mc :: IO (Sealed (FL (PrimOf p) C(r)))-               putInfo opts $ case diff of-                        NilFL -> text "Nothing"-                        patch -> text "Difference: " <+> showPatch patch-               putInfo opts $ text ""-                     $$ text "Inconsistent repository!"---repairDescription :: String-repairDescription = "Repair a corrupted repository."--repairHelp :: String-repairHelp =- "The `darcs repair' command attempts to fix corruption in the current\n" ++- "repository.  Currently it can only repair damage to the pristine tree,\n" ++- "which is where most corruption occurs.\n"--repair :: DarcsCommand-repair = DarcsCommand {commandProgramName = "darcs",-                       commandName = "repair",-                       commandHelp = repairHelp,-                       commandDescription = repairDescription,-                       commandExtraArgs = 0,-                       commandExtraArgHelp = [],-                       commandCommand = repairCmd,-                       commandPrereq = amInHashedRepository,-                       commandGetArgPossibilities = return [],-                       commandArgdefaults = nodefaults,-                       commandAdvancedOptions = [umaskOption],-                       commandBasicOptions = [workingRepoDir]}--repairCmd :: [DarcsFlag] -> [String] -> IO ()-repairCmd opts _ = withRepoLock opts $ RepoJob $ \repository -> do-  replayRepository repository opts $ \state ->-    case state of-      RepositoryConsistent ->-          putStrLn "The repository is already consistent, no changes made."-      BrokenPristine tree -> do-               putStrLn "Fixing pristine tree..."-               replacePristine repository tree-      BrokenPatches tree newps  -> do-               putStrLn "Writing out repaired patches..."-               _ <- writePatchSet newps opts-               putStrLn "Fixing pristine tree..."-               replacePristine repository tree-  index_ok <- checkIndex repository (Quiet `elem` opts)-  unless index_ok $ do renameFile "_darcs/index" "_darcs/index.bad"-                       putStrLn "Bad index discarded."-
− src/Darcs/Commands/Convert.hs 
@@ -1,261 +0,0 @@---  Copyright (C) 2002-2005,2007 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, MagicHash #-}--#include "gadts.h"--module Darcs.Commands.Convert ( convert ) where--import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,-                   createDirectory )-import Workaround ( getCurrentDirectory )-import Control.Monad ( when )-import GHC.Base ( unsafeCoerce# )-import Data.Maybe ( catMaybes )-import qualified Data.ByteString as B--import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, info, hopefully )-import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo )-import Darcs.Arguments-   ( DarcsFlag-      ( AllowConflicts, NewRepo, SetScriptsExecutable, UseFormat2-      , NoUpdateWorking-      )-   , reponame-   , setScriptsExecutableOption-   , networkOptions-   )-import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), withRepositoryDirectory, readRepo,-                          createRepository, invalidateIndex,-                          optimizeInventory,-                          tentativelyMergePatches, patchSetToPatches,-                          createPristineDirectoryTree,-                          revertRepositoryChanges, finalizeRepositoryChanges,-                          applyToWorking, setScriptsExecutable )-import Darcs.Global ( darcsdir )-import Darcs.Patch ( Named, showPatch, patch2patchinfo, fromPrim, fromPrims,-                     infopatch, adddeps, getdeps, effect, patchcontents )-import Darcs.Witnesses.Eq ( EqCheck(..), (=/\=) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapFL_FL,-                                 concatFL, mapRL )-import Darcs.Patch.Info ( piRename, piTag, isTag, PatchInfo )-import Darcs.Patch.V1 ( Patch )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.V1.Commute ( publicUnravel )-import Darcs.Patch.V1.Core ( Patch(PP), isMerger )-import Darcs.Patch.V2.Real ( mergeUnravelled )-import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), newset2RL )-import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )-import Darcs.Repository.Format(identifyRepoFormat, formatHas, RepoProperty(Darcs2))-import Darcs.Repository.Motd ( showMotd )-import Darcs.Utils ( clarifyErrors, askUser, catchall )-import Darcs.ProgressPatches ( progressFL )-import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(..) )-import Printer ( text, ($$) )-import Darcs.ColorPrinter ( traceDoc )-import Darcs.Lock ( writeBinFile )-import Darcs.External ( fetchFilePS, Cachable(Uncachable) )-import System.FilePath.Posix--#include "gadts.h"-#include "impossible.h"--convertDescription :: String-convertDescription = "Convert a repository from a legacy format."--convertHelp :: String-convertHelp =- "The current repository format is called `darcs-2'.  It was introduced\n" ++- "in Darcs 2.0 and became the default for new projects in Darcs 2.2.\n" ++- "The `darcs convert' command allows existing projects to migrate to\n" ++- "this format from the older `darcs-1' format.\n" ++- "\n" ++- "This command DOES NOT modify the source repository; a new destination\n" ++- "repository is created.  It is safe to run this command more than once\n" ++- "on a repository (e.g. for testing), before the final conversion.\n" ++- "\n" ++- convertHelp' ++- "\n" ++- "Due to this limitation, migrating a multi-branch project is a little\n" ++- "awkward.  Sorry!  Here is the recommended process:\n" ++- "\n" ++- " 1. for each branch `foo', tag that branch with `foo-final';\n" ++- " 2. merge all branches together (--allow-conflicts may help);\n" ++- " 3. run `darcs optimize --reorder' on the result;\n" ++- " 4. run `darcs convert' to create a merged darcs-2 repository;\n" ++- " 5. re-create each branch by calling `darcs get --tag foo-final' on\n" ++- "    the darcs-2 repository; and finally\n" ++- " 6. use `darcs obliterate' to delete the foo-final tags.\n"---- | This part of the help is split out because it is used twice: in--- the help string, and in the prompt for confirmation.-convertHelp' :: String-convertHelp' =- "WARNING: the repository produced by this command is not understood by\n" ++- "Darcs 1.x, and patches cannot be exchanged between repositories in\n" ++- "darcs-1 and darcs-2 formats.\n" ++- "\n" ++- "Furthermore, darcs 2 repositories created by different invocations of\n" ++- "this command SHOULD NOT exchange patches, unless those repositories\n" ++- "had no patches in common when they were converted.  (That is, within a\n" ++- "set of repos that exchange patches, no patch should be converted more\n" ++- "than once.)\n"--convert :: DarcsCommand-convert = DarcsCommand {commandProgramName = "darcs",-                    commandName = "convert",-                    commandHelp = convertHelp,-                    commandDescription = convertDescription,-                    commandExtraArgs = -1,-                    commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"],-                    commandCommand = convertCmd,-                    commandPrereq = \_ -> return $ Right (),-                    commandGetArgPossibilities = return [],-                    commandArgdefaults = nodefaults,-                    commandAdvancedOptions = networkOptions,-                    commandBasicOptions = [reponame,setScriptsExecutableOption]}--convertCmd :: [DarcsFlag] -> [String] -> IO ()-convertCmd opts [inrepodir, outname] = convertCmd (NewRepo outname:opts) [inrepodir]-convertCmd orig_opts [inrepodir] = do--  typed_repodir <- ioAbsoluteOrRemote inrepodir-  let repodir = toPath typed_repodir--  --test for converting darcs-2 repository-  format <- identifyRepoFormat repodir-  when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."--  putStrLn convertHelp'-  let vow = "I understand the consequences of my action"-  putStrLn "Please confirm that you have read and understood the above"-  vow' <- askUser ("by typing `" ++ vow ++ "': ")-  when (vow' /= vow) $ fail "User didn't understand the consequences."--  let opts = UseFormat2:orig_opts-  showMotd opts repodir-  mysimplename <- makeRepoName opts repodir-  createDirectory mysimplename-  setCurrentDirectory mysimplename-  createRepository opts-  writeBinFile (darcsdir++"/hashed_inventory") ""-  withRepoLock (NoUpdateWorking:opts) $ V2Job $ \repository ->-    withRepositoryDirectory opts repodir $ V1Job $ \themrepo -> do-      theirstuff <- readRepo themrepo-      let patches = mapFL_FL convertNamed $ patchSetToPatches theirstuff-          inOrderTags = iot theirstuff-              where iot :: PatchSet p C(s x) -> [PatchInfo]-                    iot (PatchSet _ ts) = iot_ ts-                    iot_ :: RL(Tagged t1) C(t y) -> [PatchInfo]-                    iot_ (Tagged t _ _ :<: ts) = info t : iot_ ts-                    iot_ NilRL = []-          outOfOrderTags = catMaybes $ mapRL oot $ newset2RL theirstuff-              where oot t = if isTag (info t) && not (info t `elem` inOrderTags)-                            then Just (info t, getdeps $ hopefully t)-                            else Nothing-          fixDep p = case lookup p outOfOrderTags of-                     Just d -> p : concatMap fixDep d-                     Nothing -> [p]-          convertOne :: Patch Prim C(x y) -> FL (RealPatch Prim) C(x y)-          convertOne x | isMerger x = case mergeUnravelled $ publicUnravel x of-                                       Just (FlippedSeal y) ->-                                           case effect y =/\= effect x of-                                           IsEq -> y :>: NilFL-                                           NotEq ->-                                               traceDoc (text "lossy conversion:" $$-                                                         showPatch x)-                                               fromPrims (effect x)-                                       Nothing -> traceDoc (text-                                                            "lossy conversion of complicated conflict:" $$-                                                            showPatch x)-                                                  fromPrims (effect x)-          convertOne (PP x) = fromPrim x :>: NilFL-          convertOne _ = impossible-          convertFL :: FL (Patch Prim) C(x y) -> FL (RealPatch Prim) C(x y)-          convertFL = concatFL . mapFL_FL convertOne-          convertNamed :: Named (Patch Prim) C(x y) -> PatchInfoAnd (RealPatch Prim) C(x y)-          convertNamed n = n2pia $-                           adddeps (infopatch (convertInfo $ patch2patchinfo n) $-                                              convertFL $ patchcontents n)-                                   (map convertInfo $ concatMap fixDep $ getdeps n)-          convertInfo n | n `elem` inOrderTags = n-                        | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n-          applySome xs = do -- TODO this unsafeCoerce hack is because we don't keep track of the repository state properly-                            -- Really sequence_ $ mapFL applySome below should instead be a repeated add operation --                            -- there doesn't seem to be any reason we need to do a merge here.-                            let repository2 = unsafeCoerce# repository :: Repository (RealPatch Prim) C(a b a)-                            Sealed pw <- tentativelyMergePatches repository2 "convert" (AllowConflicts:opts) NilFL xs-                            finalizeRepositoryChanges repository2 -- this is to clean out pristine.hashed-                            revertRepositoryChanges repository2-                            _ <- revertable $ applyToWorking repository2 opts pw-                            invalidateIndex repository2-      sequence_ $ mapFL applySome $ bunchFL 100 $ progressFL "Converting patch" patches-      invalidateIndex repository-      revertable $ createPristineDirectoryTree repository "."-      when (SetScriptsExecutable `elem` opts) $ setScriptsExecutable--      -- Copy over the prefs file-      let prefsRelPath = darcsdir </> "prefs" </> "prefs"-      (fetchFilePS (repodir </> prefsRelPath) Uncachable >>= B.writeFile prefsRelPath)-       `catchall` return ()--      optimizeInventory repository-      putInfo opts $ text "Finished converting."-      where revertable x = x `clarifyErrors` unlines-                  ["An error may have left your new working directory an inconsistent",-                   "but recoverable state. You should be able to make the new",-                   "repository consistent again by running darcs revert -a."]--convertCmd _ _ = fail "You must provide 'convert' with either one or two arguments."--makeRepoName :: [DarcsFlag] -> FilePath -> IO String-makeRepoName (NewRepo n:_) _ =-    do exists <- doesDirectoryExist n-       file_exists <- doesFileExist n-       if exists || file_exists-          then fail $ "Directory or file named '" ++ n ++ "' already exists."-          else return n-makeRepoName (_:as) d = makeRepoName as d-makeRepoName [] d =-  case dropWhile (=='.') $ reverse $-       takeWhile (\c -> c /= '/' && c /= ':') $-       dropWhile (=='/') $ reverse d of-  "" -> modifyRepoName "anonymous_repo"-  base -> modifyRepoName base--modifyRepoName :: String -> IO String-modifyRepoName name =-    if head name == '/'-    then mrn name (-1)-    else do cwd <- getCurrentDirectory-            mrn (cwd ++ "/" ++ name) (-1)- where-  mrn :: String -> Int -> IO String-  mrn n i = do-    exists <- doesDirectoryExist thename-    file_exists <- doesFileExist thename-    if not exists && not file_exists-       then do when (i /= -1) $-                    putStrLn $ "Directory '"++ n ++-                               "' already exists, creating repository as '"++-                               thename ++"'"-               return thename-       else mrn n $ i+1-    where thename = if i == -1 then n else n++"_"++show i-
− src/Darcs/Commands/Diff.hs 
@@ -1,214 +0,0 @@---  Copyright (C) 2003-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Diff ( diffCommand ) where--import System.FilePath.Posix ( takeFileName )-import Workaround ( getCurrentDirectory )-import Darcs.Utils ( askEnter, withCurrentDirectory )-import Control.Monad ( when )-import Data.List ( (\\) )--import Storage.Hashed.Plain( writePlainTree )--import Darcs.External( diffProgram )-import CommandLine ( parseCmd )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments-    ( DarcsFlag(AfterPatch, DiffCmd, DiffFlags, LastN)-    , diffCmdFlag-    , diffflags-    , fixSubPaths-    , matchRange-    , pauseForGui-    , storeInMemory-    , unidiff-    , workingRepoDir-    )-import Darcs.Flags ( isNotUnified, wantGuiPause )-import Darcs.Patch.PatchInfoAnd ( info )-import Darcs.RepoPath ( AbsolutePath, SubPath, toFilePath, sp2fn )-import Darcs.Match ( getPartialFirstMatch, getPartialSecondMatch,-                     firstMatch, secondMatch,-                     matchFirstPatchset, matchSecondPatchset )-import Darcs.Repository ( withRepository, RepoJob(..), readRepo,-                          amInHashedRepository,-                          createPristineDirectoryTree,-                          createPartialsPristineDirectoryTree )-import Darcs.Patch.Set ( PatchSet, newset2RL )-import Darcs.Repository.State ( readUnrecorded )-import Darcs.Patch ( RepoPatch )-import Darcs.Witnesses.Ordered ( mapRL )-import Darcs.Patch.Info ( PatchInfo, humanFriendly )-import Darcs.External ( execPipeIgnoreError )-import Darcs.Lock ( withTempDir )-import Darcs.Witnesses.Sealed ( unseal )-import Printer ( Doc, putDoc, vcat, empty, ($$) )-#include "impossible.h"--#include "gadts.h"--diffDescription :: String-diffDescription = "Create a diff between two versions of the repository."--diffHelp :: String-diffHelp =- "The `darcs diff' command compares two versions of the working tree of\n" ++- "the current repository.  Without options, the pristine (recorded) and\n" ++- "unrecorded working trees are compared.  This is lower-level than\n" ++- "the `darcs whatsnew' command, since it outputs a line-by-line diff,\n" ++- "and it is also slower.  As with `darcs whatsnew', if you specify\n" ++- "files or directories, changes to other files are not listed.\n" ++- "The command always uses an external diff utility.\n" ++- "\n" ++- "With the --patch option, the comparison will be made between working\n" ++- "trees with and without that patch.  Patches `after' the selected patch\n" ++- "are not present in either of the compared working trees.  The\n" ++- "--from-patch and --to-patch options allow the set of patches in the\n" ++- "`old' and `new' working trees to be specified separately.\n" ++- "\n" ++- "The associated tag and match options are also understood, e.g. `darcs\n" ++- "diff --from-tag 1.0 --to-tag 1.1'.  All these options assume an\n" ++- "ordering of the patch set, so results may be affected by operations\n" ++- "such as `darcs optimize --reorder'.\n" ++- "\n" ++- "diff(1) is called with the arguments -rN.  The --unified option causes\n" ++- "-u to be passed to diff(1).  An additional argument can be passed\n" ++- "using --diff-opts, such as --diff-opts=-ud or --diff-opts=-wU9.\n" ++- "\n" ++- "The --diff-command option can be used to specify an alternative\n" ++- "utility, such as meld (GNOME) or opendiff (OS X).  Arguments may be\n" ++- "included, separated by whitespace.  The value is not interpreted by a\n" ++- "shell, so shell constructs cannot be used.  The arguments %1 and %2\n" ++- "MUST be included, these are substituted for the two working trees\n" ++- "being compared.  If this option is used, --diff-opts is ignored.\n"--diffCommand :: DarcsCommand-diffCommand = DarcsCommand {commandProgramName = "darcs",-                             commandName = "diff",-                             commandHelp = diffHelp,-                             commandDescription = diffDescription,-                             commandExtraArgs = -1,-                             commandExtraArgHelp-                                 = ["[FILE or DIRECTORY]..."],-                             commandCommand = diffCmd,-                             commandPrereq = amInHashedRepository,-                             commandGetArgPossibilities = return [],-                             commandArgdefaults = nodefaults,-                             commandAdvancedOptions =-                                [ pauseForGui-                                ],-                             commandBasicOptions =-                                [ matchRange-                                , diffCmdFlag-                                , diffflags-                                , unidiff-                                , workingRepoDir-                                , storeInMemory-                                ]-                           }--getDiffOpts :: [DarcsFlag] -> [String]-getDiffOpts opts | isNotUnified opts = get_nonU_diff_opts opts-                 | otherwise         = "-u" : get_nonU_diff_opts opts-    where get_nonU_diff_opts (DiffFlags f:fs) = f : get_nonU_diff_opts fs-          get_nonU_diff_opts (_:fs) = get_nonU_diff_opts fs-          get_nonU_diff_opts [] = []---- | Returns the command we should use for diff as a tuple (command, arguments).--- This will either be whatever the user specified via --diff-command  or the--- default 'diffProgram'.  Note that this potentially involves parsing the--- user's diff-command, hence the possibility for failure with an exception.-getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String-                      -> Either String (String, [String])-getDiffCmdAndArgs cmd opts f1 f2 = helper opts where-  helper (DiffCmd c:_) =-    case parseCmd [ ('1', f1) , ('2', f2) ] c of-    Left err        -> Left $ show err-    Right ([],_)    -> bug $ "parseCmd should never return empty list"-    Right ((h:t),_) -> Right (h,t)-  helper [] = -- if no command specified, use 'diff'-    Right (cmd, ("-rN":getDiffOpts opts++[f1,f2]))-  helper (_:t) = helper t--diffCmd :: [DarcsFlag] -> [String] -> IO ()-diffCmd opts args-  | not (null [i | LastN i <- opts]) &&-      not (null [p | AfterPatch p <- opts]) =-        fail $ "using --patch and --last at the same time with the 'diff'" ++-          " command doesn't make sense. Use --from-patch to create a diff" ++-          " from this patch to the present, or use just '--patch' to view" ++-          " this specific patch."-  | null args = doDiff opts Nothing-  | otherwise = doDiff opts . Just =<< fixSubPaths opts args--doDiff :: [DarcsFlag] -> Maybe [SubPath] ->  IO ()-doDiff opts sps = withRepository opts $ RepoJob $ \repository -> do-  let pathList = map sp2fn `fmap` sps-  formerdir <- getCurrentDirectory-  withTempDirs (takeFileName formerdir) $ \odir ndir -> do-    if firstMatch opts-      then withCurrentDirectory odir $ getPartialFirstMatch repository opts pathList-      else case pathList of-        Nothing -> createPristineDirectoryTree repository $ toFilePath odir-        Just pl -> createPartialsPristineDirectoryTree repository pl $ toFilePath odir-    if secondMatch opts-       then withCurrentDirectory ndir $ getPartialSecondMatch repository opts pathList-       else withCurrentDirectory formerdir $-               readUnrecorded repository sps >>= (flip writePlainTree (toFilePath ndir))-    thediff <- withCurrentDirectory (toFilePath odir ++ "/..") $-                   case pathList of-                   Nothing -> rundiff (takeFileName $ toFilePath odir) (takeFileName $ toFilePath ndir)-                   Just fs -> vcat `fmap`-                         mapM (\f -> rundiff-                               (takeFileName (toFilePath odir) ++ "/" ++ toFilePath f)-                               (takeFileName (toFilePath ndir) ++ "/" ++ toFilePath f)) fs-    morepatches <- readRepo repository-    putDoc $ changelog (getDiffInfo opts morepatches)-            $$ thediff-    where rundiff :: String -> String -> IO Doc-          rundiff f1 f2 = do-            cmd <- diffProgram-            case getDiffCmdAndArgs cmd opts f1 f2 of-             Left err -> fail err-             Right (d_cmd, d_args) ->-              let pausingForGui = wantGuiPause opts in-              do when pausingForGui $ putStrLn $-                   "Running command '" ++ unwords (d_cmd:d_args) ++ "'"-                 output <- execPipeIgnoreError d_cmd d_args empty-                 when pausingForGui $-                    askEnter "Hit return to move on..."-                 return output--          withTempDirs :: String -> (AbsolutePath -> AbsolutePath -> IO a) -> IO a-          withTempDirs x f = withTempDir ("old-" ++ x) $ \odir ->-            withTempDir ("new-" ++ x) $ \ndir -> f odir ndir--getDiffInfo :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> [PatchInfo]-getDiffInfo opts ps =-    let infos = mapRL info . newset2RL-        handle (match_cond, do_match)-          | match_cond opts = unseal infos (do_match opts ps)-          | otherwise = infos ps-    in handle (secondMatch, matchSecondPatchset)-         \\ handle (firstMatch, matchFirstPatchset)--changelog :: [PatchInfo] -> Doc-changelog pis = vcat $ map humanFriendly pis-
− src/Darcs/Commands/Dist.hs 
@@ -1,172 +0,0 @@---  Copyright (C) 2003 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.---- |--- Module      : Darcs.Commands.Dist--- Copyright   : 2003 David Roundy--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Darcs.Commands.Dist-    (-      dist-    ) where--import Prelude hiding ( writeFile )--import Data.ByteString.Lazy ( writeFile )-import Data.Char ( isAlphaNum )-import Control.Monad ( when )-import System.Directory ( setCurrentDirectory )-import System.Cmd ( system )-import System.Exit ( ExitCode(..), exitWith )-import System.FilePath.Posix ( takeFileName, (</>) )--import Workaround ( getCurrentDirectory )-import Codec.Archive.Tar ( pack, write )-import Codec.Archive.Tar.Entry ( entryPath )-import Codec.Compression.GZip ( compress )--import Darcs.Arguments ( DarcsFlag(Verbose, Quiet, DistName, SetScriptsExecutable), distnameOption,-                         workingRepoDir, matchOne, storeInMemory,-                         setScriptsExecutableOption )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Lock ( withTempDir )-import Darcs.Match ( getNonrangeMatch, haveNonrangeMatch, firstMatch, getFirstMatch )-import Darcs.Repository ( amInHashedRepository, withRepoReadLock, RepoJob(..),-                          setScriptsExecutable,-                          createPartialsPristineDirectoryTree )-import Darcs.Repository.Prefs ( getPrefval )-import Darcs.RepoPath ( AbsolutePath, toFilePath )-import Darcs.Utils ( withCurrentDirectory )---distDescription :: String-distDescription = "Create a distribution tarball."---distHelp :: String-distHelp =-    "The `darcs dist' command creates a compressed archive (a `tarball') in\n" ++-     "the repository's root directory, containing the recorded state of the\n" ++-     "working tree (unrecorded changes and the _darcs directory are\n" ++-     "excluded).\n" ++-     "\n" ++-     "If a predist command is set (see `darcs setpref'), that command will\n" ++-     "be run on the tarball contents prior to archiving.  For example,\n" ++-     "autotools projects would set it to `autoconf && automake'.\n" ++-     "\n" ++-     "By default, the tarball (and the top-level directory within the\n" ++-     "tarball) has the same name as the repository, but this can be\n" ++-     "overridden with the --dist-name option.\n"--     -- FIXME: this is tedious and ugly.-     {--     ++ "\n" ++-     "Suppose you use a version numbering scheme `major.minor.patch', and\n" ++-     "you tag each release `major.minor'.  You can then calculate the\n" ++-     "version number by taking the newest tag and appending a dot and the\n" ++-     "number of patches since that tag.  If you use the directory name as\n" ++-     "the project name, you can make tarballs of the form name-version.tgz\n" ++-     "using the following shell script:\n" ++-     "\n" ++-     "  major_minor=$(darcs show tags | head -1) &&\n" ++-     "  patch_level=$(($(darcs changes --count --from-tag .) - 1)) &&\n" ++-     "  version=$major_minor.$patch_level &&\n" ++-     "  project=${PWD##*/} &&\n" ++-     "  darcs dist --dist-name \"$project\"-\"$version\".tar.gz\n"-     -}---dist :: DarcsCommand-dist = DarcsCommand-    {-      commandProgramName = "darcs"-    , commandName = "dist"-    , commandHelp = distHelp-    , commandDescription = distDescription-    , commandExtraArgs = 0-    , commandExtraArgHelp = []-    , commandCommand = distCmd-    , commandPrereq = amInHashedRepository-    , commandGetArgPossibilities = return []-    , commandArgdefaults = nodefaults-    , commandAdvancedOptions = []-    , commandBasicOptions =-        [-          distnameOption-        , workingRepoDir-        , matchOne-        , setScriptsExecutableOption-        , storeInMemory-        ]-    }---distCmd :: [DarcsFlag]-        -> [String]-        -> IO ()-distCmd opts _ = withRepoReadLock opts $ RepoJob $ \repository -> do-  formerdir <- getCurrentDirectory-  let distname = getDistName formerdir [x | DistName x <- opts]-  predist <- getPrefval "predist"-  let resultfile = formerdir </> distname ++ ".tar.gz"-  withTempDir "darcsdist" $ \tempdir -> do-    setCurrentDirectory formerdir-    withTempDir (toFilePath tempdir </> takeFileName distname) $ \ddir -> do-      if haveNonrangeMatch opts-        then-            if firstMatch opts-                then withCurrentDirectory ddir $ getFirstMatch repository opts-                else withCurrentDirectory ddir $ getNonrangeMatch repository opts-        else createPartialsPristineDirectoryTree repository [""] (toFilePath ddir)-      ec <- case predist of Nothing -> return ExitSuccess-                            Just pd -> system pd-      if ec == ExitSuccess-          then-              do-              withCurrentDirectory ddir $-                  when (SetScriptsExecutable `elem` opts) setScriptsExecutable-              doDist opts tempdir ddir resultfile-          else-              do-              putStrLn "Dist aborted due to predist failure"-              exitWith ec----- | This function performs the actual distribution action itself.--- NB - it does /not/ perform the pre-dist, that should already--- have completed successfully before this is invoked.-doDist :: [DarcsFlag] -> AbsolutePath -> AbsolutePath -> FilePath -> IO ()-doDist opts tempdir ddir resultfile = do-    setCurrentDirectory (toFilePath tempdir)-    let safeddir = safename $ takeFileName $ toFilePath ddir-    entries <- pack "." [safeddir]-    when (Verbose `elem` opts) $ putStr $ unlines $ map entryPath entries-    writeFile resultfile $ compress $ write entries-    when (Quiet `notElem` opts) $ putStrLn $ "Created dist as " ++ resultfile-  where-    safename n@(c:_) | isAlphaNum c  = n-    safename n = "./" ++ n---getDistName :: FilePath -> [String] -> FilePath-getDistName _ (dn:_) = dn-getDistName currentDirectory _ = takeFileName currentDirectory-
− src/Darcs/Commands/GZCRCs.hs 
@@ -1,185 +0,0 @@---  Copyright (C) 2009 Ganesh Sittampalam------ 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--- SOFTWARE.--{-# LANGUAGE CPP #-}-module Darcs.Commands.GZCRCs ( gzcrcs, doCRCWarnings ) where--import Control.Arrow ( first )-import Control.Monad ( when, unless )-import Control.Monad.Trans ( liftIO )-import Control.Monad.Writer ( runWriterT, tell )-import Data.List ( intercalate )-import Data.Monoid ( Any(..), Sum(..) )--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL--import System.Directory ( getDirectoryContents, doesFileExist, doesDirectoryExist )-import System.Exit ( ExitCode(..), exitWith )-import System.IO ( hPutStr, hPutStrLn, stderr )-import Data.IORef ( newIORef, readIORef, writeIORef )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag( Quiet, Verbose, Check, Repair, JustThisRepo ),-                        checkOrRepair, workingRepoDir, justThisRepo-                      )-import Darcs.Repository ( Repository, amInRepository, withRepository, RepoJob(..) )-import Darcs.Patch ( RepoPatch )-import Printer ( putDocLn, text )-import ByteStringUtils ( isGZFile )-import Darcs.Lock ( gzWriteAtomicFilePSs )---- This command needs access beyond the normal repository APIs (to--- get at the caches and inspect them directly)--- Could move the relevant code into Darcs.Repository modules--- but it doesn't really seem worth it.-import Darcs.Repository.InternalTypes ( extractCache )-import Darcs.Repository.Cache ( Cache(..), writable, isthisrepo, hashedFilePath, allHashedDirs )---import Darcs.Global ( getCRCWarnings, resetCRCWarnings )-import ByteStringUtils ( gzDecompress )--#include "gadts.h"--gzcrcsDescription :: String-gzcrcsDescription = "Check or repair the CRCs of compressed files in the repository."--gzcrcsHelp :: String-gzcrcsHelp = formatText-  [-   "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed files " ++-   "with bad CRCs (but valid data) to be written out. CRCs were not checked on " ++-   "reading, so this bug wasn't noticed.",-   "This command inspects your repository for this corruption and 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 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 it encounters " ++-   "any non-CRC corruption in compressed files.",-   "You may wish to also run 'darcs check --complete' before repairing the corruption. " ++-   "This is not done automatically because it might result in needing to fetch extra " ++-   "patches if the repository is lazy.",-   "If there are any other problems with your repository, you can still repair the CRCs, " ++-   "but you are advised to first make a backup copy in case the CRC errors are actually " ++-   "caused by bad data and the old CRCs might be useful in recovering that data.",-   "If you were warned about CRC errors during an operation involving another repository, " ++-   "then it is possible that the other repository contains the corrupt CRCs, so you " ++-   "should arrange for that repository to also be checked/repaired."-  ]--formatText :: [String] -> String-formatText = unlines . intercalate [""] . map (map unwords . para 80 . words)---- |Take a list of words and split it up so that each chunk fits into the specified width--- when spaces are included. Any words longer than the specified width end up in a chunk--- of their own.-para :: Int -> [[a]] -> [[[a]]]-para w = para'-  where para' [] = []-        para' xs = uncurry (:) $ para'' w xs-        para'' r (x:xs) | w == r || length x < r = first (x:) $ para'' (r - length x - 1) xs-        para'' _ xs = ([], para' xs)---- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand-doCRCWarnings :: Bool -> IO ()-doCRCWarnings verbose = do-   files <- getCRCWarnings-   resetCRCWarnings-   when (not . null $ files) $ do-      hPutStr stderr . formatText $-          ["",-           "Warning: CRC errors found. These are probably harmless but should " ++-           "be repaired. See 'darcs gzcrcs --help' for more information.",-           ""]-      when verbose $ hPutStrLn stderr $ unlines ("The following corrupt files were found:":files)--gzcrcs :: DarcsCommand-gzcrcs = DarcsCommand {commandProgramName = "darcs",-                       commandName = "gzcrcs",-                       commandHelp = gzcrcsHelp,-                       commandDescription = gzcrcsDescription,-                       commandExtraArgs = 0,-                       commandExtraArgHelp = [],-                       commandCommand = gzcrcsCmd,-                       commandPrereq = amInRepository,-                       commandGetArgPossibilities = return [],-                       commandArgdefaults = nodefaults,-                       commandAdvancedOptions = [],-                       commandBasicOptions = [checkOrRepair,-                                                justThisRepo,-                                                workingRepoDir-                                               ]}--gzcrcsCmd :: [DarcsFlag] -> [String] -> IO ()-gzcrcsCmd opts _ | Check `elem` opts || Repair `elem` opts = withRepository opts (RepoJob (gzcrcs' opts))-gzcrcsCmd _ _ = error "You must specify --check or --repair for gzcrcs"--gzcrcs'-   :: (RepoPatch p) => [DarcsFlag] -> Repository p C(r u t) -> IO ()-gzcrcs' opts repo = do-  let Ca locs = extractCache repo-  -- Somewhat ugly IORef use here because it's convenient, would be nicer-  -- to pre-filter the list of locs to check and then decide whether to-  -- print the message up front.-  warnRelatedRepos <- newIORef (JustThisRepo `notElem` opts)-  ((), Any checkFailed) <- runWriterT $ flip mapM_ locs $ \loc -> do-    unless (JustThisRepo `elem` opts && not (isthisrepo loc)) $ do-     let w = writable loc-     flip mapM_ allHashedDirs $ \hdir -> do-        let dir = hashedFilePath loc hdir ""-        exists <- liftIO $ doesDirectoryExist dir-        when exists $ do-           liftIO $ do-              warn <- readIORef warnRelatedRepos-              when (warn && not (isthisrepo loc)) $ do-                 writeIORef warnRelatedRepos False-                 putInfo $ text "Also checking related repos and caches; use --just-this-repo to disable."-           liftIO $ putInfo $ text $ "Checking " ++ dir ++ (if w then "" else " (readonly)")-           files <- liftIO $ getDirectoryContents dir-           ((), Sum count) <- runWriterT $ flip mapM_ files $ \file -> do-              let fn = dir ++ file-              isfile <- liftIO $ doesFileExist fn-              when isfile $ do-                 gz <- liftIO $ isGZFile fn-                 case gz of-                    Nothing -> return ()-                    Just len -> do-                       contents <- liftIO $ B.readFile fn-                       let (uncompressed, isCorrupt) = gzDecompress (Just len) . BL.fromChunks $ [contents]-                       when isCorrupt $ do-                          tell (Sum 1) -- count of files in current directory-                          liftIO $ putVerbose $ text $ "Corrupt: " ++ fn-                          when (w && Repair `elem` opts) $ liftIO $ gzWriteAtomicFilePSs fn uncompressed-           when (count > (0 :: Int)) $ do-              liftIO $ putInfo $ text $-                 "Found " ++ show count ++ " corrupt file" ++ (if count > 1 then "s" else "") ++-                 (if Repair `elem` opts then (if w then " (repaired)" else " (not repaired") else "")-              tell (Any True) -- something corrupt somewhere-  when (Check `elem` opts && checkFailed) $ exitWith $ ExitFailure 1-- where-     putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s-     putVerbose s = when (Verbose `elem` opts) $ putDocLn s-
− src/Darcs/Commands/Get.hs 
@@ -1,269 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Get ( get, clone ) where--import Prelude hiding ( catch )--import System.Directory ( setCurrentDirectory, doesDirectoryExist, doesFileExist,-                          createDirectory )-import Workaround ( getCurrentDirectory )-import Control.Exception ( catch, IOException )-import Control.Monad ( when )--import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias, putInfo )-import Darcs.Flags( compression )-import Darcs.Arguments ( DarcsFlag( NewRepo, Lazy,-                                    UseFormat2,-                                    UseHashedInventory, UseNoWorkingDir,-                                    SetScriptsExecutable, OnePattern ),-                        getContext, useWorkingDir,-                        partial, reponame,-                        matchOneContext, setDefault, setScriptsExecutableOption,-                        networkOptions, makeScriptsExecutable, usePacks )-import Darcs.Repository ( Repository, withRepository, RepoJob(..), withRepoLock, identifyRepositoryFor, readRepo,-                          tentativelyRemovePatches, patchSetToRepository,-                          copyRepository, tentativelyAddToPending,-                          finalizeRepositoryChanges, setScriptsExecutable-                        , invalidateIndex, createRepository )-import Darcs.Repository.Format ( identifyRepoFormat, RepoFormat,-                                 RepoProperty ( Darcs2, HashedInventory ), formatHas )-import Darcs.Patch ( RepoPatch, apply, invert, effect, PrimOf )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( lengthFL, mapFL_FL, (:>)(..) )-import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )-import Darcs.Repository.Prefs ( setDefaultrepo )-import Darcs.Repository.Motd ( showMotd )-import Darcs.Match ( havePatchsetMatch, getOnePatchset )-import Progress ( debugMessage )-import Printer ( text, errorDoc, ($$) )-import Darcs.Lock ( writeBinFile )-import Darcs.RepoPath ( toFilePath, toPath, ioAbsoluteOrRemote)-import Darcs.Witnesses.Sealed ( Sealed(..) )-import Darcs.Global ( darcsdir )-import English ( englishNum, Noun(..) )-import Storage.Hashed.Tree( Tree )-#include "gadts.h"--getDescription :: String-getDescription = "Create a local copy of a repository."--getHelp :: String-getHelp =- "Get creates a local copy of a repository.  The optional second\n" ++- "argument specifies a destination directory for the new copy; if\n" ++- "omitted, it is inferred from the source location.\n" ++- "\n" ++- "By default Darcs will copy every patch from the original repository.\n" ++- "This means the copy is completely independent of the original; you can\n" ++- "operate on the new repository even when the original is inaccessible.\n" ++- "If you expect the original repository to remain accessible, you can\n" ++- "use --lazy to avoid copying patches until they are needed (`copy on\n" ++- "demand').  This is particularly useful when copying a remote\n" ++- "repository with a long history that you don't care about.\n" ++- "\n" ++- "The --lazy option isn't as useful for local copies, because Darcs will\n" ++- "automatically use `hard linking' where possible.  As well as saving\n" ++- "time and space, you can move or delete the original repository without\n" ++- "affecting a complete, hard-linked copy.  Hard linking requires that\n" ++- "the copy be on the same filesystem and the original repository, and\n" ++- "that the filesystem support hard linking.  This includes NTFS, HFS+\n" ++- "and all general-purpose Unix filesystems (such as ext3, UFS and ZFS).\n" ++- "FAT does not support hard links.\n" ++- "\n" ++- "Darcs get will not copy unrecorded changes to the source repository's\n" ++- "working tree.\n" ++- "\n" ++- getHelpTag--get :: DarcsCommand-get = DarcsCommand {commandProgramName = "darcs",-                    commandName = "get",-                    commandHelp = getHelp,-                    commandDescription = getDescription,-                    commandExtraArgs = -1,-                    commandExtraArgHelp = ["<REPOSITORY>", "[<DIRECTORY>]"],-                    commandCommand = getCmd,-                    commandPrereq = contextExists,-                    commandGetArgPossibilities = return [],-                    commandArgdefaults = nodefaults,-                    commandAdvancedOptions = usePacks:networkOptions,-                    commandBasicOptions = [reponame,-                                            partial,-                                            matchOneContext,-                                            setDefault True,-                                            setScriptsExecutableOption,-                                            useWorkingDir]-                   }--clone :: DarcsCommand-clone = commandAlias "clone" Nothing get--getCmd :: [DarcsFlag] -> [String] -> IO ()-getCmd opts [inrepodir, outname] = getCmd (NewRepo outname:opts) [inrepodir]-getCmd opts [inrepodir] = do-  debugMessage "Starting work on get..."-  typed_repodir <- ioAbsoluteOrRemote inrepodir-  let repodir = toPath typed_repodir-  showMotd opts repodir-  rfsource <- identifyRepoFormat repodir-  debugMessage $ "Found the format of "++repodir++"..."-  mysimplename <- makeRepoName opts repodir-  createDirectory mysimplename-  setCurrentDirectory mysimplename-  let opts' = if formatHas Darcs2 rfsource-              then UseFormat2:opts-              else UseHashedInventory:filter (/= UseFormat2) opts-  createRepository opts'-  debugMessage "Finished initializing new directory."-  setDefaultrepo repodir opts--  writeBinFile (darcsdir++"/hashed_inventory") ""--  if not (null [p | OnePattern p <- opts]) -- --to-match given-     && Lazy `notElem` opts-    then withRepository opts $ RepoJob $ \repository -> do-      debugMessage "Using economical get --to-match handling"-      fromrepo <- identifyRepositoryFor  repository repodir-      Sealed patches_to_get <- getOnePatchset fromrepo opts--- Warning:  A do-notation statement discarded a result of type Repository p ghc-prim-      _ <- patchSetToRepository fromrepo patches_to_get opts-      debugMessage "Finished converting selected patch set to new repository"-    else copyRepoAndGoToChosenVersion opts repodir rfsource-getCmd _ _ = fail "You must provide 'get' with either one or two arguments."---- | called by getCmd--- assumes that the target repo of the get is the current directory, and that an inventory in the--- right format has already been created.-copyRepoAndGoToChosenVersion :: [DarcsFlag] -> String -> RepoFormat -> IO ()-copyRepoAndGoToChosenVersion opts repodir rfsource = do-  copyRepo-  withRepository opts ((RepoJob $ \repository -> goToChosenVersion repository opts) :: RepoJob ())-  putInfo opts $ text "Finished getting."-      where copyRepo :: IO ()-            copyRepo =-                withRepository opts $ RepoJob $ \repository ->-                  if formatHas HashedInventory rfsource-                   then do-                                   debugMessage "Identifying and copying repository..."-                                   copyRepoHashed repository-                   else do-                                   putInfo opts $ text "***********************************************************************"-                                               $$ text "  _______   Sorry for the wait! The repository you are fetching is"-                                               $$ text " |       |  using the DEPRECATED 'old-fashioned' format. I'm getting a"-                                               $$ text " | O   O |  hashed copy instead, but this may take a while."-                                               $$ text " |  ___  |"-                                               $$ text " | /   \\ |  We recommend that the maintainer upgrade the remote copy"-                                               $$ text " |_______|  as well. See http://wiki.darcs.net/OF for more information."-                                               $$ text ""-                                               $$ text "***********************************************************************"-                                   copyRepoHashed repository-            copyRepoHashed repository =-              do identifyRepositoryFor repository repodir >>= flip copyRepository (UseNoWorkingDir `notElem` opts)-                 when (SetScriptsExecutable `elem` opts) setScriptsExecutable--makeRepoName :: [DarcsFlag] -> FilePath -> IO String-makeRepoName (NewRepo n:_) _ =-    do exists <- doesDirectoryExist n-       file_exists <- doesFileExist n-       if exists || file_exists-          then fail $ "Directory or file named '" ++ n ++ "' already exists."-          else return n-makeRepoName (_:as) d = makeRepoName as d-makeRepoName [] d =-  case dropWhile (=='.') $ reverse $-       takeWhile (\c -> c /= '/' && c /= ':') $-       dropWhile (=='/') $ reverse d of-  "" -> modifyRepoName "anonymous_repo"-  base -> modifyRepoName base--modifyRepoName :: String -> IO String-modifyRepoName name =-    if head name == '/'-    then mrn name (-1)-    else do cwd <- getCurrentDirectory-            mrn (cwd ++ "/" ++ name) (-1)- where-  mrn :: String -> Int -> IO String-  mrn n i = do-    exists <- doesDirectoryExist thename-    file_exists <- doesFileExist thename-    if not exists && not file_exists-       then do when (i /= -1) $-                    putStrLn $ "Directory '"++ n ++-                               "' already exists, creating repository as '"++-                               thename ++"'"-               return thename-       else mrn n $ i+1-    where thename = if i == -1 then n else n++"_"++show i--getHelpTag :: String-getHelpTag =- "It is often desirable to make a copy of a repository that excludes\n" ++- "some patches.  For example, if releases are tagged then `darcs get\n" ++- "--tag .' would make a copy of the repository as at the latest release.\n" ++- "\n" ++- "An untagged repository state can still be identified unambiguously by\n" ++- "a context file, as generated by `darcs changes --context'.  Given the\n" ++- "name of such a file, the --context option will create a repository\n" ++- "that includes only the patches from that context.  When a user reports\n" ++- "a bug in an unreleased version of your project, the recommended way to\n" ++- "find out exactly what version they were running is to have them\n" ++- "include a context file in the bug report.\n" ++- "\n" ++- "You can also make a copy of an untagged state using the --to-patch or\n" ++- "--to-match options, which exclude patches `after' the first matching\n" ++- "patch.  Because these options treat the set of patches as an ordered\n" ++- "sequence, you may get different results after reordering with `darcs\n" ++- "optimize', so tagging is preferred.\n"--contextExists :: [DarcsFlag] -> IO (Either String ())-contextExists opts =-   case getContext opts of-     Nothing -> return $ Right ()-     Just f  -> do exists <- doesFileExist $ toFilePath f-                   return $ if exists-                            then Right ()-                            else Left $ "Context file "++toFilePath f++" does not exist"--goToChosenVersion :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)-                  => Repository p C(r u r)-                  -> [DarcsFlag] -> IO ()-goToChosenVersion repository opts =-    when (havePatchsetMatch opts) $ do-       debugMessage "Going to specified version..."-       patches <- readRepo repository-       Sealed context <- getOnePatchset repository opts-       when (snd (countUsThem patches context) > 0) $-            errorDoc $ text "Missing patches from context!" -- FIXME : - (-       _ :> us' <- return $ findCommonWithThem patches context-       let ps = mapFL_FL hopefully us'-       putInfo opts $ text $ "Unapplying " ++ show (lengthFL ps) ++ " " ++-                   englishNum (lengthFL ps) (Noun "patch") ""-       invalidateIndex repository-       withRepoLock opts $ RepoJob $ \_ ->--- Warning:  A do-notation statement discarded a result of type Repository p r u z.-           do _ <- tentativelyRemovePatches repository (compression opts) us'-              tentativelyAddToPending repository opts $ invert $ effect us'-              finalizeRepositoryChanges repository-              apply (invert $ effect ps) `catch` \(e :: IOException) ->-                  fail ("Couldn't undo patch in working dir.\n" ++ show e)-              makeScriptsExecutable opts (invert $ effect ps)-
− src/Darcs/Commands/Help.hs 
@@ -1,295 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.Help (- helpCmd,- commandControlList, environmentHelp,          -- these are for preproc.hs- printVersion,- listAvailableCommands ) where--import Darcs.Arguments ( DarcsFlag(..), environmentHelpEmail, environmentHelpSendmail )-import Darcs.Commands (- CommandArgs(..), CommandControl(..), DarcsCommand(..),- disambiguateCommands, extractCommands, getCommandHelp, nodefaults, usage )-import Darcs.External ( viewDoc )-import Darcs.Lock ( environmentHelpTmpdir, environmentHelpKeepTmpdir )-import Darcs.Patch.Match ( helpOnMatchers )-import Darcs.Repository.Prefs ( boringFileHelp, binariesFileHelp, environmentHelpHome )-import Darcs.Ssh ( environmentHelpSsh, environmentHelpScp, environmentHelpSshPort )-import Darcs.Utils ( withCurrentDirectory, environmentHelpEditor, environmentHelpPager )-import Data.Char ( isAlphaNum, toLower, toUpper )-import Data.List ( groupBy, isPrefixOf, intercalate, nub )-import English ( andClauses )-import Printer (text, vcat, vsep, ($$))-import System.Exit ( ExitCode(..), exitWith )-import Version ( version )-import URL (environmentHelpProxy, environmentHelpProxyPassword)-import Workaround ( getCurrentDirectory )-import qualified Darcs.TheCommands as TheCommands--helpDescription :: String-helpDescription = "Display help about darcs and darcs commands."--helpHelp :: String-helpHelp =- "Without arguments, `darcs help' prints a categorized list of darcs\n" ++- "commands and a short description of each one.  With an extra argument,\n" ++- "`darcs help foo' prints detailed help about the darcs command foo.\n"--help :: DarcsCommand-help = DarcsCommand {commandProgramName = "darcs",-                     commandName = "help",-                     commandHelp = helpHelp,-                     commandDescription = helpDescription,-                     commandExtraArgs = -1,-                     commandExtraArgHelp = ["[<DARCS_COMMAND> [DARCS_SUBCOMMAND]]  "],-                     commandCommand = \ x y -> helpCmd x y >> exitWith ExitSuccess,-                     commandPrereq = \_ -> return $ Right (),-                     commandGetArgPossibilities = return [],-                     commandArgdefaults = nodefaults,-                     commandAdvancedOptions = [],-                     commandBasicOptions = []}--helpCmd :: [DarcsFlag] -> [String] -> IO ()-helpCmd _ ["manpage"] = putStr $ unlines manpageLines-helpCmd _ ["patterns"] = viewDoc $ text $ helpOnMatchers-helpCmd _ ("environment":vs_) =-    viewDoc . vsep $-       if null vs-          then header : map render environmentHelp-          else          map render known ++ [footer]-    where header = vcat [ text "Environment Variables"-                        , text "====================="-                        ]-          footer = text ("Unknown environment variables: " ++ intercalate ", " unknown)-          render (ks, ds) = text (andClauses ks ++ ":") $$-                            vcat [text ("  " ++ d) | d <- ds]-          lookupEnv v = [ e | e@(ks,_) <- environmentHelp, v `elem` ks ]-          unknown = [ v | v <- vs, null (lookupEnv v) ]-          known   = nub (concatMap lookupEnv vs)-          vs      = map (map toUpper) vs_--helpCmd _ [] = viewDoc $ text $ usage commandControlList--helpCmd _ (cmd:args) =-    let disambiguated = disambiguateCommands commandControlList cmd args-    in case disambiguated of-         Left err -> fail err-         Right (cmds,_) ->-             let msg = case cmds of-                         CommandOnly c       -> getCommandHelp Nothing  c-                         SuperCommandOnly c  -> getCommandHelp Nothing  c-                         SuperCommandSub c s -> getCommandHelp (Just c) s-             in viewDoc $ text msg--listAvailableCommands :: IO ()-listAvailableCommands =-    do here <- getCurrentDirectory-       is_valid <- mapM-                   (\c-> withCurrentDirectory here $ (commandPrereq c) [])-                   (extractCommands commandControlList)-       putStr $ unlines $ map (commandName . fst) $-                filter (isRight.snd) $-                zip (extractCommands commandControlList) is_valid-       putStrLn "--help"-       putStrLn "--version"-       putStrLn "--exact-version"-       putStrLn "--overview"-    where isRight (Right _) = True-          isRight _ = False--printVersion :: IO ()-printVersion = putStrLn $ "darcs version " ++ version---- avoiding a module import cycle between Help and TheCommands-commandControlList :: [CommandControl]-commandControlList =-  CommandData help : TheCommands.commandControlList---- FIXME: the "grouping" comments below should made subsections in the--- manpage, as we already do for DarcsCommand groups. --twb, 2009---- | Help on each environment variable in which Darcs is interested.-environmentHelp :: [([String], [String])]-environmentHelp = [- -- General-purpose- environmentHelpHome,- environmentHelpEditor,- environmentHelpPager,- environmentHelpTmpdir,- environmentHelpKeepTmpdir,- environmentHelpEmail,- environmentHelpSendmail,- -- Remote Repositories- environmentHelpSsh,- environmentHelpScp,- environmentHelpSshPort,- environmentHelpProxy,- environmentHelpProxyPassword]---- | This module is responsible for emitting a darcs "man-page", a--- reference document used widely on Unix-like systems.  Manpages are--- primarily used as a quick reference, or "memory jogger", so the--- output should be terser than the user manual.------ Before modifying the output, please be sure to read the man(7) and--- man-pages(7) manpages, as these respectively describe the relevant--- syntax and conventions.---- | The lines of the manpage to be printed.-manpageLines :: [String]-manpageLines = [- ".TH DARCS 1 \"" ++ version ++ "\"",- ".SH NAME",- "darcs \\- an advanced revision control system",- ".SH SYNOPSIS",- ".B darcs", ".I command", ".RI < arguments |[ options ]>...",- "",- "Where the", ".I commands", "and their respective", ".I arguments", "are",- "",- unlines synopsis,- ".SH DESCRIPTION",- -- FIXME: this is copy-and-pasted from darcs.cabal, so- -- it'll get out of date as people forget to maintain- -- both in sync.- "Darcs is a free, open source revision control",- "system. It is:",- ".TP 3", "\\(bu",- "Distributed: Every user has access to the full",- "command set, removing boundaries between server and",- "client or committer and non\\(hycommitters.",- ".TP", "\\(bu",- "Interactive: Darcs is easy to learn and efficient to",- "use because it asks you questions in response to",- "simple commands, giving you choices in your work",- "flow. You can choose to record one change in a file,",- "while ignoring another. As you update from upstream,",- "you can review each patch name, even the full `diff'",- "for interesting patches.",- ".TP", "\\(bu",- "Smart: Originally developed by physicist David",- "Roundy, darcs is based on a unique algebra of",- "patches.",- "This smartness lets you respond to changing demands",- "in ways that would otherwise not be possible. Learn",- "more about spontaneous branches with darcs.",- ".SH OPTIONS",- "Different options are accepted by different Darcs commands.",- "Each command's most important options are listed in the",- ".B COMMANDS",- "section.  For a full list of all options accepted by",- "a particular command, run `darcs", ".I command", "\\-\\-help'.",- ".SS " ++ escape helpOnMatchers, -- FIXME: this is a kludge.- ".SH COMMANDS",- unlines commands,- unlines environment,- ".SH FILES",- ".SS \"_darcs/prefs/binaries\"",- escape $ unlines binariesFileHelp,- ".SS \"_darcs/prefs/boring\"",- escape $ unlines boringFileHelp,- ".SH BUGS",- "At http://bugs.darcs.net/ you can find a list of known",- "bugs in Darcs.  Unknown bugs can be reported at that",- "site (after creating an account) or by emailing the",- "report to bugs@darcs.net.",- -- ".SH EXAMPLE",- -- FIXME:- -- new project: init, rec -la;- -- track upstream project: get, pull -a;- -- contribute to project: add, rec, push/send.- ".SH SEE ALSO",- "A user manual is included with Darcs, in PDF and HTML",- "form.  It can also be found at http://darcs.net/manual/.",- ".SH LICENSE",- "Darcs is free software; you can redistribute it and/or modify",- "it under the terms of the GNU General Public License as published by",- "the Free Software Foundation; either version 2, or (at your option)",- "any later version." ]-    where-      -- | A synopsis line for each command.  Uses 'foldl' because it is-      -- necessary to avoid blank lines from Hidden_commands, as groff-      -- translates them into annoying vertical padding (unlike TeX).-      synopsis :: [String]-      synopsis = foldl iter [] commandControlList-          where iter :: [String] -> CommandControl -> [String]-                iter acc (GroupName _) = acc-                iter acc (HiddenCommand _) = acc-                iter acc (CommandData c@SuperCommand {}) =-                    acc ++ concatMap-                            (render (commandName c ++ " "))-                            (extractCommands (commandSubCommands c))-                iter acc (CommandData c) = acc ++ render "" c-                render :: String -> DarcsCommand -> [String]-                render prefix c =-                    [".B darcs " ++ prefix ++ commandName c] ++-                    (map mangle_args $ commandExtraArgHelp c) ++-                    -- In the output, we want each command to be on its own-                    -- line, but we don't want blank lines between them.-                    -- AFAICT this can only be achieved with the .br-                    -- directive, which is probably a GNUism.-                    [".br"]--      -- | As 'synopsis', but make each group a subsection (.SS), and-      -- include the help text for each command.-      commands :: [String]-      commands = foldl iter [] commandControlList-          where iter :: [String] -> CommandControl -> [String]-                iter acc (GroupName x) = acc ++ [".SS \"" ++ x ++ "\""]-                iter acc (HiddenCommand _) = acc-                iter acc (CommandData c@SuperCommand {}) =-                    acc ++ concatMap-                            (render (commandName c ++ " "))-                            (extractCommands (commandSubCommands c))-                iter acc (CommandData c) = acc ++ render "" c-                render :: String -> DarcsCommand -> [String]-                render prefix c =-                    [".B darcs " ++ prefix ++ commandName c] ++-                    (map mangle_args $ commandExtraArgHelp c) ++-                    [".RS 4", escape $ commandHelp c, ".RE"]--      -- | Now I'm showing off: mangle the extra arguments of Darcs commands-      -- so as to use the ideal format for manpages, italic words and roman-      -- punctuation.-      mangle_args :: String -> String-      mangle_args s =-          ".RI " ++ (unwords $ map show (groupBy cmp $ map toLower $ gank s))-              where cmp x y = not $ xor (isAlphaNum x) (isAlphaNum y)-                    xor x y = (x && not y) || (y && not x)-                    gank (' ':'o':'r':' ':xs) = '|' : gank xs-                    gank (x:xs) = x : gank xs-                    gank [] = []--      environment :: [String]-      environment = ".SH ENVIRONMENT" : concat-                    [(".SS \"" ++ andClauses ks ++ "\"") : map escape ds-                     | (ks, ds) <- environmentHelp]--      -- | Copied from Preproc.escape_latex_specials.-      escape :: String -> String-      escape = minus . bs       -- Order is important-        where-          minus      = replace "-"     "\\-"-          bs         = replace "\\"    "\\\\"--          replace :: Eq a => [a] -> [a] -> [a] -> [a]-          replace _ _ [] = []-          replace find repl s =-              if find `isPrefixOf` s-                  then repl ++ (replace find repl (drop (length find) s))-                  else [head s] ++ replace find repl (tail s)-
− src/Darcs/Commands/Init.hs 
@@ -1,63 +0,0 @@---  Copyright (C) 2002-2003 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.Init ( initialize, initializeCmd ) where-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, workingRepoDir,-                        patchFormatChoices, useWorkingDir )-import Darcs.Repository ( amNotInRepository, createRepository )--initializeDescription :: String-initializeDescription = "Make the current directory a repository."--initializeHelp :: String-initializeHelp =- "The `darcs initialize' command turns the current directory into a\n" ++- "Darcs repository.  Any existing files and subdirectories become\n" ++- "UNSAVED changes: record them with `darcs record --look-for-adds'.\n" ++- "\n" ++- "This command creates the `_darcs' directory, which stores version\n" ++- "control metadata.  It also contains per-repository settings in\n" ++- "_darcs/prefs/, which you can read about in the user manual.\n" ++- "\n" ++- "By default, patches of the new repository are in the darcs-2 semantics.\n" ++- "However it is possible to create a repository in darcs-1 semantics with\n" ++- "the flag `--hashed', althought this is not recommended except for sharing\n" ++- "patches with a project that uses patches in the darcs-1 semantics.\n" ++- "\n" ++- "Initialize is commonly abbreviated to `init'.\n"--initialize :: DarcsCommand-initialize = DarcsCommand {commandProgramName = "darcs",-                         commandName = "initialize",-                         commandHelp = initializeHelp,-                         commandDescription = initializeDescription,-                         commandExtraArgs = 0,-                         commandExtraArgHelp = [],-                         commandPrereq = amNotInRepository,-                         commandCommand = initializeCmd,-                         commandGetArgPossibilities = return [],-                         commandArgdefaults = nodefaults,-                         commandAdvancedOptions = [],--                         commandBasicOptions = [patchFormatChoices,-                                                useWorkingDir,-                                                workingRepoDir]}--initializeCmd :: [DarcsFlag] -> [String] -> IO ()-initializeCmd opts _ = createRepository opts-
− src/Darcs/Commands/MarkConflicts.hs 
@@ -1,113 +0,0 @@---  Copyright (C) 2002-2003,2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.MarkConflicts ( markconflicts ) where--import Prelude hiding ( catch )--import System.Exit ( ExitCode(..), exitWith )-import Darcs.SignalHandler ( withSignalsBlocked )-import Control.Monad ( unless )-import Control.Exception ( catch, IOException )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, ignoretimes, workingRepoDir, umaskOption )-import Darcs.Flags ( diffingOpts )-import Darcs.Repository ( withRepoLock, RepoJob(..), amInHashedRepository, addToPending,-                    applyToWorking,-                    readRepo, unrecordedChanges, Repository-                    )-import Darcs.Patch ( invert, PrimOf )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Darcs.Resolution ( patchsetConflictResolutions )-import Darcs.Utils ( promptYorn )-#include "impossible.h"-#include "gadts.h"--markconflictsDescription :: String-markconflictsDescription =- "Mark unresolved conflicts in working tree, for manual resolution."--markconflictsHelp :: String-markconflictsHelp =- "Darcs requires human guidance to unify changes to the same part of a\n" ++- "source file.  When a conflict first occurs, darcs will add the\n" ++- "initial state and both choices to the working tree, delimited by the\n" ++- "markers `v v v', `=====',  `* * *' and `^ ^ ^', as follows:\n" ++- "\n" ++- "v v v v v v v\n" ++- "Initial state.\n" ++- "=============\n" ++- "First choice.\n" ++- "*************\n" ++- "Second choice.\n" ++- "^ ^ ^ ^ ^ ^ ^\n" ++- "\n" ++- "However, you might revert or manually delete these markers without\n" ++- "actually resolving the conflict.  In this case, `darcs mark-conflicts'\n" ++- "is useful to show where any unresolved conflicts.  It is also useful\n" ++- "if `darcs apply' is called with --apply-conflicts, where conflicts\n" ++- "aren't marked initially.\n" ++- "\n" ++- "Any unrecorded changes to the working tree WILL be lost forever when\n" ++- "you run this command!  You will be prompted for confirmation before\n" ++- "this takes place.\n"--markconflicts :: DarcsCommand-markconflicts = DarcsCommand {commandProgramName = "darcs",-                              commandName = "mark-conflicts",-                              commandHelp = markconflictsHelp,-                              commandDescription = markconflictsDescription,-                              commandExtraArgs = 0,-                              commandExtraArgHelp = [],-                              commandCommand = markconflictsCmd,-                              commandPrereq = amInHashedRepository,-                              commandGetArgPossibilities = return [],-                              commandArgdefaults = nodefaults,-                              commandAdvancedOptions = [umaskOption],-                              commandBasicOptions = [ignoretimes,-                                                      workingRepoDir]}--markconflictsCmd :: [DarcsFlag] -> [String] -> IO ()-markconflictsCmd opts [] = withRepoLock opts $ RepoJob $ \(repository :: Repository p C(r u r)) -> do-  pend <- unrecordedChanges (diffingOpts opts) repository Nothing-  r <- readRepo repository-  Sealed res <- return $ patchsetConflictResolutions r-  (case res of NilFL -> do putStrLn "No conflicts to mark."-                           exitWith ExitSuccess-               _ -> return ()) :: IO ()-  let undoUnrec :: FL (PrimOf p) C(r u) -> IO (Repository p C(r r r))-      undoUnrec NilFL = return repository-      undoUnrec pend' =-              do putStrLn ("This will trash any unrecorded changes"++-                          " in the working directory.")-                 confirmed <- promptYorn "Are you sure? "-                 unless confirmed $ exitWith ExitSuccess-                 applyToWorking repository opts (invert pend') `catch` \(e :: IOException) ->-                    bug ("Can't undo pending changes!" ++ show e)-  repository' <- undoUnrec pend-  withSignalsBlocked $-    do addToPending repository' res-       _ <- applyToWorking repository' opts res `catch` \(e :: IOException) ->-           bug ("Problem marking conflicts in mark-conflicts!" ++ show e)-       return ()-  putStrLn "Finished marking conflicts."-markconflictsCmd _ _ = impossible-
− src/Darcs/Commands/Move.hs 
@@ -1,260 +0,0 @@---  Copyright (C) 2002-2003 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Move ( move, mv ) where-import Control.Applicative ( (<$>) )-import Control.Monad ( when, unless, zipWithM_ )-import Data.Maybe ( catMaybes )-import Darcs.SignalHandler ( withSignalsBlocked )--import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )-import Darcs.Arguments ( DarcsFlag(), maybeFixSubPaths,-                         fixSubPaths, workingRepoDir,-                        listFiles, allowProblematicFilenames, umaskOption,-                      )-import Darcs.Flags ( doAllowCaseOnly, doAllowWindowsReserved )-import Darcs.RepoPath ( SubPath(), toFilePath )-import System.FilePath.Posix ( (</>), takeFileName )-import System.Directory ( renameDirectory )-import Workaround ( renameFile )-import Darcs.Repository.State ( readRecordedAndPending, readRecorded )-import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), amInHashedRepository, addToPending )-import Darcs.Witnesses.Ordered ( FL(..), toFL )-import Darcs.Witnesses.Sealed ( Sealed(..), unseal, freeGap, FreeLeft, unFreeLeft )-import Darcs.Global ( debugMessage )-import qualified Darcs.Patch-import Darcs.Patch ( RepoPatch, PrimPatch )-import Darcs.Patch.FileName ( fp2fn, fn2fp, superName )-import Darcs.Patch.Apply( ApplyState )-import Data.List ( nub, sort )-import qualified System.FilePath.Windows as WindowsFilePath--import Darcs.Utils( treeHas, treeHasDir, treeHasAnycase, treeHasFile )-import Storage.Hashed.Tree( Tree, modifyTree )-import Storage.Hashed.Plain( readPlainTree )-import Storage.Hashed.AnchoredPath( floatPath )--#include "gadts.h"--moveDescription :: String-moveDescription = "Move or rename files."--moveHelp :: String-moveHelp =- "Darcs cannot reliably distinguish between a file being deleted and a\n" ++- "new one added, and a file being moved.  Therefore Darcs always assumes\n" ++- "the former, and provides the `darcs mv' command to let Darcs know when\n" ++- "you want the latter.  This command will also move the file in the\n" ++- "working tree (unlike `darcs remove'), unless it has already been moved.\n" ++- "\n" ++- -- Note that this paragraph is very similar to one in ./Add.lhs.- "Darcs will not rename a file if another file in the same folder has\n" ++- "the same name, except for case.  The --case-ok option overrides this\n" ++- "behaviour.  Windows and OS X usually use filesystems that do not allow\n" ++- "files a folder to have the same name except for case (for example,\n" ++- "`ReadMe' and `README').  If --case-ok is used, the repository might be\n" ++- "unusable on those systems!\n"--move :: DarcsCommand-move = DarcsCommand {commandProgramName = "darcs",-                   commandName = "move",-                   commandHelp = moveHelp,-                   commandDescription = moveDescription,-                   commandExtraArgs = -1,-                   commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"],-                   commandCommand = moveCmd,-                   commandPrereq = amInHashedRepository,-                   commandGetArgPossibilities = listFiles,-                   commandArgdefaults = nodefaults,-                   commandAdvancedOptions = [umaskOption],-                   commandBasicOptions = [allowProblematicFilenames, workingRepoDir]}--moveCmd :: [DarcsFlag] -> [String] -> IO ()-moveCmd opts args-  | length args < 2 =-      fail $ "The `darcs move' command requires at least two arguments."-  | length args == 2 = do-      xs <- maybeFixSubPaths opts args-      case xs of-        [Just from, Just to]-          | from == to -> fail "Cannot rename a file or directory onto itself!"-          | toFilePath from == "" -> fail "Cannot move the root of the repository"-          | otherwise -> moveFile opts from to-        _ -> fail "Both source and destination must be valid."-  | otherwise = let (froms, to) = (init args, last args) in do-      x <- head <$> maybeFixSubPaths opts [to]-      case x of-        Nothing -> fail "Invalid destination directory."-        Just to' -> do-          xs <- nub . sort <$> fixSubPaths opts froms-          if to' `elem` xs-            then fail "Cannot rename a file or directory onto itself!"-            else case xs of-              [] -> fail "Nothing to move."-              froms' -> moveFilesToDir opts froms' to'--data FileKind = Dir | File-              deriving (Show, Eq)--data FileStatus =-  Nonexistant-  | Unadded FileKind-  | Shadow FileKind -- ^ known to darcs, but absent in working copy-  | Known FileKind-  deriving Show--fileStatus :: Tree IO -> Tree IO -> Tree IO ->-              FilePath -> IO FileStatus-fileStatus work cur rec fp = do-  exists_in_cur <- treeHas cur fp-  exists_in_rec <- treeHas rec fp-  exists_in_work <- treeHas work fp-  case (exists_in_rec, exists_in_cur, exists_in_work) of-    (_, True, True) -> do-      isDirCur <- treeHasDir cur fp-      isDirWork <- treeHasDir work fp-      unless (isDirCur == isDirWork) . fail $ "don't know what to do with " ++ fp-      return . Known $ if isDirCur then Dir else File--    (_, False, True) -> do-      isDir <- treeHasDir work fp-      if isDir-        then return $ Unadded Dir-        else return $ Unadded File-    (False, False, False) -> return Nonexistant-    (_, _, False) -> do-      isDir <- treeHasDir cur fp-      if isDir-        then return $ Shadow Dir-        else return $ Shadow File---- | Takes two filenames (as 'Subpath'), and tries to move the first--- into/onto the second. Needs to guess what that means: renaming or moving--- into a directory, and whether it is a post-hoc move.-moveFile :: [DarcsFlag] -> SubPath -> SubPath -> IO ()-moveFile opts old new = withRepoLock opts $ RepoJob $ \repository -> do-  work <- readPlainTree "."-  cur <- readRecordedAndPending repository-  rec <- readRecorded repository-  let old_fp = toFilePath old-      new_fp = toFilePath new-  new_fs <- fileStatus work cur rec new_fp-  old_fs <- fileStatus work cur rec old_fp-  case (old_fs, new_fs) of-    (Nonexistant, _) -> fail $ old_fp ++ " is inexistant."-    (Unadded k, _) -> fail $ show k ++ " " ++ old_fp ++ " is unadded."-    (Known _, Nonexistant) -> simpleMove repository opts cur work old_fp new_fp-    (Known _, Shadow _) -> simpleMove repository opts cur work old_fp new_fp-    (_, Nonexistant) -> fail $ old_fp ++ " is not in the repository."-    (Known _, Known Dir) -> moveToDir repository opts [old_fp] new_fp-    (Known _, Unadded Dir) -> fail $ new_fp ++ " is not known to darcs; please add it to the repository."-    (Known _, _) -> fail $ new_fp ++ " already exists."-    (Shadow k, Unadded k') | k == k' -> simpleMove repository opts cur work old_fp new_fp-    (Shadow _, Known Dir) -> moveToDir repository opts [old_fp] new_fp-    (Shadow k, _) -> fail $ "cannot move " ++ show k ++ " " ++ old_fp ++ " into " ++ new_fp ++ " : " ++-                                          "did you already move it elsewhere?"--simpleMove :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t)-           -> [DarcsFlag] -> Tree IO -> Tree IO -> FilePath -> FilePath-           -> IO ()-simpleMove repository opts cur work old_fp new_fp = do-    addpatch <- checkNewAndOldFilenames opts cur work (old_fp,new_fp)-    withSignalsBlocked $ do-      case unFreeLeft <$> addpatch of-        Nothing -> addToPending repository (Darcs.Patch.move old_fp new_fp :>: NilFL)-        Just (Sealed p) -> addToPending repository (p :>: Darcs.Patch.move old_fp new_fp :>: NilFL)-      moveFileOrDir work old_fp new_fp--moveFilesToDir :: [DarcsFlag] -> [SubPath] -> SubPath -> IO ()-moveFilesToDir opts froms to = withRepoLock opts $ RepoJob $ \repo ->-  moveToDir repo opts (map toFilePath froms) $ toFilePath to--moveToDir :: (RepoPatch p, ApplyState p ~ Tree)-          => Repository p C(r u t) -> [DarcsFlag] -> [FilePath] -> FilePath -> IO ()-moveToDir repository opts moved finaldir =-  let movefns = map takeFileName moved-      movetargets = map (finaldir </>) movefns-      movepatches = zipWith (\a b -> freeGap (Darcs.Patch.move a b)) moved movetargets-  in do-    cur <- readRecordedAndPending repository-    work <- readPlainTree "."-    addpatches <- mapM (checkNewAndOldFilenames opts cur work) $ zip moved movetargets-    withSignalsBlocked $ do-      unseal (addToPending repository) $ toFL $ catMaybes addpatches ++ movepatches-      zipWithM_ (moveFileOrDir work) moved movetargets--checkNewAndOldFilenames-    :: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO -> (FilePath, FilePath) -> IO (Maybe (FreeLeft prim))-checkNewAndOldFilenames opts cur work (old,new) = do-  unless (doAllowWindowsReserved opts || WindowsFilePath.isValid new) $-     fail $ "The filename " ++ new ++ " is not valid under Windows.\n" ++-            "Use --reserved-ok to allow such filenames."-  has_work <- treeHas work old-  maybe_add_file_thats_been_moved <--     if has_work -- We need to move the object-     then do has_target <- treeHasDir work (fn2fp $ superName $ fp2fn new)-             unless has_target $-                    fail $ "The target directory " ++-                             (fn2fp $ superName $ fp2fn new)++-                             " isn't known in working directory, did you forget to add it?"-             has_new <- it_has work-             when has_new $ fail $ already_exists "working directory"-             return Nothing-     else do-       has_new <- treeHas work new-       has_cur_dir <- treeHasDir cur old-       unless has_new $ fail $ doesnt_exist "working directory"-       let add_patch = if has_cur_dir-                       then Darcs.Patch.adddir old-                       else Darcs.Patch.addfile old-       return (Just (freeGap (add_patch)))-  has_target <- treeHasDir cur (fn2fp $ superName $ fp2fn new)-  unless has_target $-    fail $ "The target directory " ++-     (fn2fp $ superName $ fp2fn new)++-     " isn't known in working directory, did you forget to add it?"-  has_new <- it_has cur-  when has_new $ fail $ already_exists "repository"-  return maybe_add_file_thats_been_moved-    where it_has s = treeHas_case (modifyTree s (floatPath old) Nothing) new-          treeHas_case = if doAllowCaseOnly opts then treeHas else treeHasAnycase-          already_exists what_slurpy =-              if doAllowCaseOnly opts-              then "A file or dir named "++new++" already exists in "-                       ++ what_slurpy ++ "."-              else "A file or dir named "++new++" (or perhaps differing"++-                       " only in case)\nalready exists in "++-                       what_slurpy ++ ".\n"++-                   "Use --case-ok to allow files differing only in case."-          doesnt_exist what_slurpy =-              "There is no file or dir named " ++ old ++-              " in the "++ what_slurpy ++ "."--moveFileOrDir :: Tree IO -> FilePath -> FilePath -> IO ()-moveFileOrDir work old new = do-  has_file <- treeHasFile work old-  has_dir <- treeHasDir work old-  when has_file $ do debugMessage $ unwords ["renameFile",old,new]-                     renameFile old new-  when has_dir $ do debugMessage $ unwords ["renameDirectory",old,new]-                    renameDirectory old new--mv :: DarcsCommand-mv = commandAlias "mv" Nothing move-
− src/Darcs/Commands/Optimize.hs 
@@ -1,372 +0,0 @@---  Copyright (C) 2003-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Optimize ( optimize ) where-import Control.Applicative ( (<$>) )-import Control.Exception ( finally )-import Control.Monad ( when, unless )-import Data.Maybe ( isJust )-import Data.List ( sort )-import System.Directory ( getDirectoryContents, doesDirectoryExist,-                          doesFileExist, renameFile, getModificationTime )-import System.IO.Unsafe ( unsafeInterleaveIO )-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy as BL--import Storage.Hashed.Darcs( decodeDarcsSize )--import Darcs.Patch.PatchInfoAnd ( info, extractHash )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag( UpgradeFormat, UseHashedInventory,-                                    Compress, UnCompress,-                                    NoCompress, Reorder,-                                    Relink, OptimizePristine,-                                    OptimizeHTTP ),-                        reorderPatches,-                        uncompressNocompress,-                        relink, sibling,-                        flagsToSiblings,-                        upgradeFormat,-                        workingRepoDir, umaskOption, optimizePristine,-                        optimizeHTTP-                      )-import Darcs.Repository.Prefs ( getPreflist )-import Darcs.Repository ( Repository,-                          withRepoLock, RepoJob(..), withGutsOf,-                          readRepo, optimizeInventory,-                          tentativelyReplacePatches, cleanRepository,-                          amInRepository, finalizeRepositoryChanges, replacePristine )-import Darcs.Repository.Old ( oldRepoFailMsg )-import Darcs.Witnesses.Ordered ( (+<+), reverseRL, mapRL, (:>)(..)-                               , mapFL, bunchFL, lengthRL )-import Darcs.Patch.Info ( isTag )-import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Set ( PatchSet(..), newset2RL, newset2FL, progressPatchSet )-import Darcs.Patch.Apply( ApplyState )-import ByteStringUtils ( gzReadFilePS )-import Darcs.Patch.Depends ( splitOnTag )-import Darcs.Lock ( maybeRelink, gzWriteAtomicFilePS, writeAtomicFilePS )-import Darcs.RepoPath ( toFilePath )-import Darcs.Utils ( withCurrentDirectory )-import Progress ( debugMessage )-import Darcs.Global ( darcsdir )---- imports for optimize --upgrade; to be tidied-import System.Directory ( createDirectoryIfMissing, removeFile )-import System.FilePath.Posix ( takeExtension, (</>), (<.>), takeFileName )--import Progress ( beginTedious, endTedious, tediousSize )-import Darcs.Flags ( compression )-import Darcs.Lock ( rmRecursive )-import Darcs.ProgressPatches ( progressFL )-import Darcs.Repository.Cache ( hashedDir, HashedDir(HashedPristineDir) )-import Darcs.Repository.Format ( identifyRepoFormat,-                                 createRepoFormat, writeRepoFormat, formatHas,-                                 RepoProperty ( HashedInventory ) )-import qualified Darcs.Repository.HashedRepo as HashedRepo-import Darcs.Repository.Prefs ( getCaches )-import Darcs.Repository.State ( readRecorded )-import Darcs.Utils ( catchall )--import Storage.Hashed.Tree( Tree, TreeItem(..), list, expand, emptyTree )-import Storage.Hashed.AnchoredPath( anchorPath )-import Storage.Hashed.Plain( readPlainTree )-import Storage.Hashed.Darcs( writeDarcsHashed )--import Codec.Archive.Tar ( write )-import Codec.Archive.Tar.Entry ( fileEntry, toTarPath )-import Codec.Compression.GZip ( compress )--#include "gadts.h"--optimizeDescription :: String-optimizeDescription = "Optimize the repository."--optimizeHelp :: String-optimizeHelp =- "The `darcs optimize' command modifies the current repository in an\n" ++- "attempt to reduce its resource requirements.  By default a single\n" ++- "fast, safe optimization is performed; additional optimization\n" ++- "techniques can be enabled by passing options to `darcs optimize'.\n" ++- "\n" ++ optimizeHelpInventory ++- -- "\n" ++ optimize_help_reorder ++- "\n" ++ optimizeHelpRelink ++- -- uncompression is least useful, so it is last.- "\n" ++ optimizeHelpCompression ++- "\n" ++- "There is one more optimization which CAN NOT be performed by this\n" ++- "command.  Every time your record a patch, a new inventory file is\n" ++- "written to _darcs/inventories/, and old inventories are never reaped.\n" ++- "\n" ++- "If _darcs/inventories/ is consuming a relatively large amount of\n" ++- "space, you can safely reclaim it by using `darcs get' to make a\n" ++- "complete copy of the repo.  When doing so, don't forget to copy over\n" ++- "any unsaved changes you have made to the working tree or to\n" ++- "unversioned files in _darcs/prefs/ (such as _darcs/prefs/author).\n"--optimize :: DarcsCommand-optimize = DarcsCommand {commandProgramName = "darcs",-                         commandName = "optimize",-                         commandHelp = optimizeHelp,-                         commandDescription = optimizeDescription,-                         commandExtraArgs = 0,-                         commandExtraArgHelp = [],-                         commandCommand = optimizeCmd,-                         commandPrereq = amInRepository,-                         commandGetArgPossibilities = return [],-                         commandArgdefaults = nodefaults,-                         commandAdvancedOptions = [uncompressNocompress, umaskOption],-                         commandBasicOptions = [workingRepoDir,-                                                 reorderPatches,-                                                 sibling, relink,-                                                  upgradeFormat,-                                                 optimizePristine,-                                                 optimizeHTTP]}--optimizeCmd :: [DarcsFlag] -> [String] -> IO ()-optimizeCmd origopts _ = do-    when (UpgradeFormat `elem` origopts) optimizeUpgradeFormat-    withRepoLock opts $ RepoJob $ \repository -> do-    cleanRepository repository -- garbage collect pristine.hashed directory-    when (OptimizeHTTP `elem` origopts) $ doOptimizeHTTP repository-    if (OptimizePristine `elem` opts)-       then doOptimizePristine repository-       else do when (Reorder `elem` opts) $ doReorder opts repository-               doOptimizeInventory repository-               when (Compress `elem` opts || UnCompress `elem` opts) $-                    optimizeCompression opts-               when (Relink `elem` opts) $-                    doRelink opts-    putStrLn "Done optimizing!"-  where opts = if UnCompress `elem` origopts then NoCompress:origopts else origopts--optimizeHelpInventory :: String-optimizeHelpInventory =- "The default optimization moves recent patches (those not included in\n" ++- "the latest tag) to the `front', reducing the amount that a typical\n" ++- "remote command needs to download.  It should also reduce the CPU time\n" ++- "needed for some operations.\n"--doOptimizeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-doOptimizeInventory repository = do-    debugMessage "Writing out a nice copy of the inventory."-    optimizeInventory repository-    debugMessage "Done writing out a nice copy of the inventory."--optimizeHelpCompression :: String-optimizeHelpCompression =- "By default patches are compressed with zlib (RFC 1951) to reduce\n" ++- "storage (and download) size.  In exceptional circumstances, it may be\n" ++- "preferable to avoid compression.  In this case the `--dont-compress'\n" ++- "option can be used (e.g. with `darcs record') to avoid compression.\n" ++- "\n" ++- "The `darcs optimize --uncompress' and `darcs optimize --compress'\n" ++- "commands can be used to ensure existing patches in the current\n" ++- "repository are respectively uncompressed or compressed.  Note that\n" ++- "repositories in the legacy `old-fashioned-inventory' format have a .gz\n" ++- "extension on patch files even when uncompressed.\n"--optimizeCompression :: [DarcsFlag] -> IO ()-optimizeCompression opts = do-    putStrLn "Optimizing (un)compression of patches..."-    do_compress (darcsdir++"/patches")-    putStrLn "Optimizing (un)compression of inventories..."-    do_compress (darcsdir++"/inventories")-    where do_compress f =-              do isd <- doesDirectoryExist f-                 if isd then withCurrentDirectory f $-                             do fs <- filter notdot `fmap` getDirectoryContents "."-                                mapM_ do_compress fs-                        else if Compress `elem` opts-                             then gzReadFilePS f >>= gzWriteAtomicFilePS f-                             else gzReadFilePS f >>= writeAtomicFilePS f-          notdot ('.':_) = False-          notdot _ = True--optimizeHelpRelink :: String-optimizeHelpRelink =- "The `darcs optimize --relink' command hard-links patches that the\n" ++- "current repository has in common with its peers.  Peers are those\n" ++- "repositories listed in _darcs/prefs/sources, or defined with the\n" ++- "`--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" ++- "repository, or if you pulled the same patch from a remote repository\n" ++- "into multiple local repositories.\n"--doOptimizePristine :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-doOptimizePristine repo = do-  hashed <- doesFileExist $ darcsdir </> "hashed_inventory"-  when hashed $ do-    inv <- BS.readFile (darcsdir </> "hashed_inventory")-    let linesInv = BS.split '\n' inv-    case linesInv of-      [] -> return ()-      (pris_line:_) ->-          let size = decodeDarcsSize $ BS.drop 9 pris_line-           in when (isJust size) $ do putStrLn "Optimizing hashed pristine..."-                                      readRecorded repo >>= replacePristine repo-                                      cleanRepository repo--doRelink :: [DarcsFlag] -> IO ()-doRelink opts =-    do some_siblings <- return (flagsToSiblings opts)-       defrepolist <- getPreflist "defaultrepo"-       siblings <- return (map toFilePath some_siblings ++ defrepolist)-       if null siblings-          then putStrLn "No siblings -- no relinking done."-          else do debugMessage "Relinking patches..."-                  patch_tree <- expand =<< readPlainTree "_darcs/patches"-                  let patches = [ anchorPath "" p | (p, File _) <- list patch_tree ]-                  maybeRelinkFiles siblings patches "_darcs/patches"-                  debugMessage "Done relinking."--maybeRelinkFiles :: [String] -> [String] -> String -> IO ()-maybeRelinkFiles src dst dir =-    mapM_ (maybeRelinkFile src) (map ((dir ++ "/") ++) dst)--maybeRelinkFile :: [String] -> String -> IO ()-maybeRelinkFile [] _ = return ()-maybeRelinkFile (h:t) f =-    do done <- maybeRelink (h ++ "/" ++ f) f-       unless done $-           maybeRelinkFile t f---- FIXME: someone needs to grovel through the source and determine--- just how optimizeInventory differs from doReorder.  The following--- is purely speculation. --twb, 2009-04--- optimize_help_reorder :: String--- optimize_help_reorder =---  "The `darcs optimize --reorder' command is a more comprehensive version\n" ++---  "of the default optimization.  It reorders patches with respect to ALL\n" ++---  "tags, rather than just the latest tag.\n"--doReorder :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository p C(r u r) -> IO ()-doReorder opts repository = do-    debugMessage "Reordering the inventory."-    PatchSet ps _ <- chooseOrder `fmap` readRepo repository--- Warning:  A do-notation statement discarded a result of type Repository p r u r.-    withGutsOf repository $ do _ <- tentativelyReplacePatches repository (compression opts) $ reverseRL ps-                               finalizeRepositoryChanges repository-    debugMessage "Done reordering the inventory."--chooseOrder :: forall p C(s x) . RepoPatch p => PatchSet p C(s x) -> PatchSet p C(s x)-chooseOrder ps = case filter isTag $ mapRL info $ newset2RL ps of-                  [] -> ps-                  (lt:_) -> case splitOnTag lt ps of-                            PatchSet xs ts :> r -> PatchSet (r+<+xs) ts--optimizeUpgradeFormat :: IO ()-optimizeUpgradeFormat = do-  debugMessage $ "Upgrading to hashed..."-  rf <- identifyRepoFormat "."-  debugMessage $ "Found our format"-  if formatHas HashedInventory rf-     then putStrLn "No action taken because this repository already is hashed."-     else do putStrLn "Checking repository in case of corruption..."-             withRepoLock [] $ RepoJob $ \repository -> do-               actuallyUpgradeFormat repository--actuallyUpgradeFormat :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-actuallyUpgradeFormat repository = do-  -- convert patches/inventory-  patches <- readRepo repository-  let k = "Hashing patch"-  beginTedious k-  tediousSize k (lengthRL $ newset2RL patches)-  let patches' = progressPatchSet k patches-  cache <- getCaches [] "."-  let compr = compression [] -- default compression-  HashedRepo.writeTentativeInventory cache compr patches'-  endTedious k-  -- convert pristine by applying patches-  -- the faster alternative would be to copy pristine, but the apply method is more reliable-  let patchesToApply = progressFL "Applying patch" $ newset2FL $ patches'-  createDirectoryIfMissing False $ darcsdir </> hashedDir HashedPristineDir--- Warning:  A do-notation statement discarded a result of type Storage.Hashed.Hash.Hash.-  _ <- writeDarcsHashed emptyTree "_darcs/pristine.hashed"-  sequence_ $ mapFL HashedRepo.applyToTentativePristine $ bunchFL 100 patchesToApply-  -- now make it official-  HashedRepo.finalizeTentativeChanges repository compr-  writeRepoFormat (createRepoFormat [UseHashedInventory]) (darcsdir </> "format")-  -- clean out old-fashioned junk-  debugMessage "Cleaning out old-fashioned repository files..."-  removeFile   $ darcsdir </> "inventory"-  removeFile   $ darcsdir </> "tentative_inventory"-  rmRecursive (darcsdir </> "pristine") `catchall` rmRecursive (darcsdir </> "current")-  rmGzsIn (darcsdir </> "patches")-  rmGzsIn (darcsdir </> "inventories")-  let checkpointDir = darcsdir </> "checkpoints"-  hasCheckPoints <- doesDirectoryExist checkpointDir-  when hasCheckPoints $ rmRecursive checkpointDir-  putStrLn "Done upgrading!"- where-  rmGzsIn dir =-    withCurrentDirectory dir $ do-      gzs <- filter ((== ".gz") . takeExtension) `fmap` getDirectoryContents "."-      mapM_ removeFile gzs--doOptimizeHTTP :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-doOptimizeHTTP repo = flip finally (mapM_ (removeFileIfExists)-  [ darcsdir </> "meta-filelist-inventories"-  , darcsdir </> "meta-filelist-pristine"-  , basicTar <.> "part"-  , patchesTar <.> "part"-  ]) $ do-  rf <- identifyRepoFormat "."-  unless (formatHas HashedInventory rf) $ fail oldRepoFailMsg-  createDirectoryIfMissing False packsDir-  -- pack patchesTar-  ps <- mapRL hashedPatchFileName . newset2RL <$> readRepo repo-  is <- map ((darcsdir </> "inventories") </>) <$> HashedRepo.listInventories-  writeFile (darcsdir </> "meta-filelist-inventories") . unlines $-    map takeFileName is-  BL.writeFile (patchesTar <.> "part") . compress . write =<<-    mapM fileEntry' ((darcsdir </> "meta-filelist-inventories") : ps ++-    reverse is)-  renameFile (patchesTar <.> "part") patchesTar-  -- pack basicTar-  pr <- sortByMTime =<< dirContents "pristine.hashed"-  writeFile (darcsdir </> "meta-filelist-pristine") . unlines $-    map takeFileName pr-  BL.writeFile (basicTar <.> "part") . compress . write =<< mapM fileEntry' (-    [ darcsdir </> "meta-filelist-pristine"-    , darcsdir </> "hashed_inventory"-    ] ++ reverse pr)-  renameFile (basicTar <.> "part") basicTar- where-  packsDir = darcsdir </> "packs"-  basicTar = packsDir </> "basic.tar.gz"-  patchesTar = packsDir </> "patches.tar.gz"-  fileEntry' x = unsafeInterleaveIO $ do-    content <- BL.fromChunks . return <$> gzReadFilePS x-    tp <- either fail return $ toTarPath False x-    return $ fileEntry tp content-  dirContents d = dirContents' d $ const True-  dirContents' d f = map ((darcsdir </> d) </>) . filter (\x ->-    head x /= '.' && f x) <$> getDirectoryContents (darcsdir </> d)-  hashedPatchFileName x = case extractHash x of-    Left _ -> fail "unexpected unhashed patch"-    Right h -> darcsdir </> "patches" </> h-  sortByMTime xs = map snd . sort <$> mapM (\x -> (\t -> (t, x)) <$>-    getModificationTime x) xs-  removeFileIfExists x = do-    ex <- doesFileExist x-    when ex $ removeFile x
− src/Darcs/Commands/Pull.hs 
@@ -1,361 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Pull ( pull, fetch ) where-import System.Exit ( ExitCode(..), exitWith )-import Workaround ( getCurrentDirectory )-import Control.Monad ( when )-import Data.List ( nub )-import Data.Maybe ( fromMaybe )--import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo )-import Darcs.CommandsAux ( checkPaths )-import Darcs.Arguments-    ( DarcsFlag-        ( AllowConflicts-        , Complement-        , DryRun-        , Intersection-        , MarkConflicts-        , NoAllowConflicts-        , Verbose-        , XMLOutput-        )-    , allInteractive-    , allowUnrelatedRepos-    , changesReverse-    , depsSel-    , dryRun-    , fixUrl-    , getOutput-    , ignoretimes-    , makeScriptsExecutable-    , matchSeveral-    , networkOptions-    , nocompress-    , output-    , pauseForGui-    , printDryRunMessageAndExit-    , pullConflictOptions-    , remoteRepo-    , repoCombinator-    , restrictPaths-    , setDefault-    , setEnvDarcsPatches-    , setScriptsExecutableOption-    , summary-    , test-    , umaskOption-    , useExternalMerge-    , workingRepoDir-    )-import Darcs.Flags( doReverse, isInteractive )-import Darcs.Repository ( Repository, identifyRepositoryFor, withGutsOf,-                          amInHashedRepository, withRepoLock, RepoJob(..),-                          finalizeRepositoryChanges, applyToWorking,-                          testTentative,-                          readRepo, checkUnrelatedRepos, invalidateIndex, modifyCache, modifyCache,  Cache(..), CacheLoc(..), WritableOrNot(..))-import qualified Darcs.Repository.Cache as DarcsCache-import Darcs.Repository.Merge ( tentativelyMergePatches )-import Darcs.Patch.PatchInfoAnd ( info, hopefully, patchDesc )-import Darcs.Patch ( RepoPatch, description, PrimOf )-import Darcs.Patch.Bundle( makeBundleN, patchFilename )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet )-import Darcs.Witnesses.Unsafe ( unsafeCoercePEnd )-import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), FL(..), RL(..)-                               , mapFL, nullFL, reverseFL, mapFL_FL )-import Darcs.Patch.Permutations ( partitionFL )-import Darcs.Repository.Prefs ( addToPreflist, defaultrepo, setDefaultrepo, getPreflist )-import Darcs.Repository.Motd (showMotd )-import Darcs.Patch.Depends ( findUncommon, findCommonWithThem,-                             newsetIntersection, newsetUnion )-import Darcs.SelectChanges ( selectChanges,-                             WhichChanges(..),-                             filterOutConflicts,-                             runSelection, selectionContext)-import Darcs.Utils ( clarifyErrors, formatPath,-                     PromptConfig(..), promptChar )-import Darcs.Witnesses.Sealed ( Sealed(..), seal )-import Printer ( putDocLn, vcat, ($$), text, putDoc )-import Darcs.Lock ( writeDocBinFile )-import Darcs.RepoPath ( useAbsoluteOrStd, stdOut )-import Storage.Hashed.Tree( Tree )-#include "impossible.h"--#include "gadts.h"--pullDescription :: String-pullDescription =- "Copy and apply patches from another repository to this one."--fetchDescription :: String-fetchDescription =- "Fetch patches from another repository, but don't apply them."--pullHelp :: String-pullHelp =- "Pull is used to bring changes made in another repository into the current\n"++- "repository (that is, either the one in the current directory, or the one\n"++- "specified with the --repodir option). Pull allows you to bring over all or\n"++- "some of the patches that are in that repository but not in this one. Pull\n"++- "accepts arguments, which are URLs from which to pull, and when called\n"++- "without an argument, pull will use the repository from which you have most\n"++- "recently either pushed or pulled.\n" ++- "\n" ++- "See 'darcs help apply' for detailed description of many options.\n"--fetchHelp :: String-fetchHelp =- "fetch is used to bring changes made in another repository\n" ++- "into the current repository without actually applying\n"++- "them. Fetch allows you to bring over all or\n"++- "some of the patches that are in that repository but not in this one. Fetch\n"++- "accepts arguments, which are URLs from which to fetch, and when called\n"++- "without an argument, fetch will use the repository from which you have most\n"++- "recently either pushed or pulled.\n"++- "The fetched patches are stored into a patch bundle, to be later\n" ++- "applied using \"darcs apply\"."---fetch :: DarcsCommand-fetch = DarcsCommand {-         commandProgramName = "darcs",-         commandName = "fetch",-         commandHelp = fetchHelp,-         commandDescription = fetchDescription,-         commandExtraArgs = -1,-         commandExtraArgHelp = ["[REPOSITORY]..."],-         commandCommand = fetchCmd,-         commandPrereq = amInHashedRepository,-         commandGetArgPossibilities = getPreflist "repos",-         commandArgdefaults = defaultrepo,-         commandAdvancedOptions =-            [ repoCombinator-            , remoteRepo-            ] ++ networkOptions,-         commandBasicOptions = [matchSeveral,-                                  allInteractive]-                                 ++dryRun++-                                 [summary,-                                  depsSel,-                                  setDefault False,-                                  workingRepoDir,-                                  output,-                                  allowUnrelatedRepos]}--pull :: DarcsCommand-pull = DarcsCommand {commandProgramName = "darcs",-                     commandName = "pull",-                     commandHelp = pullHelp,-                     commandDescription = pullDescription,-                     commandExtraArgs = -1,-                     commandExtraArgHelp = ["[REPOSITORY]..."],-                     commandCommand = pullCmd,-                     commandPrereq = amInHashedRepository,-                     commandGetArgPossibilities = getPreflist "repos",-                     commandArgdefaults = defaultrepo,-                     commandAdvancedOptions =-                        [ repoCombinator-                        , nocompress-                        , ignoretimes-                        , remoteRepo-                        , setScriptsExecutableOption-                        , umaskOption-                        , restrictPaths-                        , changesReverse-                        , pauseForGui-                        ] ++ networkOptions,-                     commandBasicOptions = [matchSeveral,-                                              allInteractive,-                                              pullConflictOptions,-                                              useExternalMerge,-                                              test]++dryRun++[summary,-                                              depsSel,-                                              setDefault False,-                                              workingRepoDir,-                                              allowUnrelatedRepos]}--mergeOpts :: [DarcsFlag] -> [DarcsFlag]-mergeOpts opts | NoAllowConflicts `elem` opts = opts-                | AllowConflicts   `elem` opts = opts-                | otherwise                    = MarkConflicts : opts--pullCmd :: [DarcsFlag] -> [String] -> IO ()-pullCmd opts repos =-  do-    pullingFrom <- mapM (fixUrl opts) repos-    withRepoLock opts $ RepoJob $ \ initRepo -> do-      let repository = modifyCache initRepo $ addReposToCache pullingFrom-      r <- fetchPatches opts' repos "pull" repository-      applyPatches opts' repository r-    where-      opts' = mergeOpts opts-      addReposToCache repos' (Ca cache) = Ca $ [ toReadOnlyCache r | r <- repos' ] ++  cache-      toReadOnlyCache = Cache DarcsCache.Repo NotWritable---fetchCmd :: [DarcsFlag] -> [String] -> IO ()-fetchCmd opts repos =-    withRepoLock opts $ RepoJob $ \ repository ->-        fetchPatches opts repos "fetch" repository-                         >>= makeBundle opts--fetchPatches :: FORALL(p r u) (RepoPatch p, ApplyState p ~ Tree)-             => [DarcsFlag] -> [String] -> String-             -> Repository p C(r u r)-             -> IO (SealedPatchSet p C(Origin),-                    Sealed ((FL (PatchInfoAnd p)  :\/: FL (PatchInfoAnd p)) C(r)))-fetchPatches opts unfixedrepodirs@(_:_) jobname repository = do-  here <- getCurrentDirectory-  repodirs <- (nub . filter (/= here)) `fmap` mapM (fixUrl opts) unfixedrepodirs-  -- Test to make sure we aren't trying to pull from the current repo-  when (null repodirs) $-        fail "Can't pull from current repository!"-  old_default <- getPreflist "defaultrepo"-  when (old_default == repodirs && not (XMLOutput `elem` opts)) $-      let pulling = if DryRun `elem` opts then "Would pull" else "Pulling"-      in  putInfo opts $ text $ pulling++" from "++concatMap formatPath repodirs++"..."-  (Sealed them, Sealed compl) <- readRepos repository opts repodirs-  setDefaultrepo (head repodirs) opts-  mapM_ (addToPreflist "repos") repodirs-  mapM_ (showMotd opts) repodirs-  us <- readRepo repository-  checkUnrelatedRepos opts us them--  common :> _ <- return $ findCommonWithThem us them-  us' :\/: them' <- return $ findUncommon us them-  _   :\/: compl' <- return $ findUncommon us compl--  let avoided = mapFL info compl'-  ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) them'-  when (Verbose `elem` opts) $-       do case us' of-            (x@(_:>:_)) -> putDocLn $ text "We have the following new (to them) patches:"-                                                             $$ (vcat $ mapFL description x)-            _ -> return ()-          when (not $ nullFL ps) $ putDocLn $ text "They have the following patches to pull:"-                                                             $$ (vcat $ mapFL description ps)-  (hadConflicts, Sealed psFiltered) <- filterOutConflicts opts (reverseFL us') repository ps-  when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."-  when  (nullFL psFiltered) $ do putInfo opts $ text "No remote changes to pull in!"-                                 setEnvDarcsPatches psFiltered-                                 exitWith ExitSuccess-  let context = selectionContext jobname opts Nothing Nothing-      selector = if doReverse opts-                 then selectChanges FirstReversed-                 else selectChanges First-  (to_be_pulled :> _) <- runSelection (selector psFiltered) $ context-  return (seal common, seal $ us' :\/: to_be_pulled)--fetchPatches _ [] jobname _ = fail $ "No default repository to " ++ jobname ++-                                " from, please specify one"--applyPatches :: forall p C(r u). (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)-             => [DarcsFlag] -> Repository p C(r u r)-             -> (SealedPatchSet p C(Origin),-                 Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(r)))-             -> IO ()-applyPatches opts repository (_, Sealed (us' :\/: to_be_pulled)) =-         do-           printDryRunMessageAndExit "pull" opts to_be_pulled-           setEnvDarcsPatches to_be_pulled-           when (nullFL to_be_pulled) $ do-                               putStrLn "You don't want to pull any patches, and that's fine with me!"-                               exitWith ExitSuccess-           checkPaths opts to_be_pulled-           putVerbose opts $ text "Getting and merging the following patches:"-           putVerbose opts $ vcat $ mapFL description to_be_pulled-           Sealed pw <- tentativelyMergePatches repository "pull" opts us' to_be_pulled-           invalidateIndex repository-           rc <- testTentative repository-           when (rc /= ExitSuccess) $ do-               when (not $ isInteractive opts) $ exitWith rc-               putStrLn $ "Looks like those patches do not pass the tests."-               let prompt = "Shall I apply them anyway?"-               yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])-               case yn of-                 'y' -> return ()-                 _ -> exitWith rc-           withGutsOf repository $ do finalizeRepositoryChanges repository-                                      _ <- revertable $ applyToWorking repository opts pw-                                      makeScriptsExecutable opts pw-                                      return ()-           putInfo opts $ text "Finished pulling and applying."--makeBundle :: forall p C(r) . (RepoPatch p, ApplyState p ~ Tree)-           => [DarcsFlag]-           -> (SealedPatchSet p C(Origin),-               Sealed ((FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(r)))-           -> IO ()-makeBundle opts (Sealed common, Sealed (_ :\/: to_be_fetched)) =-    do-      bundle <- makeBundleN Nothing (unsafeCoercePEnd common) $-                 mapFL_FL hopefully to_be_fetched-      let fname = case to_be_fetched of-                    (x:>:_)-> patchFilename $ patchDesc x-                    _ -> impossible-          o = fromMaybe stdOut (getOutput opts fname)-      useAbsoluteOrStd writeDocBinFile putDoc o $ bundle--revertable :: IO a -> IO a-revertable x =-    x `clarifyErrors` unlines-          ["Error applying patch to the working directory.","",-           "This may have left your working directory an inconsistent",-           "but recoverable state. If you had no un-recorded changes",-           "by using 'darcs revert' you should be able to make your",-           "working directory consistent again."]--{- Read in the specified pull-from repositories.  Perform-Intersection, Union, or Complement read.  In patch-theory terms-(stated in set algebra, where + is union and & is intersection-and \ is complement):--    Union =         ((R1 + R2 + ... + Rn) \ Rc)-    Intersection =  ((R1 & R2 & ... & Rn) \ Rc)-    Complement =    (R1 \ Rc) \ ((R2 + R3 + ... + Rn) \ Rc)--                        where Rc = local repo-                              R1 = 1st specified pull repo-                              R2, R3, Rn = other specified pull repo--Since Rc is not provided here yet, the result of readRepos is a-tuple: the first patchset(s) to be complemented against Rc and then-the second patchset(s) to be complemented against Rc.--}--readRepos :: (RepoPatch p, ApplyState p ~ Tree)-          => Repository p C(r u t) -> [DarcsFlag] -> [String]-          -> IO (SealedPatchSet p C(Origin),SealedPatchSet p C(Origin))-readRepos _ _ [] = impossible-readRepos to_repo opts us =-    do rs <- mapM (\u -> do r <- identifyRepositoryFor to_repo u-                            ps <- readRepo r-                            return $ seal ps) us-       return $ if Intersection `elem` opts-                then (newsetIntersection rs, seal (PatchSet NilRL NilRL))-                else if Complement `elem` opts-                     then (head rs, newsetUnion $ tail rs)-                     else (newsetUnion rs, seal (PatchSet NilRL NilRL))-
− src/Darcs/Commands/Push.hs 
@@ -1,197 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, TypeOperators #-}--module Darcs.Commands.Push ( push ) where-import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ) )-import Control.Monad ( when )-import Data.Char ( toUpper )-import Workaround ( getCurrentDirectory )-import Darcs.Commands ( DarcsCommand(..), putVerbose, putInfo, abortRun )-import Darcs.Arguments ( DarcsFlag( DryRun, Sign, SignAs, NoSign, SignSSL ),-                         setEnvDarcsPatches,-                         workingRepoDir, summary,-                         printDryRunMessageAndExit,-                         applyas, matchSeveral, fixUrl, depsSel,-                         allInteractive, dryRun,-                         remoteRepo, networkOptions,-                         setDefault, sign, allowUnrelatedRepos,-                         changesReverse-                      )--import Darcs.Flags(doReverse)-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )-import Darcs.Repository ( Repository, withRepoReadLock, RepoJob(..), identifyRepositoryFor,-                          readRepo, amInHashedRepository, checkUnrelatedRepos )-import Darcs.Patch ( RepoPatch, description )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( (:>)(..), RL, FL, nullRL,-                             nullFL, reverseFL, mapFL_FL, mapRL )-import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist )-import Darcs.External ( maybeURLCmd, signString )-import Darcs.URL ( isHttpUrl, isFile )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..),-                             selectionContext, runSelection )-import Darcs.Utils ( formatPath )-import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )-import Darcs.Patch.Bundle ( makeBundleN )-import Darcs.Patch.Patchy( ShowPatch )-import Darcs.Patch.Set ( PatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Printer ( Doc, vcat, empty, text, ($$) )-import Darcs.RemoteApply ( remoteApply, applyAs )-import Darcs.Email ( makeEmail )-import English (englishNum, Noun(..))-import Storage.Hashed.Tree( Tree )-#include "impossible.h"--#include "gadts.h"--pushDescription :: String-pushDescription =- "Copy and apply patches from this repository to another one."--pushHelp :: String-pushHelp =- "Push is the opposite of pull.  Push allows you to copy changes from the\n"++- "current repository into another repository.\n"--push :: DarcsCommand-push = DarcsCommand {commandProgramName = "darcs",-                     commandName = "push",-                     commandHelp = pushHelp,-                     commandDescription = pushDescription,-                     commandExtraArgs = 1,-                     commandExtraArgHelp = ["[REPOSITORY]"],-                     commandCommand = pushCmd,-                     commandPrereq = amInHashedRepository,-                     commandGetArgPossibilities = getPreflist "repos",-                     commandArgdefaults = defaultrepo,-                     commandAdvancedOptions = [applyas,-                                                 remoteRepo,-                                                 changesReverse] ++-                                                networkOptions,-                     commandBasicOptions = [matchSeveral, depsSel,-                                              allInteractive,-                                              sign]++dryRun++[summary,-                                              workingRepoDir,-                                              setDefault False,-                                              allowUnrelatedRepos]}--pushCmd :: [DarcsFlag] -> [String] -> IO ()-pushCmd _ [""] = impossible-pushCmd opts [unfixedrepodir] =- do- repodir <- fixUrl opts unfixedrepodir- -- Test to make sure we aren't trying to push to the current repo- here <- getCurrentDirectory- checkOptionsSanity opts repodir- when (repodir == here) $-       fail "Cannot push from repository to itself."-       -- absolute '.' also taken into account by fix_filepath- (bundle) <- withRepoReadLock opts $ RepoJob $-                          prepareBundle opts repodir- sbundle <- signString opts bundle- let body = if isFile repodir-            then sbundle-            else makeEmail repodir [] Nothing Nothing sbundle Nothing- rval <- remoteApply opts repodir body- case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"-                                   exitWith (ExitFailure ec)-              ExitSuccess -> putInfo opts $ text "Push successful."-pushCmd _ _ = impossible--prepareBundle :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree)-              => [DarcsFlag] -> String -> Repository p C(r u t) -> IO (Doc)-prepareBundle opts repodir repository = do-  old_default <- getPreflist "defaultrepo"-  when (old_default == [repodir]) $-       let pushing = if DryRun `elem` opts then "Would push" else "Pushing"-       in  putInfo opts $ text $ pushing++" to "++formatPath repodir++"..."-  them <- identifyRepositoryFor repository repodir >>= readRepo-  setDefaultrepo repodir opts-  us <- readRepo repository-  common :> us' <- return $ findCommonWithThem us them-  prePushChatter opts us (reverseFL us') them-  let context = selectionContext "push" opts Nothing Nothing-      selector = if doReverse opts-                 then selectChanges FirstReversed-                 else selectChanges First-  runSelection (selector us') context-                   >>= bundlePatches opts common--prePushChatter :: forall p a C(x y t) . (RepoPatch p, ShowPatch a) =>-                 [DarcsFlag] -> PatchSet p C(Origin x) ->-                 RL a C(t x) -> PatchSet p C(Origin y) -> IO ()-prePushChatter opts us us' them = do-  checkUnrelatedRepos opts us them-  let num_to_pull = snd $ countUsThem us them-      pull_reminder = if num_to_pull > 0-                      then text $ "The remote repository has " ++ show num_to_pull-                      ++ " " ++ englishNum num_to_pull (Noun "patch") " to pull."-                      else empty-  putVerbose opts $ text "We have the following patches to push:" $$ (vcat $ mapRL description us')-  when (not $ nullRL us') $ do putInfo opts $ pull_reminder-  when (nullRL us') $ do putInfo opts $ text "No recorded local changes to push!"-                         exitWith ExitSuccess--bundlePatches :: forall t p C(z w a). (RepoPatch p, ApplyState p ~ Tree)-              => [DarcsFlag] -> PatchSet p C(a z)-              -> (FL (PatchInfoAnd p) :> t) C(z w)-              -> IO (Doc)-bundlePatches opts common (to_be_pushed :> _) =-    do-      setEnvDarcsPatches to_be_pushed-      printDryRunMessageAndExit "push" opts to_be_pushed-      when (nullFL to_be_pushed) $ do-          putInfo opts $-            text "You don't want to push any patches, and that's fine with me!"-          exitWith ExitSuccess-      bundle <- makeBundleN Nothing-                     common (mapFL_FL hopefully to_be_pushed)-      return (bundle)--wantSign :: [DarcsFlag] -> Bool-wantSign opts = case opts of-    []            -> False-    Sign:_        -> True-    (SignAs _):_  -> True-    (SignSSL _):_ -> True-    NoSign:_      -> False-    _:opts'       -> wantSign opts'---checkOptionsSanity :: [DarcsFlag] -> String -> IO ()-checkOptionsSanity opts repodir =-  if isHttpUrl repodir then do-       when (applyAs opts /= Nothing) $-           abortRun opts $ text "Cannot --apply-as when pushing to URLs"-       maybeapply <- maybeURLCmd "APPLY" repodir-       when (maybeapply == Nothing) $-         let lprot = takeWhile (/= ':') repodir-             prot = map toUpper lprot-             msg = text ("Pushing to "++lprot++" URLs is not supported.\n"++-                         "You may be able to hack this to work"++-                         " using DARCS_APPLY_"++prot) in-         abortRun opts msg-   else do-       when (wantSign opts) $-        abortRun opts $ text "Signing doesn't make sense for local repositories or when pushing over ssh."-
− src/Darcs/Commands/Put.hs 
@@ -1,127 +0,0 @@-{-# LANGUAGE CPP #-}--module Darcs.Commands.Put ( put ) where-import System.Exit ( ExitCode( ExitSuccess, ExitFailure ), exitWith )-import Control.Monad ( when )-import Data.Maybe ( mapMaybe )-import System.Directory ( createDirectory )-import Darcs.Commands ( DarcsCommand(..), nodefaults, putVerbose, putInfo )-import Darcs.Arguments ( DarcsFlag( UseFormat2, UseHashedInventory ),-                        applyas, matchOneContext, fixUrl,-                        networkOptions, flagToString,-                        setScriptsExecutableOption, workingRepoDir, setDefault-                      )-import Darcs.Repository ( withRepoReadLock, RepoJob(..), patchSetToPatches, readRepo, amInHashedRepository )-import Darcs.Repository.Format ( identifyRepoFormat,-                                 RepoProperty ( Darcs2 ), formatHas )-import Darcs.Patch.Bundle ( makeBundle2 )-import Darcs.Patch.Set ( PatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Eq ( EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( RL(..), nullFL )-import Darcs.Match ( havePatchsetMatch, getOnePatchset )-import Darcs.Repository.Prefs ( getPreflist, setDefaultrepo )-import Darcs.URL ( isHttpUrl, isFile, splitSshUrl, SshFilePath(..) )-import Darcs.Utils ( withCurrentDirectory )-import Progress ( debugMessage )-import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )-import Darcs.External ( execSSH )-import Darcs.RemoteApply ( remoteApply )-import Darcs.Commands.Init ( initialize )-import Darcs.Email ( makeEmail )-import Darcs.Witnesses.Sealed ( Sealed(..), seal )-import Printer ( text )-#include "impossible.h"-#include "gadts.h"--putDescription :: String-putDescription =- "Makes a copy of the repository"--putHelp :: String-putHelp =- "The `darcs put' command creates a copy of the current repository.  It\n" ++- "is currently very inefficient, so when creating local copies you\n" ++- "should use `darcs get . x' instead of `darcs put x'.\n" ++- "\n" ++- "Currently this command just uses `darcs init' to create the target\n" ++- "repository, then `darcs push --all' to copy patches to it.  Options\n" ++- "passed to `darcs put' are passed to the init and/or push commands as\n" ++- "appropriate.  See those commands for an explanation of each option.\n"--put ::DarcsCommand-put = DarcsCommand {commandProgramName = "darcs",-                    commandName = "put",-                    commandHelp = putHelp,-                    commandDescription = putDescription,-                    commandExtraArgs = 1,-                    commandExtraArgHelp = ["<NEW REPOSITORY>"],-                    commandCommand = putCmd,-                    commandPrereq = amInHashedRepository,-                    commandGetArgPossibilities = getPreflist "repos",-                    commandArgdefaults = nodefaults,-                    commandAdvancedOptions = [applyas] ++ networkOptions,-                    commandBasicOptions = [matchOneContext, setScriptsExecutableOption,-                                             setDefault False, workingRepoDir]}--putCmd :: [DarcsFlag] -> [String] -> IO ()-putCmd _ [""] = fail "Empty repository argument given to put."-putCmd opts [unfixedrepodir] =- do- repodir <- fixUrl opts unfixedrepodir- -- Test to make sure we aren't trying to push to the current repo- t_cur_absolute_repo_dir <- ioAbsoluteOrRemote "."- t_req_absolute_repo_dir <- ioAbsoluteOrRemote repodir- let cur_absolute_repo_dir = toPath t_cur_absolute_repo_dir-     req_absolute_repo_dir = toPath t_req_absolute_repo_dir- when (cur_absolute_repo_dir == req_absolute_repo_dir) $-       fail "Can't put to current repository!"- when (isHttpUrl req_absolute_repo_dir) $ error "Can't put to a URL!"-- debugMessage "Creating repository"- putVerbose opts $ text "Creating repository"- rf <- identifyRepoFormat "."- let initopts = if formatHas Darcs2 rf-                then UseFormat2:opts-                else UseHashedInventory:filter (/= UseFormat2) opts- if isFile req_absolute_repo_dir-     then do createDirectory req_absolute_repo_dir-             withCurrentDirectory req_absolute_repo_dir $ (commandCommand initialize) initopts []-     else do -- isSshUrl req_absolute_repo_dir-             remoteInit (splitSshUrl req_absolute_repo_dir) initopts-- withCurrentDirectory cur_absolute_repo_dir $-                      withRepoReadLock opts $ RepoJob $ \repository -> (do-  setDefaultrepo req_absolute_repo_dir opts-  let doRead = if havePatchsetMatch opts-               then getOnePatchset repository opts  -- todo: make sure getOnePatchset has the right type-               else readRepo repository >>= (return . seal)-  Sealed (patchset :: PatchSet p C(Origin x1)) <- doRead-  Sealed (patchset2 :: PatchSet p C(Origin x2)) <- doRead-  IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck C(x1 x2))-  let patches = patchSetToPatches patchset-      patches2 = patchSetToPatches patchset2-  when (nullFL patches) $ do-          putInfo opts $ text "No patches were selected to put. Nothing to be done."-          exitWith ExitSuccess-  bundle <- makeBundle2 Nothing NilRL patches patches2-  let message = if isFile req_absolute_repo_dir-                then bundle-                else makeEmail req_absolute_repo_dir [] Nothing Nothing bundle Nothing-  putVerbose opts $ text "Applying patches in new repository..."-  rval <- remoteApply opts req_absolute_repo_dir message-  case rval of ExitFailure ec -> do putStrLn $ "Apply failed!"-                                    exitWith (ExitFailure ec)-               ExitSuccess -> putInfo opts $ text "Put successful.") :: IO ()-putCmd _ _ = impossible--remoteInit :: SshFilePath -> [DarcsFlag] -> IO ()-remoteInit repo opts = do-    let args = mapMaybe (flagToString $ commandBasicOptions initialize) opts-        command = "darcs initialize --repodir='" ++ (sshRepo repo) ++ "' " ++ unwords args-    exitCode <- execSSH repo command-    when (exitCode /= ExitSuccess) $-         fail "Couldn't initialize remote repository."
− src/Darcs/Commands/Record.hs 
@@ -1,430 +0,0 @@---  Copyright (C) 2002-2003 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}--module Darcs.Commands.Record ( record, commit, getDate, getLog,-                               askAboutDepends-                             ) where--import Prelude hiding ( catch )--import qualified Ratified( hGetContents )-import Control.Applicative ( (<$>) )-import Control.Exception.Extensible ( handleJust, catch, IOException )-import Control.Monad ( when, unless )-import System.IO ( stdin )-import Data.List ( sort, isPrefixOf, union )-import Data.Char ( ord )-import System.Exit ( exitWith, exitFailure, ExitCode(..) )-import System.Directory ( removeFile )-import Data.Maybe ( isJust, catMaybes )-import qualified Data.ByteString as B ( hPut )--import Darcs.Lock ( readLocaleFile, writeLocaleFile, worldReadableTemp, appendToFile )-import Darcs.Patch.PatchInfoAnd ( info, n2pia, PatchInfoAnd )-import Darcs.Repository ( Repository, amInHashedRepository, withRepoLock, RepoJob(..),-                          withGutsOf,-                    readTentativeRepo,-                    tentativelyAddPatch, finalizeRepositoryChanges-                        , testTentative-                        , invalidateIndex, unrecordedChanges, readRecorded )-import Darcs.Patch ( RepoPatch, Patchy, PrimOf, PrimPatch, namepatch, summaryFL, anonymous,-                     adddeps, fromPrims )-import Darcs.Patch.Set ( PatchSet(..) )-import Darcs.Witnesses.Eq ( unsafeCompare )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+),-                             reverseRL, mapFL, mapFL_FL, nullFL )-import Darcs.Witnesses.Sealed-import Darcs.Patch.Info ( PatchInfo )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Split ( primSplitter )-import Darcs.Patch.Choices ( patchChoicesTps, tpPatch,-                             forceFirsts, getChoices, tag )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..),-                             selectionContext, selectionContextPrim,-                             runSelection-                           )-import Darcs.RepoPath ( FilePathLike, SubPath, toFilePath )-import Darcs.Commands ( DarcsCommand(..), nodefaults, commandStub )-import Darcs.Commands.Util ( announceFiles, filterExistingFiles )-import Darcs.Arguments ( DarcsFlag( PromptLongComment, NoEditLongComment,-                                    EditLongComment, LogFile, Pipe, Quiet,-                                    PatchName, AskDeps, All ),-                         fileHelpAuthor,-                         getAuthor, workingRepoDir, lookforadds,-                         fixSubPaths, setEnvDarcsFiles,-                         askLongComment, askdeps, patchSelectFlag,-                         allPipeInteractive, leaveTestDir, test,-                         author, patchnameOption, umaskOption, ignoretimes,-                         nocompress, rmlogfile, logfile, listRegisteredFiles,-                         setScriptsExecutableOption-                         , unified )-import Darcs.Flags (willRemoveLogFile, diffingOpts, compression, isInteractive)-import Darcs.Utils ( askUser, promptYorn, PromptConfig(..), promptChar, editFile, clarifyErrors )-import Progress ( debugMessage)-import Darcs.ProgressPatches( progressFL)-import IsoDate ( getIsoDateTime, cleanLocalDate )-import Printer ( hPutDocLn, text, wrapText, ($$) )-import ByteStringUtils ( encodeLocale )-import Storage.Hashed.Tree( Tree )--#include "impossible.h"-#include "gadts.h"--recordDescription :: String-recordDescription = "Create a patch from unrecorded changes."--recordHelp :: String-recordHelp =- "The `darcs record' command is used to create a patch from changes in\n" ++- "the working tree.  If you specify a set of files and directories,\n" ++- "changes to other files will be skipped.\n" ++- "\n" ++ recordHelp' ++- "\n" ++ recordHelp''--record :: DarcsCommand-record = DarcsCommand {commandProgramName = "darcs",-                       commandName = "record",-                       commandHelp = recordHelp,-                       commandDescription = recordDescription,-                       commandExtraArgs = -1,-                       commandExtraArgHelp = ["[FILE or DIRECTORY]..."],-                       commandCommand = recordCmd,-                       commandPrereq = amInHashedRepository,-                       commandGetArgPossibilities = listRegisteredFiles,-                       commandArgdefaults = nodefaults,-                       commandAdvancedOptions = [logfile, rmlogfile,-                                                   nocompress, ignoretimes,-                                                   umaskOption,-                                                   setScriptsExecutableOption],-                       commandBasicOptions = [patchnameOption, author,-                                               test,-                                               leaveTestDir,-                                               allPipeInteractive,-                                               askdeps,-                                               askLongComment,-                                               lookforadds,-                                               workingRepoDir, unified]}--commitDescription :: String-commitDescription = "Redirect the user to record, push or send."--commitHelp :: String-commitHelp =- "This command does not do anything.\n"++- "If you want to save changes locally, use the `darcs record' command.\n"++- "If you want to save a recorded patch to another repository, use the\n"++- "`darcs push' or `darcs send' commands instead.\n"--commit :: DarcsCommand-commit = commandStub "commit" commitHelp commitDescription record--recordCmd :: [DarcsFlag] -> [String] -> IO ()-recordCmd opts args = do-    checkNameIsNotOption opts-    withRepoLock opts $ RepoJob $ \repository -> do-    files <- if null args then return Nothing-        else Just . sort <$> fixSubPaths opts args-    when (files == Just []) $ fail "No valid arguments were given."-    announceFiles files "Recording changes in"-    existing_files <- maybe (return Nothing)-        (fmap Just . filterExistingFiles repository) files-    when (existing_files == Just []) $-       fail "None of the files you specified exist!"-    debugMessage "About to get the unrecorded changes."-    changes <- unrecordedChanges (diffingOpts opts) repository files-    debugMessage "I've gotten unrecorded."-    case allow_empty_with_askdeps changes of--- Warning:  A do-notation statement discarded a result of type String.-      Nothing -> do when (Pipe `elem` opts) $ do _ <- getDate opts-                                                 return ()-                    putStrLn "No changes!"-                    exitFailure-      Just ch -> doRecord repository opts existing_files ch-    where allow_empty_with_askdeps :: FL p C(x y) -> Maybe (FL p C(x y))-          allow_empty_with_askdeps NilFL-              | AskDeps `elem` opts = Just NilFL-              | otherwise = Nothing-          allow_empty_with_askdeps p = Just p-- -- check that what we treat as the patch name is not accidentally a command- -- line flag-checkNameIsNotOption :: [DarcsFlag] -> IO ()-checkNameIsNotOption opts = do-    let patchNames = [n | PatchName n <- opts]-    when (length patchNames == 1) $ do-        let n = head patchNames-            oneLetterName = length n == 1 || (length n == 2 && head n == '-')-        if (oneLetterName && (All `notElem` opts))-            then do confirmed <- promptYorn $ "You specified " ++ show n ++ " as the patch name. Is that really what you want?"-                    unless confirmed $ do putStrLn "Okay, aborting the record."-                                          exitFailure-            else return ()---doRecord :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)-         => Repository p C(r u r) -> [DarcsFlag] -> Maybe [SubPath] -> FL (PrimOf p) C(r x) -> IO ()-doRecord repository opts files ps = do-    let make_log = worldReadableTemp "darcs-record"-    date <- getDate opts-    my_author <- getAuthor opts-    debugMessage "I'm slurping the repository."-    debugMessage "About to select changes..."-    pristine <- readRecorded repository-    (chs :> _ ) <- runSelection (selectChanges First ps) $-                  selectionContextPrim "record" opts (Just primSplitter)-                                       (map toFilePath <$> files)-                                       (Just pristine)-    when (is_empty_but_not_askdeps chs) $-              do putStrLn "Ok, if you don't want to record anything, that's fine!"-                 exitWith ExitSuccess-    handleJust onlySuccessfulExits (\_ -> return ()) $-             do deps <- if AskDeps `elem` opts-                        then askAboutDepends repository chs opts []-                        else return []-                when (AskDeps `elem` opts) $ debugMessage "I've asked about dependencies."-                if nullFL chs && null deps-                  then putStrLn "Ok, if you don't want to record anything, that's fine!"-                  else do setEnvDarcsFiles chs-                          (name, my_log, logf) <- getLog opts Nothing make_log chs-                          debugMessage ("Patch name as received from getLog: " ++ show (map ord name))-                          doActualRecord repository opts name date-                                 my_author my_log logf deps chs-    where is_empty_but_not_askdeps l-              | AskDeps `elem` opts = False-                                      -- a "partial tag" patch; see below.-              | otherwise = nullFL l--doActualRecord :: (RepoPatch p, ApplyState p ~ Tree)-               => Repository p C(r u r) -> [DarcsFlag] -> String -> String -> String-               -> [String] -> Maybe String-               -> [PatchInfo] -> FL (PrimOf p) C(r x) -> IO ()-doActualRecord repository opts name date my_author my_log logf deps chs =-              do debugMessage "Writing the patch file..."-                 mypatch <- namepatch date name my_author my_log $-                            fromPrims $ progressFL "Writing changes:" chs--- Warning:  A do-notation statement discarded a result of type Repository p r u x.-                 _ <- tentativelyAddPatch repository (compression opts) $ n2pia $ adddeps mypatch deps-                 invalidateIndex repository-                 debugMessage "Applying to pristine..."-                 rc <- testTentative repository-                 when (rc /= ExitSuccess) $ do-                     when (not $ isInteractive opts) $ exitWith rc `clarifyErrors` failuremessage-                     putStrLn $ "Looks like you have a bad patch: '"++name++"'"-                     let prompt = "Shall I record it anyway?"-                     yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])-                     case yn of-                       'y' -> return ()-                       _ -> exitWith rc `clarifyErrors` failuremessage-                 withGutsOf repository (finalizeRepositoryChanges repository)-                                    `clarifyErrors` failuremessage-                 debugMessage "Syncing timestamps..."-                 when (isJust logf) $ removeFile (fromJust logf)-                 when (Quiet `notElem` opts) $-                     putStrLn $ "Finished recording patch '"++name++"'"-    where failuremessage = "Failed to record patch '"++name++"'" ++-                           case logf of Just lf -> "\nLogfile left in "++lf++"."-                                        Nothing -> ""--recordHelp' :: String-recordHelp' =- "Every patch has a name, an optional description, an author and a date.\n" ++- "\n" ++- "The patch name should be a short sentence that concisely describes the\n" ++- "patch, such as `Add error handling to main event loop.'  You can\n" ++- "supply it in advance with the -m option, or provide it when prompted.\n" ++- "\n" ++- "The patch description is an optional block of free-form text.  It is\n" ++- "used to supply additional information that doesn't fit in the patch\n" ++- "name.  For example, it might include a rationale of WHY the change was\n" ++- "necessary.  By default Darcs asks if you want to add a description;\n" ++- "the --edit-long-comment and --skip-long-comment can be used to answer\n" ++- "`yes' or `no' (respectively) to this prompt.  Finally, the --logfile\n" ++- "option allows you to supply a file that already contains the patch\n" ++- "name (first line) and patch description (subsequent lines).  This is\n" ++- "useful if a previous record failed and left a darcs-record-0 file.\n" ++- "\n" ++- unlines fileHelpAuthor ++- "\n" ++- "The patch date is generated automatically.  It can only be spoofed by\n" ++- "using the --pipe option.\n"--getDate :: [DarcsFlag] -> IO String-getDate opts- | Pipe `elem` opts = do cleanLocalDate `fmap` askUser "What is the date? "-getDate _ = getIsoDateTime--data PName = FlagPatchName String | PriorPatchName String | NoPatchName--getLog :: forall prim C(x y) . (Patchy prim, PrimPatch prim) => [DarcsFlag] -> Maybe (String, [String]) -> IO String -> FL prim C(x y) ->-           IO (String, [String], Maybe String)-getLog opts m_old make_log chs = gl opts-    where patchname_specified = patchname_helper opts-          patchname_helper (PatchName n:_) | "TAG " `isPrefixOf` n = FlagPatchName $ '.':n-                                           | otherwise             = FlagPatchName n-          patchname_helper (_:fs) = patchname_helper fs-          patchname_helper [] = case m_old of Just (p,_) -> PriorPatchName p-                                              Nothing    -> NoPatchName-          default_log = case m_old of-                          Nothing    -> []-                          Just (_,l) -> l-          gl (Pipe:_) = do p <- case patchname_specified of-                                  FlagPatchName p  -> return p-                                  PriorPatchName p -> return p-                                  NoPatchName      -> prompt_patchname False-                           putStrLn "What is the log?"-                           thelog <- lines `fmap` Ratified.hGetContents stdin-                           return (p, thelog, Nothing)-          gl (LogFile f:fs) =-              do -- round 1 (patchname)-                 mlp <- lines `fmap` readLocaleFile f `catch` (\(_ :: IOException) -> return [])-                 firstname <- case (patchname_specified, mlp) of-                                (FlagPatchName  p, []) -> return p-                                (_, p:_)               -> return p -- logfile trumps prior!-                                (PriorPatchName p, []) -> return p-                                (NoPatchName, [])      -> prompt_patchname True-                 -- round 2-                 append_info f firstname--- Warning:  A do-notation statement discarded a result of type ExitCode.-                 when (EditLongComment `elem` fs) $ do _ <- editFile f-                                                       return ()-                 (name, thelog, _) <- read_long_comment f firstname-                 let toRemove = if willRemoveLogFile opts-                        then Just $ toFilePath f-                        else Nothing-                 return (name, thelog, toRemove)-          gl (EditLongComment:_) =-                  case patchname_specified of-                    FlagPatchName  p -> actually_get_log p-                    PriorPatchName p -> actually_get_log p-                    NoPatchName      -> prompt_patchname True >>= actually_get_log-          gl (NoEditLongComment:_) =-                  case patchname_specified of-                    FlagPatchName  p-                        | Just ("",_) <- m_old ->-                                       return (p, default_log, Nothing) -- rollback -m-                    FlagPatchName  p -> return (p, default_log, Nothing) -- record (or amend) -m-                    PriorPatchName p -> return (p, default_log, Nothing) -- amend-                    NoPatchName      -> do p <- prompt_patchname True -- record-                                           return (p, [], Nothing)-          gl (PromptLongComment:fs) =-                  case patchname_specified of-                    FlagPatchName p -> prompt_long_comment p -- record (or amend) -m-                    _               -> gl fs-          gl (_:fs) = gl fs-          gl [] = case patchname_specified of-                    FlagPatchName  p -> return (p, default_log, Nothing)  -- record (or amend) -m-                    PriorPatchName "" -> prompt_patchname True >>= prompt_long_comment-                    PriorPatchName p -> return (p, default_log, Nothing)-                    NoPatchName -> prompt_patchname True >>= prompt_long_comment-          prompt_patchname retry =-            do n <- askUser "What is the patch name? "-               if n == "" || "TAG " `isPrefixOf` n-                  then if retry then prompt_patchname retry-                                else fail "Bad patch name!"-                  else return n-          prompt_long_comment oldname =-            do y <- promptYorn "Do you want to add a long comment?"-               if y then actually_get_log oldname-                    else return (oldname, [], Nothing)-          actually_get_log p = do logf <- make_log-                                  -- TODO: make sure encoding used for logf is the same everywhere-                                  -- probably should be locale because the editor will assume it-                                  writeLocaleFile logf $ unlines $ p : default_log-                                  append_info logf p--- Warning:  A do-notation statement discarded a result of type ExitCode.-                                  _ <- editFile logf-                                  read_long_comment logf p-          read_long_comment :: FilePathLike p => p -> String -> IO (String, [String], Maybe p)-          read_long_comment f oldname =-              do t <- (lines.filter (/='\r')) `fmap` readLocaleFile f-                 case t of [] -> return (oldname, [], Just f)-                           (n:ls) -> return (n, takeWhile-                                             (not.(eod `isPrefixOf`)) ls,-                                             Just f)-          append_info f oldname =-              do fc <- readLocaleFile f-                 appendToFile f $ \h ->-                     do case fc of-                          _ | null (lines fc) -> B.hPut h (encodeLocale (oldname ++ "\n"))-                            | last fc /= '\n' -> B.hPut h (encodeLocale "\n")-                            | otherwise       -> return ()-                        hPutDocLn h $ text eod-                            $$ text ""-                            $$ wrapText 75-                               ("Place the long patch description above the "++-                                eod++-                                " marker.  The first line of this file "++-                                "will be the patch name.")-                            $$ text ""-                            $$ text "This patch contains the following changes:"-                            $$ text ""-                            $$ summaryFL chs--eod :: String-eod = "***END OF DESCRIPTION***"--askAboutDepends :: forall p C(r u t y) . (RepoPatch p, ApplyState p ~ Tree)-                => Repository p C(r u t) -> FL (PrimOf p) C(t y) -> [DarcsFlag]-                -> [PatchInfo] -> IO [PatchInfo]-askAboutDepends repository pa' opts olddeps = do-  -- ideally we'd just default the olddeps to yes but still ask about them.-  -- SelectChanges doesn't currently (17/12/09) offer a way to do this so would-  -- have to have this support added first.-  pps <- readTentativeRepo repository-  pa <- n2pia `fmap` anonymous (fromPrims pa')-  FlippedSeal ps <- return-                      ((case pps of-                          PatchSet x _ -> FlippedSeal ((reverseRL x)+>+(pa:>:NilFL)))-                         :: FlippedSeal (FL (PatchInfoAnd p)) C(y))-  let (pc, tps) = patchChoicesTps ps-      tas = case catMaybes (mapFL (\tp -> if pa `unsafeCompare` (tpPatch tp) || info (tpPatch tp) `elem` olddeps-                                          then Just (tag tp) else Nothing) tps) of--                [] -> error "askAboutDepends: []"-                tgs -> tgs-  Sealed2 ps' <- return $ case getChoices (forceFirsts tas pc) of _ :> mc :> _ -> Sealed2 $ mapFL_FL tpPatch mc-  (deps:>_) <- runSelection (selectChanges FirstReversed ps') $-                                        selectionContext "depend on" (filter askdep_allowed opts) Nothing Nothing-  return $ olddeps `union` mapFL info deps- where-       askdep_allowed = not . patchSelectFlag---onlySuccessfulExits :: ExitCode -> Maybe ()-onlySuccessfulExits ExitSuccess = Just ()-onlySuccessfulExits _ = Nothing--recordHelp'' :: String-recordHelp'' =- "If a test command has been defined with `darcs setpref', attempting to\n" ++- "record a patch will cause the test command to be run in a clean copy\n" ++- "of the working tree (that is, including only recorded changes).  If\n" ++- "the test fails, you will be offered to abort the record operation.\n" ++- "\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" ++- "\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" ++- "skip all but the final test.\n" ++- "\n" ++- "To see some context (unchanged lines) around each change, use the\n" ++- "--unified option.\n"-
− src/Darcs/Commands/Remove.hs 
@@ -1,166 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Remove ( remove, rm, unadd ) where--import Control.Monad ( when, foldM )-import Darcs.Commands ( DarcsCommand(..), nodefaults,-                        commandAlias, commandStub,-                        putWarning-                      )-import Darcs.Arguments ( DarcsFlag (Recursive), fixSubPaths,-                        listRegisteredFiles,-                        workingRepoDir, umaskOption,-                        recursive-                      )-import Darcs.RepoPath ( SubPath, sp2fn )-import Darcs.Repository ( Repository, withRepoLock, RepoJob(..), amInHashedRepository,-                          addToPending, readRecordedAndPending, readUnrecorded )-import Darcs.Diff( treeDiff )-import Darcs.Patch ( RepoPatch, PrimOf, PrimPatch, adddir, rmdir, addfile, rmfile )-import Darcs.Patch.FileName( fn2fp )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( FL(..), (+>+) )-import Darcs.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )-import Darcs.Repository.Prefs ( filetypeFunction, FileType )-import Storage.Hashed.Tree( Tree, TreeItem(..), find, modifyTree, expand, list )-import Storage.Hashed.AnchoredPath( anchorPath, AnchoredPath )-import Storage.Hashed( floatPath )--import Darcs.Commands.Add( expandDirs )-import Printer ( text )--#include "gadts.h"--removeDescription :: String-removeDescription = "Remove files from version control."--removeHelp :: String-removeHelp =- "The `darcs remove' command exists primarily for symmetry with `darcs\n" ++- "add', as the normal way to remove a file from version control is\n" ++- "simply to delete it from the working tree.  This command is only\n" ++- "useful in the unusual case where one wants to record a removal patch\n" ++- "WITHOUT deleting the copy in the working tree (which can be re-added).\n" ++- "\n" ++- "Note that applying a removal patch to a repository (e.g. by pulling\n" ++- "the patch) will ALWAYS affect the working tree of that repository.\n"--remove :: DarcsCommand-remove = DarcsCommand {commandProgramName = "darcs",-                       commandName = "remove",-                       commandHelp = removeHelp,-                       commandDescription = removeDescription,-                       commandExtraArgs = -1,-                       commandExtraArgHelp = ["<FILE or DIRECTORY> ..."],-                       commandCommand = removeCmd,-                       commandPrereq = amInHashedRepository,-                       commandGetArgPossibilities = listRegisteredFiles,-                       commandArgdefaults = nodefaults,-                       commandAdvancedOptions = [umaskOption],-                       commandBasicOptions =-                           [workingRepoDir, recursive "recurse into subdirectories"]}--removeCmd :: [DarcsFlag] -> [String] -> IO ()-removeCmd opts relargs = do-    when (null relargs) $-        fail "Nothing specified, nothing removed."-    origfiles <- fixSubPaths opts relargs-    when (null origfiles) $-        fail "No valid arguments were given."-    withRepoLock opts $ RepoJob $ \repository -> do-    args <- if Recursive `elem` opts-            then reverse `fmap` expandDirs origfiles-            else return origfiles-    Sealed p <- makeRemovePatch opts repository args-    addToPending repository p---- | makeRemovePatch builds a list of patches to remove the given filepaths.---   This function does not recursively process directories. The 'Recursive'---   flag should be handled by the caller by adding all offspring of a directory---   to the files list.-makeRemovePatch :: (RepoPatch p, ApplyState p ~ Tree)-                => [DarcsFlag] -> Repository p C(r u t)-                -> [SubPath] -> IO (Sealed (FL (PrimOf p) C(u)))-makeRemovePatch opts repository files =-                          do recorded <- expand =<< readRecordedAndPending repository-                             unrecorded <- readUnrecorded repository $ Just files-                             ftf <- filetypeFunction-                             result <- foldM removeOnePath (ftf,recorded,unrecorded, []) $ map (floatPath . fn2fp . sp2fn) files-                             case result of-                                 (_, _, _, patches) -> return $-                                                         unFreeLeft $ foldr (joinGap (+>+)) (emptyGap NilFL) $ reverse patches-    where removeOnePath (ftf, recorded, unrecorded, patches) f = do-            let recorded' = modifyTree recorded f Nothing-                unrecorded' = modifyTree unrecorded f Nothing-            local <- makeRemoveGap opts ftf recorded unrecorded unrecorded' f-            -- we can tell if the remove succeeded by looking if local is-            -- empty. If the remove succeeded, we should pass on updated-            -- recorded and unrecorded that reflect the removal-            return $ case local of-                       Just gap -> (ftf, recorded', unrecorded', gap : patches)-                       _        -> (ftf, recorded, unrecorded, patches)---- | Takes a file path and returns the FL of patches to remove that, wrapped in---   a 'Gap'.---   Returns 'Nothing' in case the path cannot be removed (if it is not tracked,---   or if it's a directory and it's not tracked).---   The three 'Tree' arguments are the recorded state, the unrecorded state---   excluding the removal of this file, and the unrecorded state including the---   removal of this file.-makeRemoveGap :: PrimPatch prim => [DarcsFlag] -> (FilePath -> FileType)-                -> Tree IO -> Tree IO -> Tree IO -> AnchoredPath-                -> IO (Maybe (FreeLeft (FL prim)))-makeRemoveGap opts ftf recorded unrecorded unrecorded' f =-    case (find recorded f, find unrecorded f) of-        (Just (SubTree _), Just (SubTree unrecordedChildren)) -> do-            if not $ null (list unrecordedChildren)-              then skipAndWarn "it is not empty"-              else return $ Just $ freeGap (rmdir f_fp :>: NilFL)-        (Just (File _), Just (File _)) ->-            Just `fmap` treeDiff ftf unrecorded unrecorded'-        (Just (File _), _) ->-            return $ Just $ freeGap (addfile f_fp :>: rmfile f_fp :>: NilFL)-        (Just (SubTree _), _) ->-            return  $ Just $ freeGap (adddir f_fp :>: rmdir f_fp :>: NilFL)-        (_, _) -> skipAndWarn "it is not tracked by darcs"-  where f_fp = anchorPath "" f-        skipAndWarn reason =-            do putWarning opts . text $ "Can't remove " ++ f_fp-                                        ++ " (" ++ reason ++ ")"-               return $ Nothing---rmDescription :: String-rmDescription = "Help newbies find `darcs remove'."--rmHelp :: String-rmHelp =- "The `darcs rm' command does nothing.\n" ++- "\n" ++- "The normal way to remove a file from version control is simply to\n" ++- "delete it from the working tree.  To remove a file from version\n" ++- "control WITHOUT affecting the working tree, see `darcs remove'.\n"--rm :: DarcsCommand-rm = commandStub "rm" rmHelp rmDescription remove--unadd :: DarcsCommand-unadd = commandAlias "unadd" Nothing remove-
− src/Darcs/Commands/Replace.hs 
@@ -1,241 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Replace ( replace, defaultToks ) where--import Prelude hiding ( catch )--import Data.Maybe ( isJust )-import Control.Monad ( unless, filterM )-import Control.Applicative( (<$>) )-import Control.Exception ( catch, IOException )--import Darcs.Commands ( DarcsCommand(..),-                        nodefaults )-import Darcs.Arguments ( DarcsFlag(ForceReplace, Toks), listRegisteredFiles,-                         ignoretimes, umaskOption, tokens, forceReplace,-                         workingRepoDir, fixSubPaths )-import Darcs.Repository ( withRepoLock, RepoJob(..),-                    addToPending,-                    amInHashedRepository,-                    applyToWorking,-                    readUnrecorded, readRecordedAndPending-                  )-import Darcs.Patch ( Patchy, PrimPatch, tokreplace, forceTokReplace, applyToTree )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.FileName( fn2fp )-import Darcs.Patch.Patchy ( Apply )-import Darcs.Witnesses.Ordered ( FL(..), (+>+), concatFL, toFL )-import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..) )-import Darcs.Patch.RegChars ( regChars )-import Data.Char ( isSpace )-import Darcs.RepoPath ( SubPath, toFilePath, sp2fn )-import Darcs.Repository.Prefs ( FileType(TextFile) )-import Darcs.Diff( treeDiff )-import Storage.Hashed.Tree( readBlob, modifyTree , findFile, TreeItem(..), Tree, makeBlobBS )-import Storage.Hashed.AnchoredPath( AnchoredPath, floatPath )--import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString as BS-#include "impossible.h"-#include "gadts.h"--replaceDescription :: String-replaceDescription = "Substitute one word for another."--replaceHelp :: String-replaceHelp =- "In addition to line-based patches, Darcs supports a limited form of\n" ++- "lexical substitution.  Files are treated as sequences of words, and\n" ++- "each occurrence of the old word is replaced by the new word.\n" ++- "This is intended to provide a clean way to rename a function or\n" ++- "variable.  Such renamings typically affect lines all through the\n" ++- "source code, so a traditional line-based patch would be very likely to\n" ++- "conflict with other branches, requiring manual merging.\n" ++- "\n" ++- "Files are tokenized according to one simple rule: words are strings of\n" ++- "valid token characters, and everything between them (punctuation and\n" ++- -- FIXME: this heuristic is ham-fisted and silly.  Can we drop it?- "whitespace) is discarded.  By default, valid token characters are\n" ++- "letters, numbers and the underscore (i.e. [A-Za-z0-9_]).  However if\n" ++- "the old and/or new token contains either a hyphen or period, BOTH\n" ++- "hyphen and period are treated as valid (i.e. [A-Za-z0-9_.-]).\n" ++- "\n" ++- "The set of valid characters can be customized using the --token-chars\n" ++- "option.  The argument must be surrounded by square brackets.  If a\n" ++- "hyphen occurs between two characters in the set, it is treated as a\n" ++- "set range.  For example, in most locales [A-Z] denotes all uppercase\n" ++- "letters.  If the first character is a caret, valid tokens are taken to\n" ++- "be the complement of the remaining characters.  For example, [^:\\n]\n" ++- "could be used to match fields in the passwd(5), where records and\n" ++- "fields are separated by newlines and colons respectively.\n" ++- "\n" ++- "If you choose to use --token-chars, you are STRONGLY encouraged to do\n" ++- "so consistently.  The consequences of using multiple replace patches\n" ++- "with different --token-chars arguments on the same file are not well\n" ++- "tested nor well understood.\n" ++- "\n" ++- "By default Darcs will refuse to perform a replacement if the new token\n" ++- "is already in use, because the replacements would be not be\n" ++- "distinguishable from the existing tokens.  This behaviour can be\n" ++- "overridden by supplying the --force option, but an attempt to `darcs\n" ++- "rollback' the resulting patch will affect these existing tokens.\n" ++- "\n" ++- "Limitations:\n" ++- "\n" ++- "The tokenizer treats files as byte strings, so it is not possible for\n" ++- "--token-chars to include multi-byte characters, such as the non-ASCII\n" ++- "parts of UTF-8.  Similarly, trying to replace a `high-bit' character\n" ++- "from a unibyte encoding will also result in replacement of the same\n" ++- "byte in files with different encodings.  For example, an acute a from\n" ++- "ISO 8859-1 will also match an alpha from ISO 8859-7.\n" ++- "\n" ++- "Due to limitations in the patch file format, --token-chars arguments\n" ++- "cannot contain literal whitespace.  For example, [^ \\n\\t] cannot be\n" ++- "used to declare all characters except the space, tab and newline as\n" ++- "valid within a word, because it contains a literal space.\n" ++- "\n" ++- "Unlike POSIX regex(7) bracket expressions, character classes (such as\n" ++- "[[:alnum:]]) are NOT supported by --token-chars, and will be silently\n" ++- "treated as a simple set of characters.\n"--replace :: DarcsCommand-replace = DarcsCommand {commandProgramName = "darcs",-                        commandName = "replace",-                        commandHelp = replaceHelp,-                        commandDescription = replaceDescription,-                        commandExtraArgs = -1,-                        commandExtraArgHelp = ["<OLD>","<NEW>",-                                                  "<FILE> ..."],-                        commandCommand = replaceCmd,-                        commandPrereq = amInHashedRepository,-                        commandGetArgPossibilities = listRegisteredFiles,-                        commandArgdefaults = nodefaults,-                        commandAdvancedOptions = [ignoretimes, umaskOption],-                        commandBasicOptions =-                            [tokens, forceReplace, workingRepoDir]}--replaceCmd :: [DarcsFlag] -> [String] -> IO ()-replaceCmd opts (old:new:relfs) = withRepoLock opts $ RepoJob $ \repository -> do-  fs <- fixSubPaths opts relfs-  toks <- chooseToks opts old new-  let checkToken tok =-        unless (isTok toks tok) $ fail $ "'"++tok++"' is not a valid token!"-  checkToken old-  checkToken new-  work <- readUnrecorded repository Nothing-  cur <- readRecordedAndPending repository-  files <- filterM (exists work) fs-  Sealed pswork <- mapSeal concatFL . toFL <$> mapM (repl toks cur work) files-  addToPending repository pswork-  _ <- applyToWorking repository opts pswork `catch` \(e :: IOException) ->-      fail $ "Can't do replace on working!\n"-          ++ "Perhaps one of the files already contains '"++ new++"'?\n"-          ++ show e-  return ()-  where ftf _ = TextFile-        skipmsg f = "Skipping file '" ++ toFilePath f ++ "' which isn't in the repository."-        exists tree file = if isJust $ findFile tree (floatSubPath file)-                              then return True-                              else do putStrLn $ skipmsg file-                                      return False-        repl :: forall prim . (Patchy prim, PrimPatch prim, ApplyState prim ~ Tree)-             => String -> Tree IO -> Tree IO -> SubPath -> IO (FreeLeft (FL prim))-        repl toks cur work f =-          do work_replaced <- maybeApplyToTree replace_patch work-             cur_replaced <- maybeApplyToTree replace_patch cur-             if ForceReplace `elem` opts || isJust work_replaced || isJust cur_replaced-                then get_force_replace f toks work-                else do putStrLn $ "Skipping file '"++f_fp++"'"-                        putStrLn $ "Perhaps the recorded version of this " ++-                                   "file already contains '" ++new++"'?"-                        putStrLn $ "Use the --force option to override."-                        return (emptyGap NilFL)-          where f_fp = toFilePath f-                replace_patch :: prim C(x y)-                replace_patch = tokreplace f_fp toks old new--        get_force_replace :: PrimPatch prim => SubPath -> String -> Tree IO -> IO (FreeLeft (FL prim))-        get_force_replace f toks tree = do-            let path = floatSubPath f-            content <- readBlob $ fromJust $ findFile tree path-            let newcontent = forceTokReplace toks new old (BS.concat $ BL.toChunks content)-                tree' = modifyTree tree path (File . makeBlobBS <$> newcontent)-            case newcontent of-              Nothing -> bug "weird forcing bug in replace."-              Just _ -> do pfix <- treeDiff ftf tree tree'-                           putStrLn $ "Don't be surprised!"-                           putStrLn $ "I've changed all instances of '" ++ new ++ "' to '" ++ old ++ "' first"-                           putStrLn $ "so that darcs replace can token-replace them back into '" ++ new ++ "' again."-                           return $ joinGap (+>+) pfix (freeGap (tokreplace f_fp toks old new :>: NilFL))-            where f_fp = toFilePath f--replaceCmd _ _ = fail "Usage: darcs replace OLD NEW [FILES]"--floatSubPath :: SubPath -> AnchoredPath-floatSubPath = floatPath . fn2fp . sp2fn--maybeApplyToTree :: (Apply p, ApplyState p ~ Tree) => p C(x y) -> Tree IO -> IO (Maybe (Tree IO))-maybeApplyToTree patch tree = catch (Just `fmap` applyToTree patch tree)-                                    (\(_ :: IOException) -> return Nothing)--defaultToks :: String-defaultToks = "A-Za-z_0-9"-filenameToks :: String-filenameToks = "A-Za-z_0-9\\-\\."---- | Given a set of characters and a string, returns true iff the--- string contains only characters from the set.  A set beginning with--- a caret (@^@) is treated as a complementary set.-isTok :: String -> String -> Bool-isTok _ "" = False-isTok toks s = all (regChars toks) s---- | This function checks for @--token-chars@ on the command-line.  If--- found, it validates the argument and returns it, without the--- surrounding square brackets.  Otherwise, it returns either--- 'defaultToks' or 'filenameToks' as explained in 'replaceHelp'.------ Note: Limitations in the current replace patch file format prevents--- tokens and token-char specifiers from containing any whitespace.-chooseToks :: [DarcsFlag] -> String -> String -> IO String-chooseToks (Toks t:_) a b-    | length t <= 2 =-        bad_token_spec $ "It must contain more than 2 characters, because " ++-                         "it should be enclosed in square brackets"-    | head t /= '[' || last t /= ']' =-        bad_token_spec "It should be enclosed in square brackets"-    | '^' == head tok && length tok == 1 =-        bad_token_spec "Must be at least one character in the complementary set"-    | any isSpace t =-        bad_token_spec "Space is not allowed in the spec"-    | any isSpace a = bad_token_spec $ spacey_token a-    | any isSpace b = bad_token_spec $ spacey_token b-    | not (isTok tok a) = bad_token_spec $ not_a_token a-    | not (isTok tok b) = bad_token_spec $ not_a_token b-    | otherwise          = return tok-    where tok = init $ tail t :: String-          bad_token_spec msg = fail $ "Bad token spec: '"++ t ++"' ("++ msg ++")"-          spacey_token x = x ++ " must not contain any space"-          not_a_token x = x ++ " is not a token, according to your spec"-chooseToks (_:fs) a b = chooseToks fs a b-chooseToks [] a b = if isTok defaultToks a && isTok defaultToks b-                     then return defaultToks-                     else return filenameToks-
− src/Darcs/Commands/Revert.hs 
@@ -1,123 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.Revert ( revert ) where--import Prelude hiding ( catch )--import System.Exit ( ExitCode(..), exitWith )-import Control.Applicative ( (<$>) )-import Control.Exception ( catch, IOException )-import Control.Monad ( when )-import Data.List ( sort )--import English (englishNum, This(..), Noun(..))-import Darcs.Flags( diffingOpts )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Commands.Util ( announceFiles )-import Darcs.Arguments ( DarcsFlag( All, Debug ),-                        ignoretimes, workingRepoDir,-                        allInteractive,-                        fixSubPaths,-                        listRegisteredFiles, umaskOption, unified-                      )-import Darcs.Utils ( askUser )-import Darcs.RepoPath ( toFilePath )-import Darcs.Repository ( withRepoLock, RepoJob(..), withGutsOf,-                    addToPending,-                    applyToWorking,-                    amInHashedRepository, readRecorded,-                    unrecordedChanges-                  )-import Darcs.Patch ( invert, effectOnFilePaths, commute )-import Darcs.Patch.Split ( reversePrimSplitter )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), lengthFL, nullFL, (+>+) )-import Darcs.SelectChanges ( selectChanges, WhichChanges(Last), selectionContextPrim, runSelection )-import Darcs.Patch.TouchesFiles ( chooseTouching )-import Darcs.Commands.Unrevert ( writeUnrevert )-import Darcs.Witnesses.Sealed ( Sealed(..) )--#include "gadts.h"--revertDescription :: String-revertDescription = "Discard unrecorded changes."--revertHelp :: String-revertHelp =- "The `darcs revert' command discards unrecorded changes the working\n" ++- "tree.  As with `darcs record', you will be asked which hunks (changes)\n" ++- "to revert.  The --all switch can be used to avoid such prompting. If\n" ++- "files or directories are specified, other parts of the working tree\n" ++- "are not reverted.\n" ++- "\n" ++- "In you accidentally reverted something you wanted to keep (for\n" ++- "example, typing `darcs rev -a' instead of `darcs rec -a'), you can\n" ++- "immediately run `darcs unrevert' to restore it.  This is only\n" ++- "guaranteed to work if the repository has not changed since `darcs\n" ++- "revert' ran.\n"--revert :: DarcsCommand-revert = DarcsCommand {commandProgramName = "darcs",-                       commandName = "revert",-                       commandHelp = revertHelp,-                       commandDescription = revertDescription,-                       commandExtraArgs = -1,-                       commandExtraArgHelp = ["[FILE or DIRECTORY]..."],-                       commandCommand = revertCmd,-                       commandPrereq = amInHashedRepository,-                       commandGetArgPossibilities = listRegisteredFiles,-                       commandArgdefaults = nodefaults,-                       commandAdvancedOptions = [ignoretimes, umaskOption],-                       commandBasicOptions = [allInteractive, unified,-                                               workingRepoDir]}--revertCmd :: [DarcsFlag] -> [String] -> IO ()-revertCmd opts args = withRepoLock opts $ RepoJob $ \repository -> do-  files <- if null args then return Nothing-    else Just . sort <$> fixSubPaths opts args-  announceFiles files "Reverting changes in"-  changes <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository files-  let pre_changed_files = effectOnFilePaths (invert changes) . map toFilePath <$> files-  rec <- readRecorded repository-  Sealed touching_changes <- return (chooseTouching pre_changed_files changes)-  (case touching_changes of-    NilFL -> putStrLn "There are no changes to revert!"-    _ -> do-      let context = selectionContextPrim "revert" opts (Just reversePrimSplitter) pre_changed_files (Just rec)-      (norevert:>p) <- runSelection (selectChanges Last changes) context-      if nullFL p-       then putStrLn $ "If you don't want to revert after all," ++-                        " that's fine with me!"-       else do-             let theseChanges = englishNum (lengthFL p) . This . Noun $ "change"-             yorn <- if All `elem` opts-                     then return "y"-                     else askUser $ "Do you really want to revert " ++ theseChanges "? "-             case yorn of ('y':_) -> return ()-                          _ -> exitWith $ ExitSuccess-             withGutsOf repository $ do-                 addToPending repository $ invert p-                 when (Debug `elem` opts) $ putStrLn "About to write the unrevert file."-                 case commute (norevert:>p) of-                   Just (p':>_) -> writeUnrevert repository p' rec NilFL-                   Nothing -> writeUnrevert repository (norevert+>+p) rec NilFL-                 when (Debug `elem` opts) $ putStrLn "About to apply to the working directory."-                 _ <- applyToWorking repository opts (invert p) `catch` \(e :: IOException) ->-                     fail ("Unable to apply inverse patch!" ++ show e)-                 return ()) :: IO ()-  putStrLn "Finished reverting."-
− src/Darcs/Commands/Rollback.hs 
@@ -1,193 +0,0 @@---  Copyright (C) 2002-2004,2007 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Rollback ( rollback ) where--import Prelude hiding ( catch )--import Control.Applicative ( (<$>) )-import Control.Exception ( catch, IOException )-import Control.Monad ( when )-import System.Exit ( exitWith, ExitCode(..) )-import Data.List ( sort )-import Data.Maybe ( isJust )-import System.Directory ( removeFile )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(MarkConflicts), fixSubPaths, getAuthor,-                         setEnvDarcsPatches,-                         workingRepoDir, nocompress,-                         author, patchnameOption, askLongComment,-                         leaveTestDir, notest, listRegisteredFiles,-                         matchSeveralOrLast, allInteractive, umaskOption,-                         recordRollback-                       )-import Darcs.RepoPath ( toFilePath )-import Darcs.Repository ( Repository, amInHashedRepository, withRepoLock, RepoJob(..),-                          applyToWorking,-                          readRepo,-                          tentativelyMergePatches, withGutsOf,-                          testTentative,-                          finalizeRepositoryChanges, invalidateIndex,-                          tentativelyAddToPending, considerMergeToWorking-                        )-import Darcs.Patch ( RepoPatch, summary, invert, namepatch, effect, fromPrims,-                     sortCoalesceFL, canonize, anonymous, PrimOf )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Flags ( isInteractive, rollbackInWorkingDir )-import Darcs.Patch.Set ( PatchSet(..), newset2FL )-import Darcs.Patch.Split ( reversePrimSplitter )-import Darcs.Witnesses.Ordered-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )-import Darcs.Lock ( worldReadableTemp )-import Darcs.Match ( firstMatch )-import Darcs.SelectChanges ( selectChanges,-                             WhichChanges(..),-                             selectionContext, selectionContextPrim,-                             runSelection-                           )-import Darcs.Commands.Record ( getLog )-import Darcs.Commands.Unrecord ( getLastPatches )-import Darcs.Commands.Util ( announceFiles, filterExistingFiles )-import Darcs.Utils ( clarifyErrors, PromptConfig(..), promptChar )-import Printer ( renderString )-import Progress ( debugMessage )-import Darcs.Witnesses.Sealed ( Sealed(..) )-import IsoDate ( getIsoDateTime )-import Storage.Hashed.Tree( Tree )-#include "impossible.h"-#include "gadts.h"--rollbackDescription :: String-rollbackDescription =- "Record a new patch reversing some recorded changes."--rollbackHelp :: String-rollbackHelp =- "Rollback is used to undo the effects of one or more patches without actually\n"++- "deleting them.  Instead, it creates a new patch reversing selected portions.\n"++- "of those changes. Unlike obliterate and unrecord (which accomplish a similar\n"++- "goal) rollback is perfectly safe, since it leaves in the repository a record\n"++- "of its changes.\n"--rollback :: DarcsCommand-rollback = DarcsCommand {commandProgramName = "darcs",-                         commandName = "rollback",-                         commandHelp = rollbackHelp,-                         commandDescription = rollbackDescription,-                         commandExtraArgs = -1,-                         commandExtraArgHelp = ["[FILE or DIRECTORY]..."],-                         commandCommand = rollbackCmd,-                         commandPrereq = amInHashedRepository,-                         commandGetArgPossibilities = listRegisteredFiles,-                         commandArgdefaults = nodefaults,-                         commandAdvancedOptions = [nocompress,umaskOption],-                         commandBasicOptions = [matchSeveralOrLast,-                                                  allInteractive,-                                                  author, patchnameOption, askLongComment,-                                                  notest, leaveTestDir,-                                                  workingRepoDir, recordRollback]}--rollbackCmd :: [DarcsFlag] -> [String] -> IO ()-rollbackCmd opts args = withRepoLock opts $ RepoJob $ \repository -> do-  files <- if null args then return Nothing-    else Just . sort <$> fixSubPaths opts args-  when (files == Just []) $ fail "No valid arguments were given."-  let files_fp = map toFilePath <$> files-  announceFiles files "Recording changes in"-  existing_files <- maybe (return Nothing)-    (fmap Just . filterExistingFiles repository) files-  when (existing_files == Just []) $-       fail "None of the files you specified exist!"-  allpatches <- readRepo repository-  (_ :> patches) <- return $ if firstMatch opts-                             then getLastPatches opts allpatches-                             else (PatchSet NilRL NilRL):> (newset2FL allpatches)-  let patches_context = selectionContext "rollback" opts Nothing files_fp-  (_ :> ps) <- runSelection (selectChanges LastReversed patches) patches_context-  when (nullFL ps) $ do putStrLn "No patches selected!"-                        exitWith ExitSuccess-  setEnvDarcsPatches ps-  let hunks_context = selectionContextPrim "rollback" opts (Just reversePrimSplitter) files_fp Nothing-      hunks = (concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect ps)-  runSelection (selectChanges Last hunks) hunks_context >>=-               if (rollbackInWorkingDir opts)-               then (undoItNow opts repository)-               else (rollItBackNow opts repository ps)--rollItBackNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree) =>-                [DarcsFlag] -> Repository p C(r u t) ->  FL (PatchInfoAnd p) C(x y)-                            -> (q :> FL (PrimOf p)) C(a t) -> IO ()-rollItBackNow opts repository  ps (_ :> ps'') =-         do when (nullFL ps'') $ do putStrLn "No changes selected!"-                                    exitWith ExitSuccess-            let make_log = worldReadableTemp "darcs-rollback"-                newlog = Just ("", "":"rolling back:":"":lines (renderString $ summary ps ))-            --tentativelyRemovePatches repository opts (mapFL_FL hopefully ps)-            (name, my_log, logf) <- getLog opts newlog make_log $ invert ps''-            date <- getIsoDateTime-            my_author <- getAuthor opts-            rbp <- n2pia `fmap` namepatch date name my_author my_log-                                          (fromPrims $ invert ps'')-            debugMessage "Adding rollback patch to repository."-            Sealed pw <--                tentativelyMergePatches repository "rollback"-                                            (MarkConflicts : opts) NilFL-                                            (rbp :>: NilFL)-            debugMessage "Finalizing rollback changes..."-            invalidateIndex repository-            rc <- testTentative repository-            when (rc /= ExitSuccess) $ do-                when (not $ isInteractive opts) $ exitWith rc-                putStrLn $ "Looks like you have a bad patch: '"++name++"'"-                let prompt = "Shall I rollback anyway?"-                yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])-                case yn of-                  'y' -> return ()-                  _ -> exitWith rc-            withGutsOf repository $ do-              finalizeRepositoryChanges repository-              debugMessage "About to apply rolled-back changes to working directory."-              _ <- revertable $ applyToWorking repository opts pw-              return ()-            when (isJust logf) $ removeFile (fromJust logf)-            putStrLn "Finished rolling back."-          where revertable x = x `clarifyErrors` unlines-                  ["Error applying patch to the working directory.","",-                   "This may have left your working directory an inconsistent",-                   "but recoverable state. If you had no un-recorded changes",-                   "by using 'darcs revert' you should be able to make your",-                   "working directory consistent again."]--undoItNow :: (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)-          => [DarcsFlag] -> Repository p C(r u t)-          -> (q :> FL (PrimOf p)) C(a t) -> IO ()-undoItNow opts repo (_ :> prims) =-    do-      rbp <- n2pia `fmap` anonymous (fromPrims $ invert prims)-      Sealed pw <- considerMergeToWorking repo "rollback" (MarkConflicts: opts)-                                                     NilFL (rbp :>: NilFL)-      tentativelyAddToPending repo opts pw-      withGutsOf repo $ do-        finalizeRepositoryChanges repo-        _ <- applyToWorking repo opts pw `catch` \(e :: IOException) ->-            fail ("error applying rolled back patch to working directory\n"-                  ++ show e)-        debugMessage "Finished applying unrecorded rollback patch"-
− src/Darcs/Commands/Send.hs 
@@ -1,411 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, TypeOperators #-}--module Darcs.Commands.Send ( send ) where--import Prelude hiding ( catch )--import System.Exit ( exitWith, ExitCode( ExitSuccess ) )-#ifndef HAVE_MAPI-import System.Exit ( ExitCode( ExitFailure ) )-#endif-import System.IO.Error ( ioeGetErrorString )-import System.IO ( hClose )-import Control.Exception ( catch, IOException )-import Control.Monad ( when, unless, forM_ )-import Storage.Hashed.Tree ( Tree )-import Data.List ( intercalate, isPrefixOf, stripPrefix )-import Data.Maybe ( isNothing, fromMaybe )--import Darcs.Commands ( DarcsCommand(..), putInfo, putVerbose )-import Darcs.Arguments ( DarcsFlag( EditDescription, LogFile,-                                    Target, Context,-                                    DryRun, Quiet-                                  ),-                         fixUrl, setEnvDarcsPatches,-                         getCc, getAuthor, workingRepoDir,-                         editDescription, logfile, rmlogfile,-                         sign, getSubject, depsSel, getInReplyTo,-                         matchSeveral, setDefault, outputAutoName,-                         output, ccSend, subject, target, author, sendmailCmd,-                         inReplyTo, remoteRepo, networkOptions,-                         allInteractive, getSendmailCmd,-                         printDryRunMessageAndExit,-                         summary, allowUnrelatedRepos,-                         fromOpt, dryRun, sendToContext, getOutput,-                         changesReverse, charset, getCharset,-                       )-import Darcs.Flags ( willRemoveLogFile, doReverse )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc )-import Darcs.Repository ( PatchSet, Repository,-                          amInHashedRepository, identifyRepositoryFor, withRepoReadLock, RepoJob(..),-                          readRepo, readRecorded, prefsUrl, checkUnrelatedRepos )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch ( RepoPatch, description, applyToTree, invert )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:>)(..),-                       mapFL, mapFL_FL, lengthFL, nullFL )-import Darcs.Patch.Bundle ( makeBundleN, scanContext, patchFilename )-import Darcs.Repository.Prefs ( defaultrepo, setDefaultrepo, getPreflist )-import Darcs.External ( signString, sendEmailDoc, fetchFilePS, Cachable(..), generateEmail-#ifndef HAVE_MAPI-                      , haveSendmail-#endif-                      )-import ByteStringUtils ( mmapFilePS, isAscii )-import qualified Data.ByteString.Char8 as BC (unpack)-import Darcs.Lock ( withOpenTemp, writeDocBinFile, readDocBinFile, worldReadableTemp, removeFileMayNotExist )-import Darcs.SelectChanges ( selectChanges, WhichChanges(..), selectionContext, runSelection )-import Darcs.Patch.Depends ( findCommonWithThem )-import Darcs.Utils ( askUser, promptYorn, catchall, editFile, formatPath, getSystemEncoding, isUTF8Locale )-import Data.Text.Encoding       ( decodeUtf8' )-import Progress ( debugMessage )-import Darcs.Email ( makeEmail )-import Printer ( Doc, vsep, vcat, text, ($$), (<+>), (<>), putDoc, renderPS )-import Darcs.RepoPath ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd,-                        getCurrentDirectory, useAbsoluteOrStd )-import URL.HTTP ( postUrl )-#include "impossible.h"--#include "gadts.h"--sendDescription :: String-sendDescription =- "Send by email a bundle of one or more patches."--sendHelp :: String-sendHelp =- "Send is used to prepare a bundle of patches that can be applied to a target\n"++- "repository.  Send accepts the URL of the repository as an argument.  When\n"++- "called without an argument, send will use the most recent repository that\n"++- "was either pushed to, pulled from or sent to.  By default, the patch bundle\n"++- "is sent by email, although you may save it to a file.\n"--send :: DarcsCommand-send = DarcsCommand {commandProgramName = "darcs",-                     commandName = "send",-                     commandHelp = sendHelp,-                     commandDescription = sendDescription,-                     commandExtraArgs = 1,-                     commandExtraArgHelp = ["[REPOSITORY]"],-                     commandCommand = sendCmd,-                     commandPrereq = amInHashedRepository,-                     commandGetArgPossibilities = getPreflist "repos",-                     commandArgdefaults = defaultrepo,-                     commandAdvancedOptions = [logfile, rmlogfile,-                                                 remoteRepo,-                                                 sendToContext, changesReverse] ++-                                                networkOptions,-                     commandBasicOptions = [matchSeveral, depsSel,-                                              allInteractive,-                                              fromOpt, author,-                                              target,ccSend,subject, inReplyTo, charset,-                                              output,outputAutoName,sign]-                                              ++dryRun++[summary,-                                              editDescription,-                                              setDefault False,-                                              workingRepoDir,-                                              sendmailCmd,-                                              allowUnrelatedRepos]}--sendCmd :: [DarcsFlag] -> [String] -> IO ()-sendCmd input_opts [""] = sendCmd input_opts []-sendCmd input_opts [unfixedrepodir] = withRepoReadLock input_opts $ RepoJob $-  \(repository :: Repository p C(r u r)) -> do-  context_ps <- the_context input_opts-  case context_ps of-    Just them -> do-        wtds <- decideOnBehavior input_opts (Nothing :: Maybe (Repository p C(r u r)))-        sendToThem repository input_opts wtds "CONTEXT" them-    Nothing -> do-        repodir <- fixUrl input_opts unfixedrepodir-        -- Test to make sure we aren't trying to push to the current repo-        here <- getCurrentDirectory-        when (repodir == toFilePath here) $-           fail "Can't send to current repository! Did you mean send --context?"-        old_default <- getPreflist "defaultrepo"-        when (old_default == [repodir] && Quiet `notElem` input_opts) $-             putStrLn $ "Creating patch to "++formatPath repodir++"..."-        repo <- identifyRepositoryFor repository repodir-        them <- readRepo repo-        setDefaultrepo repodir input_opts-        wtds <- decideOnBehavior input_opts (Just repo)-        sendToThem repository input_opts wtds repodir them-    where the_context [] = return Nothing-          the_context (Context foo:_)-              = (Just . scanContext )`fmap` mmapFilePS (toFilePath foo)-          the_context (_:fs) = the_context fs-sendCmd _ _ = impossible--sendToThem :: (RepoPatch p, ApplyState p ~ Tree)-           => Repository p C(r u t) -> [DarcsFlag] -> [WhatToDo] -> String-           -> PatchSet p C(Origin x) -> IO ()-sendToThem repo opts wtds their_name them = do-#ifndef HAVE_MAPI-  -- Check if the user has sendmail or provided a --sendmail-cmd-  -- (unless -o/-O or --dry-run is used)-  sendmail <- haveSendmail-  sm_cmd <- getSendmailCmd opts-  when (isNothing (getOutput opts "") && DryRun `notElem` opts &&-        not sendmail && sm_cmd == "") $ do-      putInfo opts $ text "No working sendmail instance on your machine!"-      exitWith $ ExitFailure 1-#endif-  us <- readRepo repo-  common :> us' <- return $ findCommonWithThem us them-  checkUnrelatedRepos opts us them-  (case us' of-      NilFL -> do putInfo opts $ text "No recorded local changes to send!"-                  exitWith ExitSuccess-      _ -> putVerbose opts $ text "We have the following patches to send:"-                     $$ vcat (mapFL description us')) :: IO ()-  pristine <- readRecorded repo-  let context = selectionContext "send" opts Nothing Nothing-      selector = if doReverse opts-                 then selectChanges FirstReversed-                 else selectChanges First-  (to_be_sent :> _) <- runSelection (selector us') context-  printDryRunMessageAndExit "send" opts to_be_sent-  when (nullFL to_be_sent) $ do-      putInfo opts $ text "You don't want to send any patches, and that's fine with me!"-      exitWith ExitSuccess-  setEnvDarcsPatches to_be_sent-  bundle <- prepareBundle opts common pristine (us':\/:to_be_sent)-  let make_fname (tb:>:_) = patchFilename $ patchDesc tb-      make_fname _ = impossible-      fname = make_fname to_be_sent-      outname = getOutput opts fname-  case outname of-    Just fname' -> writeBundleToFile opts to_be_sent bundle fname' wtds their_name-    Nothing -> sendBundle opts to_be_sent bundle fname wtds their_name--prepareBundle :: forall p C(x y z). (RepoPatch p, ApplyState p ~ Tree)-              => [DarcsFlag] -> PatchSet p C(Origin z)-              -> Tree IO -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(x y)-              -> IO Doc-prepareBundle opts common pristine (us' :\/: to_be_sent) = do-  pristine' <- applyToTree (invert $ mapFL_FL hopefully us') pristine-  unsig_bundle <- makeBundleN (Just pristine') (unsafeCoerceP common) (mapFL_FL hopefully to_be_sent)-  signString opts unsig_bundle--sendBundle :: forall p C(x y) . (RepoPatch p, ApplyState p ~ Tree)-           => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y)-             -> Doc -> String -> [WhatToDo] -> String -> IO ()-sendBundle opts to_be_sent bundle fname wtds their_name=-         let-           auto_subject :: forall pp C(a b) . FL (PatchInfoAnd pp) C(a b) -> String-           auto_subject (p:>:NilFL)  = "darcs patch: " ++ trim (patchDesc p) 57-           auto_subject (p:>:ps) = "darcs patch: " ++ trim (patchDesc p) 43 ++-                            " (and " ++ show (lengthFL ps) ++ " more)"-           auto_subject _ = error "Tried to get a name from empty patch list."-           trim st n = if length st <= n then st-                       else take (n-3) st ++ "..."-           in do-           thetargets <- getTargets wtds-           from <- getAuthor opts-           let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts-           (mailcontents, mailfile, mailcharset) <- getDescription opts their_name to_be_sent--           let warnMailBody = let msg = "Email body left in " in-                              case mailfile of-                                  Just mf -> putStrLn $ msg++mf++"."-                                  Nothing -> return ()--               warnCharset msg = do-                 confirmed <- promptYorn $ "Warning: " ++ msg ++ "  Send anyway?"-                 unless confirmed $ do-                    putStrLn "Aborted.  You can specify charset with the --charset option."-                    warnMailBody-                    exitWith ExitSuccess--           thecharset <- case getCharset opts of-                              -- Always trust provided charset-                              providedCset@(Just _) -> return providedCset-                              Nothing ->-                                case mailcharset of-                                Nothing -> do-                                  warnCharset "darcs could not guess the charset of your mail."-                                  return mailcharset-                                Just "utf-8" -> do-                                  -- Check the locale encoding for consistency-                                  encoding <- getSystemEncoding-                                  debugMessage $ "Current locale encoding: " ++ encoding-                                  unless (isUTF8Locale encoding) $-                                    warnCharset "your mail is valid UTF-8 but your locale differs."-                                  return mailcharset-                                -- Trust other cases (us-ascii)-                                Just _ -> return mailcharset--           let body = makeEmail their_name-                        (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) . getInReplyTo $ opts)-                        (Just mailcontents)-                        thecharset-                        bundle-                        (Just fname)-               contentAndBundle = Just (mailcontents, bundle)--               sendmail = do-                 sm_cmd <- getSendmailCmd opts-                 let to = generateEmailToString thetargets-                 sendEmailDoc from to thesubject (getCc opts)-                               sm_cmd contentAndBundle body >>-                  (putInfo opts . text $ ("Successfully sent patch bundle to: "-                            ++ to-                            ++ ccs (getCc opts) ++"."))-                 `catch` \e -> do warnMailBody-                                  fail $ ioeGetErrorString e-               ccs [] = []-               ccs cs  = " and cc'ed " ++ cs--           when (null [ p | Post p <- thetargets]) sendmail-           nbody <- withOpenTemp $ \ (fh,fn) -> do-               let to = generateEmailToString thetargets-               generateEmail fh from to thesubject (getCc opts) body-               hClose fh-               mmapFilePS fn-           forM_ [ p | Post p <- thetargets]-             (\url -> do-                putInfo opts . text $ "Posting patch to " ++ url-                postUrl url (BC.unpack nbody) "message/rfc822")-             `catch` (\(_ :: IOException) -> sendmail)-           cleanup opts mailfile--generateEmailToString :: [WhatToDo] -> String-generateEmailToString = intercalate " , " . filter (/= "") . map extractEmail-  where-    extractEmail (SendMail t) = t-    extractEmail _ = ""--cleanup :: (FilePathLike t) => [DarcsFlag] -> Maybe t -> IO ()-cleanup opts (Just mailfile) = when (isNothing (getFileopt opts) || willRemoveLogFile opts) $-                                      removeFileMayNotExist mailfile-cleanup _ Nothing = return ()--writeBundleToFile :: forall p C(x y) . (RepoPatch p, ApplyState p ~ Tree)-                  => [DarcsFlag] -> FL (PatchInfoAnd p) C(x y) -> Doc ->-                    AbsolutePathOrStd -> [WhatToDo] -> String -> IO ()-writeBundleToFile opts to_be_sent bundle fname wtds their_name =-    do (d,f,_) <- getDescription opts their_name to_be_sent-       let putabs a = do writeDocBinFile a (d $$ bundle)-                         putStrLn $ "Wrote patch to " ++ toFilePath a ++ "."-           putstd = putDoc (d $$ bundle)-       useAbsoluteOrStd putabs putstd fname-       let to = generateEmailToString wtds-       unless (null to) $-           putInfo opts . text $ "The usual recipent for this bundle is: " ++ to-       cleanup opts f--data WhatToDo-    = Post String        -- ^ POST the patch via HTTP-    | SendMail String    -- ^ send patch via email--decideOnBehavior :: RepoPatch p => [DarcsFlag] -> Maybe (Repository p C(r u t)) -> IO [WhatToDo]-decideOnBehavior opts remote_repo =-    case the_targets of-    [] -> do wtds <- case remote_repo of-                     Nothing -> return []-                     Just r -> check_post r-             unless (null wtds) $ announce_recipients wtds-             return wtds-    ts -> do announce_recipients ts-             return ts-    where the_targets = collectTargets opts-#ifdef HAVE_HTTP-          -- the ifdef above is to so that darcs only checks the remote-          -- _darcs/post if we have an implementation of postUrl.  See-          -- our HTTP module for more details-          check_post the_remote_repo =-                       do p <- ((readPost . BC.unpack) `fmap`-                                fetchFilePS (prefsUrl the_remote_repo++"/post")-                                (MaxAge 600)) `catchall` return []-                          emails <- who_to_email the_remote_repo-                          return (p++emails)-          readPost = map parseLine . lines where-              parseLine t = maybe (Post t) SendMail $ stripPrefix "mailto:" t-#else-          check_post = who_to_email-#endif-          who_to_email the_remote_repo =-              do email <- (BC.unpack `fmap`-                           fetchFilePS (prefsUrl the_remote_repo++"/email")-                                       (MaxAge 600))-                          `catchall` return ""-                 if '@' `elem` email then return . map SendMail $ lines email-                                     else return []-          announce_recipients emails =-            let pn (SendMail s) = s-                pn (Post p) = p-            in if DryRun `elem` opts-            then putInfo opts . text $ "Patch bundle would be sent to: "++unwords (map pn emails)-            else when (null the_targets && isNothing (getOutput opts "")) $-                 putInfo opts . text $ "Patch bundle will be sent to: "++unwords (map pn emails)--getTargets :: [WhatToDo] -> IO [WhatToDo]-getTargets [] = fmap ((:[]) . SendMail) $ askUser "What is the target email address? "-getTargets wtds = return wtds--collectTargets :: [DarcsFlag] -> [WhatToDo]-collectTargets flags = [ f t | Target t <- flags ] where-    f url | "http:" `isPrefixOf` url = Post url-    f em = SendMail em--getDescription :: (RepoPatch p, ApplyState p ~ Tree)-               => [DarcsFlag] -> String -> FL (PatchInfoAnd p) C(x y) -> IO (Doc, Maybe String, Maybe String)-getDescription opts their_name patches =-    case get_filename of-        Just f -> do file <- f-                     when (EditDescription `elem` opts) $ do-                       when (isNothing $ getFileopt opts) $-                            writeDocBinFile file patchdesc-                       debugMessage $ "About to edit file " ++ file-                       (_, changed) <- editFile file-                       unless changed $ do-                         confirmed <- promptYorn "File content did not change. Continue anyway?"-                         unless confirmed $ do putStrLn "Aborted."-                                               exitWith ExitSuccess-                       return ()-                     doc <- readDocBinFile file-                     return (doc, Just file, tryGetCharset doc)-        Nothing -> return (patchdesc, Nothing, tryGetCharset patchdesc)-    where patchdesc = text (if lengthFL patches == 1-                               then "1 patch"-                               else show (lengthFL patches) ++ " patches")-                      <+> text "for repository" <+> text their_name <> text ":"-                      $$ text ""-                      $$ vsep (mapFL description patches)-          get_filename = case getFileopt opts of-                                Just f -> Just $ return $ toFilePath f-                                Nothing -> if EditDescription `elem` opts-                                              then Just tempfile-                                              else Nothing-          tempfile = worldReadableTemp "darcs-temp-mail"-          tryGetCharset content = let body = renderPS content in-                                  if isAscii body-                                  then Just "us-ascii"-                                  else either (const Nothing)-                                              (const $ Just "utf-8")-                                              (decodeUtf8' body)--getFileopt :: [DarcsFlag] -> Maybe AbsolutePath-getFileopt (LogFile f:_) = Just f-getFileopt (_:flags) = getFileopt flags-getFileopt [] = Nothing
− src/Darcs/Commands/SetPref.hs 
@@ -1,108 +0,0 @@---  Copyright (C) 2003 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.SetPref ( setpref ) where--import System.Exit ( exitWith, ExitCode(..) )-import Control.Monad (when)-import Data.Maybe (fromMaybe)--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, workingRepoDir, umaskOption )-import Darcs.Repository ( amInHashedRepository, addToPending, withRepoLock, RepoJob(..) )-import Darcs.Patch ( changepref )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Repository.Prefs ( getPrefval, changePrefval, )-import English ( orClauses )-#include "impossible.h"---- | A list of all valid preferences for @_darcs/prefs/prefs@.-validPrefData :: [(String, String)] -- ^ (name, one line description)-validPrefData =-    [("test", "a shell command that runs regression tests"),-     ("predist", "a shell command to run before `darcs dist'"),-     ("boringfile", "the path to a version-controlled boring file"),-     ("binariesfile", "the path to a version-controlled binaries file")]--validPrefs :: [String]-validPrefs = map fst validPrefData--setprefDescription :: String-setprefDescription =-    "Set a preference (" ++ orClauses validPrefs ++ ")."--setprefHelp :: String-setprefHelp =- "When working on project with multiple repositories and contributors,\n" ++- "it is sometimes desirable for a preference to be set consistently\n" ++- "project-wide.  This is achieved by treating a preference set with\n" ++- "`darcs setpref' as an unrecorded change, which can then be recorded\n" ++- "and then treated like any other patch.\n" ++- "\n" ++- "Valid preferences are:\n" ++- "\n" ++- unlines ["  "++x++" -- "++y | (x,y) <- validPrefData] ++- "\n" ++- "For example, a project using GNU autotools, with a `make test' target\n" ++- "to perform regression tests, might enable Darcs' integrated regression\n" ++- "testing with the following command:\n" ++- "\n" ++- "  darcs setpref test 'autoconf && ./configure && make && make test'\n" ++- "\n" ++- "Note that merging is not currently implemented for preferences: if two\n" ++- "patches attempt to set the same preference, the last patch applied to\n" ++- "the repository will always take precedence.  This is considered a\n" ++- "low-priority bug, because preferences are seldom set.\n"--setpref :: DarcsCommand-setpref = DarcsCommand {commandProgramName = "darcs",-                        commandName = "setpref",-                        commandHelp = setprefHelp,-                        commandDescription = setprefDescription,-                        commandExtraArgs = 2,-                        commandExtraArgHelp = ["<PREF>",-                                                  "<VALUE>"],-                        commandCommand = setprefCmd,-                        commandPrereq = amInHashedRepository,-                        commandGetArgPossibilities = return validPrefs,-                        commandArgdefaults = nodefaults,-                        commandAdvancedOptions = [umaskOption],-                        commandBasicOptions =-                            [workingRepoDir]}--setprefCmd :: [DarcsFlag] -> [String] -> IO ()-setprefCmd opts [pref,val] = withRepoLock opts $ RepoJob $ \repository -> do-  when (' ' `elem` pref) $ do-    putStrLn $ "'"++pref++-               "' is not a valid preference name:  no spaces allowed!"-    exitWith $ ExitFailure 1-  when (pref `notElem` validPrefs) $ do-    putStrLn $ "'"++pref++"' is not a valid preference name!"-    putStrLn $ "Try one of: " ++ unwords validPrefs-    exitWith $ ExitFailure 1-  oval <- getPrefval pref-  let old = fromMaybe "" oval-  when ('\n' `elem` val) $ do-    putStrLn $ val ++ "is not a valid preference value: newlines forbidden!"-    exitWith $ ExitFailure 1-  changePrefval pref old val-  putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'"-  addToPending repository (changepref pref old val :>: NilFL)-setprefCmd _ _ = impossible-
− src/Darcs/Commands/Show.hs 
@@ -1,82 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.Show ( showCommand, list, query ) where--import Darcs.Commands ( DarcsCommand(..),-                        CommandControl(CommandData, HiddenCommand),-                        commandAlias,-                      )-import Darcs.Commands.ShowAuthors ( showAuthors )-import Darcs.Commands.ShowBug ( showBug )-import Darcs.Commands.ShowContents ( showContents )-import Darcs.Commands.ShowFiles ( showFiles, manifestCmd, toListManifest )-import Darcs.Commands.ShowTags ( showTags )-import Darcs.Commands.ShowRepo ( showRepo )-import Darcs.Commands.ShowIndex ( showIndex, showPristineCmd )-import Darcs.Repository ( amInRepository )--showDescription :: String-showDescription = "Show information which is stored by darcs."--showHelp :: String-showHelp =- "Use the --help option with the subcommands to obtain help for\n"++- "subcommands (for example, \"darcs show files --help\").\n" ++- "\n" ++- "In previous releases, this command was called `darcs query'.\n" ++- "Currently this is a deprecated alias.\n"--showCommand :: DarcsCommand-showCommand = SuperCommand {commandProgramName = "darcs",-                      commandName = "show",-                      commandHelp = showHelp,-                      commandDescription = showDescription,-                      commandPrereq = amInRepository,-                      commandSubCommands = [HiddenCommand showBug,-                                              CommandData showContents,-                                              CommandData showFiles, HiddenCommand showManifest,-                                              CommandData showIndex,-                                              CommandData showPristine,-                                              CommandData showRepo,-                                              CommandData showAuthors,-                                              CommandData showTags]-                     }--query :: DarcsCommand-query = commandAlias "query" Nothing showCommand--list :: DarcsCommand-list = commandAlias "list" Nothing showCommand---- unfortunately, aliases for sub-commands have to live in their parent command--- to avoid an import cycle-showPristine :: DarcsCommand-showPristine = (commandAlias "pristine" (Just showCommand) showIndex) {-  commandCommand = showPristineCmd,-  commandDescription = "Dump contents of pristine cache.",-  commandHelp =-      "The `darcs show pristine' command lists all version-controlled files " ++-      "and directories along with the hashes of their pristine copies. " ++-      "For files, the fields correspond to file size, sha256 of the pristine " ++-      "file content and the filename." }--showManifest :: DarcsCommand-showManifest = (commandAlias "manifest" (Just showCommand) showFiles) {-  commandCommand = manifestCmd toListManifest-}-
− src/Darcs/Commands/ShowAuthors.hs 
@@ -1,195 +0,0 @@---  Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael, Tomas Caithaml------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.ShowAuthors ( showAuthors ) where--import Prelude hiding ( catch )--import qualified Ratified( readFile )-import Control.Arrow ((&&&), (***))-import Control.Exception ( catch, IOException )-import Data.List ( isInfixOf, sortBy, groupBy, group, sort)-import Data.Ord (comparing)-import Data.Char ( toLower, isSpace )-import Data.Maybe( isJust )-import Text.ParserCombinators.Parsec hiding (lower, count, Line)-import Text.ParserCombinators.Parsec.Error-import Text.Regex ( Regex, mkRegexWithOpts, matchRegex )--import Darcs.Arguments ( DarcsFlag(..), workingRepoDir )-import Darcs.Commands ( DarcsCommand(..), nodefaults, putWarning )-import Darcs.External ( viewDoc )-import Darcs.Patch.PatchInfoAnd ( info )-import Darcs.Repository ( amInRepository, readRepo, withRepository, RepoJob(..) )-import Darcs.Patch.Info ( piAuthor )-import Darcs.Patch.Set ( newset2RL )-import Darcs.Witnesses.Ordered ( mapRL )-import Printer ( text )-import Data.Function (on)--data Spelling = Spelling String String [Regex] -- name, email, regexps-type ParsedLine = Maybe Spelling -- Nothing for blank lines---showAuthorsDescription :: String-showAuthorsDescription = "List authors by patch count."--showAuthorsHelp :: String-showAuthorsHelp =- "The `darcs show authors' command lists the authors of the current\n" ++- "repository, sorted by the number of patches contributed.  With the\n" ++- "--verbose option, this command simply lists the author of each patch\n" ++- "(without aggregation or sorting).\n" ++- "\n" ++- "An author's name or email address may change over time.  To tell Darcs\n" ++- "when multiple author strings refer to the same individual, create an\n" ++- "`.authorspellings' file in the root of the working tree.  Each line in\n" ++- "this file begins with an author's canonical name and address, and may\n" ++- "be followed by a comma separated list of extended regular expressions.\n" ++- "Blank lines and lines beginning with two hyphens are ignored.\n" ++- "The format of .authorspelling can be described by this pattern:\n" ++- "\n" ++- " name <address> [, regexp ]*\n" ++- "\n" ++- "There are some pitfalls concerning special characters:\n" ++- "Whitespaces are stripped, if you need space in regexp use [ ]. \n" ++- "Because comma serves as a separator you have to escape it if you want\n" ++- "it in regexp. Note that .authorspelingfile use extended regular\n" ++- "expressions so +, ? and so on are metacharacters and you need to \n" ++- "escape them to be interpreted literally.\n" ++- "\n" ++- "Any patch with an author string that matches the canonical address or\n" ++- "any of the associated regexps is considered to be the work of that\n" ++- "author.  All matching is case-insensitive and partial (it can match a\n" ++- "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" ++- "verbatim.\n" ++- "\n" ++- "An example .authorspelling file is:\n" ++- "\n" ++- "    -- This is a comment.\n" ++- "    Fred Nurk <fred@example.com>\n" ++- "    John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n" ++- "    Chuck Jones\\, Jr. <chuck@pobox.com>, cj\\+user@example.com\n"--showAuthors :: DarcsCommand-showAuthors = DarcsCommand {-  commandProgramName = "darcs",-  commandName = "authors",-  commandHelp = showAuthorsHelp,-  commandDescription = showAuthorsDescription,-  commandExtraArgs = 0,-  commandExtraArgHelp = [],-  commandCommand = authorsCmd,-  commandPrereq = amInRepository,-  commandGetArgPossibilities = return [],-  commandArgdefaults = nodefaults,-  commandAdvancedOptions = [],-  commandBasicOptions = [workingRepoDir] }--authorsCmd :: [DarcsFlag] -> [String] -> IO ()-authorsCmd opts _ = withRepository opts $ RepoJob $ \repository -> do-  patches <- readRepo repository-  spellings <- compiledAuthorSpellings opts-  let authors = mapRL (piAuthor . info) $ newset2RL patches-  viewDoc $ text $ unlines $-   if Verbose `elem` opts-    then authors-    else -- A list of the form ["<count> <canonical name>"]...--      -- Turn the final result into a list of strings.-      map (\ (count, name) -> show count ++ "\t" ++ name) $-      -- Sort by descending patch count.-      reverse $ sortBy (comparing fst) $-      -- Combine duplicates from a list [(count, canonized name)]-      -- with duplicates canonized names (see next comment).-      map ((sum *** head) . unzip) $-      groupBy ((==) `on` snd) $-      sortBy  (comparing snd) $-      -- Because it would take a long time to canonize "foo" into-      -- "foo <foo@bar.baz>" once per patch, the code below-      -- generates a list [(count, canonized name)].-      map (length &&& (canonizeAuthor spellings . head)) $-      group $ sort authors--canonizeAuthor :: [Spelling] -> String -> String-canonizeAuthor spells author = getName canonicals- where-   getName [] = author-   getName ((Spelling name email _):_) = name ++ " <" ++ email ++ ">"-   canonicals = filter (ismatch author) spells-   ismatch s (Spelling _ mail regexps) =-     s `correspondsTo` mail || any (s `contains_regex`) regexps-   contains_regex a r = isJust $ matchRegex r a-   correspondsTo a b = lower b `isInfixOf` lower a-   lower = map toLower--compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling]-compiledAuthorSpellings opts = do-  let as_file = ".authorspellings"-  contents <- (Ratified.readFile -- never unlinked from within darcs-               as_file `catch` (\(_ :: IOException) -> return ""))-  let parse_results = map (parse sentence as_file) $ lines contents-  clean 1 parse_results- where-  clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling]-  clean _ [] = return []-  -- print parse error-  clean n ((Left err):xs) = do-    let npos = setSourceLine (errorPos err) n-    putWarning opts . text . show $ setErrorPos npos err-    clean (n+1) xs-  -- skip blank line-  clean n ((Right Nothing):xs)  = clean (n+1) xs-  -- unwrap Spelling-  clean n ((Right (Just a):xs)) = do-    as <- clean (n+1) xs-    return (a:as)--------------- PARSERS--sentence :: Parser ParsedLine-sentence = spaces >> (comment <|> blank <|> addressline)-  where-    comment = string "--" >> return Nothing-    blank = eof >> return Nothing--addressline :: Parser ParsedLine-addressline = do-  name <- canonicalName <?> "Canonical name"-  addr <- between (char '<') (char '>') (many1 (noneOf ">")) <?> "Address"-  spaces-  rest <- option [] (char ',' >> regexp `sepBy` char ',') <?> "List of regexps"-  return $ Just $ Spelling (strip name) addr (compile rest)-  where-    strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse-    makeRegex s = mkRegexWithOpts s True False-    compile = map makeRegex . filter (not . null) . map strip--regexp :: Parser String-regexp = many1 p <?> "Regular expression"-  where p = try (string "\\," >> return ',')-            <|> noneOf ","--canonicalName :: Parser String-canonicalName = many1 p-  where p = try (string "\\," >> return ',')-            <|> noneOf ",<"-
− src/Darcs/Commands/ShowBug.hs 
@@ -1,51 +0,0 @@---  Copyright (C) 2007 Eric Kow------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.ShowBug ( showBug ) where--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, workingRepoDir )-import Darcs.Repository ( findRepository )-#include "impossible.h"--showBugDescription :: String-showBugDescription = "Simulate a run-time failure."--showBugHelp :: String-showBugHelp =-  "Show bug can be used to see what darcs would show you if you encountered.\n"-  ++"a bug in darcs.\n"--showBug :: DarcsCommand-showBug = DarcsCommand {commandProgramName = "darcs",-                         commandName = "bug",-                         commandHelp = showBugHelp,-                         commandDescription = showBugDescription,-                         commandExtraArgs = 0,-                         commandExtraArgHelp = [],-                         commandCommand = showBugCmd,-                         commandPrereq = findRepository,-                         commandGetArgPossibilities = return [],-                         commandArgdefaults = nodefaults,-                         commandAdvancedOptions = [],-                         commandBasicOptions = [workingRepoDir]}--showBugCmd :: [DarcsFlag] -> [String] -> IO ()-showBugCmd _ _ = bug "This is actually a fake bug in darcs."-
− src/Darcs/Commands/ShowContents.hs 
@@ -1,90 +0,0 @@---  Copyright (C) 2007 Eric Kow------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.ShowContents ( showContents ) where--import Control.Monad ( filterM, forM_, forM, unless )-import System.IO ( stdout )--import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as BL--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, matchOne,-                         workingRepoDir, fixSubPaths )-import Darcs.RepoPath ( sp2fn, toFilePath )-import Darcs.Patch.FileName( FileName, fp2fn )-import Darcs.Patch.ApplyMonad ( withFiles )-import Darcs.Match ( haveNonrangeMatch, applyInvToMatcher, nonrangeMatcher-                   , InclusiveOrExclusive(..), matchExists, applyNInv-                   , hasIndexRange )-import Darcs.Repository ( withRepository, RepoJob(..), findRepository, readRepo, readRecorded )-import qualified Storage.Hashed.Monad as HSM-import Storage.Hashed.AnchoredPath( floatPath, anchorPath )--showContentsDescription :: String-showContentsDescription = "Outputs a specific version of a file."--showContentsHelp :: String-showContentsHelp =-  "Show contents can be used to display an earlier version of some file(s).\n"++-  "If you give show contents no version arguments, it displays the recorded\n"++-  "version of the file(s).\n"--showContents :: DarcsCommand-showContents = DarcsCommand {commandProgramName = "darcs",-                              commandName = "contents",-                              commandHelp = showContentsHelp,-                              commandDescription = showContentsDescription,-                              commandExtraArgs = -1,-                              commandExtraArgHelp-                                    = ["[FILE]..."],-                              commandCommand = showContentsCmd,-                              commandPrereq = findRepository,-                              commandGetArgPossibilities = return [],-                              commandArgdefaults = nodefaults,-                              commandAdvancedOptions = [],-                              commandBasicOptions = [matchOne, workingRepoDir]}--showContentsCmd :: [DarcsFlag] -> [String] -> IO ()-showContentsCmd _ [] = fail "show contents needs at least one argument."-showContentsCmd opts args = withRepository opts $ RepoJob $ \repository -> do-  path_list <- map sp2fn `fmap` fixSubPaths opts args-  pristine <- readRecorded repository-  unapply <- if haveNonrangeMatch opts-               then do-                  patchset <- readRepo repository-                  case nonrangeMatcher opts of-                    -- Index cannot be a Matcher, so handle it manually.-                    Nothing -> case hasIndexRange opts of-                      Just (n, m) | n == m -> return $ applyNInv (n-1) patchset-                      _ -> fail "Couldn't obtain a valid matcher."-                    Just m -> do-                      unless (matchExists m patchset) $-                        fail $ "Couldn't match pattern " ++ show m-                      return $ applyInvToMatcher Exclusive m patchset-                else return (return ())-  let dump :: HSM.TreeIO [(FileName, B.ByteString)]-      dump = do-        let floatedPaths = map (floatPath . toFilePath) path_list-        okpaths <- filterM HSM.fileExists floatedPaths-        forM okpaths $ \f -> do-          content <- (B.concat . BL.toChunks) `fmap` HSM.readFile f-          return (fp2fn $ ("./" ++) $ anchorPath "" f, content)-  files <- flip withFiles unapply `fmap` fst-    `fmap` HSM.virtualTreeIO dump pristine-  forM_ files $ \(_, f) -> B.hPut stdout f
− src/Darcs/Commands/ShowFiles.hs 
@@ -1,133 +0,0 @@---  Copyright (C) 2005 Florian Weimer------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-#include "gadts.h"-module Darcs.Commands.ShowFiles ( showFiles-                                , manifestCmd, toListManifest -- for alias-                                , manifest-                                ) where-import Darcs.Arguments ( DarcsFlag(..), workingRepoDir,-                        files, directories, pending, nullFlag, matchOne )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Repository ( Repository, amInRepository, withRepository,-                          RepoJob(..) )-import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Repository.State ( readRecorded, readRecordedAndPending )-import Storage.Hashed.Tree( Tree, TreeItem(..), list, expand )-import Storage.Hashed.AnchoredPath( anchorPath )-import Storage.Hashed.Plain( readPlainTree )-import System.FilePath ( splitDirectories )--import Data.List( isPrefixOf )--import Darcs.Match ( haveNonrangeMatch, getNonrangeMatch )-import Darcs.Lock ( withDelayedDir )-showFilesDescription :: String-showFilesDescription = "Show version-controlled files in the working copy."--showFilesHelp :: String-showFilesHelp =- "The `darcs show files' command lists those files and directories in\n" ++- "the working tree that are under version control.  This command is\n" ++- "primarily for scripting purposes; end users will probably want `darcs\n" ++- "whatsnew --summary'.\n" ++- "\n" ++- "A file is `pending' if it has been added but not recorded.  By\n" ++- "default, pending files (and directories) are listed; the --no-pending\n" ++- "option prevents this.\n" ++- "\n" ++- "By default `darcs show files' lists both files and directories, but\n" ++- "the alias `darcs show manifest' only lists files.  The --files,\n" ++- "--directories, --no-files and --no-directories modify this behaviour.\n" ++- "\n" ++- "By default entries are one-per-line (i.e. newline separated).  This\n" ++- "can cause problems if the files themselves contain newlines or other\n" ++- "control characters.  To get aroudn this, the --null option uses the\n" ++- "null character instead.  The script interpreting output from this\n" ++- "command needs to understand this idiom; `xargs -0' is such a command.\n" ++- "\n" ++- "For example, to list version-controlled files by size:\n" ++- "\n" ++- "    darcs show files -0 | xargs -0 ls -ldS\n"--showFiles :: DarcsCommand-showFiles = DarcsCommand {-  commandProgramName = "darcs",-  commandName = "files",-  commandHelp = showFilesHelp,-  commandDescription = showFilesDescription,-  commandExtraArgs = -1,-  commandExtraArgHelp = ["[FILE or DIRECTORY]..."],-  commandCommand = manifestCmd toListFiles,-  commandPrereq = amInRepository,-  commandGetArgPossibilities = return [],-  commandArgdefaults = nodefaults,-  commandAdvancedOptions = [],-  commandBasicOptions = [files, directories, pending, nullFlag, matchOne,-                          workingRepoDir] }--toListFiles, toListManifest :: [DarcsFlag] -> Tree m -> [FilePath]-toListFiles    opts = filesDirs (NoFiles `notElem` opts) (NoDirectories `notElem` opts)-toListManifest opts = filesDirs (NoFiles `notElem` opts) (Directories `elem` opts)--filesDirs :: Bool -> Bool -> Tree m -> [FilePath]-filesDirs False False _ = []-filesDirs False True  t = "." : [ anchorPath "." p | (p, SubTree _) <- list t ]-filesDirs True  False t = [ anchorPath "." p | (p, File _) <- list t ]-filesDirs True  True  t = "." : (map (anchorPath "." . fst) $ list t)--manifest :: [DarcsFlag] -> [String] -> IO [FilePath]-manifest = manifestHelper toListFiles--manifestCmd :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO ()-manifestCmd to_list opts argList = do-    mapM_ output =<< manifestHelper to_list opts argList-  where-    output_null name = do { putStr name ; putChar '\0' }-    output = if NullFlag `elem` opts then output_null else putStrLn--manifestHelper :: ([DarcsFlag] -> Tree IO -> [FilePath]) -> [DarcsFlag] -> [String] -> IO [FilePath]-manifestHelper to_list opts argList = do-    list' <- (to_list opts) `fmap` withRepository opts (RepoJob myslurp)-    case argList of-        []       -> return list'-        prefixes -> return (onlysubdirs prefixes list')-    where myslurp :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u r) -> IO (Tree IO)-          myslurp r = do let fRevisioned = haveNonrangeMatch opts-                             fPending = Pending `elem` opts-                             fNoPending = NoPending `elem` opts-                       -- this covers all 8 options-                         expand =<< case (fRevisioned,fPending,fNoPending) of-                            (True,False,_) -> slurpRevision opts r-                            (True,True,_) -> error $ "can't mix revisioned and pending flags"-                            (False,False,True) -> readRecorded r-                            (False,_,False) -> readRecordedAndPending r -- pending is default-                            (False,True,True) -> error $ "can't mix pending and no-pending flags"-          isParentDir a' b' =-            let a = splitDirectories a'-                b = splitDirectories b'-            in (a `isPrefixOf` b) || (("." : a) `isPrefixOf` b)-          onlysubdirs dirs = filter (\p -> any (`isParentDir` p) dirs)--slurpRevision :: (RepoPatch p, ApplyState p ~ Tree)-              => [DarcsFlag] -> Repository p C(r u r) -> IO (Tree IO)-slurpRevision opts r = withDelayedDir "revisioned.showfiles" $ \_ -> do-  getNonrangeMatch r opts-  expand =<< readPlainTree "."-
− src/Darcs/Commands/ShowIndex.hs 
@@ -1,84 +0,0 @@--- Copyright (C) 2009 Petr Rockai------ 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--- SOFTWARE.--{-# LANGUAGE CPP #-}-#include "gadts.h"-module Darcs.Commands.ShowIndex ( showIndex-                                , showPristineCmd -- for alias-                                ) where-import Darcs.Arguments ( DarcsFlag(..), workingRepoDir,-                        files, directories, nullFlag )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Repository ( amInRepository, withRepository, RepoJob(..), readIndex )-import Darcs.Repository.State ( readRecorded )--import Storage.Hashed( floatPath )-import Storage.Hashed.Hash( encodeBase16, Hash( NoHash ) )-import Storage.Hashed.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) )-import Storage.Hashed.Index( updateIndex )-import Storage.Hashed.AnchoredPath( anchorPath )--import qualified Data.ByteString.Char8 as BS--showIndex :: DarcsCommand-showIndex = DarcsCommand {-  commandProgramName = "darcs",-  commandName = "index",-  commandDescription = "Dump contents of working tree index.",-  commandHelp =-      "The `darcs show index' command lists all version-controlled files and " ++-      "directories along with their hashes as stored in _darcs/index. " ++-      "For files, the fields correspond to file size, sha256 of the current " ++-      "file content and the filename.",-  commandExtraArgs = 0,-  commandExtraArgHelp = [],-  commandCommand = showIndexCmd,-  commandPrereq = amInRepository,-  commandGetArgPossibilities = return [],-  commandArgdefaults = nodefaults,-  commandAdvancedOptions = [],-  commandBasicOptions = [files, directories, nullFlag, workingRepoDir] }--dump :: [DarcsFlag] -> Tree IO -> IO ()-dump opts tree = do-  let line | NullFlag `elem` opts = \t -> putStr t >> putChar '\0'-           | otherwise = putStrLn-      output (p, i) = do-        let hash = case itemHash i of-                     NoHash -> "(no hash available)"-                     h -> BS.unpack $ encodeBase16 h-            path = anchorPath "" p-            isdir = case i of-                      SubTree _ -> "/"-                      _ -> ""-        line $ hash ++ " " ++ path ++ isdir-  x <- expand tree-  mapM_ output $ (floatPath ".", SubTree x) : list x--showIndexCmd :: [DarcsFlag] -> [String] -> IO ()-showIndexCmd opts _ = withRepository opts $ RepoJob $ \repo -> do-  readIndex repo >>= updateIndex >>= dump opts--showPristineCmd :: [DarcsFlag] -> [String] -> IO ()-showPristineCmd opts _ = withRepository opts $ RepoJob $ \repo -> do-  readRecorded repo >>= dump opts-
− src/Darcs/Commands/ShowRepo.hs 
@@ -1,149 +0,0 @@---  Copyright (C) 2007 Kevin Quick------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-#include "gadts.h"-module Darcs.Commands.ShowRepo ( showRepo ) where--import Data.Char ( toLower, isSpace )-import Data.List ( intercalate )-import Control.Monad ( when, unless )-import Text.Html ( tag, stringToHtml )-import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, files, xmloutput )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Repository ( withRepository, RepoJob(..), amInRepository, readRepo )-import Darcs.Repository.Internal ( Repository(..), RepoType(..) )-import Darcs.Repository.Format ( RepoFormat(..) )-import Darcs.Repository.Prefs ( getPreflist )-import Darcs.Repository.Motd ( getMotd )-import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Set ( newset2RL )-import Darcs.Witnesses.Ordered ( lengthRL )-import qualified Data.ByteString.Char8 as BC  (unpack)-import Darcs.Patch.Apply( ApplyState )-import Storage.Hashed.Tree ( Tree )--showRepoHelp :: String-showRepoHelp =- "The `darcs show repo' command displays statistics about the current\n" ++- "repository, allowing third-party scripts to access this information\n" ++- "without inspecting _darcs directly (and without breaking when the\n" ++- "_darcs format changes).\n" ++- "\n" ++- "By default, the number of patches is shown.  If this data isn't\n" ++- "needed, use --no-files to accelerate this command from O(n) to O(1).\n" ++- "\n" ++- "By default, output is in a human-readable format.  The --xml-output\n" ++- "option can be used to generate output for machine postprocessing.\n"--showRepoDescription :: String-showRepoDescription = "Show repository summary information"--showRepo :: DarcsCommand-showRepo = DarcsCommand { commandProgramName = "darcs",-                           commandName = "repo",-                           commandHelp = showRepoHelp,-                           commandDescription = showRepoDescription,-                           commandExtraArgs = 0,-                           commandExtraArgHelp = [],-                           commandCommand = repoCmd,-                           commandPrereq = amInRepository,-                           commandGetArgPossibilities = return [],-                           commandArgdefaults = nodefaults,-                           commandAdvancedOptions = [],-                           commandBasicOptions = [workingRepoDir, files, xmloutput] }--repoCmd :: [DarcsFlag] -> [String] -> IO ()-repoCmd opts _ = let put_mode = if XMLOutput `elem` opts then showInfoXML else showInfoUsr-                  in withRepository opts $ RepoJob $ \repository -> actuallyShowRepo (putInfo put_mode) repository---- Some convenience functions to output a labelled text string or an--- XML tag + value (same API).  If no value, output is suppressed--- entirely.  Borrow some help from Text.Html to perform XML output.--type ShowInfo = String -> String -> String--showInfoXML :: ShowInfo-showInfoXML t i = show $ tag (safeTag t) $ stringToHtml i--safeTag :: String -> String-safeTag [] = []-safeTag (' ':cs) = safeTag cs-safeTag ('#':cs) = "num_" ++ (safeTag cs)-safeTag (c:cs) = toLower c : safeTag cs---- labelled strings: labels are right-aligned at 14 characters;--- subsequent lines in multi-line output are indented accordingly.-showInfoUsr :: ShowInfo-showInfoUsr t i = (replicate (14 - length(t)) ' ') ++ t ++ ": " ++-                  intercalate ('\n' : (replicate 16 ' ')) (lines i) ++ "\n"--type PutInfo = String -> String -> IO ()-putInfo :: ShowInfo -> PutInfo-putInfo m t i = unless (null i) (putStr $ m t i)---- Primary show-repo operation.  Determines ordering of output for--- sub-displays.  The `out' argument is one of the above operations to--- output a labelled text string or an XML tag and contained value.--actuallyShowRepo :: (RepoPatch p, ApplyState p ~ Tree)-                 => PutInfo -> Repository p C(r u r) -> IO ()-actuallyShowRepo out r@(Repo loc opts rf rt) = do-         when (XMLOutput `elem` opts) (putStr "<repository>\n")-         showRepoType out rt-         when (Verbose `elem` opts) (out "Show" $ show r)-         showRepoFormat out rf-         out "Root" loc-         showRepoAux out rt-         showRepoPrefs out-         unless (NoFiles `elem` opts) (numPatches r >>= (out "Num Patches" . show ))-         showRepoMOTD out r-         when (XMLOutput `elem` opts) (putStr "</repository>\n")---- Most of the actual elements being displayed are part of the Show--- class; that's fine for a Haskeller, but not for the common user, so--- the routines below work to provide more human-readable information--- regarding the repository elements.--showRepoType :: PutInfo -> RepoType p -> IO ()-showRepoType out (DarcsRepository _ _) = out "Type" "darcs"--showRepoFormat :: PutInfo -> RepoFormat -> IO ()-showRepoFormat out (RF rf) = out "Format" $-    intercalate ", " (map (intercalate "|" . map BC.unpack) rf)--showRepoAux :: PutInfo -> RepoType p -> IO ()-showRepoAux out (DarcsRepository pris cs) =-    do out "Pristine" $ show pris-       out "Cache" $ intercalate ", " $ lines $ show cs---showRepoPrefs :: PutInfo -> IO ()-showRepoPrefs out = do-    getPreflist "prefs" >>= mapM_ prefOut-    getPreflist "author" >>= out "Author" . unlines-    getPreflist "defaultrepo" >>= out "Default Remote" . unlines-  where prefOut = uncurry out . (\(p,v) -> (p++" Pref", (dropWhile isSpace v))) . break isSpace--showRepoMOTD :: RepoPatch p => PutInfo -> Repository p C(r u r) -> IO ()-showRepoMOTD out (Repo loc _ _ _) = getMotd loc >>= out "MOTD" . BC.unpack---- Support routines to provide information used by the PutInfo operations above.--numPatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u r) -> IO Int-numPatches r = readRepo r >>= (return . lengthRL . newset2RL)-
− src/Darcs/Commands/ShowTags.hs 
@@ -1,82 +0,0 @@---  Copyright (C) 2007 Florian Weimer------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.ShowTags ( showTags ) where-import Darcs.Arguments ( DarcsFlag(..), possiblyRemoteRepoDir, getRepourl )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Patch.PatchInfoAnd ( info )-import Darcs.Repository ( findRepository, readRepo, withRepositoryDirectory, RepoJob(..) )-import Darcs.Patch.Info ( piTag )-import Darcs.Patch.Set ( newset2RL )-import Darcs.Witnesses.Ordered ( mapRL )-import Data.Maybe ( fromMaybe )-import System.IO ( stderr, hPutStrLn )--- import Printer ( renderPS )--showTagsDescription :: String-showTagsDescription = "Show all tags in the repository."--showTagsHelp :: String-showTagsHelp =- "The tags command writes a list of all tags in the repository to standard\n"++- "output.\n" ++- "\n" ++- "Tab characters (ASCII character 9) in tag names are changed to spaces\n" ++- "for better interoperability with shell tools.  A warning is printed if\n" ++- "this happens."--showTags :: DarcsCommand-showTags = DarcsCommand {-  commandProgramName = "darcs",-  commandName = "tags",-  commandHelp = showTagsHelp,-  commandDescription = showTagsDescription,-  commandExtraArgs = 0,-  commandExtraArgHelp = [],-  commandCommand = tagsCmd,-  commandPrereq = findRepository,-  commandGetArgPossibilities = return [],-  commandArgdefaults = nodefaults,-  commandAdvancedOptions = [],-  commandBasicOptions = [possiblyRemoteRepoDir] }--tagsCmd :: [DarcsFlag] -> [String] -> IO ()-tagsCmd opts _ =-  let repodir = fromMaybe "." (getRepourl opts) in-  withRepositoryDirectory opts repodir $ RepoJob $ \repository -> do-  patches <- readRepo repository-  sequence_ $ mapRL process $ newset2RL patches-  where process hp =-            case piTag $ info hp of-              Just t -> do-                 t' <- normalize t t False-                 putStrLn t'-              Nothing -> return ()-        normalize :: String -> String -> Bool -> IO String-        normalize _ [] _ = return []-        normalize t (x : xs) flag =-            if x == '\t' then do-                  if flag-                    then return ()-                    else hPutStrLn stderr-                             ("warning: tag with TAB character: " ++ t)-                  rest <- (normalize t xs True)-                  return $ ' ' : rest-            else do-                  rest <- (normalize t xs flag)-                  return $ x : rest-
− src/Darcs/Commands/Tag.hs 
@@ -1,123 +0,0 @@---  Copyright (C) 2003-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.Tag ( tag ) where-import System.Directory ( removeFile )-import Control.Monad ( when )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( nocompress, umaskOption, patchnameOption, author,-                         pipeInteractive, askLongComment,-                         workingRepoDir, getAuthor )-import Darcs.Patch.PatchInfoAnd ( n2pia )-import Darcs.Repository ( amInHashedRepository, withRepoLock, Repository, RepoJob(..), readRepo,-                    tentativelyAddPatch, finalizeRepositoryChanges,-                  )-import Darcs.Patch ( infopatch, adddeps, Patchy, PrimPatch, PrimOf )-import Darcs.Patch.Info ( patchinfo )-import Darcs.Patch.Depends ( getTagsRight )-import Darcs.Commands.Record ( getDate, getLog )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Lock ( worldReadableTemp )-import Darcs.Flags ( DarcsFlag(..), compression )-import System.IO ( hPutStr, stderr )--#include "gadts.h"--tagDescription :: String-tagDescription = "Name the current repository state for future reference."--tagHelp :: String-tagHelp =- "The `darcs tag' command names the current repository state, so that it\n" ++- "can easily be referred to later.  Every `important' state should be\n" ++- "tagged; in particular it is good practice to tag each stable release\n" ++- "with a number or codename.  Advice on release numbering can be found\n" ++- "at http://producingoss.com/en/development-cycle.html.\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" ++- "all tags in the current repository.\n" ++- "\n" ++- "Tagging also provides significant performance benefits: when Darcs\n" ++- "reaches a shared tag that depends on all antecedent patches, it can\n" ++- "simply stop processing.\n" ++- "\n" ++- "Like normal patches, a tag has a name, an author, a timestamp and an\n" ++- "optional long description, but it does not change the working tree.\n" ++- "A tag can have any name, but it is generally best to pick a naming\n" ++- "scheme and stick to it.\n" ++- "\n" ++- "The `darcs tag' command accepts the --pipe option, which behaves as\n" ++- "described in `darcs record'.\n"--tag :: DarcsCommand-tag = DarcsCommand {commandProgramName = "darcs",-                    commandName = "tag",-                    commandHelp = tagHelp,-                    commandDescription = tagDescription,-                    commandExtraArgs = -1,-                    commandExtraArgHelp = ["[TAGNAME]"],-                    commandCommand = tagCmd,-                    commandPrereq = amInHashedRepository,-                    commandGetArgPossibilities = return [],-                    commandArgdefaults = nodefaults,-                    commandAdvancedOptions = [nocompress,umaskOption],-                    commandBasicOptions = [patchnameOption, author,-                                            pipeInteractive,-                                            askLongComment,-                                            workingRepoDir]}--tagCmd :: [DarcsFlag] -> [String] -> IO ()-tagCmd opts args = withRepoLock opts $ RepoJob $ \(repository :: Repository p C(r u r)) -> do-    date <- getDate opts-    the_author <- getAuthor opts-    deps <- getTagsRight `fmap` readRepo repository-    (name, long_comment, mlogf)  <- get_name_log (NilFL :: FL (PrimOf p) C(a a)) opts args-    myinfo <- patchinfo date name the_author long_comment-    let mypatch = infopatch myinfo NilFL--- Warning:  A do-notation statement discarded a result of type Darcs.Repository.InternalTypes.Repository p r u r.-    _ <- tentativelyAddPatch repository (compression opts) $ n2pia $ adddeps mypatch deps-    finalizeRepositoryChanges repository-    maybe (return ()) removeFile mlogf-    putStrLn $ "Finished tagging patch '"++name++"'"-  where  get_name_log ::(Patchy prim, PrimPatch prim) => FL prim C(a a) -> [DarcsFlag] -> [String] -> IO (String, [String], Maybe String)-         get_name_log nilFL o a-                          = do let o2 = if null a then o else (add_patch_name o (unwords a))-                               (name, comment, mlogf) <- getLog o2 Nothing (worldReadableTemp "darcs-tag") nilFL-                               when (length name < 2) $ hPutStr stderr $-                                 "Do you really want to tag '"-                                 ++name++"'? If not type: darcs obliterate --last=1\n"-                               return ("TAG " ++ name, comment, mlogf)-         add_patch_name :: [DarcsFlag] -> String -> [DarcsFlag]-         add_patch_name o a| has_patch_name o = o-                           | otherwise = [PatchName a] ++ o-         has_patch_name (PatchName _:_) = True-         has_patch_name (_:fs) = has_patch_name fs-         has_patch_name [] = False---- This may be useful for developers, but users don't care about--- internals:------ A tagged version automatically depends on all patches in the--- repository.  This allows you to later reproduce precisely that--- version.  The tag does this by depending on all patches in the--- repository, except for those which are depended upon by other tags--- already in the repository.  In the common case of a sequential--- series of tags, this means that the tag depends on all patches--- since the last tag, plus that tag itself.-
− src/Darcs/Commands/Test.hs 
@@ -1,70 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.Test ( test ) where--import Prelude hiding ( catch )--import System.Exit ( exitWith )--import Darcs.Commands ( DarcsCommand(..), nodefaults, putInfo )-import Darcs.Arguments ( DarcsFlag(Test)-                       , leaveTestDir-                       , workingRepoDir-                       )-import Darcs.Repository ( Repository, amInHashedRepository, withRepository,-                          testRecorded, RepoJob(..) )-import Darcs.Patch ( RepoPatch )-import Darcs.Patch.Apply( ApplyState )-import Printer ( text )-import Storage.Hashed.Tree( Tree )--#include "gadts.h"--testDescription :: String-testDescription = "Run regression test."--testHelp :: String-testHelp =- "If a regression test is defined (see `darcs setpref') it will be run.\n"--test :: DarcsCommand-test = DarcsCommand  {commandProgramName = "darcs",-                      commandName = "test",-                      commandHelp = testHelp,-                      commandDescription = testDescription,-                      commandExtraArgs = 0,-                      commandExtraArgHelp = [],-                      commandCommand = testCmd,-                      commandPrereq = amInHashedRepository,-                      commandGetArgPossibilities = return [],-                      commandArgdefaults = nodefaults,-                      commandAdvancedOptions = [],-                      commandBasicOptions = [ leaveTestDir,-                                              workingRepoDir-                                             ]}--testCmd :: [DarcsFlag] -> [String] -> IO ()-testCmd opts _ = withRepository (Test:opts) (RepoJob (test' opts))--test'-  :: forall p C(r u t) . (RepoPatch p, ApplyState p ~ Tree)-  => [DarcsFlag] -> Repository p C(r u t) -> IO ()-test' opts repository = do-    putInfo opts $ text "Running test on current repository state."-    rc <- testRecorded repository-    exitWith rc
− src/Darcs/Commands/TrackDown.hs 
@@ -1,194 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Commands.TrackDown ( trackdown ) where-import Prelude hiding ( init, catch )-import System.Exit ( ExitCode(..) )-import System.Cmd ( system )-import System.IO ( hFlush, stdout )-import Control.Exception ( catch, IOException )-import Control.Monad( when )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag(SetScriptsExecutable, Bisect), workingRepoDir, bisect,-                         setScriptsExecutableOption, makeScriptsExecutable )-import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Repository ( amInHashedRepository, readRepo, withRepoReadLock, RepoJob(..), withRecorded,-                          setScriptsExecutable )-import Darcs.Witnesses.Ordered ( RL(..), (:<)(..), (+<+),-                                 reverseRL, splitAtRL, lengthRL, mapRL, mapFL, mapRL_RL )-import Darcs.Patch.Conflict ( Conflict )-import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.ApplyMonad ( ApplyMonad )-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Patchy ( Patchy, Invert, Apply, ShowPatch )-import Darcs.Patch ( RepoPatch, Named, description, apply, invert )-import Darcs.Patch.Set ( newset2RL )-import Printer ( putDocLn )-import Darcs.Test ( getTest )-import Darcs.Lock ( withTempDir )-import Storage.Hashed.Tree( Tree )--#include "gadts.h"--trackdownDescription :: String-trackdownDescription = "Locate the most recent version lacking an error."--trackdownHelp :: String-trackdownHelp =- "Trackdown tries to find the most recent version in the repository which\n"++- "passes a test.  Given no arguments, it uses the default repository test.\n"++- "Given one argument, it treats it as a test command.  Given two arguments,\n"++- "the first is an initialization command with is run only once, and the\n"++- "second is the test command.\n\n"++- "Without the --bisect option, trackdown does linear search starting from head,\n"++- "and moving away from head.  With the --bisect option, it does binary search.\n\n"++- "Under the assumption that failure is monotonous, trackdown produces\n"++- "the same result with and without --bisect.  (Monotonous means that when\n"++- "moving away from head, the test result changes only once from \"fail\" to \"ok\".)\n"++- "If failure is not monotonous, any one of the patches that break the test is\n"++- "found at random."--trackdown :: DarcsCommand-trackdown = DarcsCommand {commandProgramName = "darcs",-                          commandName = "trackdown",-                          commandHelp = trackdownHelp,-                          commandDescription = trackdownDescription,-                          commandExtraArgs = -1,-                          commandExtraArgHelp = ["[[INITIALIZATION]",-                                                    "COMMAND]"],-                          commandCommand = trackdownCmd,-                          commandPrereq = amInHashedRepository,-                          commandGetArgPossibilities = return [],-                          commandArgdefaults = nodefaults,-                          commandAdvancedOptions = [setScriptsExecutableOption],-                          commandBasicOptions = [workingRepoDir, bisect]}--trackdownCmd :: [DarcsFlag] -> [String] -> IO ()-trackdownCmd opts args = withRepoReadLock opts $ RepoJob $ \repository -> do-  patches <- readRepo repository-  (init,test) <- case args of-          [] ->-              do t <- getTest opts-                 return (return ExitSuccess, t)-          [cmd] ->-              do putStrLn $ "Tracking down command:\n"++cmd-                 return $ (return ExitSuccess, system cmd)-          [init,cmd] ->-              do putStrLn $ "Initializing with command:\n"++init-                 putStrLn $ "Tracking down command:\n"++cmd-                 return $ (system init, system cmd)-          _ -> fail "Trackdown expects zero to two arguments."-  withRecorded repository (withTempDir "trackingdown") $ \_ -> do-    when (SetScriptsExecutable `elem` opts) setScriptsExecutable-    _ <- init-    (if Bisect `elem` opts-     then trackBisect-     else trackNextLinear) opts test (mapRL_RL hopefully . newset2RL $ patches)---- | linear search (without --bisect)-trackNextLinear :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)-                => [DarcsFlag] -> IO ExitCode -> RL (Named p) C(x y) -> IO ()-trackNextLinear opts test (p:<:ps) = do-    test_result <- test-    if test_result == ExitSuccess-       then putStrLn "Success!"-       else do apply (invert p) `catch` \(e :: IOException) -> fail ("Bad patch:\n" ++ show e)-               makeScriptsExecutable opts (invert p)-               putStrLn "Trying without the patch:"-               putDocLn $ description $ invert p-               hFlush stdout-               trackNextLinear opts test ps-trackNextLinear _opts test NilRL = do-    test_result <- test-    if test_result == ExitSuccess-       then putStrLn "Success!"-       else putStrLn "Noone passed the test!"---- | binary search (with --bisect)-trackBisect :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p))-            => [DarcsFlag] -> IO ExitCode -> RL p C(x y) -> IO ()-trackBisect _ test NilRL = do-    test_result <- test-    if test_result == ExitSuccess-       then putStrLn "Success!"-       else putStrLn "Noone passed the test!"-trackBisect opts test ps = do-      test_result <- test-      if test_result == ExitSuccess-        then putStrLn ("Test does not fail on head.")-        else trackNextBisect opts curr_prog test BisectRight (patchTreeFromRL ps)-    where-      curr_prog = (1, 1 + round ((logBase 2 $ fromIntegral $ lengthRL ps) :: Double)) :: (Int,Int)---- | Bisect Patch Tree-data PatchTree p C(x y) where-    Leaf :: p C(x y) -> PatchTree p C(x y)-    Fork :: PatchTree p C(y z) -> PatchTree p C(x y) -> PatchTree p C(x z)---- | Direction of Bisect trackdown-data BisectDir = BisectLeft | BisectRight deriving Show---- | Progress of Bisect-type BisectState = (Int, Int)---- | Create Bisect PatchTree from the RL-patchTreeFromRL :: (Patchy p) => RL p C(x y) -> PatchTree p C(x y)-patchTreeFromRL (l :<: NilRL) = Leaf l-patchTreeFromRL xs = case splitAtRL (lengthRL xs `div` 2) xs of-                       (l :< r) -> Fork (patchTreeFromRL l) (patchTreeFromRL r)---- | Convert PatchTree back to RL-patchTree2RL :: (Patchy p) => PatchTree p C(x y) -> RL p C(x y)-patchTree2RL (Leaf p)   = p :<: NilRL-patchTree2RL (Fork l r) = (patchTree2RL l) +<+ (patchTree2RL r)---- | Iterate the Patch Tree-trackNextBisect :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p))-                => [DarcsFlag] -> BisectState -> IO ExitCode -> BisectDir -> PatchTree p C(x y) -> IO ()-trackNextBisect opts (dnow, dtotal) test dir (Fork l r) = do-  putStr ("Trying " ++ show dnow ++ "/" ++ show dtotal ++ " sequences...\n")-  hFlush stdout-  case dir of-    BisectRight -> jumpHalfOnRight opts l  -- move in temporary repo-    BisectLeft  -> jumpHalfOnLeft  opts r  -- within given direction-  test_result <- test -- execute test on repo-  case test_result of-    ExitSuccess -> trackNextBisect opts (dnow+1, dtotal) test BisectLeft l  -- continue left  (to the present)-    _           -> trackNextBisect opts (dnow+1, dtotal) test BisectRight r -- continue right (to the past)-trackNextBisect _ _ _ _ (Leaf p) = do-  putStrLn ("Last recent patch that fails the test (assuming monotony in the given range):")-  putDocLn (description p)--jumpHalfOnRight :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p)) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()-jumpHalfOnRight opts l = unapplyRL ps >> makeScriptsExecutable opts ps-  where ps = patchTree2RL l--jumpHalfOnLeft :: (IsHunk p, Conflict p, PatchListFormat p, Patchy p, ApplyMonad IO (ApplyState p)) => [DarcsFlag] -> PatchTree p C(x y) -> IO ()-jumpHalfOnLeft opts r = applyRL p >> makeScriptsExecutable opts p-  where p = patchTree2RL r--applyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => RL p C(x y) -> IO ()-applyRL   patches = sequence_ (mapFL safeApply (reverseRL $ patches))--unapplyRL :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => RL p C(x y) -> IO ()-unapplyRL patches = sequence_ (mapRL (safeApply . invert) patches)--safeApply :: (Invert p, ShowPatch p, Apply p, ApplyMonad IO (ApplyState p)) => p C(x y) -> IO ()-safeApply p = apply p `catch` (\(msg :: IOException) -> fail ("Bad patch (during trackdown --bisect):\n" ++ show msg))-
− src/Darcs/Commands/TransferMode.hs 
@@ -1,86 +0,0 @@---  Copyright (C) 2008 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, PatternGuards #-}---- The pragma above is only for pattern guards.-module Darcs.Commands.TransferMode ( transferMode ) where--import Prelude hiding ( catch )-import Control.Exception.Extensible ( catch )-import System.IO ( stdout, hFlush )--import Darcs.Utils ( withCurrentDirectory, prettyException )-import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Arguments ( DarcsFlag, workingRepoDir )-import Darcs.Repository ( amInRepository )-import Progress ( setProgressMode )-import Darcs.Global ( darcsdir )--import qualified Data.ByteString as B (hPut, readFile, length, ByteString)--transferModeDescription :: String-transferModeDescription = "Internal command for efficient ssh transfers."--transferModeHelp :: String-transferModeHelp =- "When pulling from or pushing to a remote repository over ssh, if both\n" ++- "the local and remote ends have Darcs 2, the `transfer-mode' command\n" ++- "will be invoked on the remote end.  This allows Darcs to intelligently\n" ++- "transfer information over a single ssh connection.\n" ++- "\n" ++- "If either end runs Darcs 1, a separate ssh connection will be created\n" ++- "for each transfer.  As well as being less efficient, this means users\n" ++- "who do not run ssh-agent will be prompted for the ssh password tens or\n" ++- "hundreds of times!\n"--transferMode :: DarcsCommand-transferMode = DarcsCommand {commandProgramName = "darcs",-                              commandName = "transfer-mode",-                              commandHelp = transferModeHelp,-                              commandDescription = transferModeDescription,-                              commandExtraArgs = 0,-                              commandExtraArgHelp = [],-                              commandGetArgPossibilities = return [],-                              commandCommand = transferModeCmd,-                              commandPrereq = amInRepository,-                              commandArgdefaults = nodefaults,-                              commandAdvancedOptions = [],-                              commandBasicOptions = [workingRepoDir]}--transferModeCmd :: [DarcsFlag] -> [String] -> IO ()-transferModeCmd _ _ =   do setProgressMode False-                           putStrLn "Hello user, I am darcs transfer mode"-                           hFlush stdout-                           withCurrentDirectory darcsdir $ transfer--transfer :: IO ()-transfer = do 'g':'e':'t':' ':fn <- getLine-              x <- readfile fn-              case x of-                Right c -> do putStrLn $ "got " ++ fn-                              print $ B.length c-                              B.hPut stdout c-                              hFlush stdout-                Left e -> do putStrLn $ "error " ++ fn-                             print e-                             hFlush stdout-              transfer--readfile :: String -> IO (Either String B.ByteString)-readfile fn = (Right `fmap` B.readFile fn) `catch` (\e -> return $ Left (prettyException e))-
− src/Darcs/Commands/Unrecord.hs 
@@ -1,259 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Commands.Unrecord ( unrecord, unpull, obliterate, getLastPatches ) where--import Prelude hiding ( catch )--import Control.Exception ( catch, IOException )-import Control.Monad ( when )-import System.Exit ( exitWith, ExitCode( ExitSuccess ) )-import Data.Maybe( isJust )--import Printer ( text, putDoc )-import English ( presentParticiple )-import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc )-import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias,-                        putVerbose )-import Darcs.Arguments ( DarcsFlag,-                         output, outputAutoName, getOutput,-                         workingRepoDir, nocompress, setEnvDarcsPatches,-                        matchSeveralOrLast, depsSel,-                        ignoretimes,-                        allInteractive, umaskOption, summary, dryRun,-                        printDryRunMessageAndExit, changesReverse-                      )-import Darcs.Flags ( doReverse, UseIndex(..), ScanKnown(..), compression )-import Darcs.Match ( firstMatch, matchFirstPatchset, matchAPatchread )-import Darcs.Repository ( PatchInfoAnd, withGutsOf,-                          withRepoLock, RepoJob(..),-                    tentativelyRemovePatches, finalizeRepositoryChanges,-                    tentativelyAddToPending,-                    applyToWorking,-                    readRepo, amInHashedRepository,-                    invalidateIndex, unrecordedChanges )-import Darcs.Patch ( RepoPatch, invert, commute, effect )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), appendPSFL )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Ordered ( RL(..), (:>)(..), (+<+),-                             mapFL_FL, nullFL,-                             reverseRL, mapRL, FL(..) )-import Darcs.Patch.Depends ( findCommonWithThem )-import Darcs.SelectChanges ( selectChanges-                           , WhichChanges(..)-                           , selectionContext, runSelection )-import Darcs.Patch.Bundle ( makeBundleN, patchFilename, contextPatches )-import Progress ( debugMessage )-import Darcs.Witnesses.Sealed ( Sealed(..) )-import Darcs.RepoPath( useAbsoluteOrStd )-import Darcs.Lock( writeDocBinFile )-import Storage.Hashed.Tree( Tree )-#include "gadts.h"--unrecordDescription :: String-unrecordDescription =- "Remove recorded patches without changing the working copy."--unrecordHelp :: String-unrecordHelp =- "Unrecord does the opposite of record in that it makes the changes from\n"++- "patches active changes again which you may record or revert later.  The\n"++- "working copy itself will not change.\n"++- "Beware that you should not use this command if you are going to\n"++- "re-record the changes in any way and there is a possibility that\n"++- "another user may have already pulled the patch.\n"--unrecord :: DarcsCommand-unrecord = DarcsCommand {commandProgramName = "darcs",-                         commandName = "unrecord",-                         commandHelp = unrecordHelp,-                         commandDescription = unrecordDescription,-                         commandExtraArgs = 0,-                         commandExtraArgHelp = [],-                         commandCommand = unrecordCmd,-                         commandPrereq = amInHashedRepository,-                         commandGetArgPossibilities = return [],-                         commandArgdefaults = nodefaults,-                         commandAdvancedOptions =-                             [nocompress,umaskOption,changesReverse],-                         commandBasicOptions = [matchSeveralOrLast,-                                                 depsSel,-                                                 allInteractive,-                                                 workingRepoDir]}--unrecordCmd :: [DarcsFlag] -> [String] -> IO ()-unrecordCmd opts _ = withRepoLock opts $ RepoJob $ \repository -> do-  allpatches <- readRepo repository-  (_ :> patches) <- return $ if firstMatch opts-                             then getLastPatches opts allpatches-                             else matchingHead opts allpatches-  let context = selectionContext "unrecord" opts Nothing Nothing-      selector = if doReverse opts-                 then selectChanges Last-                 else selectChanges LastReversed-  (_ :> to_unrecord) <- runSelection (selector patches) context-  when (nullFL to_unrecord) $ do putStrLn "No patches selected!"-                                 exitWith ExitSuccess-  putVerbose opts $ text-                      "About to write out (potentially) modified patches..."-  setEnvDarcsPatches to_unrecord-  invalidateIndex repository--- Warning:  A do-notation statement discarded a result of type Darcs.Repository.InternalTypes.Repository p r u z.-  withGutsOf repository $ do _ <- tentativelyRemovePatches repository (compression opts) to_unrecord-                             finalizeRepositoryChanges repository-  putStrLn "Finished unrecording."--getLastPatches :: RepoPatch p => [DarcsFlag] -> PatchSet p C(Origin r)-                 -> ((PatchSet p) :> (FL (PatchInfoAnd p))) C(Origin r)-getLastPatches opts ps =-  case matchFirstPatchset opts ps of-  Sealed p1s -> findCommonWithThem ps p1s--unpullDescription :: String-unpullDescription =- "Opposite of pull; unsafe if patch is not in remote repository."--unpullHelp :: String-unpullHelp =- "Unpull completely removes recorded patches from your local repository.\n"++- "The changes will be undone in your working copy and the patches will not be\n"++- "shown in your changes list anymore.\n"++- "Beware that if the patches are not still present in another repository you\n"++- "will lose precious code by unpulling!\n"--unpull :: DarcsCommand-unpull = (commandAlias "unpull" Nothing obliterate)-                      {commandHelp = unpullHelp,-                       commandDescription = unpullDescription,-                       commandCommand = unpullCmd}--unpullCmd :: [DarcsFlag] -> [String] -> IO ()-unpullCmd = genericObliterateCmd "unpull"---obliterateDescription :: String-obliterateDescription =- "Delete selected patches from the repository. (UNSAFE!)"--obliterateHelp :: String-obliterateHelp =- "Obliterate completely removes recorded patches from your local repository.\n"++- "The changes will be undone in your working copy and the patches will not be\n"++- "shown in your changes list anymore.\n"++- "Beware that you can lose precious code by obliterating!\n"--obliterate :: DarcsCommand-obliterate = DarcsCommand {commandProgramName = "darcs",-                           commandName = "obliterate",-                           commandHelp = obliterateHelp,-                           commandDescription = obliterateDescription,-                           commandExtraArgs = 0,-                           commandExtraArgHelp = [],-                           commandCommand = obliterateCmd,-                           commandPrereq = amInHashedRepository,-                           commandGetArgPossibilities = return [],-                           commandArgdefaults = nodefaults,-                           commandAdvancedOptions = [nocompress,ignoretimes,umaskOption, changesReverse],-                           commandBasicOptions = [matchSeveralOrLast,-                                                   depsSel,-                                                   allInteractive,-                                                   workingRepoDir,-                                                   summary,-                                                   output,-                                                   outputAutoName]++-                                                   dryRun}-obliterateCmd :: [DarcsFlag] -> [String] -> IO ()-obliterateCmd = genericObliterateCmd "obliterate"---- | genericObliterateCmd is the function that executes the "obliterate" and---   "unpull" commands.-genericObliterateCmd :: String      -- ^ The name under which the command is invoked (@unpull@ or @obliterate@)-                       -> [DarcsFlag] -- ^ The flags given on the command line-                       -> [String]    -- ^ Files given on the command line (unused)-                       -> IO ()-genericObliterateCmd cmdname opts _ = withRepoLock opts $ RepoJob $ \repository -> do-  -- FIXME we may need to honour --ignore-times here, although this command-  -- does not take that option (yet)-  pend <- unrecordedChanges (UseIndex, ScanKnown) repository Nothing-  allpatches <- readRepo repository-  (auto_kept :> removal_candidates) <- return $-                                        if firstMatch opts-                                        then getLastPatches opts allpatches-                                        else matchingHead opts allpatches-  let-      context = selectionContext cmdname opts Nothing Nothing-      selector = if doReverse opts-                 then selectChanges Last-                 else selectChanges LastReversed-  (kept :> removed) <- runSelection (selector removal_candidates) context-  when (nullFL removed) $ do putStrLn "No patches selected!"-                             exitWith ExitSuccess-  case commute (effect removed :> pend) of-    Nothing -> fail $ "Can't "++ cmdname ++-               " patch without reverting some unrecorded change."-    Just (_ :> p_after_pending) -> do-        printDryRunMessageAndExit "obliterate" opts removed-        setEnvDarcsPatches removed-        when (isJust $ getOutput opts "") $-             savetoBundle opts (auto_kept `appendPSFL` kept) removed-        invalidateIndex repository-        withGutsOf repository $--- Warning:  A do-notation statement discarded a result of type Darcs.Repository.InternalTypes.Repository p r u z.-                             do _ <- tentativelyRemovePatches repository (compression opts) removed-                                tentativelyAddToPending repository opts $ invert $ effect removed-                                finalizeRepositoryChanges repository-                                debugMessage "Applying patches to working directory..."-                                _ <- applyToWorking repository opts (invert p_after_pending) `catch` \(e :: IOException) ->-                                    fail ("Couldn't undo patch in working dir.\n" ++ show e)-                                return ()-        putStrLn $ "Finished " ++ presentParticiple cmdname ++ "."---- | matchingHead returns the repository up to some tag. The tag t is--- the last tag such that there is a patch after t that is matched by--- the user's query.-matchingHead :: forall p C(r). RepoPatch p =>-                [DarcsFlag] -> PatchSet p C(Origin r)-             -> (PatchSet p :> FL (PatchInfoAnd p)) C(Origin r)-matchingHead opts set =-    case mh set of-      (start :> patches) -> (start :> reverseRL patches)-    where-      mh :: FORALL(x) PatchSet p C(Origin x)-         -> (PatchSet p :> RL (PatchInfoAnd p)) C(Origin x)-      mh s@(PatchSet x _)-          | or (mapRL (matchAPatchread opts) x) = contextPatches s-      mh (PatchSet x (Tagged t _ ps :<: ts))-          = case mh (PatchSet (t:<:ps) ts)-            of (start :> patches) -> (start :> x +<+ patches)-      mh ps = (ps :> NilRL)--savetoBundle :: (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag]-             -> PatchSet p C(Origin z) -> FL (PatchInfoAnd p) C(z t)-             -> IO ()-savetoBundle opts kept removed@(x :>: _) = do-    bundle <- makeBundleN Nothing kept (mapFL_FL hopefully removed)-    let filename = patchFilename $ patchDesc x-        Just outname = getOutput opts filename-    useAbsoluteOrStd writeDocBinFile putDoc outname $ bundle--savetoBundle _ _ NilFL = return ()-
− src/Darcs/Commands/Unrevert.hs 
@@ -1,139 +0,0 @@---  Copyright (C) 2003-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, GADTs #-}--#include "gadts.h"--module Darcs.Commands.Unrevert ( unrevert, writeUnrevert ) where--import Prelude hiding ( catch )--import Control.Exception ( catch, IOException )-import System.Exit ( ExitCode(..), exitWith )-import Storage.Hashed.Tree( Tree )--import Darcs.Commands ( DarcsCommand(..), nodefaults )-import Darcs.Flags( diffingOpts )-import Darcs.Arguments ( DarcsFlag( MarkConflicts ),-                         ignoretimes, workingRepoDir,-                        allInteractive, umaskOption, unified-                      )-import Darcs.Repository ( SealedPatchSet, Repository, withRepoLock, RepoJob(..),-                          unrevertUrl, considerMergeToWorking,-                          tentativelyAddToPending, finalizeRepositoryChanges,-                          readRepo, amInHashedRepository,-                          readRecorded,-                          applyToWorking, unrecordedChanges )-import Darcs.Patch ( RepoPatch, PrimOf, commute, namepatch, fromPrims )-import Darcs.Patch.Apply( ApplyState )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (+>+) )-import Darcs.SelectChanges ( selectChanges, WhichChanges(First),-                             runSelection, selectionContextPrim )-import qualified Data.ByteString as B-import Darcs.Lock ( writeDocBinFile, removeFileMayNotExist )-import Darcs.Patch.Depends ( mergeThem )-import Darcs.Utils ( askUser, catchall )-import Darcs.Patch.Bundle ( scanBundle, makeBundleN )-import IsoDate ( getIsoDateTime )-import Darcs.SignalHandler ( withSignalsBlocked )-import Progress ( debugMessage )-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-#include "impossible.h"--unrevertDescription :: String-unrevertDescription =- "Undo the last revert (may fail if changes after the revert)."--unrevertHelp :: String-unrevertHelp =- "Unrevert is a rescue command in case you accidentally reverted\n" ++- "something you wanted to keep (for example, typing `darcs rev -a'\n" ++- "instead of `darcs rec -a').\n" ++- "\n" ++- "This command may fail if the repository has changed since the revert\n" ++- "took place.  Darcs will ask for confirmation before executing an\n" ++- "interactive command that will DEFINITELY prevent unreversion.\n"--unrevert :: DarcsCommand-unrevert = DarcsCommand {commandProgramName = "darcs",-                         commandName = "unrevert",-                         commandHelp = unrevertHelp,-                         commandDescription = unrevertDescription,-                         commandExtraArgs = 0,-                         commandExtraArgHelp = [],-                         commandCommand = unrevertCmd,-                         commandPrereq = amInHashedRepository,-                         commandGetArgPossibilities = return [],-                         commandArgdefaults = nodefaults,-                         commandAdvancedOptions = [umaskOption],-                         commandBasicOptions = [ignoretimes,-                                                  allInteractive,-                                                  workingRepoDir,-                                                  unified]}--unrevertCmd :: [DarcsFlag] -> [String] -> IO ()-unrevertCmd opts [] = withRepoLock opts $ RepoJob $ \repository -> do-  us <- readRepo repository-  Sealed them <- unrevertPatchBundle repository-  rec <- readRecorded repository-  unrec <- unrecordedChanges (diffingOpts opts {- always ScanKnown here -}) repository Nothing-  Sealed h_them <- return $ mergeThem us them-  Sealed pw <- considerMergeToWorking repository "pull" (MarkConflicts:opts) NilFL h_them-  let context = selectionContextPrim "unrevert" opts Nothing Nothing (Just rec)-  (p :> skipped) <- runSelection (selectChanges First pw) context-  tentativelyAddToPending repository opts p-  withSignalsBlocked $-      do finalizeRepositoryChanges repository-         _ <- applyToWorking repository opts p `catch` \(e :: IOException) ->-             fail ("Error applying unrevert to working directory...\n"-                   ++ show e)-         debugMessage "I'm about to writeUnrevert."-         writeUnrevert repository skipped rec (unrec+>+p)-  debugMessage "Finished unreverting."-unrevertCmd _ _ = impossible--writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree)-              => Repository p C(r u t) -> FL (PrimOf p) C(x y)-              -> Tree IO -> FL (PrimOf p) C(r x) -> IO ()-writeUnrevert repository NilFL _ _ = removeFileMayNotExist $ unrevertUrl repository-writeUnrevert repository ps rec pend = do-  case commute (pend :> ps) of-    Nothing -> do really <- askUser "You will not be able to unrevert this operation! Proceed? "-                  case really of ('y':_) -> return ()-                                 _ -> exitWith $ ExitSuccess-                  writeUnrevert repository NilFL rec pend-    Just (p' :> _) -> do-        rep <- readRepo repository-        date <- getIsoDateTime-        np <- namepatch date "unrevert" "anon" [] (fromRepoPrims repository p')-        bundle <- makeBundleN (Just rec) rep (np :>: NilFL)-        writeDocBinFile (unrevertUrl repository) bundle-        where fromRepoPrims :: RepoPatch p => Repository p C(r u t) -> FL (PrimOf p) C(r y) -> FL p C(r y)-              fromRepoPrims _ xs = fromPrims xs--unrevertPatchBundle :: RepoPatch p => Repository p C(r u t) -> IO (SealedPatchSet p C(Origin))-unrevertPatchBundle repository = do-  pf <- B.readFile (unrevertUrl repository)-        `catchall` fail "There's nothing to unrevert!"-  case scanBundle pf of-      Right ps -> return ps-      Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err-
− src/Darcs/Commands/Util.hs 
@@ -1,60 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Commands.Util ( announceFiles, filterExistingFiles ) where--import Darcs.Arguments ( DarcsFlag(LookForAdds) )-import Darcs.Patch ( RepoPatch )-import Darcs.RepoPath ( SubPath, toFilePath )-import Darcs.Repository ( Repository, extractOptions, readRecorded,-    readUnrecorded )-import Darcs.Repository.State ( applyTreeFilter, restrictBoring )-import Darcs.Patch.Apply ( ApplyState )-import Storage.Hashed( floatPath, readPlainTree )-import Storage.Hashed.Tree( Tree )-import Storage.Hashed.Monad ( virtualTreeIO, exists )--announceFiles :: Maybe [SubPath] -> String -> IO ()-announceFiles Nothing _ = return ()-announceFiles (Just files) message = putStrLn $ message ++ " " ++-    unwords (map show files) ++ ":\n"--filterExistingFiles :: (RepoPatch p, ApplyState p ~ Tree)-                    => Repository p C(r u t) -> [SubPath] -> IO [SubPath]-filterExistingFiles repo files = do-      pristine <- readRecorded repo-      -- TODO this is slightly inefficient, since we should really somehow-      -- extract the unrecorded state as a side-effect of unrecordedChanges-      index <- readUnrecorded repo $ Just files-      nonboring <- restrictBoring index-      working <- applyTreeFilter nonboring `fmap` readPlainTree "."-      let paths = map toFilePath files-          check = virtualTreeIO (mapM exists $ map floatPath paths)-      (in_working, _) <- check working-      (in_pristine, _) <- check pristine-      mapM_ maybe_warn $ zip3 paths in_working in_pristine-      return [ path | (path, True) <- zip files (zipWith (||) in_working in_pristine) ]-    where maybe_warn (file, False, False) =-              putStrLn $ "WARNING: File '"++file++"' does not exist!"-          maybe_warn (file, True, False) | LookForAdds `notElem` extractOptions repo =-              putStrLn $ "WARNING: File '" ++ file ++ "' not in repository!"-          maybe_warn _ = return ()-
− src/Darcs/Commands/WhatsNew.hs 
@@ -1,193 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Commands.WhatsNew-    (-      whatsnew-    , status-    ) where--import Control.Applicative ( (<$>) )-import Data.List ( delete )-import System.Exit ( ExitCode(..), exitWith )--import Storage.Hashed.Tree( Tree )--import Darcs.Arguments ( DarcsFlag(..), workingRepoDir, lookforadds,-                         ignoretimes, noskipBoring, unified, summary,-                         fixSubPaths, listRegisteredFiles )-import Darcs.Commands ( DarcsCommand(..), nodefaults, commandAlias )-import Darcs.Commands.Util ( announceFiles )-import Darcs.Diff( treeDiff )-import Darcs.Flags( isUnified, diffingOpts )-import Darcs.Patch ( RepoPatch, PrimPatch, PrimOf, plainSummaryPrims,-                     primIsHunk, applyToTree )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Format ( PatchListFormat(..) )-import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Patchy ( Patchy )-import Darcs.Patch.Permutations ( partitionRL )-import Darcs.Patch.Prim.Class ( PrimDetails(..) )-import Darcs.Patch.TouchesFiles( choosePreTouching )-import Darcs.RepoPath( SubPath, toFilePath )-import Darcs.Repository ( Repository, withRepository, RepoJob(..)-                        , amInRepository-                        , unrecordedChanges, readRecorded )-import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.PrintPatch ( printPatch, contextualPrintPatch )-import Darcs.Witnesses.Ordered ( FL(..), reverseRL, reverseFL, (:>)(..) )-import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft )-import Printer ( putDocLn, renderString, vcat, text )--whatsnew :: DarcsCommand-whatsnew = DarcsCommand { commandProgramName = "darcs"-                        , commandName = "whatsnew"-                        , commandHelp = whatsnewHelp-                        , commandDescription = whatsnewDescription-                        , commandExtraArgs = -1-                        , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]-                        , commandCommand = whatsnewCmd-                        , commandPrereq = amInRepository-                        , commandGetArgPossibilities = listRegisteredFiles-                        , commandArgdefaults = nodefaults-                        , commandAdvancedOptions = [ignoretimes, noskipBoring]-                        , commandBasicOptions = [ summary-                                                , unified-                                                , lookforadds-                                                , workingRepoDir-                                                ]-                        }--whatsnewDescription :: String-whatsnewDescription = "List unrecorded changes in the working tree."--whatsnewHelp :: String-whatsnewHelp =- "The `darcs whatsnew' command lists unrecorded changes to the working\n" ++- "tree.  If you specify a set of files and directories, only unrecorded\n" ++- "changes to those files and directories are listed.\n" ++- "\n" ++- "With the --summary option, the changes are condensed to one line per\n" ++- "file, with mnemonics to indicate the nature and extent of the change.\n" ++- "The --look-for-adds option causes candidates for `darcs add' to be\n" ++- "included in the summary output.  Summary mnemonics are as follows:\n" ++- "\n" ++- "  `A f' and `A d/' respectively mean an added file or directory.\n" ++- "  `R f' and `R d/' respectively mean a removed file or directory.\n" ++- "  `M f -N +M rP' means a modified file, with N lines deleted, M\n" ++- "  lines added, and P lexical replacements.\n" ++- "  `f -> g' means a moved file or directory.\n" ++- "  `a f' and `a d/' respectively mean a new, but unadded, file or\n" ++- "  directory, when using --look-for-adds.\n" ++- "\n" ++- "  An exclamation mark (!) as in `R! foo.c', means the hunk is known to\n" ++- "  conflict with a hunk in another patch.  The phrase `duplicated'\n" ++- "  means the hunk is known to be identical to a hunk in another patch.\n" ++- "\n" ++- "By default, `darcs whatsnew' uses Darcs' internal format for changes.\n" ++- "To see some context (unchanged lines) around each change, use the\n" ++- "--unified option.  To view changes in conventional `diff' format, use\n" ++- "the `darcs diff' command; but note that `darcs whatsnew' is faster.\n" ++- "\n" ++- "This command exits unsuccessfully (returns a non-zero exit status) if\n" ++- "there are no unrecorded changes.\n"--whatsnewCmd :: [DarcsFlag] -> [String] -> IO ()-whatsnewCmd opts args =-   withRepository opts $ RepoJob $ \(repo :: Repository p C(r u r)) -> do-    files <- if null args-                 then return Nothing-                 else Just <$> fixSubPaths opts args-    let isLookForAdds = LookForAdds `elem` opts && NoSummary `notElem` opts-        -- LookForAdds implies Summary, unless it's explcitly disabled.-        optsModifier = if isLookForAdds-                           then (Summary :) . (LookForAdds `delete`)-                           else id-        opts' = optsModifier opts-    Sealed noLookChanges <- filteredUnrecordedChanges opts' repo files-    pristine <- readRecorded repo-    -- If we are looking for adds, return the corresponding FL of changes.-    Sealed unaddedNewPathsPs <- if isLookForAdds-        then do-            -- Use opts not opts', here, since we *do* want to look for adds.-            Sealed lookChanges <- filteredUnrecordedChanges opts repo files-            noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine-            lookAddsTree <- applyAddPatchesToPristine lookChanges pristine-            ftf <- filetypeFunction-            -- Return the patches that create files/dirs that aren't yet added.-            unFreeLeft <$> treeDiff ftf noLookAddsTree lookAddsTree-        else return (Sealed NilFL)-    announceFiles files "What's new in"-    exitOnNoChanges (unaddedNewPathsPs, noLookChanges)-    printChanges opts' pristine noLookChanges-    printUnaddedPaths unaddedNewPathsPs-  where-    -- |Filter out hunk patches (leaving add patches) and return the tree-    -- resulting from applying the filtered patches to the pristine tree.-    applyAddPatchesToPristine ps pristine = do-        adds :> _ <- return $ partitionRL primIsHunk $ reverseFL ps-        applyToTree (reverseRL adds) pristine--    exitOnNoChanges :: (FL p C(x y), FL p C(u v)) -> IO ()-    exitOnNoChanges (NilFL, NilFL) = do putStrLn "No changes!"-                                        exitWith $ ExitFailure 1-    exitOnNoChanges _ = return ()--    printUnaddedPaths :: PrimPatch p => FL p C(x y) -> IO ()-    printUnaddedPaths NilFL = return ()-    printUnaddedPaths ps =-        putDocLn . lowercaseAs . renderString . plainSummaryPrims $ ps--    -- Make any add markers lowercase, to distinguish new-but-unadded files-    -- from those that are unrecorded, but added.-    lowercaseAs x = vcat $ map (text . lowercaseA) $ lines x-    lowercaseA ('A' : x) = 'a' : x-    lowercaseA x = x--    -- |Appropriately print changes, according to the passed flags.-    printChanges :: (PatchListFormat p, IsHunk p, Patchy p, PrimDetails p,-                 ApplyState p ~ Tree) => [DarcsFlag] -> Tree IO -> FL p C(x y)-                 -> IO ()-    printChanges opts' pristine changes-        | Summary `elem` opts' = putDocLn $ plainSummaryPrims changes-        | isUnified opts' = contextualPrintPatch pristine changes-        | otherwise = printPatch changes--    -- |return the unrecorded changes that affect an optional list of paths.-    filteredUnrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree,-                              ApplyState (PrimOf p) ~ Tree) => [DarcsFlag]-                              -> Repository p C(r u t) -> Maybe [SubPath]-                              -> IO (Sealed (FL (PrimOf p) C(t)))-    filteredUnrecordedChanges  opts' repo files =-        let filePaths = map toFilePath <$> files in-        let diffOpts = diffingOpts opts' in-        choosePreTouching filePaths <$> unrecordedChanges diffOpts repo files---- |status is an alias for whatsnew, with implicit Summary and LookForAdds--- flags. We override the default description, to include the implicit flags.-status :: DarcsCommand-status = statusAlias { commandCommand = statusCmd-                     , commandDescription = statusDesc-                     }-  where-    statusAlias = commandAlias "status" Nothing whatsnew-    statusCmd fs = commandCommand whatsnew (Summary : LookForAdds : fs)-    statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls '."
− src/Darcs/CommandsAux.hs 
@@ -1,122 +0,0 @@--- Copyright (C) 2006 Tommy Pettersson <ptp@lysator.liu.se>------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.CommandsAux ( checkPaths, maliciousPatches, hasMaliciousPath,-                           isMaliciousPath, isMaliciousSubPath,-                        ) where-import Darcs.Flags ( DarcsFlag( RestrictPaths, DontRestrictPaths ) )-import Darcs.Patch ( Patchy, listTouchedFiles )-import Darcs.Witnesses.Ordered ( FL, mapFL )-import Darcs.Witnesses.Sealed ( Sealed2(..), unseal2 )-import Darcs.Global ( darcsdir )-import Data.List ( intersect )-import System.FilePath ( splitDirectories, isRelative )---- * File paths-{--  Darcs will operate on files and directories with the invoking user's-  privileges. The paths for these files and directories are stored in-  patches, which darcs receives in various ways. Even though darcs will not-  create patches with "unexpected" file paths, there are no such guarantees-  for received patches. A spoofed patch could inflict changes on any file-  or directory which the invoking user is privileged to modify.--  There is no one single "apply" function that can check paths, so each-  command is responsible for not applying patches without first checking-  them with one of these function when appropriate.--}--{- |-  A convenience function to call from all darcs command functions before-  applying any patches. It checks for malicious paths in patches, and-  prints an error message and fails if it finds one.--}-checkPaths :: Patchy p => [DarcsFlag] -> FL p C(x y) -> IO ()-checkPaths opts patches-  = if check_is_on  && or (mapFL hasMaliciousPath patches)-      then fail $ unlines $ ["Malicious path in patch:"] ++-                            (map (\s -> "    " ++ s) $ concat $ mapFL maliciousPaths patches) ++-                            ["", "If you are sure this is ok then you can run again with the --dont-restrict-paths option."]-           -- TODO: print patch(es)-           -- NOTE: should use safe Doc printer, this can be evil chars-      else return ()- where-    check_is_on = DontRestrictPaths `notElem` opts  ||-                  RestrictPaths        `elem` opts---- | Filter out patches that contains some malicious file path-maliciousPatches :: Patchy p => [Sealed2 p] -> [Sealed2 p]-maliciousPatches to_check = filter (unseal2 hasMaliciousPath) to_check--hasMaliciousPath :: Patchy p => p C(x y) -> Bool-hasMaliciousPath patch =-    case maliciousPaths patch of-      [] -> False-      _ -> True--maliciousPaths :: Patchy p => p C(x y) -> [String]-maliciousPaths patch =-  let paths = listTouchedFiles patch in-    filter isMaliciousPath paths--{-|-  What is a malicious path?--  A spoofed path is a malicious path.--  1. Darcs only creates explicitly relative paths (beginning with @\".\/\"@),-     so any not explicitly relative path is surely spoofed.--  2. Darcs normalizes paths so they never contain @\"\/..\/\"@, so paths with-     @\"\/..\/\"@ are surely spoofed.--  A path to a darcs repository's meta data can modify \"trusted\" patches or-  change safety defaults in that repository, so we check for paths-  containing @\"\/_darcs\/\"@ which is the entry to darcs meta data.--  To do?--  * How about get repositories?--  * Would it be worth adding a --semi-safe-paths option for allowing-    changes to certain preference files (_darcs\/prefs\/) in sub-    repositories'?--}-isMaliciousPath :: String -> Bool-isMaliciousPath fp =-    not (isExplicitlyRelative fp) || isGenerallyMalicious fp---- | Warning : this is less rigorous than isMaliciousPath---   but it's to allow for subpath representations that---   don't start with ./-isMaliciousSubPath :: String -> Bool-isMaliciousSubPath fp =-    not (isRelative fp) || isGenerallyMalicious fp--isGenerallyMalicious :: String -> Bool-isGenerallyMalicious fp =-    splitDirectories fp `contains_any` [ "..", darcsdir ]- where-    contains_any a b = not . null $ intersect a b--isExplicitlyRelative :: String -> Bool-isExplicitlyRelative ('.':'/':_) = True  -- begins with "./"-isExplicitlyRelative _ = False
− src/Darcs/Compat.hs 
@@ -1,126 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--module Darcs.Compat (stdoutIsAPipe, mkStdoutTemp, canonFilename,-               maybeRelink, atomicCreate, sloppyAtomicCreate) where--import Prelude hiding ( catch )--import Darcs.Utils ( withCurrentDirectory )-#ifdef WIN32-import Darcs.Utils ( showHexLen )-import Data.Bits ( (.&.) )-import System.Random ( randomIO )-#else-import Foreign.C.String ( peekCString )-#endif--import Control.Monad ( unless )-import Foreign.C.Types ( CInt(..) )-import Foreign.C.String ( CString, withCString )-import Foreign.C.Error ( throwErrno, eEXIST, getErrno )-import System.Directory ( getCurrentDirectory )-import System.IO ( hFlush, stdout, stderr, hSetBuffering,-                   BufferMode(NoBuffering) )-import System.IO.Error ( mkIOError, alreadyExistsErrorType )-import System.Posix.Files ( stdFileMode )-import System.Posix.IO ( openFd, closeFd, stdOutput, stdError,-                         dupTo, defaultFileFlags, exclusive,-                         OpenMode(WriteOnly) )-import System.Posix.Types ( Fd(..) )--import Darcs.SignalHandler ( stdoutIsAPipe )--canonFilename :: FilePath -> IO FilePath-canonFilename f@(_:':':_) = return f -- absolute windows paths-canonFilename f@('/':_) = return f-canonFilename ('.':'/':f) = do cd <- getCurrentDirectory-                               return $ cd ++ "/" ++ f-canonFilename f = case reverse $ dropWhile (/='/') $ reverse f of-                  "" -> fmap (++('/':f)) getCurrentDirectory-                  rd -> withCurrentDirectory rd $-                          do fd <- getCurrentDirectory-                             return $ fd ++ "/" ++ simplefilename-    where-    simplefilename = reverse $ takeWhile (/='/') $ reverse f--#ifdef WIN32-mkstempCore :: FilePath -> IO (Fd, String)-mkstempCore fp- = do r <- randomIO-      let fp' = fp ++ (showHexLen 6 (r .&. 0xFFFFFF :: Int))-      fd <- openFd fp' WriteOnly (Just stdFileMode) flags-      return (fd, fp')-  where flags = defaultFileFlags { exclusive = True }-#else-mkstempCore :: String -> IO (Fd, String)-mkstempCore str = withCString (str++"XXXXXX") $-    \cstr -> do fd <- c_mkstemp cstr-                if fd < 0-                  then throwErrno $ "Failed to create temporary file "++str-                  else do str' <- peekCString cstr-                          fname <- canonFilename str'-                          return (Fd fd, fname)--foreign import ccall unsafe "static stdlib.h mkstemp"-    c_mkstemp :: CString -> IO CInt-#endif--mkStdoutTemp :: String -> IO String-mkStdoutTemp str =   do (fd, fn) <- mkstempCore str-                        hFlush stdout-                        hFlush stderr--- Warning:  A do-notation statement discarded a result of type Fd.-                        _ <- dupTo fd stdOutput--- Warning:  A do-notation statement discarded a result of type Fd.-                        _ <- dupTo fd stdError-                        hFlush stdout-                        hFlush stderr-                        hSetBuffering stdout NoBuffering-                        hSetBuffering stderr NoBuffering-                        return fn----foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink-    :: CString -> CString -> CInt -> IO CInt---- Checks whether src and dst are identical.  If so, makes dst into a--- link to src.  Returns True if dst is a link to src (either because--- we linked it or it already was).  Safe against changes to src if--- they are not in place, but not to dst.-maybeRelink :: String -> String -> IO Bool-maybeRelink src dst =-    withCString src $ \csrc ->-    withCString dst $ \cdst ->-    do rc <- maybe_relink csrc cdst 1-       (case rc of-        0 -> return True-        1 -> return True-        -1 -> throwErrno ("Relinking " ++ dst)-        -2 -> return False-        -3 -> do putStrLn ("Relinking: race condition avoided on file " ++-                            dst)-                 return False-        _ -> fail ("Unexpected situation when relinking " ++ dst))--sloppyAtomicCreate :: FilePath -> IO ()-sloppyAtomicCreate fp-    = do fd <- openFd fp WriteOnly (Just stdFileMode) flags-         closeFd fd-  where flags = defaultFileFlags { exclusive = True }--atomicCreate :: FilePath -> IO ()-atomicCreate fp = withCString fp $ \cstr -> do-    rc <- c_atomic_create cstr-    unless (rc >= 0) $-           do errno <- getErrno-              pwd <- getCurrentDirectory-              if errno == eEXIST-                 then ioError $ mkIOError alreadyExistsErrorType-                                          ("atomicCreate in "++pwd)-                                          Nothing (Just fp)-                 else throwErrno $ "atomicCreate "++fp++" in "++pwd--foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create-    :: CString -> IO CInt
− src/Darcs/Diff.hs 
@@ -1,156 +0,0 @@--- Copyright (C) 2009 Petr Rockai------ 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--- SOFTWARE.---- |--- Module      : Darcs.Diff--- Copyright   : 2009 Petr Rockai--- License     : MIT--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Darcs.Diff-    (-      treeDiff-    ) where---import qualified Data.ByteString.Lazy.Char8 as BLC-import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BL--import Data.List ( sortBy )--import Storage.Hashed.Tree  ( diffTrees-                            , zipTrees-                            , TreeItem(..)-                            , Tree-                            , readBlob-                            , emptyBlob-                            )-import Storage.Hashed.AnchoredPath( AnchoredPath, anchorPath )---import ByteStringUtils ( isFunky )-import Darcs.Patch  ( PrimPatch-                    , hunk-                    , canonize-                    , binary-                    , addfile-                    , rmfile-                    , adddir-                    , rmdir-                    , invert-                    )-import Darcs.Repository.Prefs ( FileType(..) )-import Darcs.Witnesses.Ordered  ( FL(..)-                                , (+>+)-                                )-import Darcs.Witnesses.Sealed ( Gap(..) )---#include "gadts.h"-#include "impossible.h"---data Diff m = Added (TreeItem m)-            | Removed (TreeItem m)-            | Changed (TreeItem m) (TreeItem m)---getDiff :: AnchoredPath-        -> Maybe (TreeItem m)-        -> Maybe (TreeItem m)-        -> (AnchoredPath, Diff m)-getDiff p Nothing (Just t) = (p, Added t)-getDiff p (Just from) (Just to) = (p, Changed from to)-getDiff p (Just t) Nothing = (p, Removed t)-getDiff _ Nothing Nothing = impossible -- zipTrees should never return this---treeDiff :: forall m w prim . (Functor m, Monad m, Gap w, PrimPatch prim)-         => (FilePath -> FileType)-         -> Tree m-         -> Tree m-         -> m (w (FL prim))-treeDiff ft t1 t2 = do-    (from, to) <- diffTrees t1 t2-    diffs <- mapM (uncurry diff) $ sortBy organise $ zipTrees getDiff from to-    return $ foldr (joinGap (+>+)) (emptyGap NilFL) diffs-  where-    -- sort into removes, changes, adds, with removes in reverse-path order-    -- and everything else in forward order-    organise :: (AnchoredPath, Diff m) -> (AnchoredPath, Diff m) -> Ordering--    organise (p1, Changed _ _ ) (p2, Changed _ _) = compare p1 p2-    organise (p1, Added _)      (p2, Added _)   = compare p1 p2-    organise (p1, Removed _)    (p2, Removed _) = compare p2 p1--    organise (_, Removed _) _ = LT-    organise _ (_, Removed _) = GT--    organise (_, Changed _ _) _ = LT-    organise _ (_, Changed _ _) = GT--    diff :: AnchoredPath -> Diff m -> m (w (FL prim))-    diff _ (Changed (SubTree _) (SubTree _)) = return (emptyGap NilFL)-    diff p (Removed (SubTree _)) =-        return $ freeGap (rmdir (anchorPath "" p) :>: NilFL)-    diff p (Added (SubTree _)) =-        return $ freeGap (adddir (anchorPath "" p) :>: NilFL)-    diff p (Added b'@(File _)) =-        do diff' <- diff p (Changed (File emptyBlob) b')-           return $ joinGap (:>:) (freeGap (addfile (anchorPath "" p))) diff'-    diff p (Removed a'@(File _)) =-        do diff' <- diff p (Changed a' (File emptyBlob))-           return $ joinGap (+>+) diff' (freeGap (rmfile (anchorPath "" p) :>: NilFL))-    diff p (Changed (File a') (File b')) =-        do a <- readBlob a'-           b <- readBlob b'-           let path = anchorPath "" p-           case ft path of-             TextFile | no_bin a && no_bin b ->-                          return $ text_diff path a b-             _ -> return $ if a /= b-                              then freeGap (binary path (strict a) (strict b) :>: NilFL)-                              else emptyGap NilFL-    diff p _ = fail $ "Missing case at path " ++ show p--    text_diff p a b-        | BL.null a && BL.null b = emptyGap NilFL-        | BL.null a = freeGap (diff_from_empty p b)-        | BL.null b = freeGap (diff_to_empty p a)-        | otherwise = freeGap (line_diff p (linesB a) (linesB b))--    line_diff p a b = canonize (hunk p 1 a b)--    diff_to_empty p x | BLC.last x == '\n' = line_diff p (init $ linesB x) []-                      | otherwise = line_diff p (linesB x) [BS.empty]--    diff_from_empty p x = invert (diff_to_empty p x)--    no_bin = not . isFunky . strict . BL.take 4096--    linesB = map strict . BLC.split '\n'--    strict = BS.concat . BL.toChunks-
− src/Darcs/Email.hs 
@@ -1,248 +0,0 @@-{-# LANGUAGE CPP #-}-module Darcs.Email ( makeEmail, readEmail, formatHeader ) where--import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper )-import Data.List ( isInfixOf )-import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS)--import ByteStringUtils ( packStringToUTF8, dropSpace, linesPS, betweenLinesPS )-import qualified Data.ByteString          as B  (ByteString, length, null, tail-                                                ,drop, head, concat, singleton-                                                ,pack, append, empty, unpack-                                                )-import qualified Data.ByteString.Char8    as BC (index, head, pack)-import Data.ByteString.Internal as B (c2w, createAndTrim)-import System.IO.Unsafe ( unsafePerformIO )-import Foreign.Ptr ( Ptr, plusPtr )-import Foreign.Storable ( poke )-import Data.Word ( Word8 )-import Data.Maybe ( fromMaybe )---- lineMax is maximum number of characters in an e-mail line excluding the CRLF--- at the end. qlineMax is the number of characters in a q-encoded or--- quoted-printable-encoded line.-lineMax, qlineMax :: Int-lineMax  = 78-qlineMax = 75---- | Formats an e-mail header by encoding any non-ascii characters using UTF-8---   and Q-encoding, and folding lines at appropriate points. It doesn't do---   more than that, so the header name and header value should be---   well-formatted give or take line length and encoding. So no non-ASCII---   characters within quoted-string, quoted-pair, or atom; no semantically---   meaningful signs in names; no non-ASCII characters in the header name;---   etcetera.-formatHeader :: String -> String -> B.ByteString-formatHeader headerName headerValue =-    B.append nameColon encodedValue-  where nameColon = B.pack (map B.c2w (headerName ++ ":")) -- space for folding-        encodedValue = foldAndEncode (' ':headerValue)-                                       (B.length nameColon) False False---- run through a string and encode non-ascii words and fold where appropriate.--- the integer argument is the current position in the current line.--- the string in the first argument must begin with whitespace, or be empty.-foldAndEncode :: String -> Int -> Bool -> Bool -> B.ByteString-foldAndEncode [] _ _               _         = B.empty-foldAndEncode s  p lastWordEncoded inMidWord =-  let newline  = B.singleton 10-      space    = B.singleton 32-      s2bs     = B.pack . map B.c2w-      -- the twelve there is the max number of ASCII chars to encode a single-      -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte-      safeEncChunkLength = (qlineMax - B.length encodedWordStart-                                      - B.length encodedWordEnd) `div` 12-      (curSpace, afterCurSpace) = span (== ' ') s-      (curWord,  afterCurWord)  = break (== ' ') afterCurSpace-      qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord)-               | otherwise       = qEncode curWord-      mustEncode = inMidWord-                   || any (\c -> not (isPrint c) || (ord c) > 127) curWord-                   || length curWord > lineMax - 1-                   || isInfixOf "=?" curWord-      mustFold-        | mustEncode && lastWordEncoded-            = p + 1 + B.length qEncWord > lineMax-        | mustEncode-            = p + length curSpace + B.length qEncWord > lineMax-        | otherwise-            = p + length curSpace + length curWord > lineMax-      mustSplit = (B.length qEncWord > qlineMax && mustEncode)-                  || length curWord > lineMax - 1-      spaceToInsert | mustEncode && lastWordEncoded = space-                    | otherwise                     = s2bs curSpace-      wordToInsert-        | mustEncode && mustSplit = qEncode (take safeEncChunkLength curWord)-        | mustEncode = qEncWord-        | otherwise  = s2bs curWord-      doneChunk | mustFold  = B.concat [newline, spaceToInsert, wordToInsert]-                | otherwise = B.concat [spaceToInsert, wordToInsert]-      (rest, nextP)-        | mustSplit-            = (drop safeEncChunkLength curWord ++ afterCurWord, qlineMax + 1)-        | mustEncode && mustFold-            = (afterCurWord, B.length spaceToInsert + B.length wordToInsert)-        | otherwise-            = (afterCurWord, p + B.length doneChunk)-  in B.append doneChunk (foldAndEncode rest nextP mustEncode mustSplit)---- | Turns a piece of string into a q-encoded block---   Applies q-encoding, for use in e-mail header values, as defined in RFC 2047.---   It just takes a string and builds an encoded-word from it, it does not check---   length or necessity.-qEncode :: String -> B.ByteString-qEncode s = B.concat [encodedWordStart,-                      encodedString,-                      encodedWordEnd]-  where encodedString =  B.concat (map qEncodeChar s)--encodedWordStart, encodedWordEnd :: B.ByteString-encodedWordStart = B.pack (map B.c2w "=?UTF-8?Q?")-encodedWordEnd   = B.pack (map B.c2w "?=")---- turns a character into its q-encoded bytestring value. For most printable--- ASCII characters, that's just the singleton bytestring with that char.-qEncodeChar :: Char -> B.ByteString-qEncodeChar c-    | c == ' '                          = c2bs '_'-    | isPrint c-      && not (c `elem` ['?', '=', '_'])-      && ord c < 128                    = c2bs c-    | otherwise                         = B.concat-                                            (map qbyte-                                              (B.unpack-                                                (packStringToUTF8 [c])))-  where c2bs = B.singleton . B.c2w-        -- qbyte turns a byte into its q-encoded "=hh" representation-        qbyte b = B.pack (map B.c2w ['='-                                    ,word8ToUDigit (b `div` 16)-                                    ,word8ToUDigit (b `mod` 16)-                                    ])-        word8ToUDigit :: Word8 -> Char-        word8ToUDigit = toUpper . intToDigit . fromIntegral---- TODO is this doing mime encoding??-qpencode :: B.ByteString -> B.ByteString-qpencode s = unsafePerformIO-           -- Really only (3 + 2/75) * length or something in the worst case-           $ B.createAndTrim (4 * B.length s) (\buf -> encode s qlineMax buf 0)--encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int-encode ps _ _ bufi | B.null ps = return bufi-encode ps n buf bufi = case B.head ps of-  c | c == newline ->-        do poke (buf `plusPtr` bufi) newline-           encode ps' qlineMax buf (bufi+1)-    | n == 0 && B.length ps > 1 ->-        do poke (buf `plusPtr` bufi) equals-           poke (buf `plusPtr` (bufi+1)) newline-           encode ps qlineMax buf (bufi + 2)-    | (c == tab || c == space) ->-        if B.null ps' || B.head ps' == newline-        then do poke (buf `plusPtr` bufi) c-                poke (buf `plusPtr` (bufi+1)) equals-                poke (buf `plusPtr` (bufi+2)) newline-                encode ps' qlineMax buf (bufi + 3)-        else do poke (buf `plusPtr` bufi) c-                encode ps' (n - 1) buf (bufi + 1)-    | (c >= bang && c /= equals && c <= tilde) ->-        do poke (buf `plusPtr` bufi) c-           encode ps' (n - 1) buf (bufi + 1)-    | n < 3 ->-        encode ps 0 buf bufi-    | otherwise ->-        do let (x, y) = c `divMod` 16-               h1 = intToUDigit x-               h2 = intToUDigit y-           poke (buf `plusPtr` bufi) equals-           poke (buf `plusPtr` (bufi+1)) h1-           poke (buf `plusPtr` (bufi+2)) h2-           encode ps' (n - 3) buf (bufi + 3)-    where ps' = B.tail ps-          newline = B.c2w '\n'-          tab     = B.c2w '\t'-          space   = B.c2w ' '-          bang    = B.c2w '!'-          tilde   = B.c2w '~'-          equals  = B.c2w '='-          intToUDigit i-            | i >= 0  && i <= 9  = B.c2w '0' + i-            | i >= 10 && i <= 15 = B.c2w 'A' + i - 10-            | otherwise = error $ "intToUDigit: '"++show i++"'not a digit"--qpdecode :: B.ByteString -> B.ByteString-qpdecode s = unsafePerformIO-             -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n"-           $ B.createAndTrim (B.length s + 1) (\buf -> decode (linesPS s) buf 0)--decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int-decode [] _ bufi = return bufi-decode (ps:pss) buf bufi- | B.null (dropSpace ps)-    = do poke (buf `plusPtr` bufi) newline-         decode pss buf (bufi+1)- | is_equals && B.length ps >= 3 && isHexDigit c1 && isHexDigit c2-    = do poke (buf `plusPtr` bufi)-              (toWord8 $ digitToInt c1 * 16 + digitToInt c2)-         decode (B.drop 3 ps:pss) buf (bufi+1)- | is_equals && B.null (dropSpace (B.tail ps)) = decode pss buf bufi- | otherwise = do poke (buf `plusPtr` bufi) (B.head ps)-                  decode (B.tail ps:pss) buf (bufi+1)-    where is_equals = BC.head ps == '='-          c1 = BC.index ps 1-          c2 = BC.index ps 2-          newline = B.c2w '\n'-          toWord8 :: Int -> Word8-          toWord8 = fromIntegral--makeEmail :: String -> [(String, String)] -> (Maybe Doc) -> Maybe String -> Doc -> (Maybe String) -> Doc-makeEmail repodir headers mcontents mcharset bundle mfilename =-    text "DarcsURL:" <+> text repodir- $$ foldl (\m (h,v) -> m $$ (text (h ++ ":") <+> text v)) empty headers- $$ text "MIME-Version: 1.0"- $$ text "Content-Type: multipart/mixed; boundary=\"=_\""- $$ text ""- $$ text "--=_"- $$ (case mcontents of-       Just contents ->-            text ("Content-Type: text/plain; charset=\"" ++-              fromMaybe "x-unknown" mcharset ++ "\"")-         $$ text "Content-Transfer-Encoding: quoted-printable"-         $$ text ""-         $$ packedString (qpencode (renderPS contents))-         $$ text ""-         $$ text "--=_"-       Nothing -> empty)- $$ text "Content-Type: text/x-darcs-patch; name=\"patch-preview.txt\""- $$ text "Content-Disposition: inline"- $$ text "Content-Transfer-Encoding: quoted-printable"- $$ text "Content-Description: Patch preview"- $$ text ""- $$ (case betweenLinesPS (BC.pack "New patches:") (BC.pack "Context:") (renderPS bundle) of-     Just s -> packedString $ qpencode s-     -- this should not happen, but in case it does, keep everything-     Nothing -> packedString $ qpencode $ renderPS bundle)- $$ text "--=_"- $$ text "Content-Type: application/x-darcs-patch" <>-      (case mfilename of-         Just filename -> text "; name=\"" <> text filename <> text "\""-         Nothing -> empty)- $$ text "Content-Transfer-Encoding: quoted-printable"- $$ text "Content-Disposition: attachment"- $$ text "Content-Description: A darcs patch for your repository!"- $$ text ""- $$ packedString (qpencode (renderPS bundle))- $$ text "--=_--"- $$ text ""- $$ text "."- $$ text ""- $$ text ""--readEmail :: B.ByteString -> B.ByteString-readEmail s =-    case betweenLinesPS-         (BC.pack "Content-Description: A darcs patch for your repository!")-         (BC.pack "--=_--") s of-    Nothing -> s -- if it wasn't an email in the first place, just pass along.-    Just s' -> qpdecode s'-
− src/Darcs/External.hs 
@@ -1,632 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--module Darcs.External (-    backupByRenaming, backupByCopying,-    copyFileOrUrl, speculateFileOrUrl, copyLocal, cloneFile,-    cloneTree, cloneTreeExcept,-    fetchFilePS, fetchFileLazyPS, gzFetchFilePS,-    sendEmail, generateEmail, sendEmailDoc, resendEmail,-    signString, verifyPS,-    execDocPipe, execPipeIgnoreError,-    getTermNColors,-    pipeDoc, pipeDocSSH, execSSH,-    maybeURLCmd,-    Cachable(Cachable, Uncachable, MaxAge),-    viewDoc, viewDocWith,-    haveSendmail,-    sendmailPath, diffProgram, darcsProgram-  ) where--import Prelude hiding ( catch )--import qualified Ratified-import Data.Maybe ( isJust, isNothing, maybeToList )-import Control.Monad ( when, zipWithM_, filterM, liftM2 )-import System.Exit ( ExitCode(..) )-import System.Environment ( getEnv, getProgName )-import System.IO ( hSetBinaryMode, hPutStr, hPutStrLn, hClose,-                   openBinaryFile, IOMode( ReadMode ),-                   openBinaryTempFile,-                   hIsTerminalDevice, stdout, stderr, Handle )-import System.IO.Error ( isDoesNotExistError )-import System.Posix.Files ( getSymbolicLinkStatus, isRegularFile, isDirectory )-import System.Directory ( createDirectory, getDirectoryContents,-                          doesFileExist, doesDirectoryExist,-                          renameFile, renameDirectory, copyFile,-                          findExecutable )-import System.Process ( runProcess, runInteractiveProcess, waitForProcess )-import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )-import Control.Exception.Extensible-    ( bracket, try, finally, catch, IOException, SomeException )-import Data.Char ( toUpper )-#if defined (HAVE_MAPI)-import Foreign.C ( CString, withCString )-#endif-#ifdef HAVE_MAPI-import Foreign.Ptr ( nullPtr )-import Darcs.Lock ( canonFilename, writeDocBinFile )-#endif-#ifdef HAVE_TERMINFO-import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability )-#endif-import System.Posix.Files ( createLink )-import System.FilePath.Posix ( (</>), normalise )--import Darcs.Flags ( DarcsFlag( SignAs, Sign, SignSSL,-                                Verify, VerifySSL )-                   , RemoteDarcs(..) )-import Darcs.RepoPath ( AbsolutePath, toFilePath )-import Darcs.Utils ( breakCommand, getViewer, ortryrunning, )-import Progress ( withoutProgress, debugMessage )--import ByteStringUtils (gzReadFilePS, linesPS, unlinesPS)-import qualified Data.ByteString as B (ByteString, empty, null, readFile-            ,hGetContents, writeFile, hPut, length-            ,take, concat, drop, isPrefixOf, singleton, append)-import qualified Data.ByteString.Char8 as BC (unpack, pack)-import qualified Data.ByteString.Lazy as BL--import Darcs.Lock ( withTemp, withOpenTemp, tempdirLoc, removeFileMayNotExist )-import CommandLine ( parseCmd, addUrlencoded )-import URL ( copyUrl, copyUrlFirst, waitUrl )-import URL ( Cachable(..) )-import Exec ( exec, Redirect(..), withoutNonBlock )-import Darcs.Ssh ( getSSH, copySSH, SSHCmd(..) )-import Darcs.URL ( isFile, isHttpUrl, isSshUrl, splitSshUrl, SshFilePath, sshUhost )-import Darcs.Utils ( catchall )-import Printer ( Doc, Printers, putDocLnWith, hPutDoc, hPutDocLn, hPutDocWith, ($$), renderPS,-                 simplePrinters,-                 text, empty, packedString, vcat, renderString )-import Darcs.Email ( formatHeader )--#ifdef HAVE_HTTP-import Network.Browser ( browse, request, setErrHandler, setOutHandler-    , setAllowRedirects )-import Network.HTTP ( RequestMethod(GET), rspCode, rspBody, rspReason-    , mkRequest )-import Network.URI ( parseURI, uriScheme )-#endif--sendmailPath :: IO String-sendmailPath = do-  l <- filterM doesFileExist $ liftM2 (</>)-                [ "/usr/sbin", "/sbin", "/usr/lib" ]-                [ "sendmail" ]-  ex <- findExecutable "sendmail"-  when (isNothing ex && null l) $ fail "Cannot find the \"sendmail\" program."-  return $ head $ maybeToList ex ++ l--diffProgram :: IO String-diffProgram = do-  l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ]-  when (null l) $ fail "Cannot find the \"diff\" program."-  return $ head l---- |Get the name of the darcs executable (as supplied by @getProgName@)-darcsProgram :: IO String-darcsProgram = getProgName--- Another option: getEnv "DARCS" `catch` \(_ :: IOException) -> getProgName--backupByRenaming :: FilePath -> IO ()-backupByRenaming = backupBy rename- where rename x y = do-         isD <- doesDirectoryExist x-         if isD then renameDirectory x y else renameFile x y--backupByCopying :: FilePath -> IO ()-backupByCopying = backupBy copy- where-  copy x y = do-    isD <- doesDirectoryExist x-    if isD then do createDirectory y-                   cloneTree (normalise x) (normalise y)-           else copyFile x y--backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()-backupBy backup f =-           do hasBF <- doesFileExist f-              hasBD <- doesDirectoryExist f-              when (hasBF || hasBD) $ helper 0-  where-  helper :: Int -> IO ()-  helper i = do existsF <- doesFileExist next-                existsD <- doesDirectoryExist next-                if (existsF || existsD)-                   then helper (i + 1)-                   else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"-                           backup f next-             where next = f ++ suffix-                   suffix = ".~" ++ show i ++ "~"--copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a-copyAndReadFile readfn fou _ | isFile fou = readfn fou-copyAndReadFile readfn fou cache = withTemp $ \t -> do copyFileOrUrl DefaultRemoteDarcs fou t cache-                                                       readfn t---- | @fetchFile fileOrUrl cache@ returns the content of its argument (either a--- file or an URL). If it has to download an url, then it will use a cache as--- required by its second argument.------ We always use default remote darcs, since it is not fatal if the remote--- darcs does not exist or is too old -- anything that supports transfer-mode--- should do, and if not, we will fall back to SFTP or SCP.-fetchFilePS :: String -> Cachable -> IO B.ByteString-fetchFilePS = copyAndReadFile B.readFile---- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument--- (either a file or an URL). Warning: this function may constitute a fd leak;--- make sure to force consumption of file contents to avoid that. See--- "fetchFilePS" for details.-fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString-#ifdef HAVE_HTTP-fetchFileLazyPS x c = case parseURI x of-  Just x' | uriScheme x' == "http:" -> do-    rsp <- fmap snd . browse $ do-      setErrHandler . const $ return ()-      setOutHandler . const $ return ()-      setAllowRedirects True-      request $ mkRequest GET x'-    if rspCode rsp /= (2, 0, 0)-      then fail $ "fetchFileLazyPS: " ++ rspReason rsp-      else return $ rspBody rsp-  _ -> copyAndReadFile BL.readFile x c-#else-fetchFileLazyPS x c = copyAndReadFile BL.readFile x c-#endif--gzFetchFilePS :: String -> Cachable -> IO B.ByteString-gzFetchFilePS = copyAndReadFile gzReadFilePS--copyFileOrUrl :: RemoteDarcs -> FilePath -> FilePath -> Cachable -> IO ()-copyFileOrUrl _    fou out _     | isFile fou = copyLocal fou out-copyFileOrUrl _    fou out cache | isHttpUrl  fou = copyRemote fou out cache-copyFileOrUrl rd   fou out _     | isSshUrl  fou = copySSH rd (splitSshUrl fou) out-copyFileOrUrl _    fou _   _     = fail $ "unknown transport protocol: " ++ fou--speculateFileOrUrl :: String -> FilePath -> IO ()-speculateFileOrUrl fou out | isHttpUrl fou = speculateRemote fou out-                           | otherwise = return ()--copyLocal  :: String -> FilePath -> IO ()-copyLocal fou out = createLink fou out `catchall` cloneFile fou out--cloneTree :: FilePath -> FilePath -> IO ()-cloneTree = cloneTreeExcept []--cloneTreeExcept :: [FilePath] -> FilePath -> FilePath -> IO ()-cloneTreeExcept except source dest =- do fs <- getSymbolicLinkStatus source-    if isDirectory fs then do-        fps <- getDirectoryContents source-        let fps' = filter (`notElem` (".":"..":except)) fps-            mk_source fp = source </> fp-            mk_dest   fp = dest   </> fp-        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')-     else fail ("cloneTreeExcept: Bad source " ++ source)-   `catch` (\(_ :: IOException) -> fail ("cloneTreeExcept: Bad source " ++ source))--cloneSubTree :: FilePath -> FilePath -> IO ()-cloneSubTree source dest =- do fs <- getSymbolicLinkStatus source-    if isDirectory fs then do-        createDirectory dest-        fps <- getDirectoryContents source-        let fps' = filter (`notElem` [".", ".."]) fps-            mk_source fp = source </> fp-            mk_dest   fp = dest   </> fp-        zipWithM_ cloneSubTree (map mk_source fps') (map mk_dest fps')-     else if isRegularFile fs then-        cloneFile source dest-     else fail ("cloneSubTree: Bad source "++ source)-    `catch` (\e -> if isDoesNotExistError e-                   then return ()-                   else ioError e)--cloneFile :: FilePath -> FilePath -> IO ()-cloneFile = copyFile--maybeURLCmd :: String -> String -> IO(Maybe(String))-maybeURLCmd what url =-  do let prot = map toUpper $ takeWhile (/= ':') url-     fmap Just (getEnv ("DARCS_" ++ what ++ "_" ++ prot))-             `catch` \(_ :: IOException) -> return Nothing--speculateRemote :: String -> FilePath -> IO () -- speculations are always Cachable-#if defined(HAVE_CURL) || defined(HAVE_HTTP)-speculateRemote u v =-    do maybeget <- maybeURLCmd "GET" u-       case maybeget of-         Just _ -> return () -- can't pipeline these-         Nothing -> copyUrl u v Cachable-#else-speculateRemote u _ = maybeURLCmd "GET" u >> return ()-#endif--copyRemote :: String -> FilePath -> Cachable -> IO ()-copyRemote u v cache =-    do maybeget <- maybeURLCmd "GET" u-       case maybeget of-         Nothing -> copyRemoteNormal u v cache-         Just get ->-           do let (cmd,args) = breakCommand get-              r <- exec cmd (args++[u]) (Null, File v, AsIs)-              when (r /= ExitSuccess) $-                  fail $ "(" ++ get ++ ") failed to fetch: " ++ u--copyRemoteNormal :: String -> FilePath -> Cachable -> IO ()-copyRemoteNormal u v cache = copyUrlFirst u v cache >> waitUrl u---- | Run a command on a remote location without passing it any input or---   reading its output.  Return its ExitCode-execSSH :: SshFilePath -> String -> IO ExitCode-execSSH remoteAddr command =-    do (ssh, ssh_args) <- getSSH SSH-       debugMessage $ unwords (ssh:ssh_args++[sshUhost remoteAddr,command])-       withoutProgress $ do hid <- runProcess ssh (ssh_args++[sshUhost remoteAddr,command])-                                   Nothing Nothing Nothing Nothing Nothing-                            waitForProcess hid--pipeDoc :: String -> [String] -> Doc -> IO ExitCode-pipeDoc c args inp = withoutNonBlock $ withoutProgress $-    do debugMessage $ unwords (c:args)-       (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing-       hSetBinaryMode i True-       hSetBinaryMode o True-       mvare <- newEmptyMVar--- Warning:  A do-notation statement discarded a result of type GHC.Conc.ThreadId.-       _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed-                hPutStr stderr)-               `finally` putMVar mvare ())-       mvaro <- newEmptyMVar--- Warning:  A do-notation statement discarded a result of type GHC.Conc.ThreadId.-       _ <- forkIO ((Ratified.hGetContents o >>= -- ratify: immediately consumed-                hPutStr stdout)-               `finally` putMVar mvaro ())-       hPutDoc i inp-       hClose i-       rval <- waitForProcess pid-       takeMVar mvare-       takeMVar mvaro-       when (rval == ExitFailure 127) $-            putStrLn $ "Command not found:\n   "++ show (c:args)-       return rval--pipeDocSSH :: SshFilePath -> [String] -> Doc -> IO ExitCode-pipeDocSSH remoteAddr args input =-    do (ssh, ssh_args) <- getSSH SSH-       pipeDoc ssh (ssh_args++ (sshUhost remoteAddr:args)) input--sendEmail :: String -> String -> String -> String -> String -> String -> IO ()-sendEmail f t s cc scmd body =-  sendEmailDoc f t s cc scmd Nothing (text body)---generateEmail-    :: Handle  -- ^ handle to write email to-    -> String  -- ^ From-    -> String  -- ^ To-    -> String  -- ^ Subject-    -> String  -- ^ CC-    -> Doc     -- ^ body-    -> IO ()-generateEmail h f t s cc body = do-     putHeader "To" t-     putHeader "From" f-     putHeader "Subject" s-     when (not (null cc)) (putHeader "Cc" cc)-     putHeader "X-Mail-Originator" "Darcs Version Control System"-     hPutDocLn h body-  where putHeader field value-            = B.hPut h (B.append (formatHeader field value) newline)-        newline = B.singleton 10--haveSendmail :: IO Bool-haveSendmail = (sendmailPath >> return True) `catch` (\(_ :: IOException) -> return False)---- | Send an email, optionally containing a patch bundle---   (more precisely, its description and the bundle itself)-sendEmailDoc-  :: String           -- ^ from-  -> String           -- ^ to-  -> String           -- ^ subject-  -> String           -- ^ cc-  -> String           -- ^ send command-  -> Maybe (Doc, Doc) -- ^ (content,bundle)-  -> Doc              -- ^ body-  -> IO ()-sendEmailDoc _ "" _ "" _ _ _ = return ()-sendEmailDoc f "" s cc scmd mbundle body =-  sendEmailDoc f cc s "" scmd mbundle body-sendEmailDoc f t s cc scmd mbundle body = do-  use_sendmail <- haveSendmail-  if use_sendmail || scmd /= "" then-    withOpenTemp $ \(h,fn) -> do-      generateEmail h f t s cc body-      hClose h-      withOpenTemp $ \(hat,at) -> do-        ftable' <- case mbundle of-                   Just (content,bundle) -> do-                       hPutDocLn hat $ bundle-                       return [ ('b', renderString content) , ('a', at) ]-                   Nothing ->-                       return [ ('b', renderString body) ]-        hClose hat-        let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable'-        r <- execSendmail ftable scmd fn-        when (r /= ExitSuccess) $ fail ("failed to send mail to: "-                                       ++ t ++ cc_list cc-                                       ++ "\nPerhaps sendmail is not configured.")-#ifdef HAVE_MAPI-   else do-     r <- withCString t $ \tp ->-           withCString f $ \fp ->-            withCString cc $ \ccp ->-             withCString s $ \sp ->-              withOpenTemp $ \(h,fn) -> do-               hPutDoc h body-               hClose h-               writeDocBinFile "mailed_patch" body-               cfn <- canonFilename fn-               withCString cfn $ \pcfn ->-                c_send_email fp tp ccp sp nullPtr pcfn-     when (r /= 0) $ fail ("failed to send mail to: " ++ t)-#else-   else fail $ "no mail facility (sendmail or mapi) located at configure time!"-#endif-  where addressOnly a =-          case dropWhile (/= '<') a of-          ('<':a2) -> takeWhile (/= '>') a2-          _        -> a--        cc_list [] = []-        cc_list c = " and cc'ed " ++ c--resendEmail :: String -> String -> B.ByteString -> IO ()-resendEmail "" _ _ = return ()-resendEmail t scmd body = do-  use_sendmail <- haveSendmail-  if use_sendmail || scmd /= ""-   then-    withOpenTemp $ \(h,fn) -> do-     hPutStrLn h $ "To: "++ t-     hPutStrLn h $ find_from (linesPS body)-     hPutStrLn h $ find_subject (linesPS body)-     hPutDocLn h $ fixit $ linesPS body-     hClose h-     let ftable = [('t',t)]-     r <-  execSendmail ftable scmd fn-     when (r /= ExitSuccess) $ fail ("failed to send mail to: " ++ t)-   else-#ifdef HAVE_MAPI-    fail "Don't know how to resend email with MAPI"-#else-    fail "no mail facility (sendmail or mapi) located at configure time (use the sendmail-command option)!"-#endif-  where br            = BC.pack "\r"-        darcsurl      = BC.pack "DarcsURL:"-        content       = BC.pack "Content-"-        from_start    = BC.pack "From:"-        subject_start = BC.pack "Subject:"-        fixit (l:ls)-         | B.null l = packedString B.empty $$ vcat (map packedString ls)-         | l == br = packedString B.empty $$ vcat (map packedString ls)-         | B.take 9 l == darcsurl || B.take 8 l == content-            = packedString l $$ fixit ls-         | otherwise = fixit ls-        fixit [] = empty-        find_from (l:ls) | B.take 5 l == from_start = BC.unpack l-                         | otherwise = find_from ls-        find_from [] = "From: unknown"-        find_subject (l:ls) | B.take 8 l == subject_start = BC.unpack l-                            | otherwise = find_subject ls-        find_subject [] = "Subject: (no subject)"--execSendmail :: [(Char,String)] -> String -> String -> IO ExitCode-execSendmail ftable scmd fn =-  if scmd == "" then do-     cmd <- sendmailPath-     exec cmd ["-i", "-t"] (File fn, Null, AsIs)-  else case parseCmd (addUrlencoded ftable) scmd of-         Right (arg0:opts, wantstdin) ->-           do let stdin = if wantstdin then File fn else Null-              exec arg0 opts (stdin, Null, AsIs)-         Left e -> fail $ ("failed to send mail, invalid sendmail-command: "++(show e))-         _ -> fail $ ("failed to send mail, invalid sendmail-command")--#ifdef HAVE_MAPI-foreign import ccall "win32/send_email.h send_email" c_send_email-             :: CString -> {- sender -}-                CString -> {- recipient -}-                CString -> {- cc -}-                CString -> {- subject -}-                CString -> {- body -}-                CString -> {- path -}-                IO Int-#endif--execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString-execPSPipe c args ps = fmap renderPS-                     $ execDocPipe c args-                     $ packedString ps--execDocPipe :: String -> [String] -> Doc -> IO Doc-execDocPipe c args instr = withoutProgress $-    do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing--- Warning:  A do-notation statement discarded a result of type GHC.Conc.ThreadId.-       _ <- forkIO $ hPutDoc i instr >> hClose i-       mvare <- newEmptyMVar--- Warning:  A do-notation statement discarded a result of type GHC.Conc.ThreadId.-       _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed-                hPutStr stderr)-               `finally` putMVar mvare ())-       out <- B.hGetContents o-       rval <- waitForProcess pid-       takeMVar mvare-       case rval of-         ExitFailure ec ->fail $ "External program '"++c++-                          "' failed with exit code "++ show ec-         ExitSuccess -> return $ packedString out---- The following is needed for diff, which returns non-zero whenever--- the files differ.-execPipeIgnoreError :: String -> [String] -> Doc -> IO Doc-execPipeIgnoreError c args instr = withoutProgress $-    do (i,o,e,pid) <- runInteractiveProcess c args Nothing Nothing--- Warning:  A do-notation statement discarded a result of type GHC.Conc.ThreadId.-       _ <- forkIO $ hPutDoc i instr >> hClose i-       mvare <- newEmptyMVar--- Warning:  A do-notation statement discarded a result of type GHC.Conc.ThreadId.-       _ <- forkIO ((Ratified.hGetContents e >>= -- ratify: immediately consumed-                hPutStr stderr)-               `finally` putMVar mvare ())-       out <- B.hGetContents o--- Warning:  A do-notation statement discarded a result of type ExitCode.-       _ <- waitForProcess pid-       takeMVar mvare-       return $ if B.null out then empty else packedString out--signString :: [DarcsFlag] -> Doc -> IO Doc-signString [] d = return d-signString (Sign:_) d = signPGP [] d-signString (SignAs keyid:_) d = signPGP ["--local-user", keyid] d-signString (SignSSL idf:_) d = signSSL idf d-signString (_:os) d = signString os d--signPGP :: [String] -> Doc -> IO Doc-signPGP args t = execDocPipe "gpg" ("--clearsign":args) t--signSSL :: String -> Doc -> IO Doc-signSSL idfile t =-    withTemp $ \cert -> do-    opensslPS ["req", "-new", "-key", idfile,-               "-outform", "PEM", "-days", "365"]-                (BC.pack "\n\n\n\n\n\n\n\n\n\n\n")-                >>= opensslPS ["x509", "-req", "-extensions",-                               "v3_ca", "-signkey", idfile,-                               "-outform", "PEM", "-days", "365"]-                >>= opensslPS ["x509", "-outform", "PEM"]-                >>= B.writeFile cert-    opensslDoc ["smime", "-sign", "-signer", cert,-                "-inkey", idfile, "-noattr", "-text"] t-    where opensslDoc = execDocPipe "openssl"-          opensslPS = execPSPipe "openssl"---verifyPS :: [DarcsFlag] -> B.ByteString -> IO (Maybe B.ByteString)-verifyPS [] ps = return $ Just ps-verifyPS (Verify pks:_) ps = verifyGPG pks ps-verifyPS (VerifySSL auks:_) ps = verifySSL auks ps-verifyPS (_:os) ps = verifyPS os ps--verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)-verifyGPG goodkeys s =-    withOpenTemp $ \(th,tn) -> do-      B.hPut th s-      hClose th-      rval <- exec "gpg"  ["--batch","--no-default-keyring",-                           "--keyring",fix_path $ toFilePath goodkeys, "--verify"]-                           (File tn, Null, Null)-      case rval of-          ExitSuccess -> return $ Just gpg_fixed_s-          _ -> return Nothing-      where gpg_fixed_s = let-                not_begin_signature x =-                    x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"-                    &&-                    x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r"-                in unlinesPS $ map fix_line $ tail $ dropWhile not_begin_signature $ linesPS s-            fix_line x | B.length x < 3 = x-                       | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x-                       | otherwise = x-#if defined(WIN32)-            fix_sep c | c=='/' = '\\'   | otherwise = c-            fix_path p = map fix_sep p-#else-            fix_path p = p-#endif--verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)-verifySSL goodkeys s = do-    certdata <- opensslPS ["smime", "-pk7out"] s-                >>= opensslPS ["pkcs7", "-print_certs"]-    cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata-    let key_used = B.concat $ tail $-                   takeWhile (/= BC.pack"-----END PUBLIC KEY-----")-                           $ linesPS cruddy_pk-        in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys)-              if not $ key_used `elem` allowed_keys-                then return Nothing -- Not an allowed key!-                else withTemp $ \cert ->-                     withTemp $ \on ->-                     withOpenTemp $ \(th,tn) -> do-                     B.hPut th s-                     hClose th-                     B.writeFile cert certdata-                     rval <- exec "openssl" ["smime", "-verify", "-CAfile",-                                             cert, "-certfile", cert]-                                             (File tn, File on, Null)-                     case rval of-                       ExitSuccess -> Just `fmap` B.readFile on-                       _ -> return Nothing-    where opensslPS = execPSPipe "openssl"---{--  - This function returns number of colors supported by current terminal-  - or -1 if color output not supported or error occured.-  - Terminal type determined by TERM env. variable.-  -}-getTermNColors :: IO Int-#ifdef HAVE_TERMINFO-getTermNColors = do-  t <- setupTermFromEnv-  return $ case getCapability t $ tiGetNum "colors" of-    Nothing -> (-1)-    Just x -> x-#else-getTermNColors = return (-1)-#endif--viewDoc :: Doc -> IO ()-viewDoc = viewDocWith simplePrinters--viewDocWith :: Printers -> Doc -> IO ()-viewDocWith pr msg = do-  isTerminal <- hIsTerminalDevice stdout--- Warning:  A do-notation statement discarded a result of type ExitCode.-  _ <- if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg)-     then do viewerPlusArgs <- getViewer-             let (viewer:args) = words viewerPlusArgs-             pipeDocToPager viewer args pr msg-               `ortryrunning` pipeDocToPager  "less" [] pr msg-               `ortryrunning` pipeDocToPager  "more" [] pr msg-#ifdef WIN32-               `ortryrunning` pipeDocToPager  "more.com" [] pr msg-#endif-               `ortryrunning` pipeDocToPager "" [] pr msg-     else pipeDocToPager "" [] pr msg-  return ()-              where lengthGreaterThan n _ | n <= 0 = True-                    lengthGreaterThan _ [] = False-                    lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs--pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode--pipeDocToPager "" _ pr inp = do-  putDocLnWith pr inp-  return ExitSuccess--pipeDocToPager c args pr inp = withoutNonBlock $ withoutProgress $ do-  tmp <- tempdirLoc-  bracket (openBinaryTempFile tmp "darcs-pager") cleanup $ \(fn,fh) ->-    do hPutDocWith pr fh inp-       hClose fh-       bracket (openBinaryFile fn ReadMode) hClose $ \h ->-         do x <- do waitForProcess  =<< runProcess c args Nothing Nothing (Just h) Nothing Nothing-            when (x == ExitFailure 127) $-                 putStrLn $ "Command not found:\n   "++ show (c:args)-            return x-  where--- Warning:  A do-notation statement discarded a result of type Either SomeException ().-    cleanup (f,h) = do _ <- try (hClose h) :: IO (Either SomeException ())-                       removeFileMayNotExist f
− src/Darcs/Flags.hs 
@@ -1,279 +0,0 @@--- Copyright (C) 2002-2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Flags-    ( DarcsFlag( .. )-    , Compression( .. )-    , UseIndex(..)-    , ScanKnown(..)-    , RemoteDarcs(..)-    , compression-    , remoteDarcs-    , diffingOpts-    , wantExternalMerge-    , wantGuiPause-    , isInteractive-    , maxCount-    , willIgnoreTimes-    , willRemoveLogFile-    , isUnified-    , isNotUnified-    , doHappyForwarding-    , includeBoring-    , doAllowCaseOnly-    , doAllowWindowsReserved-    , doReverse-    , usePacks-    , showChangesOnlyToFiles-    , rollbackInWorkingDir-    , removeFromAmended-    , defaultFlag-    ) where---import Data.List ( find )-import Data.Maybe( fromMaybe, isJust )-import Darcs.Patch.MatchData ( PatchMatch )-import Darcs.RepoPath ( AbsolutePath, AbsolutePathOrStd )----- | The 'DarcsFlag' type is a list of all flags that can ever be--- passed to darcs, or to one of its commands.-data DarcsFlag = Help | ListOptions | NoTest | Test-               | OnlyChangesToFiles | ChangesToAllFiles-               | LeaveTestDir | NoLeaveTestDir-               | Timings | Debug | DebugVerbose | DebugHTTP-               | Verbose | NormalVerbosity | Quiet-               | Target String | Cc String-               | Output AbsolutePathOrStd | OutputAutoName AbsolutePath-               | Subject String | InReplyTo String | Charset String-               | SendmailCmd String | Author String | PatchName String-               | OnePatch String | SeveralPatch String-               | AfterPatch String | UpToPatch String-               | TagName String | LastN Int | MaxCount Int | PatchIndexRange Int Int-               | NumberPatches-               | OneTag String | AfterTag String | UpToTag String-               | GenContext | Context AbsolutePath | Count-               | LogFile AbsolutePath | RmLogFile | DontRmLogFile-               | DistName String | All-               | Recursive | NoRecursive | Reorder-               | RestrictPaths | DontRestrictPaths-               | AskDeps | NoAskDeps | IgnoreTimes | DontIgnoreTimes-               | LookForAdds | NoLookForAdds-               | AnyOrder | CreatorHash String-               | Intersection | Union | Complement-               | Sign | SignAs String | NoSign | SignSSL String-               | HappyForwarding | NoHappyForwarding-               | Verify AbsolutePath | VerifySSL AbsolutePath-               | RemoteDarcsOpt String-               | EditDescription | NoEditDescription-               | Toks String-               | EditLongComment | NoEditLongComment | PromptLongComment-               | KeepDate | NoKeepDate-               | AllowConflicts | MarkConflicts | NoAllowConflicts-               | SkipConflicts-               | Boring | SkipBoring-               | AllowCaseOnly | DontAllowCaseOnly-               | AllowWindowsReserved | DontAllowWindowsReserved-               | DontGrabDeps | DontPromptForDependencies | PromptForDependencies-               | Compress | NoCompress | UnCompress-               | WorkRepoDir String | WorkRepoUrl String | RemoteRepo String-               | NewRepo String-               | Reply String | ApplyAs String-               | MachineReadable | HumanReadable-               | Pipe | Interactive-               | DiffCmd String-               | ExternalMerge String | Summary | NoSummary-               | PauseForGui | NoPauseForGui-               | Unified | NonUnified | Reverse | Forward-               | Complete | Lazy-               | FixFilePath AbsolutePath AbsolutePath | DiffFlags String-               | XMLOutput-               | ForceReplace-               | OnePattern PatchMatch | SeveralPattern PatchMatch-               | AfterPattern PatchMatch | UpToPattern PatchMatch-               | NonApply | NonVerify | NonForce-               | DryRun--               -- The Bool parameters are a bit of a hack so that we can tell-               -- whether the user explicitly set the option or not.-               -- A more general mechanism would be better.-               -- True = explicitly set by user (on command-line or in prefs/defaults),-               -- False = defaulted by darcs-               | SetDefault Bool | NoSetDefault Bool--               | Disable | SetScriptsExecutable | DontSetScriptsExecutable | Bisect-               | UseHashedInventory-               | UseFormat2 | UseNoWorkingDir | UseWorkingDir-               | NoUpdateWorking-               | Sibling AbsolutePath | Relink-               | OptimizePristine | OptimizeHTTP-               | UpgradeFormat-               | Files | NoFiles | Directories | NoDirectories-               | Pending | NoPending-               | PosthookCmd String | NoPosthook | AskPosthook | RunPosthook-               | PrehookCmd String  | NoPrehook  | AskPrehook  | RunPrehook-               | UMask String-               | StoreInMemory | ApplyOnDisk-               | NoHTTPPipelining-               | Packs | NoPacks-               | NoCache-               | AllowUnrelatedRepos-               | Check | Repair | JustThisRepo-               | NullFlag-               | RecordRollback | NoRecordRollback-               | NoAmendUnrecord | AmendUnrecord-                 deriving ( Eq, Show )---- ADTs for selecting specific behaviour... FIXME These should be eventually--- moved out from this module, closer to where they are actually used--data Compression = NoCompression-                 | GzipCompression--data UseIndex = UseIndex-              | IgnoreIndex--data ScanKnown = ScanKnown -- ^Just files already known to darcs-               | ScanAll -- ^All files, i.e. look for new ones-               | ScanBoring -- ^All files, even boring ones--data RemoteDarcs = RemoteDarcs String-                 | DefaultRemoteDarcs---compression :: [DarcsFlag]-            -> Compression-compression f-    | NoCompress `elem` f = NoCompression-    | otherwise           = GzipCompression---remoteDarcs :: [DarcsFlag]-            -> RemoteDarcs-remoteDarcs f-    | (x:_) <- [ c | RemoteDarcsOpt c <- f ] = RemoteDarcs x-    | otherwise = DefaultRemoteDarcs---diffingOpts :: [DarcsFlag]-            -> (UseIndex, ScanKnown)-diffingOpts opts = (index, scan)-  where-    index = if willIgnoreTimes opts-            then IgnoreIndex-            else UseIndex-    scan =-        if LookForAdds `elem` opts-        then-          if Boring `elem` opts-          then ScanBoring-          else ScanAll-        else ScanKnown---wantExternalMerge :: [DarcsFlag] -> Maybe String-wantExternalMerge [] = Nothing-wantExternalMerge (ExternalMerge c:_) = Just c-wantExternalMerge (_:fs) = wantExternalMerge fs---wantGuiPause :: [DarcsFlag] -> Bool-wantGuiPause fs = (hasDiffCmd || hasExternalMerge) && hasPause-  where-    hasDiffCmd = any isDiffCmd fs-    hasExternalMerge = isJust $ wantExternalMerge fs-    isDiffCmd (DiffCmd _) = True-    isDiffCmd _ = False-    hasPause = maybe True (==PauseForGui) $ find isPauseFlag $ reverse fs-    isPauseFlag f = (f==PauseForGui) || (f==NoPauseForGui)---isInteractive :: [DarcsFlag] -> Bool-isInteractive = isInteractive_ True-    where-      isInteractive_ def [] = def-      isInteractive_ _ (Interactive:_) = True-      isInteractive_ _ (All:_) = False-      isInteractive_ _ (DryRun:fs) = isInteractive_ False fs-      isInteractive_ def (_:fs) = isInteractive_ def fs--maxCount :: [DarcsFlag] -> Maybe Int-maxCount (MaxCount n : _) = Just n-maxCount (_:xs) = maxCount xs-maxCount [] = Nothing---- | @lastWord [(flag, value)] default opts@ scans @opts@ for a flag--- in the list and returns the value of the first match, or @default@--- if none is found.------ We call this the \"last\" word because we assume that flags are--- *prepended* in the order they arrive, so what is first internally--- is last from the user's point of view.-lastWord :: [(DarcsFlag,a)] -> a -> [DarcsFlag] -> a-lastWord known_flags = foldr . flip $ \ def -> fromMaybe def . flip lookup known_flags--getBoolFlag :: DarcsFlag -> DarcsFlag -> [DarcsFlag] -> Bool-getBoolFlag t f = lastWord [(t, True), (f, False)] False--willIgnoreTimes :: [DarcsFlag] -> Bool-willIgnoreTimes = getBoolFlag IgnoreTimes DontIgnoreTimes--willRemoveLogFile :: [DarcsFlag] -> Bool-willRemoveLogFile = getBoolFlag RmLogFile DontRmLogFile--isUnified :: [DarcsFlag] -> Bool-isUnified = getBoolFlag Unified NonUnified--isNotUnified :: [DarcsFlag] -> Bool-isNotUnified = getBoolFlag NonUnified Unified--doHappyForwarding :: [DarcsFlag] -> Bool-doHappyForwarding = getBoolFlag HappyForwarding NoHappyForwarding--includeBoring :: [DarcsFlag] -> Bool-includeBoring = getBoolFlag Boring SkipBoring--doAllowCaseOnly :: [DarcsFlag] -> Bool-doAllowCaseOnly = getBoolFlag AllowCaseOnly DontAllowCaseOnly---doAllowWindowsReserved :: [DarcsFlag] -> Bool-doAllowWindowsReserved = getBoolFlag AllowWindowsReserved DontAllowWindowsReserved--doReverse :: [DarcsFlag] -> Bool-doReverse = getBoolFlag Reverse Forward--usePacks :: [DarcsFlag] -> Bool-usePacks = getBoolFlag Packs NoPacks--showChangesOnlyToFiles :: [DarcsFlag] -> Bool-showChangesOnlyToFiles = getBoolFlag OnlyChangesToFiles ChangesToAllFiles---- | Set flags to a default value, but only one has not already been provided-defaultFlag :: [DarcsFlag] -- ^ distractors-            -> DarcsFlag   -- ^ default-            -> [DarcsFlag] -- ^ flags-            -> [DarcsFlag] -- ^ updated flags-defaultFlag alts def flags =- if any (`elem` flags) alts then flags else def : flags--rollbackInWorkingDir :: [DarcsFlag] -> Bool-rollbackInWorkingDir = getBoolFlag NoRecordRollback RecordRollback--removeFromAmended :: [DarcsFlag] -> Bool-removeFromAmended = getBoolFlag AmendUnrecord NoAmendUnrecord
− src/Darcs/Global.hs 
@@ -1,286 +0,0 @@--- Copyright (C) 2005 Tomasz Zielonka------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}---- |--- Module      : Darcs.Global--- Copyright   : 2005 Tomasz Zielonka--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable------ This was originally Tomasz Zielonka's AtExit module, slightly generalised--- to include global variables.  Here, we attempt to cover broad, global--- features, such as exit handlers.  These features slightly break the Haskellian--- purity of darcs, in favour of programming convenience.--module Darcs.Global-    (-      atexit-    , withAtexit-    , SshSettings(..)-    , defaultSsh-    , timingsMode-    , setTimingsMode-    , whenDebugMode-    , withDebugMode-    , setDebugMode-    , debugMessage-    , debugFail-    , putTiming-    , addCRCWarning-    , getCRCWarnings-    , resetCRCWarnings-    , addBadSource-    , getBadSourcesList-    , isBadSource-    , darcsdir-    , isReachableSource-    , addReachableSource-    , windows-    ) where---import Control.Applicative ( (<$>), (<*>) )-import Control.Monad ( when )-import Control.Concurrent.MVar-import Control.Exception.Extensible ( bracket_, catch, catchJust, SomeException-                                    )-#if (MIN_VERSION_base(4,4,0))-import Control.Exception.Extensible ( mask )-#else-import Control.Exception.Extensible ( block, unblock )-#endif-import Data.IORef ( IORef, newIORef, readIORef, writeIORef )-import Data.IORef ( modifyIORef )-import Data.List ( isPrefixOf )-import System.Info ( os )-import System.IO.Unsafe (unsafePerformIO)-import System.IO (hPutStrLn, hPutStr, stderr)-import System.IO.Error ( ioeGetErrorType, isDoesNotExistErrorType )-import System.Process ( readProcessWithExitCode )-import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )-import System.Environment ( getEnv )-import Prelude hiding (catch)--#if !(MIN_VERSION_base(4,4,0))-mask f = block (f unblock)-#endif--windows :: Bool-windows = "mingw" `isPrefixOf` os---atexitActions :: MVar (Maybe [IO ()])-atexitActions = unsafePerformIO (newMVar (Just []))-{-# NOINLINE atexitActions #-}----- | Registers an IO action to run just before darcs exits. Useful for removing--- temporary files and directories, for example. Referenced in Issue1914.-atexit :: IO ()-       -> IO ()-atexit action =-    modifyMVar_ atexitActions $ \ml ->-        case ml of-            Just l ->-                return (Just (action : l))-            Nothing -> do-                hPutStrLn stderr "It's too late to use atexit"-                return Nothing---withAtexit :: IO a -> IO a-withAtexit prog =-    bracket_-        (return ())-        exit-        prog-  where-    exit = mask $ \unmask -> do-        Just actions <- swapMVar atexitActions Nothing-        -- from now on atexit will not register new actions-        mapM_ (runAction unmask) actions-    runAction unmask action =-        catch (unmask action) $ \(exn :: SomeException) -> do-            hPutStrLn stderr $ "Exception thrown by an atexit registered action:"-            hPutStrLn stderr $ show exn----- Write-once-read-many global variables make it easier to implement flags, such--- as --no-ssh-cm. Using global variables reduces the number of parameters that--- we have to pass around, but it is rather unsafe and should be used sparingly.---_debugMode :: IORef Bool-_debugMode = unsafePerformIO $ newIORef False-{-# NOINLINE _debugMode #-}---setDebugMode :: IO ()-setDebugMode = writeIORef _debugMode True---whenDebugMode :: IO () -> IO ()-whenDebugMode j = do b <- readIORef _debugMode-                     when b j---withDebugMode :: (Bool -> IO a) -> IO a-withDebugMode j = readIORef _debugMode >>= j---debugMessage :: String -> IO ()-debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m---debugFail :: String -> IO a-debugFail m = debugMessage m >> fail m---putTiming :: IO ()-putTiming = when timingsMode $ do-    t <- getClockTime >>= toCalendarTime-    hPutStr stderr (calendarTimeToString t++": ")---_timingsMode :: IORef Bool-_timingsMode = unsafePerformIO $ newIORef False-{-# NOINLINE _timingsMode #-}---setTimingsMode :: IO ()-setTimingsMode = writeIORef _timingsMode True---timingsMode :: Bool-timingsMode = unsafePerformIO $ readIORef _timingsMode-{-# NOINLINE timingsMode #-}---data SshSettings = SshSettings-    { ssh :: String-    , scp :: String-    , sftp :: String-    } deriving (Show, Eq)---_defaultSsh :: IORef SshSettings-_defaultSsh = unsafePerformIO $ newIORef =<< detectSsh----- | Expected properties:------ * only ever runs once in the lifetime of the program--- * environment variables override all--- * tries Putty first on Windows--- * falls back to plain old ssh-detectSsh :: IO SshSettings-detectSsh = do-    whenDebugMode (putStrLn "Detecting SSH settings")-    vanilla <-  if windows-                  then do-                    plinkStr <- (snd3 <$> readProcessWithExitCode "plink" [] "")-                                  `catch` \(e :: SomeException) -> return (show e)-                    whenDebugMode $ putStrLn $-                        "SSH settings (plink): " ++-                        (concat . take 1 . lines $ plinkStr)-                    if "PuTTY" `isPrefixOf` plinkStr-                      then return (SshSettings "plink" "pscp -q" "psftp")-                      else return rawVanilla-                  else return rawVanilla-    settings <- SshSettings <$> fromEnv (ssh vanilla)  "DARCS_SSH"-                            <*> fromEnv (scp vanilla)  "DARCS_SCP"-                            <*> fromEnv (sftp vanilla) "DARCS_SFTP"-    whenDebugMode (putStrLn $ "SSH settings: " ++ show settings)-    return settings-  where-    snd3 (_, x, _) = x-    rawVanilla = SshSettings "ssh" "scp -q" "sftp"-    fromEnv :: String -> String -> IO String-    fromEnv d v = catchJust notFound-                            (getEnv v)-                            (const (return d))-    notFound e =  if isDoesNotExistErrorType (ioeGetErrorType e)-                  then Just ()-                  else Nothing---defaultSsh :: SshSettings-defaultSsh = unsafePerformIO $ readIORef _defaultSsh---type CRCWarningList = [FilePath]-_crcWarningList :: IORef CRCWarningList-_crcWarningList = unsafePerformIO $ newIORef []-{-# NOINLINE _crcWarningList #-}---addCRCWarning :: FilePath -> IO ()-addCRCWarning fp = modifyIORef _crcWarningList (fp:)---getCRCWarnings :: IO [FilePath]-getCRCWarnings = readIORef _crcWarningList---resetCRCWarnings :: IO ()-resetCRCWarnings = writeIORef _crcWarningList []---_badSourcesList :: IORef [String]-_badSourcesList = unsafePerformIO $ newIORef []-{-# NOINLINE _badSourcesList #-}---addBadSource :: String -> IO ()-addBadSource cache = modifyIORef _badSourcesList (cache:)---getBadSourcesList :: IO [String]-getBadSourcesList = readIORef _badSourcesList---isBadSource :: IO (String -> Bool)-isBadSource = do-    badSources <- getBadSourcesList-    return (`elem` badSources)---_reachableSourcesList :: IORef [String]-_reachableSourcesList = unsafePerformIO $ newIORef []-{-# NOINLINE _reachableSourcesList #-}---addReachableSource :: String -> IO ()-addReachableSource src = modifyIORef _reachableSourcesList (src:)---getReachableSources :: IO [String]-getReachableSources = readIORef _reachableSourcesList---isReachableSource :: IO (String -> Bool)-isReachableSource =  do-    reachableSources <- getReachableSources-    return (`elem` reachableSources)---darcsdir :: String-darcsdir = "_darcs"
− src/Darcs/IO.hs 
@@ -1,184 +0,0 @@--- Copyright (C) 2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Darcs.IO ( runTolerantly, runSilently ) where--import Prelude hiding ( catch )-import Data.Char ( toLower )-import Data.List ( isSuffixOf )-import System.IO.Error ( isDoesNotExistError, isPermissionError )-import Control.Exception.Extensible ( catch, SomeException, IOException )-import Control.Monad.Error-import System.Directory ( createDirectory,-                          removeDirectory, removeFile,-                          renameFile, renameDirectory,-                          doesDirectoryExist, doesFileExist-                        )-import Darcs.Repository.Prefs( changePrefval )--import qualified Data.ByteString as B (empty, null, readFile)--import Darcs.Utils ( prettyException )-import Darcs.External ( backupByCopying, backupByRenaming )-import Darcs.Patch.FileName ( FileName, fn2fp )-import Darcs.Lock ( writeAtomicFilePS )-import Darcs.Patch.ApplyMonad( ApplyMonad(..) )-import Storage.Hashed.Tree( Tree )--instance ApplyMonad IO Tree where-    type ApplyMonadBase IO = IO-    mDoesDirectoryExist = doesDirectoryExist . fn2fp-    mChangePref = changePrefval-    mModifyFilePS f j = B.readFile (fn2fp f) >>= j >>= writeAtomicFilePS (fn2fp f)-    mCreateDirectory = createDirectory . fn2fp-    mCreateFile f = do exf <- doesFileExist (fn2fp f)-                       if exf then fail $ "File '"++fn2fp f++"' already exists!"-                              else do exd <- doesDirectoryExist $ fn2fp f-                                      if exd then fail $ "File '"++fn2fp f++"' already exists!"-                                             else writeAtomicFilePS (fn2fp f) B.empty-    mRemoveFile f = do let fp = fn2fp f-                       x <- B.readFile fp-                       when (not $ B.null x) $-                            fail $ "Cannot remove non-empty file "++fp-                       removeFile fp-    mRemoveDirectory = removeDirectory . fn2fp-    mRename a b = catch-                  (renameDirectory x y `mplus` renameFile x y)-                  -- We need to catch does not exist errors, since older-                  -- versions of darcs allowed users to rename nonexistent-                  -- files.  :(-                  (\e -> if isDoesNotExistError e-                                 then return ()-                                 else ioError e)-      where x = fn2fp a-            y = fn2fp b--class Monad m => TolerantMonad m where-    warning :: IO () -> m ()-    runIO :: m a -> IO a-    runTM :: IO a -> m a--newtype TolerantIO a = TIO { runTolerantly :: IO a }-instance TolerantMonad TolerantIO where-    warning io = TIO $ io `catch` \e -> putStrLn $ "Warning: " ++ prettyException e-    runIO (TIO io) = io-    runTM io = TIO io--newtype SilentIO a = SIO { runSilently :: IO a }-instance TolerantMonad SilentIO where-    warning io = SIO $ io `catch` \(_ :: SomeException) -> return ()-    runIO (SIO io) = io-    runTM io = SIO io---- NOTE: The following instance declarations are duplicated merely to avoid--- enabling -fallow-undecidable-instances.  If we used--- -fallow-undecidable-instances, we would write instead:---- instance TolerantMonad m => Monad m where---      ...---- etc.-instance Functor TolerantIO where-    fmap f m = m >>= return . f--instance Monad TolerantIO where-    f >>= g = runTM $ runIO f >>= runIO . g-    f >> g = runTM $ runIO f >> runIO g-    fail s = runTM $ fail s-    return x = runTM $ return x--instance Functor SilentIO where-    fmap f m = m >>= return . f--instance Monad SilentIO where-    f >>= g = runTM $ runIO f >>= runIO . g-    f >> g = runTM $ runIO f >> runIO g-    fail s = runTM $ fail s-    return x = runTM $ return x--instance ApplyMonad TolerantIO Tree where-    type ApplyMonadBase TolerantIO = IO-    mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d-    mReadFilePS f = runTM $ mReadFilePS f-    mChangePref a b c = warning $ mChangePref a b c-    mModifyFilePS f j = warning $ mModifyFilePS f (runIO . j)-    mCreateFile f = warning $ backup f >> mCreateFile f-    mCreateDirectory d = warning $ backup d >> mCreateDirectory d-    mRemoveFile f = warning $ mRemoveFile f-    mRemoveDirectory d = warning $ catch-                                 (mRemoveDirectory d)-                                 (\(e :: IOException) ->-                                   if "(Directory not empty)" `isSuffixOf` show e-                                   then ioError $ userError $-                                            "Not deleting " ++ fn2fp d ++ " because it is not empty."-                                   else ioError $ userError $-                                            "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)-    mRename a b = warning $ catch-                          (let do_backup = if (map toLower x == map toLower y)-                                           then backupByCopying (fn2fp b) -- avoid making the original vanish-                                           else backupByRenaming (fn2fp b)-                           in do_backup >> mRename a b)-                          (\e -> case () of-                                 _ | isPermissionError e -> ioError $ userError $-                                       couldNotRename ++ "."-                                   | isDoesNotExistError e -> ioError $ userError $-                                       couldNotRename ++ " because " ++ x ++ " does not exist."-                                   | otherwise -> ioError e-                          )-       where-        x = fn2fp a-        y = fn2fp b-        couldNotRename = "Could not rename " ++ x ++ " to " ++ y--instance ApplyMonad SilentIO Tree where-    type ApplyMonadBase SilentIO = IO-    mDoesDirectoryExist d = runTM $ mDoesDirectoryExist d-    mReadFilePS f = runTM $ mReadFilePS f-    mChangePref a b c = warning $ mChangePref a b c-    mModifyFilePS f j = warning $ mModifyFilePS f (runIO . j)-    mCreateFile f = warning $ backup f >> mCreateFile f-    mCreateDirectory d = warning $ backup d >> mCreateDirectory d-    mRemoveFile f = warning $ mRemoveFile f-    mRemoveDirectory d = warning $ catch-                                 (mRemoveDirectory d)-                                 (\(e :: SomeException) ->-                                   if "(Directory not empty)" `isSuffixOf` show e-                                   then ioError $ userError $-                                            "Not deleting " ++ fn2fp d ++ " because it is not empty."-                                   else ioError $ userError $-                                            "Not deleting " ++ fn2fp d ++ " because:\n" ++ show e)-    mRename a b = warning $ catch-                          (let do_backup = if (map toLower x == map toLower y)-                                           then backupByCopying (fn2fp b) -- avoid making the original vanish-                                           else backupByRenaming (fn2fp b)-                           in do_backup >> mRename a b)-                          (\e -> case () of-                                 _ | isPermissionError e -> ioError $ userError $-                                       couldNotRename ++ "."-                                   | isDoesNotExistError e -> ioError $ userError $-                                       couldNotRename ++ " because " ++ x ++ " does not exist."-                                   | otherwise -> ioError e-                          )-       where-        x = fn2fp a-        y = fn2fp b-        couldNotRename = "Could not rename " ++ x ++ " to " ++ y--backup :: FileName -> IO ()-backup f = backupByRenaming (fn2fp f)
− src/Darcs/Lock.hs 
@@ -1,346 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, ForeignFunctionInterface #-}--module Darcs.Lock ( withLock, withLockCanFail,-              withTemp, withOpenTemp, withStdoutTemp,-              withTempDir, withPermDir, withDelayedDir, withNamedTemp,-              writeToFile, appendToFile,-              writeBinFile, writeLocaleFile, writeDocBinFile,-              appendBinFile, appendDocBinFile,-              readBinFile, readLocaleFile, readDocBinFile,-              writeAtomicFilePS,-              gzWriteAtomicFilePS, gzWriteAtomicFilePSs, gzWriteDocFile,-              rmRecursive, removeFileMayNotExist,-              canonFilename, maybeRelink,-              worldReadableTemp, tempdirLoc,-              editText,-              environmentHelpTmpdir, environmentHelpKeepTmpdir-            ) where--import Prelude hiding ( catch )-import Data.List ( inits )-import Data.Maybe ( isJust, listToMaybe )-import System.Exit ( exitWith, ExitCode(..) )-import System.IO ( openBinaryFile, openBinaryTempFile,-                   hClose, hPutStr, Handle,-                   IOMode(WriteMode, AppendMode), hFlush, stdout )-import System.IO.Error ( isDoesNotExistError, isAlreadyExistsError )-import Control.Exception.Extensible-                         ( bracket, throwIO, catch, try, SomeException )-import System.Directory ( removeFile, removeDirectory,-                   doesFileExist, doesDirectoryExist,-                   getDirectoryContents, createDirectory,-                   getTemporaryDirectory,-                 )-import System.FilePath.Posix ( splitDirectories )-import Workaround ( renameFile )-import Darcs.Utils ( withCurrentDirectory, maybeGetEnv, firstJustIO, runEditor )-import Control.Monad ( unless, when )--import Darcs.URL ( isRelative )-import Darcs.Utils ( catchall, addToErrorLoc )-import Darcs.RepoPath ( AbsolutePath, FilePathLike, toFilePath,-                        getCurrentDirectory, setCurrentDirectory )--import ByteStringUtils ( gzWriteFilePSs, decodeLocale, encodeLocale )-import qualified Data.ByteString as B (null, readFile, writeFile, hPut, ByteString)-import qualified Data.ByteString.Char8 as BC (unpack)--import Darcs.SignalHandler ( withSignalsBlocked )-import Printer ( Doc, hPutDoc, packedString, empty, renderPSs )-import Darcs.Global ( atexit, darcsdir )-import Darcs.Compat ( mkStdoutTemp, canonFilename, maybeRelink,-                atomicCreate, sloppyAtomicCreate )-import System.Posix.Files ( getSymbolicLinkStatus, isDirectory,-                            fileMode, getFileStatus, setFileMode )-import System.Posix ( sleep )-#include "impossible.h"--withLock :: String -> IO a -> IO a-releaseLock :: String -> IO ()--withLock s job = bracket (getlock s 30) releaseLock (\_ -> job)---- | Tries to perform some task if it can obtain the lock,--- Otherwise, just gives up without doing the task-withLockCanFail :: String -> IO a -> IO (Either () a)-withLockCanFail s job =-  bracket (takeLock s)-          (\l -> when l $ releaseLock s)-          (\l -> if l then job >>= (return.Right)-                      else return $ Left ())--getlock :: String -> Int -> IO String-getlock l 0 = do putStrLn $ "Couldn't get lock "++l-                 exitWith $ ExitFailure 1-getlock lbad tl = do l <- canonFilename lbad-                     gotit <- takeLock l-                     if gotit then return l-                              else do putStrLn $ "Waiting for lock "++l-                                      hFlush stdout -- for Windows-                                      done <- sleep 2-                                      if done == 0-                                         then getlock l (tl - 1)-                                         else getlock l 0--removeFileMayNotExist :: FilePathLike p => p -> IO ()-removeFileMayNotExist f = catchNonExistence (removeFile $ toFilePath f) ()--catchNonExistence :: IO a -> a -> IO a-catchNonExistence job nonexistval =-    catch job $-    \e -> if isDoesNotExistError e then return nonexistval-                                   else ioError e--releaseLock s = removeFileMayNotExist s--takeLock :: FilePathLike p => p -> IO Bool-takeLock fp =-    do atomicCreate $ toFilePath fp-       return True-  `catch` \e -> if isAlreadyExistsError e-                then return False-                else do pwd <- getCurrentDirectory-                        throwIO $ addToErrorLoc e-                                   ("takeLock "++toFilePath fp++" in "++toFilePath pwd)--takeFile :: FilePath -> IO Bool-takeFile fp =-    do sloppyAtomicCreate fp-       return True-  `catch` \e -> if isAlreadyExistsError e-                then return False-                else do pwd <- getCurrentDirectory-                        throwIO $ addToErrorLoc e-                                   ("takeFile "++fp++" in "++toFilePath pwd)---- |'withTemp' safely creates an empty file (not open for writing) and--- returns its name.------ The temp file operations are rather similar to the locking operations, in--- that they both should always try to clean up, so exitWith causes trouble.-withTemp :: (String -> IO a) -> IO a-withTemp = bracket get_empty_file removeFileMayNotExist-    where get_empty_file = do (f,h) <- openBinaryTempFile "." "darcs"-                              hClose h-                              return f---- |'withOpenTemp' creates a temporary file, and opens it.--- Both of them run their argument and then delete the file.  Also,--- both of them (to my knowledge) are not susceptible to race conditions on--- the temporary file (as long as you never delete the temporary file; that--- would reintroduce a race condition).-withOpenTemp :: ((Handle, String) -> IO a) -> IO a-withOpenTemp = bracket get_empty_file cleanup--- Warning:  A do-notation statement discarded a result of type Either SomeException ().-    where cleanup (h,f) = do _ <- try (hClose h) :: IO (Either SomeException ())-                             removeFileMayNotExist f-          get_empty_file = invert `fmap` openBinaryTempFile "." "darcs"-          invert (a,b) = (b,a)--withStdoutTemp :: (String -> IO a) -> IO a-withStdoutTemp = bracket (mkStdoutTemp "stdout_") removeFileMayNotExist--tempdirLoc :: IO FilePath-tempdirLoc = firstJustIO [ readBinFile (darcsdir++"/prefs/tmpdir") >>= return . Just . head.words >>= chkdir,-                            maybeGetEnv "DARCS_TMPDIR" >>= chkdir,-                            getTemporaryDirectory >>= chkdir . Just,-                            getCurrentDirectorySansDarcs,-                            return $ Just "."  -- always returns a Just-                          ]-              >>= return . fromJust-    where chkdir Nothing = return Nothing-          chkdir (Just d) = doesDirectoryExist d >>= return . \e -> if e then Just (d++"/") else Nothing--environmentHelpTmpdir :: ([String], [String])-environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [- "Darcs often creates temporary directories.  For example, the `darcs",- "diff' command creates two for the working trees to be diffed.  By",- "default temporary directories are created in /tmp, or if that doesn't",- "exist, in _darcs (within the current repo).  This can be overridden by",- "specifying some other directory in the file _darcs/prefs/tmpdir or the",- "environment variable $DARCS_TMPDIR or $TMPDIR."])--getCurrentDirectorySansDarcs :: IO (Maybe FilePath)-getCurrentDirectorySansDarcs = do-  c <- getCurrentDirectory-  return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c-  where no_darcs x = not $ darcsdir `elem` splitDirectories x--data WithDirKind = Perm | Temp | Delayed--withDir :: WithDirKind -> String -> (AbsolutePath -> IO a) -> IO a-withDir _ "" _ = bug "withDir called with empty directory name"-withDir kind abs_or_relative_name job = do-  absolute_name <- if isRelative abs_or_relative_name-                   then fmap (++ abs_or_relative_name) tempdirLoc-                   else return abs_or_relative_name-  formerdir <- getCurrentDirectory-  bracket (create_directory absolute_name 0)-          (\dir -> do setCurrentDirectory formerdir-                      k <- keep_tmpdir-                      unless k $ do case kind of-                                      Perm -> return ()-                                      Temp -> rmRecursive (toFilePath dir)-                                      Delayed -> atexit $ rmRecursive (toFilePath dir))-          job-    where newname name 0 = name-          newname name n = name ++ "-" ++ show n-          create_directory :: FilePath -> Int -> IO AbsolutePath-          create_directory name n-              = do createDirectory $ newname name n-                   setCurrentDirectory $ newname name n-                   getCurrentDirectory-                `catch` (\e -> if isAlreadyExistsError e-                               then create_directory name (n+1)-                               else throwIO e)-          keep_tmpdir = isJust `fmap` maybeGetEnv "DARCS_KEEP_TMPDIR"--environmentHelpKeepTmpdir :: ([String], [String])-environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[- "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will",- "not remove the temporary directories it creates.  This is intended",- "primarily for debugging Darcs itself, but it can also be useful, for",- "example, to determine why your test preference (see `darcs setpref')",- "is failing when you run `darcs record', but working when run manually."])---- |'withPermDir' is like 'withTempDir', except that it doesn't--- delete the directory afterwards.-withPermDir :: String -> (AbsolutePath -> IO a) -> IO a-withPermDir = withDir Perm---- |'withTempDir' creates an empty directory and then removes it when it--- is no longer needed.  withTempDir creates a temporary directory.  The--- location of that directory is determined by the contents of--- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if--- that doesn't exist then whatever your operating system considers to be a--- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under--- Windows).------ If none of those exist it creates the temporary directory--- in the current directory, unless the current directory is under a _darcs--- directory, in which case the temporary directory in the parent of the highest--- _darcs directory to avoid accidentally corrupting darcs's internals.--- This should not fail, but if it does indeed fail, we go ahead and use the--- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set--- temporary directory is not removed, this can be useful for debugging.-withTempDir :: String -> (AbsolutePath -> IO a) -> IO a-withTempDir = withDir Temp--withDelayedDir :: String -> (AbsolutePath -> IO a) -> IO a-withDelayedDir = withDir Delayed--doesDirectoryReallyExist :: FilePath -> IO Bool-doesDirectoryReallyExist f =-    catchNonExistence (isDirectory `fmap` getSymbolicLinkStatus f) False--rmRecursive :: FilePath -> IO ()-rmRecursive d =-    do isd <- doesDirectoryReallyExist d-       if not isd-          then removeFile d-          else do conts <- actual_dir_contents-                  withCurrentDirectory d $-                    mapM_ rmRecursive conts-                  removeDirectory d-    where actual_dir_contents = -- doesn't include . or ..-              do c <- getDirectoryContents d-                 return $ filter (/=".") $ filter (/="..") c--worldReadableTemp :: String -> IO String-worldReadableTemp f = wrt 0-    where wrt :: Int -> IO String-          wrt 100 = fail $ "Failure creating temp named "++f-          wrt n = let f_new = f++"-"++show n-                  in do ok <- takeFile f_new-                        if ok then return f_new-                              else wrt (n+1)--withNamedTemp :: String -> (String -> IO a) -> IO a-withNamedTemp n = bracket get_empty_file removeFileMayNotExist-    where get_empty_file = worldReadableTemp n--editText :: String -> B.ByteString -> IO B.ByteString-editText desc txt = withNamedTemp desc $ \f -> do-  B.writeFile f txt--- Warning:  A do-notation statement discarded a result of type ExitCode.-  _ <- runEditor f-  B.readFile f--readBinFile :: FilePathLike p => p -> IO String-readBinFile = fmap BC.unpack . B.readFile . toFilePath---- | Reads a file. Differs from readBinFile in that it interprets the file in---   the current locale instead of as ISO-8859-1.-readLocaleFile :: FilePathLike p => p -> IO String-readLocaleFile f = decodeLocale `fmap` B.readFile (toFilePath f)--readDocBinFile :: FilePathLike p => p -> IO Doc-readDocBinFile fp = do ps <- B.readFile $ toFilePath fp-                       return $ if B.null ps then empty else packedString ps--appendBinFile :: FilePathLike p => p -> String -> IO ()-appendBinFile f s = appendToFile f $ \h -> hPutStr h s--appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()-appendDocBinFile f d = appendToFile f $ \h -> hPutDoc h d--writeBinFile :: FilePathLike p => p -> String -> IO ()-writeBinFile f s = writeToFile f $ \h -> hPutStr h s---- | Writes a file. Differs from writeBinFile in that it writes the string---   encoded with the current locale instead of what GHC thinks is right.-writeLocaleFile :: FilePathLike p => p -> String -> IO ()-writeLocaleFile f s = writeToFile f $ \h -> B.hPut h (encodeLocale s)--writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()-writeDocBinFile f d = writeToFile f $ \h -> hPutDoc h d--writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()-writeAtomicFilePS f ps = writeToFile f $ \h -> B.hPut h ps--gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()-gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps]--gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO ()-gzWriteAtomicFilePSs f pss =-    withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do-    gzWriteFilePSs newf pss-    already_exists <- doesFileExist $ toFilePath f-    when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)-                             setFileMode newf mode-             `catchall` return ()-    renameFile newf (toFilePath f)--gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()-gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d--writeToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()-writeToFile f job =-    withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do-    bracket (openBinaryFile newf WriteMode) hClose job-    already_exists <- doesFileExist (toFilePath f)-    when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)-                             setFileMode newf mode-             `catchall` return ()-    renameFile newf (toFilePath f)--appendToFile :: FilePathLike p => p -> (Handle -> IO ()) -> IO ()-appendToFile f job = withSignalsBlocked $-    bracket (openBinaryFile (toFilePath f) AppendMode) hClose job
− src/Darcs/Match.hs 
@@ -1,463 +0,0 @@---  Copyright (C) 2004-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, ScopedTypeVariables, MultiParamTypeClasses, FlexibleInstances, Rank2Types #-}--#include "gadts.h"---- | /First matcher, Second matcher and Nonrange matcher/------ When we match for patches, we have a PatchSet, of which we want a--- subset. This subset is formed by the patches in a given interval--- which match a given criterion. If we represent time going left to--- right, then we have (up to) three 'Matcher's:------ * the 'firstMatcher' is the left bound of the interval,------ * the 'secondMatcher' is the right bound, and------ * the 'nonrangeMatcher' is the criterion we use to select among---   patches in the interval.------- Each of these matchers can be present or not according to the--- options. The patches we want would then be the ones that all--- present matchers have in common.------ (Implementation note: keep in mind that the PatchSet is written--- backwards with respect to the timeline, ie., from right to left)-module Darcs.Match ( matchFirstPatchset, matchSecondPatchset,-               matchPatch,-               matchAPatch, matchAPatchread,-               getFirstMatch, getNonrangeMatch, getNonrangeMatchS,-               getPartialFirstMatch, getPartialSecondMatch,-               getPartialNonrangeMatch,-               firstMatch, secondMatch, haveNonrangeMatch,-               havePatchsetMatch, getOnePatchset,-               checkMatchSyntax, applyInvToMatcher, nonrangeMatcher,-               InclusiveOrExclusive(..), matchExists, applyNInv, hasIndexRange-             ) where--import Text.Regex ( mkRegex, matchRegex )-import Control.Monad ( when )-import Data.Maybe ( isJust )-import Data.List ( isPrefixOf )--import Darcs.MonadProgress ( MonadProgress )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, piap,-                         conscientiously, hopefully )-import Darcs.Patch.Info ( justName )-import Darcs.Patch ( RepoPatch, Patchy, Named, invert, invertRL, patch2patchinfo, apply )-import Darcs.Patch.Dummy ( DummyPatch )-import Darcs.Repository ( Repository, readRepo, createPristineDirectoryTree )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL )-import Darcs.Patch.Apply( ApplyState )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Repository.ApplyPatches ( applyPatches )-import Darcs.Patch.Depends ( getPatchesBeyondTag, splitOnTag )-import Darcs.Witnesses.Ordered ( RL(..), consRLSealed, (:>)(..) )--import ByteStringUtils ( mmapFilePS )--import Darcs.Flags ( DarcsFlag( OnePatch, SeveralPatch, Context,-                               AfterPatch, UpToPatch, LastN, PatchIndexRange,-                               OneTag, AfterTag, UpToTag,-                               OnePattern, SeveralPattern,-                               AfterPattern, UpToPattern ) )-import Darcs.Patch.Bundle ( scanContext )-import Darcs.Patch.Match ( Matcher, MatchFun, matchPattern, applyMatcher, makeMatcher, parseMatch )-import Darcs.Patch.MatchData ( PatchMatch )-import Printer ( text, ($$) )--import Darcs.RepoPath ( toFilePath )-import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )-import Darcs.Patch.FileName ( FileName )-import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed2(..),-                      seal, flipSeal, seal2, unsealFlipped, unseal2, unseal )-import Storage.Hashed.Tree ( Tree )-#include "impossible.h"--data InclusiveOrExclusive = Inclusive | Exclusive deriving Eq---- | @haveNonrangeMatch flags@ tells whether there is a flag in--- @flags@ which corresponds to a match that is "non-range". Thus,--- @--match@, @--patch@ and @--index@ make @haveNonrangeMatch@--- true, but not @--from-patch@ or @--to-patch@.-haveNonrangeMatch :: [DarcsFlag] -> Bool-haveNonrangeMatch fs = isJust (hasIndexRange fs) || isJust (nonrangeMatcher fs::Maybe (Matcher DummyPatch))---- | @havePatchsetMatch flags@ tells whether there is a "patchset--- match" in the flag list. A patchset match is @--match@ or--- @--patch@, or @--context@, but not @--from-patch@ nor (!)--- @--index@.--- Question: Is it supposed not to be a subset of @haveNonrangeMatch@?-havePatchsetMatch :: [DarcsFlag] -> Bool-havePatchsetMatch fs = isJust (nonrangeMatcher fs::Maybe (Matcher DummyPatch)) || hasC fs-    where hasC [] = False-          hasC (Context _:_) = True-          hasC (_:xs) = hasC xs--getNonrangeMatch :: (ApplyMonad IO (ApplyState p), RepoPatch p, ApplyState p ~ Tree)-                 => Repository p C(r u t) -> [DarcsFlag] -> IO ()-getNonrangeMatch r fs = withRecordedMatch r (getNonrangeMatchS fs)--getPartialNonrangeMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)-                        => Repository p C(r u t)-                           -> [DarcsFlag] -> [FileName] -> IO ()-getPartialNonrangeMatch r fs _ =-    withRecordedMatch r (getNonrangeMatchS fs)--getNonrangeMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p, ApplyState p ~ Tree) =>-                        [DarcsFlag] -> PatchSet p C(Origin x) -> m ()-getNonrangeMatchS fs repo =-    case nonrangeMatcher fs of-        Just m -> if nonrangeMatcherIsTag fs-                        then getTagS m repo-                        else getMatcherS Exclusive m repo-        Nothing -> fail "Pattern not specified in getNonrangeMatch."---- | @firstMatch fs@ tells whether @fs@ implies a "first match", that--- is if we match against patches from a point in the past on, rather--- than against all patches since the creation of the repository.-firstMatch :: [DarcsFlag] -> Bool-firstMatch fs = isJust (hasLastn fs)-                 || isJust (firstMatcher fs::Maybe (Matcher DummyPatch))-                 || isJust (hasIndexRange fs)--getFirstMatch :: (ApplyMonad IO (ApplyState p), RepoPatch p, ApplyState p ~ Tree)-              => Repository p C(r u t) -> [DarcsFlag] -> IO ()-getFirstMatch r fs = withRecordedMatch r (getFirstMatchS fs)--getPartialFirstMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)-                     => Repository p C(r u t)-                        -> [DarcsFlag] -> Maybe [FileName] -> IO ()-getPartialFirstMatch r fs _ =-    withRecordedMatch r (getFirstMatchS fs)--getFirstMatchS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p) =>-                     [DarcsFlag] -> PatchSet p C(Origin x) -> m ()-getFirstMatchS fs repo =-    case hasLastn fs of-    Just n -> unpullLastN repo n-    Nothing ->-     case hasIndexRange fs of-     Just (_,b) -> unpullLastN repo b -- b is chronologically earlier than a-     Nothing    ->-      case firstMatcher fs of-               Nothing -> fail "Pattern not specified in getFirstMatch."-               Just m -> if firstMatcherIsTag fs-                         then getTagS m repo-                         else getMatcherS Inclusive m repo---- | @secondMatch fs@ tells whether @fs@ implies a "second match", that--- is if we match against patches up to a point in the past on, rather--- than against all patches until now.-secondMatch :: [DarcsFlag] -> Bool-secondMatch fs = isJust (secondMatcher fs::Maybe (Matcher DummyPatch)) || isJust (hasIndexRange fs)--getPartialSecondMatch :: (RepoPatch p, ApplyMonad IO (ApplyState p), ApplyState p ~ Tree)-                      => Repository p C(r u t)-                        -> [DarcsFlag] -> Maybe [FileName] -> IO ()-getPartialSecondMatch r fs _ =-    withRecordedMatch r $ \repo ->-    case secondMatcher fs of-    Nothing -> case hasIndexRange fs of-                Just (a,_) -> unpullLastN repo (a-1)-                Nothing    -> fail "Two patterns not specified in get_second_match."-    Just m -> if secondMatcherIsTag fs-              then getTagS m repo-              else getMatcherS Exclusive m repo--unpullLastN :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p) => PatchSet p C(x y) -> Int -> m ()-unpullLastN repo n = applyInvRL `unsealFlipped` (safetake n $ newset2RL repo)--checkMatchSyntax :: [DarcsFlag] -> IO ()-checkMatchSyntax opts =- case getMatchPattern opts of-  Nothing -> return ()-  Just p  -> either fail (const $ return ()) $ (parseMatch p::Either String (MatchFun DummyPatch))--getMatchPattern :: [DarcsFlag] -> Maybe PatchMatch-getMatchPattern [] = Nothing-getMatchPattern (OnePattern m:_) = Just m-getMatchPattern (SeveralPattern m:_) = Just m-getMatchPattern (_:fs) = getMatchPattern fs--tagmatch :: String -> Matcher p-tagmatch r = makeMatcher ("tag-name "++r) tm-    where tm (Sealed2 p) =-              let n = justName (info p) in-              "TAG " `isPrefixOf` n && isJust (matchRegex (mkRegex r) $ drop 4 n)--mymatch :: String -> Matcher p-mymatch r = makeMatcher ("patch-name "++r) mm-    where mm (Sealed2 p) = isJust . matchRegex (mkRegex r) . justName . info $ p----- | strictJust is a strict version of the Just constructor, used to ensure--- that if we claim we've got a pattern match, that the pattern will--- actually match (rathern than fail to compile properly).-strictJust :: a -> Maybe a-strictJust x = Just $! x---- | @nonrangeMatcher@ is the criterion that is used to match against--- patches in the interval. It is 'Just m' when the @--patch@, @--match@,--- @--tag@ options are passed (or their plural variants).-nonrangeMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)-nonrangeMatcher [] = Nothing-nonrangeMatcher (OnePattern m:_) = strictJust $ matchPattern m-nonrangeMatcher (OneTag t:_) = strictJust $ tagmatch t-nonrangeMatcher (OnePatch p:_) = strictJust $ mymatch p-nonrangeMatcher (SeveralPattern m:_) = strictJust $ matchPattern m-nonrangeMatcher (SeveralPatch p:_) = strictJust $ mymatch p-nonrangeMatcher (_:fs) = nonrangeMatcher fs---- | @nonrangeMatcherIsTag@ returns true if the matching option was--- '--tag'-nonrangeMatcherIsTag :: [DarcsFlag] -> Bool-nonrangeMatcherIsTag [] = False-nonrangeMatcherIsTag (OneTag _:_) = True-nonrangeMatcherIsTag (_:fs) = nonrangeMatcherIsTag fs---- | @firstMatcher@ returns the left bound of the matched interval.--- This left bound is also specified when we use the singular versions--- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@--- returns @Nothing@.-firstMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)-firstMatcher [] = Nothing-firstMatcher (OnePattern m:_) = strictJust $ matchPattern m-firstMatcher (AfterPattern m:_) = strictJust $ matchPattern m-firstMatcher (AfterTag t:_) = strictJust $ tagmatch t-firstMatcher (OnePatch p:_) = strictJust $ mymatch p-firstMatcher (AfterPatch p:_) = strictJust $ mymatch p-firstMatcher (_:fs) = firstMatcher fs--firstMatcherIsTag :: [DarcsFlag] -> Bool-firstMatcherIsTag [] = False-firstMatcherIsTag (AfterTag _:_) = True-firstMatcherIsTag (_:fs) = firstMatcherIsTag fs--secondMatcher :: Patchy p => [DarcsFlag] -> Maybe (Matcher p)-secondMatcher [] = Nothing-secondMatcher (OnePattern m:_) = strictJust $ matchPattern m-secondMatcher (UpToPattern m:_) = strictJust $ matchPattern m-secondMatcher (OnePatch p:_) = strictJust $ mymatch p-secondMatcher (UpToPatch p:_) = strictJust $ mymatch p-secondMatcher (UpToTag t:_) = strictJust $ tagmatch t-secondMatcher (_:fs) = secondMatcher fs--secondMatcherIsTag :: [DarcsFlag] -> Bool-secondMatcherIsTag [] = False-secondMatcherIsTag (UpToTag _:_) = True-secondMatcherIsTag (_:fs) = secondMatcherIsTag fs---- | @matchAPatchread fs p@ tells whether @p@ matches the matchers in--- the flags listed in @fs@.-matchAPatchread :: Patchy p => [DarcsFlag] -> PatchInfoAnd p C(x y) -> Bool-matchAPatchread fs = case nonrangeMatcher fs of-                       Nothing -> const True-                       Just m -> applyMatcher m---- | @matchAPatch fs p@ tells whether @p@ matches the matchers in--- the flags @fs@-matchAPatch :: Patchy p => [DarcsFlag] -> Named p C(x y) -> Bool-matchAPatch fs p =-    case nonrangeMatcher fs of-    Nothing -> True-    Just m -> applyMatcher m (patch2patchinfo p `piap` p)--matchPatch :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> Sealed2 (Named p)-matchPatch fs ps =-    case hasIndexRange fs of-    Just (a,a') | a == a' -> case (unseal myhead) $ dropn (a-1) ps of-                             Just (Sealed2 p) -> seal2 $ hopefully p-                             Nothing -> error "Patch out of range!"-                | otherwise -> bug ("Invalid index range match given to matchPatch: "++-                                    show (PatchIndexRange a a'))-                where myhead :: PatchSet p C(start x) -> Maybe (Sealed2 (PatchInfoAnd p))-                      myhead (PatchSet NilRL (Tagged t _ _ :<: _)) = Just $ seal2 t-                      myhead (PatchSet (x:<:_) _) = Just $ seal2 x-                      myhead _ = Nothing-    Nothing -> case nonrangeMatcher fs of-                    Nothing -> bug "Couldn't matchPatch"-                    Just m -> findAPatch m ps--getOnePatchset :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> [DarcsFlag] ->-                 IO (SealedPatchSet p C(Origin))-getOnePatchset repository fs =-    case nonrangeMatcher fs of-        Just m -> do ps <- readRepo repository-                     if nonrangeMatcherIsTag fs-                        then return $ getMatchingTag m ps-                        else return $ matchAPatchset m ps-        Nothing -> (seal . scanContext) `fmap` mmapFilePS (toFilePath $ context_f fs)-    where context_f [] = bug "Couldn't match_nonrange_patchset"-          context_f (Context f:_) = f-          context_f (_:xs) = context_f xs---- | @hasLastn fs@ return the @--last@ argument in @fs@, if any.-hasLastn :: [DarcsFlag] -> Maybe Int-hasLastn [] = Nothing-hasLastn (LastN (-1):_) = error "--last requires a positive integer argument."-hasLastn (LastN n:_) = Just n-hasLastn (_:fs) = hasLastn fs--hasIndexRange :: [DarcsFlag] -> Maybe (Int,Int)-hasIndexRange [] = Nothing-hasIndexRange (PatchIndexRange x y:_) = Just (x,y)-hasIndexRange (_:fs) = hasIndexRange fs---- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its--- first matcher, ie the one that comes first dependencywise. Hence,--- patches in @matchFirstPatchset fs ps@ are the context for the ones--- we don't want.-matchFirstPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x)-                   -> SealedPatchSet p C(start)-matchFirstPatchset fs patchset =-    case hasLastn fs of-    Just n -> dropn n patchset-    Nothing ->-        case hasIndexRange fs of-        Just (_,b) -> dropn b patchset-        Nothing ->-               case firstMatcher fs of-               Nothing -> bug "Couldn't matchFirstPatchset"-               Just m -> unseal (dropn 1) $ if firstMatcherIsTag fs-                                            then getMatchingTag m patchset-                                            else matchAPatchset m patchset---- | @dropn n ps@ drops the @n@ last patches from @ps@.-dropn :: Int -> PatchSet p C(start x) -> SealedPatchSet p C(start)-dropn n ps | n <= 0 = seal ps-dropn n (PatchSet NilRL (Tagged t _ ps :<: ts)) = dropn n $ PatchSet (t:<:ps) ts-dropn _ (PatchSet NilRL NilRL) = seal $ PatchSet NilRL NilRL-dropn n (PatchSet (_:<:ps) ts) = dropn (n-1) $ PatchSet ps ts---- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its--- second matcher, ie the one that comes last dependencywise.-matchSecondPatchset :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x)-                    -> SealedPatchSet p C(start)-matchSecondPatchset fs ps =-  case hasIndexRange fs of-  Just (a,_) -> dropn (a-1) ps-  Nothing ->-    case secondMatcher fs of-    Nothing -> bug "Couldn't matchSecondPatchset"-    Just m -> if secondMatcherIsTag fs-              then getMatchingTag m ps-              else matchAPatchset m ps---- | @findAPatch m ps@ returns the last patch in @ps@ matching @m@, and--- calls 'error' if there is none.-findAPatch :: RepoPatch p => Matcher p -> PatchSet p C(start x) -> Sealed2 (Named p)-findAPatch m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m-findAPatch m (PatchSet NilRL (Tagged t _ ps :<: ts)) = findAPatch m (PatchSet (t:<:ps) ts)-findAPatch m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal2 $ hopefully p-                                    | otherwise = findAPatch m (PatchSet ps ts)---- | @matchAPatchset m ps@ returns a (the largest?) subset of @ps@--- ending in patch which matches @m@. Calls 'error' if there is none.-matchAPatchset :: RepoPatch p => Matcher p -> PatchSet p C(start x)-               -> SealedPatchSet p C(start)-matchAPatchset m (PatchSet NilRL NilRL) = error $ "Couldn't find patch matching " ++ show m-matchAPatchset m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchAPatchset m (PatchSet (t:<:ps) ts)-matchAPatchset m (PatchSet (p:<:ps) ts) | applyMatcher m p = seal (PatchSet (p:<:ps) ts)-                                        | otherwise = matchAPatchset m (PatchSet ps ts)---- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags--- returns a 'SealedPatchSet' containing all patches in the last tag which--- matches @m@. Last tag means the most recent tag in repository order,--- i.e. the last one you'd see if you ran darcs changes -t @m@. Calls--- 'error' if there is no matching tag.-getMatchingTag :: RepoPatch p => Matcher p -> PatchSet p C(start x) -> SealedPatchSet p C(start)-getMatchingTag m (PatchSet NilRL NilRL) = error $ "Couldn't find a tag matching " ++ show m-getMatchingTag m (PatchSet NilRL (Tagged t _ ps :<: ts)) = getMatchingTag m (PatchSet (t:<:ps) ts)-getMatchingTag m (PatchSet (p:<:ps) ts)-    | applyMatcher m p =-        -- found a non-clean tag, need to commute out the things that it doesn't depend on-        case splitOnTag (info p) (PatchSet (p:<:ps) ts) of-            patchSet :> _ -> seal patchSet-    | otherwise = getMatchingTag m (PatchSet ps ts)---- | @matchExists m ps@ tells whether there is a patch matching--- @m@ in @ps@-matchExists :: Matcher p -> PatchSet p C(start x) -> Bool-matchExists _ (PatchSet NilRL NilRL) = False-matchExists m (PatchSet NilRL (Tagged t _ ps :<: ts)) = matchExists m (PatchSet (t:<:ps) ts)-matchExists m (PatchSet (p:<:ps) ts) | applyMatcher m $ p = True-                                     | otherwise = matchExists m (PatchSet ps ts)--applyInvToMatcher :: (RepoPatch p, ApplyMonad m (ApplyState p))-                  => InclusiveOrExclusive -> Matcher p -> PatchSet p C(Origin x) -> m ()-applyInvToMatcher _ _ (PatchSet NilRL NilRL) = impossible-applyInvToMatcher ioe m (PatchSet NilRL (Tagged t _ ps :<: ts)) = applyInvToMatcher ioe m-                                                                  (PatchSet (t:<:ps) ts)-applyInvToMatcher ioe m (PatchSet (p:<:ps) xs)-    | applyMatcher m p = when (ioe == Inclusive) (applyInvp p)-    | otherwise = applyInvp p >> applyInvToMatcher ioe m (PatchSet ps xs)---- | @applyNInv@ n ps applies the inverse of the last @n@ patches of @ps@.-applyNInv :: (RepoPatch p, ApplyMonad m (ApplyState p)) => Int -> PatchSet p C(Origin x) -> m ()-applyNInv n _ | n <= 0 = return ()-applyNInv _ (PatchSet NilRL NilRL) = error "Index out of range."-applyNInv n (PatchSet NilRL (Tagged t _ ps :<: ts)) =-  applyNInv n (PatchSet (t :<: ps) ts)-applyNInv n (PatchSet (p :<: ps) xs) =-  applyInvp p >> applyNInv (n - 1) (PatchSet ps xs)---getMatcherS :: (ApplyMonad m (ApplyState p), RepoPatch p) =>-                 InclusiveOrExclusive -> Matcher p -> PatchSet p C(Origin x) -> m ()-getMatcherS ioe m repo =-    if matchExists m repo-    then applyInvToMatcher ioe m repo-    else fail $ "Couldn't match pattern "++ show m--getTagS :: (ApplyMonad m (ApplyState p), MonadProgress m, RepoPatch p) =>-             Matcher p -> PatchSet p C(Origin x) -> m ()-getTagS match repo = do-    let pinfo = patch2patchinfo `unseal2` (findAPatch match repo)-    case getPatchesBeyondTag pinfo repo of-        FlippedSeal extras -> applyInvRL extras---- | @applyInvp@ tries to get the patch that's in a 'PatchInfoAnd--- patch', and to apply its inverse. If we fail to fetch the patch--- (presumably in a partial repositiory), then we share our sorrow--- with the user.-applyInvp :: (Patchy p, ApplyMonad m (ApplyState p)) => PatchInfoAnd p C(x y) -> m ()-applyInvp hp = apply (invert $ fromHopefully hp)-    where fromHopefully = conscientiously $ \e ->-                     text "Sorry, partial repository problem.  Patch not available:"-                     $$ e-                     $$ text ""-                     $$ text "If you think what you're trying to do is ok then"-                     $$ text "report this as a bug on the darcs-user list."---- | a version of 'take' for 'RL' lists that cater for contexts.-safetake :: Int -> RL a C(x y) -> FlippedSeal (RL a) C(y)-safetake 0 _ = flipSeal NilRL-safetake _ NilRL = error "There aren't that many patches..."-safetake i (a:<:as) = a `consRLSealed` safetake (i-1) as--withRecordedMatch :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t)-                  -> (PatchSet p C(Origin r) -> IO ()) -> IO ()-withRecordedMatch r job = do createPristineDirectoryTree r "."-                             readRepo r >>= job--applyInvRL :: (ApplyMonad m (ApplyState p), MonadProgress m, Patchy p) => RL (PatchInfoAnd p) C(x r) -> m ()-applyInvRL = applyPatches . invertRL -- this gives nicer feedback
− src/Darcs/MonadProgress.hs 
@@ -1,71 +0,0 @@-{-# LANGUAGE TypeSynonymInstances #-}---  Copyright (C) 2011 Ganesh Sittampalam------ 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--- SOFTWARE.--module Darcs.MonadProgress ( MonadProgress(..), ProgressAction(..)-                           , silentlyRunProgressActions )-  where--import Prelude hiding ( catch )-import Progress ( beginTedious, endTedious, tediousSize, finishedOneIO )-import Printer ( hPutDocLn, Doc )-import Darcs.ColorPrinter () -- for instance Show Doc-import Control.Exception ( catch )-import System.IO ( stderr )-import qualified Storage.Hashed.Monad as HSM---- |a monadic action, annotated with a progress message that could be printed out--- while running the action, and a message that could be printed out on error.--- Actually printing out these messages is optional to allow non-IO monads to--- just run the action.-data ProgressAction m a =-  ProgressAction-   {paAction :: m a-   ,paMessage :: Doc-   ,paOnError :: Doc-   }--class Monad m => MonadProgress m where-  -- |run a list of 'ProgressAction's. In some monads (typically IO-based ones),-  -- the progress and error messages will be used. In others they will be-  -- ignored and just the actions will be run.-  runProgressActions :: String -> [ProgressAction m ()] -> m ()--instance MonadProgress IO where-  runProgressActions _ [] = return ()-  runProgressActions what items =-    do beginTedious what-       tediousSize what (length items)-       mapM_ go items-       endTedious what-    where go item =-            do finishedOneIO what (show $ paMessage item)-               paAction item `catch` \e ->-                 do hPutDocLn stderr $ paOnError item-                    ioError e---- |run a list of 'ProgressAction's without any feedback messages-silentlyRunProgressActions :: Monad m => String -> [ProgressAction m ()] -> m ()-silentlyRunProgressActions _ = mapM_ paAction--instance (Functor m, Monad m) => MonadProgress (HSM.TreeMonad m) where-  runProgressActions = silentlyRunProgressActions
src/Darcs/Patch.hs view
@@ -16,18 +16,11 @@ --  Boston, MA 02110-1301, USA.  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7 -#include "gadts.h"- module Darcs.Patch-    ( RepoPatch-    , PrimOf+    ( PrimPatchBase(..)     , Named-    , Patchy-    , joinPatches-    , fromPrim-    , fromPrims+    , ApplyState     , rmfile     , addfile     , rmdir@@ -35,20 +28,18 @@     , move     , hunk     , tokreplace-    , namepatch     , anonymous     , binary     , description-    , showContextPatch+    , showPatchWithContext+    , ShowPatchFor(..)     , showPatch-    , showNicely+    , displayPatch+    , content     , infopatch     , changepref     , thing     , things-    , primIsAddfile-    , primIsHunk-    , primIsSetpref     , merge     , commute     , listTouchedFiles@@ -59,26 +50,22 @@     , resolveConflicts     , Effect     , effect-    , primIsBinary-    , gzWritePatch-    , writePatch-    , primIsAdddir     , invert     , invertFL     , invertRL-    , commuteFLorComplain+    , commuteFL     , commuteRL     , readPatch     , readPatchPartial-    , canonize+    , canonizeFL     , sortCoalesceFL     , tryToShrink     , patchname     , patchcontents-    , applyToFilePaths     , apply     , applyToTree-    , effectOnFilePaths+    , maybeApplyToTree+    , effectOnPaths     , patch2patchinfo     , summary     , summaryFL@@ -89,50 +76,47 @@     , getdeps     , listConflictedFiles     , isInconsistent+    , module Darcs.Patch.RepoPatch+    , module Darcs.Patch.PatchInfoAnd     ) where  -import Darcs.Patch.Apply ( applyToFilePaths, effectOnFilePaths, applyToTree )-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Commute ( commuteFLorComplain, commuteRL )-import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts, listConflictedFiles, resolveConflicts )+import Darcs.Patch.Apply ( apply, effectOnPaths, applyToTree,+                           maybeApplyToTree, ApplyState )+import Darcs.Patch.Commute ( commute, commuteFL, commuteRL )+import Darcs.Patch.Conflict ( resolveConflicts ) import Darcs.Patch.Effect ( Effect(effect) )-import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Invert ( invertRL, invertFL )+import Darcs.Patch.Invert ( invert, invertRL, invertFL )+import Darcs.Patch.Inspect ( listTouchedFiles, hunkMatches )+import Darcs.Patch.Merge ( merge ) import Darcs.Patch.Named ( Named,-                           adddeps, namepatch,+                           adddeps,                            anonymous,                            getdeps,                            infopatch,                            patch2patchinfo, patchname, patchcontents )-import Darcs.Patch.Patchy ( Patchy,-                            showPatch, showNicely, showContextPatch,-                            invert,-                            thing, things,-                            apply,-                            description, summary, summaryFL,-                            commute, listTouchedFiles, hunkMatches-                          )-import Darcs.Patch.Prim ( FromPrims, fromPrims, joinPatches, FromPrim, fromPrim,-                          canonize,+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )+import Darcs.Patch.Prim ( canonizeFL,                           sortCoalesceFL,                           rmdir, rmfile, tokreplace, adddir, addfile,                           binary, changepref, hunk, move,-                          primIsAdddir, primIsAddfile,-                          primIsHunk, primIsBinary, primIsSetpref,                           tryToShrink,-                          PrimPatch, PrimPatchBase(..) )+                          PrimPatch ) import Darcs.Patch.Read ( readPatch, readPatchPartial ) import Darcs.Patch.Repair ( isInconsistent ) import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.Show ( writePatch, gzWritePatch )-import Darcs.Patch.Summary ( xmlSummary, plainSummary, plainSummaryPrims )+import Darcs.Patch.Show ( description, showPatch, content, displayPatch+                        , summary, summaryFL, thing, things, ShowPatchFor(..)+                        , showPatchWithContext )+import Darcs.Patch.Summary+    ( listConflictedFiles+    , xmlSummary+    , plainSummary+    , plainSummaryPrims+    ) import Darcs.Patch.TokenReplace ( forceTokReplace )-import Darcs.Patch.V1.Commute ( merge )--import Storage.Hashed.Tree( Tree )---instance (CommuteNoConflicts p, Conflict p, IsHunk p, PatchListFormat p,-          PrimPatchBase p, Patchy p, ApplyState p ~ Tree) => Patchy (Named p)+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , hopefully+    , info+    )
+ src/Darcs/Patch/Annotate.hs view
@@ -0,0 +1,266 @@+{-# LANGUAGE OverloadedStrings #-}++-- Copyright (C) 2010 Petr Rockai+--+-- 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+-- SOFTWARE.++-- |+-- Module      : Darcs.Patch.Annotate+-- Copyright   : 2010 Petr Rockai+-- License     : MIT+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Patch.Annotate+    (+      annotateFile+    , annotateDirectory+    , format+    , machineFormat+    , AnnotateResult+    , Annotate(..)+    , AnnotateRP+    ) where++import Darcs.Prelude++import Control.Monad ( when )+import Control.Monad.State ( modify, modify', gets, execState )++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.Map as M+import qualified Data.Vector as V++import Data.Function ( on )+import Data.List( nub )+import Data.List.NonEmpty ( groupBy )+import qualified Data.List.NonEmpty as NE+import Data.Maybe( isJust, mapMaybe )++import qualified Darcs.Patch.Prim.FileUUID as FileUUID++import Darcs.Patch.Annotate.Class+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FromPrim ( PrimOf(..) )+import Darcs.Patch.Info ( displayPatchInfo, piAuthor, makePatchname )+import Darcs.Patch.Invert ( Invert, invert )+import Darcs.Patch.Named ( patchcontents )+import Darcs.Patch.PatchInfoAnd( info, PatchInfoAnd, hopefully )+import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) )+import Darcs.Patch.TokenReplace ( annotateReplace )+import Darcs.Patch.Witnesses.Ordered++import Darcs.Util.Path ( AnchoredPath, movedirfilename, flatten )+import Darcs.Util.Printer( renderString )+import Darcs.Util.ByteString ( linesPS, decodeLocale )++data FileOrDirectory = File+                     | Directory+                       deriving (Show, Eq)++-- |This constraint expresses what is needed for a repo patch to+-- support the high-level interface to annotation+-- (currently annotateFile and annotateDirectory)+type AnnotateRP p = (Annotate (PrimOf p), Invert (PrimOf p), Effect p)++instance Annotate Prim where+  annotate (FP fn fp) = case fp of+    RmFile -> do+      whenPathIs fn $ modify' (\s -> s { currentPath = Nothing })+      withDirectory $ updateDirectory fn+    AddFile -> return ()+    Hunk off o n -> whenPathIs fn $ withFile $ \c -> do+      let remove = length o+      let add = length n+      i <- gets currentInfo+      a <- gets annotated+      -- NOTE patches are inverted and in inverse order+      modify' $ \s ->+        -- NOTE subtract one from offset because darcs counts from one,+        -- whereas vectors and lists count from zero.+        let (to,from) = splitAt (off-1) c+        in  s { current = FileContent $ map eval $ to ++ replicate add (-1, B.empty) ++ drop remove from+              , annotated = merge i a $ map eval $ take remove $ from+              }+    TokReplace t o n -> whenPathIs fn $ withFile $ \c -> do+      let test = annotateReplace t (BC.pack o) (BC.pack n)+      i <- gets currentInfo+      a <- gets annotated+      modify' $ \s -> s+        { current = FileContent $ map (\(ix,b)->if test b then (-1,B.empty) else (ix,b)) c+        , annotated = merge i a $ map eval $ filter (test . snd) $ c+        }+    -- TODO what if the status of a file changed from text to binary?+    Binary _ _ -> whenPathIs fn $ error "annotate: can't handle binary changes"+  annotate (DP _ AddDir) = return ()+  annotate (DP fn RmDir) = withDirectory $ \c -> do+    whenPathIs fn $ modify' (\s -> s { currentPath = Nothing })+    updateDirectory fn c+  annotate (Move fn fn') = do+    modify' (\s -> s { currentPath = fmap (movedirfilename fn fn') (currentPath s) })+    withDirectory $ \c -> do+      let fix (i, x) = (i, movedirfilename fn fn' x)+      modify $ \s -> s { current = DirContent $ map fix c }+  annotate (ChangePref _ _ _) = return ()++instance Annotate FileUUID.Prim where+  annotate _ = error "annotate not implemented for FileUUID patches"++annotatePIAP :: AnnotateRP p => PatchInfoAnd p wX wY -> AnnotatedM ()+annotatePIAP =+  sequence_ . mapFL annotate . invert . effect . patchcontents . hopefully++withDirectory :: ([(Int, AnchoredPath)] -> AnnotatedM ()) -> AnnotatedM ()+withDirectory actions = do+  what <- gets current+  case what of+    DirContent c -> actions c+    FileContent _ -> return ()++withFile :: ([(Int, B.ByteString)] -> AnnotatedM ()) -> AnnotatedM ()+withFile actions = do+  what <- gets current+  case what of+    FileContent c -> actions c+    DirContent _ -> return ()++whenPathIs :: AnchoredPath -> AnnotatedM () -> AnnotatedM ()+whenPathIs fn actions = do+  p <- gets currentPath+  when (p == Just fn) actions++eval :: (Int, a) -> (Int, a)+eval (i,b) = seq i $ seq b $ (i,b)++merge :: a+      -> V.Vector (Maybe a, BC.ByteString)+      -> [(Int, t)]+      -> V.Vector (Maybe a, BC.ByteString)+merge i a l = a V.// [ (line, (Just i, B.empty))+                     | (line, _) <- l, line >= 0 && line < V.length a]++updateDirectory :: AnchoredPath -> [(Int,AnchoredPath)] -> AnnotatedM ()+updateDirectory path files = do+    case filter ((==path) . snd) files of+      [match@(ident, _)] -> reannotate ident match+      _ -> return ()+  where+    reannotate :: Int -> (Int, AnchoredPath) -> AnnotatedM ()+    reannotate ident match =+      modify $ \x -> x { annotated = annotated x V.// [ (ident, update $ currentInfo x) ]+                       , current = DirContent $ filter (/= match) files }+    update inf = (Just inf, flatten path)++complete :: Annotated -> Bool+complete x = V.all (isJust . fst) $ annotated x++annotate' :: AnnotateRP p+          => RL (PatchInfoAnd p) wX wY+          -> Annotated+          -> Annotated+annotate' NilRL ann = ann+annotate' (ps :<: p) ann+    | complete ann = ann+    | otherwise = annotate' ps $ execState (annotatePIAP p) (ann { currentInfo = info p })++annotateFile :: AnnotateRP p+             => RL (PatchInfoAnd p) wX wY+             -> AnchoredPath+             -> B.ByteString+             -> AnnotateResult+annotateFile patches inipath inicontent = annotated $ annotate' patches initial+  where+    initial = Annotated2 { currentPath = Just inipath+                        , currentInfo = error "There is no currentInfo."+                        , current = FileContent $ zip [0..] (linesPS inicontent)+                        , annotated = V.replicate (length $ breakLines inicontent)+                                                      (Nothing, B.empty)+                        }++annotateDirectory :: AnnotateRP p+                  => RL (PatchInfoAnd p) wX wY+                  -> AnchoredPath+                  -> [AnchoredPath]+                  -> AnnotateResult+annotateDirectory patches inipath inicontent = annotated $ annotate' patches initial+  where+    initial = Annotated2 { currentPath = Just inipath+                        , currentInfo = error "There is no currentInfo."+                        , current = DirContent $ zip [0..] inicontent+                        , annotated = V.replicate (length inicontent) (Nothing, B.empty)+                        }++machineFormat :: B.ByteString -> AnnotateResult -> String+machineFormat d a = unlines [ case i of+                                 Just inf -> show $ makePatchname inf+                                 Nothing -> -- make unknowns uniform, for easier parsing+                                   take 40 ( repeat '0' ) -- fake hash of the right size+                              ++ " | " ++ BC.unpack line ++ " " ++ BC.unpack add+                            | ((i, add), line) <- zip (V.toList a) (breakLines d) ]++format :: B.ByteString -> AnnotateResult -> String+format d a = pi_list ++ "\n" ++ numbered+  where+    numberedLines = zip [(1 :: Int)..] . lines $ file++    prependNum (lnum, annLine) =+        let maxDigits = length . show . length $ numberedLines+            lnumStr = show lnum+            paddingNum = maxDigits - length lnumStr+        in replicate paddingNum ' ' ++ lnumStr ++ ": " ++ annLine++    numbered = unlines . map prependNum $ numberedLines++    pi_list = unlines [ show n ++ ": " ++ renderString (displayPatchInfo i)+                      | (n :: Int, i) <- zip [1..] pis ]++    file = concat [ annotation (fst $ NE.head chunk) ++ " | " ++ line (NE.head chunk) +++                    "\n" ++ unlines [ indent 25 (" | " ++ line l) | l <- NE.tail chunk ]+                  | chunk <- file_ann ]++    pis = nub $ mapMaybe fst $ V.toList a++    pi_map = M.fromList (zip pis [1 :: Int ..])++    file_ann = groupBy ((==) `on` fst) $ zip (V.toList a) (breakLines d)++    line ((_, add), l) = decodeLocale $ BC.concat [l, " ", add]++    annotation (Just i, _) | Just n <- M.lookup i pi_map =+        pad 20 (piMail i) ++ " " ++ pad 4 ('#' : show n)+    annotation _ = pad 25 "unknown"++    pad n str = replicate (n - length str) ' ' ++ take n str++    indent n str = replicate n ' ' ++ str++    piMail pi+        | '<' `elem` piAuthor pi = takeWhile (/= '>') . drop 1 . dropWhile (/= '<') $ piAuthor pi+        | otherwise = piAuthor pi++breakLines :: BC.ByteString -> [BC.ByteString]+breakLines s = case BC.split '\n' s of+    [] -> []+    split | BC.null (last split) -> init split+          | otherwise -> split
+ src/Darcs/Patch/Annotate/Class.hs view
@@ -0,0 +1,37 @@+module Darcs.Patch.Annotate.Class where++import Darcs.Prelude++import Control.Monad.State ( State )+import qualified Data.ByteString as B+import qualified Data.Vector as V++import Darcs.Patch.Info ( PatchInfo )+import Darcs.Util.Path ( AnchoredPath )++type AnnotateResult = V.Vector (Maybe PatchInfo, B.ByteString)++data Content2 f g+  = FileContent (f (g B.ByteString))+  | DirContent (f (g AnchoredPath))++data Annotated2 f g = Annotated2+  { annotated :: !AnnotateResult+  , current :: !(Content2 f g)+  , currentPath :: (Maybe AnchoredPath)+  , currentInfo :: PatchInfo+  }++type Content = Content2 [] ((,) Int)+type Annotated = Annotated2 [] ((,) Int)++deriving instance Eq Content+deriving instance Show Content++deriving instance Eq Annotated+deriving instance Show Annotated++type AnnotatedM = State Annotated++class Annotate p where+  annotate :: p wX wY -> AnnotatedM ()
src/Darcs/Patch/Apply.hs view
@@ -15,11 +15,6 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. --{-# LANGUAGE CPP, MultiParamTypeClasses #-}--#include "gadts.h"- -- | -- Module      : Darcs.Patch.Apply -- Copyright   : 2002-2005 David Roundy@@ -31,70 +26,83 @@ module Darcs.Patch.Apply     (       Apply(..)-    , applyToFilePaths+    , ObjectIdOfPatch+    , applyToPaths     , applyToTree     , applyToState-    , effectOnFilePaths+    , maybeApplyToTree+    , effectOnPaths     ) where -import Prelude hiding ( catch, pi )+import Darcs.Prelude -import Control.Applicative ( (<$>) )-import Control.Arrow ( (***) )+import Control.Exception ( IOException )+import Control.Monad.Catch ( MonadThrow, MonadCatch(catch) ) -import Storage.Hashed.Tree( Tree )-import Storage.Hashed.Monad( virtualTreeMonad )+import Darcs.Util.Path ( AnchoredPath )+import Darcs.Util.Tree ( Tree )  import Darcs.Patch.ApplyMonad ( ApplyMonad(..), withFileNames, ApplyMonadTrans(..) )-import Darcs.Patch.FileName( fn2fp, fp2fn )-import Darcs.Witnesses.Ordered ( FL(..), RL(..) )-+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Object ( ObjectIdOf )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )  class Apply p where     type ApplyState p :: (* -> *) -> *-    apply :: ApplyMonad m (ApplyState p) => p C(x y) -> m ()+    apply :: ApplyMonad (ApplyState p) m => p wX wY -> m ()+    unapply :: ApplyMonad (ApplyState p) m => p wX wY -> m ()+    default unapply :: (ApplyMonad (ApplyState p) m, Invert p) => p wX wY -> m ()+    unapply = apply . invert  instance Apply p => Apply (FL p) where     type ApplyState (FL p) = ApplyState p     apply NilFL = return ()     apply (p:>:ps) = apply p >> apply ps+    unapply NilFL = return ()+    unapply (p:>:ps) = unapply ps >> unapply p  instance Apply p => Apply (RL p) where     type ApplyState (RL p) = ApplyState p     apply NilRL = return ()-    apply (p:<:ps) = apply ps >> apply p---effectOnFilePaths :: (Apply p, ApplyState p ~ Tree)-                  => p C(x y)-                  -> [FilePath]-                  -> [FilePath]-effectOnFilePaths p fps = fps' where-    (_, fps', _) = applyToFilePaths p Nothing fps+    apply (ps:<:p) = apply ps >> apply p+    unapply NilRL = return ()+    unapply (ps:<:p) = unapply p >> unapply ps +type ObjectIdOfPatch p = ObjectIdOf (ApplyState p) -applyToFilePaths :: (Apply p, ApplyState p ~ Tree)-                 => p C(x y)-                 -> Maybe [(FilePath, FilePath)]-                 -> [FilePath]-                 -> ([FilePath], [FilePath], [(FilePath, FilePath)])-applyToFilePaths pa ofpos fs = toFPs $ withFileNames ofnos fns (apply pa) where-        fns = map fp2fn fs-        ofnos = map (fp2fn *** fp2fn) <$> ofpos-        toFPs (affected, new, renames) =-            (map fn2fp affected, map fn2fp new, map (fn2fp *** fn2fp) renames)+effectOnPaths :: (Apply p, ApplyState p ~ Tree)+              => p wX wY+              -> [AnchoredPath]+              -> [AnchoredPath]+effectOnPaths p fps = fps' where+    (_, fps', _) = applyToPaths p Nothing fps +applyToPaths :: (Apply p, ApplyState p ~ Tree)+             => p wX wY+             -> Maybe [(AnchoredPath, AnchoredPath)]+             -> [AnchoredPath]+             -> ([AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)])+applyToPaths pa ofpos fs = withFileNames ofpos fs (apply pa)  -- | Apply a patch to a 'Tree', yielding a new 'Tree'.-applyToTree :: (Apply p, Functor m, Monad m, ApplyState p ~ Tree)-            => p C(x y)+applyToTree :: (Apply p, MonadThrow m, ApplyState p ~ Tree)+            => p wX wY             -> Tree m             -> m (Tree m)-applyToTree patch t = snd <$> virtualTreeMonad (apply patch) t-+applyToTree = applyToState -applyToState :: forall p m C(x y). (Apply p, ApplyMonadTrans m (ApplyState p))-             => p C(x y)+applyToState :: forall p m wX wY. (Apply p, ApplyMonadTrans (ApplyState p) m)+             => p wX wY              -> (ApplyState p) m              -> m ((ApplyState p) m) applyToState patch t = snd <$> runApplyMonad (apply patch) t++-- | Attempts to apply a given patch to a Tree. If the apply fails, we return+-- Nothing, otherwise we return the updated Tree.+maybeApplyToTree+  :: (Apply p, ApplyState p ~ Tree, MonadCatch m)+  => p wX wY+  -> Tree m+  -> m (Maybe (Tree m))+maybeApplyToTree patch tree =+  (Just `fmap` applyToTree patch tree) `catch` (\(_::IOException) -> return Nothing)
src/Darcs/Patch/ApplyMonad.hs view
@@ -1,4 +1,8 @@-{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UndecidableSuperClasses #-} -- Copyright (C) 2010, 2011 Petr Rockai -- -- Permission is hereby granted, free of charge, to any person@@ -20,127 +24,125 @@ -- ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE.-module Darcs.Patch.ApplyMonad( ApplyMonad(..), ApplyMonadTrans(..), withFileNames, withFiles, ToTree(..) ) where+module Darcs.Patch.ApplyMonad+  ( ApplyMonad(..), ApplyMonadTrans(..), ApplyMonadOperations+  , withFileNames+  , ApplyMonadTree(..)+  , evalApplyMonad+  ) where +import Darcs.Prelude+ import qualified Data.ByteString      as B import qualified Data.ByteString.Lazy as BL-import qualified Data.Map             as M-import qualified Storage.Hashed.Monad as HSM-import Storage.Hashed.Tree ( Tree )-import ByteStringUtils( linesPS, unlinesPS )-import Darcs.Patch.FileName( FileName, movedirfilename, fn2fp, isParentOrEqOf )-import Storage.Hashed.AnchoredPath( floatPath, AnchoredPath )+import qualified Darcs.Util.Tree.Monad as TM+import Darcs.Patch.Object ( ObjectIdOf )+import Darcs.Util.StrictIdentity (StrictIdentity(..) )+import Darcs.Util.Tree ( Tree )+import Data.Maybe ( fromMaybe )+import Darcs.Util.Path ( AnchoredPath, movedirfilename, isPrefix )+import Control.Monad.Catch ( MonadThrow(..) ) import Control.Monad.State.Strict-import Control.Monad.Identity( Identity )-import Darcs.MonadProgress --- TODO should UUID/Object live somewhere more central?-import Darcs.Patch.Prim.V3.ObjectMap ( UUID, ObjectMap, DirContent )+import GHC.Exts ( Constraint ) -fn2ap :: FileName -> AnchoredPath-fn2ap = floatPath . fn2fp+class (Monad m, ApplyMonad state (ApplyMonadOver state m))+      => ApplyMonadTrans state m where+  type ApplyMonadOver state m :: * -> *+  runApplyMonad :: (ApplyMonadOver state m) x -> state m -> m (x, state m) -class ToTree s where-  toTree :: s m -> Tree m+instance MonadThrow m => ApplyMonadTrans Tree m where+  type ApplyMonadOver Tree m = TM.TreeMonad m+  runApplyMonad = TM.virtualTreeMonad -instance ToTree Tree where-  toTree = id+evalApplyMonad+  :: ApplyMonadTrans state m => ApplyMonadOver state m a -> state m -> m a+evalApplyMonad action st = fst <$> runApplyMonad action st -class (Functor m, Monad m, ApplyMonad (ApplyMonadOver m state) state)-      => ApplyMonadTrans m (state :: (* -> *) -> *) where-  type ApplyMonadOver m state :: * -> *-  runApplyMonad :: (ApplyMonadOver m state) x -> state m -> m (x, state m)+type family ApplyMonadOperations (state :: (* -> *) -> *) :: (* -> *) -> Constraint -instance (Functor m, Monad m) => ApplyMonadTrans m Tree where-  type ApplyMonadOver m Tree = HSM.TreeMonad m-  runApplyMonad = HSM.virtualTreeMonad+class MonadThrow m => ApplyMonadTree m where+    -- a semantic, Tree-based interface for patch application+    mDoesDirectoryExist ::  AnchoredPath -> m Bool+    mDoesFileExist ::  AnchoredPath -> m Bool+    mReadFilePS ::  AnchoredPath -> m B.ByteString+    mCreateDirectory ::  AnchoredPath -> m ()+    mRemoveDirectory ::  AnchoredPath -> m ()+    mCreateFile ::  AnchoredPath -> m ()+    mRemoveFile ::  AnchoredPath -> m ()+    mRename ::  AnchoredPath -> AnchoredPath -> m ()+    mModifyFilePS ::  AnchoredPath -> (B.ByteString -> m B.ByteString) -> m ()+    mChangePref ::  String -> String -> String -> m ()+    mChangePref _ _ _ = return () -class (Functor m, Monad m, Functor (ApplyMonadBase m), Monad (ApplyMonadBase m), ToTree state)-       -- ApplyMonadOver (ApplyMonadBase m) ~ m is *not* required in general,-       -- since ApplyMonadBase is not injective-       => ApplyMonad m (state :: (* -> *) -> *) where-    type ApplyMonadBase m :: * -> *+type instance ApplyMonadOperations Tree = ApplyMonadTree -    nestedApply :: m x -> state (ApplyMonadBase m) -> m (x, state (ApplyMonadBase m))-    liftApply :: (state (ApplyMonadBase m) -> (ApplyMonadBase m) x) -> state (ApplyMonadBase m)-                 -> m (x, state (ApplyMonadBase m))+class ( Monad m+      , ApplyMonadOperations state m+      )+      => ApplyMonad (state :: (* -> *) -> *) m | m -> state where -    getApplyState :: m (state (ApplyMonadBase m))-    putApplyState :: state m -> m ()+    readFilePS :: ObjectIdOf state -> m B.ByteString -    -- a semantic, ObjectMap-based interface for patch application-    editFile :: (state ~ ObjectMap) => UUID -> (B.ByteString -> B.ByteString) -> m ()-    editDirectory :: (state ~ ObjectMap) => UUID -> (DirContent -> DirContent) -> m ()+instance MonadThrow m => ApplyMonad Tree (TM.TreeMonad m) where+    readFilePS path = mReadFilePS path -    -- a semantic, Tree-based interface for patch application-    mDoesDirectoryExist :: (state ~ Tree) => FileName -> m Bool-    mDoesFileExist :: (state ~ Tree) => FileName -> m Bool-    mReadFilePS :: (state ~ Tree) => FileName -> m B.ByteString-    mReadFilePSs :: (state ~ Tree) => FileName -> m [B.ByteString]-    mReadFilePSs f = linesPS `fmap` mReadFilePS f-    mCreateDirectory :: (state ~ Tree) => FileName -> m ()-    mRemoveDirectory :: (state ~ Tree) => FileName -> m ()-    mCreateFile :: (state ~ Tree) => FileName -> m ()-    mCreateFile f = mModifyFilePS f $ \_ -> return B.empty-    mRemoveFile :: (state ~ Tree) => FileName -> m ()-    mRename :: (state ~ Tree) => FileName -> FileName -> m ()-    mModifyFilePS :: (state ~ Tree) => FileName -> (B.ByteString -> m B.ByteString) -> m ()-    mModifyFilePSs :: (state ~ Tree) => FileName -> ([B.ByteString] -> m [B.ByteString]) -> m ()-    mModifyFilePSs f j = mModifyFilePS f (fmap unlinesPS . j . linesPS)-    mChangePref :: (state ~ Tree) => String -> String -> String -> m ()-    mChangePref _ _ _ = return ()+instance MonadThrow m => ApplyMonadTree (TM.TreeMonad m) where+    mDoesDirectoryExist p = TM.directoryExists p+    mDoesFileExist p = TM.fileExists p+    mReadFilePS p = BL.toStrict <$> TM.readFile p+    mModifyFilePS p j =+      TM.writeFile p . BL.fromStrict =<< j . BL.toStrict =<< TM.readFile p+    mCreateFile p = TM.writeFile p BL.empty+    mCreateDirectory p = TM.createDirectory p+    mRename from to = TM.rename from to+    mRemoveDirectory = TM.unlink+    mRemoveFile = TM.unlink -instance (Functor m, Monad m) => ApplyMonad (HSM.TreeMonad m) Tree where-    type ApplyMonadBase (HSM.TreeMonad m) = m-    getApplyState = gets HSM.tree-    nestedApply a start = lift $ runApplyMonad a start-    liftApply a start = do x <- gets HSM.tree-                           lift $ runApplyMonad (lift $ a x) start+-- Latest name, current original name.+type OrigFileNameOf = (AnchoredPath, AnchoredPath)+-- Touched files, new file list (after removes etc.) and rename details+type FilePathMonadState = ([AnchoredPath], [AnchoredPath], [OrigFileNameOf])+type FilePathMonad = StateT FilePathMonadState Pure -    -- putApplyState needs some support from HSM+newtype Pure a = Pure (StrictIdentity a)+  deriving (Functor, Applicative, Monad) -    mDoesDirectoryExist d = HSM.directoryExists (fn2ap d)-    mDoesFileExist d = HSM.fileExists (fn2ap d)-    mReadFilePS p = B.concat `fmap` BL.toChunks `fmap` HSM.readFile (fn2ap p)-    mModifyFilePS p j = do have <- HSM.fileExists (fn2ap p)-                           x <- if have then B.concat `fmap` BL.toChunks `fmap` HSM.readFile (fn2ap p)-                                        else return B.empty-                           HSM.writeFile (fn2ap p) . BL.fromChunks . (:[]) =<< j x-    mCreateDirectory p = HSM.createDirectory (fn2ap p)-    mRename from to = HSM.rename (fn2ap from) (fn2ap to)-    mRemoveDirectory = HSM.unlink . fn2ap-    mRemoveFile = HSM.unlink . fn2ap+runPure :: Pure a -> a+runPure (Pure (StrictIdentity x)) = x --- Latest name, current original name.-type OrigFileNameOf = (FileName, FileName)--- Touched files, new file list (after removes etc.) and rename details-type FilePathMonadState = ([FileName], [FileName], [OrigFileNameOf])-type FilePathMonad = State FilePathMonadState+-- With "Data.Functor.Identity" this instance would not satisfy the law+-- @throwM e >> x = throwM e@, which is why we use 'StrictIdentity'.+instance MonadThrow Pure where+  throwM e = Pure (error (show e))  -- |trackOrigRename takes an old and new name and attempts to apply the mapping -- to the OrigFileNameOf pair. If the old name is the most up-to-date name of -- the file in question, the first element of the OFNO will match, otherwise if -- the up-to-date name was originally old, the second element will match.-trackOrigRename :: FileName -> FileName -> OrigFileNameOf -> OrigFileNameOf+trackOrigRename :: AnchoredPath -> AnchoredPath -> OrigFileNameOf -> OrigFileNameOf trackOrigRename old new pair@(latest, from)-    | old `isParentOrEqOf` latest = (latest, movedirfilename old new latest)-    | old `isParentOrEqOf` from = (latest, movedirfilename old new from)+    | old `isPrefix` latest = (latest, movedirfilename old new latest)+    | old `isPrefix` from = (latest, movedirfilename old new from)     | otherwise = pair  -- |withFileNames takes a maybe list of existing rename-pairs, a list of -- filenames and an action, and returns the resulting triple of affected files, -- updated filename list and new rename details. If the rename-pairs are not -- present, a new list is generated from the filesnames.-withFileNames :: (Maybe [OrigFileNameOf]) -> [FileName] -> FilePathMonad a+withFileNames :: Maybe [OrigFileNameOf] -> [AnchoredPath] -> FilePathMonad a     -> FilePathMonadState-withFileNames mbofnos fps x = execState x ([], fps, ofnos) where-    ofnos = maybe (map (\y -> (y, y)) fps) id mbofnos+withFileNames mbofnos fps x = runPure $ execStateT x ([], fps, ofnos)+  where+    ofnos = fromMaybe (map (\y -> (y, y)) fps) mbofnos -instance ApplyMonad FilePathMonad Tree where-    type ApplyMonadBase FilePathMonad = Identity-    -- We can't check it actually is a directory here-    mDoesDirectoryExist d = gets $ \(_, fs, _) -> d `elem` fs+instance ApplyMonad Tree FilePathMonad where+    readFilePS = error "readFilePS not defined for FilePathMonad" +instance ApplyMonadTree FilePathMonad where+    -- We can't check it actually is a directory here+    mDoesDirectoryExist p = gets $ \(_, fs, _) -> p `elem` fs+    mDoesFileExist = mDoesDirectoryExist     mCreateDirectory = mCreateFile     mCreateFile f = modify $ \(ms, fs, rns) -> (f : ms, fs, rns)     mRemoveFile f = modify $ \(ms, fs, rns) -> (f : ms, filter (/= f) fs, rns)@@ -150,28 +152,4 @@                                    , map (movedirfilename a b) fs                                    , map (trackOrigRename a b) rns)     mModifyFilePS f _ = mCreateFile f--instance MonadProgress FilePathMonad where-  runProgressActions = silentlyRunProgressActions--type RestrictedApply = State (M.Map FileName B.ByteString)--instance ApplyMonad RestrictedApply Tree where-  type ApplyMonadBase RestrictedApply = Identity-  mDoesDirectoryExist _ = return True-  mCreateDirectory _ = return ()-  mRemoveFile f = modify $ M.delete f-  mRemoveDirectory _ = return ()-  mRename a b = modify $ M.mapKeys (movedirfilename a b)-  mModifyFilePS f j = do look <- gets $ M.lookup f-                         case look of-                           Nothing -> return ()-                           Just bits -> do-                             new <- j bits-                             modify $ M.insert f new--instance MonadProgress RestrictedApply where-  runProgressActions = silentlyRunProgressActions--withFiles :: [(FileName, B.ByteString)] -> RestrictedApply a -> [(FileName, B.ByteString)]-withFiles p x = M.toList $ execState x $ M.fromList p+    mReadFilePS = error "mReadFilePS not defined for FilePathMonad"
src/Darcs/Patch/Bracketed.hs view
@@ -1,40 +1,53 @@ module Darcs.Patch.Bracketed     ( Bracketed(..), mapBracketed, unBracketed-    , BracketedFL, mapBracketedFL_FL, unBracketedFL+    , BracketedFL, mapBracketedFLFL, unBracketedFL     ) where -#include "gadts.h"+import Darcs.Prelude  import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Witnesses.Ordered ( FL(..), mapFL_FL, concatFL )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL, mapFL_FL, concatFL )+import Darcs.Util.Printer ( vcat, blueText, ($$) ) + -- |This type exists for legacy support of on-disk format patch formats. -- It is a wrapper type that explicitly tracks the nesting of braces and parens -- in the on-disk representation of such patches. It is used as an intermediate -- form when reading such patches normally, and also for round-tripping such -- patches when checking the hash in bundles. -- It shouldn't be used for anything else.-data Bracketed p C(x y) where-  Singleton :: p C(x y) -> Bracketed p C(x y)            -- A single patch, not wrapped in anything-  Braced :: BracketedFL p C(x y) -> Bracketed p C(x y)   -- A list of patches, wrapped in {}-  Parens :: BracketedFL p C(x y) -> Bracketed p C(x y)   -- A list of patches, wrapped in ()+data Bracketed p wX wY where+  Singleton :: p wX wY -> Bracketed p wX wY            -- A single patch, not wrapped in anything+  Braced :: BracketedFL p wX wY -> Bracketed p wX wY   -- A list of patches, wrapped in {}+  Parens :: BracketedFL p wX wY -> Bracketed p wX wY   -- A list of patches, wrapped in () -type BracketedFL p C(x y) = FL (Bracketed p) C(x y)+type BracketedFL p wX wY = FL (Bracketed p) wX wY -unBracketed :: Bracketed p C(x y) -> FL p C(x y)+unBracketed :: Bracketed p wX wY -> FL p wX wY unBracketed (Singleton p) = p :>: NilFL unBracketed (Braced ps) = unBracketedFL ps unBracketed (Parens ps) = unBracketedFL ps -unBracketedFL :: BracketedFL p C(x y) -> FL p C(x y)+unBracketedFL :: BracketedFL p wX wY -> FL p wX wY unBracketedFL = concatFL . mapFL_FL unBracketed -mapBracketed :: (FORALL(a b) p C(a b) -> q C(a b)) -> Bracketed p C(x y) -> Bracketed q C(x y)+mapBracketed :: (forall wA wB . p wA wB -> q wA wB) -> Bracketed p wX wY -> Bracketed q wX wY mapBracketed f (Singleton p) = Singleton (f p)-mapBracketed f (Braced ps) = Braced (mapBracketedFL_FL f ps)-mapBracketed f (Parens ps) = Parens (mapBracketedFL_FL f ps)+mapBracketed f (Braced ps) = Braced (mapBracketedFLFL f ps)+mapBracketed f (Parens ps) = Parens (mapBracketedFLFL f ps) -mapBracketedFL_FL :: (FORALL(a b) p C(a b) -> q C(a b)) -> BracketedFL p C(x y) -> BracketedFL q C(x y)-mapBracketedFL_FL f ps = mapFL_FL (mapBracketed f) ps+mapBracketedFLFL :: (forall wA wB . p wA wB -> q wA wB) -> BracketedFL p wX wY -> BracketedFL q wX wY+mapBracketedFLFL f = mapFL_FL (mapBracketed f)  instance PatchListFormat (Bracketed p)++instance ShowPatchBasic p => ShowPatchBasic (Bracketed p) where+    showPatch f (Singleton p) = showPatch f p+    showPatch _ (Braced NilFL) = blueText "{" $$ blueText "}"+    showPatch f (Braced ps) = blueText "{" $$ vcat (mapFL (showPatch f) ps) $$ blueText "}"+    showPatch f (Parens ps) = blueText "(" $$ vcat (mapFL (showPatch f) ps) $$ blueText ")"++-- the ReadPatch instance is defined in Darcs.Patch.Read as it is+-- used as an intermediate form during reading of lists of patches+-- that are specified as ListFormatV1 or ListFormatV2.
− src/Darcs/Patch/Bracketed/Instances.hs 
@@ -1,21 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Bracketed.Instances () where--import Darcs.Patch.Bracketed ( Bracketed(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..) )--import Darcs.Witnesses.Ordered ( FL(NilFL), mapFL )--import Printer ( vcat, blueText, ($$) )--#include "gadts.h"--instance ShowPatchBasic p => ShowPatchBasic (Bracketed p) where-    showPatch (Singleton p) = showPatch p-    showPatch (Braced NilFL) = blueText "{" $$ blueText "}"-    showPatch (Braced ps) = blueText "{" $$ vcat (mapFL showPatch ps) $$ blueText "}"-    showPatch (Parens ps) = blueText "(" $$ vcat (mapFL showPatch ps) $$ blueText ")"---- the ReadPatch instance is defined in Darcs.Patch.Read as it is--- used as an intermediate form during reading of lists of patches--- that are specified as ListFormatV1 or ListFormatV2.
src/Darcs/Patch/Bundle.hs view
@@ -14,243 +14,290 @@ -- along with this program; see the file COPYING.  If not, write to -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA.+module Darcs.Patch.Bundle+    ( Bundle(..)+    , makeBundle+    , parseBundle+    , interpretBundle+    , readContextFile+    , minContext+    ) where -{-# LANGUAGE CPP #-}+import Darcs.Prelude -#include "gadts.h"+import Control.Applicative ( many, (<|>) )+import Control.Monad ( (<=<) ) -module Darcs.Patch.Bundle ( hashBundle, makeBundle2, makeBundleN, scanBundle,-                            contextPatches, scanContext, patchFilename, getContext,-                            parseBundle-                   ) where+import qualified Data.ByteString as B+    ( ByteString+    , breakSubstring+    , concat+    , drop+    , isPrefixOf+    , null+    , splitAt+    )+import qualified Data.ByteString.Char8 as BC+    ( break+    , dropWhile+    , pack+    ) -import Data.Char ( isAlpha, toLower, isDigit, isSpace )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, piap, fmapFL_PIAP,-                         patchInfoAndPatch,-                         unavailable, hopefully )-import Darcs.Patch ( RepoPatch, Named, showPatch, showContextPatch, readPatchPartial )-import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Apply ( ApplyState, ObjectIdOfPatch )+import Darcs.Patch.ApplyMonad ( ApplyMonadTrans ) import Darcs.Patch.Bracketed ( Bracketed, unBracketedFL )-import Darcs.Patch.Bracketed.Instances ()+import Darcs.Patch.Commute ( Commute, commuteFL )+import Darcs.Patch.Depends ( contextPatches, splitOnTag ) import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, humanFriendly, isTag )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet )-import Darcs.Patch.Show ( ShowPatchBasic )-import Darcs.Patch.Depends ( slightlyOptimizePatchset )-import Darcs.Patch.ReadMonads ( parseStrictly )-import Darcs.Patch.PatchInfoAnd( info )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( RL(..), FL(..), (:>)(..),-                             reverseFL, (+<+), mapFL, mapFL_FL, mapRL )-import Printer ( Doc, renderPS, newline, text, ($$),-                 (<>), vcat, vsep, renderString )+import Darcs.Patch.Info+    ( PatchInfo+    , displayPatchInfo+    , piTag+    , readPatchInfo+    , showPatchInfo+    )+import Darcs.Patch.Named ( Named, fmapFL_Named )+import Darcs.Patch.Object ( ObjectId )+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , info+    , n2pia+    , patchInfoAndPatch+    , unavailable+    )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )+import Darcs.Patch.Read ( readPatch' )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Show ( showPatch, showPatchWithContext )+import Darcs.Patch.Set+    ( PatchSet(..)+    , SealedPatchSet+    , Origin+    , appendPSFL+    )+import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor(ForStorage) )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..)+    , FL(..)+    , RL(..)+    , mapFL+    , mapFL_FL+    , mapRL+    , reverseFL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd, unsafeCoercePStart ) -import ByteStringUtils ( linesPS, unlinesPS, dropSpace, substrPS)-import qualified Data.ByteString as B (ByteString, length, null, drop, isPrefixOf)-import qualified Data.ByteString.Char8 as BC (unpack, break, pack)+import Darcs.Util.ByteString+    ( dropSpace+    , mmapFilePS+    , betweenLinesPS+    )+import Darcs.Util.Hash ( sha1PS, sha1Show )+import Darcs.Util.Parser+    ( Parser+    , lexString+    , lexWord+    , optional+    , parse+    )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , newline+    , packedString+    , renderPS+    , renderString+    , text+    , vcat+    , vsep+    ) -import SHA1( sha1PS )-import Darcs.Witnesses.Sealed ( Sealed(Sealed)) -import Storage.Hashed.Tree( Tree )-import Storage.Hashed.Monad( virtualTreeIO )+-- | A 'Bundle' is a context together with some patches. The context+-- consists of unavailable patches.+data Bundle p wX wY where+  Bundle :: (FL (PatchInfoAnd p) :> FL (PatchInfoAnd p)) wX wY+         -> Bundle p wX wY --- |hashBundle creates a SHA1 string of a given a FL of named patches. This--- allows us to ensure that the patches in a received patchBundle have not been--- modified in transit.-hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (Named p) C(x y) -> String-hashBundle to_be_sent = sha1PS $ renderPS-                         $ vcat (mapFL showPatch to_be_sent) <> newline+-- | Interpret a 'Bundle' in the context of a 'PatchSet'. This means we+-- match up a possible tag in the context of the 'Bundle'. This fails if+-- the tag couldn't be found.+interpretBundle :: Commute p+                => PatchSet p Origin wT+                -> Bundle p wA wB+                -> Either String (PatchSet p Origin wB)+interpretBundle ref (Bundle (context :> patches)) =+  flip appendPSFL patches <$> interpretContext ref context -makeBundleN :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO)-             -> PatchSet p C(start x) -> FL (Named p) C(x y) -> IO Doc-makeBundleN the_s (PatchSet ps (Tagged t _ _ :<: _)) to_be_sent =-    makeBundle2 the_s (ps +<+ (t :<: NilRL)) to_be_sent to_be_sent-makeBundleN the_s (PatchSet ps NilRL) to_be_sent =-    makeBundle2 the_s ps to_be_sent to_be_sent+-- | Create a b16 encoded SHA1 of a given a FL of named patches. This allows us+-- to ensure that the patches in a received bundle have not been modified in+-- transit.+hashBundle :: (PatchListFormat p, ShowPatchBasic p) => FL (Named p) wX wY+           -> B.ByteString+hashBundle to_be_sent =+    sha1Show $ sha1PS $ renderPS $+        vcat (mapFL (showPatch ForStorage) to_be_sent) <> newline --- | In makeBundle2, it is presumed that the two patch sequences are--- identical, but that they may be lazily generated.  If two different--- patch sequences are passed, a bundle with a mismatched hash will be--- generated, which is not the end of the world, but isn't very useful--- either.-makeBundle2 :: (ApplyState p ~ Tree, RepoPatch p) => Maybe (Tree IO) -> RL (PatchInfoAnd p) C(start x)-             -> FL (Named p) C(x y) -> FL (Named p) C(x y) -> IO Doc-makeBundle2 the_s common' to_be_sent to_be_sent2 =-    do patches <- case the_s of-                    Just tree -> fst `fmap` virtualTreeIO (showContextPatch to_be_sent) tree-                    Nothing -> return (vsep $ mapFL showPatch to_be_sent)-       return $ format patches-    where format the_new = text ""-                           $$ text "New patches:"-                           $$ text ""-                           $$ the_new-                           $$ text ""-                           $$ text "Context:"-                           $$ text ""-                           $$ (vcat $ map showPatchInfo common)-                           $$ text "Patch bundle hash:"-                           $$ text (hashBundle to_be_sent2)-                           $$ text ""-          common = mapRL info common'+makeBundle+  :: (RepoPatch p, ApplyMonadTrans (ApplyState p) IO, ObjectId (ObjectIdOfPatch p))+  => Maybe (ApplyState p IO)+  -> PatchSet p wStart wX+  -> FL (Named p) wX wY+  -> IO Doc+makeBundle mstate repo to_be_sent+  | _ :> context <- contextPatches repo =+    format context <$>+      case mstate of+        Just state -> showPatchWithContext ForStorage state to_be_sent+        Nothing -> return (vsep $ mapFL (showPatch ForStorage) to_be_sent)+  where+    format context patches =+      text ""+      $$ text "New patches:"+      $$ text ""+      $$ patches+      $$ text ""+      $$ text "Context:"+      $$ text ""+      $$ vcat (mapRL (showPatchInfo ForStorage . info) context)+      $$ text "Patch bundle hash:"+      $$ packedString (hashBundle to_be_sent)+      $$ text "" -parseBundle ::forall p. RepoPatch p => B.ByteString-              -> Either String (Sealed ((PatchSet p :> FL (PatchInfoAnd p)) C(Origin)))-parseBundle ps-  | B.null ps = Left "Bad patch bundle!"-  | otherwise =-    case sillyLex ps of-    ("New patches:",rest) ->-        case getPatches rest of-        (Sealed bracketedPatches, rest') ->-            case sillyLex rest' of-            ("Context:", rest'') ->-                case getContext rest'' of-                (cont,maybe_hash) ->-                    case substrPS (BC.pack "Patch bundle hash:")-                         maybe_hash of-                    Just n ->-                        if hashBundle (mapFL_FL hopefully bracketedPatches)-                               == fst (sillyLex $ snd $ sillyLex $-                                       B.drop n maybe_hash)-                        then Right $ sealContextWithPatches cont bracketedPatches-                        else Left $-                                 "Patch bundle failed hash!\n" ++-                                 "This probably means that the patch has been "++-                                 "corrupted by a mailer.\n"++-                                 "The most likely culprit is CRLF newlines."-                    Nothing -> Right $ sealContextWithPatches cont bracketedPatches-            (a,r) -> Left $ "Malformed patch bundle: '"++a++"' is not 'Context:'"-                     ++ "\n" ++ BC.unpack r-    ("Context:",rest) ->-        case getContext rest of-        (cont, rest') ->-            case sillyLex rest' of-            ("New patches:", rest'') ->-                case getPatches rest'' of-                (Sealed bracketedPatches, _) -> Right $ sealContextWithPatches cont bracketedPatches-            (a,_) -> Left $ "Malformed patch bundle: '" ++ a ++-                     "' is not 'New patches:'"-    ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->-            parseBundle $ filterGpgDashes rest-    (_,rest) -> parseBundle rest-    where sealContextWithPatches :: RepoPatch p => [PatchInfo] -> FL (PatchInfoAnd (Bracketed p)) C(x y) -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) C(Origin))-          sealContextWithPatches context bracketedPatches =-              let patches = mapFL_FL (fmapFL_PIAP unBracketedFL) bracketedPatches in-              case reverse context of-              (x:ry) | isTag x ->-                        Sealed $ (PatchSet-                                  (unavailablePatches (reverse ry))-                                  (Tagged (piUnavailable x) Nothing NilRL :<: NilRL)-                                  :> patches)-              _ -> Sealed ((PatchSet (unavailablePatches context)-                            NilRL) :> patches)-                   -- The above NilRLs aren't quite right, because ther *are*-                   -- earlier patches, but we can't set this to undefined-                   -- because there are situations where we look at the rest.-                   -- :{+hashFailureMessage :: String+hashFailureMessage =+  "Patch bundle failed hash!\n\+  \This probably means that the patch has been corrupted by a mailer.\n\+  \The most likely culprit is CRLF newlines." +parseBundle :: RepoPatch p+            => B.ByteString -> Either String (Sealed (Bundle p wX))+parseBundle =+    fmap fst . parse pUnsignedBundle . dropInitialTrash . decodeGpgClearsigned+  where+    dropInitialTrash s =+      case BC.break (== '\n') (dropSpace s) of+        (line,rest)+          | contextName `B.isPrefixOf` line || patchesName `B.isPrefixOf` line -> s+          | B.null rest -> rest+          | otherwise -> dropInitialTrash rest -scanBundle ::forall p . RepoPatch p => B.ByteString-             -> Either String (SealedPatchSet p C(Origin))-scanBundle bundle = do-  Sealed ((PatchSet recent tagged):>ps) <- parseBundle bundle-  return . Sealed $ PatchSet (reverseFL ps +<+ recent) tagged+pUnsignedBundle :: forall p wX. RepoPatch p => Parser (Sealed (Bundle p wX))+pUnsignedBundle = pContextThenPatches <|> pPatchesThenContext+  where+    packBundle context patches =+      Sealed $ Bundle $ (unavailablePatchesFL (reverse context)) :>+        (mapFL_FL (n2pia . fmapFL_Named unBracketedFL) patches)+    -- Is this a legacy format?+    pContextThenPatches = do+      context <- pContext+      Sealed patches <- pPatches+      return $ packBundle context patches+    pPatchesThenContext = do+      Sealed patches <- pPatches+      context <- pContext+      mBundleHash <- optional pBundleHash+      case mBundleHash of+        Just bundleHash -> do+          let realHash = hashBundle patches+          if realHash == bundleHash+            then return $ packBundle context patches+            else fail hashFailureMessage+        Nothing -> return $ packBundle context patches --- |filterGpgDashes unescapes a clearsigned patch, which will have had any--- lines starting with dashes escaped with a leading "- ".-filterGpgDashes :: B.ByteString -> B.ByteString-filterGpgDashes ps =-    unlinesPS $ map drop_dashes $-    takeWhile (/= BC.pack "-----END PGP SIGNED MESSAGE-----") $-    dropWhile not_context_or_newpatches $ linesPS ps-    where drop_dashes x = if B.length x < 2 then x-                          else if BC.pack "- " `B.isPrefixOf` x-                               then B.drop 2 x-                               else x-          not_context_or_newpatches s = (s /= BC.pack "Context:") &&-                                        (s /= BC.pack "New patches:")+pBundleHash :: Parser B.ByteString+pBundleHash = lexString bundleHashName >> lexWord --- |unavailablePatches converts a list of PatchInfos into a RL of PatchInfoAnd--- Unavailable patches. This is used to represent the Context of a patchBundle.-unavailablePatches :: RepoPatch p => [PatchInfo] -> RL (PatchInfoAnd p) C(x y)-unavailablePatches [] = unsafeCoerceP NilRL-unavailablePatches (x:xs) = piUnavailable x :<: unavailablePatches xs+bundleHashName :: B.ByteString+bundleHashName = BC.pack "Patch bundle hash:" --- |piUnavailable returns an Unavailable within a PatchInfoAnd given a--- PatchInfo.-piUnavailable :: RepoPatch p => PatchInfo -> PatchInfoAnd p C(x y)-piUnavailable i = (i `patchInfoAndPatch`-                      unavailable ("Patch not stored in patch bundle:\n" ++-                                   renderString (humanFriendly i)))+unavailablePatchesFL :: [PatchInfo] -> FL (PatchInfoAnd p) wX wY+unavailablePatchesFL = foldr ((:>:) . piUnavailable) (unsafeCoercePEnd NilFL)+  where+    piUnavailable i = patchInfoAndPatch i . unavailable $+      "Patch not stored in patch bundle:\n" ++ renderString (displayPatchInfo i) --- |getContext parses a context list, returning a tuple containing the list,--- and remaining ByteString input.-getContext :: B.ByteString -> ([PatchInfo],B.ByteString)-getContext ps =-    case parseStrictly readPatchInfo ps of-    Just (pinfo,r') ->-        case getContext r' of-        (pis,r'') -> (pinfo:pis, r'')-    Nothing -> ([],ps)+pContext :: Parser [PatchInfo]+pContext = lexString contextName >> many readPatchInfo --- |(-:-) is used to build up a Sealed FL of patches and tuple it, along with--- any unconsumed input.-(-:-) :: a C(x y) -> (Sealed (FL a C(y)),b) -> (Sealed (FL a C(x)),b)-p -:- (Sealed ps, r) = (Sealed (p:>:ps), r)+contextName :: B.ByteString+contextName = BC.pack "Context:" --- |getPatches attempts to parse a sequence of patches from a ByteString,--- returning the FL of as many patches-with-info as were successfully parsed,--- along with any unconsumed input.-getPatches :: RepoPatch p => B.ByteString -> (Sealed (FL (PatchInfoAnd (Bracketed p)) C(x)), B.ByteString)-getPatches ps =-    case parseStrictly readPatchInfo ps of-    Nothing -> (Sealed NilFL, ps)-    Just (pinfo,_) ->-        case readPatchPartial ps of-        Nothing -> (Sealed NilFL, ps)-        Just (Sealed p, r) -> (pinfo `piap` p) -:- getPatches r+pPatches :: RepoPatch p => Parser (Sealed (FL (Named (Bracketed p)) wX))+pPatches = lexString patchesName >> readPatch' --- |sillyLex takes a ByteString and breaks it upon the first newline, having--- removed any leading spaces. The before-newline part is unpacked to a String,--- and tupled up with the remaining ByteString. -sillyLex :: B.ByteString -> (String, B.ByteString)-sillyLex ps = (BC.unpack a, b)-    where-        (a, b) = BC.break (== '\n') (dropSpace ps)+patchesName :: B.ByteString+patchesName = BC.pack "New patches:" -contextPatches :: RepoPatch p => PatchSet p C(Origin x) ->-                  (PatchSet p :> (RL (PatchInfoAnd p))) C(Origin x)-contextPatches set = case slightlyOptimizePatchset set of-  PatchSet ps (Tagged t _ ps' :<: ts)-      -> (PatchSet ps' ts) :> (ps +<+ (t :<: NilRL))-  PatchSet ps NilRL -> (PatchSet NilRL NilRL :> ps)+readContextFile :: Commute p+                => PatchSet p Origin wX+                -> FilePath+                -> IO (SealedPatchSet p Origin)+readContextFile ref = fmap Sealed . (parseAndInterpret <=< mmapFilePS)+  where+    parseAndInterpret =+      either fail return . (interpretContext ref <=< parseContextFile) --- are the type witnesses sensible?-scanContext :: RepoPatch p => B.ByteString -> PatchSet p C(Origin x)-scanContext ps-  | B.null ps = error "Bad context!"-  | otherwise =-    case sillyLex ps of-    ("Context:",rest) ->-        case getContext rest of-          (cont@(_:_), _) | isTag (last cont) ->-            PatchSet (unavailablePatches $ init cont)-                     (Tagged (piUnavailable $ last cont) Nothing NilRL :<: NilRL)-          (cont, _) -> PatchSet (unavailablePatches cont) NilRL-    ("-----BEGIN PGP SIGNED MESSAGE-----",rest) ->-            scanContext $ filterGpgDashes rest-    (_,rest) -> scanContext rest+-- | Interpret a context file in the context of a 'PatchSet'. This means we+-- match up a possible tag. This fails if the tag couldn't be found.+interpretContext :: Commute p+                 => PatchSet p Origin wT+                 -> FL (PatchInfoAnd p) wA wB+                 -> Either String (PatchSet p Origin wB)+interpretContext ref context =+  case context of+    tag :>: rest+      | Just tagname <- piTag (info tag) ->+        case splitOnTag (info tag) ref of+          Nothing ->+            Left $ "Cannot find tag " ++ tagname ++ " from context in our repo"+          Just (PatchSet ts _) ->+            Right $ PatchSet ts (unsafeCoercePStart (reverseFL rest))+    _ -> Right $ PatchSet NilRL (unsafeCoercePStart (reverseFL context)) --- |patchFilename maps a patch description string to a safe (lowercased, spaces--- removed and ascii-only characters) patch filename.-patchFilename :: String -> String-patchFilename the_summary = name ++ ".dpatch"-    where name = map safeFileChar the_summary-          safeFileChar c | isAlpha c = toLower c-                         | isDigit c = c-                         | isSpace c = '-'-          safeFileChar _ = '_'+parseContextFile :: B.ByteString+                 -> Either String (FL (PatchInfoAnd p) wX wY)+parseContextFile =+    fmap fst . parse pUnsignedContext . decodeGpgClearsigned+  where+    pUnsignedContext = unavailablePatchesFL . reverse <$> pContext++-- | Minimize the context of an 'FL' of patches to be packed into a bundle.+minContext :: (RepoPatch p)+           => PatchSet p wStart wB -- context to be minimized+           -> FL (PatchInfoAnd p) wB wC+           -> Sealed ((PatchSet p :> FL (PatchInfoAnd p)) wStart)+minContext (PatchSet behindTag topCommon) to_be_sent =+  case genCommuteWhatWeCanRL commuteFL (topCommon :> to_be_sent) of+    (c :> to_be_sent' :> _) -> seal (PatchSet behindTag c :> to_be_sent') ++-- TODO shouldn't we verify the signature? That is, pipe the input through+-- "gpg --verify -o-"? This would also let gpg handle their own mangling.++-- | Decode gpg clearsigned file content.+decodeGpgClearsigned :: B.ByteString -> B.ByteString+decodeGpgClearsigned input =+  case betweenLinesPS startSignedName endSignedName input of+    Nothing -> input+    Just signed -> removeGpgDashes (dropHashType signed)+  where+    -- Note that B.concat is optimized to avoid unnecessary work, in particular+    -- concatenating slices that were originally adjacent involves no extra+    -- copying, and allocation of the result buffer is done only once.+    removeGpgDashes = B.concat . splitGpgDashes+    splitGpgDashes s =+      case B.breakSubstring newline_dashes s of+        (before, rest)+          | B.null rest -> [s]+          | (keep, after) <- B.splitAt 2 rest ->+              before : keep : splitGpgDashes (B.drop 2 after)+    newline_dashes = BC.pack "\n- -"+    dropHashType s =+      case B.breakSubstring hashTypeName s of+        (_, rest)+          | B.null rest -> s+          | otherwise -> dropSpace $ BC.dropWhile (/= '\n') rest+    hashTypeName = BC.pack "Hash:"+    startSignedName = BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"+    endSignedName = BC.pack "-----BEGIN PGP SIGNATURE-----"
src/Darcs/Patch/Choices.hs view
@@ -15,270 +15,300 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}--#include "gadts.h"---- | PatchChoices divides a sequence of patches into three sets: "first",--- "middle" and "last", such that all patches can be applied, if you first--- apply the first ones then the middle ones and then the last ones.--- Obviously if there are dependencies between the patches that will put a--- constraint on how you can choose to divide them up.  The PatchChoices data--- type and associated functions are here to deal with many of the common+-- | The purpose of this module is to deal with many of the common -- cases that come up when choosing a subset of a group of patches. ----- 'forceLast' tells PatchChoices that a particular patch is required to be in--- the "last" group, which also means that any patches that depend on it--- must be in the "last" group.+-- The idea is to divide a sequence of candidate patches into an initial+-- section named 'InFirst', a final section named 'InLast', and between them a+-- third section of not yet decided patches named 'InMiddle'. The reason for the+-- neutral terminology 'InFirst', 'InMiddle', and 'InLast', is that which of 'InFirst'+-- and 'InLast' counts as @selected@ or @deselected@ depends on+-- what we want to achive, that is, on the command and its options.+-- See "Darcs.UI.SelectChanges" for examples of how to use the functions from+-- this module. ----- Internally, a PatchChoices doesn't always reorder the patches until--- it is asked for the final output (e.g. by 'get_first_choice').--- Instead, each patch is placed in a state of definitely first,--- definitely last and undecided; undecided leans towards--- "middle". The patches that are first are commuted to the head--- immediately, but patches that are middle and last are mixed--- together. In case you're wondering about the first-middle-last--- language, it's because in some cases the "yes" answers will be last--- (as is the case for the revert command), and in others first (as in--- record, pull and push).+-- Obviously if there are dependencies between the patches that will put a+-- constraint on how you can choose to divide them up. Unless stated otherwise,+-- functions that move patches from one section to another pull all dependent+-- patches with them. ----- Some patch marked "middle" may in fact be unselectable because of--- dependencies: when a patch is marked "last", its dependencies are--- not updated until patchSlot is called on them.-module Darcs.Patch.Choices ( PatchChoices, patchChoices, patchChoicesTps,-                             patchChoicesTpsSub,-                      patchSlot, patchSlot',-                      getChoices, refineChoices,-                      separateFirstMiddleFromLast,-                      separateFirstFromMiddleLast,-                      forceFirst, forceFirsts, forceLast, forceLasts,-                      forceMatchingFirst, forceMatchingLast,-                      selectAllMiddles,-                      makeUncertain, makeEverythingLater, makeEverythingSooner,-                      TaggedPatch, Tag, tag, tpPatch,-                             Slot(..),-                      substitute-                    ) where--import Control.Monad.Identity ( Identity )-import Control.Monad.State ( StateT(..) )+-- Internally, we don't necessarily reorder patches immediately, but merely+-- tag them with the desired status, and thus postpone the actual commutation.+-- This saves a lot of unnecessary work, especially when choices are made+-- interactively, where the user can revise earlier decisions.+module Darcs.Patch.Choices+    ( -- * Choosing patches+      PatchChoices+    , Slot(..)+      -- ** Constructing+    , patchChoices+    , mkPatchChoices+      -- ** Querying+    , patchSlot+    , getChoices+    , separateFirstMiddleFromLast+    , separateFirstFromMiddleLast+      -- ** Forcing patches into a given 'Slot'+    , forceMatchingFirst+    , forceFirsts+    , forceFirst+    , forceMatchingLast+    , forceLasts+    , forceLast+    , forceMiddle+    , makeEverythingSooner+    , makeEverythingLater+      -- ** Operations on 'InMiddle' patches+    , selectAllMiddles+    , refineChoices+      -- ** Substitution+    , substitute+      -- * Labelling patches+    , LabelledPatch+    , Label+    , label+    , unLabel+    , labelPatches+    , getLabelInt+    ) where -import Prelude hiding ( pred )+import Darcs.Prelude -import Darcs.Patch-     ( Patchy, commuteRL, commute, merge, listTouchedFiles, hunkMatches-     , invert )-import Darcs.Patch.Merge ( Merge )+import Darcs.Patch.Invert ( Invert, invert )+import Darcs.Patch.Commute ( Commute, commute, commuteRL )+import Darcs.Patch.Inspect ( PatchInspect, listTouchedFiles, hunkMatches ) import Darcs.Patch.Permutations ( commuteWhatWeCanRL, commuteWhatWeCanFL )-import Darcs.Patch.Patchy ( Invert, Commute, PatchInspect )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( FL(..), RL(..),-                             (:>)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),-                             zipWithFL, mapFL_FL, concatFL,-                             (+>+), reverseRL, anyFL )-import Darcs.Witnesses.Sealed ( Sealed2(..) )---#include "impossible.h"-+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), RL(..)+    , (:>)(..), (:||:)(..)+    , zipWithFL, mapFL_FL, concatFL+    , (+>+), reverseRL, anyFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) --- | 'TG' @mp i@ acts as a temporary identifier to help us keep track of patches+-- | 'Label' @mp i@ acts as a temporary identifier to help us keep track of patches --   during the selection process.  These are useful for finding patches that --   may have moved around during patch selection (being pushed forwards or --   backwards as dependencies arise). -----   The identifier is implemented as a tuple @TG mp i@. The @i@ is just some---   arbitrary label, expected to be unique within the patches being+--   The identifier is implemented as a tuple @Label mp i@. The @i@ is an+--   integer, expected to be unique within the patches being --   scrutinised.  The @mp@ is motivated by patch splitting; it --   provides a convenient way to generate a new identifier from the patch---   being split.  For example, if we split a patch identified as @TG Nothing---   5@, the resulting sub-patches could be identified as @TG (TG Nothing 5)---   1@, @TG (TG Nothing 5) 2@, etc.-data Tag = TG (Maybe Tag) Integer deriving ( Eq, Ord )-data TaggedPatch p C(x y) = TP Tag (p C(x y))+--   being split.  For example, if we split a patch identified as @Label Nothing+--   5@, the resulting sub-patches could be identified as+--   @Label (Just (Label Nothing 5))1@, @Label (Just (Label Nothing 5)) 2@, etc.+--+--   IOW, 'Label' is a non-empty, reversed list of 'Int's.+data Label = Label (Maybe Label) Int deriving Eq --- | The @Bool@ parameter indicates whether the patch has been explicitely--- selected (or rejected) by the user.-data PatchChoice p C(x y) = PC { pcPatch :: (TaggedPatch p C(x y))-                               , _pcChoice :: Bool}+-- | A patch with a 'Label' attached to it.+data LabelledPatch p wX wY = LP Label (p wX wY) -data PatchChoices p C(x y) where-  PCs { pcsFirsts :: FL (TaggedPatch p) C(x m)-      , pcsLasts :: FL (PatchChoice p) C(m y)} :: PatchChoices p C(x y)+-- | This internal type tags a 'LabelledPatch' with a 'Bool', to distinguish+-- 'InMiddle' from 'InLast' patches.+data PatchChoice p wX wY = PC+  { pcPatch :: (LabelledPatch p wX wY) -- ^ the 'LabelledPatch' in question+  , _pcIsLast :: Bool                  -- ^ 'False' = 'InMiddle', 'True' = 'InLast'+  } --- | See module documentation for 'Darcs.Patch.Choices'-data Slot = InFirst | InMiddle | InLast+-- | Internal function to tag a 'LabelledPatch' as 'InMiddle' or 'InLast'.+pcSetLast :: Bool -> LabelledPatch p wX wY -> PatchChoice p wX wY+pcSetLast = flip PC -tag :: TaggedPatch p C(x y) -> Tag-tag (TP tg _) = tg+-- TODO pcsFirsts should be an 'RL', not an 'FL'.+-- | A sequence of 'LabelledPatch'es where each patch is either+-- 'InFirst', 'InMiddle', or 'InLast'. The representation is+-- optimized for the case where we start chosing patches from the left+-- of the sequence: patches that are 'InFirst' are commuted to the head+-- immediately, but patches that are 'InMiddle' or 'InLast' are mixed+-- together; when a patch is marked 'InLast', its dependencies are+-- not updated until we retrieve the final result.+data PatchChoices p wX wY where+  PCs :: { pcsFirsts :: FL (LabelledPatch p) wX wM+         , pcsMiddleLasts :: FL (PatchChoice p) wM wY}+      -> PatchChoices p wX wY -tpPatch :: TaggedPatch p C(x y) -> p C(x y)-tpPatch (TP _ p) = p+-- | See module documentation for "Darcs.Patch.Choices".+data Slot = InFirst | InMiddle | InLast -liftTP :: (p C(x y) -> p C(a b)) -> (TaggedPatch p C(x y) -> TaggedPatch p C(a b))-liftTP f (TP t p) = TP t (f p)+label :: LabelledPatch p wX wY -> Label+label (LP tg _) = tg --- This is dangerous if two patches from different tagged series are compared--- ideally Tag (and hence TaggedPatch/PatchChoices) would have a witness type--- to represent the originally tagged sequence.-compareTags :: TaggedPatch p C(a b) -> TaggedPatch p C(c d) -> EqCheck C((a, b) (c, d))-compareTags (TP t1 _) (TP t2 _) = if t1 == t2 then unsafeCoerceP IsEq else NotEq+getLabelInt :: Label -> Int+getLabelInt (Label _ i) = i -instance MyEq p => MyEq (TaggedPatch p) where-    unsafeCompare (TP t1 p1) (TP t2 p2) = t1 == t2 && unsafeCompare p1 p2+unLabel :: LabelledPatch p wX wY -> p wX wY+unLabel (LP _ p) = p -instance Invert p => Invert (TaggedPatch p) where-    invert = liftTP invert+-- This is dangerous if two patches from different labelled series are compared+-- ideally Label (and hence LabelledPatch/PatchChoices) would have a witness type+-- to represent the originally labelled sequence.+compareLabels :: LabelledPatch p wA wB -> LabelledPatch p wC wD -> EqCheck (wA, wB) (wC, wD)+compareLabels (LP l1 _) (LP l2 _) = if l1 == l2 then unsafeCoerceP IsEq else NotEq -instance Commute p => Commute (TaggedPatch p) where-    commute (TP t1 p1 :> TP t2 p2) = do p2' :> p1' <- commute (p1 :> p2)-                                        return (TP t2 p2' :> TP t1 p1')+instance Invert p => Invert (LabelledPatch p) where+  invert (LP t p) = LP t (invert p) -instance PatchInspect p => PatchInspect (TaggedPatch p) where-    listTouchedFiles (TP _ p) = listTouchedFiles p-    hunkMatches f (TP _ p) = hunkMatches f p+instance Commute p => Commute (LabelledPatch p) where+  commute (LP l1 p1 :> LP l2 p2) = do+    p2' :> p1' <- commute (p1 :> p2)+    return (LP l2 p2' :> LP l1 p1') -instance Merge p => Merge (TaggedPatch p) where-    merge (TP t1 p1 :\/: TP t2 p2) = case merge (p1 :\/: p2) of-                                     p2' :/\: p1' -> TP t2 p2' :/\: TP t1 p1'+instance PatchInspect p => PatchInspect (LabelledPatch p) where+  listTouchedFiles = listTouchedFiles . unLabel+  hunkMatches f = hunkMatches f . unLabel  instance Commute p => Commute (PatchChoice p) where-  commute (PC p1 c1 :> PC p2 c2) = do p2' :> p1' <- commute (p1 :> p2)-                                      return (PC p2' c2 :> PC p1' c1)+  commute (PC p1 c1 :> PC p2 c2) = do+    p2' :> p1' <- commute (p1 :> p2)+    return (PC p2' c2 :> PC p1' c1)  instance PatchInspect p => PatchInspect (PatchChoice p) where-  listTouchedFiles (PC p _) = listTouchedFiles p-  hunkMatches f (PC p _) = hunkMatches f p--instance Merge p => Merge (PatchChoice p) where-  merge (PC tp1 c1 :\/: PC tp2 c2) = case merge (tp1 :\/: tp2) of-    tp2' :/\: tp1' -> PC tp2' c2 :/\: PC tp1' c1--patchChoices :: Patchy p => FL p C(x y) -> PatchChoices p C(x y)-patchChoices = fst . patchChoicesTps+  listTouchedFiles = listTouchedFiles . pcPatch+  hunkMatches f = hunkMatches f . pcPatch --- |Tag a sequence of patches as subpatches of an existing tag. This is intended for--- use when substituting a patch for an equivalent patch or patches.-patchChoicesTpsSub :: Patchy p-                      => Maybe Tag -> FL p C(x y)-                      -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))-patchChoicesTpsSub tg ps = let tps = zipWithFL TP (map (TG tg) [1..]) ps-                           in (PCs NilFL (mapFL_FL (\tp -> PC tp False) tps), tps)+-- | Create a 'PatchChoices' from a sequence of patches, so that+-- all patches are initially 'InMiddle'.+patchChoices :: FL p wX wY -> PatchChoices p wX wY+patchChoices = mkPatchChoices . labelPatches Nothing --- |Tag a sequence of patches.-patchChoicesTps :: Patchy p => FL p C(x y) -> (PatchChoices p C(x y), FL (TaggedPatch p) C(x y))-patchChoicesTps = patchChoicesTpsSub Nothing+-- | Label a sequence of patches, maybe using the given parent label.+labelPatches :: Maybe Label -> FL p wX wY -> FL (LabelledPatch p) wX wY+labelPatches tg ps = zipWithFL LP (map (Label tg) [1..]) ps -instance MyEq p => MyEq (PatchChoice p) where-    unsafeCompare (PC tp1 _) (PC tp2 _) = unsafeCompare tp1 tp2+-- | Create a 'PatchChoices' from an already labelled sequence of patches,+-- so that all patches are initially 'InMiddle'.+mkPatchChoices :: FL (LabelledPatch p) wX wY -> PatchChoices p wX wY+mkPatchChoices = PCs NilFL . mapFL_FL (pcSetLast False)  -separateFirstFromMiddleLast :: Patchy p => PatchChoices p C(x z)-                                -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)-separateFirstFromMiddleLast (PCs f l) = f :> mapFL_FL (\ (PC tp _) -> tp) l+-- | Like 'getChoices' but lumps together 'InMiddle' and 'InLast' patches.+-- This is more efficient than using 'getChoices' and then catenating 'InMiddle'+-- and 'InLast' sections because we have to commute less.+-- (This is what 'PatchChoices' are optimized for.)+--+-- prop> separateFirstFromMiddleLast c == case getChoices c of f:>m:>l -> f:>m+>+l+separateFirstFromMiddleLast :: PatchChoices p wX wZ+                            -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ+separateFirstFromMiddleLast (PCs f ml) = f :> mapFL_FL pcPatch ml -separateFirstMiddleFromLast :: Patchy p => PatchChoices p C(x z)-                                -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x z)+-- | Like 'getChoices' but lumps together 'InFirst' and 'InMiddle' patches.+--+-- prop> separateFirstMiddleFromLast c == case getChoices c of f:>m:>l -> f+>+m:>l+separateFirstMiddleFromLast :: Commute p+                            => PatchChoices p wX wZ+                            -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wZ separateFirstMiddleFromLast (PCs f l) =   case pushLasts l of     (m :> l') -> f +>+ m :> l' --- | @getChoices@ evaluates a @PatchChoices@ into the first, middle and last sequences--- by doing the commutes that were needed.-getChoices :: Patchy p => PatchChoices p C(x y)-            -> (FL (TaggedPatch p) :> FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)-getChoices (PCs f l) =-  case pushLasts l of-       (m :> l') -> f :> m :> l'+-- | Retrieve the resulting sections from a 'PatchChoice'.  The result is a+-- triple @first:>middle:>last@, such that all patches in @first@ are+-- 'InFirst', all patches in @middle@ are 'InMiddle', and all patches in @last@+-- are 'InLast'.+getChoices :: Commute p+           => PatchChoices p wX wY+           -> (FL (LabelledPatch p) :> FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY+getChoices (PCs f ml) =+  case pushLasts ml of+    (m :> l') -> f :> m :> l' -pushLasts :: Patchy p => FL (PatchChoice p) C(x y)-            -> (FL (TaggedPatch p) :> FL (TaggedPatch p)) C(x y)+-- | Internal function to commute patches in the common 'pcsMiddleLasts' segment+-- so that all 'InLast' patches are behind 'InMiddle' ones. Patches 'InMiddle'+-- that depend on any 'InLast' are promoted to 'InLast'.+pushLasts :: Commute p+          => FL (PatchChoice p) wX wY+          -> (FL (LabelledPatch p) :> FL (LabelledPatch p)) wX wY pushLasts NilFL = NilFL :> NilFL-pushLasts (PC tp False :>: pcs) =+pushLasts (PC lp False :>: pcs) =   case pushLasts pcs of-       (m :> l) -> (tp :>: m) :> l-pushLasts (PC tp True :>: pcs) =+       (m :> l) -> (lp :>: m) :> l+pushLasts (PC lp True :>: pcs) =   case pushLasts pcs of     (m :> l) ->-      case commuteWhatWeCanFL (tp :> m) of-        (m' :> tp' :> deps) -> m' :> (tp' :>: deps +>+ l)+      case commuteWhatWeCanFL (lp :> m) of+        (m' :> lp' :> deps) -> m' :> (lp' :>: deps +>+ l) --- | @refineChoices act@ performs @act@ on the middle part of a sequence--- of choices, in order to hopefully get more patches into the @first@ and--- @last@ parts of a @PatchChoices@.-refineChoices :: (Patchy p, Monad m, Functor m) =>-                (FORALL(u v) FL (TaggedPatch p) C(u v) ->-                      PatchChoices p C(u v) ->-                      m (PatchChoices p C(u v)))-                -> PatchChoices p C(x y) -> m (PatchChoices p C(x y))+-- TODO for the way we use this function it is too restrictive IMO: it does not+-- allow the user to select anything that doesn't match the pre-filters.+-- | Use the given monadic 'PatchChoices' transformer on the 'InMiddle' section+-- of a 'PatchChoices', then fold the result back into the original 'PatchChoices'.+refineChoices :: (Commute p, Monad m)+              => (forall wU wV . FL (LabelledPatch p) wU wV ->+                  PatchChoices p wU wV -> m (PatchChoices p wU wV))+              -> PatchChoices p wX wY -> m (PatchChoices p wX wY) refineChoices act ps =-      case getChoices ps of-        (f :> m :> l) -> do-          let mchoices = PCs NilFL . mapFL_FL (flip PC False) $ m-          (PCs f' l') <- act m mchoices-          return . PCs (f +>+ f') $ l' +>+ mapFL_FL (flip PC True) l+  case getChoices ps of+    (f :> m :> l) -> do+      (PCs f' l') <- act m (mkPatchChoices m)+      return . PCs (f +>+ f') $ l' +>+ mapFL_FL (pcSetLast True) l -patchSlot :: forall p C(a b x y). Patchy p => TaggedPatch p C(a b)-          -> PatchChoices p C(x y) -> (Slot, PatchChoices p C(x y))-patchSlot (TP t _) pc@(PCs f l) =-  if foundIn f-  then (InFirst, pc)-  else psLast f NilRL NilRL l+-- | Given a 'LabelledPatch' determine to which section of the given+-- 'PatchChoices' it belongs. This is not trivial to compute, since a patch+-- tagged as 'InMiddle' may be forced to actually be 'InLast' by dependencies. We+-- return a possibly re-ordered 'PatchChoices' so as not to waste the+-- commutation effort.+patchSlot :: forall p wA wB wX wY. Commute p+          => LabelledPatch p wA wB+          -> PatchChoices p wX wY+          -> (Slot, PatchChoices p wX wY)+patchSlot (LP t _) pc@(PCs f ml)+  | foundIn f = (InFirst, pc)+  | otherwise = psLast f NilRL NilRL ml   where-    foundIn = anyFL ((== t) . tag)-    psLast :: FORALL(m c l)-             FL (TaggedPatch p) C(x m) ->-             RL (TaggedPatch p) C(m c) ->-             RL (TaggedPatch p) C(c l) ->-             FL (PatchChoice p) C(l y) ->-             (Slot, PatchChoices p C(x y))-    psLast firsts middles bubble (PC tp True :>: ls)-      | tag tp == t = (InLast+    foundIn = anyFL ((== t) . label)+    psLast :: forall wM wC wL .+             FL (LabelledPatch p) wX wM ->+             RL (LabelledPatch p) wM wC ->+             RL (LabelledPatch p) wC wL ->+             FL (PatchChoice p) wL wY ->+             (Slot, PatchChoices p wX wY)+    psLast firsts middles bubble (PC lp True :>: ls)+      | label lp == t = (InLast                       , PCs { pcsFirsts = firsts-                            , pcsLasts = settleM middles+                            , pcsMiddleLasts = settleM middles                                          +>+ settleB bubble-                                         +>+ PC tp True :>: ls})-    psLast firsts middles bubble (PC tp False :>: ls)-      | tag tp == t =-        case commuteRL (bubble :> tp) of-        Just (tp' :> bubble') -> (InMiddle,+                                         +>+ PC lp True :>: ls})+    psLast firsts middles bubble (PC lp False :>: ls)+      | label lp == t =+        case commuteRL (bubble :> lp) of+        Just (lp' :> bubble') -> (InMiddle,                                  PCs { pcsFirsts = firsts-                                     , pcsLasts = settleM middles-                                                  +>+ PC tp' False+                                     , pcsMiddleLasts = settleM middles+                                                  +>+ PC lp' False                                                   :>: settleB bubble'                                                   +>+ ls})         Nothing -> (InLast,                    PCs { pcsFirsts = firsts-                       , pcsLasts = settleM middles+                       , pcsMiddleLasts = settleM middles                                     +>+ settleB bubble-                                    +>+ PC tp True+                                    +>+ PC lp True                                     :>: ls})-    psLast firsts middles bubble (PC tp True :>: ls) =-      psLast firsts middles (tp :<: bubble) ls-    psLast firsts middles bubble (PC tp False :>: ls) =-      case commuteRL (bubble :> tp) of-        Just (tp' :> bubble') -> psLast firsts (tp' :<: middles) bubble' ls-        Nothing -> psLast firsts middles (tp :<: bubble) ls-    psLast _ _ _ NilFL = impossible-    settleM middles = mapFL_FL (\tp -> PC tp False) $ reverseRL middles-    settleB bubble = mapFL_FL (\tp -> PC tp True) $ reverseRL bubble--patchSlot' :: Patchy p =>-              TaggedPatch p C(a b) -> StateT (PatchChoices p C(x y)) Identity Slot-patchSlot' tp = StateT (return . patchSlot tp)+    psLast firsts middles bubble (PC lp True :>: ls) =+      psLast firsts middles (bubble :<: lp) ls+    psLast firsts middles bubble (PC lp False :>: ls) =+      case commuteRL (bubble :> lp) of+        Just (lp' :> bubble') -> psLast firsts (middles :<: lp') bubble' ls+        Nothing -> psLast firsts middles (bubble :<: lp) ls+    psLast _ _ _ NilFL = error "impossible case"+    settleM middles = mapFL_FL (\lp -> PC lp False) $ reverseRL middles+    settleB bubble = mapFL_FL (\lp -> PC lp True) $ reverseRL bubble -forceMatchingFirst :: forall p C(a b). Patchy p =>-                      ( FORALL(x y) TaggedPatch p C(x y) -> Bool)-                      -> PatchChoices p C(a b)-                      -> PatchChoices p C(a b)-forceMatchingFirst pred (PCs fn l) =-  fmfLasts fn NilRL l+-- | Force all patches matching the given predicate to be 'InFirst',+-- pulling any dependencies with them. This even forces any patches+-- that were already tagged 'InLast'.+forceMatchingFirst :: forall p wA wB. Commute p+                   => ( forall wX wY . LabelledPatch p wX wY -> Bool)+                   -> PatchChoices p wA wB+                   -> PatchChoices p wA wB+forceMatchingFirst pred (PCs f0 ml) = fmfLasts f0 NilRL ml     where-      fmfLasts :: FL (TaggedPatch p) C(a m)-                 -> RL (PatchChoice p) C(m n)-                 -> FL (PatchChoice p) C(n b)-                 -> PatchChoices p C(a b)+      fmfLasts :: FL (LabelledPatch p) wA wM+                 -> RL (PatchChoice p) wM wN+                 -> FL (PatchChoice p) wN wB+                 -> PatchChoices p wA wB       fmfLasts f l1 (a :>: l2)           | pred_pc a =             case commuteWhatWeCanRL (l1 :> a) of@@ -286,117 +316,151 @@                 let                   f' = f +>+ mapFL_FL pcPatch (reverseRL deps) +>+ (pcPatch a' :>: NilFL)                 in fmfLasts f' l1' l2-      fmfLasts f l1 (a :>: l2) = fmfLasts f (a :<: l1) l2+      fmfLasts f l1 (a :>: l2) = fmfLasts f (l1 :<: a) l2       fmfLasts f l1 NilFL = PCs { pcsFirsts = f-                                , pcsLasts = reverseRL l1 }-      pred_pc :: FORALL(x y) PatchChoice p C(x y) -> Bool-      pred_pc (PC tp _) = pred tp+                                , pcsMiddleLasts = reverseRL l1 }+      pred_pc :: forall wX wY . PatchChoice p wX wY -> Bool+      pred_pc (PC lp _) = pred lp -forceFirsts :: Patchy p => [Tag] -> PatchChoices p C(a b)-              -> PatchChoices p C(a b)-forceFirsts ps = forceMatchingFirst ((`elem` ps) . tag)+-- | Force all patches labelled with one of the given labels to be 'InFirst',+-- pulling any dependencies with them. This even forces any patches+-- that were already tagged 'InLast'.+forceFirsts :: Commute p+            => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB+forceFirsts ps = forceMatchingFirst ((`elem` ps) . label) -forceFirst :: Patchy p => Tag -> PatchChoices p C(a b)-              -> PatchChoices p C(a b)-forceFirst p = forceMatchingFirst ((== p) . tag)+-- | Force a single patch labelled with the given label to be 'InFirst',+-- pulling any dependencies with them. This even forces any patches+-- that were already tagged 'InLast'.+forceFirst :: Commute p+           => Label -> PatchChoices p wA wB -> PatchChoices p wA wB+forceFirst p = forceMatchingFirst ((== p) . label) --TODO: stop after having seen the patch we want to force first -selectAllMiddles :: forall p C(x y). Patchy p => Bool-                   -> PatchChoices p C(x y) -> PatchChoices p C(x y)+-- | Make all 'InMiddle' patches either 'InFirst' or 'InLast'. This does *not*+-- modify any patches that are already determined to be 'InLast' by+-- dependencies.+selectAllMiddles :: forall p wX wY. Commute p+                 => Bool -> PatchChoices p wX wY -> PatchChoices p wX wY selectAllMiddles True (PCs f l) = PCs f (mapFL_FL g l)-    where g (PC tp _) = PC tp True+    where g (PC lp _) = PC lp True selectAllMiddles False (PCs f l) = samf f NilRL NilRL l   where-    samf :: FORALL(m1 m2 m3)-           FL (TaggedPatch p) C(x m1) ->-           RL (TaggedPatch p) C(m1 m2) ->-           RL (PatchChoice p) C(m2 m3) ->-           FL (PatchChoice p) C(m3 y) ->-           PatchChoices p C(x y)-    samf f1 f2 l1 (pc@(PC tp False) :>: l2) =+    samf :: forall wM1 wM2 wM3 .+           FL (LabelledPatch p) wX wM1 ->+           RL (LabelledPatch p) wM1 wM2 ->+           RL (PatchChoice p) wM2 wM3 ->+           FL (PatchChoice p) wM3 wY ->+           PatchChoices p wX wY+    samf f1 f2 l1 (pc@(PC lp False) :>: l2) =       case commuteRL (l1 :> pc) of-        Nothing -> samf f1 f2 (PC tp True :<: l1) l2-        Just ((PC tp' _) :> l1') -> samf f1 (tp' :<: f2) l1' l2-    samf f1 f2 l1 (PC tp True :>: l2) = samf f1 f2 (PC tp True :<: l1) l2+        Nothing -> samf f1 f2 (l1 :<: PC lp True) l2+        Just ((PC lp' _) :> l1') -> samf f1 (f2 :<: lp') l1' l2+    samf f1 f2 l1 (PC lp True :>: l2) = samf f1 f2 (l1 :<: PC lp True) l2     samf f1 f2 l1 NilFL = PCs (f1 +>+ reverseRL f2) (reverseRL l1) -forceMatchingLast :: Patchy p => (FORALL(x y) TaggedPatch p C(x y) -> Bool)-                     -> PatchChoices p C(a b)-                     -> PatchChoices p C(a b)-forceMatchingLast pred (PCs f l) = do-  fmlFirst pred True NilRL f l+-- | Similar to 'forceMatchingFirst' only that patches are forced to be+-- 'InLast' regardless of their previous status.+forceMatchingLast :: Commute p => (forall wX wY . LabelledPatch p wX wY -> Bool)+                  -> PatchChoices p wA wB+                  -> PatchChoices p wA wB+forceMatchingLast pred (PCs f ml) =+  forceMatchingMiddleOrLast pred True NilRL f ml -fmlFirst :: forall p C(a b m1 m2) . Patchy p =>-           (FORALL(x y) TaggedPatch p C(x y) -> Bool) -> Bool-           -> RL (TaggedPatch p) C(a m1)-           -> FL (TaggedPatch p) C(m1 m2)-           -> FL (PatchChoice p) C(m2 b)-           -> PatchChoices p C(a b)-fmlFirst pred b f1 (a :>: f2) l-        | pred a =-          case commuteWhatWeCanFL (a :> f2) of-            (f2' :> a' :> deps) ->-              let-                l' = mapFL_FL (\tp -> PC tp b) (a' :>: deps) +>+ l-              in-              fmlFirst pred b f1 f2' l'-fmlFirst pred b f1 (a :>: f2) l = fmlFirst pred b (a :<: f1) f2 l-fmlFirst pred b f1 NilFL l = PCs { pcsFirsts = reverseRL f1-                                 , pcsLasts = mapFL_FL ch l}-  where ch (PC tp c) = (PC tp (if pred tp then b else c) )+-- | Internal function working directly on the constituent parts of a+-- 'PatchChoices' and taking an accumulating 'RL' to build up a new 'InFirst'+-- section.  It forces patches to be 'InMiddle' or 'InLast', depending+-- on the 'Bool' parameter ('True' means 'InLast', 'False' means 'InMiddle').+-- It does this regardless of the previous status of patches and also pulls+-- any dependent patches with it.+forceMatchingMiddleOrLast+  :: forall p wA wB wM1 wM2 . Commute p+  => (forall wX wY . LabelledPatch p wX wY -> Bool)+  -> Bool+  -> RL (LabelledPatch p) wA wM1  -- ^ accumulator for 'InFirst' patches+  -> FL (LabelledPatch p) wM1 wM2 -- ^ original 'InFirst' section+  -> FL (PatchChoice p) wM2 wB    -- ^ original 'InMiddle' and 'InLast' section+  -> PatchChoices p wA wB+forceMatchingMiddleOrLast pred b f1 (a :>: f2) ml+  | pred a =+    case commuteWhatWeCanFL (a :> f2) of+      (f2' :> a' :> deps) ->+        let+          ml' = mapFL_FL (pcSetLast b) (a' :>: deps) +>+ ml+        in+        forceMatchingMiddleOrLast pred b f1 f2' ml'+forceMatchingMiddleOrLast pred b f1 (a :>: f2) ml =+  forceMatchingMiddleOrLast pred b (f1 :<: a) f2 ml+forceMatchingMiddleOrLast pred b f1 NilFL ml =+  PCs { pcsFirsts = reverseRL f1+      , pcsMiddleLasts = mapFL_FL choose ml+      }+  where+    choose (PC lp c) = (PC lp (if pred lp then b else c) ) -forceLasts :: Patchy p => [Tag]-                    -> PatchChoices p C(a b) -> PatchChoices p C(a b)-forceLasts ps = forceMatchingLast ((`elem` ps) . tag)+-- | Force all patches labelled with one of the given labels to be 'InLast',+-- pulling any dependencies with them. This even forces any patches+-- that were previously tagged 'InFirst'.+forceLasts :: Commute p+           => [Label] -> PatchChoices p wA wB -> PatchChoices p wA wB+forceLasts ps = forceMatchingLast ((`elem` ps) . label) -forceLast :: Patchy p => Tag-                    -> PatchChoices p C(a b) -> PatchChoices p C(a b)-forceLast p = forceMatchingLast ((== p) . tag)+-- | Force a single patch labelled with the given label to be 'InLast',+-- pulling any dependencies with them, regardless of their previous status.+forceLast :: Commute p+          => Label -> PatchChoices p wA wB -> PatchChoices p wA wB+forceLast p = forceMatchingLast ((== p) . label) -makeUncertain :: Patchy p => Tag -> PatchChoices p C(a b) -> PatchChoices p C(a b)-makeUncertain t (PCs f l) = fmlFirst ((== t) . tag) False NilRL f l+-- | Force a patch with the given 'Label' to be 'InMiddle',+-- pulling any dependencies with it, regardless of their previous status.+forceMiddle :: Commute p => Label -> PatchChoices p wA wB -> PatchChoices p wA wB+forceMiddle t (PCs f l) = forceMatchingMiddleOrLast ((== t) . label) False NilRL f l -makeEverythingLater :: Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)-makeEverythingLater (PCs f l) =-  let m = mapFL_FL (\tp -> PC tp False) f-      l' = mapFL_FL (\(PC tp _) -> PC tp True) l-  in-  PCs NilFL $ m +>+ l'+-- | Turn 'InFirst' patches into 'InMiddle' ones and 'InMiddle' into 'InLast' ones.+makeEverythingLater :: PatchChoices p wX wY -> PatchChoices p wX wY+makeEverythingLater (PCs f ml) =+  let m = mapFL_FL (pcSetLast False) f+      ml' = mapFL_FL (\(PC lp _) -> PC lp True) ml+  in PCs NilFL $ m +>+ ml' -makeEverythingSooner :: forall p C(x y).-  Patchy p => PatchChoices p C(x y) -> PatchChoices p C(x y)-makeEverythingSooner (PCs f l) =-  case mes NilRL NilRL l-       of (m :> l') ->-            PCs (f +>+ m) l'+-- | Turn 'InMiddle' patches into 'InFirst' and 'InLast' patches into 'InMiddle'.+-- Does *not* pull dependencies into 'InFirst', instead patches that+-- cannot be commuted past 'InLast' patches stay 'InMiddle'.+makeEverythingSooner :: forall p wX wY. Commute p+                     => PatchChoices p wX wY -> PatchChoices p wX wY+makeEverythingSooner (PCs f ml) =+  case mes NilRL NilRL ml+       of (m :> ml') ->+            PCs (f +>+ m) ml'     where-      mes :: FORALL(m1 m2 m3)-            RL (TaggedPatch p) C(m1 m2) ->-            RL (TaggedPatch p) C(m2 m3) ->-            FL (PatchChoice p) C(m3 y) ->-            (FL (TaggedPatch p) :> FL (PatchChoice p)) C(m1 y)-      mes middle bubble (PC tp True :>: ls) = mes middle (tp :<: bubble) ls-      mes middle bubble (PC tp False :>: ls) =-        case commuteRL (bubble :> tp) of-          Nothing -> mes middle (tp :<: bubble) ls-          Just (tp' :> bubble') -> mes (tp' :<: middle) bubble' ls-      mes middle bubble NilFL = (reverseRL middle) :> mapFL_FL (\tp -> PC tp False) (reverseRL bubble)+      mes :: forall wM1 wM2 wM3 .+            RL (LabelledPatch p) wM1 wM2 ->+            RL (LabelledPatch p) wM2 wM3 ->+            FL (PatchChoice p) wM3 wY ->+            (FL (LabelledPatch p) :> FL (PatchChoice p)) wM1 wY+      mes middle bubble (PC lp True :>: mls) = mes middle (bubble :<: lp) mls+      mes middle bubble (PC lp False :>: mls) =+        case commuteRL (bubble :> lp) of+          Nothing -> mes middle (bubble :<: lp) mls+          Just (lp' :> bubble') -> mes (middle :<: lp') bubble' mls+      mes middle bubble NilFL =+        (reverseRL middle) :> mapFL_FL (\lp -> PC lp False) (reverseRL bubble) --- | 'substitute' @(a :||: bs)@ @pcs@ replaces @a@ with @bs@ in @pcs@ preserving the choice---   associated with @a@-substitute :: forall p C(x y)-            . Patchy p-           => Sealed2 (TaggedPatch p :||: FL (TaggedPatch p))-           -> PatchChoices p C(x y)-           -> PatchChoices p C(x y)-substitute (Sealed2 (tp :||: new_tps)) (PCs f l) =-  PCs (concatFL $ mapFL_FL substTp f) (concatFL $ mapFL_FL substPc l)+-- | Substitute a single 'LabelledPatch' with an equivalent list of patches,+-- preserving its status as 'InFirst', 'InMiddle' or 'InLast').+-- The patch is looked up using equality of 'Label's.+substitute :: forall p wX wY .+              Sealed2 (LabelledPatch p :||: FL (LabelledPatch p))+           -> PatchChoices p wX wY+           -> PatchChoices p wX wY+substitute (Sealed2 (lp :||: new_lps)) (PCs f l) =+  PCs (concatFL $ mapFL_FL substLp f) (concatFL $ mapFL_FL substPc l)    where-     substTp :: TaggedPatch p C(a b) -> FL (TaggedPatch p) C(a b)-     substTp tp'-       | IsEq <- compareTags tp tp' = new_tps-       | otherwise = tp' :>: NilFL-     substPc :: PatchChoice p C(a b) -> FL (PatchChoice p) C(a b)-     substPc (PC tp' c)-       | IsEq <- compareTags tp tp' = mapFL_FL (flip PC c) new_tps-       | otherwise = PC tp' c :>: NilFL+     substLp :: LabelledPatch p wA wB -> FL (LabelledPatch p) wA wB+     substLp lp'+       | IsEq <- compareLabels lp lp' = new_lps+       | otherwise = lp' :>: NilFL+     substPc :: PatchChoice p wA wB -> FL (PatchChoice p) wA wB+     substPc (PC lp' c)+       | IsEq <- compareLabels lp lp' = mapFL_FL (pcSetLast c) new_lps+       | otherwise = PC lp' c :>: NilFL
src/Darcs/Patch/Commute.hs view
@@ -1,74 +1,81 @@ module Darcs.Patch.Commute-    ( Commute(..),-      commuteFL, commuteFLorComplain,-      commuteRL, commuteRLFL,-      toFwdCommute, toRevCommute+    ( Commute(..)+    , commuteFL+    , commuteRL+    , commuteRLFL+    , selfCommuter+    ) where++import Darcs.Prelude++import Darcs.Patch.CommuteFn+    ( CommuteFn+    , commuterIdFL+    , commuterRLId+    , commuterRLFL     )-    where+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), RL(..), reverseFL, reverseRL,+    (:>)(..) ) -import Darcs.Witnesses.Ordered (FL(..), RL(..), -                                reverseFL, reverseRL,-                                (:>)(..), (:<)(..)-                               )-import Darcs.Witnesses.Sealed ( Sealed2, seal2 )+{- | Class of patches that that can be commuted. -#include "gadts.h"+Instances should obey the following laws: --- | Things that can commute.-class Commute p where-    commute :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))+[commute-symmetry] --- | Swaps the ordered pair type so that commute can be--- called directly.-toFwdCommute :: (Commute p, Commute q, Monad m)-             => ((p :< q) C(x y) -> m ((q :< p) C(x y)))-             -> (q :> p) C(x y) -> m ((p :> q) C(x y))-toFwdCommute c (x :> y) = do x' :< y' <- c (y :< x)-                             return (y' :> x')+    prop> commute (p:>q) == Just (q':>p') <=> commute (q':>p') == Just (p':>q) --- | Swaps the ordered pair type from the order expected--- by commute to the reverse order.-toRevCommute :: (Commute p, Commute q, Monad m)-             => ((p :> q) C(x y) -> m ((q :> p) C(x y)))-             -> (q :< p) C(x y) -> m ((p :< q) C(x y))-toRevCommute c (x :< y) = do x' :> y' <- c (y :> x)-                             return (y' :< x')+[invert-commute] +    If patches are invertible, then +    prop> commute (p:>q) == Just (q':>p') <=> commute (invert q:>invert p) == Just (invert p':>invert q') -instance Commute p => Commute (FL p) where-    commute (NilFL :> x) = Just (x :> NilFL)-    commute (x :> NilFL) = Just (NilFL :> x)-    commute (xs :> ys) = do ys' :> rxs' <- commuteRLFL (reverseFL xs :> ys)-                            return $ ys' :> reverseRL rxs'+The more general law +[square-commute] -commuteRLFL :: Commute p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))-commuteRLFL (NilRL :> ys) = Just (ys :> NilRL)-commuteRLFL (xs :> NilFL) = Just (NilFL :> xs)-commuteRLFL (xs :> y :>: ys) = do y' :> xs' <- commuteRL (xs :> y)-                                  ys' :> xs'' <- commuteRLFL (xs' :> ys)-                                  return (y' :>: ys' :> xs'')+    prop> commute (p:>q) == Just (q':>p') => commute (invert p:>q') == Just (q:>invert p') -commuteRL :: Commute p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))-commuteRL (z :<: zs :> w) = do w' :> z' <- commute (z :> w)-                               w'' :> zs' <- commuteRL (zs :> w')-                               return (w'' :> z' :<: zs')-commuteRL (NilRL :> w) = Just (w :> NilRL)+is valid in general only provided we know (a priori) that @'commute' ('invert'+p':>'q')@ succeeds, in other words, that p and q are not in conflict with each+other. See "Darcs.Patch.CommuteNoConflicts" for an extended discussion. -commuteFLorComplain :: Commute p => (p :> FL p) C(x y) -> Either (Sealed2 p) ((FL p :> p) C(x y))-commuteFLorComplain (p :> NilFL) = Right (NilFL :> p)-commuteFLorComplain (q :> p :>: ps) = case commute (q :> p) of-                            Just (p' :> q') ->-                               case commuteFLorComplain (q' :> ps) of-                               Right (ps' :> q'') -> Right (p' :>: ps' :> q'')-                               Left l -> Left l-                            Nothing -> Left $ seal2 p+-}+class Commute p where+    commute :: (p :> p) wX wY -> Maybe ((p :> p) wX wY) -commuteFL :: Commute p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))-commuteFL = either (const Nothing) Just . commuteFLorComplain+instance Commute p => Commute (FL p) where+    {-# INLINE commute #-}+    commute (NilFL :> x) = Just (x :> NilFL)+    commute (x :> NilFL) = Just (NilFL :> x)+    commute (xs :> ys) = do+        ys' :> rxs' <- commuteRLFL (reverseFL xs :> ys)+        return $ ys' :> reverseRL rxs' +-- |'commuteRLFL' commutes an 'RL' past an 'FL'.+{-# INLINE commuteRLFL #-}+commuteRLFL :: Commute p => (RL p :> FL p) wX wY+            -> Maybe ((FL p :> RL p) wX wY)+commuteRLFL = commuterRLFL commute+ instance Commute p => Commute (RL p) where-    commute (xs :> ys) = do fys' :> xs' <- commuteRLFL (xs :> reverseRL ys)-                            return (reverseFL fys' :> xs')+    {-# INLINE commute #-}+    commute (xs :> ys) = do+        fys' :> xs' <- commuteRLFL (xs :> reverseRL ys)+        return (reverseFL fys' :> xs') +-- |'commuteRL' commutes a RL past a single element.+{-# INLINE commuteRL #-}+commuteRL :: Commute p => (RL p :> p) wX wY -> Maybe ((p :> RL p) wX wY)+commuteRL = commuterRLId commute++-- |'commuteFL' commutes a single element past a FL.+{-# INLINE commuteFL #-}+commuteFL :: Commute p => (p :> FL p) wX wY -> Maybe ((FL p :> p) wX wY)+commuteFL = commuterIdFL commute++-- |Build a commuter between a patch and itself using the operation from the type class.+selfCommuter :: Commute p => CommuteFn p p+selfCommuter = commute
+ src/Darcs/Patch/CommuteFn.hs view
@@ -0,0 +1,124 @@+module Darcs.Patch.CommuteFn+    ( CommuteFn,+      commuterIdFL, commuterFLId,+      commuterIdRL, commuterRLId,+      commuterRLFL,+      MergeFn,+      PartialMergeFn,+      mergerIdFL,+      TotalCommuteFn,+      totalCommuterIdFL, totalCommuterFLId, totalCommuterFLFL,+      invertCommuter+    ) where++import Darcs.Prelude++import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..)+    , (:\/:)(..)+    , (:/\:)(..)+    , FL(..)+    , RL(..)+    )++-- |CommuteFn is the basis of a general framework for building up commutation+-- operations between different patch types in a generic manner. Unfortunately+-- type classes are not well suited to the problem because of the multiple possible+-- routes by which the commuter for (FL p1, FL p2) can be built out of the+-- commuter for (p1, p2) - and more complicated problems when we start building+-- multiple constructors on top of each other. The type class resolution machinery+-- really can't cope with selecting some route, because it doesn't know that all+-- possible routes should be equivalent.+--+-- Note that a CommuteFn cannot be lazy i.e. commute patches only when the+-- resulting sequences are demanded. This is because of the possibility of+-- failure ('Nothing'): all the commutes must be performed before we can know+-- whether the overall commute succeeds.+type CommuteFn p1 p2 = forall wX wY . (p1 :> p2) wX wY -> Maybe ((p2 :> p1) wX wY)++type TotalCommuteFn p1 p2 = forall wX wY . (p1 :> p2) wX wY -> (p2 :> p1) wX wY++type MergeFn p1 p2 = forall wX wY . (p1 :\/: p2) wX wY -> (p2 :/\: p1) wX wY++type PartialMergeFn p1 p2 = forall wX wY . (p1 :\/: p2) wX wY -> Maybe ((p2 :/\: p1) wX wY)++commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2)+commuterIdRL _ (x :> NilRL) = return (NilRL :> x)+commuterIdRL commuter (x :> (ys :<: y))+  = do ys' :> x' <- commuterIdRL commuter (x :> ys)+       y' :> x'' <- commuter (x' :> y)+       return ((ys' :<: y') :> x'')++commuterIdFL :: CommuteFn p1 p2 -> CommuteFn p1 (FL p2)+commuterIdFL _ (x :> NilFL) = return (NilFL :> x)+commuterIdFL commuter (x :> (y :>: ys))+  = do y' :> x' <- commuter (x :> y)+       ys' :> x'' <- commuterIdFL commuter (x' :> ys)+       return ((y' :>: ys') :> x'')++-- | TODO document laziness or lack thereof+mergerIdFL :: MergeFn p1 p2 -> MergeFn p1 (FL p2)+mergerIdFL _ (x :\/: NilFL) = NilFL :/\: x+mergerIdFL merger (x :\/: (y :>: ys))+  = case merger (x :\/: y) of+      y' :/\: x' -> case mergerIdFL merger (x' :\/: ys) of+          ys' :/\: x'' -> (y' :>: ys') :/\: x''++-- | TODO document laziness or lack thereof+totalCommuterIdFL :: TotalCommuteFn p1 p2 -> TotalCommuteFn p1 (FL p2)+totalCommuterIdFL _ (x :> NilFL) = NilFL :> x+totalCommuterIdFL commuter (x :> (y :>: ys)) =+   case commuter (x :> y) of+     y' :> x' -> case totalCommuterIdFL commuter (x' :> ys) of+                   ys' :> x'' -> (y' :>: ys') :> x''++commuterFLId :: CommuteFn p1 p2 -> CommuteFn (FL p1) p2+commuterFLId _ (NilFL :> y) = return (y :> NilFL)+commuterFLId commuter ((x :>: xs) :> y)+  = do y' :> xs' <- commuterFLId commuter (xs :> y)+       y'' :> x' <- commuter (x :> y')+       return (y'' :> (x' :>: xs'))++commuterRLId :: CommuteFn p1 p2 -> CommuteFn (RL p1) p2+commuterRLId _ (NilRL :> y) = return (y :> NilRL)+commuterRLId commuter ((xs :<: x) :> y)+  = do y' :> x' <- commuter (x :> y)+       y'' :> xs' <- commuterRLId commuter (xs :> y')+       return (y'' :> (xs' :<: x'))++commuterRLFL :: forall p1 p2. CommuteFn p1 p2 -> CommuteFn (RL p1) (FL p2)+commuterRLFL commuter (xs :> ys) = right xs ys+  where+    right :: RL p1 wX wY -> FL p2 wY wZ -> Maybe ((FL p2 :> RL p1) wX wZ)+    right as NilFL = Just (NilFL :> as)+    right as (b :>: bs) = do+      b' :> as' <- commuterRLId commuter (as :> b)+      bs' :> as'' <- left as' bs+      return (b' :>: bs' :> as'')+    left :: RL p1 wX wY -> FL p2 wY wZ -> Maybe ((FL p2 :> RL p1) wX wZ)+    left NilRL bs = Just (bs :> NilRL)+    left (as :<: a) bs = do+      bs' :> a' <- commuterIdFL commuter (a :> bs)+      bs'' :> as' <- right as bs'+      return (bs'' :> as' :<: a')++-- | TODO document laziness or lack thereof+totalCommuterFLId :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) p2+totalCommuterFLId _ (NilFL :> y) = y :> NilFL+totalCommuterFLId commuter ((x :>: xs) :> y) =+   case totalCommuterFLId commuter (xs :> y) of+     y' :> xs' -> case commuter (x :> y') of+                    y'' :> x' -> y'' :> (x' :>: xs')++-- | TODO document laziness or lack thereof+totalCommuterFLFL :: TotalCommuteFn p1 p2 -> TotalCommuteFn (FL p1) (FL p2)+totalCommuterFLFL commuter = totalCommuterFLId (totalCommuterIdFL commuter)++-- | Make use of the inverse-commute law to reduce the number of cases+-- when defining commute for complicated patch types.+{-# INLINE invertCommuter #-}+invertCommuter :: (Invert p, Invert q) => CommuteFn p q -> CommuteFn q p+invertCommuter commuter (x :> y) = do+    ix' :> iy' <- commuter (invert y :> invert x)+    return (invert iy' :> invert ix')
+ src/Darcs/Patch/CommuteNoConflicts.hs view
@@ -0,0 +1,78 @@+module Darcs.Patch.CommuteNoConflicts+    ( CommuteNoConflicts(..)+    , mergeNoConflicts+    ) where++import Darcs.Prelude++import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Witnesses.Ordered ( (:/\:)(..), (:>)(..), (:\/:)(..) )++-- | It is natural to think of conflicting patches @p@ and @q@ as+-- a parallel pair @(p':\/:'q)@ because this is how conflicting patches arise.+-- But then Darcs comes along and merges them anyway by converting one of+-- them to a conflictor. Thus, inside a sequence of patches we may see+-- them as a sequential pair @(p ':>' q')@. In that case, 'commute' will always+-- succeed, as expressed by the merge-commute law. 'commuteNoConflicts'+-- is a restricted version of 'commute' that should fail in this case but+-- otherwise give the same result as 'commute'.+--+-- Primitive patch types have no conflictors, so for them we have+-- @'commute' == 'commuteNoConflicts'@.+--+-- Instances should obey the following laws:+--+-- * Symmetry+--+--     prop> commuteNoConflicts (p:>q) == Just (q':>p') <=> commuteNoConflicts (q':>p') == Just (p':>q)+--+-- * Square-Commute (if an instance @'Invert' p@ exists)+--+--     prop> commuteNoConflicts (p:>q) == Just (q':>p') => commuteNoConflicts (invert p:>q') == Just (q:>invert p')+--+-- * 'commuteNoConflicts' is a restriction of 'commute'+--+--     prop> commuteNoConflicts (p:>q) == Just r => commute (p:>q) == Just r+--+class Commute p => CommuteNoConflicts p where+    commuteNoConflicts :: (p :> p) wX wY -> Maybe ((p :> p) wX wY)+    -- ^ An alternative to 'commute' to be used if correctness of your code+    -- depends on the validity of the square-commute law, or to determine+    -- whether patches are in conflict. A parallel pair of patches @p':\/:'q@+    -- is conflicting if and only if @'commuteNoConflicts'(p^':>'q)@ fails. Its+    -- main use is so that we can define 'mergeNoConflicts' cleanly.++{- |+The non-conflicting merge of @(p':\/:'q)@ tries to commute the inverse @p^@+of @p@ with @q@. If it succeeds then the part of the result that corresponds+to @p^@ is re-inverted. This is also known as a "clean merge".++Note that to maintain consistency in the presence of conflictors we must use+use 'commuteNoConflicts' here and not 'commute'. Otherwise we run into+contradictions as explained below.++Concretely, suppose we use 'commute' here and that @q@ is a conflictor that+represents the primitive patch @r@ and conflicts (only) with (primitive+patch) @p^@. That is, @q@ results from the conflicted+@merge(r':\/:'p^)=(s':/\:'q)@, where @s@ is another conflictor. Now,+according to merge-commute we get @commute(p^':>'q)=Just(r':>'s)@, and thus+@mergeNoConflict(p':\/:'q)=Just(s^':/\:'r)@ in contradiction to our+assumption that @(p^':\/:'q@ are in conflict i.e.+@mergeNoConflict(p^':\/:'q)@ fails. (This argument takes for granted that+the addition of conflictors to prim patches preserves their commute+behavior. This is not yet stated as a law but all implementations obviously+adhere to it.)++As a side note, the fact that we now get an inverse conflictor @s^@ as part+of the result leads to further problems. For instance, whether our repo is+conflicted now depends on the order of patches: @(p':>'r)@ is not conflicted,+but its commute @(q':>'s^)@ obviously is. In fact, @(q':>'s^)@ is nothing else+but the (identity-preserving) "force-commute" of @(p':>'r)@, see the thread at+<https://lists.osuosl.org/pipermail/darcs-devel/2017-November/018403.html>.+-}+mergeNoConflicts :: (Invert p, CommuteNoConflicts p)+                 => (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)+mergeNoConflicts (p :\/: q) = do+  q' :> ip' <- commuteNoConflicts (invert p :> q)+  return (q' :/\: invert ip')
src/Darcs/Patch/Conflict.hs view
@@ -1,89 +1,122 @@+--  Copyright (C) 2002-2003 David Roundy, 2010 Ganesh Sittampalam module Darcs.Patch.Conflict-    ( Conflict(..), CommuteNoConflicts(..)-    , IsConflictedPrim(..), ConflictState(..) )-    where--import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Permutations ()-import Darcs.Patch.Prim.Class ( PrimOf )-import Darcs.Witnesses.Ordered-    ( FL(..), RL(..), (:>)(..)-    , mapFL, reverseFL, mapRL, reverseRL-    )-import Darcs.Witnesses.Sealed ( Sealed, unseal )-import Darcs.Utils ( nubsort )--#include "gadts.h"--class (Effect p, PatchInspect (PrimOf p)) => Conflict p where-    listConflictedFiles :: p C(x y) -> [FilePath]-    listConflictedFiles p =-        nubsort $ concatMap (unseal listTouchedFiles) $ concat $ resolveConflicts p-    resolveConflicts :: p C(x y) -> [[Sealed (FL (PrimOf p) C(y))]]--    conflictedEffect :: p C(x y) -> [IsConflictedPrim (PrimOf p)]-    conflictedEffect x = case listConflictedFiles x of-                         [] -> mapFL (IsC Okay) $ effect x-                         _ -> mapFL (IsC Conflicted) $ effect x--class CommuteNoConflicts p where-    -- | If 'commuteNoConflicts' @x :> y@ succeeds, we know that that @x@ commutes-    --   past @y@ without any conflicts.   This function is useful for patch types-    --   for which 'commute' is defined to always succeed; so we need some way to-    --   pick out the specific cases where commutation succeeds without any conflicts.-    commuteNoConflicts :: (p :> p) C(x y) -> Maybe ((p :> p) C(x y))--instance (CommuteNoConflicts p, Conflict p) => Conflict (FL p) where-    listConflictedFiles = nubsort . concat . mapFL listConflictedFiles-    resolveConflicts NilFL = []-    resolveConflicts x = resolveConflicts $ reverseFL x-    conflictedEffect = concat . mapFL conflictedEffect--instance CommuteNoConflicts p => CommuteNoConflicts (FL p) where-    commuteNoConflicts (NilFL :> x) = Just (x :> NilFL)-    commuteNoConflicts (x :> NilFL) = Just (NilFL :> x)-    commuteNoConflicts (xs :> ys) =   do ys' :> rxs' <- commuteNoConflictsRLFL (reverseFL xs :> ys)-                                         return $ ys' :> reverseRL rxs'+    ( Conflict(..)+    , ConflictDetails(..)+    , Mangled+    , Unravelled+    , mangleOrFail+    , combineConflicts+    , findConflicting+    ) where -instance (CommuteNoConflicts p, Conflict p) => Conflict (RL p) where-    listConflictedFiles = nubsort . concat . mapRL listConflictedFiles-    resolveConflicts x = rcs x NilFL-        where rcs :: RL p C(x y) -> FL p C(y w) -> [[Sealed (FL (PrimOf p) C(w))]]-              rcs NilRL _ = []-              rcs (p:<:ps) passedby | (_:_) <- resolveConflicts p =-                  case commuteNoConflictsFL (p:>passedby) of-                    Just (_:> p') -> resolveConflicts p' ++ rcs ps (p:>:passedby)-                    Nothing -> rcs ps (p:>:passedby)-              rcs (p:<:ps) passedby = seq passedby $ rcs ps (p:>:passedby)-    conflictedEffect = concat . reverse . mapRL conflictedEffect+import Darcs.Prelude -instance CommuteNoConflicts p => CommuteNoConflicts (RL p) where-    commuteNoConflicts (NilRL :> x) = Just (x :> NilRL)-    commuteNoConflicts (x :> NilRL) = Just (NilRL :> x)-    commuteNoConflicts (xs :> ys) =   do ys' :> rxs' <- commuteNoConflictsRLFL (xs :> reverseRL ys)-                                         return $ reverseFL ys' :> rxs'+import Darcs.Patch.Commute ( Commute(..), commuteFL, commuteRL )+import Darcs.Patch.CommuteFn ( commuterIdFL )+import Darcs.Patch.CommuteNoConflicts ( CommuteNoConflicts(..) )+import Darcs.Patch.Permutations ()+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Prim ( PrimMangleUnravelled(..), Mangled, Unravelled )+import Darcs.Patch.Show ( ShowPatch(..), ShowPatchFor(ForStorage), showPatch )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..), RL(..), mapFL, (+<<+) )+import Darcs.Util.Printer ( renderString, text, vcat, ($$) ) -data IsConflictedPrim prim where-    IsC :: !ConflictState -> !(prim C(x y)) -> IsConflictedPrim prim-data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read)+data ConflictDetails prim wX =+  ConflictDetails {+    conflictMangled :: Maybe (Mangled prim wX),+    conflictParts :: Unravelled prim wX+  } -commuteNoConflictsFL :: CommuteNoConflicts p => (p :> FL p) C(x y) -> Maybe ((FL p :> p) C(x y))-commuteNoConflictsFL (p :> NilFL) = Just (NilFL :> p)-commuteNoConflictsFL (q :> p :>: ps) =   do p' :> q' <- commuteNoConflicts (q :> p)-                                            ps' :> q'' <- commuteNoConflictsFL (q' :> ps)-                                            return (p' :>: ps' :> q'')+-- | For one conflict (a connected set of conflicting prims), store the+-- conflicting parts and, if possible, their mangled version.+mangleOrFail :: PrimMangleUnravelled prim+             => Unravelled prim wX -> ConflictDetails prim wX+mangleOrFail parts =+  ConflictDetails {+    conflictMangled = mangleUnravelled parts,+    conflictParts = parts+  } -commuteNoConflictsRL :: CommuteNoConflicts p => (RL p :> p) C(x y) -> Maybe ((p :> RL p) C(x y))-commuteNoConflictsRL (NilRL :> p) = Just (p :> NilRL)-commuteNoConflictsRL (p :<: ps :> q) =   do q' :> p' <- commuteNoConflicts (p :> q)-                                            q'' :> ps' <- commuteNoConflictsRL (ps :> q')-                                            return (q'' :> p' :<: ps')+class Conflict p where+    isConflicted :: p wX wY ->  Bool+    -- | The first parameter is a context containing all patches+    -- preceding the ones for which we want to calculate the conflict+    -- resolution, which is the second parameter.+    -- Each element of the result list represents the resolution+    -- of one maximal set of transitively conflicting alternatives,+    -- in other words, a connected subset of the conflict graph.+    -- But the elements themselves must not conflict with each other,+    -- guaranteeing that they can be cleanly merged into a single 'FL' of prims.+    resolveConflicts :: RL p wO wX -> RL p wX wY -> [ConflictDetails (PrimOf p) wY] -commuteNoConflictsRLFL :: CommuteNoConflicts p => (RL p :> FL p) C(x y) -> Maybe ((FL p :> RL p) C(x y))-commuteNoConflictsRLFL (NilRL :> ys) = Just (ys :> NilRL)-commuteNoConflictsRLFL (xs :> NilFL) = Just (NilFL :> xs)-commuteNoConflictsRLFL (xs :> y :>: ys) =   do y' :> xs' <- commuteNoConflictsRL (xs :> y)-                                               ys' :> xs'' <- commuteNoConflictsRLFL (xs' :> ys)-                                               return (y' :>: ys' :> xs'')+-- | By definition, a conflicting patch is resolved if another patch+-- (that is not itself conflicted) depends on the conflict. If the+-- representation of conflicts is self-contained as it is for V1 and V2,+-- then we can calculate the maximal set of conflicting alternatives for+-- a conflict separately for each conflictor at the end of a repo.+-- This function can then be used to lift this to an 'RL' of patches.+--+-- So, when looking for conflicts in a list of patches, we go+-- through the whole list looking for individual patches that represent+-- a conflict. But then we try to commute them past all the+-- patches we've already seen. If we fail, i.e. there's something+-- that depends on the conflict, then we forget about the conflict;+-- this is the Nothing case of the 'commuteNoConflictsFL' call.+-- Otherwise the patch is now in the correct position to extract the+-- conflicting alternatives.+combineConflicts+    :: forall p wX wY. CommuteNoConflicts p+    => (forall wA wB. p wA wB -> [Unravelled (PrimOf p) wB])+    -> RL p wX wY -> [Unravelled (PrimOf p) wY]+combineConflicts resolveOne x = rcs x NilFL+  where+    rcs :: RL p wX wM -> FL p wM wY -> [Unravelled (PrimOf p) wY]+    rcs NilRL _ = []+    rcs (ps :<: p) passedby+      | null (resolveOne p) = seq passedby rest -- TODO why seq here?+      | otherwise =+        case commuterIdFL commuteNoConflicts (p :> passedby) of+          Just (_ :> p') -> resolveOne p' ++ rest+          Nothing -> rest+      where+        rest = rcs ps (p :>: passedby) +-- | Find all patches in the context that conflict with a given patch,+-- commuting them to the head (past the patch in question).+--+-- This actually works by commuting the patch and its dependencies backward+-- until it becomes unconflicted, then minimizing the trailing patches by+-- re-commuting them backward as long as that keeps the patch unconflicted.+--+-- Precondition: the context must contain all conflicting patches.+findConflicting+  :: forall p wX wY wZ+   . (Commute p, Conflict p, ShowPatch p)+  => RL p wX wY+  -> p wY wZ+  -> (RL p :> p :> RL p) wX wZ+findConflicting context patch = go (context :> NilFL :> patch :> NilFL) where+  go :: (RL p :> FL p :> p :> FL p) wA wB -> (RL p :> p :> RL p) wA wB+  go (ctx :> deps :> p :> nondeps)+    | not (isConflicted p) = prune (ctx +<<+ deps :> p :> NilRL :> nondeps)+  go (NilRL :> deps :> p :> nondeps) =+    error $ renderString $ text "precondition violated:" $$+      vcat (mapFL (showPatch ForStorage) deps) $$+      text "===============" $$+      text "patch:" $$ (showPatch ForStorage) p $$+      text "===============" $$+      vcat (mapFL (showPatch ForStorage) nondeps)+  go (cs :<: c :> deps :> p :> nondeps) =+    case commuteFL (c :> deps) of+      Nothing -> go (cs :> c :>: deps :> p :> nondeps)+      Just (deps' :> c') ->+        case commute (c' :> p) of+          Nothing -> go (cs :> c :>: deps :> p :> nondeps)+          Just (p' :> c'') -> go (cs :> deps' :> p' :> c'' :>: nondeps)+  prune :: (RL p :> p :> RL p :> FL p) wA wB -> (RL p :> p :> RL p) wA wB+  prune (ctx :> p :> rs :> NilFL) = ctx :> p :> rs+  prune (ctx :> p :> rs :> n :>: ns)+    | Just (n' :> rs') <- commuteRL (rs :> n)+    , Just (n'' :> p') <- commute (p :> n')+    , not (isConflicted p') = prune (ctx :<: n'' :> p' :> rs' :> ns)+    | otherwise = prune (ctx :> p :> rs :<: n :> ns)
− src/Darcs/Patch/ConflictMarking.hs 
@@ -1,99 +0,0 @@---  Copyright (C) 2002-2003 David Roundy, 2010 Ganesh Sittampalam-{-# LANGUAGE ViewPatterns #-}-module Darcs.Patch.ConflictMarking-     ( mangleUnravelled-     ) where--import qualified Data.ByteString.Char8 as BC (pack, last)-import qualified Data.ByteString       as B (null, ByteString)-import Data.List ( sort, intersperse )-import Data.Maybe ( isJust )--import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk, isHunk )-import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Permutations ()-import Darcs.Patch.Prim ( PrimPatch, is_filepatch, primIsHunk, primFromHunk )-import Darcs.Witnesses.Ordered ( FL(..) )-import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal )--#include "gadts.h"-#include "impossible.h"--applyHunks :: IsHunk prim => [Maybe B.ByteString] -> FL prim C(x y) -> [Maybe B.ByteString]-applyHunks ms ((isHunk -> Just (FileHunk _ l o n)):>:ps) = applyHunks (rls l ms) ps-    where rls k _ | k <=0 = bug $ "bad hunk: start position <=0 (" ++ show k ++ ")"-          rls 1 mls = map Just n ++ drop (length o) mls-          rls i (ml:mls) = ml : rls (i-1) mls-          rls _ [] = bug "rls in applyHunks"-applyHunks ms NilFL = ms-applyHunks _ (_:>:_) = impossible--getAFilename :: PrimPatch prim => [Sealed (FL prim C(x))] -> FileName-getAFilename ((Sealed ((is_filepatch -> Just f):>:_)):_) = f-getAFilename _ = fp2fn ""--getOld :: PrimPatch prim => [Maybe B.ByteString] -> [Sealed (FL prim C(x))] -> [Maybe B.ByteString]-getOld mls (ps:pss) = getOld (getHunksOld mls ps) pss-getOld mls [] = mls--getHunksOld :: PrimPatch prim => [Maybe B.ByteString] -> Sealed (FL prim C(x))-              -> [Maybe B.ByteString]-getHunksOld mls (Sealed ps) =-    applyHunks (applyHunks mls ps) (invert ps)--getHunksNew :: IsHunk prim => [Maybe B.ByteString] -> Sealed (FL prim C(x))-              -> [Maybe B.ByteString]-getHunksNew mls (Sealed ps) = applyHunks mls ps--getHunkline :: [[Maybe B.ByteString]] -> Int-getHunkline = ghl 1-    where ghl :: Int -> [[Maybe B.ByteString]] -> Int-          ghl n pps =-            if any (isJust . head) pps-            then n-            else ghl (n+1) $ map tail pps--makeChunk :: Int -> [Maybe B.ByteString] -> [B.ByteString]-makeChunk n mls = pull_chunk $ drop (n-1) mls-    where pull_chunk (Just l:mls') = l : pull_chunk mls'-          pull_chunk (Nothing:_) = []-          pull_chunk [] = bug "should this be [] in pull_chunk?"---mangleUnravelled :: PrimPatch prim => [Sealed (FL prim C(x))] -> Sealed (FL prim C(x))-mangleUnravelled pss = if onlyHunks pss-                        then (:>: NilFL) `mapSeal` mangleUnravelledHunks pss-                        else head pss--onlyHunks :: forall prim C(x) . PrimPatch prim => [Sealed (FL prim C(x))] -> Bool-onlyHunks [] = False-onlyHunks pss = fn2fp f /= "" && all oh pss-    where f = getAFilename pss-          oh :: Sealed (FL prim C(y)) -> Bool-          oh (Sealed (p:>:ps)) = primIsHunk p &&-                                 [fn2fp f] == listTouchedFiles p &&-                                 oh (Sealed ps)-          oh (Sealed NilFL) = True--mangleUnravelledHunks :: PrimPatch prim => [Sealed (FL prim C(x))] -> Sealed (prim C(x))---mangleUnravelledHunks [[h1],[h2]] = Deal with simple cases handily?-mangleUnravelledHunks pss =-        if null nchs then bug "mangleUnravelledHunks"-                     else Sealed (primFromHunk (FileHunk filename l old new))-    where oldf = getOld (repeat Nothing) pss-          newfs = map (getHunksNew oldf) pss-          l = getHunkline $ oldf : newfs-          nchs = sort $ map (makeChunk l) newfs-          filename = getAFilename pss-          old = makeChunk l oldf-          new = [top] ++ old ++ [initial] ++ concat (intersperse [middle] nchs) ++ [bottom]-          top    = BC.pack $ "v v v v v v v" ++ eol_c-          initial= BC.pack $ "=============" ++ eol_c-          middle = BC.pack $ "*************" ++ eol_c-          bottom = BC.pack $ "^ ^ ^ ^ ^ ^ ^" ++ eol_c-          eol_c  = if any (\ps -> not (B.null ps) && BC.last ps == '\r') old-                   then "\r"-                   else ""-
+ src/Darcs/Patch/Debug.hs view
@@ -0,0 +1,20 @@+module Darcs.Patch.Debug ( PatchDebug(..) )where++import Darcs.Patch.Witnesses.Ordered ( FL, RL )++-- | PatchDebug is a hook class for temporarily adding debug information.+-- To use it, add any methods that are required, implement those methods+-- where needed, and then make it available in the relevant contexts.+-- For example it can be temporarily added as a superclass of `Patchy`.+-- The advantage of having it here already is that everything is+-- (or should be) declared as an instance of it, so you can use+-- defaulting or just leave out declarations of instance methods and+-- code will still compile.+class PatchDebug p where+   -- | A dummy method so we can export/import PatchDebug(..) without+   -- triggering warnings+   patchDebugDummy :: p wX wY -> ()+   patchDebugDummy _ = ()++instance PatchDebug p => PatchDebug (FL p)+instance PatchDebug p => PatchDebug (RL p)
src/Darcs/Patch/Depends.hs view
@@ -15,364 +15,412 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP , ScopedTypeVariables #-}+{- | Definitions used in this module: -#include "gadts.h"+[Explicit dependencies]: The set of patches that a (named) patch depends on+  "by name", i.e. irrespective of (non-)commutation (non commuting patches are+  implicit dependencies). The most important example are tags, but non-tag+  patches can also have explicit dependencies by recording them with+  --ask-deps. -module Darcs.Patch.Depends ( getTagsRight,-                             areUnrelatedRepos,-                             mergeThem, findCommonWithThem,-                             countUsThem, removeFromPatchSet,-                 optimizePatchset, deepOptimizePatchset,-                 slightlyOptimizePatchset,-                 getPatchesBeyondTag, getPatchesInTag,-                 splitOnTag,-                 newsetUnion, newsetIntersection,-                 commuteToEnd, findUncommon, merge2FL-               ) where-import Data.List ( delete, intersect, (\\) )+[Covered]: A patch @p@ is covered by a tag @t@ if @t@ explicitly depends on+  @p@ or a tag covered by @t@ explicitly depends on @p@. In other words, the+  transitive closure of the relation "is depended on", restricted to+  situations where the right hand side is a tag. Note that it does /not/ take+  explicit dependencies of non-tag patches into account at all. -import Darcs.Patch ( RepoPatch, getdeps, commute, commuteFLorComplain, commuteRL )-import Darcs.Patch.Info ( PatchInfo, isTag, humanFriendly )-import Darcs.Patch.Merge ( mergeFL )-import Darcs.Patch.Permutations ( partitionFL, partitionRL, removeSubsequenceRL )-import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, hopefullyM, info )-import Darcs.Witnesses.Eq ( EqCheck(..), (=\/=), (=/\=) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart )-import Darcs.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..), (:>)(..), (:>)(..),-                                 (+>+), mapFL,-                                 RL(..), FL(..), isShorterThanRL, (+<+),-                                 reverseFL, reverseRL, mapRL, )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, newset2RL )-import Darcs.ProgressPatches ( progressRL )-import Darcs.Witnesses.Sealed (Sealed(..), FlippedSeal(..), flipSeal, seal )-import Printer ( renderString, vcat )-#include "impossible.h"+[Clean]: A tag @t@ in a repository is clean if all patches prior to the tag are+  covered by @t@. Tags normally start out as clean tags (the exception is+  if --ask-deps is used). It typically becomes unclean when it is merged into+  another repo (here the exceptions are if --reorder-patches is used, or if+  the target repo is actually a subset of the source repo).+-} -{-|-with_partial_intersection takes two 'PatchSet's and splits them into a /common/-intersection portion and two sets of patches.  The intersection, however,-is only lazily determined, so there is no guarantee that all intersecting-patches will be included in the intersection 'PatchSet'.  This is a pretty-efficient function, because it makes use of the already-broken-up nature of-'PatchSet's.+module Darcs.Patch.Depends+    ( getUncovered+    , areUnrelatedRepos+    , findCommon+    , findCommonWithThem+    , findUncommon+    , patchSetMerge+    , countUsThem+    , removeFromPatchSet+    , slightlyOptimizePatchset+    , fullyOptimizePatchSet+    , splitOnTag+    , patchSetUnion+    , patchSetIntersection+    , cleanLatestTag+    , contextPatches+    ) where -Note that the first argument to with_partial_intersection should be-the repository that is more cheaply accessed (i.e. local), as-with_partial_intersection does its best to reduce the number of-inventories that are accessed from its rightmost argument.--}+import Darcs.Prelude -with_partial_intersection-    :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y)-    -> (FORALL(a c) RL (Tagged p) C(start a)-            -> RL (PatchInfoAnd p) C(a x)-            -> RL (PatchInfoAnd p) C(a c)-            -> ddd)-    -> ddd-with_partial_intersection (PatchSet ps1 NilRL) s j = j NilRL ps1 (newset2RL s)-with_partial_intersection s (PatchSet ps2 NilRL) j =-    j NilRL (newset2RL s) ps2-with_partial_intersection bbb (PatchSet a (Tagged ta _ _ :<: _)) j-    | Just (PatchSet b t) <- simpleTag (info ta) bbb = j t b (unsafeCoerceP a)-with_partial_intersection aaa (PatchSet b (Tagged tb _ pb :<: tbs)) j-    = case hopefullyM tb of-        Just _ -> with_partial_intersection aaa (PatchSet (b+<+tb:<:pb) tbs) j-        Nothing -> case splitOnTag (info tb) aaa of-                   PatchSet NilRL com :> us -> j com us (unsafeCoerceP b)-                   _ -> impossible+import Control.Applicative ( (<|>) )+import Data.List ( delete, foldl1', intersect, (\\) ) -getPatchesBeyondTag :: RepoPatch p => PatchInfo -> PatchSet p C(start x) -> FlippedSeal (RL (PatchInfoAnd p)) C(x)-getPatchesBeyondTag t (PatchSet ps (Tagged hp _ _ :<:_)) | info hp == t = flipSeal ps-getPatchesBeyondTag t patchset@(PatchSet (hp:<:ps) ts) =-    if info hp == t-    then if getTagsRight patchset == [info hp]-         then flipSeal $ NilRL -- special case to avoid looking at redundant patches-         else case splitOnTag t patchset of _ :> e -> flipSeal e-    else case getPatchesBeyondTag t (PatchSet ps ts) of-         FlippedSeal xxs -> FlippedSeal (hp :<: xxs)-getPatchesBeyondTag t (PatchSet NilRL NilRL) = bug $ "tag\n" ++-                                                renderString (humanFriendly t) ++-                                                "\nis not in the patchset in getPatchesBeyondTag."-getPatchesBeyondTag t0 (PatchSet NilRL (Tagged t _ ps :<: ts)) =-                              getPatchesBeyondTag t0 (PatchSet (t:<:ps) ts)+import Darcs.Patch.Named ( getdeps )+import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Ident+    ( fastRemoveSubsequenceRL+    , findCommonRL+    , findCommonWithThemRL+    )+import Darcs.Patch.Info ( PatchInfo, isTag )+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Permutations ( partitionRL )+import Darcs.Patch.PatchInfoAnd( PatchInfoAnd, hopefully, info )+import Darcs.Patch.Set+    ( Origin+    , PatchSet(..)+    , SealedPatchSet+    , Tagged(..)+    , appendPSFL+    , emptyPatchSet+    , patchSet2FL+    , patchSet2RL+    , patchSetSplit+    )+import Darcs.Patch.Progress ( progressRL )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) )+import Darcs.Patch.Witnesses.Ordered+    ( (:\/:)(..), (:/\:)(..), (:>)(..), Fork(..),+    mapFL, RL(..), FL(..), isShorterThanRL, breakRL,+    (+<+), reverseFL, reverseRL, mapRL )+import Darcs.Patch.Witnesses.Sealed+    ( Sealed(..), seal ) -splitOnTag :: RepoPatch p => PatchInfo -> PatchSet p C(start x) -> (PatchSet p :> RL (PatchInfoAnd p)) C(start x)-splitOnTag t (PatchSet ps (Tagged hp x ps2 :<: ts))-    | info hp == t = (PatchSet NilRL (Tagged hp x ps2 :<: ts)) :> ps-splitOnTag t patchset@(PatchSet (hp:<:ps) ts)-    | info hp == t = if getTagsRight patchset == [info hp]-                     then PatchSet NilRL (Tagged hp Nothing ps :<: ts) :> NilRL-                     else case partitionRL ((`notElem` (t:ds)) . info) (hp:<:ps) of-                          (x:<:a) :> b ->-                              if getTagsRight (PatchSet (x:<:a) ts) == [t]-                              then PatchSet NilRL (Tagged x Nothing a :<: ts) :> b-                              else case splitOnTag t $ eatOne $ PatchSet (x:<:a) ts of-                                   xx :> yy -> xx :> (b +<+ yy)-                          _ -> impossible-    where ds = getdeps (hopefully hp)-          eatOne :: PatchSet p C(start x) -> PatchSet p C(start x)-          eatOne (PatchSet ps1 (Tagged x _ ps2 :<: ts')) = PatchSet (ps1+<+x:<:ps2) ts'-          eatOne _ = bug "a stubborn case in splitOnTag (theoretically possible)"-splitOnTag t (PatchSet (p:<:ps) ts) = case splitOnTag t (PatchSet ps ts) of-                                        ns :> x -> ns :> (p:<:x)-splitOnTag t0 (PatchSet NilRL (Tagged t _ ps :<: ts)) = splitOnTag t0 (PatchSet (t:<:ps) ts)-splitOnTag t0 (PatchSet NilRL NilRL) = bug $ "tag\n" ++-                                                renderString (humanFriendly t0) ++-                                                "\nis not in the patchset in splitOnTag."+{-|+Find clean tags that are common to both argument 'PatchSet's and return a+'Fork' with the common clean tags and whatever remains of the 'PatchSet's.+The two "uncommon" sequences may still have patches in common, even clean+tags, since we look only at the "known clean" tags of the second argument,+i.e. those that are the head of a 'Tagged' section. --- | @getPatchesInTag t ps@ returns a 'SealedPatchSet' of all--- patches in @ps@ which are contained in @t@.-getPatchesInTag :: RepoPatch p => PatchInfo -> PatchSet p C(start x) -> SealedPatchSet p C(start)-getPatchesInTag t ns = case splitOnTag t ns of-                            ns' :> _ -> seal ns'+This is a pretty efficient function, because it makes use of the+already-broken-up nature of 'PatchSet's. --- | @getTagsRight ps@ returns the 'PatchInfo' for all the patches in---   @ps@ that are not depended on by anything else *through explicit---   dependencies*. Tags are a likely candidate, although we may also---   find some non-tag patches in this list.------   Keep in mind that in a typical repository with a lot of tags, only a small---   fraction of tags would be returned as they would be at least indirectly---   depended on by the topmost ones.-getTagsRight :: PatchSet p C(start x) -> [PatchInfo]-getTagsRight (PatchSet ps NilRL) = getTagsR (mapRL infoAndDeps ps)-getTagsRight (PatchSet ps (Tagged t _ _ :<: _)) = getTagsR (mapRL infoAndDeps (ps+<+t:<:NilRL))+Note that the first argument should be the repository that is more cheaply+accessed (i.e. local), as 'taggedIntersection' does its best to reduce the+number of inventories that are accessed from its second argument.+-}+taggedIntersection :: forall p wX wY . Commute p+                   => PatchSet p Origin wX -> PatchSet p Origin wY ->+                      Fork (RL (Tagged p))+                           (RL (PatchInfoAnd p))+                           (RL (PatchInfoAnd p)) Origin wX wY+taggedIntersection (PatchSet NilRL ps1) s2 = Fork NilRL ps1 (patchSet2RL s2)+taggedIntersection s1 (PatchSet NilRL ps2) = Fork NilRL (patchSet2RL s1) ps2+taggedIntersection s1 (PatchSet (ts2 :<: Tagged t2ps t2 _) ps2) =+  -- First try to find t2 in the heads of Tagged sections of s1;+  -- if that fails, try to reorder patches in s1 so that it does;+  -- otherwise t2 does not occur in s1, so recurse with the current+  -- Tagged section of s2 unwrapped.+  case maybeSplitSetOnTag (info t2) s1 <|> splitOnTag (info t2) s1 of+    Just (PatchSet ts1 ps1) -> Fork ts1 ps1 (unsafeCoercePStart ps2)+    Nothing -> taggedIntersection s1 (PatchSet ts2 (t2ps :<: t2 +<+ ps2)) -getTagsR :: [(PatchInfo, Maybe [PatchInfo])] -> [PatchInfo]-getTagsR [] = []-getTagsR ((i0,Nothing):pps0) = i0 : getTagsR pps0-getTagsR ((i0,Just ds0):pps0) = i0 : getTagsR (drop_tags_r ds0 pps0)-    where-    -- example traversal given dependencies:-    ---    -- X1 -> X2-    -- X1 -> X4-    -- X2 -> X3-    ---    -- [X2,X4]: | o1  o2  X2  o3  o4  X3  o5 X5-    --            o1 |o2  X2  o3  o4  X3  o5 X5-    -- [X4,X3]:   o1  o2   |  o3  o4  X3  o5 X5-    --            ...-    --    [X4]:   o1  o2      o3  o4   |  o5 X5-    --            ...-    --      []:   o1  o2      o3  o4      o5-    drop_tags_r :: [PatchInfo]-                -> [(PatchInfo, Maybe [PatchInfo])] -> [(PatchInfo, Maybe [PatchInfo])]-    drop_tags_r [] pps = pps-    drop_tags_r _  []  = []-    drop_tags_r ds (hp:pps)-        | fst hp `elem` ds = case snd hp of-                             Just ds' -> drop_tags_r (ds'++delete (fst hp) ds) pps-                             Nothing -> drop_tags_r (delete (fst hp) ds) pps-        | otherwise = hp : drop_tags_r ds pps+-- |'maybeSplitSetOnTag' takes a tag's 'PatchInfo', @t0@, and a 'PatchSet' and+-- attempts to find @t0@ in one of the 'Tagged's in the PatchSet. If the tag is+-- found, the 'PatchSet' is split up, on that tag, such that all later patches+-- are in the "since last tag" patch list. If the tag is not found, 'Nothing'+-- is returned.+-- This is a simpler version of 'splitOnTag' that only looks at the heads+-- of 'Tagged' sections and does not commute any patches.+maybeSplitSetOnTag :: PatchInfo -> PatchSet p wStart wX+                   -> Maybe (PatchSet p wStart wX)+maybeSplitSetOnTag t0 origSet@(PatchSet (ts :<: Tagged pst t _) ps)+    | t0 == info t = Just origSet+    | otherwise = do+        PatchSet ts' ps' <- maybeSplitSetOnTag t0 (PatchSet ts (pst :<: t))+        Just $ PatchSet ts' (ps' +<+ ps)+maybeSplitSetOnTag _ _ = Nothing -infoAndDeps :: PatchInfoAnd p C(x y) -> (PatchInfo, Maybe [PatchInfo])-infoAndDeps p-        | isTag (info p) = (info p, getdeps `fmap` hopefullyM p)-        | otherwise = (info p, Nothing)+-- | Take a tag's 'PatchInfo', and a 'PatchSet', and attempt to find the tag in+-- the 'PatchSet'. If found, return a new 'PatchSet', in which the tag is now+-- clean (and the last of the 'Tagged' list), while all patches that are not+-- covered by the tag are in the trailing list of patches.+-- If the tag is not in the 'PatchSet', we return 'Nothing'.+splitOnTag :: Commute p => PatchInfo -> PatchSet p wStart wX+           -> Maybe (PatchSet p wStart wX)+-- If the tag we are looking for is the first Tagged tag of the patchset, we+-- are done.+splitOnTag t s@(PatchSet (_ :<: Tagged _ hp _) _) | info hp == t = Just s+-- If the tag is the most recent patch in the set, we check if the patch is the+-- only non-depended-on patch in the set (i.e. it is a clean tag); creating a+-- new Tagged out of the patches and tag, and adding it to the patchset, if+-- this is the case. Otherwise, we try to make the tag clean.+splitOnTag t patchset@(PatchSet ts hps@(ps :<: hp)) | info hp == t =+    if getUncovered patchset == [t]+        then+          -- If t is the only patch not covered by any tag, then it is clean+          Just $ PatchSet (ts :<: Tagged ps hp Nothing) NilRL+        else+          -- Make it clean by commuting out patches not explicitly depended on+          -- by @t@; since we do this with just the trailing sequence @hps@ i.e.+          -- we don't include the tag of the next Tagged, we have to make an+          -- extra check to see if this tag is covered, too, and otherwise+          -- recurse with the next Tagged section unwrapped. Note that we cannot+          -- simply check if @t@ depends on this tag because it may depend+          -- indirectly via unclean tags contained in @hps@.+          case partitionRL ((`notElem` (t : getdeps (hopefully hp))) . info) hps of+            tagAndDeps@(ds' :<: hp') :> nonDeps ->+                -- check if t is now fully clean+                if getUncovered (PatchSet ts tagAndDeps) == [t]+                    then let tagged = Tagged ds' hp' Nothing in+                         return $ PatchSet (ts :<: tagged) nonDeps+                    else do+                        unfolded <- unwrapOneTagged $ PatchSet ts tagAndDeps+                        PatchSet ts' ps' <- splitOnTag t unfolded+                        return $ PatchSet ts' (ps' +<+ nonDeps)+            _ -> error "impossible case"+-- We drop the leading patch, to try and find a non-Tagged tag.+splitOnTag t (PatchSet ts (ps :<: p)) = do+    PatchSet ns xs <- splitOnTag t (PatchSet ts ps)+    return $ PatchSet ns (xs :<: p)+-- If there are no patches left, we "unfold" the next Tagged, and try again.+splitOnTag t0 patchset@(PatchSet (_ :<: Tagged _ _ _) NilRL) =+    unwrapOneTagged patchset >>= splitOnTag t0+-- If we've checked all the patches, but haven't found the tag, return Nothing.+splitOnTag _ (PatchSet NilRL NilRL) = Nothing --- | @deepOptimizePatchset@ runs through all patches whether they are in the---   surface inventory or the deep one.-deepOptimizePatchset :: PatchSet p C(start x) -> PatchSet p C(start x)-deepOptimizePatchset ns = optimizePatchset (PatchSet (newset2RL ns) NilRL)+-- | Reorder a 'PatchSet' such that the latest tag becomes clean.+cleanLatestTag :: Commute p+               => PatchSet p wStart wX+               -> PatchSet p wStart wX+cleanLatestTag inp@(PatchSet ts ps) =+  case breakRL (isTag . info) ps of+    NilRL :> _ -> inp -- no tag among the ps -> we are done+    (left@(_ :<: t) :> right) ->+      case splitOnTag (info t) (PatchSet ts left) of+        Just (PatchSet ts' ps') -> PatchSet ts' (ps' +<+ right)+        _ -> error "impossible case" -- because t is in left --- | @optimizePatchset@ is similar to @slightlyOptimizePatchset@ in---   that it only works on the surface inventory (see below), but it---   works a bit harder and can optimize several tags.+-- | Create a 'Tagged' section for every clean tag. For unclean tags we try to+-- make them clean, but only if that doesn't make an earlier clean tag dirty.+-- This means that the operation is idempotent and in particular monotonic,+-- which justifies the "optimize" in the name.+fullyOptimizePatchSet+  :: forall p wZ . Commute p => PatchSet p Origin wZ -> PatchSet p Origin wZ+fullyOptimizePatchSet = go emptyPatchSet . patchSet2FL+  where+    go :: PatchSet p Origin wY -> FL (PatchInfoAnd p) wY wZ -> PatchSet p Origin wZ+    go s NilFL = s+    go s@(PatchSet ts ps) (q:>:qs)+      | isTag qi, getUncovered s' == [qi] =+          -- tag is clean+          go (PatchSet (ts :<: Tagged ps q Nothing) NilRL) qs+      | isTag qi, Just s'' <- makeClean s q = go s'' qs+      | otherwise = go s' qs+      where+        qi = info q+        s' = PatchSet ts (ps:<:q)++-- | Take a 'PatchSet' and an adjacent tag and try to make the tag clean+-- by commuting out trailing patches that are not covered by the tag.+makeClean+  :: Commute p+  => PatchSet p Origin wY+  -> PatchInfoAnd p wY wZ+  -> Maybe (PatchSet p Origin wZ)+makeClean (PatchSet ts ps) t =+  let ti = info t in+  case partitionRL ((`notElem` (ti : getdeps (hopefully t))) . info) (ps :<: t) of+    tagAndDeps@(ds :<: t') :> nonDeps ->+      -- check if tag really became clean+      if getUncovered (PatchSet ts tagAndDeps) == [ti]+        then Just $ PatchSet (ts :<: Tagged ds t' Nothing) nonDeps+        else Nothing+    _ -> error "imposible"++-- |'unwrapOneTagged' unfolds a single Tagged object in a PatchSet, adding the+-- tag and patches to the PatchSet's patch list.+unwrapOneTagged :: PatchSet p wX wY -> Maybe (PatchSet p wX wY)+unwrapOneTagged (PatchSet (ts :<: Tagged tps t _) ps) =+    Just $ PatchSet ts (tps :<: t +<+ ps)+unwrapOneTagged _ = Nothing++-- | Return the 'PatchInfo' for all the patches in a 'PatchSet' that are not+-- *explicitly* depended on by any tag (in the given 'PatchSet'). -----   * surface inventory: the sequence of patches that corresponds---     to the @\_darcs/hashed\_inventory@ or @\_darcs/inventory@ files+-- This is exactly the set of patches that a new tag recorded on top+-- of the 'PatchSet' would explicitly depend on. -----   * deep inventory: the sequence of sequences of patches that---     corresponds to the @\_darcs/inventories@ directory-optimizePatchset :: PatchSet p C(start x) -> PatchSet p C(start x)-optimizePatchset (PatchSet NilRL ts) = PatchSet NilRL ts-optimizePatchset (PatchSet (p:<:ps) ts)-    | isTag (info p) && getTagsRight (PatchSet (p:<:ps) ts) == [info p]-      -- all subsequent patches depend on p-      = case optimizePatchset (PatchSet ps ts) of-        PatchSet ps' ts' -> PatchSet NilRL (Tagged p Nothing ps' :<: ts')-    | otherwise = case optimizePatchset (PatchSet ps ts) of-                  PatchSet ps' ts' -> PatchSet (p:<:ps') ts'+-- Note that the result is not minimal with respect to dependencies, not even+-- explicit dependencies: explicit dependencies of regular (non-tag) patches+-- are completely ignored.+getUncovered :: PatchSet p wStart wX -> [PatchInfo]+getUncovered (PatchSet tagged patches) =+  findUncovered $+    case tagged of+      NilRL -> mapRL infoAndExplicitDeps patches+      _ :<: Tagged _ t _ -> mapRL infoAndExplicitDeps patches ++ [(info t, [])]+  where+    -- Both findUncovered and dropDepsIn are basically graph algorithms. We+    -- present the (directed, acyclic) graph as a topologically sorted list of+    -- vertices together with the targets of their outgoing edges. The problem+    -- findUncovered solves is to find all vertices with no incoming edges.+    -- This is done by removing all vertices reachable from any vertex in the+    -- graph.+    findUncovered :: Eq a => [(a, [a])] -> [a]+    findUncovered [] = []+    findUncovered ((pi, deps) : rest) =+        pi : findUncovered (dropDepsIn deps rest) --- | @slightlyOptimizePatchset@ only works on the surface inventory---   (see 'optimizePatchset') and only optimises at most one tag in---   there, going for the most recent tag which has no non-depended---   patch after it. Older tags won't be 'clean', which means the---   PatchSet will not be in 'unclean :< clean' state.-slightlyOptimizePatchset :: PatchSet p C(start x) -> PatchSet p C(start x)-slightlyOptimizePatchset (PatchSet ps0 ts0) = sops $ PatchSet (progressRL "Optimizing inventory" ps0) ts0-    where sops :: PatchSet p C(start y) -> PatchSet p C(start y)-          sops (PatchSet NilRL ts) = PatchSet NilRL ts-          sops (PatchSet (hp:<:ps) ts)-              | isTag (info hp) = if getTagsRight (PatchSet (hp:<:ps) ts) == [info hp]-                                   then -- exactly one tag and it depends on everything not already archived-                                        PatchSet NilRL (Tagged hp Nothing ps :<: ts)-                                   else -- other tags or other top-level patches too (so move past hp)-                                        case sops $ PatchSet (progressRL "Optimizing inventory" ps) ts of-                                        PatchSet ps' ts' -> PatchSet (hp:<:ps') ts'-              | otherwise = -- move past hp-                            case sops $ PatchSet ps ts of-                            PatchSet ps' ts' -> PatchSet (hp:<:ps') ts'+    -- Remove the given list of vertices from the graph, as well as all+    -- vertices reachable from them.+    dropDepsIn :: Eq a => [a] -> [(a, [a])] -> [(a, [a])]+    dropDepsIn [] ps = ps+    dropDepsIn _  [] = []+    dropDepsIn ds (hp@(hpi,hpds) : ps)+        | hpi `elem` ds = dropDepsIn (delete hpi ds ++ hpds) ps+        | otherwise = hp : dropDepsIn ds ps -commuteToEnd :: forall p C(start x y). RepoPatch p => RL (PatchInfoAnd p) C(x y)-               -> PatchSet p C(start y) -> (PatchSet p :> RL (PatchInfoAnd p)) C(start x)-commuteToEnd NilRL (PatchSet ps ts) = PatchSet NilRL ts :> ps-commuteToEnd (p:<:ps) (PatchSet xs ts)-    | info p `elem` mapRL info xs = case fastRemoveRL p xs of-                                    Just xs' -> commuteToEnd ps (PatchSet xs' ts)-                                    Nothing -> impossible -- "Nothing is impossible"-commuteToEnd ps (PatchSet xs (Tagged t _ ys :<: ts)) =-    commuteToEnd ps (PatchSet (xs+<+t:<:ys) ts)-commuteToEnd _ _ = impossible+    -- The patch info together with the list of explicit dependencies in case+    -- it is a tag. This constructs one element of the graph representation.+    -- It cannot be used for the tag of a Tagged section as that may not be+    -- available in a lazy repo. That's okay because we already know it is+    -- clean, so no patches preceding it it can be uncovered.+    infoAndExplicitDeps :: PatchInfoAnd p wX wY -> (PatchInfo, [PatchInfo])+    infoAndExplicitDeps p+        | isTag (info p) = (info p, getdeps $ hopefully p)+        | otherwise = (info p, []) -removeFromPatchSet :: RepoPatch p => FL (PatchInfoAnd p) C(x y)-                 -> PatchSet p C(start y) -> Maybe (PatchSet p C(start x))-removeFromPatchSet bad0 = rfns (reverseFL bad0)-    where rfns :: RepoPatch p => RL (PatchInfoAnd p) C(x y)-               -> PatchSet p C(start y) -> Maybe (PatchSet p C(start x))-          rfns bad (PatchSet ps ts)-              | all (`elem` (mapRL info ps)) (mapRL info bad) =-                  do ps' <- removeSubsequenceRL bad ps-                     Just $ PatchSet ps' ts-          rfns _ (PatchSet _ NilRL) = Nothing-          rfns bad (PatchSet ps (Tagged t _ tps :<: ts)) =-                        rfns bad (PatchSet (ps+<+t:<:tps) ts)+-- | Create a new 'Tagged' section for the most recent clean tag found in the+-- tail of un-'Tagged' patches without re-ordering patches. Note that earlier+-- tags may remain un-'Tagged' even if they are actually clean.+slightlyOptimizePatchset :: PatchSet p wStart wX -> PatchSet p wStart wX+slightlyOptimizePatchset (PatchSet ts0 ps0) =+    go $ PatchSet ts0 (progressRL "Optimizing inventory" ps0)+  where+    go :: PatchSet p wStart wY -> PatchSet p wStart wY+    go (PatchSet ts NilRL) = PatchSet ts NilRL+    go s@(PatchSet ts (ps :<: hp))+        | isTag (info hp)+        , [info hp] == getUncovered s =+            PatchSet (ts :<: Tagged ps hp Nothing) NilRL+        | otherwise = appendPSFL (go (PatchSet ts ps)) (hp :>: NilFL) -findCommonWithThem :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y)-                   -> (PatchSet p :> FL (PatchInfoAnd p)) C(start x)+removeFromPatchSet+  :: (Commute p, Eq2 p)+  => FL (PatchInfoAnd p) wX wY+  -> PatchSet p wStart wY+  -> Maybe (PatchSet p wStart wX)+removeFromPatchSet bad s@(PatchSet ts ps)+  | all (`elem` mapRL info ps) (mapFL info bad) = do+    ps' <- fastRemoveSubsequenceRL (reverseFL bad) ps+    return (PatchSet ts ps')+  | otherwise = removeFromPatchSet bad =<< unwrapOneTagged s++-- | The symmetric difference between two 'PatchSet's, expressed as a 'Fork'+-- consisting of the intersection 'PatchSet' and the trailing lists of+-- left-only and right-only patches.+--+-- From a purely functional point of view this is a symmetric function.+-- However, laziness effects make it asymmetric: the LHS is more likely to be+-- evaluated fully, while the RHS is evaluated as sparingly as possible. For+-- efficiency, the LHS should come from the local repo and the RHS from the+-- remote one. This asymmetry can also have a semantic effect, namely if+-- 'PatchSet's have *unavailable* patches or inventories, for instance when we+-- deal with a lazy clone of a repo that is no longer accessible. In this case+-- the order of arguments may determine whether the command fails or succeeds.+findCommon+  :: Commute p+  => PatchSet p Origin wX+  -> PatchSet p Origin wY+  -> Fork (PatchSet p) (FL (PatchInfoAnd p)) (FL (PatchInfoAnd p)) Origin wX wY+findCommon us them =+  case taggedIntersection us them of+    Fork common us' them' ->+      case findCommonRL us' them' of+        Fork more_common us'' them'' ->+          Fork (PatchSet common more_common) (reverseRL us'') (reverseRL them'')++findCommonWithThem+  :: Commute p+  => PatchSet p Origin wX+  -> PatchSet p Origin wY+  -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wX findCommonWithThem us them =-    with_partial_intersection us them $-    \common us' them' ->-        case partitionFL ((`elem` mapRL info them') . info) $ reverseRL us' of-          _ :> bad@(_:>:_) :> _ -> bug $ "Failed to commute common patches:\n" ++-                                   (renderString $ vcat $ mapRL (humanFriendly . info) $ reverseFL bad)-          common2 :> _nilfl :> only_ours -> PatchSet (reverseFL common2) common :> unsafeCoerceP only_ours+  case taggedIntersection us them of+    Fork common us' them' ->+      case findCommonWithThemRL us' them' of+        more_common :> us'' ->+          PatchSet common more_common :> reverseRL us'' -findUncommon :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y)-                         -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) C(x y)+findUncommon+  :: Commute p+  => PatchSet p Origin wX+  -> PatchSet p Origin wY+  -> (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY findUncommon us them =-  case findCommonWithThem us them of-    _common :> us' -> case findCommonWithThem them us of-      _ :> them' -> unsafeCoercePStart us' :\/: them'+  case taggedIntersection us them of+    Fork _ us' them' ->+      case (findCommonWithThemRL us' them', findCommonWithThemRL them' us') of+        (_ :> us'', _ :> them'') ->+          reverseRL us'' :\/: unsafeCoercePStart (reverseRL them'') -countUsThem :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) -> (Int, Int)+countUsThem :: Commute p+            => PatchSet p Origin wX+            -> PatchSet p Origin wY+            -> (Int, Int) countUsThem us them =-    with_partial_intersection us them $-    \_ us' them' -> let uu = mapRL info us'-                        tt = mapRL info them'-                    in (length $ uu \\ tt, length $ tt \\ uu)--mergeThem :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y)-           -> Sealed (FL (PatchInfoAnd p) C(x))-mergeThem us them =-   with_partial_intersection us them $-    \_ us' them' -> merge2FL (reverseRL us') (reverseRL them')--newsetIntersection :: RepoPatch p => [SealedPatchSet p C(start)] -> SealedPatchSet p C(start)-newsetIntersection [] = seal $ PatchSet NilRL NilRL-newsetIntersection [x] = x-newsetIntersection (Sealed y:ys) =-    case newsetIntersection ys of-    Sealed z -> with_partial_intersection y z $-                \common a b ->-                    case mapRL info a `intersect` mapRL info b of-                    morecommon ->-                        case partitionRL (\e -> info e `notElem` morecommon) a of-                        commonps :> _ -> seal $ PatchSet commonps common+    case taggedIntersection us them of+        Fork _ us' them' -> let uu = mapRL info us'+                                tt = mapRL info them' in+                            (length $ uu \\ tt, length $ tt \\ uu) -newsetUnion :: RepoPatch p => [SealedPatchSet p C(start)] -> SealedPatchSet p C(start)-newsetUnion [] = seal $ PatchSet NilRL NilRL-newsetUnion [x] = x-newsetUnion (Sealed y@(PatchSet psy tsy):Sealed y2:ys) =-    case mergeThem y y2 of-    Sealed p2 -> newsetUnion $ seal (PatchSet (reverseFL p2+<+psy) tsy) : ys+patchSetMerge+  :: (Commute p, Merge p)+  => PatchSet p Origin wX+  -> PatchSet p Origin wY+  -> (FL (PatchInfoAnd p) :/\: FL (PatchInfoAnd p)) wX wY+patchSetMerge us them = merge (findUncommon us them) --- | Merge two FLs (say L and R), starting in a common context. The result is a--- FL starting in the original end context of L, going to a new context that is--- the result of applying all patches from R on top of patches from L.------ While this function is similar to 'mergeFL', there are three important--- differences to keep in mind:------ * 'mergeFL' does not correctly deal with duplicate patches whereas this one---   does---   (Question from Eric Kow: in what sense? Why not fix the mergeFL instance?)------ * 'mergeFL' returns both paths of the merge diamond, but this version only---   returns one, so you'd better choose the order carefully, eg.---   (@merge2FL l r@)------ * The conventional order we use in this function is reversed from---   'mergeFL' (so @mergeFL r l@ vs. @merge2FL l r@. This does not---   matter so much for the former since you get both paths.---   (Question from Eric Kow: should we flip merge2FL for more uniformity in---    the code?)-merge2FL :: RepoPatch p => FL (PatchInfoAnd p) C(x y)-         -> FL (PatchInfoAnd p) C(x z)-         -> Sealed (FL (PatchInfoAnd p) C(y))-merge2FL _ NilFL = seal NilFL-merge2FL NilFL ys = seal ys-merge2FL xs (y:>:ys) | Just xs' <- fastRemoveFL y xs = merge2FL xs' ys-merge2FL (x:>:xs) ys | Just ys' <- fastRemoveFL x ys = merge2FL xs ys'-                     | otherwise = case mergeFL (x :\/: ys) of-                                     ys' :/\: _ -> merge2FL xs ys'+-- | A 'PatchSet' consisting of the patches common to all input 'PatchSet's.+-- This is *undefined* for the empty list since intersection of 'PatchSet's+-- has no unit.+patchSetIntersection+  :: Commute p => [SealedPatchSet p Origin] -> SealedPatchSet p Origin+patchSetIntersection = foldr1 go+  where+    go (Sealed ps) (Sealed acc) =+      case findCommonWithThem ps acc of+        common :> _ -> seal common -simpleTag :: PatchInfo -> PatchSet p C(start x) -> Maybe (PatchSet p C(start x))-simpleTag t0 (PatchSet ps (Tagged t h pst :<: ts))-    | t0 == info t = Just $ PatchSet ps (Tagged t h pst :<: ts)-    | otherwise = do PatchSet ps' ts' <- simpleTag t0 (PatchSet (t:<:pst) ts)-                     Just $ PatchSet (ps +<+ ps') ts'-simpleTag _ _ = Nothing+-- | A 'PatchSet' consisting of the patches contained in any of the input+-- 'PatchSet's. The input 'PatchSet's are merged in left to right order, left+-- patches first.+patchSetUnion+  :: (Commute p, Merge p) => [SealedPatchSet p Origin] -> SealedPatchSet p Origin+-- You may consider simplifying this to a plain foldr'. However, this is+-- extremely inefficient because we have to build everything up from an empty+-- PatchSet. In principle this could be avoided by merging right patches first,+-- but then we get a failure in the conflict-chain-resolution test for darcs-1.+patchSetUnion [] = seal emptyPatchSet+patchSetUnion [x] = x+patchSetUnion xs = foldl1' go xs+  where+    go (Sealed acc) (Sealed ps) =+      case patchSetMerge acc ps of+        ps_only :/\: _ -> seal $ appendPSFL acc ps_only -areUnrelatedRepos :: RepoPatch p => PatchSet p C(start x) -> PatchSet p C(start y) -> Bool+-- | Two 'PatchSet's are considered unrelated unless they share a common+-- inventory, or either 'PatchSet' has less than 5 patches, or they have at+-- least one patch in common.+areUnrelatedRepos+  :: Commute p => PatchSet p Origin wX -> PatchSet p Origin wY -> Bool areUnrelatedRepos us them =-    with_partial_intersection us them checkit-    where checkit (Tagged _ _ _ :<: _) _ _ = False-          checkit _ u t | t `isShorterThanRL` 5 = False-                        | u `isShorterThanRL` 5 = False-                        | otherwise = null $ intersect (mapRL info u) (mapRL info t)---- | Remove a patch from FL, using PatchInfo equality. The result is Just--- whenever the patch has been found and removed. If the patch is not present--- in the sequence at all or any commutation fails, we get Nothing. First two--- cases are optimisations for the common cases where the head of the list is--- the patch to remove, or the patch is not there at all.-fastRemoveFL :: RepoPatch p => PatchInfoAnd p C(x y) -> FL (PatchInfoAnd p) C(x z)-             -> Maybe (FL (PatchInfoAnd p) C(y z))-fastRemoveFL _ NilFL = Nothing-fastRemoveFL a (b:>:bs) | IsEq <- a =\/= b = Just bs-                        | info a `notElem` mapFL info bs = Nothing-fastRemoveFL a (b:>:bs) = do a' :> bs' <- pullout NilRL bs-                             a'' :> b' <- commute (b :> a')-                             IsEq <- return (a'' =\/= a)-                             Just (b':>:bs')-    where i = info a-          pullout :: RepoPatch p => RL (PatchInfoAnd p) C(a0 a)-                  -> FL (PatchInfoAnd p) C(a b)-                  -> Maybe ((PatchInfoAnd p :> FL (PatchInfoAnd p)) C(a0 b))-          pullout _ NilFL = Nothing-          pullout acc (x:>:xs) | info x == i = do x' :> acc' <- commuteRL (acc :> x)-                                                  Just (x' :> reverseRL acc' +>+ xs)-                               | otherwise = pullout (x:<:acc) xs+  case taggedIntersection us them of+    Fork NilRL u t+      | t `isShorterThanRL` 5 -> False+      | u `isShorterThanRL` 5 -> False+      | otherwise -> null $ intersect (mapRL info u) (mapRL info t)+    _ -> False -fastRemoveRL :: RepoPatch p => PatchInfoAnd p C(y z) -> RL (PatchInfoAnd p) C(x z)-             -> Maybe (RL (PatchInfoAnd p) C(x y))-fastRemoveRL _ NilRL = Nothing-fastRemoveRL a (b:<:bs) | IsEq <- a =/\= b = Just bs-                        | info a `notElem` mapRL info bs = Nothing-fastRemoveRL a (b:<:bs) = do bs' :> a' <- pullout NilFL bs-                             b' :> a'' <- commute (a' :> b)-                             IsEq <- return (a'' =/\= a)-                             Just (b':<:bs')-    where i = info a-          pullout :: RepoPatch p => FL (PatchInfoAnd p) C(b c)-                  -> RL (PatchInfoAnd p) C(a b)-                  -> Maybe ((RL (PatchInfoAnd p) :> PatchInfoAnd p) C(a c))-          pullout _ NilRL = Nothing-          pullout acc (x:<:xs) | info x == i = do acc' :> x' <--                                                      either (const Nothing)-                                                      Just (commuteFLorComplain (x :> acc))-                                                  Just (reverseFL acc' +<+ xs :> x')-                               | otherwise = pullout (x:>:acc) xs+-- | Split a 'PatchSet' at the latest clean tag. The left part is what comes+-- before the tag, the right part is the tag and its non-dependencies.+contextPatches :: PatchSet p wX wY+               -> (PatchSet p :> RL (PatchInfoAnd p)) wX wY+contextPatches = patchSetSplit . slightlyOptimizePatchset
− src/Darcs/Patch/Dummy.hs 
@@ -1,29 +0,0 @@-{-# OPTIONS_GHC -fno-warn-missing-methods #-}-{-# LANGUAGE EmptyDataDecls #-}-module Darcs.Patch.Dummy ( DummyPatch ) where--import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Patchy-    ( Patchy, ShowPatch, Invert, Commute, Apply(..), PatchInspect-    , ReadPatch )-import Darcs.Patch.Show ( ShowPatchBasic )-import Darcs.Witnesses.Eq ( MyEq )-import Storage.Hashed.Tree( Tree )--#include "gadts.h"--data DummyPatch C(x y)--instance IsHunk DummyPatch-instance PatchListFormat DummyPatch-instance MyEq DummyPatch-instance Invert DummyPatch-instance PatchInspect DummyPatch-instance ReadPatch DummyPatch-instance ShowPatchBasic DummyPatch-instance ShowPatch DummyPatch-instance Commute DummyPatch-instance Apply DummyPatch where-  type ApplyState DummyPatch = Tree-instance Patchy DummyPatch
src/Darcs/Patch/Effect.hs view
@@ -1,29 +1,25 @@+{-# OPTIONS_GHC -fno-warn-unrecognised-pragmas #-} module Darcs.Patch.Effect ( Effect(..) ) where -import Darcs.Patch.Prim.Class ( PrimOf )+import Darcs.Prelude -import Darcs.Witnesses.Ordered-    ( FL(..), RL(..), reverseFL, reverseRL-    , concatFL, concatRL, mapFL_FL, mapRL_RL+import Darcs.Patch.FromPrim ( PrimOf )++import Darcs.Patch.Witnesses.Ordered+    ( FL(..), RL(..), reverseRL+    , concatFL, mapFL_FL     ) -#include "gadts.h" --- | Patches whose concrete effect which can be expressed as a list of+-- | Patches whose concrete effect can be expressed as a list of --   primitive patches. -- --   A minimal definition would be either of @effect@ or @effectRL@. class Effect p where-    effect :: p C(x y) -> FL (PrimOf p) C(x y)-    effect = reverseRL . effectRL-    effectRL :: p C(x y) -> RL (PrimOf p) C(x y)-    effectRL = reverseFL . effect+    effect :: p wX wY -> FL (PrimOf p) wX wY  instance Effect p => Effect (FL p) where-    effect p = concatFL $ mapFL_FL effect p-    effectRL p = concatRL $ mapRL_RL effectRL $ reverseFL p+    effect = concatFL . mapFL_FL effect  instance Effect p => Effect (RL p) where-    effect p = concatFL $ mapFL_FL effect $ reverseRL p-    effectRL p = concatRL $ mapRL_RL effectRL p-+    effect = effect . reverseRL
src/Darcs/Patch/FileHunk.hs view
@@ -1,27 +1,48 @@ module Darcs.Patch.FileHunk-    ( FileHunk(..), IsHunk(..), showFileHunk+    ( FileHunk(..), IsHunk(..), showFileHunk, showContextFileHunk     )     where -import Darcs.Patch.FileName ( FileName )+import Darcs.Prelude++import Darcs.Patch.Apply ( ObjectIdOfPatch ) import Darcs.Patch.Format ( FileNameFormat )-import Darcs.Patch.Show ( formatFileName )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Object ( ObjectId(..) ) -import Printer+import Darcs.Util.Printer     ( Doc, blueText, text, lineColor, vcat, userchunkPS     , prefix, ($$), (<+>), Color(Cyan, Magenta) )  import qualified Data.ByteString as B ( ByteString ) -#include "gadts.h" -data FileHunk C(x y) = FileHunk !FileName !Int [B.ByteString] [B.ByteString]+data FileHunk oid wX wY = FileHunk oid !Int [B.ByteString] [B.ByteString] +type role FileHunk nominal nominal nominal+ class IsHunk p where-    isHunk :: p C(x y) -> Maybe (FileHunk C(x y))+    isHunk :: p wX wY -> Maybe (FileHunk (ObjectIdOfPatch p) wX wY) -showFileHunk :: FileNameFormat -> FileHunk C(x y) -> Doc+showFileHunk :: ObjectId oid => FileNameFormat -> FileHunk oid wX wY -> Doc showFileHunk x (FileHunk f line old new) =-           blueText "hunk" <+> formatFileName x f <+> text (show line)+           blueText "hunk" <+> formatObjectId x f <+> text (show line)         $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS old))         $$ lineColor Cyan    (prefix "+" (vcat $ map userchunkPS new))++showContextFileHunk+  :: ObjectId oid+  => FileNameFormat+  -> [B.ByteString]+  -> FileHunk oid wB wC+  -> [B.ByteString]+  -> Doc+showContextFileHunk fmt pre (FileHunk f l o n) post =+  blueText "hunk" <+> formatObjectId fmt f <+> text (show l) $$+  prefix " " (vcat $ map userchunkPS pre) $$+  lineColor Magenta (prefix "-" (vcat $ map userchunkPS o)) $$+  lineColor Cyan (prefix "+" (vcat $ map userchunkPS n)) $$+  prefix " " (vcat $ map userchunkPS post)++instance Invert (FileHunk oid) where+    invert (FileHunk path line old new) = FileHunk path line new old
− src/Darcs/Patch/FileName.hs 
@@ -1,161 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- | FileName is an abstract type intended to facilitate the input and output of--- unicode filenames.-module Darcs.Patch.FileName ( FileName( ),-                              fp2fn, fn2fp,-                              fn2ps, ps2fn,-                              niceps2fn, fn2niceps,-                              breakOnDir, normPath, ownName, superName,-                              movedirfilename,-                              encodeWhite, decodeWhite,-                              (///),-                              breakup, isParentOrEqOf-                            ) where--import Data.Char ( isSpace, chr, ord )-import Data.List ( stripPrefix )-import ByteStringUtils ( packStringToUTF8, unpackPSFromUTF8 )-import qualified Data.ByteString.Char8 as BC (unpack, pack)-import qualified Data.ByteString       as B  (ByteString)--newtype FileName = FN FilePath deriving ( Eq, Ord )--instance Show FileName where-   showsPrec d (FN fp) = showParen (d > appPrec) $ showString "fp2fn " . showsPrec (appPrec + 1) fp-      where appPrec = 10--{-# INLINE fp2fn #-}-fp2fn :: FilePath -> FileName-fp2fn fp = FN fp--{-# INLINE fn2fp #-}-fn2fp :: FileName -> FilePath-fn2fp (FN fp) = fp--{-# INLINE niceps2fn #-}-niceps2fn :: B.ByteString -> FileName-niceps2fn = FN . decodeWhite . BC.unpack--{-# INLINE fn2niceps #-}-fn2niceps :: FileName -> B.ByteString-fn2niceps (FN fp) = BC.pack $ encodeWhite fp--{-# INLINE fn2ps #-}-fn2ps :: FileName -> B.ByteString-fn2ps (FN fp) = packStringToUTF8 $ encodeWhite fp--{-# INLINE ps2fn #-}-ps2fn :: B.ByteString -> FileName-ps2fn ps = FN $ decodeWhite $ unpackPSFromUTF8 ps---- | 'encodeWhite' translates whitespace in filenames to a darcs-specific---   format (numerical representation according to 'ord' surrounded by---   backslashes).  Note that backslashes are also escaped since they are used---   in the encoding.------   > encodeWhite "hello there" == "hello\32\there"---   > encodeWhite "hello\there" == "hello\92\there"-encodeWhite :: FilePath -> String-encodeWhite (c:cs) | isSpace c || c == '\\' =-    '\\' : (show $ ord c) ++ "\\" ++ encodeWhite cs-encodeWhite (c:cs) = c : encodeWhite cs-encodeWhite [] = []---- | 'decodeWhite' interprets the Darcs-specific \"encoded\" filenames---   produced by 'encodeWhite'------   > decodeWhite "hello\32\there"  == "hello there"---   > decodeWhite "hello\92\there"  == "hello\there"---   > decodeWhite "hello\there"   == error "malformed filename"-decodeWhite :: String -> FilePath-decodeWhite ('\\':cs) =-    case break (=='\\') cs of-    (theord, '\\':rest) ->-        chr (read theord) : decodeWhite rest-    _ -> error "malformed filename"-decodeWhite (c:cs) = c: decodeWhite cs-decodeWhite "" = ""--ownName :: FileName -> FileName-ownName (FN f) =  case breakLast '/' f of Nothing -> FN f-                                          Just (_,f') -> FN f'-superName :: FileName -> FileName-superName fn = case normPath fn of-                FN f -> case breakLast '/' f of-                        Nothing -> FN "."-                        Just (d,_) -> FN d-breakOnDir :: FileName -> Maybe (FileName,FileName)-breakOnDir (FN p) = case breakFirst '/' p of-                      Nothing -> Nothing-                      Just (d,f) | d == "." -> breakOnDir $ FN f-                                 | otherwise -> Just (FN d, FN f)-normPath :: FileName -> FileName -- remove "./"-normPath (FN p) = FN $ repath $ dropDotdot $ breakup p--repath :: [String] -> String-repath [] = ""-repath [f] = f-repath (d:p) = d ++ "/" ++ repath p--dropDotdot :: [String] -> [String]-dropDotdot ("":p) = dropDotdot p-dropDotdot (".":p) = dropDotdot p-dropDotdot ("..":p) = ".." : (dropDotdot p)-dropDotdot (_:"..":p) = dropDotdot p-dropDotdot (d:p) = case dropDotdot p of-                    ("..":p') -> p'-                    p' -> d : p'-dropDotdot [] = []---- | Split a file path at the slashes-breakup :: String -> [String]-breakup p = case break (=='/') p of-            (d,"") -> [d]-            (d,p') -> d : breakup (tail p')--breakFirst :: Char -> String -> Maybe (String,String)-breakFirst c l = bf [] l-    where bf a (r:rs) | r == c = Just (reverse a,rs)-                      | otherwise = bf (r:a) rs-          bf _ [] = Nothing-breakLast :: Char -> String -> Maybe (String,String)-breakLast c l = case breakFirst c (reverse l) of-                Nothing -> Nothing-                Just (a,b) -> Just (reverse b, reverse a)--(///) :: FileName -> FileName -> FileName-(FN "")///b = normPath b-a///b = normPath $ fp2fn $ fn2fp a ++ "/" ++ fn2fp b--isParentOrEqOf :: FileName -> FileName -> Bool-isParentOrEqOf fn1 fn2 = case stripPrefix (fn2fp fn1) (fn2fp fn2) of-    Just ('/' : _) -> True-    Just [] -> True-    _ -> False--movedirfilename :: FileName -> FileName -> FileName -> FileName-movedirfilename old new name =-    if name' == old'-        then new-        else case stripPrefix old' name' of-            Just rest@('/':_) -> fp2fn $ "./" ++ new' ++ rest-            _ -> name-        where old' = fn2fp $ normPath old-              new' = fn2fp $ normPath new-              name' = fn2fp $ normPath name
src/Darcs/Patch/Format.hs view
@@ -1,32 +1,39 @@ module Darcs.Patch.Format-    ( PatchListFormat(..), ListFormat(..)-    , FileNameFormat(..) )-    where+    ( PatchListFormat(..)+    , ListFormat(..)+    , FileNameFormat(..)+    ) where -#include "gadts.h"+import Darcs.Prelude --- | Showing and reading lists of patches This class allows us to control how+-- | Showing and reading lists of patches. This class allows us to control how -- lists of patches are formatted on disk. For legacy reasons V1 patches have -- their own special treatment (see 'ListFormat'). Other patch types use the -- default format which just puts them in a sequence without separators or any -- prelude/epilogue. ----- This means that 'FL (FL p)' etc would be ambiguous, so there are no instances--- for 'FL p' or other list types.+-- This means that 'FL (FL p)' etc would be ambiguous, so there are no+-- instances for 'FL p' or other list types. class PatchListFormat p where-  patchListFormat :: ListFormat p-  patchListFormat = ListFormatDefault+    patchListFormat :: ListFormat p+    patchListFormat = ListFormatDefault  -- | This type is used to tweak the way that lists of 'p' are shown for a given--- 'Patch' type 'p'. It is needed to maintain backwards compatibility for V1 and--- V2 patches.-data ListFormat (p :: PATCHKIND)-  = ListFormatDefault -- ^ Show and read lists without braces.-  | ListFormatV1      -- ^ Show lists with a single layer of braces around the outside,-                      -- except for singletons which have no braces.-                      -- Read with arbitrary nested braces and parens and flatten them out.-  | ListFormatV2      -- ^ Show lists without braces-                      -- Read with arbitrary nested parens and flatten them out.+-- 'Patch' type 'p'. It is needed to maintain backwards compatibility for V1+-- and V2 patches.+data ListFormat (p :: (* -> * -> *))+    = ListFormatDefault -- ^ Show and read lists without braces.+    | ListFormatV1      -- ^ Show lists with a single layer of braces around+                        -- the outside, except for singletons which have no+                        -- braces. Read with arbitrary nested braces and parens+                        -- and flatten them out.+    | ListFormatV2      -- ^ Show lists without braces. Read with arbitrary+                        -- nested parens and flatten them out.+    | ListFormatV3      -- ^ Temporary hack to disable use of showContextSeries+                        -- for darcs-3 patches, until I find out how to fix this. -data FileNameFormat = OldFormat-                    | NewFormat+data FileNameFormat+    = FileNameFormatV1      -- ^ on-disk format for V1 patches+    | FileNameFormatV2      -- ^ on-disk format for V2 patches+    | FileNameFormatDisplay -- ^ display format+    deriving (Eq, Show)
+ src/Darcs/Patch/FromPrim.hs view
@@ -0,0 +1,38 @@+module Darcs.Patch.FromPrim+    ( PrimPatchBase(..)+    , FromPrim(..)+    , ToPrim(..)+    , ToFromPrim+    ) where++import Darcs.Prelude++import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Patch.Witnesses.Ordered ( FL, RL, mapFL_FL )+import Darcs.Patch.Ident ( PatchId )+import Darcs.Patch.Info ( PatchInfo )++class PrimPatch (PrimOf p) => PrimPatchBase p where+    type PrimOf (p :: (* -> * -> *)) :: (* -> * -> *)++instance PrimPatchBase p => PrimPatchBase (FL p) where+    type PrimOf (FL p) = PrimOf p++instance PrimPatchBase p => PrimPatchBase (RL p) where+    type PrimOf (RL p) = PrimOf p++class FromPrim p where+    fromAnonymousPrim :: PrimOf p wX wY -> p wX wY+    fromPrim :: PatchId p -> PrimOf p wX wY -> p wX wY+    fromPrims :: PatchInfo -> FL (PrimOf p) wX wY -> FL p wX wY++    default fromPrim :: (PatchId p ~ ()) => PatchId p -> PrimOf p wX wY -> p wX wY+    fromPrim () = fromAnonymousPrim++    default fromPrims :: (PatchId p ~ ()) => PatchInfo -> FL (PrimOf p) wX wY -> FL p wX wY+    fromPrims _ = mapFL_FL (fromPrim ())++class ToPrim p where+    toPrim :: p wX wY -> Maybe (PrimOf p wX wY)++type ToFromPrim p = (FromPrim p, ToPrim p)
+ src/Darcs/Patch/Ident.hs view
@@ -0,0 +1,317 @@+module Darcs.Patch.Ident+    ( Ident(..)+    , SignedIdent+    , PatchId+    , (=\^/=)+    , (=/^\=)+    , SignedId(..)+    , StorableId(..)+    , fastRemoveFL+    , fastRemoveRL+    , fastRemoveSubsequenceRL+    , findCommonFL+    , findCommonRL+    , findCommonWithThemFL+    , findCommonWithThemRL+    , commuteToPrefix+    -- * Properties+    , prop_identInvariantUnderCommute+    , prop_sameIdentityImpliesCommutable+    , prop_equalImpliesSameIdentity+    , prop_sameIdentityImpliesEqual+    ) where++import qualified Data.Set as S++import Darcs.Prelude++import Darcs.Patch.Commute ( Commute, commute, commuteFL, commuteRL )+import Darcs.Patch.Permutations ( partitionFL', partitionRL' )+import Darcs.Patch.Show ( ShowPatchFor )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..), isIsEq )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..)+    , (:\/:)(..)+    , FL(..)+    , RL(..)+    , Fork(..)+    , (+<<+)+    , (+>>+)+    , mapFL+    , mapRL+    , reverseFL+    , reverseRL+    )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd, unsafeCoercePStart )++import Darcs.Util.Parser ( Parser )+import Darcs.Util.Printer ( Doc )++-- | The reason this is not associated to class 'Ident' is that for technical+-- reasons we want to be able to define type instances for patches that don't+-- have an identity and therefore cannot be lawful members of class 'Ident'.+type family PatchId (p :: * -> * -> *)++{- | Class of patches that have an identity/name.++Patches with an identity give rise to the notion of /nominal equality/,+expressed by the operators '=\^/=' and '=/^\='.++Laws:++[/ident-commute/]++    Patch identity must be invariant under commutation:++    prop> 'commute' (p :> _) == 'Just' (_ :> p') => 'ident' p == 'ident' p'++    and thus (via symmetry of 'commute'):++    prop> 'commute' (_ :> q) == 'Just' (q' :> _) => 'ident' q == 'ident' q'++    Conversely, patches with the same identity result from a series of+    'commute's:++    prop> 'ident' p == 'ident' p' => exists qs, qs' :: FL p. 'commuteFL' (p :> qs) == 'Just' (qs' :> p')++[/ident-compare/]++    In general, comparing patches via their identity is+    weaker than (semantic) equality:++    prop> 'unsafeCompare' p q => 'ident' p == 'ident' q++    However, if the patches have a common context, then semantic and nominal+    equality should coincide, up to internal re-ordering:++    prop> p '=\~/=' q  <=> p '=\^/=' q+    prop> p '=/~\=' q  <=> p '=/^\=' q++    (Technical note: equality up to internal re-ordering is currently only+    defined for 'FL's, but it should be obvious how to generalize it.)++Taken together, these laws express the assumption that recording a patch+gives it a universally unique identity.++Note that violations of this universal property are currently not detected+in a reliable way. Fixing this is possible but far from easy.++-}+class Ord (PatchId p) => Ident p where+  ident :: p wX wY -> PatchId p++type instance PatchId (FL p) = S.Set (PatchId p)+type instance PatchId (RL p) = S.Set (PatchId p)+type instance PatchId (p :> p) = S.Set (PatchId p)++instance Ident p => Ident (FL p) where+  ident = S.fromList . mapFL ident++instance Ident p => Ident (RL p) where+  ident = S.fromList . mapRL ident++instance Ident p => Ident (p :> p) where+  ident (p :> q) = S.fromList [ident p, ident q]++-- | Nominal equality for patches with an identity in the same context. Usually+-- quite a bit faster than structural equality.+(=\^/=) :: Ident p => p wA wB -> p wA wC -> EqCheck wB wC+p =\^/= q = if ident p == ident q then unsafeCoercePEnd IsEq else NotEq++(=/^\=) :: Ident p => p wA wC -> p wB wC -> EqCheck wA wB+p =/^\= q = if ident p == ident q then unsafeCoercePStart IsEq else NotEq+++{- | Signed identities.++Like for class 'Invert', we require that 'invertId' is self-inverse:++prop> 'invertId' . 'invertId' = 'id'++We also require that inverting changes the sign:++prop> 'positiveId' . 'invertId' = 'not' . 'positiveId'++Side remark: in mathematical terms, these properties can be expressed by+stating that 'invertId' is an involution and that 'positiveId' is a+"homomorphism of sets with an involution" (there is no official term for+this) from @a@ to the simplest non-trivial set with involution, namely+'Bool' with the involution 'not'.+-}+class Ord a => SignedId a where+  positiveId :: a -> Bool+  invertId :: a -> a++{- | Constraint for patches that have an identity that is signed,+     i.e. can be positive (uninverted) or negative (inverted).++Provided that an instance 'Invert' exists, inverting a patch+inverts its identity:++prop> 'ident' ('invert' p) = 'invertId' ('ident' p)++-}+type SignedIdent p = (Ident p, SignedId (PatchId p))+++{- | Storable identities.++The methods here can be used to help implement ReadPatch and ShowPatch+for a patch type containing the identity.++As with all Read/Show pairs, We expect that the output of+@showId ForStorage x@ can be parsed by 'readId' to produce @x@:++prop> 'parse' 'readId' . 'renderPS' . 'showId' 'ForStorage' == 'id'++-}+class StorableId a where+  readId :: Parser a+  showId :: ShowPatchFor -> a -> Doc++{-# INLINABLE fastRemoveFL #-}+-- | Remove a patch from an FL of patches with an identity. The result is+-- 'Just' whenever the patch has been found and removed and 'Nothing'+-- otherwise. If the patch is not found at the head of the sequence we must+-- first commute it to the head before we can remove it.+-- +-- We assume that this commute always succeeds. This is justified because+-- patches are created with a (universally) unique identity, implying that if+-- two patches have the same identity, then they have originally been the same+-- patch; thus being at a different position must be due to commutation,+-- meaning we can commute it back.+--+-- For patch types that define semantic equality via nominal equality, this is+-- only faster than 'removeFL' if the patch does not occur in the sequence,+-- otherwise we have to perform the same number of commutations.+fastRemoveFL :: forall p wX wY wZ. (Commute p, Ident p)+             => p wX wY+             -> FL p wX wZ+             -> Maybe (FL p wY wZ)+fastRemoveFL a bs+  | i `notElem` mapFL ident bs = Nothing+  | otherwise = do+      _ :> bs' <- pullout NilRL bs+      Just (unsafeCoercePStart bs')+  where+    i = ident a+    pullout :: RL p wA wB -> FL p wB wC -> Maybe ((p :> FL p) wA wC)+    pullout _ NilFL = Nothing+    pullout acc (x :>: xs)+      | ident x == i = do+          x' :> acc' <- commuteRL (acc :> x)+          Just (x' :> acc' +>>+ xs)+      | otherwise = pullout (acc :<: x) xs++-- | Same as 'fastRemoveFL' only for 'RL'.+fastRemoveRL :: forall p wX wY wZ. (Commute p, Ident p)+             => p wY wZ+             -> RL p wX wZ+             -> Maybe (RL p wX wY)+fastRemoveRL a bs+  | i `notElem` mapRL ident bs = Nothing+  | otherwise = do+      bs' :> _ <- pullout bs NilFL+      Just (unsafeCoercePEnd bs')+  where+    i = ident a+    pullout :: RL p wA wB -> FL p wB wC -> Maybe ((RL p :> p) wA wC)+    pullout NilRL _ = Nothing+    pullout (xs :<: x) acc+      | ident x == i = do+          acc' :> x' <- commuteFL (x :> acc)+          Just (xs +<<+ acc' :> x')+      | otherwise = pullout xs (x :>: acc)++fastRemoveSubsequenceRL :: (Commute p, Ident p)+                        => RL p wY wZ+                        -> RL p wX wZ+                        -> Maybe (RL p wX wY)+fastRemoveSubsequenceRL NilRL ys = Just ys+fastRemoveSubsequenceRL (xs :<: x) ys =+  fastRemoveRL x ys >>= fastRemoveSubsequenceRL xs++-- | Find the common and uncommon parts of two lists that start in a common+-- context, using patch identity for comparison. Of the common patches, only+-- one is retained, the other is discarded.+findCommonFL :: (Commute p, Ident p)+             => FL p wX wY+             -> FL p wX wZ+             -> Fork (FL p) (FL p) (FL p) wX wY wZ+findCommonFL xs ys =+  case findCommonWithThemFL xs ys of+    cxs :> xs' ->+      case findCommonWithThemFL ys xs of+        cys :> ys' ->+          case cxs =\^/= cys of+            NotEq -> error "common patches aren't equal"+            IsEq -> Fork cxs xs' ys'++findCommonWithThemFL+  :: (Commute p, Ident p) => FL p wX wY -> FL p wX wZ -> (FL p :> FL p) wX wY+findCommonWithThemFL xs ys =+  case partitionFL' ((`S.member` yids) . ident) NilRL NilRL xs of+    cxs :> NilRL :> xs' -> cxs :> reverseRL xs'+    _ -> error "failed to commute common patches"+  where+    yids = S.fromList (mapFL ident ys)++findCommonRL :: (Commute p, Ident p)+             => RL p wX wY+             -> RL p wX wZ+             -> Fork (RL p) (RL p) (RL p) wX wY wZ+findCommonRL xs ys =+  case findCommonWithThemRL xs ys of+    cxs :> xs' ->+      case findCommonWithThemRL ys xs of+        cys :> ys' ->+          case cxs =\^/= cys of+            NotEq -> error "common patches aren't equal"+            IsEq -> Fork cxs xs' ys'++findCommonWithThemRL+  :: (Commute p, Ident p) => RL p wX wY -> RL p wX wZ -> (RL p :> RL p) wX wY+findCommonWithThemRL xs ys =+  case partitionRL' (not . (`S.member` yids) . ident) xs of+    cxs :> NilFL :> xs' -> reverseFL cxs :> xs'+    _ -> error "failed to commute common patches"+  where+    yids = S.fromList (mapRL ident ys)++-- | Try to commute all patches matching any of the 'PatchId's in the set to the+-- head of an 'FL', i.e. backwards in history.+commuteToPrefix :: (Commute p, Ident p)+                => S.Set (PatchId p) -> FL p wX wY -> Maybe ((FL p :> RL p) wX wY)+commuteToPrefix is ps+  | prefix :> NilRL :> rest <-+      partitionFL' ((`S.member` is) . ident) NilRL NilRL ps = Just (prefix :> rest)+  | otherwise = Nothing++prop_identInvariantUnderCommute :: (Commute p, Ident p)+                                => (p :> p) wX wY -> Maybe Bool+prop_identInvariantUnderCommute (p :> q) =+  case commute (p :> q) of+    Just (q' :> p') -> Just $ ident p == ident p' && ident q == ident q'+    Nothing -> Nothing++prop_sameIdentityImpliesCommutable :: (Commute p, Eq2 p, Ident p)+                                   => (p :\/: (RL p :> p)) wX wY -> Maybe Bool+prop_sameIdentityImpliesCommutable (p :\/: (ps :> q))+  | ident p == ident q =+      case commuteRL (ps :> q) of+        Just (p' :> _) -> Just $ isIsEq (p =\/= p')+        Nothing -> Just False+  | otherwise = Nothing++prop_equalImpliesSameIdentity :: (Eq2 p, Ident p)+                              => p wA wB -> p wC wD -> Maybe Bool+prop_equalImpliesSameIdentity p q+  | p `unsafeCompare` q = Just $ ident p == ident q+  | otherwise = Nothing++-- Note the assumption of coinciding start states here!+prop_sameIdentityImpliesEqual :: (Eq2 p, Ident p)+                              => (p :\/: p) wX wY -> Maybe Bool+prop_sameIdentityImpliesEqual (p :\/: q)+  | ident p == ident q = Just $ isIsEq $ p =\/= q+  | otherwise = Nothing
+ src/Darcs/Patch/Index/Monad.hs view
@@ -0,0 +1,148 @@+-- Copyright (C) 2009 Benedikt Schmidt+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,++-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE MultiParamTypeClasses #-}++module Darcs.Patch.Index.Monad+    ( withPatchMods+    , applyToFileMods+    , FileMod(..)+    ) where++import Darcs.Prelude++import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) )+import Control.Monad ( when, forM_ )+import Control.Monad.Catch ( MonadThrow(..), SomeException )+import Control.Monad.State ( MonadState, StateT, execStateT, gets, modify )+import Control.Arrow+import Darcs.Util.Path ( AnchoredPath, anchorPath, movedirfilename, isPrefix )+import qualified Data.Set as S+import Data.Set ( Set )+import Darcs.Util.Tree (Tree)++-- | This is used to track changes to files+data FileMod a+  = PTouch a+  | PCreateFile a+  | PCreateDir a+  | PRename a a+  | PRemove a+  | PDuplicateTouch a+    -- ^ this is used for duplicate patches that don't+    --   have any effect, but we still want to keep+    --   track of them+  deriving (Show, Eq, Functor)++type FileModState = (Set AnchoredPath, [FileMod AnchoredPath])++newtype FileModMonad a =+  FMM (StateT FileModState (Either SomeException) a)+  deriving ( Functor+           , Applicative+           , Monad+           , MonadThrow+           , MonadState FileModState+           )++withPatchMods :: FileModMonad a+              -> Set AnchoredPath+              -> FileModState+withPatchMods (FMM m) fps =+  second reverse $+    case execStateT m (fps,[]) of+      Left e -> error (show e)+      Right r -> r++-- These instances are defined to be used only with+-- apply.+instance ApplyMonad Tree FileModMonad where+    readFilePS = error "readFilePS FileModMonad"++instance ApplyMonadTree FileModMonad where+    mDoesDirectoryExist d = do+      fps <- gets fst+      return $ S.member d fps+    mDoesFileExist f = do+      fps <- gets fst+      return $ S.member f fps+    mReadFilePS _ = error "mReadFilePS FileModMonad"+    mCreateFile = createFile+    mCreateDirectory = createDir+    mRemoveFile = remove+    mRemoveDirectory = remove+    mRename a b = do+      fns <- gets fst+      -- we have to account for directory moves+      addMod (PRename a b)+      modifyFps (S.delete a)+      addFile b+      forM_ (S.toList fns) $ \fn ->+        when (a `isPrefix` fn && a /= fn) $ do+          modifyFps (S.delete fn)+          let newfn = movedirfilename a b fn+          addFile newfn+          addMod (PRename fn newfn)+    mModifyFilePS f _ = addMod (PTouch f)++-- ---------------------------------------------------------------------+-- State Handling Functions++addMod :: FileMod AnchoredPath -> FileModMonad ()+addMod pm = modify $ second (pm :)++addFile :: AnchoredPath -> FileModMonad ()+addFile f = modifyFps (S.insert f)++createFile :: AnchoredPath -> FileModMonad ()+createFile fn = do+  errorIfPresent fn True+  addMod (PCreateFile fn)+  addFile fn++createDir :: AnchoredPath -> FileModMonad ()+createDir fn = do+  errorIfPresent fn False+  addMod (PCreateDir fn)+  addFile fn++errorIfPresent :: AnchoredPath -> Bool -> FileModMonad ()+errorIfPresent fn isFile = do+  fs <- gets fst+  when (S.member fn fs) $ throwM $ userError $ unwords+    [ "error: patch index entry for"+    , if isFile then "file" else "directory"+    , anchorPath "" fn+    , "created >1 times. Run `darcs repair` and try again."+    ]++remove :: AnchoredPath -> FileModMonad ()+remove f = addMod (PRemove f) >> modifyFps (S.delete f)++modifyFps :: (Set AnchoredPath -> Set AnchoredPath) -> FileModMonad ()+modifyFps f = modify $ first f++--------------------------------------------------------------------------------+-- | Apply a patch to set of 'AnchoredPath's, yielding the new set of+-- 'AnchoredPath's and 'FileMod's+applyToFileMods :: (Apply p, ApplyState p ~ Tree)+                => p wX wY+                -> Set AnchoredPath+                -> FileModState+applyToFileMods patch = withPatchMods (apply patch)
+ src/Darcs/Patch/Index/Types.hs view
@@ -0,0 +1,59 @@+-- Copyright (C) 2009-2010 Benedikt Schmidt+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Patch.Index.Types where++import Darcs.Prelude++import Darcs.Patch.Info ( makePatchname, PatchInfo )+import Darcs.Util.Hash( SHA1, sha1short, sha1zero )+import Darcs.Util.Path ( anchorPath, AnchoredPath )+import Data.Binary ( Binary(..) )++-- | The FileId for a file consists of the FilePath (creation name)+--   and an index. The index denotes how many files+--   with the same name have been added before (and subsequently+--   deleted or moved)+data FileId = FileId {cname::AnchoredPath,count::Int}+  deriving (Eq,Show,Ord)++instance Binary FileId where+  put (FileId rfp i) = put (rfp,i)+  get = do+   (rfp,cnt) <- get+   return $ FileId rfp cnt++-- | Convert FileId to string+showFileId :: FileId -> String+showFileId (FileId fn i) = show i++"#"++anchorPath "." fn++-- | The PatchId identifies a patch and can be created from a PatchInfo with makePatchname+newtype PatchId = PID {patchId :: SHA1}+  deriving (Binary,Show,Ord,Eq)++pid2string :: PatchId -> String+pid2string = show . patchId++short :: PatchId -> Int+short (PID sha1) = fromIntegral $ sha1short sha1++zero :: PatchId+zero = PID sha1zero++makePatchID :: PatchInfo -> PatchId+makePatchID = PID . makePatchname+
src/Darcs/Patch/Info.hs view
@@ -15,105 +15,232 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -module Darcs.Patch.Info ( PatchInfo(..), patchinfo, invertName,-                          idpatchinfo, addJunk, makePatchname,-                          makeFilename, makeAltFilename, readPatchInfo,-                          justName, justAuthor, justLog, repopatchinfo,-                          RepoPatchInfo, humanFriendly, toXml, piDate,-                          setPiDate, piDateString, piDateBytestring,-                          piName, piRename, piAuthor, piTag, piLog,-                          showPatchInfo, isTag, readPatchInfos, escapeXML-                        ) where-import Text.Html hiding (name, text, option)-import System.Random ( randomRIO )+module Darcs.Patch.Info+    ( PatchInfo(..) -- constructor and fields exported *only for tests*+    , rawPatchInfo  -- exported *only for tests*+    , patchinfo+    , addJunk+    , replaceJunk+    , makePatchname+    , readPatchInfo+    , justName+    , justAuthor+    , justLog+    , displayPatchInfo+    , toXml+    , toXmlShort+    , piDate+    , piDateString+    , piName+    , piRename+    , piAuthor+    , piTag+    , piLog+    , showPatchInfo+    , isTag+    , escapeXML+    , validDate+    , validLog+    , validAuthor+    , validDatePS+    , validLogPS+    , validAuthorPS+    ) where++import Darcs.Prelude++import Data.Char ( isAscii )+import Crypto.Random ( seedNew, seedToInteger ) import Numeric ( showHex )-import Control.Monad ( when, unless )+import Control.Monad ( when, unless, void ) -import ByteStringUtils ( unlinesPS, packStringToUTF8, unpackPSFromUTF8, decodeLocale)-import qualified Darcs.Patch.ReadMonads as RM ( take )-import Darcs.Patch.ReadMonads as RM ( skipSpace, char,-                                      takeTill, anyChar, ParserM,-                                      option, parseStrictly,+import Darcs.Util.ByteString+    ( decodeLocale+    , packStringToUTF8+    , unlinesPS+    , unpackPSFromUTF8+    )+import qualified Darcs.Util.Parser as RM ( take )+import Darcs.Util.Parser as RM ( skipSpace, char,+                                      takeTill, anyChar, Parser,+                                      option,                                       takeTillChar,                                       linesStartingWithEndingWith)+import Darcs.Patch.Show ( ShowPatchFor(..) ) import qualified Data.ByteString       as B  (length, splitAt, null                                              ,isPrefixOf, tail, concat                                              ,empty, head, cons, append                                              ,ByteString )-import qualified Data.ByteString.Char8 as BC (index, head, unpack, pack)+import qualified Data.ByteString.Char8 as BC+    ( index, head, notElem, all, unpack, pack ) import Data.List( isPrefixOf )+import Data.List.NonEmpty ( NonEmpty(..) )+import qualified Data.List.NonEmpty as NE -import Printer ( renderString, Doc, packedString,-                 empty, ($$), (<>), (<+>), vcat, text, blueText, prefix )-import Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime )-import System.Time ( CalendarTime(ctTZ), calendarTimeToString, toClockTime,+import Darcs.Util.Printer ( Doc, packedString,+                 empty, ($$), (<+>), vcat, text, cyanText, blueText, prefix )+import Darcs.Util.IsoDate ( readUTCDate )+import System.Time ( CalendarTime, calendarTimeToString, toClockTime,                      toCalendarTime ) import System.IO.Unsafe ( unsafePerformIO )-import SHA1 ( sha1PS )-import Darcs.Utils ( promptYorn )-import Prelude hiding (pi, log)+import Darcs.Util.Hash ( sha1PS, SHA1 )+import Darcs.Util.Prompt ( promptYorn ) -data RepoPatchInfo = RPI String PatchInfo+import Darcs.Test.TestOnly ( TestOnly ) -repopatchinfo :: String -> PatchInfo -> RepoPatchInfo-repopatchinfo r pi = RPI r pi+{- |+A PatchInfo value contains the metadata of a patch. The date, name, author+and log fields are UTF-8 encoded text in darcs 2.4 and later, and just+sequences of bytes (decoded with whatever is the locale when displayed) in+earlier darcs. --- | A PatchInfo value contains the metadata of a patch. The date, name, author--- and log fields are UTF-8 encoded text in darcs 2.4 and later, and just--- sequences of bytes (decoded with whatever is the locale when displayed) in--- earlier darcs.------ The members with names that start with '_' are not supposed to be used--- directly in code that does not care how the patch info is stored.-data PatchInfo = PatchInfo { _piDate    :: !B.ByteString-                           , _piName    :: !B.ByteString-                           , _piAuthor  :: !B.ByteString-                           , _piLog     :: ![B.ByteString]-                           , isInverted :: !Bool-                           }-                 deriving (Eq,Ord)+The members with names that start with '_' are not supposed to be used+directly in code that does not care how the patch info is stored. -idpatchinfo :: PatchInfo-idpatchinfo = PatchInfo myid myid myid [] False-    where myid = BC.pack "identity"+@_piLegacyIsInverted@: +Historically, the @isInverted@ flag was used to indicate that a Named patch+was inverted.++We no longer support direct inversion of 'Darcs.Patch.Named.Named' patches,+except sometimes via the 'Darcs.Patch.Invertible.Invertible' wrapper which+tracks inversion in the wrapper.++However, going even further back in time, inverted patches could be written+out by @darcs rollback@. This was changed in 2008 so any patches on disk+with this flag set would have been written by a darcs from prior to then.+As they still exist, including in the darcs repository itself, we need+to support them.++As far as current darcs is concerned, the flag should be treated like any+other field in 'PatchInfo' apart from never being set freshly:++ - There is no semantic relationship between a 'PatchInfo' with+   @piLegacyIsInverted = False@ and the same 'PatchInfo' with+   @piLegacyIsInverted = True@. For example they are not inverses of each+   other.++- New or amended patches should never be written out with+  @_piLegacyIsInverted = True@.++ - We do need to maintain backwards compatibility so we take care to+   preserve things like the hash, on-disk format etc.++- A patch with @_piLegacyIsInverted = True@ should work with all the+  normal darcs operations.++The flag is completely separate and orthogonal to the tracking of+explicit inversion in the 'Darcs.Patch.Invertible.Invertible' wrapper.+The 'Darcs.Patch.Invertible.Invertible' wrapper+is only used in memory and never stored to disk so there should be no+confusion when reading a patch from disk. Within the codebase they+serve completely different purposes and should not interact at all.+-}+data PatchInfo =+  PatchInfo { _piDate    :: !B.ByteString+            , _piName    :: !B.ByteString+            , _piAuthor  :: !B.ByteString+            , _piLog     :: ![B.ByteString]+              -- | See the long description of this field in the+              -- docs above.+            , _piLegacyIsInverted :: !Bool+            }+  deriving (Eq,Ord,Show)++-- Validation++-- We need these functions to ensure that we can parse the+-- result of showPatchInfo.++validDate :: String -> Bool+validDate = all validCharForDate++validDatePS :: B.ByteString -> Bool+validDatePS = BC.all validCharForDate++-- | The isAscii limitation is due to the use of BC.pack below.+validCharForDate :: Char -> Bool+validCharForDate c = isAscii c && c /= '\n' && c /= ']'++validLog :: String -> Bool+validLog = notElem '\n'++validLogPS :: B.ByteString -> Bool+validLogPS = BC.notElem '\n'++validAuthor :: String -> Bool+validAuthor = notElem '*'++validAuthorPS :: B.ByteString -> Bool+validAuthorPS = BC.notElem '*'++rawPatchInfo+  :: TestOnly+  => String -> String -> String -> [String] -> Bool -> PatchInfo+rawPatchInfo = rawPatchInfoInternal++rawPatchInfoInternal :: String -> String -> String -> [String] -> Bool -> PatchInfo+rawPatchInfoInternal date name author log inverted =+    PatchInfo { _piDate     = BC.pack $ validateDate date+              , _piName     = packStringToUTF8 $ validateName name+              , _piAuthor   = packStringToUTF8 $ validateAuthor author+              , _piLog      = map (packStringToUTF8 . validateLog) log+              , _piLegacyIsInverted  = inverted+              }+  where+    validateAuthor = validate validAuthor "author"+    validateName = validate validLog "patch name"+    validateLog = validate validLog "log line"+    validateDate = validate validDate "date"+    validate test meta x =+      if test x then x else error (unwords ["invalid",meta,show x])++-- | @patchinfo date name author log@ constructs a new 'PatchInfo' value+-- with the given details, automatically assigning an Ignore-this header+-- to guarantee the patch is unique.  The function does not verify+-- the date string's sanity. patchinfo :: String -> String -> String -> [String] -> IO PatchInfo patchinfo date name author log =-    addJunk $ PatchInfo { _piDate     = BC.pack date-                         , _piName     = packStringToUTF8 name-                         , _piAuthor   = packStringToUTF8 author-                         , _piLog      = map packStringToUTF8 log-                         , isInverted  = False }+    addJunk $ rawPatchInfoInternal date name author log False  -- | addJunk adds a line that contains a random number to make the patch --   unique. addJunk :: PatchInfo -> IO PatchInfo addJunk pinf =-    do x <- randomRIO (0,2^(128 ::Integer) :: Integer)+    do x <- seedToInteger <$> seedNew+       -- Note: this is now 40 bytes long compare to the 32 we had before        when (_piLog pinf /= ignoreJunk (_piLog pinf)) $-            do putStrLn "Lines beginning with 'Ignore-this: ' will be ignored."+            do putStrLn $ "Lines beginning with 'Ignore-this: ' " +++                          "will not be shown when displaying a patch."                confirmed <- promptYorn "Proceed? "                unless confirmed $ fail "User cancelled because of Ignore-this."-       return $ pinf { _piLog = BC.pack (head ignored++showHex x ""):+       return $ pinf { _piLog = BC.pack (NE.head ignored++showHex x ""):                                  _piLog pinf } -ignored :: [String] -- this is a [String] so we can change the junk header.-ignored = ["Ignore-this: "]+replaceJunk :: PatchInfo -> IO PatchInfo+replaceJunk pi@(PatchInfo {_piLog=log}) = addJunk $ pi{_piLog = ignoreJunk log} +-- This is a list so we can change the junk header.+-- The first element will be used for new patches, the rest are also recognised+-- in existing patches.+ignored :: NonEmpty String+ignored = "Ignore-this: " :| []+ ignoreJunk :: [B.ByteString] -> [B.ByteString] ignoreJunk = filter isnt_ignored-    where isnt_ignored x = doesnt_start_with x (map BC.pack ignored) -- TODO+    where isnt_ignored x = doesnt_start_with x (map BC.pack (NE.toList ignored)) -- TODO           doesnt_start_with x ys = not $ any (`B.isPrefixOf` x) ys   -- * Patch info formatting-invertName :: PatchInfo -> PatchInfo-invertName pi = pi { isInverted = not (isInverted pi) } --- | Get the name, including an "UNDO: " prefix if the patch is inverted.+-- | Get the name, including an "UNDO: " prefix if the patch is+-- a legacy inverted patch. justName :: PatchInfo -> String-justName pinf = if isInverted pinf then "UNDO: " ++ nameString-                                     else nameString+justName pinf =+  if _piLegacyIsInverted pinf+    then "UNDO: " ++ nameString+    else nameString   where nameString = metadataToString (_piName pinf)  -- | Returns the author of a patch.@@ -123,18 +250,20 @@ justLog :: PatchInfo -> String justLog = unlines . map BC.unpack . _piLog -humanFriendly :: PatchInfo -> Doc-humanFriendly pi =-    text (friendlyD $ _piDate pi) <> text "  " <> text (piAuthor pi)+displayPatchInfo :: PatchInfo -> Doc+displayPatchInfo pi =+    cyanText "patch " <> cyanText (show $ makePatchname pi)+ $$ text "Author: " <> text (piAuthor pi)+ $$ text "Date:   " <> text (friendlyD $ _piDate pi)  $$ hfn (piName pi)  $$ vcat (map ((text "  " <>) . text) (piLog pi))   where hfn x = case piTag pi of                 Nothing -> inverted <+> text x                 Just t -> text "  tagged" <+> text t-        inverted = if isInverted pi then text "  UNDO:" else text "  *"+        inverted = if _piLegacyIsInverted pi then text "  UNDO:" else text "  *"  -- | Returns the name of the patch. Unlike 'justName', it does not preprend---   "UNDO: " to the name if the patch is inverted.+--   "UNDO: " to the name if the patch has the legacy inverted flag set. piName :: PatchInfo -> String piName = metadataToString . _piName @@ -148,16 +277,12 @@ isTag :: PatchInfo -> Bool isTag pinfo = "TAG " `isPrefixOf` justName pinfo --- | Note: we ignore timezone information in the date string,---   systematically treating a time as UTC.  So if the patch---   tells me it's 17:00 EST, we're actually treating it as---   17:00 UTC, in other words 11:00 EST.  This is for---   backwards compatibility to darcs prior to 2003-11, sometime---   before 1.0.  Fortunately, newer patch dates are written in---   UTC, so this timezone truncation is harmless for them.+-- | Read the date from raw patch (meta) data and convert it to UTC.+-- The raw data may contain timezone info. This is for compatibiltity+-- with patches that were created before 2003-11, when darcs still+-- created patches that contained localized date strings. readPatchDate :: B.ByteString -> CalendarTime-readPatchDate = ignoreTz . readUTCDate . BC.unpack-  where ignoreTz ct = ct { ctTZ = 0 }+readPatchDate = readUTCDate . BC.unpack  piDate :: PatchInfo -> CalendarTime piDate = readPatchDate . _piDate@@ -165,12 +290,6 @@ piDateString :: PatchInfo -> String piDateString = BC.unpack . _piDate -piDateBytestring :: PatchInfo -> B.ByteString-piDateBytestring = _piDate--setPiDate :: String -> PatchInfo -> PatchInfo-setPiDate date pi = pi { _piDate = BC.pack date }- -- | Get the log message of a patch. piLog :: PatchInfo -> [String] piLog = map metadataToString . ignoreJunk . _piLog@@ -189,28 +308,36 @@ --   We try UTF-8 first because UTF-8 is clearly recognizable, widely used, --   and people may have UTF-8 patches even when UTF-8 is not their locale. metadataToString :: B.ByteString -> String-metadataToString bs | not ('\xfffd' `elem` bsUtf8) = bsUtf8-                    | otherwise                    = decodeLocale bs+metadataToString bs | '\xfffd' `notElem` bsUtf8 = bsUtf8+                    | otherwise                 = decodeLocale bs   where bsUtf8 = unpackPSFromUTF8 bs  friendlyD :: B.ByteString -> String---friendlyD d = calendarTimeToString . readPatchDate . d friendlyD d = unsafePerformIO $ do     ct <- toCalendarTime $ toClockTime $ readPatchDate d     return $ calendarTimeToString ct  toXml :: PatchInfo -> Doc-toXml pi =+toXml = toXml' True++toXmlShort :: PatchInfo -> Doc+toXmlShort = toXml' False++toXml' :: Bool -> PatchInfo -> Doc+toXml' includeComments pi =         text "<patch"     <+> text "author='" <> escapeXMLByteString (_piAuthor pi) <> text "'"     <+> text "date='" <> escapeXMLByteString (_piDate pi) <> text "'"     <+> text "local_date='" <> escapeXML (friendlyD $ _piDate pi) <> text "'"-    <+> text "inverted='" <> text (show $ isInverted pi) <> text "'"-    <+> text "hash='" <> text (makePatchname pi) <> text "'>"- $$     prefix "\t" (-            text "<name>" <> escapeXMLByteString (_piName pi) <> text "</name>"-         $$ commentsAsXml (_piLog pi))- $$     text "</patch>"+    <+> text "inverted='" <> text (show $ _piLegacyIsInverted pi) <> text "'"+    <+> text "hash='" <> text (show $ makePatchname pi) <> text "'>"+    $$  indent abstract+    $$  text "</patch>"+      where+        indent = prefix "    "+        name = text "<name>" <> escapeXMLByteString (_piName pi) <> text "</name>"+        abstract | includeComments = name $$ commentsAsXml (_piLog pi)+                 | otherwise = name  commentsAsXml :: [B.ByteString] -> Doc commentsAsXml comments@@ -238,8 +365,8 @@ strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] strReplace x y (z:zs)-  | x == z    = y ++ (strReplace x y zs)-  | otherwise = z : (strReplace x y zs)+  | x == z    = y ++ strReplace x y zs+  | otherwise = z : strReplace x y zs  bstrReplace :: Char -> String -> B.ByteString -> B.ByteString bstrReplace c s bs | B.null bs   = B.empty@@ -249,78 +376,24 @@                                      else B.cons (B.head bs)                                                  (bstrReplace c s (B.tail bs)) -makeAltFilename :: PatchInfo -> String-makeAltFilename pi@(PatchInfo { isInverted = False }) =-    fixUpFname (midtrunc (piName pi)++"-"++justAuthor pi++"-"++BC.unpack (_piDate pi))-makeAltFilename pi@(PatchInfo { isInverted = True}) =-    makeAltFilename (pi { isInverted = False }) ++ "-inverted"---- | This makes darcs-1 (non-hashed repos) filenames, and is also generally--- used in both in hashed and non-hashed repo code for making patch "hashes".------ The name consists of three segments:------  * timestamp (ISO8601-compatible yyyymmmddHHMMSS, UTC)------  * SHA1 hash of the author------  * SHA1 hash of the patch name, author, date, log, and \"inverted\"---    flag.-makeFilename :: PatchInfo -> String-makeFilename pi = makePatchname pi ++ ".gz"--makePatchname :: PatchInfo -> String-makePatchname pi =-    showIsoDateTime d++"-"++sha1_a++"-"++sha1PS sha1_me+-- | Hash on patch metadata (patch name, author, date, log, and the legacy+-- \"inverted\" flag.+-- Robust against context changes but does not guarantee patch contents.+-- Usually used as matcher or patch identifier (see Darcs.Patch.Match).+makePatchname :: PatchInfo -> SHA1+makePatchname pi = sha1PS sha1_me         where b2ps True = BC.pack "t"               b2ps False = BC.pack "f"               sha1_me = B.concat [_piName pi,                                   _piAuthor pi,                                   _piDate pi,                                   B.concat $ _piLog pi,-                                  b2ps $ isInverted pi]-              d = readPatchDate $ _piDate pi-              sha1_a = take 5 $ sha1PS $ _piAuthor pi+                                  b2ps $ _piLegacyIsInverted pi] -midtrunc :: String -> String-midtrunc s-    | length s < 73 = s-    | otherwise = (take 40 s)++"..."++(reverse $ take 30 $ reverse s)-fixUpFname :: String -> String-fixUpFname = map mungeChar -mungeChar :: Char -> Char-mungeChar '*' = '+'-mungeChar '?' = '2'-mungeChar '>' = '7'-mungeChar '<' = '2'-mungeChar ' ' = '_'-mungeChar '"' = '~'-mungeChar '`' = '.'-mungeChar '\'' = '.'-mungeChar '/' = '1'-mungeChar '\\' = '1'-mungeChar '!' = '1'-mungeChar ':' = '.'-mungeChar ';' = ','-mungeChar '{' = '~'-mungeChar '}' = '~'-mungeChar '(' = '~'-mungeChar ')' = '~'-mungeChar '[' = '~'-mungeChar ']' = '~'-mungeChar '=' = '+'-mungeChar '#' = '+'-mungeChar '%' = '8'-mungeChar '&' = '6'-mungeChar '@' = '9'-mungeChar '|' = '1'-mungeChar  c  =  c--instance  HTML RepoPatchInfo  where-    toHtml = htmlPatchInfo-instance  Show PatchInfo  where-    show pi = renderString (showPatchInfo pi)+showPatchInfo :: ShowPatchFor -> PatchInfo -> Doc+showPatchInfo ForDisplay = displayPatchInfo+showPatchInfo ForStorage = storePatchInfo  -- |Patch is stored between square brackets. --@@ -334,16 +407,16 @@ -- -- note that below I assume the name has no newline in it. -- See 'readPatchInfo' for the inverse operation.-showPatchInfo :: PatchInfo -> Doc-showPatchInfo pi =+-- There are more assumptions, see validation functions above.+storePatchInfo :: PatchInfo -> Doc+storePatchInfo pi =     blueText "[" <> packedString (_piName pi)  $$ packedString (_piAuthor pi) <> text inverted <> packedString (_piDate pi)                                  <> myunlines (_piLog pi) <> blueText "] "-    where inverted = if isInverted pi then "*-" else "**"+    where inverted = if _piLegacyIsInverted pi then "*-" else "**"           myunlines [] = empty-          myunlines xs = mul xs-              where mul [] = text "\n"-                    mul (s:ss) = text "\n " <> packedString s <> mul ss+          myunlines xs =+              foldr (\s -> ((text "\n " <> packedString s) <>)) (text "\n") xs  -- |Parser for 'PatchInfo' as stored in patch bundles and inventory files, -- for example:@@ -355,7 +428,7 @@ -- > ] -- -- See 'showPatchInfo' for the inverse operation.-readPatchInfo :: ParserM m => m (PatchInfo)+readPatchInfo :: Parser PatchInfo readPatchInfo = do   skipSpace   char '['@@ -364,31 +437,11 @@   author <- takeTillChar '*'   s2 <- RM.take 2   ct <- takeTill (\c->c==']'||c=='\n')-  option () (char '\n' >> return ()) -- consume newline char, if present+  option () (void (char '\n')) -- consume newline char, if present   log <- linesStartingWithEndingWith ' ' ']'-  return $ PatchInfo { _piDate = ct-                     , _piName = name-                     , _piAuthor = author-                     , _piLog = log-                     , isInverted = BC.index s2 1 /= '*'-                     }--readPatchInfos :: B.ByteString -> [PatchInfo]-readPatchInfos inv | B.null inv = []-readPatchInfos inv = case parseStrictly readPatchInfo inv of-                     Just (pinfo,r) -> pinfo : readPatchInfos r-                     _ -> []--htmlPatchInfo :: RepoPatchInfo -> Html-htmlPatchInfo (RPI r pi) =-    toHtml $ (td << patchLink r pi) `above`-               ((td ! [align "right"] << mailLink (justAuthor pi)) `beside`-                (td << (friendlyD $ _piDate pi)))--patchLink :: String -> PatchInfo -> Html-patchLink r pi =-    toHtml $ hotlink-               ("darcs?"++r++"**"++makeFilename pi)-               [toHtml $ piName pi]-mailLink :: String -> Html-mailLink email = toHtml $ hotlink ("mailto:"++email) [toHtml email]+  return PatchInfo { _piDate = ct+                   , _piName = name+                   , _piAuthor = author+                   , _piLog = log+                   , _piLegacyIsInverted = BC.index s2 1 /= '*'+                   }
src/Darcs/Patch/Inspect.hs view
@@ -3,16 +3,25 @@        )        where -import Darcs.Witnesses.Ordered ( FL, RL, reverseRL, mapFL )+import Darcs.Prelude +import Darcs.Patch.Witnesses.Ordered ( FL, RL, reverseRL, mapFL )+import Darcs.Util.Path ( AnchoredPath )+ import qualified Data.ByteString.Char8 as BC import Data.List ( nub ) -#include "gadts.h"+-- TODO Whether a patch touches a given file is not an invariant property of a+-- patch: it depends on the context i.e. it changes when we re-order patches.+-- Can we define an interface where this becomes an invariant property? +-- TODO This interface only makes sense if @ApplyState p ~ Tree@. To support+-- other ApplyStates we need to devise an abstraction for "objects" of the+-- ApplyState.+ class PatchInspect p where-    listTouchedFiles :: p C(x y) -> [FilePath]-    hunkMatches :: (BC.ByteString -> Bool) -> p C(x y) -> Bool+    listTouchedFiles :: p wX wY -> [AnchoredPath]+    hunkMatches :: (BC.ByteString -> Bool) -> p wX wY -> Bool  instance PatchInspect p => PatchInspect (FL p) where     listTouchedFiles xs = nub $ concat $ mapFL listTouchedFiles xs
src/Darcs/Patch/Invert.hs view
@@ -3,17 +3,30 @@        )        where -import Darcs.Witnesses.Ordered ( FL(..), RL(..) )+import Darcs.Prelude -#include "gadts.h"+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), RL(..), reverseFL, reverseRL, (:>)(..) ) +-- | The 'invert' operation must be self-inverse, i.e. an involution:+--+-- prop> invert . invert = id class Invert p where-    invert :: p C(x y) -> p C(y x)+    invert :: p wX wY -> p wY wX -invertFL :: Invert p => FL p C(x y) -> RL p C(y x)+invertFL :: Invert p => FL p wX wY -> RL p wY wX invertFL NilFL = NilRL-invertFL (x:>:xs) = invert x :<: invertFL xs+invertFL (x:>:xs) = invertFL xs :<: invert x -invertRL :: Invert p => RL p C(x y) -> FL p C(y x)+invertRL :: Invert p => RL p wX wY -> FL p wY wX invertRL NilRL = NilFL-invertRL (x:<:xs) = invert x :>: invertRL xs+invertRL (xs:<:x) = invert x :>: invertRL xs++instance Invert p => Invert (FL p) where+    invert = reverseRL . invertFL++instance Invert p => Invert (RL p) where+    invert = reverseFL . invertRL++instance Invert p => Invert (p :> p) where+  invert (a :> b) = invert b :> invert a
+ src/Darcs/Patch/Invertible.hs view
@@ -0,0 +1,115 @@+{- | Formal inverses for patches that aren't really invertible. Note that+most the mixed {'Fwd','Rev'} cases for 'Commute' and 'Eq2' are just errors.+-}+module Darcs.Patch.Invertible+    ( Invertible+    , mkInvertible+    , fromPositiveInvertible+    , withInvertible+    ) where++import Darcs.Prelude++import Darcs.Patch.CommuteFn ( invertCommuter )+import Darcs.Patch.Ident+  ( Ident(..), PatchId, SignedId(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.RepoPatch+    ( Apply(..)+    , Commute(..)+    , Eq2(..)+    , PrimPatchBase(..)+    , PatchInspect(..)+    , PatchListFormat(..)+    , ShowContextPatch(..)+    , ShowPatch(..)+    , ShowPatchBasic(..)+    )+import Darcs.Patch.Show ( ShowPatchFor(..) )+import Darcs.Patch.Witnesses.Ordered ((:>)(..))++-- | Wrapper type to allow formal inversion of patches which aren't really+-- invertible.+data Invertible p wX wY where+   Fwd :: p wX wY -> Invertible p wX wY+   Rev :: p wX wY -> Invertible p wY wX++-- | Wrap a patch to make it (formally) 'Invertible'. The result is initially+-- positive i.e. 'Fwd'.+mkInvertible :: p wX wY -> Invertible p wX wY+mkInvertible = Fwd++-- | Get the underlying patch from an 'Invertible', assuming (as a precondition)+-- that it is positive i.e. 'Fwd'.+fromPositiveInvertible :: Invertible p wX wY -> p wX wY+fromPositiveInvertible (Fwd p) = p+fromPositiveInvertible (Rev _) = error "precondition of fromPositiveInvertible"++-- | Run a function on the patch inside an 'Invertible'. The function has to be+-- parametric in the witnesses, so we can run it with both a 'Fwd' and a 'Rev'+-- patch.+withInvertible :: (forall wA wB. p wA wB -> r) -> Invertible p wX wY -> r+withInvertible f (Fwd p) = f p+withInvertible f (Rev p) = f p++instance Invert (Invertible p) where+  invert (Fwd p) = Rev p+  invert (Rev p) = Fwd p++instance Commute p => Commute (Invertible p) where+  commute (Fwd p :> Fwd q) = do+    q' :> p' <- commute (p :> q)+    return (Fwd q' :> Fwd p')+  commute pair@(Rev _ :> Rev _) = invertCommuter commute pair+  commute _ = error "cannote commute mixed Fwd/Rev"++instance Eq2 p => Eq2 (Invertible p) where+  Fwd p =\/= Fwd q = p =\/= q+  Rev p =\/= Rev q = p =/\= q+  _ =\/= _ = error "cannot compare mixed Fwd/Rev"++instance Apply p => Apply (Invertible p) where+  type ApplyState (Invertible p) = ApplyState p+  apply (Fwd p) = apply p+  apply (Rev p) = unapply p+  unapply (Fwd p) = unapply p+  unapply (Rev p) = apply p++data InvertibleId ident = InvertibleId Bool ident+  deriving (Eq, Ord)++instance Ord ident => SignedId (InvertibleId ident) where+  positiveId (InvertibleId inverted _) = inverted+  invertId (InvertibleId inverted theid) =+     InvertibleId (not inverted) theid++type instance PatchId (Invertible p) = InvertibleId (PatchId p)++instance Ident p => Ident (Invertible p) where+  ident (Fwd p) = InvertibleId False (ident p)+  ident (Rev p) = InvertibleId True  (ident p)++instance PatchInspect p => PatchInspect (Invertible p) where+  listTouchedFiles (Fwd p) = listTouchedFiles p+  listTouchedFiles (Rev p) = listTouchedFiles p+  hunkMatches f (Fwd p) = hunkMatches f p+  hunkMatches f (Rev p) = hunkMatches f p++instance PrimPatchBase p => PrimPatchBase (Invertible p) where+  type PrimOf (Invertible p) = PrimOf p++instance ShowPatchBasic p => ShowPatchBasic (Invertible p) where+  showPatch ForStorage = error "Invertible patches must not be stored"+  showPatch ForDisplay = withInvertible (showPatch ForDisplay)++instance ShowPatch p => ShowPatch (Invertible p) where+  -- note these are only used for display+  description = withInvertible description+  summary = withInvertible summary+  content = withInvertible content++instance ShowContextPatch p => ShowContextPatch (Invertible p) where+  showPatchWithContextAndApply ForStorage = error "Invertible patches must not be stored"+  showPatchWithContextAndApply ForDisplay = withInvertible (showPatchWithContextAndApply ForDisplay)++instance PatchListFormat p => PatchListFormat (Invertible p)
src/Darcs/Patch/Match.hs view
@@ -1,4 +1,4 @@---  Copyright (C) 2004 David Roundy+--  Copyright (C) 2004-2005 David Roundy -- --  This program is free software; you can redistribute it and/or modify --  it under the terms of the GNU General Public License as published by@@ -15,77 +15,215 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -#include "gadts.h"+-- | /First matcher, Second matcher and Nonrange matcher/+--+-- When we match for patches, we have a PatchSet, of which we want a+-- subset. This subset is formed by the patches in a given interval+-- which match a given criterion. If we represent time going left to+-- right, then we have (up to) three 'Matcher's:+--+-- * the 'firstMatcher' is the left bound of the interval,+--+-- * the 'secondMatcher' is the right bound, and+--+-- * the 'nonrangeMatcher' is the criterion we use to select among+--   patches in the interval.+---+-- Each of these matchers can be present or not according to the+-- options. The patches we want would then be the ones that all+-- present matchers have in common.+--+-- Alternatively, match flags can also be understood as a 'patchSetMatch'.+-- This (ab-)uses match flags that normally denote a 'nonrangeMatcher',+-- (additionally including the 'OneIndex' flag --index=n), to denote+-- selection of a full 'PatchSet' up to the latest matching patch. This+-- works similar to 'secondMatcher' except for tag matches, which in this+-- case mean to select only the tag and all its dependencies. In other+-- words, the tag will be clean in the resulting 'PatchSet'.+--+-- (Implementation note: keep in mind that the PatchSet is written+-- backwards with respect to the timeline, ie., from right to left)+module Darcs.Patch.Match+    ( helpOnMatchers+    , matchFirstPatchset+    , matchSecondPatchset+    , splitSecondFL+    , matchAPatch+    , rollbackToPatchSetMatch+    , firstMatch+    , secondMatch+    , haveNonrangeMatch+    , PatchSetMatch(..)+    , patchSetMatch+    , checkMatchSyntax+    , hasIndexRange+    , getMatchingTag+    , matchAPatchset+    , MatchFlag(..)+    , matchingHead+    , Matchable+    , MatchableRP+    ) where -module Darcs.Patch.Match ( PatchMatch, Matcher, MatchFun,-                    patchMatch, matchPattern,-                    applyMatcher, makeMatcher,-                    parseMatch,-                    matchParser, helpOnMatchers,-                  ) where+import Darcs.Prelude  import Text.ParserCombinators.Parsec+    ( parse+    , CharParser+    , (<?>)+    , (<|>)+    , noneOf+    , option+    , eof+    , many+    , try+    , between+    , spaces+    , char+    , oneOf+    , string+    , choice+    ) import Text.ParserCombinators.Parsec.Expr-import Text.Regex ( mkRegex, matchRegex )+    ( OperatorTable+    , Assoc( AssocLeft )+    , Operator ( Infix, Prefix )+    , buildExpressionParser+    )+import Darcs.Util.Regex ( mkRegex, matchRegex )++import Control.Exception ( Exception, throw ) import Data.Maybe ( isJust )-import Data.List ( isPrefixOf ) import System.IO.Unsafe ( unsafePerformIO )+import Data.List ( isPrefixOf, intercalate )+import Data.Char ( toLower )+import Data.Typeable ( Typeable ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )-import Darcs.Patch ( Patchy, hunkMatches, listTouchedFiles, patchcontents )-import Darcs.Patch.Info ( justName, justAuthor, justLog, makeFilename,-                          piDate )-import Darcs.Witnesses.Sealed ( Sealed2(..), seal2 )-import DateMatcher ( parseDateMatcher )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Patch ( hunkMatches, listTouchedFiles )+import Darcs.Patch.Info ( justName, justAuthor, justLog, makePatchname,+                          piDate, piTag ) -import Darcs.Patch.MatchData ( PatchMatch(..), patchMatch ) import qualified Data.ByteString.Char8 as BC -import Darcs.Patch.Dummy ( DummyPatch )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )+import Darcs.Patch.Set+    ( Origin+    , PatchSet(..)+    , SealedPatchSet+    , Tagged(..)+    , patchSetDrop+    )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Depends ( splitOnTag, contextPatches )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Inspect ( PatchInspect ) +import Darcs.Patch.Witnesses.Ordered+    ( RL(..), FL(..), (:>)(..), reverseRL, mapRL, (+<+) )+import Darcs.Patch.Witnesses.Sealed+    ( Sealed2(..), seal, seal2, unseal2, unseal )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )++import Darcs.Util.DateMatcher ( parseDateMatcher )+import Darcs.Util.Path ( anchorPath )+import Darcs.Util.Tree ( Tree )++-- | Patches that can be matched.+type Matchable p =+  ( Apply p+  , PatchInspect p+  , Ident p+  , PatchId p ~ PatchInfo+  )++-- | Constraint for a patch type @p@ that ensures @'PatchInfoAnd' p@+-- is 'Matchable'.+type MatchableRP p =+  ( Apply p+  , Commute p+  , PatchInspect p+  )+ -- | A type for predicates over patches which do not care about -- contexts-type MatchFun p = Sealed2 (PatchInfoAnd p) -> Bool+data MatchFun = MatchFun (forall p. Matchable p => Sealed2 p -> Bool)  -- | A @Matcher@ is made of a 'MatchFun' which we will use to match -- patches and a @String@ representing it.-data Matcher p = MATCH String (MatchFun p)+data Matcher = MATCH String MatchFun -instance Show (Matcher p) where+instance Show Matcher where     show (MATCH s _) = '"':s ++ "\"" -makeMatcher :: String -> (Sealed2 (PatchInfoAnd p) -> Bool) -> Matcher p-makeMatcher s m = MATCH s m+data MatchFlag+    = OnePattern String+    | SeveralPattern String+    | AfterPattern String+    | UpToPattern String+    | OnePatch String+    | SeveralPatch String+    | AfterPatch String+    | UpToPatch String+    | OneHash String+    | AfterHash String+    | UpToHash String+    | OneTag String+    | SeveralTag String+    | AfterTag String+    | UpToTag String+    | LastN Int+    | OneIndex Int+    | IndexRange Int Int+    | Context AbsolutePath+    deriving (Show) +makeMatcher :: String -> MatchFun -> Matcher+makeMatcher = MATCH+ -- | @applyMatcher@ applies a matcher to a patch.-applyMatcher :: Matcher p -> PatchInfoAnd p C(x y) -> Bool-applyMatcher (MATCH _ m) = m . seal2+applyMatcher :: Matchable p => Matcher -> p wX wY -> Bool+applyMatcher (MATCH _ (MatchFun m)) = m . seal2 -parseMatch :: Patchy p => PatchMatch -> Either String (MatchFun p)-parseMatch (PatternMatch s) =-    case parse matchParser "match" s of-    Left err -> Left $ "Invalid -"++"-match pattern '"++s+++parseMatch :: String -> Either String Matcher+parseMatch pattern =+    case parse matchParser "match" pattern of+    Left err -> Left $ "Invalid --match pattern '"++ pattern ++                 "'.\n"++ unlines (map ("    "++) $ lines $ show err) -- indent-    Right m -> Right m+    Right m -> Right (makeMatcher pattern m) -matchPattern :: Patchy p => PatchMatch -> Matcher p-matchPattern p@(PatternMatch s) =-    case parseMatch p of+matchPattern :: String -> Matcher+matchPattern pattern =+    case parseMatch pattern of     Left err -> error err-    Right m -> makeMatcher s m+    Right m -> m -trivial :: Patchy p => MatchFun p-trivial = const True+matchParser :: CharParser st MatchFun+matchParser = submatcher <?> helpfulErrorMsg+  where+    submatcher = do+        m <- option matchAnyPatch submatch+        eof+        return m -matchParser :: Patchy p => CharParser st (MatchFun p)-matchParser =  do m <- option trivial submatch-                  eof-                  return m+    -- When using <?>, Parsec prepends "expecting " to the given error message,+    -- so the phrasing below makes sense.+    helpfulErrorMsg = "valid expressions over: "+                      ++ intercalate ", " (map (\(name, _, _, _, _) -> name) ps)+                      ++ "\nfor more help, see `darcs help patterns`." -submatch :: Patchy p => CharParser st (MatchFun p)-submatch = buildExpressionParser table match <?> "match rule"+    ps = primitiveMatchers -table :: OperatorTable Char st (MatchFun p)+    -- matchAnyPatch is returned if submatch fails without consuming any+    -- input, i.e. if we pass --match '', we want to match anything.+    matchAnyPatch = MatchFun (const True)++submatch :: CharParser st MatchFun+submatch = buildExpressionParser table match++table :: OperatorTable Char st MatchFun table   = [ [prefix "not" negate_match,              prefix "!" negate_match ]           , [binary "||" or_match,@@ -93,141 +231,480 @@              binary "&&" and_match,             binary "and" and_match ]           ]-    where binary name fun =-              Infix (do _ <- trystring name-                        spaces-                        return fun) AssocLeft-          prefix  name fun = Prefix $ do _ <- trystring name+    where binary name fun = Infix (tryNameAndUseFun name fun) AssocLeft+          prefix name fun = Prefix $ tryNameAndUseFun name fun+          tryNameAndUseFun name fun = do _ <- trystring name                                          spaces                                          return fun-          negate_match a p = not (a p)-          or_match m1 m2 p = (m1 p) || (m2 p)-          and_match m1 m2 p = (m1 p) && (m2 p)+          negate_match (MatchFun m) = MatchFun $ \p -> not (m p)+          or_match (MatchFun m1) (MatchFun m2) = MatchFun $ \p -> m1 p || m2 p+          and_match (MatchFun m1) (MatchFun m2) = MatchFun $ \p -> m1 p && m2 p  trystring :: String -> CharParser st String trystring s = try $ string s -match :: Patchy p => CharParser st (MatchFun p)-match = between spaces spaces-        (parens submatch-         <|> choice matchers_-         <?> "simple match")-        where matchers_ = map createMatchHelper primitiveMatchers-+match :: CharParser st MatchFun+match = between spaces spaces (parens submatch <|> choice matchers_)+  where+    matchers_ = map createMatchHelper primitiveMatchers -createMatchHelper :: (String, String, [String], String -> MatchFun p)-                  -> CharParser st (MatchFun p)-createMatchHelper (key,_,_,matcher) =+createMatchHelper :: (String, String, String, [String], String -> MatchFun)+                  -> CharParser st MatchFun+createMatchHelper (key,_,_,_,matcher) =   do _ <- trystring key      spaces      q <- quoted      return $ matcher q --- FIXME: would this be better defined in Darcs.Commands.Help?--- | The string that is emitted when the user runs @darcs help --match@.-helpOnMatchers :: String-helpOnMatchers = unlines $+-- | The string that is emitted when the user runs @darcs help patterns@.+helpOnMatchers :: [String]+helpOnMatchers =   ["Selecting Patches:",    "",-   "The --patches option yields patches with names matching an `extended'",+   "The --patches option yields patches with names matching an *extended*",    "regular expression.  See regex(7) for details.  The --matches option",    "yields patches that match a logical (Boolean) expression: one or more",    "primitive expressions combined by grouping (parentheses) and the",    "complement (not), conjunction (and) and disjunction (or) operators.",    "The C notation for logic operators (!, && and ||) can also be used.",    "",-   " --patches=regex is a synonym for --matches='name regex'",-   " --from-patch and --to-patch are synonyms for --from-match='name... and --to-match='name...",-   " --from-patch and --to-match can be unproblematically combined:",-   " darcs changes --from-patch='html.*documentation' --to-match='date 20040212'",+   "    --patches=regex is a synonym for --matches='name regex'",+   "    --hash=HASH is a synonym for --matches='hash HASH'",+   "    --from-patch and --to-patch are synonyms for",+   "      --from-match='name... and --to-match='name...",+   "    --from-hash and --to-hash are synonyms for",+   "      --from-match='hash...' and --to-match='hash...'",+   "    sensible combinations of --from-* and --to-* options are possible:",+   "      `darcs log --from-patch='html.*docu' --to-match='date 20040212'`",+   "      `darcs log --from-hash=368089c6969 --to-patch='^fix.*renamed or moved\\.$'`",    "",-   "The following primitive Boolean expressions are supported:"]+   "The following primitive Boolean expressions are supported:"+   ,""]   ++ keywords-  ++ ["", "Here are some examples:"]+  ++ ["", "Here are some examples:", ""]   ++ examples-  where -- This type signature exists to appease GHC.-        ps :: [(String, String, [String], String -> MatchFun DummyPatch)]-        ps = primitiveMatchers-        keywords = [showKeyword k d | (k,d,_,_) <- ps]-        examples = [showExample k e | (k,_,es,_) <- ps, e <- es]+  where ps = primitiveMatchers+        keywords = [showKeyword (unwords [k,a]) d | (k,a,d,_,_) <- ps]+        examples = [showExample k e | (k,_,_,es,_) <- ps, e <- es]         showKeyword keyword description =-            -- FIXME: it would be nice to have a variable name here:-            -- "author REGEX - match against author (email address)"-            -- or "exact STRING - match against exact patch name".-            "  " ++ keyword ++ " - " ++ description ++ "."+            "    " ++ keyword ++ " - " ++ description ++ "."         showExample keyword example =-            -- FIXME: this string is long, and its not a use case I've-            -- ever seen in practice.  Can we use something else,-            -- like "darcs changes --matches"? --twb, 2008-12-28-            "  darcs annotate --summary --match "+            "    darcs log --match "             ++ "'" ++ keyword ++ " " ++ example ++ "'" -primitiveMatchers :: Patchy p => [(String, String, [String], String -> MatchFun p)]-                     -- ^ keyword (operator), help description, list+primitiveMatchers :: [(String, String, String, [String], String -> MatchFun)]+                     -- ^ keyword (operator), argument name, help description, list                      -- of examples, matcher function primitiveMatchers =- [ ("exact", "check a literal string against the patch name"+ [ ("exact", "STRING", "check literal STRING is equal to patch name"            , ["\"Resolve issue17: use dynamic memory allocation.\""]            , exactmatch )- , ("name", "check a regular expression against the patch name"+ , ("name", "REGEX", "match REGEX against patch name"           , ["issue17", "\"^[Rr]esolve issue17\\>\""]-          , mymatch )- , ("author", "check a regular expression against the author name"+          , namematch )+ , ("author", "REGEX", "match REGEX against patch author"             , ["\"David Roundy\"", "droundy", "droundy@darcs.net"]             , authormatch )- , ("hunk", "check a regular expression against the contents of a hunk patch"+ , ("hunk", "REGEX", "match REGEX against contents of a hunk patch"             , ["\"foo = 2\"", "\"^instance .* Foo where$\""]             , hunkmatch )- , ("comment", "check a regular expression against the log message"+ , ("comment", "REGEX", "match REGEX against the full log message"          , ["\"prevent deadlocks\""]          , logmatch )- , ("hash",  "match the darcs hash for a patch"-          ,  ["20040403105958-53a90-c719567e92c3b0ab9eddd5290b705712b8b918ef"-             ,"c719567e92c3b0ab9eddd5290b705712b8b918ef"-             ,"c719567e"]+ , ("hash", "HASH", "match HASH against (a prefix of) the hash of a patch"+          ,  ["c719567e92c3b0ab9eddd5290b705712b8b918ef","c7195"]           ,  hashmatch )- , ("date", "match the patch date"+ , ("date", "DATE", "match DATE against the patch date"           , ["\"2006-04-02 22:41\"", "\"tea time yesterday\""]           , datematch )- , ("touch", "match file paths for a patch"+ , ("touch", "REGEX", "match file paths for a patch"           , ["src/foo.c", "src/", "\"src/*.(c|h)\""]           , touchmatch ) ] -parens :: CharParser st (MatchFun p)-       -> CharParser st (MatchFun p)-parens p  = between (string "(") (string ")") p+parens :: CharParser st MatchFun+       -> CharParser st MatchFun+parens = between (string "(") (string ")")  quoted :: CharParser st String quoted = between (char '"') (char '"')                  (many $ do { _ <- char '\\' -- allow escapes-                            ; try (oneOf ['\\', '"']) <|> return '\\'+                            ; try (oneOf "\\\"") <|> return '\\'                             }-                         <|>  noneOf ['"'])+                         <|>  noneOf "\"")          <|> between spaces spaces (many $ noneOf " ()")          <?> "string" -mymatch, exactmatch, authormatch, hunkmatch, hashmatch, datematch, touchmatch :: Patchy p => String -> MatchFun p+datematch, hashmatch, authormatch, exactmatch, namematch, logmatch,+  hunkmatch, touchmatch :: String -> MatchFun -mymatch r (Sealed2 hp) = isJust $ matchRegex (mkRegex r) $ justName (info hp)+namematch r =+  MatchFun $ \(Sealed2 hp) ->+    isJust $ matchRegex (mkRegex r) $ justName (ident hp) -exactmatch r (Sealed2 hp) = r == (justName (info hp))+exactmatch r = MatchFun $ \(Sealed2 hp) -> r == justName (ident hp) -authormatch a (Sealed2 hp) = isJust $ matchRegex (mkRegex a) $ justAuthor (info hp)+authormatch a =+  MatchFun $ \(Sealed2 hp) ->+    isJust $ matchRegex (mkRegex a) $ justAuthor (ident hp) -logmatch :: Patchy p => String -> MatchFun p-logmatch l (Sealed2 hp) = isJust $ matchRegex (mkRegex l) $ justLog (info hp)+logmatch l =+  MatchFun $ \(Sealed2 hp) ->+    isJust $ matchRegex (mkRegex l) $ justLog (ident hp) -hunkmatch r (Sealed2 hp) = let patch = patchcontents $ hopefully hp-                               regexMatcher = isJust . (matchRegex (mkRegex r) . BC.unpack)-                           in hunkMatches regexMatcher patch+hunkmatch r =+  MatchFun $ \(Sealed2 hp) ->+    let regexMatcher = isJust . matchRegex (mkRegex r) . BC.unpack+     in hunkMatches regexMatcher hp -hashmatch h (Sealed2 hp) = let rh = makeFilename (info hp) in-                                  (rh == h) || (rh == h++".gz")-                                            || (h `isPrefixOf` drop 21 rh)-                           -- enable matching on (prefix of) third part, like in darcs 2.10+hashmatch h =+  MatchFun $ \(Sealed2 hp) ->+    let rh = show $ makePatchname (ident hp)+        lh = map toLower h+     in (lh `isPrefixOf` rh) || (lh == rh ++ ".gz") -datematch d (Sealed2 hp) = let dm = unsafePerformIO $ parseDateMatcher d-                                  in dm $ piDate (info hp)+datematch d =+  MatchFun $ \(Sealed2 hp) ->+    let dm = unsafePerformIO $ parseDateMatcher d+     in dm $ piDate (ident hp) -touchmatch r (Sealed2 hp) = let files = listTouchedFiles $ patchcontents $ hopefully hp-                            in or $ map (isJust . matchRegex (mkRegex r)) files+touchmatch r =+  MatchFun $ \(Sealed2 hp) ->+    let files = listTouchedFiles hp+     in any (isJust . matchRegex (mkRegex r)) (map (anchorPath ".") files)++-- | @haveNonrangeMatch flags@ tells whether there is a flag in+-- @flags@ which corresponds to a match that is "non-range". Thus,+-- @--match@, @--patch@, and @--hash@ make @haveNonrangeMatch@+-- true, but not @--from-patch@ or @--to-patch@.+haveNonrangeMatch :: [MatchFlag] -> Bool+haveNonrangeMatch fs = isJust (nonrangeMatcher fs)++data PatchSetMatch+  = IndexMatch Int+  | PatchMatch Matcher+  | TagMatch Matcher+  | ContextMatch AbsolutePath++patchSetMatch :: [MatchFlag] -> Maybe PatchSetMatch+patchSetMatch [] = Nothing+patchSetMatch (OneTag t:_) = strictJust $ TagMatch $ tagmatch t+patchSetMatch (OnePattern m:_) = strictJust $ PatchMatch $ matchPattern m+patchSetMatch (OnePatch p:_) = strictJust $ PatchMatch $ patchmatch p+patchSetMatch (OneHash h:_) = strictJust $ PatchMatch $ hashmatch' h+patchSetMatch (OneIndex n:_) = strictJust $ IndexMatch n+patchSetMatch (Context p:_) = strictJust $ ContextMatch p+patchSetMatch (_:fs) = patchSetMatch fs++-- | @firstMatch fs@ tells whether @fs@ implies a "first match", that+-- is if we match against patches from a point in the past on, rather+-- than against all patches since the creation of the repository.+firstMatch :: [MatchFlag] -> Bool+firstMatch fs = isJust (hasLastn fs)+                 || isJust (firstMatcher fs)+                 || isJust (hasIndexRange fs)++-- | @secondMatch fs@ tells whether @fs@ implies a "second match", that+-- is if we match against patches up to a point in the past on, rather+-- than against all patches until now.+secondMatch :: [MatchFlag] -> Bool+secondMatch fs =+  isJust (secondMatcher fs) ||+  isJust (hasIndexRange fs)++checkMatchSyntax :: [MatchFlag] -> IO ()+checkMatchSyntax opts =+  case getMatchPattern opts of+    Nothing -> return ()+    Just p ->+      either+        fail+        (const $ return ())+        (parseMatch p)++getMatchPattern :: [MatchFlag] -> Maybe String+getMatchPattern [] = Nothing+getMatchPattern (OnePattern m:_) = Just m+getMatchPattern (SeveralPattern m:_) = Just m+getMatchPattern (AfterPattern m:_) = Just m+getMatchPattern (UpToPattern m:_) = Just m+getMatchPattern (_:fs) = getMatchPattern fs++tagmatch :: String -> Matcher+tagmatch r = makeMatcher ("tag-name "++r) (MatchFun tm)+  where+    tm (Sealed2 p) =+      case piTag (ident p) of+        Just t -> isJust (matchRegex (mkRegex r) t)+        Nothing -> False++patchmatch :: String -> Matcher+patchmatch r = makeMatcher ("patch-name "++r) (namematch r)++hashmatch' :: String -> Matcher+hashmatch' r = makeMatcher ("hash "++r) (hashmatch r)+++-- | strictJust is a strict version of the Just constructor, used to ensure+-- that if we claim we've got a pattern match, that the pattern will+-- actually match (rathern than fail to compile properly).+strictJust :: a -> Maybe a+strictJust x = Just $! x++-- | @nonrangeMatcher@ is the criterion that is used to match against+-- patches in the interval. It is 'Just m' when the @--patch@, @--match@,+-- @--tag@ options are passed (or their plural variants).+nonrangeMatcher :: [MatchFlag] -> Maybe Matcher+nonrangeMatcher [] = Nothing+nonrangeMatcher (OnePattern m:_) = strictJust $ matchPattern m+nonrangeMatcher (OneTag t:_) = strictJust $ tagmatch t+nonrangeMatcher (OnePatch p:_) = strictJust $ patchmatch p+nonrangeMatcher (OneHash h:_) = strictJust $ hashmatch' h+nonrangeMatcher (SeveralPattern m:_) = strictJust $ matchPattern m+nonrangeMatcher (SeveralTag t:_) = strictJust $ tagmatch t+nonrangeMatcher (SeveralPatch p:_) = strictJust $ patchmatch p+nonrangeMatcher (_:fs) = nonrangeMatcher fs++-- | @firstMatcher@ returns the left bound of the matched interval.+-- This left bound is also specified when we use the singular versions+-- of @--patch@, @--match@ and @--tag@. Otherwise, @firstMatcher@+-- returns @Nothing@.+firstMatcher :: [MatchFlag] -> Maybe Matcher+firstMatcher [] = Nothing+firstMatcher (OnePattern m:_) = strictJust $ matchPattern m+firstMatcher (AfterPattern m:_) = strictJust $ matchPattern m+firstMatcher (AfterTag t:_) = strictJust $ tagmatch t+firstMatcher (OnePatch p:_) = strictJust $ patchmatch p+firstMatcher (AfterPatch p:_) = strictJust $ patchmatch p+firstMatcher (OneHash h:_) = strictJust $ hashmatch' h+firstMatcher (AfterHash h:_) = strictJust $ hashmatch' h+firstMatcher (_:fs) = firstMatcher fs++firstMatcherIsTag :: [MatchFlag] -> Bool+firstMatcherIsTag [] = False+firstMatcherIsTag (AfterTag _:_) = True+firstMatcherIsTag (_:fs) = firstMatcherIsTag fs++secondMatcher :: [MatchFlag] -> Maybe Matcher+secondMatcher [] = Nothing+secondMatcher (OnePattern m:_) = strictJust $ matchPattern m+secondMatcher (UpToPattern m:_) = strictJust $ matchPattern m+secondMatcher (OnePatch p:_) = strictJust $ patchmatch p+secondMatcher (UpToPatch p:_) = strictJust $ patchmatch p+secondMatcher (OneHash h:_) = strictJust $ hashmatch' h+secondMatcher (UpToHash h:_) = strictJust $ hashmatch' h+secondMatcher (UpToTag t:_) = strictJust $ tagmatch t+secondMatcher (_:fs) = secondMatcher fs++secondMatcherIsTag :: [MatchFlag] -> Bool+secondMatcherIsTag [] = False+secondMatcherIsTag (UpToTag _:_) = True+secondMatcherIsTag (_:fs) = secondMatcherIsTag fs++-- | Whether a patch matches the given 'MatchFlag's. This should be+-- invariant under inversion:+--+-- prop> matchAPatch (invert p) = matchAPatch p+matchAPatch :: Matchable p => [MatchFlag] -> p wX wY -> Bool+matchAPatch fs p =+  case nonrangeMatcher fs of+    Nothing -> True+    Just m -> applyMatcher m p++-- | @hasLastn fs@ return the @--last@ argument in @fs@, if any.+hasLastn :: [MatchFlag] -> Maybe Int+hasLastn [] = Nothing+hasLastn (LastN (-1):_) = error "--last requires a positive integer argument."+hasLastn (LastN n:_) = Just n+hasLastn (_:fs) = hasLastn fs++hasIndexRange :: [MatchFlag] -> Maybe (Int,Int)+hasIndexRange [] = Nothing+hasIndexRange (IndexRange x y:_) = Just (x,y)+hasIndexRange (_:fs) = hasIndexRange fs++-- | @matchFirstPatchset fs ps@ returns the part of @ps@ before its+-- first matcher, ie the one that comes first dependencywise. Hence,+-- patches in @matchFirstPatchset fs ps@ are the context for the ones+-- we want.+matchFirstPatchset :: MatchableRP p+                   => [MatchFlag] -> PatchSet p wStart wX+                   -> Maybe (SealedPatchSet p wStart)+matchFirstPatchset fs patchset+  | Just n <- hasLastn fs = Just $ patchSetDrop n patchset+  | Just (_, b) <- hasIndexRange fs = Just $ patchSetDrop b patchset+  | Just m <- firstMatcher fs =+    Just $ unseal (patchSetDrop 1) $+    if firstMatcherIsTag fs+      then getMatchingTag m patchset+      else matchAPatchset m patchset+  | otherwise = Nothing++-- | @matchSecondPatchset fs ps@ returns the part of @ps@ before its+-- second matcher, ie the one that comes last dependencywise.+matchSecondPatchset :: MatchableRP p+                    => [MatchFlag] -> PatchSet p wStart wX+                    -> Maybe (SealedPatchSet p wStart)+matchSecondPatchset fs ps+  | Just (a, _) <- hasIndexRange fs = Just $ patchSetDrop (a - 1) ps+  | Just m <- secondMatcher fs =+    Just $+    if secondMatcherIsTag fs+      then getMatchingTag m ps+      else matchAPatchset m ps+  | otherwise = Nothing++-- | Split on the second matcher. Note that this picks up the first match+-- starting from 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 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, the second element is the+                                      --  patches after it+splitSecondFL extract fs ps =+   case hasIndexRange fs of+   Just _ -> -- selecting the last n doesn't really make sense if we're starting+             -- from the earliest patches+             error "index matches not supported by splitSecondPatchesFL"+   Nothing ->+     case secondMatcher fs of+     Nothing -> error "Couldn't splitSecondPatches"+     Just m -> splitMatchFL extract m ps++splitMatchFL+  :: Matchable p+  => (forall wA wB. q wA wB -> Sealed2 p)+  -> Matcher+  -> FL q wX wY+  -> (FL q :> FL q) wX wY+splitMatchFL _extract m NilFL = error $ "Couldn't find a patch matching " ++ show m+splitMatchFL extract m (p :>: ps)+   | unseal2 (applyMatcher m) . extract $ p = (p :>: NilFL) :> ps+   | otherwise = case splitMatchFL extract m ps of+                    before :> after -> (p :>: before) :> after++-- | Using a special exception type here means that is is treated as+-- regular failure, and not as a bug in Darcs.+data MatchFailure = MatchFailure String+  deriving Typeable++instance Exception MatchFailure++instance Show MatchFailure where+  show (MatchFailure m) =+    "Couldn't find a patch matching " ++ m++-- | @matchAPatchset m ps@ returns a prefix of @ps@+-- ending in a patch matching @m@, and calls 'error' if there is none.+matchAPatchset+  :: MatchableRP p+  => Matcher+  -> PatchSet p wStart wX+  -> SealedPatchSet p wStart+matchAPatchset m (PatchSet NilRL NilRL) =+  throw $ MatchFailure $ show m+matchAPatchset m (PatchSet (ts :<: Tagged ps t _) NilRL) =+  matchAPatchset m (PatchSet ts (ps :<: t))+matchAPatchset m (PatchSet ts (ps :<: p))+  | applyMatcher m p = seal (PatchSet ts (ps :<: p))+  | otherwise = matchAPatchset m (PatchSet ts ps)++splitOnMatchingTag :: MatchableRP p+                   => Matcher+                   -> PatchSet p wStart wX+                   -> PatchSet p wStart wX+splitOnMatchingTag _ s@(PatchSet NilRL NilRL) = s+splitOnMatchingTag m s@(PatchSet (ts :<: Tagged ps t _) NilRL)+    | applyMatcher m t = s+    | otherwise = splitOnMatchingTag m (PatchSet ts (ps:<:t))+splitOnMatchingTag m (PatchSet ts (ps:<:p))+    -- found a non-clean tag, need to commute out the things that it doesn't depend on+    | applyMatcher m p =+        case splitOnTag (info p) (PatchSet ts (ps:<:p)) of+          Just x -> x+          Nothing -> error "splitOnTag failed"+    | otherwise =+        case splitOnMatchingTag m (PatchSet ts ps) of+          PatchSet ts' ps' -> PatchSet ts' (ps' :<: p)++-- | @getMatchingTag m ps@, where @m@ is a 'Matcher' which matches tags+-- returns a 'SealedPatchSet' containing all patches in the last tag which+-- matches @m@. Last tag means the most recent tag in repository order,+-- i.e. the last one you'd see if you ran darcs log -t @m@. Calls+-- 'error' if there is no matching tag.+getMatchingTag :: MatchableRP p+               => Matcher+               -> PatchSet p wStart wX+               -> SealedPatchSet p wStart+getMatchingTag m ps =+  case splitOnMatchingTag m ps of+    PatchSet NilRL _ -> throw $ userError $ "Couldn't find a tag matching " ++ show m+    PatchSet ps' _ -> seal $ PatchSet ps' NilRL++-- | Rollback (i.e. apply the inverse) of what remains of a 'PatchSet' after we+-- extract a 'PatchSetMatch'. This is the counterpart of 'getOnePatchset' and+-- is used to create a matching state. In particular, if the match is --index=n+-- then rollback the last (n-1) patches; if the match is --tag, then rollback+-- patches that are not depended on by the tag; otherwise rollback patches that+-- follow the latest matching patch.+rollbackToPatchSetMatch :: ( ApplyMonad (ApplyState p) m+                           , MatchableRP p, ApplyState p ~ Tree+                           )+                        => PatchSetMatch+                        -> PatchSet p Origin wX+                        -> m ()+rollbackToPatchSetMatch psm repo =+  case psm of+    IndexMatch n -> applyNInv (n-1) repo+    TagMatch m ->+      case splitOnMatchingTag m repo of+        PatchSet NilRL _ -> throw $ MatchFailure $ show m+        PatchSet _ extras -> unapply extras+    PatchMatch m -> applyInvToMatcher m repo+    ContextMatch _ -> error "rollbackToPatchSetMatch: unexpected context match"++-- | @applyInvToMatcher@ m ps applies the inverse of the patches in @ps@,+-- starting at the end, until we hit a patch that matches the 'Matcher' @m@.+applyInvToMatcher :: (MatchableRP p, ApplyMonad (ApplyState p) m)+                  => Matcher+                  -> PatchSet p Origin wX+                  -> m ()+applyInvToMatcher m (PatchSet NilRL NilRL) =+  throw $ MatchFailure $ show m+applyInvToMatcher m (PatchSet (ts :<: Tagged ps t _) NilRL) =+  applyInvToMatcher m (PatchSet ts (ps :<: t))+applyInvToMatcher m (PatchSet xs (ps :<: p))+  | applyMatcher m p = return ()+  | otherwise = unapply p >> applyInvToMatcher m (PatchSet xs ps)++-- | @applyNInv@ n ps applies the inverse of the last @n@ patches of @ps@.+applyNInv :: (MatchableRP p, ApplyMonad (ApplyState p) m)+          => Int -> PatchSet p Origin wX -> m ()+applyNInv n _ | n <= 0 = return ()+applyNInv _ (PatchSet NilRL NilRL) = throw $ userError "Index out of range"+applyNInv n (PatchSet (ts :<: Tagged ps t _) NilRL) =+  applyNInv n (PatchSet ts (ps :<: t))+applyNInv n (PatchSet xs (ps :<: p)) =+  unapply p >> applyNInv (n - 1) (PatchSet xs ps)++-- | matchingHead returns the repository up to some tag. The tag t is the last+-- tag such that there is a patch after t that is matched by the user's query.+matchingHead :: forall p wR. MatchableRP p+             => [MatchFlag] -> PatchSet p Origin wR+             -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR+matchingHead matchFlags set =+    case mh set of+        (start :> patches) -> start :> reverseRL patches+  where+    mh :: forall wX . PatchSet p Origin wX+       -> (PatchSet p :> RL (PatchInfoAnd p)) Origin wX+    mh s@(PatchSet _ x)+        | or (mapRL (matchAPatch matchFlags) x) = contextPatches s+    mh (PatchSet (ts :<: Tagged ps t _) x) =+        case mh (PatchSet ts (ps :<: t)) of+            (start :> patches) -> start :> patches +<+ x+    mh ps = ps :> NilRL
− src/Darcs/Patch/MatchData.hs 
@@ -1,28 +0,0 @@--- Copyright (C) 2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Patch.MatchData ( PatchMatch(..), patchMatch,-                      ) where--data PatchMatch = PatternMatch String-                  deriving ( Eq )--instance Show PatchMatch where-    show (PatternMatch m) = "pattern " ++ show m--patchMatch :: String -> PatchMatch-patchMatch s = PatternMatch s
src/Darcs/Patch/Merge.hs view
@@ -1,5 +1,3 @@-#include "gadts.h"- -- | -- Module      : Darcs.Patch.Merge -- Maintainer  : darcs-devel@darcs.net@@ -7,47 +5,221 @@ -- Portability : portable  module Darcs.Patch.Merge-    (-      Merge(..)+    ( -- * Classes+      CleanMerge(..)+    , Merge(..)+      -- * Functions+    , selfMerger+    , swapMerger+    , mergerIdFL+    , mergerFLId+    , mergerFLFL+    , cleanMergeFL     , mergeFL+    , swapMerge+    , swapCleanMerge+    , mergeList+      -- * Properties+    , prop_mergeSymmetric+    , prop_mergeCommute     ) where +import Control.Monad ( foldM ) -import Data.Maybe ( fromJust )+import Darcs.Prelude -import Darcs.Patch.Commute ( Commute )-import Darcs.Witnesses.Ordered ( (:\/:)(..), (:/\:)(..),-                                 FL(..), RL,-                                 reverseFL, reverseRL-                               )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.CommuteFn ( MergeFn, PartialMergeFn )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), isIsEq )+import Darcs.Patch.Witnesses.Ordered+    ( (:\/:)(..)+    , (:/\:)(..)+    , FL(..)+    , (:>)(..)+    , (+>+)+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) +{- | Class of patches that can, possibly, be merged cleanly, that is,+without conflict. --- | Things that can always be merged-class Commute p => Merge p where-    merge :: (p :\/: p) C(x y)-          -> (p :/\: p) C(x y)+Every patch type can be made an instance of 'CleanMerge' in a trivial way by+defining @'cleanMerge' _ = 'Nothing'@, which vacuously conforms to all+required laws. +Instances should obey the following laws: -instance Merge p => Merge (FL p) where-    merge (NilFL :\/: x) = x :/\: NilFL-    merge (x :\/: NilFL) = NilFL :/\: x-    merge ((x:>:xs) :\/: ys) = fromJust $ do-        ys' :/\: x' <- return $ mergeFL (x :\/: ys)-        xs' :/\: ys'' <- return $ merge (ys' :\/: xs)-        return (ys'' :/\: (x' :>: xs'))+[/symmetry/] +    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') <=> cleanMerge (q :\/: p) == Just (p' :/\: q') -instance Merge p => Merge (RL p) where-    merge (x :\/: y) = case merge (reverseRL x :\/: reverseRL y) of-                       (ry' :/\: rx') -> reverseFL ry' :/\: reverseFL rx'+If an instance @'Commute' p@ exists, then we also require +[/merge-commute/] +    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') ==> commute (p :> q') == Just (q :> p')++    that is, the two branches of a clean merge commute to each other.++If an instance @'Invert' p@ exists, then we also require++[/square-merge/]++    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') => cleanMerge (invert p :\/: q') == Just (q :/\: invert p')++    Here is a picture that explains why we call this /square-merge/:++    >     A---p--->X          A<--p^---X+    >     |        |          |        |+    >     |        |          |        |+    >     q        q'   =>    q        q'+    >     |        |          |        |+    >     v        v          v        v+    >     Y---p'-->B          Y<--p'^--B++-}+class CleanMerge p where+  cleanMerge :: (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)++instance CleanMerge p => CleanMerge (FL p) where+  cleanMerge (NilFL :\/: x) = return $ x :/\: NilFL+  cleanMerge (x :\/: NilFL) = return $ NilFL :/\: x+  cleanMerge ((x :>: xs) :\/: ys) = do+    ys' :/\: x' <- cleanMergeFL (x :\/: ys)+    xs' :/\: ys'' <- cleanMerge (ys' :\/: xs)+    return $ ys'' :/\: (x' :>: xs')++-- | Cleanly merge a single patch with an 'FL' of patches.+cleanMergeFL :: CleanMerge p => PartialMergeFn p (FL p)+cleanMergeFL (p :\/: NilFL) = return $ NilFL :/\: p+cleanMergeFL (p :\/: (x :>: xs)) = do+  x' :/\: p'  <- cleanMerge (p :\/: x)+  xs' :/\: p'' <- cleanMergeFL (p' :\/: xs)+  return $ (x' :>: xs') :/\: p''++{- | Patches that can always be merged, even if they conflict.++Instances should obey the following laws:++[/symmetry/]++    prop> merge (p :\/: q) == q' :/\: p' <=> merge (q :\/: p) == p' :/\: q'++[/merge-commute/]++    prop> merge (p :\/: q) == q' :/\: p' ==> commute (p :> q') == Just (q :> p')++    that is, the two branches of a merge commute to each other.++[/extension/]++    prop> cleanMerge (p :\/: q) == Just (q' :/\: p') => merge (p :\/: q) == q' :/\: p'++    that is, 'merge' is an extension of 'cleanMerge'.++-}+class CleanMerge p => Merge p where+    merge :: (p :\/: p) wX wY -> (p :/\: p) wX wY++-- | Synonym for 'merge'.+selfMerger :: Merge p => MergeFn p p+selfMerger = merge++instance Merge p => Merge (FL p) where+    merge = mergerFLFL merge+ mergeFL :: Merge p-        => (p :\/: FL p) C(x y)-        -> (FL p :/\: p) C(x y)-mergeFL (p :\/: NilFL) = NilFL :/\: p-mergeFL (p :\/: (x :>: xs)) = fromJust $ do-    x' :/\: p' <- return $ merge (p :\/: x)-    xs' :/\: p'' <- return $ mergeFL (p' :\/: xs)-    return ((x' :>: xs') :/\: p'')+        => (p :\/: FL p) wX wY+        -> (FL p :/\: p) wX wY+mergeFL = mergerIdFL merge +-- | Lift a merge function over @p :\/: q@+-- to a merge function over @p :\/: FL q@+mergerIdFL :: MergeFn p q -> MergeFn p (FL q)+mergerIdFL _mergeFn (p :\/: NilFL) = NilFL :/\: p+mergerIdFL  mergeFn (p :\/: (x :>: xs)) =+  case mergeFn (p :\/: x) of+    x' :/\: p' -> case mergerIdFL mergeFn (p' :\/: xs) of+      xs' :/\: p'' -> (x' :>: xs') :/\: p''++-- | Lift a merge function over @p :\/: q@+-- to a merge function over @FL p :\/: q@+mergerFLId :: MergeFn p q -> MergeFn (FL p) q+mergerFLId mergeFn = swapMerger (mergerIdFL (swapMerger mergeFn))++-- | Lift a merge function over @p :\/: q@+-- to a merge function over @FL p :\/: FL q@+mergerFLFL :: MergeFn p q -> MergeFn (FL p) (FL q)+mergerFLFL mergeFn = mergerIdFL (mergerFLId mergeFn)++-- | Swap the two patches, 'merge', then swap again. Used to exploit+-- 'prop_mergeSymmetric' when defining 'merge'.+swapMerge :: Merge p => (p :\/: p) wX wY -> (p :/\: p) wX wY+swapMerge = swapMerger merge++-- | Swap the two patches, apply an arbitrary merge function, then swap again.+swapMerger :: MergeFn p q -> MergeFn q p+swapMerger mergeFn (x :\/: y) = case mergeFn (y :\/: x) of x' :/\: y' -> y' :/\: x'++-- | Swap the two patches, 'cleanMerge', then swap again. Used to exploit+-- 'prop_cleanMergeSymmetric' when defining 'cleanMerge'.+swapCleanMerge :: CleanMerge p => (p :\/: p) wX wY -> Maybe ((p :/\: p) wX wY)+swapCleanMerge (x :\/: y) = do+  x' :/\: y' <- cleanMerge (y :\/: x)+  return $ y' :/\: x'++-- | Combine a list of patch sequences, all starting at the same state, into a+-- single sequence that also starts at the same state, using cleanMerge.+-- If the merge fails, we return the two sequences that+-- could not be merged so we can issue more detailed error messages.+mergeList :: CleanMerge p+          => [Sealed (FL p wX)]+          -> Either (Sealed (FL p wX), Sealed (FL p wX)) (Sealed (FL p wX))+mergeList = foldM mergeTwo (Sealed NilFL)+  where+    mergeTwo (Sealed ps) (Sealed qs) =+      case cleanMerge (ps :\/: qs) of+        Just (qs' :/\: _) -> Right $ Sealed $ ps +>+ qs'+        Nothing -> Left (Sealed ps, Sealed qs)++-- | This function serves no purpose except to demonstrate how merge together+-- with the square commute law allows us to commute any pair of adjacent+-- patches.+-- Note that using this function introduces inverse conflictors if the regular+-- commute would fail. This is problematic because it invalidates another+-- global invariant we rely on, namely that we can always drop (obliterate or+-- amend) patches from the end of a repo. This is because inverse conflictors+-- contain references to patches that come after it, so dropping them would+-- make the inverse conflictor inconsistent.+_forceCommute :: (Commute p, Merge p, Invert p) => (p :> p) wX wY -> (p :> p) wX wY+_forceCommute (p :> q) =+  case commute (p :> q) of+    Just (q' :> p') -> q' :> p'+    Nothing ->+      case merge (invert p :\/: q) of+        q' :/\: ip' -> q' :> invert ip'++-- | Whether the given pair of patches satisfies the /symmetry/ law.+prop_mergeSymmetric :: (Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool+prop_mergeSymmetric (p :\/: q) =+  case merge (p :\/: q) of+    q' :/\: p' ->+      case merge (q :\/: p) of+        p'' :/\: q'' ->+          isIsEq (q' =\/= q'') && isIsEq (p' =\/= p'')++-- | Whether the given pair of patches satisfies the /merge-commute/ law.+prop_mergeCommute :: (Commute p, Eq2 p, Merge p) => (p :\/: p) wX wY -> Bool+prop_mergeCommute (p :\/: q) =+  case merge (p :\/: q) of+    q' :/\: p' ->+      case commute (p :> q') of+        Nothing -> False+        Just (q'' :> p'') ->+          isIsEq (q'' =\/= q) && isIsEq (p'' =/\= p')+      &&+      case commute (q :> p') of+        Nothing -> False+        Just (p'' :> q'') ->+          isIsEq (p'' =\/= p) && isIsEq (q'' =/\= q')
src/Darcs/Patch/Named.hs view
@@ -15,51 +15,94 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}--#include "gadts.h"+-- | 'Named' patches group a set of changes with meta data ('PatchInfo') and+-- explicit dependencies (created using `darcs tag` or using --ask-deps).+--+-- While the data constructor 'NamedP' is exported for technical reasons, code+-- outside this modules should (and generally does) treat it as an abstract+-- data type. The only exception is the rebase implementation i.e. the modules+-- under "Darcs.Patch.Rebase". +{-# LANGUAGE UndecidableInstances #-} module Darcs.Patch.Named-       ( Named(..),-         infopatch,-         adddeps, namepatch, anonymous,-         getdeps,-         patch2patchinfo, patchname, patchcontents,-         fmapNamed, fmapFL_Named-       )-       where+    ( Named(..)+    -- treated as abstract data type except by Darcs.Patch.Rebase+    , infopatch+    , adddeps+    , setinfo+    , anonymous+    , HasDeps(..)+    , patch2patchinfo+    , patchname+    , patchcontents+    , fmapNamed+    , fmapFL_Named+    , mergerIdNamed+    , ShowDepsFormat(..)+    , ShowWhichDeps(..)+    , showDependencies+    ) where -import Prelude hiding ( pi )-import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts )-import Darcs.Patch.Effect ( Effect(effect, effectRL) )+import Darcs.Prelude++import Data.List.Ordered ( nubSort )+import qualified Data.Set as S++import Darcs.Patch.CommuteFn ( MergeFn, commuterIdFL, mergerIdFL )+import Darcs.Patch.Conflict ( Conflict(..), findConflicting )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.Effect ( Effect(effect) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Info ( PatchInfo, readPatchInfo, showPatchInfo, patchinfo,-                          humanFriendly, makePatchname, invertName )-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Patchy ( Patchy, Commute(..), Invert(..), Apply(..),-                            PatchInspect(..), ReadPatch(..) )-import Darcs.Patch.Prim ( PrimOf, PrimPatchBase )-import Darcs.Patch.ReadMonads ( ParserM, option, lexChar,+                          piName, displayPatchInfo, makePatchname )+import Darcs.Patch.Merge ( CleanMerge(..), Merge(..) )+import Darcs.Patch.Object ( ObjectId )+import Darcs.Patch.Apply ( Apply(..), ObjectIdOfPatch )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim(..) )+import Darcs.Util.Parser ( Parser, option, lexChar,                                 choice, skipWhile, anyChar ) import Darcs.Patch.Repair ( mapMaybeSnd, Repair(..), RepairToFL, Check(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), showNamedPrefix )-import Darcs.Patch.Summary ( plainSummary )+import Darcs.Patch.Show+    ( ShowContextPatch(..)+    , ShowPatch(..)+    , ShowPatchBasic(..)+    , ShowPatchFor(..)+    , displayPatch+    )+import Darcs.Patch.Summary+    ( Summary(..)+    , plainSummaryFL+    )+import Darcs.Patch.Unwind ( Unwind(..), squashUnwound ) import Darcs.Patch.Viewing () -- for ShowPatch FL instances -import Darcs.Witnesses.Eq ( MyEq(..) )-import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL, mapFL_FL )-import Darcs.Witnesses.Sealed ( Sealed, mapSeal )-import Darcs.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..), (:\/:)(..), (:/\:)(..)+    , FL(..), RL(..), mapFL, mapRL, mapFL_FL, mapRL_RL+    , (+<+), (+>+), concatRLFL, reverseFL+    , (+<<+), (+>>+), concatFL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed, mapSeal )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) -import Printer ( renderString, ($$), (<+>), (<>), prefix, text, vcat )+import Darcs.Util.IsoDate ( showIsoDateTime, theBeginning )+import Darcs.Util.Printer+    ( Doc, ($$), (<+>), text, vcat, cyanText, blueText, redText )  -- | The @Named@ type adds a patch info about a patch, that is a name.-data Named p C(x y) where+data Named p wX wY where     NamedP :: !PatchInfo            -> ![PatchInfo]-           -> !(FL p C(x y))-           -> Named p C(x y)+           -> !(FL p wX wY)+           -> Named p wX wY+   deriving Show -- ^ @NamedP info deps p@ represents patch @p@ with name -- @info@. @deps@ is a list of dependencies added at the named patch -- level, compared with the unnamed level (ie, dependencies added with@@ -70,8 +113,12 @@  instance Effect p => Effect (Named p) where     effect (NamedP _ _ p) = effect p-    effectRL (NamedP _ _ p) = effectRL p +type instance PatchId (Named p) = PatchInfo++instance Ident (Named p) where+    ident = patch2patchinfo+ instance IsHunk (Named p) where     isHunk _ = Nothing @@ -80,19 +127,18 @@ instance (ReadPatch p, PatchListFormat p) => ReadPatch (Named p) where  readPatch' = readNamed -readNamed :: (ReadPatch p, PatchListFormat p, ParserM m) => m (Sealed (Named p C(x )))-readNamed-          = do n <- readPatchInfo+readNamed :: (ReadPatch p, PatchListFormat p) => Parser (Sealed (Named p wX))+readNamed = do n <- readPatchInfo                d <- readDepends                p <- readPatch'                return $ (NamedP n d) `mapSeal` p -readDepends :: ParserM m => m [PatchInfo]+readDepends :: Parser [PatchInfo] readDepends =   option [] $ do lexChar '<'                  readPis -readPis :: ParserM m => m [PatchInfo]+readPis :: Parser [PatchInfo] readPis = choice [ do pi <- readPatchInfo                       pis <- readPis                       return (pi:pis)@@ -103,50 +149,54 @@ instance Apply p => Apply (Named p) where     type ApplyState (Named p) = ApplyState p     apply (NamedP _ _ p) = apply p+    unapply (NamedP _ _ p) = unapply p  instance RepairToFL p => Repair (Named p) where     applyAndTryToFix (NamedP n d p) = mapMaybeSnd (NamedP n d) `fmap` applyAndTryToFix p -namepatch :: Patchy p => String -> String -> String -> [String] -> FL p C(x y) -> IO (Named p C(x y))-namepatch date name author desc p-    | '\n' `elem` name = error "Patch names cannot contain newlines."-    | otherwise = do pinf <- patchinfo date name author desc-                     return $ NamedP pinf [] p--anonymous :: Patchy p => FL p C(x y) -> IO (Named p C(x y))-anonymous p = namepatch "today" "anonymous" "unknown" ["anonymous"] p+anonymous :: FromPrim p => FL (PrimOf p) wX wY -> IO (Named p wX wY)+anonymous ps = do+  info <- patchinfo (showIsoDateTime theBeginning) "anonymous" "unknown" ["anonymous"]+  return $ infopatch info ps -infopatch :: Patchy p => PatchInfo -> FL p C(x y) -> Named p C(x y)-infopatch pi p = NamedP pi [] p+infopatch :: forall p wX wY. FromPrim p => PatchInfo -> FL (PrimOf p) wX wY -> Named p wX wY+infopatch pi ps = NamedP pi [] (fromPrims pi ps) where -adddeps :: Named p C(x y) -> [PatchInfo] -> Named p C(x y)+adddeps :: Named p wX wY -> [PatchInfo] -> Named p wX wY adddeps (NamedP pi _ p) ds = NamedP pi ds p -getdeps :: Named p C(x y) -> [PatchInfo]-getdeps (NamedP _ ds _) = ds+setinfo :: PatchInfo -> Named p wX wY -> Named p wX wY+setinfo i (NamedP _ ds ps) = NamedP i ds ps -patch2patchinfo :: Named p C(x y) -> PatchInfo+-- | This slightly ad-hoc class is here so we can call 'getdeps' with patch+-- types that wrap a 'Named', such as 'RebaseChange'.+class HasDeps p where+  getdeps :: p wX wY -> [PatchInfo]++instance HasDeps (Named p) where+  getdeps (NamedP _ ds _) = ds++patch2patchinfo :: Named p wX wY -> PatchInfo patch2patchinfo (NamedP i _ _) = i -patchname :: Named p C(x y) -> String-patchname (NamedP i _ _) = makePatchname i+patchname :: Named p wX wY -> String+patchname (NamedP i _ _) = show $ makePatchname i -patchcontents :: Named p C(x y) -> FL p C(x y)+patchcontents :: Named p wX wY -> FL p wX wY patchcontents (NamedP _ _ p) = p -fmapNamed :: (FORALL(a b) p C(a b) -> q C(a b)) -> Named p C(x y) -> Named q C(x y)+patchcontentsRL :: RL (Named p) wX wY -> RL p wX wY+patchcontentsRL = concatRLFL . mapRL_RL patchcontents++fmapNamed :: (forall wA wB . p wA wB -> q wA wB) -> Named p wX wY -> Named q wX wY fmapNamed f (NamedP i deps p) = NamedP i deps (mapFL_FL f p) -fmapFL_Named :: (FL p C(x y) -> FL q C(x y)) -> Named p C(x y) -> Named q C(x y)+fmapFL_Named :: (FL p wA wB -> FL q wC wD) -> Named p wA wB -> Named q wC wD fmapFL_Named f (NamedP i deps p) = NamedP i deps (f p) -instance (Commute p, MyEq p) => MyEq (Named p) where-    unsafeCompare (NamedP n1 d1 p1) (NamedP n2 d2 p2) =-        n1 == n2 && d1 == d2 && unsafeCompare p1 p2--instance (Commute p, Invert p) => Invert (Named p) where-    invert (NamedP n d p)  = NamedP (invertName n) (map invertName d) (invert p)-+instance (Commute p, Eq2 p) => Eq2 (Named p) where+    unsafeCompare (NamedP n1 ds1 ps1) (NamedP n2 ds2 ps2) =+        n1 == n2 && ds1 == ds2 && unsafeCompare ps1 ps2  instance Commute p => Commute (Named p) where     commute (NamedP n1 d1 p1 :> NamedP n2 d2 p2) =@@ -155,45 +205,217 @@         else do (p2' :> p1') <- commute (p1 :> p2)                 return (NamedP n2 d2 p2' :> NamedP n1 d1 p1') +instance CleanMerge p => CleanMerge (Named p) where+    cleanMerge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2)+      | n1 == n2 = error "cannot cleanMerge identical Named patches"+      | otherwise = do+          p2' :/\: p1' <- cleanMerge (p1 :\/: p2)+          return $ NamedP n2 d2 p2' :/\: NamedP n1 d1 p1'+ instance Merge p => Merge (Named p) where     merge (NamedP n1 d1 p1 :\/: NamedP n2 d2 p2)-        = case merge (p1 :\/: p2) of-          (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1'+      | n1 == n2 = error "cannot merge identical Named patches"+      | otherwise =+          case merge (p1 :\/: p2) of+            (p2' :/\: p1') -> NamedP n2 d2 p2' :/\: NamedP n1 d1 p1' +-- Merge an unnamed patch with a named patch.+-- This operation is safe even if the first patch is named, as names can+-- never conflict with each other.+-- This is in contrast with commuterIdNamed which is not safe and hence+-- is defined closer to the code that uses it.+mergerIdNamed :: MergeFn p1 p2 -> MergeFn p1 (Named p2)+mergerIdNamed merger (p1 :\/: NamedP n2 d2 p2) =+   case mergerIdFL merger (p1 :\/: p2) of+     p2' :/\: p1' -> NamedP n2 d2 p2' :/\: p1'++{- | This instance takes care of handling the interaction between conflict+resolution and explicit dependencies. A conflict involves a set of two or+more patches and the general rule is that the conflict is considered+resolved if there is another (later) patch that (transitively) depends on+each of the (mutually) conflicting patches.++This principle extends to explicit dependencies between 'Named' patches. In+particular, recording a tag has the effect of resolving any as yet+unresolved conflicts in a repo.++In general a 'Named' patch contains multiple changes ( a "changeset").+Consider the named patches++@+  Named A [] a+  Named B [] (b1;b2)+  Named C [] c+  Named D [A,B] _+@++where, at the RepoPatch level, @a@ conflicts with @b1@, and @c@ with @b2@.+@D@ depends explicitly on both @A@ and @B@, so it fully covers the conflict+between @a@ and @b1@ and thus we would be justified to consider that+particular conflict as resolved. Unfortunately we cannot detect this at the+Named patch level because RepoPatchV1 and V2 have no notion of patch+identities. Thus, at the Named level the two underlying conflicts appear as+a single large conflict between the three named patches @A@, @B@, and @C@,+and this means that patch @D@ does /not/ count as a (partial) resolution+(even though it arguably should).++When we decide that a set of conflicting Named patches is resolved, we move+the RepoPatches contained in them to the context of the resolution. For all+other named patches, we must commute as much of their contents as possible+past the ones marked as resolved, using commutation at the RepoPatch level+(i.e. ignoring explicit dependencies). -}++instance ( Commute p+         , Conflict p+         , Summary p+         , PrimPatchBase p+         , PatchListFormat p+         , ShowPatch p+         ) =>+         Conflict (Named p) where+  isConflicted (NamedP _ _ ps) = or (mapFL isConflicted ps)+  resolveConflicts context patches =+    case separate S.empty [] context patches NilFL NilFL of+      resolved :> unresolved ->+        resolveConflicts (patchcontentsRL context +<<+ resolved) (reverseFL unresolved)+    where+      -- Separate the patch contents of an 'RL' of 'Named' patches into those+      -- we regard as resolved due to explicit dependencies and any others.+      -- Implicit dependencies are kept with the resolved patches. The first+      -- parameter accumulates the PatchInfo of patches which we consider+      -- resolved; the second one accumulates direct and indirect explicit+      -- dependencies for the patches we have traversed. The third parameter+      -- is the context, which is only needed as input to 'findConflicting'.+      separate+        :: S.Set PatchInfo    -- names of resolved Named patches so far+        -> [S.Set PatchInfo]  -- transitive explicit dependencies so far+        -> RL (Named p) w0 w1 -- context for Named patches+        -> RL (Named p) w1 w2 -- Named patches under consideration+        -> FL p w2 w3         -- result: resolved at RepoPatch layer so far+        -> FL p w3 w4         -- result: unresolved at RepoPatch layer so far+        -> (FL p :> FL p) w1 w4+      separate acc_res acc_deps ctx (ps :<: p@(NamedP name deps contents)) resolved unresolved+        | name `S.member` acc_res || isConflicted p+        , _ :> _ :> conflicting <- findConflicting (ctx +<+ ps) p+        , let conflict_ids = S.fromList $ name : mapRL ident conflicting+        , any (conflict_ids `S.isSubsetOf`) acc_deps =+          -- Either we already determined that p is considered resolved,+          -- or p is conflicted and all patches involved in the conflict are+          -- transitively explicitly depended upon by a single patch.+          -- The action is to regard everything in 'contents' as resolved.+          separate (acc_res `S.union` conflict_ids) (extend name deps acc_deps)+            ctx ps (contents +>+ resolved) unresolved+        | otherwise =+          -- Commute as much as we can of our patch 'contents' past 'resolved',+          -- without dragging dependencies along.+          -- To use existing tools for commutation means we have to+          -- commuteWhatWeCan 'resolved' backwards through the 'contents',+          -- now /with/ dragging dependencies along.+          case genCommuteWhatWeCanRL (commuterIdFL commute)+                (reverseFL contents :> resolved) of+            dragged :> resolved' :> more_unresolved ->+              separate acc_res (extend name deps acc_deps) ctx ps+                (dragged +>>+ resolved') (more_unresolved +>>+ unresolved)+      separate _ _ _ NilRL resolved unresolved = resolved :> unresolved++      -- Extend a list of sets of dependencies by adding the new list of+      -- dependencies to each set that contains the given 'name'. If 'name'+      -- does not occur in any of the sets, we add the dependencies as a new+      -- set to the list.+      -- Since we have to track whether 'name' was found in any of the input+      -- sets, this is not a straight-forward fold, so we use explicit+      -- recursion.+      extend :: Ord a => a -> [a] -> [S.Set a] -> [S.Set a]+      extend _ [] acc_deps = acc_deps+      extend name deps acc_deps = go False (S.fromList deps) acc_deps where+        go False new [] = [new]+        go True _ [] = []+        go found new (ds:dss)+          | name `S.member` ds = ds `S.union` new : go True new dss+          | otherwise = ds : go found new dss++instance (PrimPatchBase p, Unwind p) => Unwind (Named p) where+  fullUnwind (NamedP _ _ ps) = squashUnwound (mapFL_FL fullUnwind ps)+ instance PatchInspect p => PatchInspect (Named p) where     listTouchedFiles (NamedP _ _ p) = listTouchedFiles p     hunkMatches f (NamedP _ _ p) = hunkMatches f p -instance (CommuteNoConflicts p, Conflict p) => Conflict (Named p) where-    listConflictedFiles (NamedP _ _ p) = listConflictedFiles p-    resolveConflicts (NamedP _ _ p) = resolveConflicts p+instance Summary p => Summary (Named p) where+    conflictedEffect = conflictedEffect . patchcontents  instance Check p => Check (Named p) where     isInconsistent (NamedP _ _ p) = isInconsistent p +-- ForStorage: note the difference between use of <> when there are+-- no explicit dependencies vs. <+> when there are+showNamedPrefix :: ShowPatchFor -> PatchInfo -> [PatchInfo] -> Doc -> Doc+showNamedPrefix f@ForStorage n [] p =+    showPatchInfo f n <> p+showNamedPrefix f@ForStorage n d p =+    showPatchInfo f n+    $$ blueText "<"+    $$ vcat (map (showPatchInfo f) d)+    $$ blueText ">"+    <+> p+showNamedPrefix f@ForDisplay n [] p =+    showPatchInfo f n+    $$ p+showNamedPrefix f@ForDisplay n d p =+    showPatchInfo f n+    $$ showDependencies ShowNormalDeps ShowDepsVerbose d+    $$ p+ instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (Named p) where-    showPatch (NamedP n [] p) = showPatchInfo n <> showPatch p-    showPatch (NamedP n d p) = showNamedPrefix n d <+> showPatch p+    showPatch f (NamedP n d p) = showNamedPrefix f n d $ showPatch f p -instance (Apply p, CommuteNoConflicts p, Conflict p, IsHunk p, PatchListFormat p,+instance ( Apply p+         , IsHunk p+         , PatchListFormat p+         , ObjectId (ObjectIdOfPatch p)+         , ShowContextPatch p+         ) =>+         ShowContextPatch (Named p) where+    showPatchWithContextAndApply f (NamedP n d p) =+        showNamedPrefix f n d <$> showPatchWithContextAndApply f p++data ShowDepsFormat = ShowDepsVerbose | ShowDepsSummary deriving (Eq)++-- | Support for rebase+data ShowWhichDeps = ShowNormalDeps | ShowDroppedDeps deriving (Eq)++showDependencies :: ShowWhichDeps -> ShowDepsFormat -> [PatchInfo] -> Doc+showDependencies which format deps = vcat (map showDependency deps)+  where+    showDependency d =+      case format of+        ShowDepsVerbose ->+          mark which format <+> cyanText (show (makePatchname d)) $$+          text "  *" <+> text (piName d)+        ShowDepsSummary ->+          mark which format <+>+          cyanText (take 8 (show (makePatchname d))) <+> text (piName d)+    mark ShowNormalDeps ShowDepsVerbose = blueText "depend"+    mark ShowDroppedDeps ShowDepsVerbose = redText "dropped"+    mark ShowNormalDeps ShowDepsSummary = text "D"+    mark ShowDroppedDeps ShowDepsSummary = text "D!"++instance (Summary p, PatchListFormat p,           PrimPatchBase p, ShowPatch p) => ShowPatch (Named p) where-    showContextPatch (NamedP n [] p) = showContextPatch p >>= return . (showPatchInfo n <>)-    showContextPatch (NamedP n d p) = showContextPatch p >>= return . (showNamedPrefix n d <+>)-    description (NamedP n _ _) = humanFriendly n-    summary p = description p $$ text "" $$-                prefix "    " (plainSummary p) -- this isn't summary because summary does the-                                            -- wrong thing with (Named (FL p)) so that it can-                                            -- get the summary of a sequence of named patches-                                            -- right.-    summaryFL = vcat . mapFL summary-    showNicely p@(NamedP _ _ pt) = description p $$-                                   prefix "    " (showNicely pt)+    description (NamedP n _ _) = displayPatchInfo n+    summary (NamedP _ ds ps) =+        showDependencies ShowNormalDeps ShowDepsSummary ds $$ plainSummaryFL ps+    summaryFL nps =+        showDependencies ShowNormalDeps ShowDepsSummary ds $$ plainSummaryFL ps+      where+        ds = nubSort $ concat $ mapFL getdeps nps+        ps = concatFL $ mapFL_FL patchcontents nps+    content (NamedP _ ds ps) =+        showDependencies ShowNormalDeps ShowDepsVerbose ds $$ displayPatch ps -instance (PatchListFormat p, ShowPatch p) => Show (Named p C(x y)) where-    show = renderString . showPatch+instance Show2 p => Show1 (Named p wX) -instance (PatchListFormat p, ShowPatch p) => Show1 (Named p C(x)) where-    showDict1 = ShowDictClass+instance Show2 p => Show2 (Named p) -instance (PatchListFormat p, ShowPatch p) => Show2 (Named p) where-    showDict2 = ShowDictClass+instance PatchDebug p => PatchDebug (Named p)+
+ src/Darcs/Patch/Object.hs view
@@ -0,0 +1,49 @@+module Darcs.Patch.Object where++import Darcs.Prelude++import qualified Data.ByteString.Char8 as BC ( unpack )++import Darcs.Patch.Format ( FileNameFormat(..) )+import Darcs.Util.ByteString ( packStringToUTF8, encodeLocale )+import Darcs.Util.Path ( AnchoredPath, encodeWhite, anchorPath )+import Darcs.Util.Printer ( Doc, text, packedString )+import Darcs.Util.Tree ( Tree )++-- | Given a state type (parameterized over a monad m :: * -> *), this gives us+-- the type of the key with which we can lookup an item (or object) in the+-- state.+type family ObjectIdOf (state :: (* -> *) -> *)++-- | We require from such a key (an 'ObjectId') that it has a canonical way+-- to format itself to a 'Doc'. For historical reasons, this takes a parameter+-- of type 'FileNameFormat'.+class Eq oid => ObjectId oid where+  formatObjectId :: FileNameFormat -> oid -> Doc++type instance ObjectIdOf Tree = AnchoredPath++-- formatFileName is defined here only to avoid an import cycle++-- | Format a 'AnchoredPath' to a 'Doc' according to the given 'FileNameFormat'.+--+-- NOTE: This is not only used for display but also to format patch files. This is+--       why we have to do the white space encoding here.+--       See 'Darcs.Repository.Hashed.writePatchIfNecessary'.+--+-- Besides white space encoding, for 'FileNameFormatV2' we just pack it into a 'Doc'. For+-- 'FileNameFormatV1' we must emulate the non-standard darcs-1 encoding of file paths: it+-- is an UTF8 encoding of the raw byte stream, interpreted as code points.+--+-- See also 'Darcs.Patch.Show.readFileName'.+formatFileName :: FileNameFormat -> AnchoredPath -> Doc+formatFileName FileNameFormatV1 =+  packedString . packStringToUTF8 . BC.unpack . encodeLocale . encodeWhite . ap2fp+formatFileName FileNameFormatV2 = text . encodeWhite . ap2fp+formatFileName FileNameFormatDisplay = text . ap2fp++instance ObjectId AnchoredPath where+  formatObjectId = formatFileName++ap2fp :: AnchoredPath -> FilePath+ap2fp ap = "./" ++ anchorPath "" ap
− src/Darcs/Patch/OldDate.hs 
@@ -1,350 +0,0 @@--- Copyright (C) 2003 Peter Simons--- Copyright (C) 2003,2008 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- This module is intended to provide backwards-compatibility in the parsing--- of darcs patches.  In other words: don't change it, new features don't get--- added here.  The only user should be Darcs.Patch.Info.--module Darcs.Patch.OldDate ( readUTCDate, showIsoDateTime ) where--import Text.ParserCombinators.Parsec-import System.Time-import Data.Char ( toUpper, isDigit )-import Control.Monad ( liftM, liftM2 )-import qualified Data.ByteString.Char8 as B-import Data.Maybe ( fromMaybe )---- | Read/interpret a date string, assuming UTC if timezone---   is not specified in the string-readUTCDate :: String -> CalendarTime-readUTCDate = readDate 0--readDate :: Int -> String -> CalendarTime-readDate tz d =-             case parseDate tz d of-             Left e -> error e-             Right ct -> ct--parseDate :: Int -> String -> Either String CalendarTime-parseDate tz d =-              if length d >= 14 && B.all isDigit bd-              then Right $-                   CalendarTime (readI $ B.take 4 bd)-                                (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd)-                                (readI $ B.take 2 $ B.drop 6 bd) -- Day-                                (readI $ B.take 2 $ B.drop 8 bd) -- Hour-                                (readI $ B.take 2 $ B.drop 10 bd) -- Minute-                                (readI $ B.take 2 $ B.drop 12 bd) -- Second-                                0 Sunday 0 -- Picosecond, weekday and day of year unknown-                                "GMT" 0 False-              else let dt = do { x <- dateTime tz; eof; return x }-                   in case parse dt "" d of-                      Left e -> Left $ "bad date: "++d++" - "++show e-                      Right ct -> Right ct-  where bd = B.pack (take 14 d)-        readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)--showIsoDateTime :: CalendarTime -> String-showIsoDateTime ct = concat [ show $ ctYear ct-                            , twoDigit . show . (+1) . fromEnum $ ctMonth ct-                            , twoDigit . show $ ctDay ct-                            , twoDigit . show $ ctHour ct-                            , twoDigit . show $ ctMin ct-                            , twoDigit . show $ ctSec ct-                            ]-    where twoDigit []          = undefined-          twoDigit x@(_:[])    = '0' : x-          twoDigit x@(_:_:[])  = x-          twoDigit _           = undefined------- Parser Combinators ------------------------------------------------- |Case-insensitive variant of Parsec's 'char' function.--caseChar        :: Char -> GenParser Char a Char-caseChar c       = satisfy (\x -> toUpper x == toUpper c)---- |Case-insensitive variant of Parsec's 'string' function.--caseString      :: String -> GenParser Char a ()-caseString cs    = mapM_ caseChar cs <?> cs---- |Match a parser at least @n@ times.--manyN           :: Int -> GenParser a b c -> GenParser a b [c]-manyN n p-    | n <= 0     = return []-    | otherwise  = liftM2 (++) (count n p) (many p)---- |Match a parser at least @n@ times, but no more than @m@ times.--manyNtoM        :: Int -> Int -> GenParser a b c -> GenParser a b [c]-manyNtoM n m p-    | n < 0      = return []-    | n > m      = return []-    | n == m     = count n p-    | n == 0     = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))-    | otherwise  = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)-------- Date/Time Parser -------------------------------------------------dateTime :: Int -> CharParser a CalendarTime-dateTime tz =-            choice [try $ cvsDateTime tz,-                    try $ iso8601DateTime tz,-                    oldDateTime]--cvsDateTime :: Int -> CharParser a CalendarTime-cvsDateTime tz =-                do y <- year-                   _ <- char '/'-                   mon <- monthNum-                   _ <- char '/'-                   d <- day-                   _ <- mySpaces-                   h <- hour-                   _ <- char ':'-                   m <- minute-                   _ <- char ':'-                   s <- second-                   z <- option tz $ mySpaces >> zone-                   return (CalendarTime y mon d h m s 0 Monday 0 "" z False)--oldDateTime   :: CharParser a CalendarTime-oldDateTime    =   do wd <- dayName-                      _ <- mySpaces-                      mon <- monthName-                      _ <- mySpaces-                      d <- day-                      _ <- mySpaces-                      h <- hour-                      _ <- char ':'-                      m <- minute-                      _ <- char ':'-                      s <- second-                      _ <- mySpaces-                      z <- zone-                      _ <- mySpaces-                      y <- year-                      return (CalendarTime y mon d h m s 0 wd 0 "" z False)--{- FIXME: In case you ever want to use this outside of darcs, you should note-   that this implementation of ISO 8601 is not complete.--   reluctant to implement (ambiguous!):-     * years > 9999-     * truncated representations with implied century (89 for 1989)-   unimplemented:-     * repeated durations (not relevant)-     * lowest order component fractions in intervals-     * negative dates (BC)-   unverified or too relaxed:-     * the difference between 24h and 0h-     * allows stuff like 2005-1212; either you use the hyphen all the way-       (2005-12-12) or you don't use it at all (20051212), but you don't use-       it halfway, likewise with time-     * No bounds checking whatsoever on intervals!-       (next action: read iso doc to see if bounds-checking required?) -}-iso8601DateTime   :: Int -> CharParser a CalendarTime-iso8601DateTime localTz = try $-  do d <- iso8601Date-     t <- option id $ try $ do optional $ oneOf " T"-                               iso8601Time-     return $ t $ d { ctTZ = localTz }--iso8601Date :: CharParser a CalendarTime-iso8601Date =-  do d <- calendar_date <|> week_date <|> ordinal_date-     return $ foldr ($) nullCalendar d-  where-    calendar_date = -- yyyy-mm-dd-      try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]-               -- allow other variants to be parsed correctly-               notFollowedBy (digit <|> char 'W')-               return d-    week_date = --yyyy-Www-dd-      try $ do yfn <- year_-               optional dash-               _ <- char 'W'-               -- offset human 'week 1' -> computer 'week 0'-               w'  <- (\x -> x-1) `liftM` twoDigits-               wd  <- option 1 $ do { optional dash; nDigits 1 }-               let y = yfn nullCalendar-                   firstDay = ctWDay y-               -- things that make this complicated-               -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday-               -- 2. the first week is the one that contains at least Thursday-               --    if the year starts after Thursday, then some days of the year-               --    will have already passed before the first week-               let afterThursday = firstDay == Sunday || firstDay > Thursday-                   w  = if afterThursday then w'+1 else w'-                   diff c = c { ctDay = (7 * w) + wd - (fromEnum firstDay) }-               return [(toUTCTime.toClockTime.diff.yfn)]-    ordinal_date = -- yyyy-ddd-      try $ optchain year_ [ (dash, yearDay_) ]-    ---    year_  = try $ do y <- fourDigits <?> "year (0000-9999)"-                      return $ \c -> c { ctYear = y }-    month_ = try $ do m <- twoDigits <?> "month (1 to 12)"-                      -- we (artificially) use ctPicosec to indicate-                      -- whether the month has been specified.-                      return $ \c -> c { ctMonth = intToMonth m, ctPicosec = 0 }-    day_   = try $ do d <- twoDigits <?> "day in month (1 to 31)"-                      return $ \c -> c { ctDay = d }-    yearDay_ = try $ do d <- nDigits 3 <?> "day in year (1 to 366)"-                        return $ \c -> c { ctYDay = d }-    dash = char '-'---- we return a function which sets the time on another calendar-iso8601Time :: CharParser a (CalendarTime -> CalendarTime)-iso8601Time = try $-  do ts <- optchain hour_ [ (colon     , min_)-                          , (colon     , sec_)-                          , (oneOf ",.", pico_) ]-     z  <- option id $ choice [ zulu , offset ]-     return $ foldr (.) id (z:ts)-  where-    hour_ = do h <- twoDigits-               return $ \c -> c { ctHour = h }-    min_  = do m <- twoDigits-               return $ \c -> c { ctMin = m }-    sec_  = do s <- twoDigits-               return $ \c -> c { ctSec = s }-    pico_ = do digs <- many digit-               let picoExp = 12-                   digsExp = length digs-               let frac | null digs = 0-                        | digsExp > picoExp = read $ take picoExp digs-                        | otherwise = 10 ^ (picoExp - digsExp) * (read digs)-               return $ \c -> c { ctPicosec = frac }-    zulu   = do { _ <- char 'Z'; return (\c -> c { ctTZ = 0 }) }-    offset = do sign <- choice [ do { char '+' >> return   1  }-                               , do { char '-' >> return (-1) } ]-                h <- twoDigits-                m <- option 0 $ do { optional colon; twoDigits }-                return $ \c -> c { ctTZ = sign * 60 * ((h*60)+m) }-    colon = char ':'--optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]-optchain p next = try $-  do r1 <- p-     r2 <- case next of-           [] -> return []-           ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }-     return (r1:r2)--nDigits :: Int -> CharParser a Int-nDigits n = read `liftM` count n digit--twoDigits, fourDigits :: CharParser a Int-twoDigits = nDigits 2-fourDigits = nDigits 4--mySpaces :: CharParser a String-mySpaces = manyN 1 $ char ' '--dayName        :: CharParser a Day-dayName         = choice-                       [ caseString "Mon"       >> return Monday-                       , try (caseString "Tue") >> return Tuesday-                       , caseString "Wed"       >> return Wednesday-                       , caseString "Thu"       >> return Thursday-                       , caseString "Fri"       >> return Friday-                       , try (caseString "Sat") >> return Saturday-                       , caseString "Sun"       >> return Sunday-                       ]--year            :: CharParser a Int-year             = fourDigits--monthNum       :: CharParser a Month-monthNum = do mn <- manyNtoM 1 2 digit-              return $ intToMonth $ (read mn :: Int)--intToMonth :: Int -> Month-intToMonth 1 = January-intToMonth 2 = February-intToMonth 3 = March-intToMonth 4 = April-intToMonth 5 = May-intToMonth 6 = June-intToMonth 7 = July-intToMonth 8 = August-intToMonth 9 = September-intToMonth 10 = October-intToMonth 11 = November-intToMonth 12 = December-intToMonth _  = error "invalid month!"--monthName      :: CharParser a Month-monthName       = choice-                       [ try (caseString "Jan") >> return January-                       , caseString "Feb"       >> return February-                       , try (caseString "Mar") >> return March-                       , try (caseString "Apr") >> return April-                       , caseString "May"       >> return May-                       , try (caseString "Jun") >> return June-                       , caseString "Jul"       >> return July-                       , caseString "Aug"       >> return August-                       , caseString "Sep"       >> return September-                       , caseString "Oct"       >> return October-                       , caseString "Nov"       >> return November-                       , caseString "Dec"       >> return December-                       ]--day             :: CharParser a Int-day              = do d <- manyNtoM 1 2 digit-                      return (read d :: Int)--hour            :: CharParser a Int-hour             = twoDigits--minute          :: CharParser a Int-minute           = twoDigits--second          :: CharParser a Int-second           = twoDigits--zone            :: CharParser a Int-zone             = choice-                       [ do { _ <- char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }-                       , do { _ <- char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }-                       , mkZone "UTC"  0-                       , mkZone "UT"  0-                       , mkZone "GMT" 0-                       , mkZone "EST" (-5)-                       , mkZone "EDT" (-4)-                       , mkZone "CST" (-6)-                       , mkZone "CDT" (-5)-                       , mkZone "MST" (-7)-                       , mkZone "MDT" (-6)-                       , mkZone "PST" (-8)-                       , mkZone "PDT" (-7)-                       , mkZone "CEST" 2-                       , mkZone "EEST" 3-                         -- if we don't understand it, just give a GMT answer...-                       , do { _ <- manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])-                                       (lookAhead space_digit);-                              return 0 }-                       ]-     where mkZone n o  = try $ do { caseString n; return (o*60*60) }-           space_digit = try $ do { _ <- char ' '; oneOf ['0'..'9'] }--nullCalendar :: CalendarTime-nullCalendar = CalendarTime 0 January 0 0 0 0 1 Sunday 0 "" 0 False
src/Darcs/Patch/PatchInfoAnd.hs view
@@ -15,43 +15,64 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7--#include "gadts.h"+module Darcs.Patch.PatchInfoAnd+    ( Hopefully+    , PatchInfoAnd+    , PatchInfoAndG+    , piap+    , n2pia+    , patchInfoAndPatch+    , fmapPIAP+    , fmapFLPIAP+    , hopefully+    , info+    , hopefullyM+    , createHashed+    , extractHash+    , actually+    , unavailable+    , patchDesc+    ) where -module Darcs.Patch.PatchInfoAnd ( Hopefully, PatchInfoAnd,-                         WPatchInfo, unWPatchInfo, compareWPatchInfo,-                         piap, n2pia, patchInfoAndPatch,-                         fmapPIAP, fmapFL_PIAP,-                         conscientiously, hopefully, info, winfo,-                         hopefullyM, createHashed, extractHash,-                         actually, unavailable, patchDesc ) where+import Darcs.Prelude +import Control.Exception ( Exception, throw ) import System.IO.Unsafe ( unsafeInterleaveIO )+import Data.Typeable ( Typeable ) -import Darcs.SignalHandler ( catchNonSignal )-import Printer ( Doc, renderString, errorDoc, text, ($$), vcat )-import Darcs.Patch.Info ( PatchInfo, humanFriendly, justName )-import Darcs.Patch ( RepoPatch, Named, patch2patchinfo )-import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Conflict ( Conflict(..) )+import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) ) import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Named ( fmapNamed, fmapFL_Named )-import Darcs.Patch.Prim ( PrimPatchBase(..) )-import Darcs.Patch.Patchy ( Patchy, ReadPatch(..), Apply(..), Invert(..),-                            ShowPatch(..), Commute(..), PatchInspect(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId )+import Darcs.Patch.Info ( PatchInfo, displayPatchInfo, justName, showPatchInfo )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Merge ( CleanMerge(..), Merge(..) )+import Darcs.Patch.Named ( Named, fmapFL_Named )+import Darcs.Patch.Read ( ReadPatch(..) ) import Darcs.Patch.Repair ( Repair(..), RepairToFL )-import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( (:>)(..), (:\/:)(..), (:/\:)(..), FL, mapFL )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, mapSeal )-import Darcs.Utils ( prettyException )-import Storage.Hashed.Tree( Tree )--import Control.Applicative ( (<$>) )+import Darcs.Patch.Show ( ShowPatch(..) )+import Darcs.Patch.Show ( ShowContextPatch(..), ShowPatchBasic(..) )+import Darcs.Patch.Summary ( Summary )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) )+import Darcs.Patch.Witnesses.Ordered+    ( (:/\:)(..)+    , (:>)(..)+    , (:\/:)(..)+    , FL+    , mapFL+    , mapRL_RL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), mapSeal, seal )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Util.Exception ( prettyException )+import Darcs.Util.Printer ( Doc, renderString, text, vcat, ($$) )+import Darcs.Util.SignalHandler ( catchNonSignal )+import Darcs.Util.ValidHash ( PatchHash )  -- | @'Hopefully' p C@ @(x y)@ is @'Either' String (p C@ @(x y))@ in a -- form adapted to darcs patches. The @C@ @(x y)@ represents the type@@ -60,174 +81,227 @@ -- 'SimpleHopefully' does the real work of emulating -- 'Either'. @Hopefully sh@ represents an expected unhashed patch, and -- @Hashed hash sh@ represents an expected hashed patch with its hash.-data Hopefully a C(x y) = Hopefully (SimpleHopefully a C(x y)) | Hashed String (SimpleHopefully a C(x y))+data Hopefully a wX wY+    = Hopefully (SimpleHopefully a wX wY)+    | Hashed PatchHash (SimpleHopefully a wX wY)+    deriving Show  -- | @SimpleHopefully@ is a variant of @Either String@ adapted for -- type witnesses. @Actually@ is the equivalent of @Right@, while -- @Unavailable@ is @Left@.-data SimpleHopefully a C(x y) = Actually (a C(x y)) | Unavailable String+data SimpleHopefully a wX wY = Actually (a wX wY) | Unavailable String+    deriving Show --- | @'PatchInfoAnd' p C(a b)@ represents a hope we have to get a+type PatchInfoAnd p = PatchInfoAndG (Named p)++-- | @'PatchInfoAnd' p wA wB@ represents a hope we have to get a -- patch through its info. We're not sure we have the patch, but we -- know its info.-data PatchInfoAnd p C(a b) = PIAP !PatchInfo (Hopefully (Named p) C(a b))--instance PrimPatchBase p => PrimPatchBase (PatchInfoAnd p) where-   type PrimOf (PatchInfoAnd p) = PrimOf p---- | @'WPatchInfo' C(a b)@ represents the info of a patch, marked with--- the patch's witnesses.-newtype WPatchInfo C(a b) = WPatchInfo { unWPatchInfo :: PatchInfo }---- This is actually unsafe if we ever commute patches and then compare them--- using this function. TODO: consider adding an extra existential to WPatchInfo--- (as with TaggedPatch in Darcs.Patch.Choices)-compareWPatchInfo :: WPatchInfo C(a b) -> WPatchInfo C(c d) -> EqCheck C((a, b) (c, d))-compareWPatchInfo (WPatchInfo x) (WPatchInfo y) = if x == y then unsafeCoerceP IsEq else NotEq--instance MyEq WPatchInfo where-   WPatchInfo x `unsafeCompare` WPatchInfo y = x == y+data PatchInfoAndG p wA wB =+  PIAP !PatchInfo+       (Hopefully p wA wB)+  deriving (Show) -fmapH :: (a C(x y) -> b C(w z)) -> Hopefully a C(x y) -> Hopefully b C(w z)+fmapH :: (a wX wY -> b wW wZ) -> Hopefully a wX wY -> Hopefully b wW wZ fmapH f (Hopefully sh) = Hopefully (ff sh)     where ff (Actually a) = Actually (f a)           ff (Unavailable e) = Unavailable e-fmapH f (Hashed h sh) = Hashed h (ff sh)+fmapH f (Hashed _ sh) = Hopefully (ff sh)     where ff (Actually a) = Actually (f a)           ff (Unavailable e) = Unavailable e -info :: PatchInfoAnd p C(a b) -> PatchInfo+info :: PatchInfoAndG p wA wB -> PatchInfo info (PIAP i _) = i -patchDesc :: forall p C(x y) . PatchInfoAnd p C(x y) -> String+patchDesc :: forall p wX wY . PatchInfoAnd p wX wY -> String patchDesc p = justName $ info p -winfo :: PatchInfoAnd p C(a b) -> WPatchInfo C(a b)-winfo (PIAP i _) = WPatchInfo i- -- | @'piap' i p@ creates a PatchInfoAnd containing p with info i.-piap :: PatchInfo -> Named p C(a b) -> PatchInfoAnd p C(a b)+piap :: PatchInfo -> p wA wB -> PatchInfoAndG p wA wB piap i p = PIAP i (Hopefully $ Actually p)  -- | @n2pia@ creates a PatchInfoAnd representing a @Named@ patch.-n2pia :: Named p C(x y) -> PatchInfoAnd p C(x y)-n2pia x = patch2patchinfo x `piap` x+n2pia :: (Ident p, PatchId p ~ PatchInfo) => p wX wY -> PatchInfoAndG p wX wY+n2pia x = ident x `piap` x -patchInfoAndPatch :: PatchInfo -> Hopefully (Named p) C(a b) -> PatchInfoAnd p C(a b)+patchInfoAndPatch :: PatchInfo -> Hopefully p wA wB -> PatchInfoAndG p wA wB patchInfoAndPatch =  PIAP -fmapPIAP :: (FORALL(a b) p C(a b) -> q C(a b)) -> PatchInfoAnd p C(x y) -> PatchInfoAnd q C(x y)-fmapPIAP f (PIAP i hp) = PIAP i (fmapH (fmapNamed f) hp)+fmapFLPIAP :: (FL p wX wY -> FL q wX wY)+           -> PatchInfoAnd p wX wY -> PatchInfoAnd q wX wY+fmapFLPIAP f (PIAP i hp) = PIAP i (fmapH (fmapFL_Named f) hp) -fmapFL_PIAP :: (FL p C(x y) -> FL q C(x y)) -> PatchInfoAnd p C(x y) -> PatchInfoAnd q C(x y)-fmapFL_PIAP f (PIAP i hp) = PIAP i (fmapH (fmapFL_Named f) hp)+fmapPIAP :: (p wX wY -> q wX wY)+           -> PatchInfoAndG p wX wY -> PatchInfoAndG q wX wY+fmapPIAP f (PIAP i hp) = PIAP i (fmapH f hp)  -- | @'hopefully' hp@ tries to get a patch from a 'PatchInfoAnd' -- value. If it fails, it outputs an error \"failed to read patch: -- \<description of the patch>\". We get the description of the patch -- from the info part of 'hp'-hopefully :: PatchInfoAnd p C(a b) -> Named p C(a b)+hopefully :: PatchInfoAndG p wA wB -> p wA wB hopefully = conscientiously $ \e -> text "failed to read patch:" $$ e +-- | Using a special exception type here means that is is treated as+-- regular failure, and not as a bug in Darcs.+data PatchNotAvailable = PatchNotAvailable Doc+  deriving Typeable++instance Exception PatchNotAvailable++instance Show PatchNotAvailable where+  show (PatchNotAvailable e) = renderString e+ -- | @'conscientiously' er hp@ tries to extract a patch from a 'PatchInfoAnd'. -- If it fails, it applies the error handling function @er@ to a description -- of the patch info component of @hp@.+-- Note: this function must be lazy in its second argument, which is why we+-- use a lazy pattern match. conscientiously :: (Doc -> Doc)-                -> PatchInfoAnd p C(a b) -> Named p C(a b)-conscientiously er (PIAP pinf hp) =+                -> PatchInfoAndG p wA wB -> p wA wB+conscientiously er ~(PIAP pinf hp) =     case hopefully2either hp of       Right p -> p-      Left e -> errorDoc $ er (humanFriendly pinf $$ text e)+      Left e -> throw $ PatchNotAvailable $ er (displayPatchInfo pinf $$ text e) --- | @hopefullyM@ is a version of @hopefully@ which calls @fail@ in a--- monad instead of erroring.-hopefullyM :: Monad m => PatchInfoAnd p C(a b) -> m (Named p C(a b))-hopefullyM (PIAP pinf hp) = case hopefully2either hp of+-- | Return 'Just' the patch content or 'Nothing' if it is unavailable.+hopefullyM :: PatchInfoAndG p wA wB -> Maybe (p wA wB)+hopefullyM (PIAP _ hp) = case hopefully2either hp of                               Right p -> return p-                              Left e -> fail $ renderString (humanFriendly pinf $$ text e)+                              Left _ -> Nothing  -- Any recommendations for a nice adverb to name the below?-hopefully2either :: Hopefully a C(x y) -> Either String (a C(x y))+hopefully2either :: Hopefully a wX wY -> Either String (a wX wY) hopefully2either (Hopefully (Actually p)) = Right p hopefully2either (Hashed _ (Actually p)) = Right p hopefully2either (Hopefully (Unavailable e)) = Left e hopefully2either (Hashed _ (Unavailable e)) = Left e -actually :: a C(x y) -> Hopefully a C(x y)+actually :: a wX wY -> Hopefully a wX wY actually = Hopefully . Actually -createHashed :: String -> (String -> IO (Sealed (a C(x)))) -> IO (Sealed (Hopefully a C(x)))-createHashed h f = do mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler)+createHashed :: PatchHash -> (PatchHash -> IO (Sealed (a wX))) -> IO (Sealed (Hopefully a wX))+createHashed h f = mapSeal (Hashed h) `fmap` unsafeInterleaveIO (f' `catchNonSignal` handler)   where   f' = do Sealed x <- f h           return (Sealed (Actually x))   handler e = return $ seal $ Unavailable $ prettyException e -extractHash :: PatchInfoAnd p C(a b) -> Either (Named p C(a b)) String-extractHash (PIAP _ (Hashed s _)) = Right s+extractHash :: PatchInfoAndG p wA wB -> Either (p wA wB) PatchHash+extractHash (PIAP _ (Hashed sh _)) = Right sh extractHash hp = Left $ conscientiously (\e -> text "unable to read patch:" $$ e) hp -unavailable :: String -> Hopefully a C(x y)+unavailable :: String -> Hopefully a wX wY unavailable = Hopefully . Unavailable -instance (Commute p, MyEq p) => MyEq (PatchInfoAnd p) where-    unsafeCompare (PIAP i _) (PIAP i2 _) = i == i2+-- * Instances defined only for PatchInfoAnd ---instance Invert (p C(x y)) => Invert (PatchInfoAnd (p C(x y))) where-instance (Commute p, Invert p) => Invert (PatchInfoAnd p) where-    invert (PIAP i p) = PIAP i (invert `fmapH` p)+instance Show2 p => Show1 (PatchInfoAnd p wX) -instance PatchListFormat (PatchInfoAnd p)+instance Show2 p => Show2 (PatchInfoAnd p) -instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (PatchInfoAnd p) where-    showPatch (PIAP n p) = case hopefully2either p of-                           Right x -> showPatch x-                           Left _ -> humanFriendly n+instance RepairToFL p => Repair (PatchInfoAnd p) where+    applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p+                            case mp' of+                              Nothing -> return Nothing+                              Just (e,p') -> return $ Just (e, n2pia p') -instance (Apply p, Conflict p, CommuteNoConflicts p, IsHunk p, PatchListFormat p, PrimPatchBase p,-          ShowPatch p, ApplyState p ~ Tree) => ShowPatch (PatchInfoAnd p) where-    showContextPatch (PIAP n p) = case hopefully2either p of-                                    Right x -> showContextPatch x-                                    Left _ -> return $ humanFriendly n-    description (PIAP n _) = humanFriendly n-    summary (PIAP n p) = case hopefully2either p of-                         Right x -> summary x-                         Left _ -> humanFriendly n+-- * Instances defined for PatchInfoAndG++instance PrimPatchBase p => PrimPatchBase (PatchInfoAndG p) where+   type PrimOf (PatchInfoAndG p) = PrimOf p++getHopefully :: Hopefully p wX wY -> SimpleHopefully p wX wY+getHopefully (Hashed _ x) = x+getHopefully (Hopefully x) = x++instance Eq2 p => Eq2 (SimpleHopefully p) where+    Actually p1 `unsafeCompare` Actually p2 = p1 `unsafeCompare` p2+    _ `unsafeCompare` _ = error "cannot compare unavailable patches"++instance Eq2 p => Eq2 (Hopefully p) where+    Hashed h1 _ `unsafeCompare` Hashed h2 _ = h1 == h2+    hp1 `unsafeCompare` hp2 =+      getHopefully hp1 `unsafeCompare` getHopefully hp2++instance Eq2 p => Eq2 (PatchInfoAndG p) where+    PIAP i1 p1 `unsafeCompare` PIAP i2 p2 = i1 == i2 && p1 `unsafeCompare` p2++type instance PatchId (PatchInfoAndG p) = PatchInfo++instance Ident (PatchInfoAndG p) where+    ident (PIAP i _) = i++instance PatchListFormat (PatchInfoAndG p)++instance ShowPatchBasic p => ShowPatchBasic (PatchInfoAndG p) where+    showPatch f (PIAP n p) =+      case hopefully2either p of+        Right x -> showPatch f x+        Left _ -> showPatchInfo f n++instance ShowContextPatch p => ShowContextPatch (PatchInfoAndG p) where+  showPatchWithContextAndApply f (PIAP n p) =+    case hopefully2either p of+      Right x -> showPatchWithContextAndApply f x+      Left _ -> return $ showPatchInfo f n++instance (Summary p, PatchListFormat p,+          ShowPatch p) => ShowPatch (PatchInfoAndG p) where+    description (PIAP n _) = displayPatchInfo n+    summary (PIAP _ p) =+      case hopefully2either p of+        Right x -> summary x+        Left _ -> text $ "[patch summary is unavailable]"     summaryFL = vcat . mapFL summary-    showNicely (PIAP n p) = case hopefully2either p of-                            Right x -> showNicely x-                            Left _ -> humanFriendly n+    content (PIAP _ p) =+      case hopefully2either p of+        Right x -> content x+        Left _ -> text $ "[patch content is unavailable]" -instance Commute p => Commute (PatchInfoAnd p) where+instance (PatchId p ~ PatchInfo, Commute p) => Commute (PatchInfoAndG p) where     commute (x :> y) = do y' :> x' <- commute (hopefully x :> hopefully y)-                          return $ (info y `piap` y') :> (info x `piap` x')+                          return $ (ident y `piap` y') :> (ident x `piap` x') -instance Merge p => Merge (PatchInfoAnd p) where-    merge (x :\/: y) = case merge (hopefully x :\/: hopefully y) of-                       y' :/\: x' -> (info y `piap` y') :/\: (info x `piap` x')+instance (PatchId p ~ PatchInfo, CleanMerge p) =>+         CleanMerge (PatchInfoAndG p) where+    cleanMerge (x :\/: y)+      | ident x == ident y = error "cannot cleanMerge identical PatchInfoAndG"+      | otherwise = do+          y' :/\: x' <- cleanMerge (hopefully x :\/: hopefully y)+          return $ (ident y `piap` y') :/\: (ident x `piap` x') -instance PatchInspect p => PatchInspect (PatchInfoAnd p) where-    listTouchedFiles = listTouchedFiles . hopefully-    hunkMatches _ _ = error "hunkmatches not implemented for PatchInfoAnd"+instance (PatchId p ~ PatchInfo, Merge p) => Merge (PatchInfoAndG p) where+    merge (x :\/: y)+      | ident x == ident y = error "cannot merge identical PatchInfoAndG"+      | otherwise =+          case merge (hopefully x :\/: hopefully y) of+            y' :/\: x' -> (ident y `piap` y') :/\: (ident x `piap` x') -instance Apply p => Apply (PatchInfoAnd p) where-    type ApplyState (PatchInfoAnd p) = ApplyState p-    apply p = apply $ hopefully p+instance PatchInspect p => PatchInspect (PatchInfoAndG p) where+    listTouchedFiles = listTouchedFiles . hopefully+    hunkMatches f = hunkMatches f . hopefully -instance RepairToFL p => Repair (PatchInfoAnd p) where-    applyAndTryToFix p = do mp' <- applyAndTryToFix $ hopefully p-                            case mp' of-                              Nothing -> return Nothing-                              Just (e,p') -> return $ Just (e, n2pia p')+instance Apply p => Apply (PatchInfoAndG p) where+    type ApplyState (PatchInfoAndG p) = ApplyState p+    apply = apply . hopefully+    unapply = unapply . hopefully -instance (ReadPatch p, PatchListFormat p) => ReadPatch (PatchInfoAnd p) where+instance ( ReadPatch p, Ident p, PatchId p ~ PatchInfo+         ) => ReadPatch (PatchInfoAndG p) where     readPatch' = mapSeal n2pia <$> readPatch' -instance Effect p => Effect (PatchInfoAnd p) where+instance Effect p => Effect (PatchInfoAndG p) where     effect = effect . hopefully-    effectRL = effectRL . hopefully -instance IsHunk (PatchInfoAnd p) where+instance IsHunk (PatchInfoAndG p) where     isHunk _ = Nothing -instance (RepoPatch p, ApplyState p ~ Tree) => Patchy (PatchInfoAnd p)+instance PatchDebug p => PatchDebug (PatchInfoAndG p)++instance (Commute p, Conflict p, Summary p, PrimPatchBase p, PatchListFormat p, ShowPatch p) => Conflict (PatchInfoAnd p) where+    isConflicted = isConflicted . hopefully+    -- Note: this relies on the laziness of 'hopefully' for efficiency+    -- and correctness in the face of lazy repositories+    resolveConflicts context patches =+      resolveConflicts (mapRL_RL hopefully context) (mapRL_RL hopefully patches)
− src/Darcs/Patch/Patchy.hs 
@@ -1,38 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Patch.Patchy-     ( Patchy,-       Apply(..), Commute(..), Invert(..),-       PatchInspect(..), ReadPatch(..),-       showPatch, ShowPatch(..)-     ) where--import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.Show ( showPatch, ShowPatch(..), ShowPatchBasic )-import Darcs.Witnesses.Eq ( MyEq )--class (MyEq p, Apply p, Commute p, PatchInspect p, ShowPatch p, ReadPatch p, Invert p) => Patchy p-
− src/Darcs/Patch/Patchy/Instances.hs 
@@ -1,13 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}--module Darcs.Patch.Patchy.Instances () where--import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Patchy ( Patchy )-import Darcs.Patch.Permutations ()-import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.Viewing ()-import Darcs.Witnesses.Ordered ( FL, RL )--instance (IsHunk p, PatchListFormat p, Patchy p) => Patchy (FL p)-instance (IsHunk p, PatchListFormat p, Patchy p) => Patchy (RL p)
src/Darcs/Patch/Permutations.hs view
@@ -17,138 +17,193 @@ -- Boston, MA 02110-1301, USA.  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-} -#include "gadts.h"+module Darcs.Patch.Permutations+    ( removeFL+    , removeRL+    , removeCommon+    , commuteWhatWeCanFL+    , commuteWhatWeCanRL+    , genCommuteWhatWeCanRL+    , genCommuteWhatWeCanFL+    , partitionFL+    , partitionRL+    , partitionFL'+    , partitionRL'+    , simpleHeadPermutationsFL+    , headPermutationsRL+    , headPermutationsFL+    , permutationsRL+    , removeSubsequenceFL+    , removeSubsequenceRL+    , partitionConflictingFL+    , (=\~/=)+    , (=/~\=)+    , nubFL+    ) where -module Darcs.Patch.Permutations ( removeFL, removeRL, removeCommon,-                                  commuteWhatWeCanFL, commuteWhatWeCanRL,-                                  genCommuteWhatWeCanRL,-                                  partitionFL, partitionRL,-                                  simpleHeadPermutationsFL, headPermutationsRL,-                                  headPermutationsFL,-                                  removeSubsequenceFL, removeSubsequenceRL,-                                  partitionConflictingFL,-                                  CommuteFn, selfCommuter,-                                  commuterIdFL, commuterFLId,-                                  commuterIdRL-                                ) where+import Darcs.Prelude +import Data.List ( nubBy ) import Data.Maybe ( mapMaybe )-import Darcs.Patch.Commute ( Commute, commute, commuteFLorComplain, commuteRL )-import Darcs.Patch.Invert ( Invert(..), invertFL, invertRL )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+<+)-                               , reverseFL, (+>+), (:\/:)(..), lengthFL-                               , lengthRL, reverseRL )-#include "impossible.h"+import Darcs.Patch.Commute ( Commute, commute, commuteFL, commuteRL )+import Darcs.Patch.CommuteFn ( CommuteFn )+import Darcs.Patch.Merge ( CleanMerge(..), cleanMergeFL )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..), isIsEq )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), RL(..), (:>)(..), (:\/:)(..), (:/\:)(..)+    , (+<+), (+>+)+    , lengthFL, lengthRL+    , reverseFL, reverseRL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) ) --- |split an 'FL' into "left" and "right" lists according to a predicate @p@, using commutation as necessary.--- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy--- the predicate, it goes in the "middle" list; to sum up, we have: @all p left@ and @all (not.p) right@, while--- midddle is mixed.+-- | Split an 'FL' according to a predicate, using commutation as necessary,+-- into those that satisfy the predicate and can be commuted to the left, and+-- those that do not satisfy it and can be commuted to the right. Whatever+-- remains stays in the middle.+--+-- Note that the predicate @p@ should be invariant under commutation:+-- if @commute(x:>y)==Just(y':>x')@ then @p x == p x' && p y == p y'@. partitionFL :: Commute p-            => (FORALL(u v) p C(u v) -> Bool)       -- ^predicate; if true we would like the patch in the "left" list-            -> FL p C(x y)                          -- ^input 'FL'-            -> ((FL p :> FL p :> FL p) C(x y))      -- ^"left", "middle" and "right"+            => (forall wU wV . p wU wV -> Bool)  -- ^predicate; if true we would like the patch in the "left" list+            -> FL p wX wY                        -- ^input 'FL'+            -> (FL p :> FL p :> FL p) wX wY      -- ^"left", "middle" and "right"+partitionFL keepleft ps =+    case partitionFL' keepleft NilRL NilRL ps of+        left :> middle :> right -> left :> reverseRL middle :> reverseRL right --- optimise by using an accumulating parameter to track all the "right" patches that we've found so far+-- optimise by using an accumulating parameter to track all the "left"+-- patches that we've found so far; also do not reverse the result lists partitionFL' :: Commute p-             => (FORALL(u v) p C(u v) -> Bool)-             -> RL p C(a b)  -- the "middle" patches found so far-             -> RL p C(b c)  -- the "right" patches found so far-             -> FL p C(c d)-             -> ((FL p :> FL p :> FL p) C(a d))--partitionFL keepleft ps = partitionFL' keepleft NilRL NilRL ps--partitionFL' _ middle right NilFL = (NilFL :> reverseRL middle :> reverseRL right)+             => (forall wU wV . p wU wV -> Bool)+             -> RL p wA wB  -- the "middle" patches found so far+             -> RL p wB wC  -- the "right" patches found so far+             -> FL p wC wD+             -> (FL p :> RL p :> RL p) wA wD+partitionFL' _ middle right NilFL = NilFL :> middle :> right partitionFL' keepleft middle right (p :>: ps)-   | keepleft p = case commuteRL (right :> p) of-     Just (p' :> right') -> case commuteRL (middle :> p') of-       Just (p'' :> middle') -> case partitionFL' keepleft middle' right' ps of-         (a :> b :> c) -> (p'' :>: a :> b :> c)-       Nothing -> partitionFL' keepleft (p' :<: middle) right' ps-     Nothing -> case commuteWhatWeCanRL (right :> p) of-       (tomiddle :> p' :> right') -> partitionFL' keepleft (p' :<: tomiddle +<+ middle) right' ps-   | otherwise = partitionFL' keepleft middle (p :<: right) ps----- |split an 'RL' into "left" and "right" lists according to a predicate, using commutation as necessary.--- If a patch does satisfy the predicate but cannot be commuted past one that does not satisfy--- the predicate, it goes in the "left" list.-partitionRL :: Commute p-            => (FORALL(u v) p C(u v) -> Bool)    -- ^predicate; if true we would like the patch in the "right" list-            -> RL p C(x y)                       -- ^input 'RL'-            -> (RL p :> RL p) C(x y)             -- ^"left" and "right" results---- optimise by using an accumulating parameter to track all the "left" patches that we've found so far-partitionRL' :: Commute p-             => (FORALL(u v) p C(u v) -> Bool)-             -> RL p C(x z)-             -> FL p C(z y)   -- the "left" patches found so far-             -> (RL p :> RL p) C(x y)+    | keepleft p = case commuteWhatWeCanRL (right :> p) of+        (NilRL :> p' :> right') -> case commuteRL (middle :> p') of+            Just (p'' :> middle') -> case partitionFL' keepleft middle' right' ps of+                (a :> b :> c) -> p'' :>: a :> b :> c+            Nothing -> partitionFL' keepleft (middle :<: p') right' ps+        (tomiddle :> p' :> right') ->+            partitionFL' keepleft (middle +<+ tomiddle :<: p') right' ps+    | otherwise = partitionFL' keepleft middle (right :<: p) ps -partitionRL keepright ps = partitionRL' keepright ps NilFL+-- | Split an 'RL' according to a predicate, using commutation as necessary,+-- into those that satisfy the predicate and can be commuted to the right, and+-- those that do not satisfy it and can be commuted to the left. Whatever+-- remains stays in the middle.+--+-- Note that the predicate @p@ should be invariant under commutation:+-- if @commute(x:>y)==Just(y':>x')@ then @p x == p x' && p y == p y'@.+partitionRL' :: forall p wX wY. Commute p+             => (forall wU wV . p wU wV -> Bool)+             -> RL p wX wY+             -> (FL p :> FL p :> RL p) wX wY+partitionRL' predicate input = go input NilFL NilFL where+  go :: RL p wA wB  -- input RL+     -> FL p wB wC  -- the "left" patches found so far+     -> FL p wC wD  -- the "middle" patches found so far+     -> (FL p :> FL p :> RL p) wA wD+  go NilRL left middle = left :> middle :> NilRL+  go (ps :<: p) left middle+    | predicate p = case commuteWhatWeCanFL (p :> left) of+        (left' :> p' :> NilFL) -> case commuteFL (p' :> middle) of+            Just (middle' :> p'') -> case go ps left' middle' of+                (a :> b :> c) -> a :> b :> c :<: p''+            Nothing -> go ps left' (p' :>: middle)+        (left' :> p' :> tomiddle) ->+            go ps left' (p' :>: tomiddle +>+ middle)+    | otherwise = go ps (p :>: left) middle -partitionRL' _ NilRL qs = reverseFL qs :> NilRL+-- | Split an 'RL' according to a predicate, using commutation as necessary,+-- into those that satisfy the predicate and can be commuted to the right, and+-- those that don't, i.e. either do not satisfy the predicate or cannot be+-- commuted to the right.+--+-- Note that the predicate @p@ should be invariant under commutation:+-- if @commute(x:>y)==Just(y':>x')@ then @p x == p x' && p y == p y'@.+partitionRL :: forall p wX wY. Commute p+            => (forall wU wV . p wU wV -> Bool) -- ^predicate; if true we would like the patch in the "right" list+            -> RL p wX wY                       -- ^input 'RL'+            -> (RL p :> RL p) wX wY             -- ^"left" and "right" results+partitionRL keepright = go . (:> NilFL)+  where+    go :: (RL p :> FL p) wA wB -> (RL p :> RL p) wA wB+    go (NilRL :> qs) = (reverseFL qs :> NilRL)+    go (ps :<: p :> qs)+      | keepright p+      , Just (qs' :> p') <- commuteFL (p :> qs) =+          case go (ps :> qs') of+            a :> b -> a :> b :<: p'+      | otherwise = go (ps :> p :>: qs) -partitionRL' keepright (p :<: ps) qs-   | keepright p,-     Right (qs' :> p') <- commuteFLorComplain (p :> qs)-       = case partitionRL' keepright ps qs' of-         a :> b -> a :> p' :<: b-   | otherwise = partitionRL' keepright ps (p :>: qs)+commuteWhatWeCanFL :: Commute p => (p :> FL p) wX wY -> (FL p :> p :> FL p) wX wY+commuteWhatWeCanFL = genCommuteWhatWeCanFL commute -commuteWhatWeCanFL :: Commute p => (p :> FL p) C(x y) -> (FL p :> p :> FL p) C(x y)-commuteWhatWeCanFL (p :> x :>: xs) =-    case commute (p :> x) of-    Nothing -> case commuteWhatWeCanFL (x :> xs) of-               xs1 :> x' :> xs2 -> case commuteWhatWeCanFL (p :> xs1) of-                              xs1' :> p' :> xs2' -> xs1' :> p' :> xs2' +>+ x' :>: xs2-    Just (x' :> p') -> case commuteWhatWeCanFL (p' :> xs) of-                       a :> p'' :> c -> x' :>: a :> p'' :> c-commuteWhatWeCanFL (y :> NilFL) = NilFL :> y :> NilFL+genCommuteWhatWeCanFL :: Commute q+                      => CommuteFn p q+                      -> (p :> FL q) wX wY+                      -> (FL q :> p :> FL q) wX wY+genCommuteWhatWeCanFL com (p :> x :>: xs) =+  case com (p :> x) of+    Nothing ->+      case commuteWhatWeCanFL (x :> xs) of+        xs1 :> x' :> xs2 ->+          case genCommuteWhatWeCanFL com (p :> xs1) of+            xs1' :> p' :> xs2' -> xs1' :> p' :> xs2' +>+ x' :>: xs2+    Just (x' :> p') ->+      case genCommuteWhatWeCanFL com (p' :> xs) of+        a :> p'' :> c -> x' :>: a :> p'' :> c+genCommuteWhatWeCanFL _ (y :> NilFL) = NilFL :> y :> NilFL -commuteWhatWeCanRL :: Commute p => (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y)+commuteWhatWeCanRL :: Commute p => (RL p :> p) wX wY -> (RL p :> p :> RL p) wX wY commuteWhatWeCanRL = genCommuteWhatWeCanRL commute -genCommuteWhatWeCanRL :: (FORALL(a b) ((p :> p) C(a b) -> Maybe ((p :> p) C(a b))))-                      -> (RL p :> p) C(x y) -> (RL p :> p :> RL p) C(x y)-genCommuteWhatWeCanRL com (x :<: xs :> p) =-    case com (x :> p) of-    Nothing -> case genCommuteWhatWeCanRL com (xs :> x) of-               xs1 :> x' :> xs2 -> case genCommuteWhatWeCanRL com (xs2 :> p) of-                              xs1' :> p' :> xs2' -> xs1' +<+ x' :<: xs1 :> p' :> xs2'-    Just (p' :> x') -> case genCommuteWhatWeCanRL com (xs :> p') of-                       a :> p'' :> c -> a :> p'' :> x' :<: c+genCommuteWhatWeCanRL :: Commute p+                      => CommuteFn p q+                      -> (RL p :> q) wX wY+                      -> (RL p :> q :> RL p) wX wY+genCommuteWhatWeCanRL com (xs :<: x :> p) =+  case com (x :> p) of+    Nothing ->+      case commuteWhatWeCanRL (xs :> x) of+        xs1 :> x' :> xs2 ->+          case genCommuteWhatWeCanRL com (xs2 :> p) of+            xs1' :> p' :> xs2' -> xs1 :<: x' +<+ xs1' :> p' :> xs2'+    Just (p' :> x') ->+      case genCommuteWhatWeCanRL com (xs :> p') of+        xs1 :> p'' :> xs2 -> xs1 :> p'' :> xs2 :<: x' genCommuteWhatWeCanRL _ (NilRL :> y) = NilRL :> y :> NilRL  -removeCommon :: (MyEq p, Commute p) => (FL p :\/: FL p) C(x y) -> (FL p :\/: FL p) C(x y)+removeCommon :: (Eq2 p, Commute p) => (FL p :\/: FL p) wX wY -> (FL p :\/: FL p) wX wY removeCommon (xs :\/: NilFL) = xs :\/: NilFL removeCommon (NilFL :\/: xs) = NilFL :\/: xs removeCommon (xs :\/: ys) = rc xs (headPermutationsFL ys)-    where rc :: (MyEq p, Commute p) => FL p C(x y) -> [(p:>FL p) C(x z)] -> (FL p :\/: FL p) C(y z)+    where rc :: (Eq2 p, Commute p) => FL p wX wY -> [(p:>FL p) wX wZ] -> (FL p :\/: FL p) wY wZ           rc nms ((n:>ns):_) | Just ms <- removeFL n nms = removeCommon (ms :\/: ns)           rc ms [n:>ns] = ms :\/: n:>:ns           rc ms (_:nss) = rc ms nss-          rc _ [] = impossible -- because we already checked for NilFL case+          rc _ [] = error "impossible case" -- because we already checked for NilFL case  -- | 'removeFL' @x xs@ removes @x@ from @xs@ if @x@ can be commuted to its head. --   Otherwise it returns 'Nothing'-removeFL :: (MyEq p, Commute p) => p C(x y) -> FL p C(x z) -> Maybe (FL p C(y z))+removeFL :: (Eq2 p, Commute p) => p wX wY -> FL p wX wZ -> Maybe (FL p wY wZ) removeFL x xs = r x $ headPermutationsFL xs-    where r :: (MyEq p, Commute p) => p C(x y) -> [(p:>FL p) C(x z)] -> Maybe (FL p C(y z))+    where r :: (Eq2 p, Commute p) => p wX wY -> [(p:>FL p) wX wZ] -> Maybe (FL p wY wZ)           r _ [] = Nothing           r z ((z':>zs):zss) | IsEq <- z =\/= z' = Just zs                              | otherwise = r z zss  -- | 'removeRL' is like 'removeFL' except with 'RL'-removeRL :: (MyEq p, Commute p) => p C(y z) -> RL p C(x z) -> Maybe (RL p C(x y))+removeRL :: (Eq2 p, Commute p) => p wY wZ -> RL p wX wZ -> Maybe (RL p wX wY) removeRL x xs = r x $ headPermutationsRL xs-    where r :: (MyEq p, Commute p) => p C(y z) -> [RL p C(x z)] -> Maybe (RL p C(x y))-          r z ((z':<:zs):zss) | IsEq <- z =/\= z' = Just zs+    where r :: (Eq2 p, Commute p) => p wY wZ -> [RL p wX wZ] -> Maybe (RL p wX wY)+          r z ((zs:<:z'):zss) | IsEq <- z =/\= z' = Just zs                               | otherwise = r z zss           r _ _ = Nothing @@ -156,27 +211,27 @@ --   @ab@ have been commuted out of it, if possible.  If this is not possible --   for any reason (the set of patches @ab@ is not actually a subset of @abc@, --   or they can't be commuted out) we return 'Nothing'.-removeSubsequenceFL :: (MyEq p, Commute p) => FL p C(a b)-                     -> FL p C(a c) -> Maybe (FL p C(b c))+removeSubsequenceFL :: (Eq2 p, Commute p) => FL p wA wB+                     -> FL p wA wC -> Maybe (FL p wB wC) removeSubsequenceFL a b | lengthFL a > lengthFL b = Nothing                          | otherwise = rsFL a b-    where rsFL :: (MyEq p, Commute p) => FL p C(a b) -> FL p C(a c) -> Maybe (FL p C(b c))+    where rsFL :: (Eq2 p, Commute p) => FL p wA wB -> FL p wA wC -> Maybe (FL p wB wC)           rsFL NilFL ys = Just ys           rsFL (x:>:xs) yys = removeFL x yys >>= removeSubsequenceFL xs  -- | 'removeSubsequenceRL' is like @removeSubsequenceFL@ except that it works --   on 'RL'-removeSubsequenceRL :: (MyEq p, Commute p) => RL p C(ab abc)-                     -> RL p C(a abc) -> Maybe (RL p C(a ab))+removeSubsequenceRL :: (Eq2 p, Commute p) => RL p wAb wAbc+                     -> RL p wA wAbc -> Maybe (RL p wA wAb) removeSubsequenceRL a b | lengthRL a > lengthRL b = Nothing                          | otherwise = rsRL a b-    where rsRL :: (MyEq p, Commute p) => RL p C(ab abc) -> RL p C(a abc) -> Maybe (RL p C(a ab))+    where rsRL :: (Eq2 p, Commute p) => RL p wAb wAbc -> RL p wA wAbc -> Maybe (RL p wA wAb)           rsRL NilRL ys = Just ys-          rsRL (x:<:xs) yys = removeRL x yys >>= removeSubsequenceRL xs+          rsRL (xs:<:x) yys = removeRL x yys >>= removeSubsequenceRL xs  -- | This is a minor variant of 'headPermutationsFL' with each permutation --   is simply returned as a 'FL'-simpleHeadPermutationsFL :: Commute p => FL p C(x y) -> [FL p C(x y)]+simpleHeadPermutationsFL :: Commute p => FL p wX wY -> [FL p wX wY] simpleHeadPermutationsFL ps = map (\ (x:>xs) -> x:>:xs) $ headPermutationsFL ps  -- | 'headPermutationsFL' @p:>:ps@ returns all the permutations of the list@@ -195,7 +250,7 @@ --   > y :> X h a s t c k --   > s :> X h a y t c k --   > k :> X h a y s t c-headPermutationsFL :: Commute p => FL p C(x y) -> [(p :> FL p) C(x y)]+headPermutationsFL :: Commute p => FL p wX wY -> [(p :> FL p) wX wY] headPermutationsFL NilFL = [] headPermutationsFL (p:>:ps) =     (p:>ps) : mapMaybe (swapfirstFL.(p:>)) (headPermutationsFL ps)@@ -205,83 +260,72 @@ -- | 'headPermutationsRL' is like 'headPermutationsFL', except that we --   operate on an 'RL' (in other words, we are pushing things to the end of a --   patch sequence instead of to the beginning).-headPermutationsRL :: Commute p => RL p C(x y) -> [RL p C(x y)]+headPermutationsRL :: Commute p => RL p wX wY -> [RL p wX wY] headPermutationsRL NilRL = []-headPermutationsRL (p:<:ps) =-    (p:<:ps) : mapMaybe (swapfirstRL.(p:<:)) (headPermutationsRL ps)-        where swapfirstRL (p1:<:p2:<:xs) = do p1':>p2' <- commute (p2:>p1)-                                              Just $ p2':<:p1':<:xs+headPermutationsRL (ps:<:p) =+    (ps:<:p) : mapMaybe (swapfirstRL.(:<:p)) (headPermutationsRL ps)+        where swapfirstRL (xs:<:p2:<:p1) = do p1':>p2' <- commute (p2:>p1)+                                              Just $ xs:<:p1':<:p2'               swapfirstRL _ = Nothing -instance (MyEq p, Commute p) => MyEq (FL p) where-    a =\/= b | lengthFL a /= lengthFL b = NotEq-             | otherwise = cmpSameLength a b-             where cmpSameLength :: FL p C(x y) -> FL p C(x z) -> EqCheck C(y z)-                   cmpSameLength (x:>:xs) xys | Just ys <- removeFL x xys = cmpSameLength xs ys-                   cmpSameLength NilFL NilFL = IsEq-                   cmpSameLength _ _ = NotEq-    xs =/\= ys = reverseFL xs =/\= reverseFL ys--instance (Invert p, Commute p) => Invert (FL p) where-    invert = reverseRL . invertFL--instance (MyEq p, Commute p) => MyEq (RL p) where-    unsafeCompare = bug "Buggy use of unsafeCompare on RL"-    a =/\= b | lengthRL a /= lengthRL b = NotEq-             | otherwise = cmpSameLength a b-             where cmpSameLength :: RL p C(x y) -> RL p C(w y) -> EqCheck C(x w)-                   cmpSameLength (x:<:xs) xys | Just ys <- removeRL x xys = cmpSameLength xs ys-                   cmpSameLength NilRL NilRL = IsEq-                   cmpSameLength _ _ = NotEq-    xs =\/= ys = reverseRL xs =\/= reverseRL ys--instance (Commute p, Invert p) => Invert (RL p) where-    invert = reverseFL . invertRL---- |CommuteFn is the basis of a general framework for building up commutation--- operations between different patch types in a generic manner. Unfortunately--- type classes are not well suited to the problem because of the multiple possible--- routes by which the commuter for (FL p1, FL p2) can be built out of the--- commuter for (p1, p2) - and more complicated problems when we start building--- multiple constructors on top of each other. The type class resolution machinery--- really can't cope with selecting some route, because it doesn't know that all--- possible routes should be equivalent.-type CommuteFn p1 p2 = FORALL(x y) (p1 :> p2) C(x y) -> Maybe ((p2 :> p1) C(x y))---- |Build a commuter between a patch and itself using the operation from the type class.-selfCommuter :: Commute p => CommuteFn p p-selfCommuter = commute+-- | All permutations of an 'RL'.+permutationsRL :: Commute p => RL p wX wY -> [RL p wX wY]+permutationsRL ps =+  ps : [qs' :<: q | qs :<: q <- headPermutationsRL ps, qs' <- permutationsRL qs] -commuterIdRL :: CommuteFn p1 p2 -> CommuteFn p1 (RL p2)-commuterIdRL _ (x :> NilRL) = return (NilRL :> x)-commuterIdRL commuter (x :> (y :<: ys))-  = do ys' :> x' <- commuterIdRL commuter (x :> ys)-       y' :> x'' <- commuter (x' :> y)-       return ((y' :<: ys') :> x'')+-- | This commutes patches in the RHS to bring them into the same+-- order as the LHS.+(=\~/=)+  :: forall p wA wB wC+   . (Commute p, Eq2 p)+  => FL p wA wB+  -> FL p wA wC+  -> EqCheck wB wC+a =\~/= b+  | lengthFL a /= lengthFL b = NotEq+  | otherwise = cmpSameLength a b+  where+    cmpSameLength :: FL p wX wY -> FL p wX wZ -> EqCheck wY wZ+    cmpSameLength (x :>: xs) x_ys+      | Just ys <- removeFL x x_ys = cmpSameLength xs ys+    cmpSameLength NilFL NilFL = IsEq+    cmpSameLength _ _ = NotEq -commuterIdFL :: CommuteFn p1 p2 -> CommuteFn p1 (FL p2)-commuterIdFL _ (x :> NilFL) = return (NilFL :> x)-commuterIdFL commuter (x :> (y :>: ys))-  = do y' :> x' <- commuter (x :> y)-       ys' :> x'' <- commuterIdFL commuter (x' :> ys)-       return ((y' :>: ys') :> x'')+-- | This commutes patches in the RHS to bring them into the same+-- order as the LHS.+(=/~\=)+  :: forall p wA wB wC+   . (Commute p, Eq2 p)+  => RL p wA wC+  -> RL p wB wC+  -> EqCheck wA wB+a =/~\= b+  | lengthRL a /= lengthRL b = NotEq+  | otherwise = cmpSameLength a b+  where+    cmpSameLength :: RL p wX wZ -> RL p wY wZ -> EqCheck wX wY+    cmpSameLength (xs :<: x) ys_x+      | Just ys <- removeRL x ys_x = cmpSameLength xs ys+    cmpSameLength NilRL NilRL = IsEq+    cmpSameLength _ _ = NotEq -commuterFLId :: CommuteFn p1 p2 -> CommuteFn (FL p1) p2-commuterFLId _ (NilFL :> y) = return (y :> NilFL)-commuterFLId commuter ((x :>: xs) :> y)-  = do y' :> xs' <- commuterFLId commuter (xs :> y)-       y'' :> x' <- commuter (x :> y')-       return (y'' :> (x' :>: xs'))+-- | A variant of 'nub' that is based on '=\~/= i.e. ignores (internal) ordering.+nubFL :: (Commute p, Eq2 p) => [Sealed (FL p wX)] -> [Sealed (FL p wX)]+nubFL = nubBy eqSealedFL where+  eqSealedFL (Sealed ps) (Sealed qs) = isIsEq (ps =\~/= qs) --- |Partition a list into the patches that commute with the given patch and those that don't (including dependencies)-partitionConflictingFL :: (Commute p1, Invert p1) => CommuteFn p1 p2 -> FL p1 C(x y) -> p2 C(x z) -> (FL p1 :> FL p1) C(x y)-partitionConflictingFL _ NilFL _ = (NilFL :> NilFL)-partitionConflictingFL commuter (x :>: xs) y =-   case commuter (invert x :> y) of-     Nothing -> case commuteWhatWeCanFL (x :> xs) of-                 xs_ok :> x' :> xs_deps ->-                   case partitionConflictingFL commuter xs_ok y of-                     xs_clean :> xs_conflicts -> xs_clean :> (xs_conflicts +>+ (x' :>: xs_deps))-     Just (y' :> _) ->-       case partitionConflictingFL commuter xs y' of-          xs_clean :> xs_conflicts -> (x :>: xs_clean) :> xs_conflicts+-- | Partition a list into the patches that merge cleanly with the given+-- patch and those that don't (including dependencies)+partitionConflictingFL+  :: forall p wX wY wZ+   . (Commute p, CleanMerge p)+  => FL p wX wY -> FL p wX wZ -> (FL p :> FL p) wX wY+partitionConflictingFL = go NilRL NilRL+  where+    go :: RL p wA wB -> RL p wB wC -> FL p wC wD -> FL p wB w -> (FL p :> FL p) wA wD+    go clean dirty NilFL _ = reverseRL clean :> reverseRL dirty+    go clean dirty (x:>:xs) ys+      | Just (x' :> dirty') <- commuteRL (dirty :> x)+      , Just (ys' :/\: _) <- cleanMergeFL (x' :\/: ys) =+        go (clean :<: x') dirty' xs ys'+      | otherwise = go clean (dirty :<: x) xs ys
src/Darcs/Patch/Prim.hs view
@@ -1,25 +1,32 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim-       ( showPrim, showPrimFL,-         primIsAddfile, primIsHunk, primIsBinary, primIsSetpref,-         primIsAdddir, is_filepatch,-         canonize, tryToShrink,-         sortCoalesceFL, join, canonizeFL,-         tryShrinkingInverse,-         summarizePrim,-         applyPrimFL,-         readPrim,-         FromPrim(..), FromPrims(..), ToFromPrim(..),-         PrimPatch, PrimPatchBase(..), PrimConstruct(..)-       )-       where+    ( PrimApply(..)+    , PrimCoalesce(..)+    , PrimConstruct(..)+    , PrimDetails(..)+    , PrimMangleUnravelled(..)+    , PrimPatch+    , PrimRead(..)+    , PrimShow(..)+    , PrimSift(..)+    , Mangled+    , Unravelled+    , canonizeFL+    , coalesce+    ) where  import Darcs.Patch.Prim.Class-    ( PrimConstruct(..), PrimCanonize(..)-    , PrimClassify(..), PrimDetails(..)-    , PrimShow(..), showPrimFL, PrimRead(..)-    , PrimApply(..)-    , FromPrim(..), FromPrims(..), ToFromPrim(..)-    , PrimPatchBase(..), PrimPatch+    ( PrimApply(..)+    , PrimCoalesce(..)+    , PrimConstruct(..)+    , PrimDetails(..)+    , PrimMangleUnravelled(..)+    , PrimPatch+    , PrimRead(..)+    , PrimShow(..)+    , PrimSift(..)+    , Mangled+    , Unravelled     )-+import Darcs.Patch.Prim.Canonize ( canonizeFL )+import Darcs.Patch.Prim.Coalesce ( coalesce )
+ src/Darcs/Patch/Prim/Canonize.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE ViewPatterns #-}+module Darcs.Patch.Prim.Canonize ( canonizeFL ) where++import Darcs.Prelude++import qualified Data.ByteString as B (ByteString, empty)++import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )+import Darcs.Patch.Prim.Class+    ( PrimConstruct(primFromHunk)+    , PrimCoalesce(sortCoalesceFL)+    )+import Darcs.Patch.Witnesses.Ordered ( FL(..), joinGapsFL, mapFL_FL, concatFL )+import Darcs.Patch.Witnesses.Sealed ( unseal, Gap(..), unFreeLeft )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePEnd )+import Darcs.Util.Diff ( DiffAlgorithm, getChanges )++canonizeHunk :: Gap w => DiffAlgorithm -> FileHunk oid wX wY -> w (FL (FileHunk oid))+canonizeHunk _ (FileHunk f line old new)+  | null old || null new || old == [B.empty] || new == [B.empty] =+      freeGap (FileHunk f line old new :>: NilFL)+canonizeHunk da (FileHunk f line old new) =+  makeHoley f line $ getChanges da old new++makeHoley :: Gap w+          => oid+          -> Int+          -> [(Int, [B.ByteString], [B.ByteString])]+          -> w (FL (FileHunk oid))+makeHoley f line =+  joinGapsFL . map (\(l, o, n) -> freeGap (FileHunk f (l + line) o n))++-- | It can sometimes be handy to have a canonical representation of a given+-- patch.  We achieve this by defining a canonical form for each patch type,+-- and a function 'canonize' which takes a patch and puts it into+-- canonical form.  This routine is used by the diff function to create an+-- optimal patch (based on an LCS algorithm) from a simple hunk describing the+-- old and new version of a file.+canonize :: (IsHunk prim, PrimConstruct prim)+         => DiffAlgorithm -> prim wX wY -> FL prim wX wY+canonize da p | Just fh <- isHunk p =+  mapFL_FL primFromHunk $ unseal unsafeCoercePEnd $ unFreeLeft $ canonizeHunk da fh+canonize _ p = p :>: NilFL++-- | Put a sequence of primitive patches into canonical form.+--+-- Even if the patches are just hunk patches,+-- this is not necessarily the same set of results as you would get+-- if you applied the sequence to a specific tree and recalculated+-- a diff.+--+-- XXX Why not? How does it differ? The implementation for Prim.V1 does+-- sortCoalesceFL and then invokes the diff algorithm for each hunk. How can+-- that be any different to applying the sequence and then taking the diff?+-- Is this merely because diff does not sort by file path?+--+-- Besides, diff and apply /must/ be inverses in the sense that for any two+-- states {start, end}, we have+--+-- prop> diff start (apply (diff start end)) == end+canonizeFL :: (IsHunk prim, PrimCoalesce prim, PrimConstruct prim)+           => DiffAlgorithm -> FL prim wX wY -> FL prim wX wY+-- Note: it is important to first coalesce and then canonize, since+-- coalescing can produce non-canonical hunks (while hunks resulting+-- from canonizing a single hunk cannot be coalesced). See issue525,+-- in particular msg20270 for details.+canonizeFL da = concatFL . mapFL_FL (canonize da) . sortCoalesceFL
src/Darcs/Patch/Prim/Class.hs view
@@ -1,136 +1,150 @@ module Darcs.Patch.Prim.Class-    ( PrimConstruct(..), PrimCanonize(..)-    , PrimClassify(..), PrimDetails(..)-    , PrimShow(..), showPrimFL, PrimRead(..)+    ( PrimConstruct(..)+    , PrimCoalesce(..)+    , PrimDetails(..)+    , PrimSift(..)+    , PrimShow(..)+    , PrimRead(..)     , PrimApply(..)-    , PrimPatch, PrimPatchBase(..)-    , FromPrim(..), FromPrims(..), ToFromPrim(..)+    , PrimPatch+    , PrimMangleUnravelled(..)+    , Mangled+    , Unravelled+    , primCleanMerge     )     where +import Darcs.Prelude++import Darcs.Patch.Annotate.Class ( Annotate ) import Darcs.Patch.ApplyMonad ( ApplyMonad )-import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.FileHunk ( FileHunk, IsHunk )-import Darcs.Patch.FileName ( FileName )-import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) )-import Darcs.Patch.Patchy ( Patchy )-import Darcs.Patch.ReadMonads ( ParserM )+import Darcs.Patch.Format ( FileNameFormat, PatchListFormat )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Apply ( Apply(..), ObjectIdOfPatch )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.CommuteFn ( PartialMergeFn )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Merge ( CleanMerge(..) )+import Darcs.Patch.Read ( ReadPatch ) import Darcs.Patch.Repair ( RepairToFL )+import Darcs.Patch.Show ( ShowPatch, ShowContextPatch ) import Darcs.Patch.SummaryData ( SummDetail )-import Darcs.Witnesses.Ordered-    ( FL(..), RL, (:>), mapFL, mapFL_FL, concatFL, reverseFL, concatRL )-import Darcs.Witnesses.Sealed ( Sealed )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck )+import Darcs.Patch.Witnesses.Ordered ( (:/\:)(..), (:>)(..), (:\/:)(..), FL )+import Darcs.Patch.Witnesses.Show ( Show2 )+import Darcs.Patch.Witnesses.Sealed ( Sealed ) -import Printer ( Doc, vcat )+import Darcs.Util.Parser ( Parser )+import Darcs.Util.Path ( AnchoredPath )+import Darcs.Util.Printer ( Doc )  import qualified Data.ByteString as B ( ByteString ) -#include "gadts.h" -class (Patchy prim, PatchListFormat prim, IsHunk prim, RepairToFL prim-      ,PrimConstruct prim, PrimCanonize prim-      ,PrimClassify prim, PrimDetails prim-      ,PrimShow prim, PrimRead prim, PrimApply prim-      )-    => PrimPatch prim--class PrimPatch (PrimOf p) => PrimPatchBase p where-    type PrimOf (p :: PATCHKIND) :: PATCHKIND--instance PrimPatchBase p => PrimPatchBase (FL p) where-    type PrimOf (FL p) = PrimOf p--instance PrimPatchBase p => PrimPatchBase (RL p) where-    type PrimOf (RL p) = PrimOf p--class FromPrim p where-   fromPrim :: PrimOf p C(x y) -> p C(x y)--class FromPrim p => ToFromPrim p where-    toPrim :: p C(x y) -> Maybe (PrimOf p C(x y))--class FromPrims p where-    fromPrims :: FL (PrimOf p) C(x y) -> p C(x y)-    joinPatches :: FL p C(x y) -> p C(x y)--instance FromPrim p => FromPrim (FL p) where-    fromPrim p = fromPrim p :>: NilFL--instance FromPrim p => FromPrims (FL p) where-    fromPrims = mapFL_FL fromPrim-    joinPatches = concatFL--instance FromPrim p => FromPrims (RL p) where-    fromPrims = reverseFL . mapFL_FL fromPrim-    joinPatches = concatRL . reverseFL--class PrimClassify prim where-   primIsAddfile :: prim C(x y) -> Bool-   primIsRmfile :: prim C(x y) -> Bool-   primIsAdddir :: prim C(x y) -> Bool-   primIsRmdir :: prim C(x y) -> Bool-   primIsMove :: prim C(x y) -> Bool-   primIsHunk :: prim C(x y) -> Bool-   primIsTokReplace :: prim C(x y) -> Bool-   primIsBinary :: prim C(x y) -> Bool-   primIsSetpref :: prim C(x y) -> Bool-   is_filepatch :: prim C(x y) -> Maybe FileName+type PrimPatch prim =+    ( Annotate prim+    , Apply prim+    , CleanMerge prim+    , Commute prim+    , Invert prim+    , Eq2 prim+    , IsHunk prim+    , PatchInspect prim+    , RepairToFL prim+    , Show2 prim+    , PrimConstruct prim+    , PrimCoalesce prim+    , PrimDetails prim+    , PrimApply prim+    , PrimSift prim+    , PrimMangleUnravelled prim+    , ReadPatch prim+    , ShowPatch prim+    , ShowContextPatch prim+    , PatchListFormat prim+    )  class PrimConstruct prim where-   addfile :: FilePath -> prim C(x y)-   rmfile :: FilePath -> prim C(x y)-   adddir :: FilePath -> prim C(x y)-   rmdir :: FilePath -> prim C(x y)-   move :: FilePath -> FilePath -> prim C(x y)-   changepref :: String -> String -> String -> prim C(x y)-   hunk :: FilePath -> Int -> [B.ByteString] -> [B.ByteString] -> prim C(x y)-   tokreplace :: FilePath -> String -> String -> String -> prim C(x y)-   binary :: FilePath -> B.ByteString -> B.ByteString -> prim C(x y)-   primFromHunk :: FileHunk C(x y) -> prim C(x y)-   anIdentity :: prim C(x x)--class PrimCanonize prim where-   tryToShrink :: FL prim C(x y) -> FL prim C(x y)-   tryShrinkingInverse :: FL prim C(x y) -> Maybe (FL prim C(x y))+   addfile :: AnchoredPath -> prim wX wY+   rmfile :: AnchoredPath -> prim wX wY+   adddir :: AnchoredPath -> prim wX wY+   rmdir :: AnchoredPath -> prim wX wY+   move :: AnchoredPath -> AnchoredPath -> prim wX wY+   changepref :: String -> String -> String -> prim wX wY+   hunk :: AnchoredPath -> Int -> [B.ByteString] -> [B.ByteString] -> prim wX wY+   tokreplace :: AnchoredPath -> String -> String -> String -> prim wX wY+   binary :: AnchoredPath -> B.ByteString -> B.ByteString -> prim wX wY+   primFromHunk :: FileHunk (ObjectIdOfPatch prim) wX wY -> prim wX wY -   -- | 'sortCoalesceFL' @ps@ coalesces as many patches in @ps@ as-   --   possible, sorting the results in some standard order.-   sortCoalesceFL :: FL prim C(x y) -> FL prim C(x y)+class (Commute prim, Eq2 prim, Invert prim) => PrimCoalesce prim where+   -- | Try to shrink the input sequence by getting rid of self-cancellations+   -- and identity patches or by coalescing patches. Also sort patches+   -- according to some internally defined order (specific to the patch type)+   -- as far as possible while respecting dependencies.+   -- A result of 'Nothing' means that we could not shrink the input.+   --+   -- This method is included in the class for optimization. Instances are free+   -- to use 'Darcs.Patch.Prim.Coalesce.defaultTryToShrink'.+   tryToShrink :: FL prim wX wY -> Maybe (FL prim wX wY) -   -- | It can sometimes be handy to have a canonical representation of a given-   -- patch.  We achieve this by defining a canonical form for each patch type,-   -- and a function 'canonize' which takes a patch and puts it into-   -- canonical form.  This routine is used by the diff function to create an-   -- optimal patch (based on an LCS algorithm) from a simple hunk describing the-   -- old and new version of a file.-   canonize :: prim C(x y) -> FL prim C(x y)+   -- | This is similar to 'tryToShrink' but always gives back a result: if the+   -- sequence could not be shrunk we merely give back a sorted version.+   --+   -- This method is included in the class for optimization. Instances are free+   -- to use 'Darcs.Patch.Prim.Coalesce.defaultSortCoalesceFL'.+   sortCoalesceFL :: FL prim wX wY -> FL prim wX wY -   -- | 'canonizeFL' @ps@ puts a sequence of primitive patches into-   -- canonical form. Even if the patches are just hunk patches,-   -- this is not necessarily the same set of results as you would get-   -- if you applied the sequence to a specific tree and recalculated-   -- a diff.+   -- | Coalesce adjacent patches to one with the same effect.    ---   -- Note that this process does not preserve the commutation behaviour-   -- of the patches and is therefore not appropriate for use when-   -- working with already recorded patches (unless doing amend-record-   -- or the like).-   canonizeFL :: FL prim C(x y) -> FL prim C(x y)+   -- prop> apply (primCoalesce p q) == apply p >> apply q+   primCoalesce :: prim wX wY -> prim wY wZ -> Maybe (prim wX wZ) -   join :: (prim :> prim) C(x y) -> Maybe (FL prim C(x y))+   -- | Whether prim patch has no effect at all and thus can be eliminated+   -- as far as coalescing is concerned.+   isIdentity :: prim wX wY -> EqCheck wX wY +   -- | Provide a total order between arbitrary patches that is consistent+   -- with 'Eq2':+   --+   -- prop> unsafeCompare p q == IsEq  <=>  comparePrim p q == EQ+   comparePrim :: prim wA wB -> prim wC wD -> Ordering +-- | Prim patches that support "sifting". This is the process of eliminating+-- changes from a sequence of prims that can be recovered by comparing states+-- (normally the pristine and working states), except those that other changes+-- depend on. In other words, changes to the content of (tracked) files. The+-- implementation is allowed and expected to shrink and coalesce changes in the+-- process.+class PrimSift prim where+  -- | Whether a prim is a candidate for sifting+  primIsSiftable :: prim wX wY -> Bool+ class PrimDetails prim where-   summarizePrim :: prim C(x y) -> [SummDetail]+   summarizePrim :: prim wX wY -> [SummDetail]  class PrimShow prim where-   showPrim :: FileNameFormat -> prim C(a b) -> Doc--showPrimFL :: PrimShow prim => FileNameFormat -> FL prim C(a b) -> Doc-showPrimFL f xs = vcat (mapFL (showPrim f) xs)+   showPrim :: FileNameFormat -> prim wA wB -> Doc+   showPrimWithContextAndApply :: ApplyMonad  (ApplyState prim) m => FileNameFormat -> prim wA wB -> m Doc  class PrimRead prim where-   readPrim :: ParserM m => FileNameFormat -> m (Sealed (prim C(x )))+   readPrim :: FileNameFormat -> Parser (Sealed (prim wX))  class PrimApply prim where-   applyPrimFL :: ApplyMonad m (ApplyState prim) => FL prim C(x y) -> m ()+   applyPrimFL :: ApplyMonad (ApplyState prim) m => FL prim wX wY -> m ()++-- | A list of conflicting alternatives. They form a connected+-- component of the conflict graph i.e. one transitive conflict.+type Unravelled prim wX = [Sealed (FL prim wX)]++-- | Result of mangling a single Unravelled.+type Mangled prim wX = Sealed (FL prim wX)++class PrimMangleUnravelled prim where+  -- | Mangle conflicting alternatives if possible.+  mangleUnravelled :: Unravelled prim wX -> Maybe (Mangled prim wX)++primCleanMerge :: (Commute prim, Invert prim) => PartialMergeFn prim prim+primCleanMerge (p :\/: q) = do+  q' :> ip' <- commute (invert p :> q)+  return $ q' :/\: invert ip'
+ src/Darcs/Patch/Prim/Coalesce.hs view
@@ -0,0 +1,123 @@+{- | Generic coalesce functions++Some of the algorithms in this module do complex recursive operations on+sequences of patches in order to simplify them. These algorithms require+that we know whether some intermediate step has made any progress. If not,+we want to terminate or try something different.++We capture this as an effect by tagging intermediate data with the 'Any'+monoid, a newtype wrapper for 'Bool' with disjunction as 'mappend'. The+standard @instance 'Monoid' a => 'Monad' (a,)'@ defined in the base package+then gives use the desired semantics. That is, when we sequence operations+using '>>=', the result tells us whether 'Any' of the two operations have+made progress. -}++module Darcs.Patch.Prim.Coalesce+    ( coalesce+    , defaultTryToShrink+    , defaultSortCoalesceFL+    , withAnyToMaybe+    , sortCoalesceFL2+    ) where++import Darcs.Prelude++import Data.Maybe ( fromMaybe )+import Data.Monoid ( Any(..) )++import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Prim.Class ( PrimCoalesce(..), isIdentity)+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (:>)(..) )++-- | Either 'primCoalesce' or cancel inverses.+--+-- prop> primCoalesce (p :> q) == Just r => apply r = apply p >> apply q+coalesce :: PrimCoalesce prim => (prim :> prim) wX wY -> Maybe (Maybe2 prim wX wY)+coalesce (p1 :> p2)+  | IsEq <- invert p1 =\/= p2 = Just Nothing2+  | otherwise = Just2 <$> primCoalesce p1 p2++defaultTryToShrink :: PrimCoalesce prim => FL prim wX wY -> Maybe (FL prim wX wY)+defaultTryToShrink = withAnyToMaybe . sortCoalesceFL2++defaultSortCoalesceFL :: PrimCoalesce prim => FL prim wX wY -> FL prim wX wY+defaultSortCoalesceFL = snd . sortCoalesceFL2++-- | Conversion between @('Any', a)@ and @'Maybe' a@.+withAnyToMaybe :: (Any, a) -> Maybe a+withAnyToMaybe (Any True, x) = Just x+withAnyToMaybe (Any False, _) = Nothing++-- | The heart of 'sortCoalesceFL'.+sortCoalesceFL2 :: PrimCoalesce prim => FL prim wX wY -> (Any, FL prim wX wY)+sortCoalesceFL2 NilFL = (Any False, NilFL)+sortCoalesceFL2 (x:>:xs) = do+  xs' <- sortCoalesceFL2 xs+  case isIdentity x of+    IsEq -> (Any True, xs')+    NotEq -> pushCoalescePatch x xs'++-- | Try to coalesce the patch with any of the elements in the sequence,+-- using commutation to push it down the list, until either+--+--  (1) @new@ is 'LT' the next member of the list (using 'comparePrim')+-- +--  (2) commutation fails or+-- +--  (3) coalescing succeeds.+--+-- In case (1) we push the patch further, trying to coalesce it with any of its+-- successors and disregarding any ordering. If this is successful, we recurse+-- with the result, otherwise we leave the patch where it was, so the sequence+-- remains sorted.+--+-- In case (3) we recursively continue with the result unless that is empty.+-- +-- The result is returned in the @('Any',)@ monad to indicate whether it was+-- able to shrink the patch sequence. To make this clear, we do /not/ track+-- whether sorting has made progress, only shrinking.+--+-- The precondition is that the input sequence is already sorted.+pushCoalescePatch+  :: forall prim wX wY wZ+   . PrimCoalesce prim+  => prim wX wY+  -> FL prim wY wZ+  -> (Any, FL prim wX wZ)+pushCoalescePatch new NilFL = (Any False, new:>:NilFL)+pushCoalescePatch new ps@(p :>: ps') =+  case coalesce (new :> p) of+    Just (Just2 new') -> (Any True, snd $ pushCoalescePatch new' ps')+    Just Nothing2 -> (Any True, ps')+    Nothing ->+      case comparePrim new p of+        LT ->+          case shrinkOne new ps of+            Just ps'' ->+              -- we have to start over here because shrinkOne may have+              -- destroyed the order+              sortCoalesceFL2 ps''+            Nothing -> (Any False, new :>: ps)+        _ ->+          case commute (new :> p) of+            Just (p' :> new') ->+              case pushCoalescePatch new' ps' of+                (Any True, r) -> (Any True, snd $ pushCoalescePatch p' r)+                (Any False, r) -> (Any False, p' :>: r)+            Nothing -> (Any False, new :>: ps)+  where+    -- Try to coalesce a patch with any element of an adjacent sequence,+    -- regardless of ordering. If successful, the result may not be+    -- sorted, even if the input was.+    shrinkOne :: prim wA wB -> FL prim wB wC -> Maybe (FL prim wA wC)+    shrinkOne _ NilFL = Nothing+    shrinkOne a (b :>: bs) =+      case coalesce (a :> b) of+        Just Nothing2 -> Just bs+        Just (Just2 ab) -> Just $ fromMaybe (ab :>: bs) $ shrinkOne ab bs+        Nothing -> do+          b' :> a' <- commute (a :> b)+          (b' :>:) <$> shrinkOne a' bs
+ src/Darcs/Patch/Prim/FileUUID.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -Wno-orphans #-}+module Darcs.Patch.Prim.FileUUID ( Prim ) where++import Darcs.Prelude++import Darcs.Patch.Prim.FileUUID.Apply ()+import Darcs.Patch.Prim.FileUUID.Coalesce ()+import Darcs.Patch.Prim.FileUUID.Commute ()+import Darcs.Patch.Prim.FileUUID.Core ( Prim )+import Darcs.Patch.Prim.FileUUID.Details ()+import Darcs.Patch.Prim.FileUUID.Read ()+import Darcs.Patch.Prim.FileUUID.Show ()++import Darcs.Patch.Prim.Class+  ( PrimMangleUnravelled(..)+  )++-- dummy implementation+instance PrimMangleUnravelled Prim where+  mangleUnravelled _ = Nothing
+ src/Darcs/Patch/Prim/FileUUID/Apply.hs view
@@ -0,0 +1,140 @@+{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings, UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Patch.Prim.FileUUID.Apply ( hunkEdit, ObjectMap(..) ) where++import Darcs.Prelude++import Control.Monad.Catch ( MonadThrow(throwM) )+import Control.Monad.State( StateT, runStateT, gets, lift, put )+import qualified Data.ByteString as B+import qualified Data.Map as M++import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.ApplyMonad+    ( ApplyMonad(..), ApplyMonadTrans(..)+    , ApplyMonadOperations+    )+import Darcs.Patch.Prim.Class ( PrimApply(..) )+import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..), HunkMove(..) )+import Darcs.Patch.Prim.FileUUID.Show+import Darcs.Patch.Prim.FileUUID.ObjectMap+import Darcs.Patch.Repair ( RepairToFL(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..) )++import Darcs.Util.Printer( text, packedString, ($$), renderString )+++instance Apply Prim where+  type ApplyState Prim = ObjectMap+  apply (Manifest i (L dirid name)) = editDirectory dirid (addObject name i dirid)+  apply (Demanifest i (L dirid name)) = editDirectory dirid (delObject name i dirid)+  apply (Hunk i hunk) = editFile i (hunkEdit hunk)+  apply (HunkMove (HM fs ls ft lt c)) =+    editFile fs (hunkEdit (H ls c B.empty)) >> editFile ft (hunkEdit (H lt B.empty c))+  apply Identity = return ()++instance RepairToFL Prim where+  applyAndTryToFixFL p = apply p >> return Nothing++instance PrimApply Prim where+  applyPrimFL NilFL = return ()+  applyPrimFL (p :>: ps) = apply p >> applyPrimFL ps++addObject :: Name -> UUID -> UUID -> DirContent -> Either String DirContent+addObject name obj dirid dir+  | Just obj' <- M.lookup name dir =+    Left $ unwords+      [ "##error applying patch: cannot insert"+      , show (name, obj)+      , "into directory"+      , show dirid+      , "because another object"+      , show obj'+      , "with that name already exists"+      ]+  | otherwise = Right $ M.insert name obj dir++delObject :: Name -> UUID -> UUID -> DirContent -> Either String DirContent+delObject name obj dirid dir =+  case M.lookup name dir of+    Just obj'+      | obj == obj' -> Right $ M.delete name dir+      | otherwise ->+        Left $ unwords+          [ "##error applying patch: cannot remove"+          , show (name, obj)+          , "from directory"+          , show dirid+          , "because it contains a different object"+          , show obj'+          ]+    Nothing ->+        Left $ unwords+          [ "##error applying patch: cannot remove"+          , show (name, obj)+          , "from directory"+          , show dirid+          , "because it does not contain any object of that name"+          ]++hunkEdit :: Hunk wX wY -> FileContent -> Either String FileContent+hunkEdit h@(H off old new) c+  | old `B.isPrefixOf` (B.drop off c) =+      Right $ B.concat [B.take off c, new, B.drop (off + B.length old) c]+  | otherwise =+      Left $ renderString $+      text "##error applying hunk:" $$ displayHunk Nothing h $$ "##to" $$+      packedString c+--       $$ text "##old=" <> text (ppShow old) $$+--       text "##new=" <> text (ppShow new) $$+--       text "##c=" <> text (ppShow c)++editObject :: MonadThrow m+           => UUID+           -> (Maybe (Object m) -> Either String (Object m))+           -> (StateT (ObjectMap m) m) ()+editObject i edit = do+  load <- gets getObject+  store <- gets putObject+  obj <- lift $ load i+  obj' <- liftEither $ edit obj+  new <- lift $ store i $ obj'+  put new++-- a semantic, ObjectMap-based interface for patch application+class ApplyMonadObjectMap m where+  editFile :: UUID -> (FileContent -> Either String FileContent) -> m ()+  editDirectory :: UUID -> (DirContent -> Either String DirContent) -> m ()++type instance ApplyMonadOperations ObjectMap = ApplyMonadObjectMap++instance MonadThrow m => ApplyMonad ObjectMap (StateT (ObjectMap m) m) where+  readFilePS i = do+    load <- gets getObject+    mobj <- lift $ load i+    case mobj of+      Just (Blob readBlob _) -> lift readBlob+      Just _ -> throwM $ userError $ "readFilePS " ++ show i ++ ": object is not a file"+      Nothing -> throwM $ userError $ "readFilePS " ++ show i ++ ": no such file"++liftEither :: MonadThrow m => Either String a -> m a+liftEither (Left e) = throwM $ userError e+liftEither (Right v) = return v++instance MonadThrow m => ApplyMonadObjectMap (StateT (ObjectMap m) m) where+  editFile i edit = editObject i edit'+    where+      edit' (Just (Blob x _)) = Right $ Blob (liftEither . edit =<< x) Nothing+      edit' Nothing = Right $ Blob (liftEither $ edit "") Nothing+      edit' (Just (Directory _)) =+        Left $ "wrong kind of object: " ++ show i ++ " is a directory, not a file"+  editDirectory i edit = editObject i edit'+    where+      edit' (Just (Directory x)) = Directory <$> edit x+      edit' Nothing = Directory <$> edit M.empty+      edit' (Just (Blob _ _)) =+        Left $ "wrong kind of object: " ++ show i ++ " is a file, not a directory"++instance MonadThrow m => ApplyMonadTrans ObjectMap m where+  type ApplyMonadOver ObjectMap m = StateT (ObjectMap m) m+  runApplyMonad = runStateT
+ src/Darcs/Patch/Prim/FileUUID/Coalesce.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -Wno-orphans -Wno-missing-methods #-}+module Darcs.Patch.Prim.FileUUID.Coalesce () where++import Darcs.Prelude++import Darcs.Patch.Prim.Class ( PrimCoalesce(..), PrimSift(..) )+import Darcs.Patch.Prim.FileUUID.Commute ()+import Darcs.Patch.Prim.FileUUID.Core ( Prim )++-- none of the methods are implemented+instance PrimCoalesce Prim where+  sortCoalesceFL = id -- just so that we can use it in the tests++-- none of the methods are implemented+instance PrimSift Prim
+ src/Darcs/Patch/Prim/FileUUID/Commute.hs view
@@ -0,0 +1,65 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Patch.Prim.FileUUID.Commute () where++import Darcs.Prelude++import qualified Data.ByteString as B (length)++import Darcs.Patch.Witnesses.Ordered ( (:>)(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Prim.FileUUID.Core ( Prim(..), Hunk(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Merge ( CleanMerge(..) )+import Darcs.Patch.Permutations () -- for Invert instance of FL+import Darcs.Patch.Prim.Class ( primCleanMerge )++-- For FileUUID it is easier to list the cases that do /not/ commute+depends :: (Prim :> Prim) wX wY -> Bool+depends (Manifest i1 l1 :> Demanifest i2 l2)+  -- cannot commute add with remove of same object, regardless of location+  | i1 == i2 = True+  -- cannot commute add with remove of any two things at the same location+  | l1 == l2 = True+depends (Demanifest i1 l1 :> Manifest i2 l2)+  -- cannot commute remove with add of same object, regardless of location+  | i1 == i2 = True+  -- cannot commute remove with add of any two things at the same location+  | l1 == l2 = True+depends (_ :> _) = False++instance Commute Prim where+  commute pair+    | depends pair = Nothing+  commute (Hunk f1 h1 :> Hunk f2 h2)+    | f1 == f2 =+        case commuteHunk (h1 :> h2) of+          Just (h2' :> h1') -> Just (Hunk f2 h2' :> Hunk f1 h1')+          Nothing -> Nothing+  commute (a :> b) =+    Just (unsafeCoerceP b :> unsafeCoerceP a)++commuteHunk :: (Hunk :> Hunk) wX wY -> Maybe ((Hunk :> Hunk) wX wY)+commuteHunk (H off1 old1 new1 :> H off2 old2 new2)+  | off1 + len_new1 < off2  = yes (off2 - len_new1 + len_old1, off1)+  | off2 + len_old2 < off1  = yes (off2, off1 + len_new2 - len_old2)+  | len_old2 /= 0+  , len_old1 /= 0+  , len_new2 /= 0+  , len_new1 /= 0+  , off1 + len_new1 == off2 = yes (off2 - len_new1 + len_old1, off1)+  | len_old2 /= 0+  , len_old1 /= 0+  , len_new2 /= 0+  , len_new1 /= 0+  , off2 + len_old2 == off1 = yes (off2, off1 + len_new2 - len_old2)+  | otherwise               = no+  where+    len_old1 = B.length old1+    len_new1 = B.length new1+    len_old2 = B.length old2+    len_new2 = B.length new2+    yes (off2', off1') = Just (H off2' old2 new2 :> H off1' old1 new1)+    no = Nothing++instance CleanMerge Prim where+  cleanMerge = primCleanMerge
+ src/Darcs/Patch/Prim/FileUUID/Core.hs view
@@ -0,0 +1,133 @@+-- Copyright (C) 2011 Petr Rockai+--+-- 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+-- SOFTWARE.+++module Darcs.Patch.Prim.FileUUID.Core+    ( Prim(..)+    , Hunk(..)+    , HunkMove(..)+    -- re-exports+    , Object(..)+    , UUID(..)+    , Location(..)+    , Name+    , FileContent+    ) where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Eq ( Eq2(..) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Patch.Witnesses.Unsafe+import Darcs.Patch.FileHunk( IsHunk(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Prim.Class ( PrimConstruct(..) )+import Darcs.Patch.Prim.FileUUID.ObjectMap++-- -----------------------------------------------------------------------------+-- Hunk++data Hunk wX wY = H !Int !FileContent !FileContent+  deriving (Eq, Show)++type role Hunk nominal nominal++instance Show1 (Hunk wX)++instance Show2 Hunk++invertHunk :: Hunk wX wY -> Hunk wY wX+invertHunk (H off old new) = H off new old++instance Eq2 Hunk where+  unsafeCompare p q = unsafeCoerceP p == q++-- -----------------------------------------------------------------------------+-- HunkMove++data HunkMove wX wY = HM !UUID !Int !UUID !Int !FileContent+  deriving (Eq, Show)++type role HunkMove nominal nominal++invertHunkMove :: HunkMove wX wY -> HunkMove wY wX+invertHunkMove (HM sid soff tid toff content) = HM tid toff sid soff content++instance Eq2 HunkMove where+  unsafeCompare (HM sid1 soff1 tid1 toff1 c1) (HM sid2 soff2 tid2 toff2 c2) =+    sid1 == sid2 && soff1 == soff2 && tid1 == tid2 && toff1 == toff2 && c1 == c2++-- -----------------------------------------------------------------------------+-- Prim++data Prim wX wY where+  Hunk :: !UUID -> !(Hunk wX wY) -> Prim wX wY+  HunkMove :: !(HunkMove wX wY) -> Prim wX wY+  Manifest :: !UUID -> !Location -> Prim wX wY+  Demanifest :: !UUID -> !Location -> Prim wX wY+  Identity :: Prim wX wX++deriving instance Eq (Prim wX wY)+deriving instance Show (Prim wX wY)++instance Show1 (Prim wX)++instance Show2 Prim++-- TODO: PrimConstruct makes no sense for FileUUID prims+instance PrimConstruct Prim where+  addfile _ = error "PrimConstruct addfile"+  rmfile _ = error "PrimConstruct rmfile"+  adddir _ = error "PrimConstruct adddir"+  rmdir _ = error "PrimConstruct rmdir"+  move _ _ = error "PrimConstruct move"+  changepref _ _ _ = error "PrimConstruct changepref"+  hunk _ _ _ _ = error "PrimConstruct hunk"+  tokreplace _ _ _ _ = error "PrimConstruct tokreplace"+  binary _ _ _ = error "PrimConstruct binary"+  primFromHunk _ = error "PrimConstruct primFromHunk"++instance IsHunk Prim where+  isHunk _ = Nothing++instance Invert Prim where+  invert (Hunk x h) = Hunk x $ invertHunk h+  invert (HunkMove hm) = HunkMove $ invertHunkMove hm+  invert (Manifest x y) = Demanifest x y+  invert (Demanifest x y) = Manifest x y+  invert Identity = Identity++instance PatchInspect Prim where+  -- We don't need this for FileUUID. Slashes are not allowed in Manifest and+  -- Demanifest patches and nothing else uses working-copy paths.+  listTouchedFiles _ = []++  -- TODO (used for --match 'hunk ...', presumably)+  hunkMatches _ _ = False++instance Eq2 Prim where+  unsafeCompare (Hunk a b) (Hunk c d) = a == c && b `unsafeCompare` d+  unsafeCompare (Manifest a b) (Manifest c d) = a == c && b == d+  unsafeCompare (Demanifest a b) (Demanifest c d) = a == c && b == d+  unsafeCompare Identity Identity = True+  unsafeCompare _ _ = False
+ src/Darcs/Patch/Prim/FileUUID/Details.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Patch.Prim.FileUUID.Details+    ()+    where++import Darcs.Patch.Prim.Class ( PrimDetails(..) )+import Darcs.Patch.Prim.FileUUID.Core ( Prim(..) )+++-- TODO+instance PrimDetails Prim where+  summarizePrim _ = []
+ src/Darcs/Patch/Prim/FileUUID/ObjectMap.hs view
@@ -0,0 +1,68 @@+-- Copyright (C) 2011 Petr Rockai+--+-- 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+-- SOFTWARE.++module Darcs.Patch.Prim.FileUUID.ObjectMap+    ( UUID(..), Location(..), Object(..)+    , ObjectMap(..), DirContent, FileContent+    , isBlob, isDirectory+    , Name -- re-export+    ) where++import Darcs.Prelude++import Darcs.Patch.Object ( ObjectIdOf )+import Darcs.Util.Hash ( Hash )+import Darcs.Util.Path ( Name )+import qualified Data.ByteString as B (ByteString)+import qualified Data.Map as M++type FileContent = B.ByteString++newtype UUID = UUID B.ByteString deriving (Eq, Ord, Show)++-- | An object is located by giving the 'UUID' of the parent+-- 'Directory' and a 'Name'.+data Location = L !UUID !Name+  deriving (Eq, Show)++-- TODO use HashMap instead?+type DirContent = M.Map Name UUID++data Object (m :: * -> *)+  = Directory DirContent+  | Blob (m FileContent) !(Maybe Hash)++isBlob :: Object m -> Bool+isBlob Blob{} = True+isBlob Directory{} = False++isDirectory :: Object m -> Bool+isDirectory Directory{} = True+isDirectory Blob{} = False++data ObjectMap (m :: * -> *) = ObjectMap+  { getObject :: UUID -> m (Maybe (Object m))+  , putObject :: UUID -> Object m -> m (ObjectMap m)+  , listObjects :: m [UUID]+  }++type instance ObjectIdOf ObjectMap = UUID
+ src/Darcs/Patch/Prim/FileUUID/Read.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ViewPatterns, OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Patch.Prim.FileUUID.Read () where++import Darcs.Prelude hiding ( take )++import Control.Monad ( liftM, liftM2 )++import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Prim.Class( PrimRead(..) )+import Darcs.Patch.Prim.FileUUID.Core( Prim(..), Hunk(..) )+import Darcs.Patch.Prim.FileUUID.ObjectMap+import Darcs.Patch.Witnesses.Sealed( seal )++import Darcs.Util.Path ( decodeWhiteName )+import Darcs.Util.Parser++instance PrimRead Prim where+  readPrim _ = do+    skipSpace+    choice $ map (liftM seal)+      [ identity+      , hunk "hunk" Hunk+      , manifest "manifest" Manifest+      , manifest "demanifest" Demanifest+      ]+    where+      manifest kind ctor = liftM2 ctor (patch kind) location+      identity = lexString "identity" >> return Identity+      patch x = string x >> uuid+      uuid = UUID <$> lexWord+      filename = do+        word <- lexWord+        either fail return $ decodeWhiteName word+      content = do+        lexString "content"+        len <- int+        _ <- char '\n'+        take len+      location = liftM2 L uuid filename+      hunk kind ctor = do+        uid <- patch kind+        offset <- int+        old <- content+        new <- content+        return $ ctor uid (H offset old new)++instance ReadPatch Prim where+  readPatch' = readPrim undefined
+ src/Darcs/Patch/Prim/FileUUID/Show.hs view
@@ -0,0 +1,118 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE OverloadedStrings, UndecidableInstances #-}+module Darcs.Patch.Prim.FileUUID.Show+    ( displayHunk )+    where++import Darcs.Prelude++import qualified Data.ByteString as B++import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) )+import Darcs.Patch.Show+    ( ShowPatchBasic(..), ShowPatch(..)+    , ShowContextPatch(..), ShowPatchFor(..) )+import Darcs.Patch.Summary ( plainSummaryPrim )+import Darcs.Patch.Prim.Class ( PrimShow(..) )+import Darcs.Patch.Prim.FileUUID.Core+    ( Prim(..), Hunk(..), HunkMove(..), UUID(..), Location(..), FileContent )+import Darcs.Patch.Prim.FileUUID.Details ()+import Darcs.Util.ByteString ( linesPS )+import Darcs.Util.Path ( Name, encodeWhiteName )+import Darcs.Util.Printer+    ( text, packedString, blueText, prefix+    , (<+>), ($$), Doc, vcat+    )++-- TODO this instance shouldn't really be necessary, as Prims aren't used generically+instance PatchListFormat Prim++fileNameFormat :: ShowPatchFor -> FileNameFormat+fileNameFormat ForDisplay = FileNameFormatDisplay+fileNameFormat ForStorage = FileNameFormatV2++instance ShowPatchBasic Prim where+  showPatch fmt = showPrim (fileNameFormat fmt)++-- dummy instance, does not actually show any context+instance Apply Prim => ShowContextPatch Prim where+  -- showPatchWithContextAndApply f = showPrimWithContextAndApply (fileNameFormat f)+  showPatchWithContextAndApply f p = apply p >> return (showPatch f p)++instance ShowPatch Prim where+  summary = plainSummaryPrim+  -- summaryFL = plainSummaryPrims False+  thing _ = "change"++instance PrimShow Prim where+  showPrim FileNameFormatDisplay (Hunk u h) = displayHunk (Just u) h+  showPrim _ (Hunk u h) = storeHunk u h+  showPrim FileNameFormatDisplay (HunkMove hm) = displayHunkMove hm+  showPrim _ (HunkMove hm) = storeHunkMove hm+  showPrim _ (Manifest f (L d p)) = showManifest "manifest" d f p+  showPrim _ (Demanifest f (L d p)) = showManifest "demanifest" d f p+  showPrim _ Identity = blueText "identity"+  showPrimWithContextAndApply _ _ = error "show with context not implemented"++showManifest :: String -> UUID -> UUID -> Name -> Doc+showManifest txt dir file name =+  blueText txt <+>+  formatUUID file <+>+  formatUUID dir <+>+  packedString (encodeWhiteName name)++displayHunk :: Maybe UUID -> Hunk wX wY -> Doc+displayHunk uid (H off old new) =+  blueText "hunk" <+>+  maybe (text "<nil>") formatUUID uid <+>+  text (show off) $$+  displayFileContent "-" old $$+  displayFileContent "+" new++storeHunk :: UUID -> Hunk wX wY -> Doc+storeHunk uid (H off old new) =+  text "hunk" <+>+  formatUUID uid <+>+  text (show off) $$+  storeFileContent old $$+  storeFileContent new++displayHunkMove :: HunkMove wX wY -> Doc+displayHunkMove (HM sid soff tid toff c) =+  blueText "hunkmove" <+>+  formatUUID sid <+>+  text (show soff) <+>+  formatUUID tid <+>+  text (show toff) $$+  displayFileContent "|" c++storeHunkMove :: HunkMove wX wY -> Doc+storeHunkMove (HM sid soff tid toff c) =+  text "hunkmove" <+>+  formatUUID sid <+>+  text (show soff) <+>+  formatUUID tid <+>+  text (show toff) $$+  storeFileContent c++-- TODO add some heuristics to recognize binary content+displayFileContent :: String -> FileContent -> Doc+displayFileContent pre = vcat . map (prefix pre) . showLines . linesPS+  where+    context = blueText "[...]"+    showLines [] = []+    showLines [x]+      | B.null x = []+      | otherwise = [context <> packedString x <> context]+    showLines (x:xs) =+      [context <> packedString x] +++      map packedString (init xs) +++      [packedString (last xs) <> context]++storeFileContent :: FileContent -> Doc+storeFileContent c =+  text "content" <+> text (show (B.length c)) $$ packedString c++formatUUID :: UUID -> Doc+formatUUID (UUID x) = packedString x
+ src/Darcs/Patch/Prim/Named.hs view
@@ -0,0 +1,110 @@+-- -fno-cse is here because of anonymousNamedPrim - see the comments on that+{-# OPTIONS_GHC -fno-cse #-}+-- | Wrapper for prim patches to give them an identity derived from the identity+-- of the containined Named patch.+module Darcs.Patch.Prim.Named+    ( NamedPrim+    -- accessors+    , PrimPatchId+    , namedPrim+    , positivePrimPatchIds+    , anonymousNamedPrim+    -- for testing+    , unsafePrimPatchId+    , prop_primPatchIdNonZero+    ) where++import Control.Monad ( mzero )++import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL++import qualified Data.Binary as Binary+import Crypto.Random ( getRandomBytes )+import System.IO.Unsafe ( unsafePerformIO )++import Darcs.Prelude hiding ( take )++import Darcs.Patch.Ident ( PatchId, SignedId(..), StorableId(..) )+import Darcs.Patch.Info ( PatchInfo, makePatchname )+import Darcs.Patch.Prim.WithName ( PrimWithName(..) )+import Darcs.Patch.Show ( ShowPatchFor(..) )++import Darcs.Test.TestOnly+import Darcs.Util.Hash ( SHA1, sha1Show, sha1Read )+import Darcs.Util.Parser+import Darcs.Util.Printer++-- TODO [V3INTEGRATION]:+-- Review whether we can use a PatchInfo directly here instead of a SHA1+-- Unless we can use observable sharing, this might be significantly+-- slower/less space efficient.+-- | Signed patch identity.+-- The 'SHA1' hash of the non-inverted meta data ('PatchInfo') plus an 'Int'+-- for the sequence number within the named patch, starting with 1. The 'Int'+-- gets inverted together with the patch and must never be 0 else we could not+-- distinguish between the patch and its inverse.+data PrimPatchId = PrimPatchId !Int !SHA1+  deriving (Eq, Ord, Show)++-- | This should only be used for testing, as it exposes the internal structure+-- of a 'PrimPatchId'.+unsafePrimPatchId :: TestOnly => Int -> SHA1 -> PrimPatchId+unsafePrimPatchId = PrimPatchId++prop_primPatchIdNonZero :: PrimPatchId -> Bool+prop_primPatchIdNonZero (PrimPatchId i _) = i /= 0++instance SignedId PrimPatchId where+  positiveId (PrimPatchId i _) = i > 0+  invertId (PrimPatchId i h) = PrimPatchId (- i) h++-- | Create an infinite list of positive 'PrimPatchId's.+positivePrimPatchIds :: PatchInfo -> [PrimPatchId]+positivePrimPatchIds info = map (flip PrimPatchId (makePatchname info)) [1..]++type NamedPrim = PrimWithName PrimPatchId++namedPrim :: PrimPatchId -> p wX wY -> NamedPrim p wX wY+namedPrim = PrimWithName++type instance PatchId (NamedPrim p) = PrimPatchId++-- TODO [V3INTEGRATION]:+-- It might be nice to elide the patch identifiers from the+-- on-disk format when they are the same as that of the containing patch+-- (which is the common case when there are no conflicts).+-- It's not that easy to implement as it requires refactoring to pass+-- the patch identifier downwards.+-- The sequence numbers could also be inferred from position.+instance StorableId PrimPatchId where+  readId = do+    lexString (BC.pack "hash")+    i <- int+    skipSpace+    x <- take 40+    liftMaybe $ PrimPatchId i <$> sha1Read x+   where+     liftMaybe = maybe mzero return++  showId ForStorage (PrimPatchId i h) =+    text "hash" <+> text (show i) <+> packedString (sha1Show h)+  showId ForDisplay _ = mempty++-- Because we are using unsafePerformIO, we need -fno-cse for+-- this module. We don't need -fno-full-laziness because the+-- body of the unsafePerformIO mentions 'p' so can't float outside+-- the scope of 'p'.+-- http://hackage.haskell.org/package/base-4.12.0.0/docs/System-IO-Unsafe.html+{-# NOINLINE anonymousNamedPrim #-}+anonymousNamedPrim :: p wX wY -> NamedPrim p wX wY+anonymousNamedPrim p =+  unsafePerformIO $ do+    b20 <- getRandomBytes 20+    b8 <- getRandomBytes 8+    return $+      PrimWithName+        (PrimPatchId+           (abs (Binary.decode $ BL.fromStrict b8))+           (Binary.decode $ BL.fromStrict b20))+        p
src/Darcs/Patch/Prim/V1.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1 ( Prim ) where  import Darcs.Patch.Prim.V1.Apply ()@@ -6,16 +5,6 @@ import Darcs.Patch.Prim.V1.Commute () import Darcs.Patch.Prim.V1.Core ( Prim ) import Darcs.Patch.Prim.V1.Details ()+import Darcs.Patch.Prim.V1.Mangle () import Darcs.Patch.Prim.V1.Read () import Darcs.Patch.Prim.V1.Show ()--import Darcs.Patch.Prim.Class ( PrimPatch, PrimPatchBase(..), FromPrim(..) )-import Darcs.Patch.Patchy ( Patchy )--instance PrimPatch Prim-instance Patchy Prim-instance PrimPatchBase Prim where-  type PrimOf Prim = Prim--instance FromPrim Prim where-  fromPrim = id
src/Darcs/Patch/Prim/V1/Apply.hs view
@@ -1,6 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE MultiWayIf #-} module Darcs.Patch.Prim.V1.Apply () where +import Darcs.Prelude++import Control.Monad.Catch ( MonadThrow(throwM) )+ import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Repair ( RepairToFL(..) ) @@ -10,43 +15,52 @@       DirPatchType(..), FilePatchType(..) ) import Darcs.Patch.Prim.V1.Show ( showHunk ) -import Darcs.Patch.FileName ( fn2fp )-import Darcs.Patch.Format ( FileNameFormat(..) )-import Darcs.Patch.TokenReplace ( tryTokInternal )--import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )-import Storage.Hashed.Tree( Tree )+import Darcs.Util.Path ( AnchoredPath, anchorPath )+import Darcs.Patch.Format ( FileNameFormat(FileNameFormatDisplay) )+import Darcs.Patch.TokenReplace ( tryTokReplace ) -import Darcs.Witnesses.Ordered ( FL(..), mapFL_FL, spanFL, (:>)(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoercePStart )+import Darcs.Patch.ApplyMonad ( ApplyMonadTree(..) )+import Darcs.Util.Tree( Tree ) -import ByteStringUtils ( unlinesPS, breakAfterNthNewline, breakBeforeNthNewline, )-import Printer( renderString )+import Darcs.Patch.Witnesses.Ordered ( FL(..), spanFL, (:>)(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoercePStart ) -import qualified Data.ByteString as B ( ByteString, empty, null, concat )-import qualified Data.ByteString.Char8 as BC (pack, singleton, unpack)-import Data.List ( intersperse )+import Darcs.Util.ByteString ( unlinesPS )+import Darcs.Util.Printer( renderString ) -#include "gadts.h"-#include "impossible.h"+import qualified Data.ByteString as B+    ( ByteString+    , drop+    , empty+    , null+    , concat+    , isPrefixOf+    , length+    , splitAt+    )+import qualified Data.ByteString.Char8 as BC (pack, unpack, unlines, elemIndices)  type FileContents = B.ByteString +ap2fp :: AnchoredPath -> FilePath+ap2fp = anchorPath ""+ instance Apply Prim where     type ApplyState Prim = Tree     apply (FP f RmFile) = mRemoveFile f     apply (FP f AddFile) = mCreateFile f-    apply p@(FP _ (Hunk _ _ _)) = applyPrimFL (p :>: NilFL)-    apply (FP f (TokReplace t o n)) = mModifyFilePSs f doreplace-        where doreplace ls =-                  case mapM (tryTokInternal t (BC.pack o) (BC.pack n)) ls of-                  Nothing -> fail $ "replace patch to " ++ fn2fp f+    apply (FP f (Hunk l o n)) = mModifyFilePS f $ applyHunk f (l, o, n)+    apply (FP f (TokReplace t o n)) = mModifyFilePS f doreplace+        where doreplace fc =+                  case tryTokReplace t (BC.pack o) (BC.pack n) fc of+                  Nothing -> throwM $ userError $ "replace patch to " ++ ap2fp f                              ++ " couldn't apply."-                  Just ls' -> return $ map B.concat ls'+                  Just fc' -> return fc'     apply (FP f (Binary o n)) = mModifyFilePS f doapply         where doapply oldf = if o == oldf                              then return n-                             else fail $ "binary patch to " ++ fn2fp f+                             else throwM $ userError+                                  $ "binary patch to " ++ ap2fp f                                   ++ " couldn't apply."     apply (DP d AddDir) = mCreateDirectory d     apply (DP d RmDir) = mRemoveDirectory d@@ -57,17 +71,17 @@     applyAndTryToFixFL (FP f RmFile) =         do x <- mReadFilePS f            mRemoveFile f-           return $ case B.null x of-             True -> Nothing-             False -> Just ("WARNING: Fixing removal of non-empty file "++fn2fp f,-                           -- No need to coerce because the content-                           -- removal patch has freely decided contexts-                            FP f (Binary x B.empty) :>: FP f RmFile :>: NilFL )+           return $ if B.null x+                        then Nothing+                        else Just ("WARNING: Fixing removal of non-empty file "++ap2fp f,+                                   -- No need to coerce because the content+                                   -- removal patch has freely decided contexts+                                   FP f (Binary x B.empty) :>: FP f RmFile :>: NilFL )     applyAndTryToFixFL (FP f AddFile) =         do exists <- mDoesFileExist f            if exists              then return $-                     Just ("WARNING: Dropping add of existing file "++fn2fp f,+                     Just ("WARNING: Dropping add of existing file "++ap2fp f,                            -- the old context was wrong, so we have to coerce                            unsafeCoercePStart NilFL                           )@@ -77,76 +91,169 @@         do exists <- mDoesDirectoryExist f            if exists              then return $-                     Just ("WARNING: Dropping add of existing directory "++fn2fp f,+                     Just ("WARNING: Dropping add of existing directory "++ap2fp f,                            -- the old context was wrong, so we have to coerce                            unsafeCoercePStart NilFL                           )              else do mCreateDirectory f                      return Nothing-    applyAndTryToFixFL p = do apply p; return Nothing+    applyAndTryToFixFL (FP f (Binary old new)) =+        do x <- mReadFilePS f+           mModifyFilePS f (\_ -> return new)+           if x /= old+             then return $+                     Just ("WARNING: Fixing binary patch to "++ap2fp f,+                           FP f (Binary x new) :>: NilFL+                          )+             else return Nothing+    applyAndTryToFixFL p@(Move old new) =+        do old_is_file <- mDoesFileExist old+           old_is_dir <- mDoesDirectoryExist old+           new_is_file <- mDoesFileExist new+           new_is_dir <- mDoesDirectoryExist new+           if | not (old_is_file || old_is_dir) ->+                  return $+                     Just ("WARNING: Dropping move patch with non-existing source "++ap2fp old,+                           unsafeCoercePStart NilFL+                          )+              | new_is_file || new_is_dir ->+                  return $+                     Just ("WARNING: Dropping move patch with existing target "++ap2fp old,+                           unsafeCoercePStart NilFL+                          )+              | otherwise -> apply p >> return Nothing+    applyAndTryToFixFL p = apply p >> return Nothing  instance PrimApply Prim where     applyPrimFL NilFL = return ()-    applyPrimFL ((FP f h@(Hunk _ _ _)):>:the_ps)+    applyPrimFL (h@(FP f (Hunk{})):>:the_ps)      = case spanFL f_hunk the_ps of            (xs :> ps') ->-               do let foo = h :>: mapFL_FL (\(FP _ h') -> h') xs-                  mModifyFilePS f $ hunkmod foo+               do mModifyFilePS f $ hunkmod (h :>: xs)                   applyPrimFL ps'-        where f_hunk (FP f' (Hunk _ _ _)) | f == f' = True+        where f_hunk (FP f' (Hunk{})) = f == f'               f_hunk _ = False-              hunkmod :: ApplyMonad m Tree => FL FilePatchType C(x y)+              -- TODO there should be a HOF that abstracts+              -- over this recursion scheme+              hunkmod :: MonadThrow m => FL Prim wX wY                       -> B.ByteString -> m B.ByteString-              hunkmod NilFL ps = return ps-              hunkmod (Hunk line old new:>:hs) ps-               = case applyHunkLines [(line,old,new)] ps of-                     Just ps' -> hunkmod hs ps'-                     Nothing -> fail $ "### Error applying:\n" ++-                                       (renderString $ showHunk NewFormat f line old new) ++-                                       "\n### to file " ++ fn2fp f ++ ":\n" ++ BC.unpack ps-              hunkmod _ _ = impossible-    applyPrimFL (p:>:ps) = do apply p-                              applyPrimFL ps+              hunkmod NilFL content = return content+              hunkmod (FP _ (Hunk line old new):>:hs) content =+                  applyHunk f (line, old, new) content >>= hunkmod hs+              hunkmod _ _ = error "impossible case"+    applyPrimFL (p:>:ps) = apply p >> applyPrimFL ps -applyHunks :: [(Int, [B.ByteString], [B.ByteString])]-           -> B.ByteString -> Maybe [B.ByteString]-applyHunks [] ps = Just [ps]-applyHunks ((l, [], n):hs) ps-    = case breakBeforeNthNewline (l - 2) ps of-      (prfix, after_prefix) -> do rest <- applyHunks hs after_prefix-                                  return $ intersperse nl (prfix:n) ++ rest-                                       where nl = BC.singleton '\n'-applyHunks ((l, o, n):hs) ps-    = case breakBeforeNthNewline (l - 2) ps of-      (prfix, after_prefix) ->-          case breakBeforeNthNewline (length o) after_prefix of-          (oo, _) | oo /= unlinesPS (B.empty:o) -> fail "applyHunks error"-          (_, suffix) ->-              do rest <- applyHunks hs suffix-                 return $ intersperse nl (prfix:n) ++ rest-    where nl = BC.singleton '\n'+applyHunk :: MonadThrow m+          => AnchoredPath+          -> (Int, [B.ByteString], [B.ByteString])+          -> FileContents+          -> m FileContents+applyHunk f h fc =+  case applyHunkLines h fc of+    Right fc' -> return fc'+    Left msg ->+      throwM $ userError $+      "### Error applying:\n" ++ renderHunk h +++      "\n### to file " ++ ap2fp f ++ ":\n" ++ BC.unpack fc +++      "### Reason: " ++ msg+  where+    renderHunk (l, o, n) = renderString (showHunk FileNameFormatDisplay f l o n) -applyHunkLines :: [(Int, [B.ByteString], [B.ByteString])]-               -> FileContents -> Maybe FileContents-applyHunkLines [] c = Just c-applyHunkLines [(1, [], n)] ps | B.null ps = Just $ unlinesPS (n++[B.empty])-applyHunkLines hs@((l, o, n):hs') ps =- do pss <- case l of-           1 -> case breakAfterNthNewline (length o) ps of-                Nothing -> if ps == unlinesPS o-                           then return $ intersperse nl n-                           else fail "applyHunkLines: Unexpected hunks"-                Just (shouldbeo, suffix)-                    | shouldbeo /= unlinesPS (o++[B.empty]) ->-                        fail $ "applyHunkLines: Bad patch!"-                    | null n ->-                        do x <- applyHunkLines hs' suffix-                           return [x]-                    | otherwise ->-                        do rest <- applyHunks hs' suffix-                           return $ intersperse nl n ++ nl:rest-           _ | l < 0 -> bug "Prim.applyHunkLines: After -ve lines?"-             | otherwise -> applyHunks hs ps-    let result = B.concat pss-    return result-    where nl = BC.singleton '\n'+{- The way darcs handles newlines is not easy to understand.++Everything seems pretty logical and conventional as long as files end in a+newline. In this case, the lines in a hunk can be regarded as newline+terminated, too. However, this view breaks down if we consider files that+are not newline terminated.++Here is a different view that covers the general case and explains,+conceptually, the algorithm below.++* Ever line (in a hunk or file) is regarded as being /preceded/ by a newline+  character.++* Every file starts out containing a single newline character, that is, a+  single empty line. A first empty line at the start of a file (if present)+  is /invisible/.++* When lines are appended to a file by a hunk, they are inserted /before/ a+  final empty line, if there is one. This results in a file that remains+  being terminated by a newline.++* In particular, when we start with an empty file and add a line, we push+  the invisible newline back, making it visible, and the newline that+  initiates our new content becomes invisible instead. This results in a+  newline terminated file, as above.++* However, if there is a newline at the end of a file (remember that this+  includes the case of an empty file), a hunk can /remove/ it by removing an+  empty line before adding anything. This results in a file that is /not/+  newline terminated.++The invisible newline character at the front is, of course, not present+anywhere in the representation of files, it is just a conceptual tool.++The algorithm below is highly optimized to minimize allocation of+intermediate ByteStrings. -}++applyHunkLines :: (Int, [B.ByteString], [B.ByteString])+               -> FileContents+               -> Either String FileContents+applyHunkLines (line, old, new) content+  | line == 1 =+      {- This case is subtle because here we have to deal with any invisible+      newline at the front of a file without it actually being present. We+      first try to drop everything up to the (length old)'th newline. ++      If this fails, we know that the content was not newline terminated. So+      we replace everything with the new content, interspersing but not+      terminating the lines with newline characters.++      If it succeeds, we insert the new content, interspersing /and/+      terminating the lines with newline characters before appending the+      rest of the content. -}+      case breakAfterNthNewline (length old) content of+        Nothing+          -- old content is not newline terminated+          | content == unlinesPS old -> Right $ unlinesPS new+          | otherwise -> Left "Hunk wants to remove content that isn't there"+        Just (should_be_old, suffix)+          -- old content is newline terminated+          | should_be_old == BC.unlines old ->+              Right $ unlinesPS $ new ++ [suffix]+          | otherwise ->+              Left "Hunk wants to remove content that isn't there"+  | line >= 2 = do+      {- This is the simpler case. We can be sure that we have at least one+      newline character at the point where we modify the file. This means we+      can apply the conceptual view literally, i.e. replace old content with+      new content /before/ this newline, where the lines in the old and new+      content are /preceded/ by newline characters. -}+      (pre, start) <- breakBeforeNthNewline (line-2) content+      let hunkContent ls = unlinesPS (B.empty:ls)+      post <- dropPrefix (hunkContent old) start+      return $ B.concat [pre, hunkContent new, post]+  | otherwise = Left "Hunk has zero or negative line number"+  where+    dropPrefix x y+      | x `B.isPrefixOf` y = Right $ B.drop (B.length x) y+      | otherwise =+        Left $ "Hunk wants to remove content that isn't there"++breakAfterNthNewline :: Int -> B.ByteString -> Maybe (B.ByteString, B.ByteString)+breakAfterNthNewline 0 the_ps = Just (B.empty, the_ps)+breakAfterNthNewline n _ | n < 0 = error "precondition of breakAfterNthNewline"+breakAfterNthNewline n the_ps = go n (BC.elemIndices '\n' the_ps)+  where+    go _ [] = Nothing -- we have fewer than n newlines+    go 1 (i:_) = Just $ B.splitAt (i + 1) the_ps+    go !m (_:is) = go (m - 1) is++breakBeforeNthNewline :: Int -> B.ByteString -> Either String (B.ByteString, B.ByteString)+breakBeforeNthNewline n _ | n < 0 = error "precondition of breakBeforeNthNewline"+breakBeforeNthNewline n the_ps = go n (BC.elemIndices '\n' the_ps)+  where+    go 0 [] = Right (the_ps, B.empty)+    go 0 (i:_) = Right $ B.splitAt i the_ps+    go !m (_:is) = go (m - 1) is+    go _ [] = Left "Line number does not exist"
src/Darcs/Patch/Prim/V1/Coalesce.hs view
@@ -1,239 +1,148 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TupleSections #-}+ module Darcs.Patch.Prim.V1.Coalesce     ()     where -import Prelude hiding ( pi )-import Data.Map ( elems, fromListWith, mapWithKey )+import Darcs.Prelude -import qualified Data.ByteString as B (ByteString)+import qualified Data.Map as M -import Darcs.Patch.FileName ( FileName, fp2fn )-import Darcs.Patch.Prim.Class ( PrimCanonize(..) )+import qualified Data.ByteString as B ( ByteString )++import System.FilePath ( (</>) )++import Darcs.Patch.Prim.Class ( PrimCoalesce(..) )+import Darcs.Patch.Prim.Coalesce import Darcs.Patch.Prim.V1.Commute ()-import Darcs.Patch.Prim.V1.Core-    ( Prim(..), FilePatchType(..), DirPatchType(..)-    , comparePrim, isIdentity-    )+import Darcs.Patch.Prim.V1.Core ( DirPatchType(..), FilePatchType(..), Prim(..) ) import Darcs.Patch.Prim.V1.Show ()-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:<)(..)-                               , reverseRL, mapFL, mapFL_FL-                               , concatFL, lengthFL, (+>+) )-import Darcs.Witnesses.Sealed ( unseal, Sealed2(..), unsafeUnseal2-                              , Gap(..), unFreeLeft-                              )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )-import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Commute ( Commute(..) )--- import Darcs.Patch.Permutations () -- for Invert instance of FL-import Lcs ( getChanges )--#include "gadts.h"-#include "impossible.h"+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), concatFL, mapFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2 )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP ) --- | 'coalesce' @p2 :< p1@ tries to combine @p1@ and @p2@ into a single---   patch without intermediary changes.  For example, two hunk patches---   modifying adjacent lines can be coalesced into a bigger hunk patch.---   Or a patch which moves file A to file B can be coalesced with a---   patch that moves file B into file C, yielding a patch that moves---   file A to file C.-coalesce :: (Prim :< Prim) C(x y) -> Maybe (FL Prim C(x y))-coalesce (FP f1 _ :< FP f2 _) | f1 /= f2 = Nothing-coalesce (p2 :< p1) | IsEq <- p2 =\/= invert p1 = Just NilFL-coalesce (FP f1 p1 :< FP _ p2) = fmap (:>: NilFL) $ coalesceFilePrim f1 (p1 :< p2) -- f1 = f2-coalesce (Move a b :< Move b' a') | a == a' = Just $ Move b' b :>: NilFL-coalesce (Move a b :< FP f AddFile) | f == a = Just $ FP b AddFile :>: NilFL-coalesce (Move a b :< DP f AddDir) | f == a = Just $ DP b AddDir :>: NilFL-coalesce (FP f RmFile :< Move a b) | b == f = Just $ FP a RmFile :>: NilFL-coalesce (DP f RmDir :< Move a b) | b == f = Just $ DP a RmDir :>: NilFL-coalesce (ChangePref p f1 t1 :< ChangePref p2 f2 t2) | p == p2 && t2 == f1 = Just $ ChangePref p f2 t1 :>: NilFL-coalesce _ = Nothing+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Path ( AnchoredPath, unsafeFloatPath ) -mapPrimFL :: (FORALL(x y) FL Prim C(x y) -> FL Prim C(x y))-             -> FL Prim C(w z) -> FL Prim C(w z)-mapPrimFL f x =--- an optimisation; break the list up into independent sublists--- and apply f to each of them-     case mapM toSimpleSealed $ mapFL Sealed2 x of-     Just sx -> concatFL $ unsealList $ elems $-                mapWithKey (\ k p -> Sealed2 (f (fromSimples k (unsealList (p []))))) $-                fromListWith (flip (.)) $-                map (\ (a,b) -> (a,(b:))) sx-     Nothing -> f x+-- | Map a monadic function over an 'FL' of 'Prim's.+--+-- Be careful which 'Monad' to choose when using this function. For instance,+-- 'Maybe' would return 'Nothing' if any of the calls failed to shrink their+-- argument, which usually not what we want. A suitable candidate is @('Any',)@.+mapPrimFL :: Monad m+          => (forall wA wB . FL Prim wA wB -> m (FL Prim wA wB))+          -> FL Prim wX wY -> m (FL Prim wX wY)+mapPrimFL f ps =+  -- an optimisation; break the list up into independent sublists+  -- and apply f to each of them+  case mapM withPathAsKey $ mapFL Sealed2 ps of+    Just pairs ->+      concatFL .+      unsealList .+      M.elems <$>+      (mapM (fmap Sealed2 . f . unsealList . ($ [])) $+      M.fromListWith (flip (.)) $ map (\(k, v) -> (k, (v :))) pairs)+    Nothing -> f ps   where-        unsealList :: [Sealed2 p] -> FL p C(a b)-        unsealList [] = unsafeCoerceP NilFL-        unsealList (y:ys) = unsafeUnseal2 y :>: unsealList ys--        toSimpleSealed :: Sealed2 Prim -> Maybe (FileName, Sealed2 Simple)-        toSimpleSealed (Sealed2 p) = fmap (\(fn, s) -> (fn, Sealed2 s)) (toSimple p)----data Simple C(x y) = SFP !(FilePatchType C(x y)) | SDP !(DirPatchType C(x y))-                   | SCP String String String-                   deriving ( Show )--toSimple :: Prim C(x y) -> Maybe (FileName, Simple C(x y))-toSimple (FP a b) = Just (a, SFP b)-toSimple (DP a AddDir) = Just (a, SDP AddDir)-toSimple (DP _ RmDir) = Nothing -- ordering is trickier with rmdir present-toSimple (Move _ _) = Nothing-toSimple (ChangePref a b c) = Just (fp2fn "_darcs/prefs/prefs", SCP a b c)--fromSimple :: FileName -> Simple C(x y) -> Prim C(x y)-fromSimple a (SFP b) = FP a b-fromSimple a (SDP b) = DP a b-fromSimple _ (SCP a b c) = ChangePref a b c--fromSimples :: FileName -> FL Simple C(x y) -> FL Prim C(x y)-fromSimples a bs = mapFL_FL (fromSimple a) bs--tryHarderToShrink :: FL Prim C(x y) -> FL Prim C(x y)-tryHarderToShrink x = tryToShrink2 $ maybe x id (tryShrinkingInverse x)--tryToShrink2 :: FL Prim C(x y) -> FL Prim C(x y)-tryToShrink2 psold =-    let ps = sortCoalesceFL psold-        ps_shrunk = shrinkABit ps-                    in-    if lengthFL ps_shrunk < lengthFL ps-    then tryToShrink2 ps_shrunk-    else ps_shrunk--shrinkABit :: FL Prim C(x y) -> FL Prim C(x y)-shrinkABit NilFL = NilFL-shrinkABit (p:>:ps) =-    case tryOne NilRL p ps of-    Nothing -> p :>: shrinkABit ps-    Just ps' -> ps'+    unsealList :: [Sealed2 p] -> FL p wA wB+    unsealList = foldr ((:>:) . unseal2 unsafeCoerceP) (unsafeCoerceP NilFL) -tryOne :: RL Prim C(w x) -> Prim C(x y) -> FL Prim C(y z)-        -> Maybe (FL Prim C(w z))-tryOne _ _ NilFL = Nothing-tryOne sofar p (p1:>:ps) =-    case coalesce (p1 :< p) of-    Just p' -> Just (reverseRL sofar +>+ p' +>+ ps)-    Nothing -> case commute (p :> p1) of-               Nothing -> Nothing-               Just (p1' :> p') -> tryOne (p1':<:sofar) p' ps+    withPathAsKey :: Sealed2 Prim -> Maybe (AnchoredPath, Sealed2 Prim)+    withPathAsKey (Sealed2 p) = fmap (, Sealed2 p) $ getKey p --- | The heart of "sortCoalesceFL"-sortCoalesceFL2 :: FL Prim C(x y) -> FL Prim C(x y)-sortCoalesceFL2 NilFL = NilFL-sortCoalesceFL2 (x:>:xs) | IsEq <- isIdentity x = sortCoalesceFL2 xs-sortCoalesceFL2 (x:>:xs) = either id id $ pushCoalescePatch x $ sortCoalesceFL2 xs+    getKey (FP fp _) = Just fp+    getKey (DP fp AddDir) = Just fp+    getKey (DP _ RmDir) = Nothing -- ordering is trickier with rmdir present+    getKey (Move {}) = Nothing+    getKey (ChangePref {}) = Just (unsafeFloatPath (darcsdir </> "prefs" </> "prefs")) --- | 'pushCoalescePatch' @new ps@ is almost like @new :>: ps@ except---   as an alternative to consing, we first try to coalesce @new@ with---   the head of @ps@.  If this fails, we try again, using commutation---   to push @new@ down the list until we find a place where either---   (a) @new@ is @LT@ the next member of the list [see 'comparePrim']---   (b) commutation fails or---   (c) coalescing succeeds.---   The basic principle is to coalesce if we can and cons otherwise.------   As an additional optimization, pushCoalescePatch outputs a Left---   value if it wasn't able to shrink the patch sequence at all, and---   a Right value if it was indeed able to shrink the patch sequence.---   This avoids the O(N) calls to lengthFL that were in the older---   code.------   Also note that pushCoalescePatch is only ever used (and should---   only ever be used) as an internal function in in---   sortCoalesceFL2.-pushCoalescePatch :: Prim C(x y) -> FL Prim C(y z)-                    -> Either (FL Prim C(x z)) (FL Prim C(x z))-pushCoalescePatch new NilFL = Left (new:>:NilFL)-pushCoalescePatch new ps@(p:>:ps')-    = case coalesce (p :< new) of-      Just (new' :>: NilFL) -> Right $ either id id $ pushCoalescePatch new' ps'-      Just NilFL -> Right ps'-      Just _ -> impossible -- coalesce either returns a singleton or empty-      Nothing -> if comparePrim new p == LT then Left (new:>:ps)-                            else case commute (new :> p) of-                                 Just (p' :> new') ->-                                     case pushCoalescePatch new' ps' of-                                     Right r -> Right $ either id id $-                                                pushCoalescePatch p' r-                                     Left r -> Left (p' :>: r)-                                 Nothing -> Left (new:>:ps)+-- | @'coalescePair' p1 p2@ tries to combine @p1@ and @p2@ into a single+--   patch. For example, two hunk patches+--   modifying adjacent lines can be coalesced into a bigger hunk patch.+--   Or a patch which moves file A to file B can be coalesced with a+--   patch that moves file B into file C, yielding a patch that moves+--   file A to file C.+coalescePair :: Prim wX wY -> Prim wY wZ -> Maybe (Prim wX wZ)+coalescePair (FP f1 p1) (FP f2 p2)+  | f1 /= f2 = Nothing+  | otherwise = coalesceFilePrim f1 p1 p2+coalescePair (Move a b) (Move b' c) | b == b' = Just $ Move a c+coalescePair (FP a AddFile) (Move a' b) | a == a' = Just $ FP b AddFile+coalescePair (DP a AddDir) (Move a' b)  | a == a' = Just $ DP b AddDir+coalescePair (Move a b) (FP b' RmFile)  | b == b' = Just $ FP a RmFile+coalescePair (Move a b) (DP b' RmDir)   | b == b' = Just $ DP a RmDir+coalescePair (ChangePref p a b) (ChangePref p' b' c)+  | p == p' && b == b' = Just $ ChangePref p a c+coalescePair _ _ = Nothing -coalesceFilePrim :: FileName -> (FilePatchType :< FilePatchType) C(x y)-                  -> Maybe (Prim C(x y))-coalesceFilePrim f (Hunk line1 old1 new1 :< Hunk line2 old2 new2)+coalesceFilePrim :: AnchoredPath -> FilePatchType wX wY -> FilePatchType wY wZ+                 -> Maybe (Prim wX wZ)+coalesceFilePrim f (Hunk line1 old1 new1) (Hunk line2 old2 new2)     = coalesceHunk f line1 old1 new1 line2 old2 new2--- Token replace patches operating right after (or before) AddFile (RmFile)+-- Token replace patches operating right after AddFile or before RmFile -- is an identity patch, as far as coalescing is concerned.-coalesceFilePrim f (TokReplace _ _ _ :< AddFile) = Just $ FP f AddFile-coalesceFilePrim f (RmFile :< TokReplace _ _ _) = Just $ FP f RmFile-coalesceFilePrim f (TokReplace t1 o1 n1 :< TokReplace t2 o2 n2)-    | t1 == t2 && n2 == o1 = Just $ FP f $ TokReplace t1 o2 n1-coalesceFilePrim f (Binary m n :< Binary o m')+coalesceFilePrim f (AddFile) (TokReplace{}) = Just $ FP f AddFile+coalesceFilePrim f (TokReplace{}) (RmFile) = Just $ FP f RmFile+coalesceFilePrim f (TokReplace t1 a b) (TokReplace t2 b' c)+    | t1 == t2 && b == b' = Just $ FP f $ TokReplace t1 a c+coalesceFilePrim f (Binary o m') (Binary m n)     | m == m' = Just $ FP f $ Binary o n-coalesceFilePrim _ _ = Nothing+coalesceFilePrim _ _ _ = Nothing -coalesceHunk :: FileName+coalesceHunk :: AnchoredPath              -> Int -> [B.ByteString] -> [B.ByteString]              -> Int -> [B.ByteString] -> [B.ByteString]-             -> Maybe (Prim C(x y))+             -> Maybe (Prim wX wY) coalesceHunk f line1 old1 new1 line2 old2 new2-    | line1 == line2 && lengthold1 < lengthnew2 =-        if take lengthold1 new2 /= old1+    | line2 == line1 && lengthold2 < lengthnew1 =+        if take lengthold2 new1 /= old2         then Nothing-        else case drop lengthold1 new2 of-        extranew -> Just (FP f (Hunk line1 old2 (new1 ++ extranew)))-    | line1 == line2 && lengthold1 > lengthnew2 =-        if take lengthnew2 old1 /= new2+        else case drop lengthold2 new1 of+        extranew -> Just (FP f (Hunk line2 old1 (new2 ++ extranew)))+    | line2 == line1 && lengthold2 > lengthnew1 =+        if take lengthnew1 old2 /= new1         then Nothing-        else case drop lengthnew2 old1 of-        extraold -> Just (FP f (Hunk line1 (old2 ++ extraold) new1))-    | line1 == line2 = if new2 == old1 then Just (FP f (Hunk line1 old2 new1))+        else case drop lengthnew1 old2 of+        extraold -> Just (FP f (Hunk line2 (old1 ++ extraold) new2))+    | line2 == line1 = if new1 == old2 then Just (FP f (Hunk line2 old1 new2))                        else Nothing-    | line1 < line2 && lengthold1 >= line2 - line1 =-        case take (line2 - line1) old1 of-        extra-> coalesceHunk f line1 old1 new1 line1 (extra ++ old2) (extra ++ new2)-    | line1 > line2 && lengthnew2 >= line1 - line2 =-        case take (line1 - line2) new2 of+    | line2 < line1 && lengthold2 >= line1 - line2 =+        case take (line1 - line2) old2 of         extra-> coalesceHunk f line2 (extra ++ old1) (extra ++ new1) line2 old2 new2+    | line2 > line1 && lengthnew1 >= line2 - line1 =+        case take (line2 - line1) new1 of+        extra-> coalesceHunk f line1 old1 new1 line1 (extra ++ old2) (extra ++ new2)     | otherwise = Nothing-    where lengthold1 = length old1-          lengthnew2 = length new2+    where lengthold2 = length old2+          lengthnew1 = length new1 -canonizeHunk :: Gap w-             => FileName -> Int -> [B.ByteString] -> [B.ByteString]-             -> w (FL Prim)-canonizeHunk f line old new-    | null old || null new-        = freeGap (FP f (Hunk line old new) :>: NilFL)-canonizeHunk f line old new = makeHoley f line $ getChanges old new+instance PrimCoalesce Prim where+  tryToShrink = withAnyToMaybe . mapPrimFL sortCoalesceFL2 -makeHoley :: Gap w-          => FileName -> Int -> [(Int,[B.ByteString], [B.ByteString])]-          -> w (FL Prim)-makeHoley f line changes =-    foldr (joinGap (:>:)) (emptyGap NilFL) $-    map (\ (l,o,n) -> freeGap (FP f (Hunk (l+line) o n))) changes+  sortCoalesceFL = snd . mapPrimFL sortCoalesceFL2 -instance PrimCanonize Prim where-   tryToShrink = mapPrimFL tryHarderToShrink+  primCoalesce = coalescePair -   tryShrinkingInverse (x:>:y:>:z)-       | IsEq <- invert x =\/= y = Just z-       | otherwise = case tryShrinkingInverse (y:>:z) of-                     Nothing -> Nothing-                     Just yz' -> Just $ case tryShrinkingInverse (x:>:yz') of-                                        Nothing -> x:>:yz'-                                        Just xyz' -> xyz'-   tryShrinkingInverse _ = Nothing+  isIdentity (FP _ (Binary old new)) | old == new = unsafeCoerceP IsEq+  isIdentity (FP _ (Hunk _ old new)) | old == new = unsafeCoerceP IsEq+  isIdentity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerceP IsEq+  isIdentity (Move old new) | old == new = unsafeCoerceP IsEq+  isIdentity _ = NotEq -   sortCoalesceFL = mapPrimFL sortCoalesceFL2-   canonize p | IsEq <- isIdentity p = NilFL-   canonize (FP f (Hunk line old new)) = unseal unsafeCoercePEnd $ unFreeLeft $ canonizeHunk f line old new-   canonize p = p :>: NilFL-   -- Running canonize twice is apparently necessary to fix issue525;-   -- would be nice to understand why.-   canonizeFL = concatFL . mapFL_FL canonize . sortCoalesceFL .-                concatFL . mapFL_FL canonize-   join (x :> y) = coalesce (y :< x)+  -- Basically, identical patches are equal and+  -- @Move < DP < FP < ChangePref@.+  -- Everything else is compared in dictionary order of its arguments.+  comparePrim (Move a b) (Move c d) = compare (a, b) (c, d)+  comparePrim (Move _ _) _ = LT+  comparePrim _ (Move _ _) = GT+  comparePrim (DP d1 p1) (DP d2 p2) = compare (d1, p1) $ unsafeCoerceP (d2, p2)+  comparePrim (DP _ _) _ = LT+  comparePrim _ (DP _ _) = GT+  comparePrim (FP f1 fp1) (FP f2 fp2) =+    compare (f1, fp1) $ unsafeCoerceP (f2, fp2)+  comparePrim (FP _ _) _ = LT+  comparePrim _ (FP _ _) = GT+  comparePrim (ChangePref a1 b1 c1) (ChangePref a2 b2 c2) =+    compare (c1, b1, a1) (c2, b2, a2)
src/Darcs/Patch/Prim/V1/Commute.hs view
@@ -1,30 +1,43 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Prim.V1.Commute-    ( Perhaps(..)-    , subcommutes, WrappedCommuteFunction(..)-    )-    where+module Darcs.Patch.Prim.V1.Commute () where -import Prelude hiding ( pi )+import Darcs.Prelude+ import Control.Monad ( MonadPlus, msum, mzero, mplus )+import Control.Applicative ( Alternative(..) ) -import qualified Data.ByteString as B (ByteString, concat)-import qualified Data.ByteString.Char8 as BC (pack)+import qualified Data.ByteString as B ( ByteString )+import qualified Data.ByteString.Char8 as BC ( pack ) -import Darcs.Patch.FileName ( FileName, fn2fp, movedirfilename )-import Darcs.Witnesses.Ordered ( (:<)(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Util.Path ( AnchoredPath, movedirfilename, isPrefix )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..) ) import Darcs.Patch.Prim.V1.Core      ( Prim(..), FilePatchType(..) ) import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Commute ( Commute(..), toFwdCommute, toRevCommute )+import Darcs.Patch.Merge ( CleanMerge(..) )+import Darcs.Patch.Commute ( Commute(..) ) import Darcs.Patch.Permutations () -- for Invert instance of FL-import Darcs.Patch.TokenReplace ( tryTokInternal )+import Darcs.Patch.Prim.Class ( primCleanMerge )+import Darcs.Patch.TokenReplace ( tryTokReplace ) -#include "impossible.h"-#include "gadts.h"+isSuperdir :: AnchoredPath -> AnchoredPath -> Bool+isSuperdir d1 d2 = isPrefix d1 d2 && d1 /= d2 -isInDirectory :: FileName -> FileName -> Bool+{-+This is the original definition.+Note that it explicitly excludes equality:++isSuperdir d1 d2 = isd (fn2fp d1) (fn2fp d2)+  where+    isd s1 s2 =+      length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/"+-}++isInDirectory :: AnchoredPath -> AnchoredPath -> Bool+isInDirectory = isPrefix+{-+Again, here is the orginial definition: isInDirectory d f = iid (fn2fp d) (fn2fp f)     where iid (cd:cds) (cf:cfs)               | cd /= cf = False@@ -32,40 +45,50 @@           iid [] ('/':_) = True           iid [] [] = True -- Count directory itself as being in directory...           iid _ _ = False+-}  data Perhaps a = Unknown | Failed | Succeeded a +instance Functor Perhaps where+    fmap _ Unknown = Unknown+    fmap _ Failed = Failed+    fmap f (Succeeded x) = Succeeded (f x)++instance Applicative Perhaps where+    pure = Succeeded+    _ <*> Failed = Failed+    _ <*> Unknown = Unknown+    Failed <*> _ = Failed+    Unknown <*> _ = Unknown+    Succeeded f <*> Succeeded x = Succeeded (f x)+ instance  Monad Perhaps where     (Succeeded x) >>= k =  k x     Failed   >>= _      =  Failed     Unknown  >>= _      =  Unknown-    Failed   >> _       =  Failed-    (Succeeded _) >> k  =  k-    Unknown  >> k       =  k-    return              =  Succeeded-    fail _              =  Unknown+    return              =  pure +instance Alternative Perhaps where+    empty = Unknown+    Unknown <|> ys    = ys+    Failed  <|> _     = Failed+    (Succeeded x) <|> _ = Succeeded x+ instance  MonadPlus Perhaps where-    mzero                 = Unknown-    Unknown `mplus` ys    = ys-    Failed  `mplus` _     = Failed-    (Succeeded x) `mplus` _ = Succeeded x+    mzero = Unknown+    mplus = (<|>)  toMaybe :: Perhaps a -> Maybe a toMaybe (Succeeded x) = Just x toMaybe _ = Nothing -toPerhaps :: Maybe a -> Perhaps a-toPerhaps (Just x) = Succeeded x-toPerhaps Nothing = Failed- cleverCommute :: CommuteFunction -> CommuteFunction-cleverCommute c (p1:<p2) =-    case c (p1 :< p2) of+cleverCommute c (p1:>p2) =+    case c (p1 :> p2) of     Succeeded x -> Succeeded x     Failed -> Failed-    Unknown -> case c (invert p2 :< invert p1) of-               Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1')+    Unknown -> case c (invert p2 :> invert p1) of+               Succeeded (p1' :> p2') -> Succeeded (invert p2' :> invert p1')                Failed -> Failed                Unknown -> Unknown --cleverCommute c (p1,p2) = c (p1,p2) `mplus`@@ -76,17 +99,17 @@  speedyCommute :: CommuteFunction  -- Deal with common cases quickly!     -- Two file-patches modifying different files trivially commute.-speedyCommute (p2@(FP f' _) :< p1@(FP f _))-  | f /= f' = Succeeded (unsafeCoerceP p1 :< unsafeCoerceP p2)+speedyCommute (p1@(FP f1 _) :> p2@(FP f2 _))+  | f1 /= f2 = Succeeded (unsafeCoerceP p2 :> unsafeCoerceP p1) speedyCommute _other = Unknown  everythingElseCommute :: CommuteFunction-everythingElseCommute x = eec x-    where+everythingElseCommute = eec+  where     eec :: CommuteFunction-    eec (ChangePref p f t :<p1) = Succeeded (unsafeCoerceP p1 :< ChangePref p f t)-    eec (p2 :<ChangePref p f t) = Succeeded (ChangePref p f t :< unsafeCoerceP p2)-    eec xx = cleverCommute commuteFiledir                xx+    eec (p1 :> ChangePref p f t) = Succeeded (ChangePref p f t :> unsafeCoerceP p1)+    eec (ChangePref p f t :> p2) = Succeeded (unsafeCoerceP p2 :> ChangePref p f t)+    eec xx = cleverCommute commuteFiledir xx  {- Note that it must be true that@@ -100,116 +123,98 @@ -}  instance Commute Prim where-    commute x = toMaybe $ msum [toFwdCommute speedyCommute x,-                                toFwdCommute everythingElseCommute x+    commute x = toMaybe $ msum [speedyCommute x,+                                everythingElseCommute x                                ] -isSuperdir :: FileName -> FileName -> Bool-isSuperdir d1 d2 = isd (fn2fp d1) (fn2fp d2)-    where isd s1 s2 =-              length s2 >= length s1 + 1 && take (length s1 + 1) s2 == s1 ++ "/"- commuteFiledir :: CommuteFunction-commuteFiledir (FP f1 p1 :< FP f2 p2) =-  if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerceP p2) :< FP f1 (unsafeCoerceP p1) )-  else commuteFP f1 (p1 :< p2)-commuteFiledir (DP d1 p1 :< DP d2 p2) =-  if (not $ isInDirectory d1 d2) && (not $ isInDirectory d2 d1) &&-     d1 /= d2-  then Succeeded ( DP d2 (unsafeCoerceP p2) :< DP d1 (unsafeCoerceP p1) )+commuteFiledir (FP f1 p1 :> FP f2 p2) =+  if f1 /= f2 then Succeeded ( FP f2 (unsafeCoerceP p2) :> FP f1 (unsafeCoerceP p1) )+  else commuteFP f1 (p1 :> p2)+commuteFiledir (DP d1 p1 :> DP d2 p2) =+  if not (isInDirectory d1 d2 || isInDirectory d2 d1) && d1 /= d2+  then Succeeded ( DP d2 (unsafeCoerceP p2) :> DP d1 (unsafeCoerceP p1) )   else Failed-commuteFiledir (DP d dp :< FP f fp) =+commuteFiledir (FP f fp :> DP d dp) =     if not $ isInDirectory d f-    then Succeeded (FP f (unsafeCoerceP fp) :< DP d (unsafeCoerceP dp))+    then Succeeded (DP d (unsafeCoerceP dp) :> FP f (unsafeCoerceP fp))     else Failed -commuteFiledir (Move d d' :< FP f2 p2)-    | f2 == d' = Failed-    | (p2 == AddFile || p2 == RmFile) && d == f2 = Failed-    | otherwise = Succeeded (FP (movedirfilename d d' f2) (unsafeCoerceP p2) :< Move d d')-commuteFiledir (Move d d' :< DP d2 p2)-    | isSuperdir d2 d' || isSuperdir d2 d = Failed-    | d == d2 = Failed  -- The exact guard is p2 == AddDir && d == d2-                        -- but note d == d2 suffices because we know p2 != RmDir-                        -- (and hence p2 == AddDir) since patches must be sequential.-    | d2 == d' = Failed-    | otherwise = Succeeded (DP (movedirfilename d d' d2) (unsafeCoerceP p2) :< Move d d')-commuteFiledir (Move d d' :< Move f f')+-- FIXME using isSuperdir here makes no sense, should use just isPrefix++commuteFiledir (FP f1 p1 :> Move d d')+    | f1 == d' = Failed+    | (p1 == AddFile || p1 == RmFile) && d == f1 = Failed+    | otherwise = Succeeded (Move d d' :> FP (movedirfilename d d' f1) (unsafeCoerceP p1))+commuteFiledir (DP d1 p1 :> Move d d')+    | isSuperdir d1 d' || isSuperdir d1 d = Failed+    | d == d1 = Failed  -- The exact guard is p1 == AddDir && d == d1+                        -- but note d == d1 suffices because we know p1 != RmDir+                        -- (and hence p1 == AddDir) since patches must be sequential.+    | d1 == d' = Failed+    | otherwise = Succeeded (Move d d' :> DP (movedirfilename d d' d1) (unsafeCoerceP p1))+commuteFiledir (Move f f' :> Move d d')     | f == d' || f' == d = Failed     | f == d || f' == d' = Failed     | d `isSuperdir` f && f' `isSuperdir` d' = Failed     | otherwise =-        Succeeded (Move (movedirfilename d d' f) (movedirfilename d d' f') :<-                   Move (movedirfilename f' f d) (movedirfilename f' f d'))+        Succeeded (Move (movedirfilename f' f d) (movedirfilename f' f d') :>+                   Move (movedirfilename d d' f) (movedirfilename d d' f'))  commuteFiledir _ = Unknown -type CommuteFunction = FORALL(x y) (Prim :< Prim) C(x y) -> Perhaps ((Prim :< Prim) C(x y))-newtype WrappedCommuteFunction = WrappedCommuteFunction { runWrappedCommuteFunction :: CommuteFunction }--subcommutes :: [(String, WrappedCommuteFunction)]-subcommutes =-    [("speedyCommute", WrappedCommuteFunction speedyCommute),-     ("commuteFiledir", WrappedCommuteFunction (cleverCommute commuteFiledir)),-     ("commuteFilepatches", WrappedCommuteFunction (cleverCommute commuteFilepatches)),-     ("commutex", WrappedCommuteFunction (toPerhaps . toRevCommute commute))-    ]--commuteFilepatches :: CommuteFunction-commuteFilepatches (FP f1 p1 :< FP f2 p2) | f1 == f2 = commuteFP f1 (p1 :< p2)-commuteFilepatches _ = Unknown+type CommuteFunction = forall wX wY . (Prim :> Prim) wX wY -> Perhaps ((Prim :> Prim) wX wY) -commuteFP :: FileName -> (FilePatchType :< FilePatchType) C(x y)-          -> Perhaps ((Prim :< Prim) C(x y))-commuteFP f (Hunk line1 [] [] :< p2) =-    seq f $ Succeeded (FP f (unsafeCoerceP p2) :< FP f (Hunk line1 [] []))-commuteFP f (p2 :< Hunk line1 [] []) =-    seq f $ Succeeded (FP f (Hunk line1 [] []) :< FP f (unsafeCoerceP p2))-commuteFP f (Hunk line1 old1 new1 :< Hunk line2 old2 new2) = seq f $-  toPerhaps $ commuteHunk f (Hunk line1 old1 new1 :< Hunk line2 old2 new2)-commuteFP f (TokReplace t o n :< Hunk line2 old2 new2) = seq f $-    case tryTokReplace t o n old2 of-    Nothing -> Failed-    Just old2' ->-      case tryTokReplace t o n new2 of+commuteFP :: AnchoredPath -> (FilePatchType :> FilePatchType) wX wY+          -> Perhaps ((Prim :> Prim) wX wY)+commuteFP f (p1 :> Hunk line1 [] []) =+    Succeeded (FP f (Hunk line1 [] []) :> FP f (unsafeCoerceP p1))+commuteFP f (Hunk line1 [] [] :> p2) =+    Succeeded (FP f (unsafeCoerceP p2) :> FP f (Hunk line1 [] []))+commuteFP f (Hunk line1 old1 new1 :> Hunk line2 old2 new2) =+    case commuteHunkLines line1 (length old1) (length new1) line2 (length old2) (length new2) of+      Just (line2', line1') ->+        Succeeded (FP f (Hunk line2' old2 new2) :> FP f (Hunk line1' old1 new1))       Nothing -> Failed-      Just new2' -> Succeeded (FP f (Hunk line2 old2' new2') :<-                               FP f (TokReplace t o n))-commuteFP f (TokReplace t o n :< TokReplace t2 o2 n2)-    | seq f $ t /= t2 = Failed-    | o == o2 = Failed-    | n == o2 = Failed-    | o == n2 = Failed-    | n == n2 = Failed-    | otherwise = Succeeded (FP f (TokReplace t2 o2 n2) :<-                             FP f (TokReplace t o n))+commuteFP f (Hunk line1 old1 new1 :> TokReplace t o n) =+    let po = BC.pack o; pn = BC.pack n in+    case tryTokReplaces t po pn old1 of+    Nothing -> Failed+    Just old1' ->+      case tryTokReplaces t po pn new1 of+        Nothing -> Failed+        Just new1' -> Succeeded (FP f (TokReplace t o n) :>+                                 FP f (Hunk line1 old1' new1'))+commuteFP f (TokReplace t1 o1 n1 :> TokReplace t2 o2 n2)+    | t1 /= t2 = Failed+    | o1 == o2 = Failed+    | n1 == o2 = Failed+    | o1 == n2 = Failed+    | n1 == n2 = Failed+    | otherwise = Succeeded (FP f (TokReplace t2 o2 n2) :>+                             FP f (TokReplace t1 o1 n1)) commuteFP _ _ = Unknown -commuteHunk :: FileName -> (FilePatchType :< FilePatchType) C(x y)-            -> Maybe ((Prim :< Prim) C(x y))-commuteHunk f (Hunk line2 old2 new2 :< Hunk line1 old1 new1)-  | seq f $ line1 + lengthnew1 < line2 =-      Just (FP f (Hunk line1 old1 new1) :<-            FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2))-  | line2 + lengthold2 < line1 =-      Just (FP f (Hunk (line1+ lengthnew2 - lengthold2) old1 new1) :<-            FP f (Hunk line2 old2 new2))-  | line1 + lengthnew1 == line2 &&-    lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 =-      Just (FP f (Hunk line1 old1 new1) :<-            FP f (Hunk (line2 - lengthnew1 + lengthold1) old2 new2))-  | line2 + lengthold2 == line1 &&-    lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 =-      Just (FP f (Hunk (line1 + lengthnew2 - lengthold2) old1 new1) :<-            FP f (Hunk line2 old2 new2))-  | otherwise = seq f Nothing-  where lengthnew1 = length new1-        lengthnew2 = length new2-        lengthold1 = length old1-        lengthold2 = length old2-commuteHunk _ _ = impossible+commuteHunkLines :: Int -> Int -> Int -> Int -> Int -> Int+                 -> Maybe (Int, Int)+commuteHunkLines line1 len_old1 len_new1 line2 len_old2 len_new2+  | line1 + len_new1 < line2  = Just (line2 - len_new1 + len_old1, line1)+  | line2 + len_old2 < line1  = Just (line2, line1 + len_new2 - len_old2)+  | len_old2 /= 0+  , len_old1 /= 0+  , len_new2 /= 0+  , len_new1 /= 0+  , line1 + len_new1 == line2 = Just (line2 - len_new1 + len_old1, line1)+  | len_old2 /= 0+  , len_old1 /= 0+  , len_new2 /= 0+  , len_new1 /= 0+  , line2 + len_old2 == line1 = Just (line2, line1 + len_new2 - len_old2)+  | otherwise                 = Nothing -tryTokReplace :: String -> String -> String-                -> [B.ByteString] -> Maybe [B.ByteString]-tryTokReplace t o n mss =-  mapM (fmap B.concat . tryTokInternal t (BC.pack o) (BC.pack n)) mss+tryTokReplaces :: String -> B.ByteString -> B.ByteString+               -> [B.ByteString] -> Maybe [B.ByteString]+tryTokReplaces t o n = mapM (tryTokReplace t o n)++instance CleanMerge Prim where+  cleanMerge = primCleanMerge
src/Darcs/Patch/Prim/V1/Core.hs view
@@ -15,130 +15,93 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}--#include "gadts.h"- module Darcs.Patch.Prim.V1.Core-       ( Prim(..),-         DirPatchType(..), FilePatchType(..),-         isIdentity,-         comparePrim,-       )-       where+    ( Prim(..)+    , DirPatchType(..)+    , FilePatchType(..)+    ) where -import Prelude hiding ( pi )+import Darcs.Prelude  import qualified Data.ByteString as B (ByteString) -import Darcs.Patch.FileName ( FileName, fn2fp, fp2fn, normPath )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Util.Path ( AnchoredPath )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Debug ( PatchDebug(..) ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) ) import Darcs.Patch.Invert ( Invert(..) ) import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Object ( ObjectIdOf ) import Darcs.Patch.Permutations () -- for Invert instance of FL-import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) )+import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimSift(..) ) -data Prim C(x y) where-    Move :: !FileName -> !FileName -> Prim C(x y)-    DP :: !FileName -> !(DirPatchType C(x y)) -> Prim C(x y)-    FP :: !FileName -> !(FilePatchType C(x y)) -> Prim C(x y)-    ChangePref :: !String -> !String -> !String -> Prim C(x y)+data Prim wX wY where+    Move :: !AnchoredPath -> !AnchoredPath -> Prim wX wY+    DP :: !AnchoredPath -> !(DirPatchType wX wY) -> Prim wX wY+    FP :: !AnchoredPath -> !(FilePatchType wX wY) -> Prim wX wY+    ChangePref :: !String -> !String -> !String -> Prim wX wY -data FilePatchType C(x y) = RmFile | AddFile-                          | Hunk !Int [B.ByteString] [B.ByteString]-                          | TokReplace !String !String !String-                          | Binary B.ByteString B.ByteString-                            deriving (Eq,Ord)+data FilePatchType wX wY+    = RmFile+    | AddFile+    | Hunk !Int [B.ByteString] [B.ByteString]+    | TokReplace !String !String !String+    | Binary B.ByteString B.ByteString+    deriving (Eq,Ord) -data DirPatchType C(x y) = RmDir | AddDir+type role FilePatchType nominal nominal++data DirPatchType wX wY = RmDir | AddDir                            deriving (Eq,Ord) -instance MyEq FilePatchType where-    unsafeCompare a b = a == unsafeCoerceP b+type role DirPatchType nominal nominal -instance MyEq DirPatchType where+instance Eq2 FilePatchType where     unsafeCompare a b = a == unsafeCoerceP b -isIdentity :: Prim C(x y) -> EqCheck C(x y)-isIdentity (FP _ (Binary old new)) | old == new = unsafeCoerceP IsEq-isIdentity (FP _ (Hunk _ old new)) | old == new = unsafeCoerceP IsEq-isIdentity (FP _ (TokReplace _ old new)) | old == new = unsafeCoerceP IsEq-isIdentity (Move old new) | old == new = unsafeCoerceP IsEq-isIdentity _ = NotEq--instance PrimClassify Prim where-   primIsAddfile (FP _ AddFile) = True-   primIsAddfile _ = False--   primIsRmfile (FP _ RmFile) = True-   primIsRmfile _ = False--   primIsAdddir (DP _ AddDir) = True-   primIsAdddir _ = False--   primIsRmdir (DP _ RmDir) = True-   primIsRmdir _ = False--   primIsMove (Move _ _) = True-   primIsMove _ = False--   primIsHunk (FP _ (Hunk _ _ _)) = True-   primIsHunk _ = False--   primIsTokReplace (FP _ (TokReplace _ _ _)) = True-   primIsTokReplace _ = False--   primIsBinary (FP _ (Binary _ _)) = True-   primIsBinary _ = False--   primIsSetpref (ChangePref _ _ _) = True-   primIsSetpref _ = False--   is_filepatch (FP f _) = Just f-   is_filepatch _ = Nothing+instance Invert FilePatchType where+    invert RmFile = AddFile+    invert AddFile = RmFile+    invert (Hunk line old new) = Hunk line new old+    invert (TokReplace t o n) = TokReplace t n o+    invert (Binary o n) = Binary n o -evalargs :: (a -> b -> c) -> a -> b -> c-evalargs f x y = (f $! x) $! y+instance Eq2 DirPatchType where+    unsafeCompare a b = a == unsafeCoerceP b -instance PrimConstruct Prim where-   addfile f = FP (fp2fn $ nFn f) AddFile-   rmfile f = FP (fp2fn $ nFn f) RmFile-   adddir d = DP (fp2fn $ nFn d) AddDir-   rmdir d = DP (fp2fn $ nFn d) RmDir-   move f f' = Move (fp2fn $ nFn f) (fp2fn $ nFn f')-   changepref p f t = ChangePref p f t-   hunk f line old new = evalargs FP (fp2fn $ nFn f) (Hunk line old new)-   tokreplace f tokchars old new =-       evalargs FP (fp2fn $ nFn f) (TokReplace tokchars old new)-   binary f old new = FP (fp2fn $! nFn f) $ Binary old new-   primFromHunk (FileHunk fn line before after) = FP fn (Hunk line before after)-   anIdentity = let fp = "./dummy" in move fp fp+instance Invert DirPatchType where+    invert RmDir = AddDir+    invert AddDir = RmDir -nFn :: FilePath -> FilePath-nFn f = "./"++(fn2fp $ normPath $ fp2fn f)+instance ObjectIdOf (ApplyState Prim) ~ AnchoredPath => PrimConstruct Prim where+    addfile f = FP f AddFile+    rmfile f = FP f RmFile+    adddir d = DP d AddDir+    rmdir d = DP d RmDir+    move old new = Move old new+    changepref p f t = ChangePref p f t+    hunk f line old new = FP f (Hunk line old new)+    tokreplace f tokchars old new = FP f (TokReplace tokchars old new)+    binary f old new = FP f $ Binary old new+    primFromHunk (FileHunk f line before after) = FP f (Hunk line before after) -instance IsHunk Prim where-   isHunk (FP fn (Hunk line before after)) = Just (FileHunk fn line before after)-   isHunk _ = Nothing+instance ObjectIdOf (ApplyState Prim) ~ AnchoredPath => IsHunk Prim where+    isHunk (FP f (Hunk line before after)) = Just (FileHunk f line before after)+    isHunk _ = Nothing  instance Invert Prim where-    invert (FP f RmFile)  = FP f AddFile-    invert (FP f AddFile)  = FP f RmFile-    invert (FP f (Hunk line old new))  = FP f $ Hunk line new old-    invert (FP f (TokReplace t o n)) = FP f $ TokReplace t n o-    invert (FP f (Binary o n)) = FP f $ Binary n o-    invert (DP d RmDir) = DP d AddDir-    invert (DP d AddDir) = DP d RmDir+    invert (FP f p)  = FP f (invert p)+    invert (DP d p) = DP d (invert p)     invert (Move f f') = Move f' f     invert (ChangePref p f t) = ChangePref p t f  instance PatchInspect Prim where     -- Recurse on everything, these are potentially spoofed patches-    listTouchedFiles (Move f1 f2) = map fn2fp [f1, f2]-    listTouchedFiles (FP f _) = [fn2fp f]-    listTouchedFiles (DP d _) = [fn2fp d]+    listTouchedFiles (Move f1 f2) = [f1, f2]+    listTouchedFiles (FP f _) = [f]+    listTouchedFiles (DP d _) = [d]     listTouchedFiles (ChangePref _ _ _) = []      hunkMatches f (FP _ (Hunk _ remove add)) = anyMatches remove || anyMatches add@@ -148,7 +111,9 @@     hunkMatches _ (ChangePref _ _ _) = False     hunkMatches _ (Move _ _) = False -instance MyEq Prim where+instance PatchDebug Prim++instance Eq2 Prim where     unsafeCompare (Move a b) (Move c d) = a == c && b == d     unsafeCompare (DP d1 p1) (DP d2 p2)         = d1 == d2 && p1 `unsafeCompare` p2@@ -158,22 +123,10 @@         = c1 == c2 && b1 == b2 && a1 == a2     unsafeCompare _ _ = False -instance Eq (Prim C(x y)) where+instance Eq (Prim wX wY) where     (==) = unsafeCompare --- | 'comparePrim' @p1 p2@ is used to provide an arbitrary ordering between---   @p1@ and @p2@.  Basically, identical patches are equal and---   @Move < DP < FP < ChangePref@.---   Everything else is compared in dictionary order of its arguments.-comparePrim :: Prim C(x y) -> Prim C(w z) -> Ordering-comparePrim (Move a b) (Move c d) = compare (a, b) (c, d)-comparePrim (Move _ _) _ = LT-comparePrim _ (Move _ _) = GT-comparePrim (DP d1 p1) (DP d2 p2) = compare (d1, p1) $ unsafeCoerceP (d2, p2)-comparePrim (DP _ _) _ = LT-comparePrim _ (DP _ _) = GT-comparePrim (FP f1 fp1) (FP f2 fp2) = compare (f1, fp1) $ unsafeCoerceP (f2, fp2)-comparePrim (FP _ _) _ = LT-comparePrim _ (FP _ _) = GT-comparePrim (ChangePref a1 b1 c1) (ChangePref a2 b2 c2)- = compare (c1, b1, a1) (c2, b2, a2)+instance PrimSift Prim where+  primIsSiftable (FP _ (Binary _ _)) = True+  primIsSiftable (FP _ (Hunk _ _ _)) = True+  primIsSiftable _ = False
src/Darcs/Patch/Prim/V1/Details.hs view
@@ -3,21 +3,21 @@     ()     where -import Prelude hiding ( pi )+import Darcs.Prelude+ import Darcs.Patch.Prim.Class ( PrimDetails(..) ) import Darcs.Patch.Prim.V1.Core     ( Prim(..), FilePatchType(..), DirPatchType(..) ) import Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) -#include "gadts.h"  instance PrimDetails Prim where   summarizePrim (FP f (Hunk _ o n)) = [SummFile SummMod f (length o) (length n) 0]   summarizePrim (FP f (Binary _ _)) = [SummFile SummMod f 0 0 0]   summarizePrim (FP f AddFile) = [SummFile SummAdd f 0 0 0]   summarizePrim (FP f RmFile) = [SummFile SummRm f 0 0 0]-  summarizePrim (FP f (TokReplace _ _ _)) = [SummFile SummMod f 0 0 1]+  summarizePrim (FP f (TokReplace{})) = [SummFile SummMod f 0 0 1]   summarizePrim (DP d AddDir) = [SummAddDir d]   summarizePrim (DP d RmDir) = [SummRmDir d]   summarizePrim (Move f1 f2) = [SummMv f1 f2]-  summarizePrim (ChangePref _ _ _) = [SummNone]+  summarizePrim (ChangePref{}) = [SummNone]
+ src/Darcs/Patch/Prim/V1/Mangle.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Patch.Prim.V1.Mangle () where++import Darcs.Prelude++import qualified Data.ByteString.Char8 as BC (pack, last)+import qualified Data.ByteString as B (null, ByteString)+import Data.Maybe ( isJust, listToMaybe )+import Data.List ( sort, intercalate, nub )+import Safe ( headErr, tailErr )++import Darcs.Patch.Apply ( ObjectIdOfPatch )+import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )+import Darcs.Patch.Inspect ( PatchInspect(listTouchedFiles) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Prim.Class+    ( PrimConstruct(primFromHunk)+    , PrimMangleUnravelled(..)+    )+import Darcs.Patch.Prim.V1.Core ( Prim )+import Darcs.Patch.Prim.V1.Apply ()+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), mapFL_FL_M )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, unseal )++-- | The state of a single file as far as we know it. 'Nothing'+-- means we don't know the content of a particular line.+newtype FileState wX = FileState { content :: [Maybe B.ByteString] }++-- | An infinite list of undefined lines.+unknownFileState :: FileState wX+unknownFileState = FileState (repeat Nothing)++-- | Note that @applyHunk p . applyHunk (invert p) /= id@: it converts+-- undefined lines ('Nothing') to defined ones ('Just' the old content of @p@).+applyHunk :: FileHunk oid wX wY -> FileState wX -> FileState wY+applyHunk (FileHunk _ line old new) = FileState . go . content+  where+    go mls =+      case splitAt (line - 1) mls of+        (before, rest) ->+          concat [before, map Just new, drop (length old) rest]++-- | Iterate 'applyHunk'.+applyHunks :: FL (FileHunk oid) wX wY -> FileState wX -> FileState wY+applyHunks NilFL = id+applyHunks (p:>:ps) = applyHunks ps . applyHunk p+++instance PrimMangleUnravelled Prim where+  mangleUnravelled pss = do+      hunks <- onlyHunks pss+      filename <- listToMaybe (filenames pss)+      return $ mapSeal ((:>: NilFL) . primFromHunk) $ mangleHunks filename hunks+    where+      -- | The names of all touched files.+      filenames = nub . concatMap (unseal listTouchedFiles)++      -- | Convert every prim in the input to a 'FileHunk', or fail.+      onlyHunks :: forall prim oid wX. (IsHunk prim, ObjectIdOfPatch prim ~ oid)+                => [Sealed (FL prim wX)]+                -> Maybe [Sealed (FL (FileHunk oid) wX)]+      onlyHunks = mapM toHunk where+        toHunk :: Sealed (FL prim wA) -> Maybe (Sealed (FL (FileHunk oid) wA))+        toHunk (Sealed ps) = fmap Sealed $ mapFL_FL_M isHunk ps++      -- | Mangle a list of hunks, returning a single hunk.+      -- Note: the input list consists of 'FL's because when commuting conflicts+      -- to the head we may accumulate dependencies. In fact, the patches in all+      -- of the given (mutually conflicting) 'FL's should coalesce to a single hunk.+      mangleHunks :: oid -> [Sealed (FL (FileHunk oid) wX)] -> Sealed (FileHunk oid wX)+      mangleHunks _ [] = error "mangleHunks called with empty list of alternatives"+      mangleHunks path ps = Sealed (FileHunk path l old new)+        where+          oldf    = foldl oldFileState unknownFileState ps+          newfs   = map (newFileState oldf) ps+          l       = getHunkline (Sealed oldf : newfs)+          nchs    = sort (map (makeChunk l) newfs)+          old     = makeChunk l (Sealed oldf)+          new     = [top] ++ old ++ [initial] ++ intercalate [middle] nchs ++ [bottom]+          top     = BC.pack ("v v v v v v v" ++ eol_c)+          initial = BC.pack ("=============" ++ eol_c)+          middle  = BC.pack ("*************" ++ eol_c)+          bottom  = BC.pack ("^ ^ ^ ^ ^ ^ ^" ++ eol_c)+          -- simple heuristic to infer the line ending convention from patch contents+          eol_c   =+            if any (\line -> not (B.null line) && BC.last line == '\r') old+              then "\r"+              else ""++      -- | Apply the patches and their inverse. This turns all lines touched+      -- by the 'FL' of patches into defined lines with their "old" values.+      oldFileState :: FileState wX -> Sealed (FL (FileHunk oid) wX) -> FileState wX+      oldFileState mls (Sealed ps) = applyHunks (ps +>+ invert ps) mls++      -- | This is @flip 'applyHunks'@ under 'Sealed'.+      newFileState :: FileState wX -> Sealed (FL (FileHunk oid) wX) -> Sealed FileState+      newFileState mls (Sealed ps) = Sealed (applyHunks ps mls)++      -- Index of the first line touched by any of the FileStates (1-based).+      getHunkline :: [Sealed FileState] -> Int+      getHunkline = go 1 . map (unseal content)+        where+          -- head and tail are safe here because all inner lists are infinite+          go n pps =+            if any (isJust . headErr) pps+              then n+              else go (n + 1) $ map tailErr pps++      -- | The chunk of defined lines starting at the given position (1-based).+      makeChunk :: Int -> Sealed FileState -> [B.ByteString]+      makeChunk n = takeWhileJust . drop (n - 1) . unseal content+        where+          -- stolen from utility-ht, thanks Henning!+          takeWhileJust = foldr (\x acc -> maybe [] (:acc) x) []
src/Darcs/Patch/Prim/V1/Read.hs view
@@ -1,45 +1,46 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.Prim.V1.Read () where +import Darcs.Prelude+ import Darcs.Patch.Prim.Class ( PrimRead(..), hunk, binary ) import Darcs.Patch.Prim.V1.Core-    ( Prim(..),-      DirPatchType(..), FilePatchType(..) )+    ( Prim(..)+    , DirPatchType(..)+    , FilePatchType(..)+    )+import Darcs.Patch.Prim.V1.Apply () -import Darcs.Patch.FileName ( fn2fp )-import Darcs.Patch.Format ( FileNameFormat(..) )-import Darcs.Patch.Read ( ReadPatch(..), readFileName )-import Darcs.Patch.ReadMonads (ParserM, takeTillChar,-                               string, int,-                               option, choice,-                               anyChar, char, myLex',-                               skipSpace, skipWhile, linesStartingWith)+import Darcs.Util.Path (  )+import Darcs.Patch.Format ( FileNameFormat )+import Darcs.Patch.Read ( readFileName )+import Darcs.Util.Parser+    ( Parser, takeTillChar, string, int+    , option, choice, anyChar, char, lexWord+    , skipSpace, skipWhile, linesStartingWith+    ) -import Darcs.Witnesses.Sealed ( seal )+import Darcs.Patch.Witnesses.Sealed ( seal ) -import ByteStringUtils ( fromHex2PS )+import Darcs.Util.ByteString ( fromHex2PS )  import Control.Monad ( liftM ) import qualified Data.ByteString       as B  ( ByteString, init, tail, concat ) import qualified Data.ByteString.Char8 as BC ( unpack, pack ) -#include "gadts.h" -instance ReadPatch Prim where- readPatch' = readPrim OldFormat- instance PrimRead Prim where-  readPrim x+  readPrim fmt      = skipSpace >> choice-       [ return' $ readHunk x-       , return' $ readAddFile x-       , return' $ readAddDir x-       , return' $ readMove x-       , return' $ readRmFile x-       , return' $ readRmDir x-       , return' $ readTok x-       , return' $ readBinary x-       , return' $ readChangePref+       [ return' $ readHunk fmt+       , return' $ readAddFile fmt+       , return' $ readAddDir fmt+       , return' $ readMove fmt+       , return' $ readRmFile fmt+       , return' $ readRmDir fmt+       , return' $ readTok fmt+       , return' $ readBinary fmt+       , return' readChangePref        ]     where     return'  = liftM seal@@ -71,32 +72,33 @@ changepref :: B.ByteString changepref = BC.pack "changepref" -readHunk :: ParserM m => FileNameFormat -> m (Prim C(x y))-readHunk x = do+readHunk :: FileNameFormat -> Parser (Prim wX wY)+readHunk fmt = do   string hunk'-  fi <- myLex'+  fi <- readFileName fmt   l <- int   have_nl <- skipNewline   if have_nl-     then do _ <- linesStartingWith ' ' -- skipping context-             old <- linesStartingWith '-'-             new <- linesStartingWith '+'-             _ <- linesStartingWith ' ' -- skipping context-             return $ hunk (fn2fp $ readFileName x fi) l old new-     else return $ hunk (fn2fp $ readFileName x fi) l [] []+    then do+      _ <- linesStartingWith ' ' -- skipping context+      old <- linesStartingWith '-'+      new <- linesStartingWith '+'+      _ <- linesStartingWith ' ' -- skipping context+      return $ hunk fi l old new+    else return $ hunk fi l [] [] -skipNewline :: ParserM m => m Bool+skipNewline :: Parser Bool skipNewline = option False (char '\n' >> return True) -readTok :: ParserM m => FileNameFormat -> m (Prim C(x y))-readTok x = do+readTok :: FileNameFormat -> Parser (Prim wX wY)+readTok fmt = do   string replace-  f <- myLex'-  regstr <- myLex'-  o <- myLex'-  n <- myLex'-  return $ FP (readFileName x f) $ TokReplace (BC.unpack (drop_brackets regstr))-                          (BC.unpack o) (BC.unpack n)+  f <- readFileName fmt+  regstr <- lexWord+  o <- lexWord+  n <- lexWord+  return $ FP f $ TokReplace (BC.unpack (drop_brackets regstr))+                             (BC.unpack o) (BC.unpack n)     where drop_brackets = B.init . B.tail  @@ -111,54 +113,58 @@ -- > newhex -- > *HEXHEXHEX -- > ...-readBinary :: ParserM m => FileNameFormat -> m (Prim C(x y))-readBinary x = do+readBinary :: FileNameFormat -> Parser (Prim wX wY)+readBinary fmt = do   string binary'-  fi <- myLex'-  _ <- myLex'+  fi <- readFileName fmt+  _ <- lexWord   skipSpace   old <- linesStartingWith '*'-  _ <- myLex'+  r_old <- either fail return $ fromHex2PS $ B.concat old+  _ <- lexWord   skipSpace   new <- linesStartingWith '*'-  return $ binary (fn2fp $ readFileName x fi)-                  (fromHex2PS $ B.concat old)-                  (fromHex2PS $ B.concat new)--readAddFile :: ParserM m => FileNameFormat -> m (Prim C(x y))-readAddFile x = do string addfile-                   f <- myLex'-                   return $ FP (readFileName x f) AddFile+  r_new <- either fail return $ fromHex2PS $ B.concat new+  return $ binary fi r_old r_new -readRmFile :: ParserM m => FileNameFormat -> m (Prim C(x y))-readRmFile x = do string rmfile-                  f <- myLex'-                  return $ FP (readFileName x f) RmFile+readAddFile :: FileNameFormat -> Parser (Prim wX wY)+readAddFile fmt = do+  string addfile+  f <- readFileName fmt+  return $ FP f AddFile -readMove :: ParserM m => FileNameFormat -> m (Prim C(x y))-readMove x = do string move-                d <- myLex'-                d' <- myLex'-                return $ Move (readFileName x d) (readFileName x d')+readRmFile :: FileNameFormat -> Parser (Prim wX wY)+readRmFile fmt = do+  string rmfile+  f <- readFileName fmt+  return $ FP f RmFile -readChangePref :: ParserM m => m (Prim C(x y))-readChangePref- = do string changepref-      p <- myLex'-      skipWhile (== ' ')-      _ <- anyChar -- skip newline-      f <- takeTillChar '\n'-      _ <- anyChar -- skip newline-      t <- takeTillChar '\n'-      return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t)+readMove :: FileNameFormat -> Parser (Prim wX wY)+readMove fmt = do+  string move+  d <- readFileName fmt+  d' <- readFileName fmt+  return $ Move d d' -readAddDir :: ParserM m => FileNameFormat -> m (Prim C(x y))-readAddDir x = do string adddir-                  f <- myLex'-                  return $ DP (readFileName x f) AddDir+readChangePref :: Parser (Prim wX wY)+readChangePref = do+  string changepref+  p <- lexWord+  skipWhile (== ' ')+  _ <- anyChar -- skip newline+  f <- takeTillChar '\n'+  _ <- anyChar -- skip newline+  t <- takeTillChar '\n'+  return $ ChangePref (BC.unpack p) (BC.unpack f) (BC.unpack t) -readRmDir :: ParserM m => FileNameFormat -> m (Prim C(x y))-readRmDir x = do string rmdir-                 f <- myLex'-                 return $ DP (readFileName x f) RmDir+readAddDir :: FileNameFormat -> Parser (Prim wX wY)+readAddDir fmt = do+  string adddir+  f <- readFileName fmt+  return $ DP f AddDir +readRmDir :: FileNameFormat -> Parser (Prim wX wY)+readRmDir fmt = do+  string rmdir+  f <- readFileName fmt+  return $ DP f RmDir
src/Darcs/Patch/Prim/V1/Show.hs view
@@ -1,150 +1,95 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE ViewPatterns, UndecidableInstances #-} -- XXX Undecidable only in GHC < 7+{-# LANGUAGE ViewPatterns, UndecidableInstances #-} module Darcs.Patch.Prim.V1.Show     ( showHunk )     where -import Prelude hiding ( pi )+import Darcs.Prelude -import ByteStringUtils ( fromPS2Hex )+import Darcs.Util.ByteString ( fromPS2Hex ) import qualified Data.ByteString as B (ByteString, length, take, drop)-import qualified Data.ByteString.Char8 as BC (head) -import Storage.Hashed.Tree( Tree )--import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..), showFileHunk )-import Darcs.Patch.FileName ( FileName )-import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), formatFileName )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )-import Darcs.Patch.Viewing ( showContextHunk )+import Darcs.Patch.Apply ( Apply(..), ObjectIdOfPatch )+import Darcs.Patch.FileHunk ( FileHunk(..), showFileHunk )+import Darcs.Patch.Format ( FileNameFormat )+import Darcs.Patch.Show ( formatFileName ) import Darcs.Patch.Permutations () -- for Invert instance of FL import Darcs.Patch.Prim.Class ( PrimShow(..) ) import Darcs.Patch.Prim.V1.Core      ( Prim(..), FilePatchType(..), DirPatchType(..) ) import Darcs.Patch.Prim.V1.Details ()-import Darcs.Witnesses.Show ( appPrec, Show1(..), Show2(..), ShowDict(..) )-import Printer ( Doc, vcat,+import Darcs.Patch.Viewing ( showContextHunk )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )++import Darcs.Util.Path ( AnchoredPath )+import Darcs.Util.Printer ( Doc, vcat,                  text, userchunk, invisibleText, invisiblePS, blueText,-                 ($$), (<+>), (<>),+                 ($$), (<+>)                )+import Darcs.Util.Tree ( Tree ) -#include "gadts.h" --- TODO this instance shouldn't really be necessary, as Prims aren't used generically-instance PatchListFormat Prim--instance ShowPatchBasic Prim where-    showPatch = showPrim OldFormat--instance (ApplyState Prim ~ Tree) => ShowPatch Prim where-    showContextPatch (isHunk -> Just fh) = showContextHunk fh-    showContextPatch p = return $ showPatch p-    summary = plainSummaryPrim-    summaryFL = plainSummaryPrims-    thing _ = "change"--instance Show (Prim C(x y)) where-    showsPrec d (Move fn1 fn2) = showParen (d > appPrec) $ showString "Move " .-                                 showsPrec (appPrec + 1) fn1 . showString " " .-                                 showsPrec (appPrec + 1) fn2-    showsPrec d (DP fn dp) = showParen (d > appPrec) $ showString "DP " .-                             showsPrec (appPrec + 1) fn . showString " " .-                             showsPrec (appPrec + 1) dp-    showsPrec d (FP fn fp) = showParen (d > appPrec) $ showString "FP " .-                             showsPrec (appPrec + 1) fn . showString " " .-                             showsPrec (appPrec + 1) fp-    showsPrec d (ChangePref p f t) = showParen (d > appPrec) $ showString "ChangePref " .-                                     showsPrec (appPrec + 1) p . showString " " .-                                     showsPrec (appPrec + 1) f . showString " " .-                                     showsPrec (appPrec + 1) t--instance Show2 Prim where-   showDict2 = ShowDictClass--instance Show1 (Prim C(x)) where-   showDict1 = ShowDictClass--instance Show (FilePatchType C(x y)) where-    showsPrec _ RmFile = showString "RmFile"-    showsPrec _ AddFile = showString "AddFile"-    showsPrec d (Hunk line old new) | all ((==1) . B.length) old && all ((==1) . B.length) new-        = showParen (d > appPrec) $ showString "Hunk " .-                                      showsPrec (appPrec + 1) line . showString " " .-                                      showsPrecC old . showString " " .-                                      showsPrecC new-       where showsPrecC [] = showString "[]"-             showsPrecC ss = showParen True $ showString "packStringLetters " . showsPrec (appPrec + 1) (map BC.head ss)-    showsPrec d (Hunk line old new) = showParen (d > appPrec) $ showString "Hunk " .-                                      showsPrec (appPrec + 1) line . showString " " .-                                      showsPrec (appPrec + 1) old . showString " " .-                                      showsPrec (appPrec + 1) new-    showsPrec d (TokReplace t old new) = showParen (d > appPrec) $ showString "TokReplace " .-                                         showsPrec (appPrec + 1) t . showString " " .-                                         showsPrec (appPrec + 1) old . showString " " .-                                         showsPrec (appPrec + 1) new-    -- this case may not work usefully-    showsPrec d (Binary old new) = showParen (d > appPrec) $ showString "Binary " .-                                   showsPrec (appPrec + 1) old . showString " " .-                                   showsPrec (appPrec + 1) new--instance Show (DirPatchType C(x y)) where-    showsPrec _ RmDir = showString "RmDir"-    showsPrec _ AddDir = showString "AddDir"--{--instance Show (Prim C(x y))  where-    show p = renderString (showPrim p) ++ "\n"--}+instance Show2 Prim+instance Show1 (Prim wX)+deriving instance Show (Prim wX wY)+deriving instance Show (FilePatchType wX wY)+deriving instance Show (DirPatchType wX wY) -instance PrimShow Prim where-  showPrim x (FP f AddFile) = showAddFile x f-  showPrim x (FP f RmFile)  = showRmFile x f-  showPrim x (FP f (Hunk line old new))  = showHunk x f line old new-  showPrim x (FP f (TokReplace t old new))  = showTok x f t old new-  showPrim x (FP f (Binary old new))  = showBinary x f old new-  showPrim x (DP d AddDir) = showAddDir x d-  showPrim x (DP d RmDir)  = showRmDir x d-  showPrim x (Move f f') = showMove x f f'+instance (Apply Prim, ApplyState Prim ~ Tree, ObjectIdOfPatch Prim ~ AnchoredPath) =>+         PrimShow Prim where+  showPrim fmt (FP f AddFile) = showAddFile fmt f+  showPrim fmt (FP f RmFile)  = showRmFile fmt f+  showPrim fmt (FP f (Hunk line old new))  = showHunk fmt f line old new+  showPrim fmt (FP f (TokReplace t old new))  = showTok fmt f t old new+  showPrim fmt (FP f (Binary old new))  = showBinary fmt f old new+  showPrim fmt (DP d AddDir) = showAddDir fmt d+  showPrim fmt (DP d RmDir)  = showRmDir fmt d+  showPrim fmt (Move f f') = showMove fmt f f'   showPrim _ (ChangePref p f t) = showChangePref p f t+  showPrimWithContextAndApply fmt p@(FP f (Hunk line old new)) = do+    r <- showContextHunk fmt (FileHunk f line old new)+    apply p+    return r+  showPrimWithContextAndApply fmt p = do+    apply p+    return $ showPrim fmt p -showAddFile :: FileNameFormat -> FileName -> Doc-showAddFile x f = blueText "addfile" <+> formatFileName x f+showAddFile :: FileNameFormat -> AnchoredPath -> Doc+showAddFile fmt f = blueText "addfile" <+> formatFileName fmt f -showRmFile :: FileNameFormat -> FileName -> Doc-showRmFile x f = blueText "rmfile" <+> formatFileName x f+showRmFile :: FileNameFormat -> AnchoredPath -> Doc+showRmFile fmt f = blueText "rmfile" <+> formatFileName fmt f -showMove :: FileNameFormat -> FileName -> FileName -> Doc-showMove x d d' = blueText "move" <+> formatFileName x d <+> formatFileName x d'+showMove :: FileNameFormat -> AnchoredPath -> AnchoredPath -> Doc+showMove fmt d d' = blueText "move" <+> formatFileName fmt d <+> formatFileName fmt d'  showChangePref :: String -> String -> String -> Doc showChangePref p f t = blueText "changepref" <+> text p                     $$ userchunk f                     $$ userchunk t -showAddDir :: FileNameFormat -> FileName -> Doc-showAddDir x d = blueText "adddir" <+> formatFileName x d+showAddDir :: FileNameFormat -> AnchoredPath -> Doc+showAddDir fmt d = blueText "adddir" <+> formatFileName fmt d -showRmDir :: FileNameFormat -> FileName -> Doc-showRmDir x d = blueText "rmdir" <+> formatFileName x d+showRmDir :: FileNameFormat -> AnchoredPath -> Doc+showRmDir fmt d = blueText "rmdir" <+> formatFileName fmt d -showHunk :: FileNameFormat -> FileName -> Int -> [B.ByteString] -> [B.ByteString] -> Doc-showHunk x f line old new = showFileHunk x (FileHunk f line old new)+showHunk :: FileNameFormat -> AnchoredPath -> Int -> [B.ByteString] -> [B.ByteString] -> Doc+showHunk fmt f line old new = showFileHunk fmt (FileHunk f line old new) -showTok :: FileNameFormat -> FileName -> String -> String -> String -> Doc-showTok x f t o n = blueText "replace" <+> formatFileName x f+showTok :: FileNameFormat -> AnchoredPath -> String -> String -> String -> Doc+showTok fmt f t o n = blueText "replace" <+> formatFileName fmt f                                      <+> text "[" <> userchunk t <> text "]"                                      <+> userchunk o                                      <+> userchunk n -showBinary :: FileNameFormat -> FileName -> B.ByteString -> B.ByteString -> Doc-showBinary x f o n =-    blueText "binary" <+> formatFileName x f+showBinary :: FileNameFormat -> AnchoredPath -> B.ByteString -> B.ByteString -> Doc+showBinary fmt f o n =+    blueText "binary" <+> formatFileName fmt f  $$ invisibleText "oldhex"- $$ (vcat $ map makeprintable $ breakEvery 78 $ fromPS2Hex o)+ $$ vcat (map makeprintable $ breakEvery 78 $ fromPS2Hex o)  $$ invisibleText "newhex"- $$ (vcat $ map makeprintable $ breakEvery 78 $ fromPS2Hex n)+ $$ vcat (map makeprintable $ breakEvery 78 $ fromPS2Hex n)      where makeprintable ps = invisibleText "*" <> invisiblePS ps  breakEvery :: Int -> B.ByteString -> [B.ByteString]
− src/Darcs/Patch/Prim/V3.hs 
@@ -1,22 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Prim.V3 ( Prim ) where--import Darcs.Patch.Prim.V3.Apply ()-import Darcs.Patch.Prim.V3.Coalesce ()-import Darcs.Patch.Prim.V3.Commute ()-import Darcs.Patch.Prim.V3.Core ( Prim )-import Darcs.Patch.Prim.V3.Details ()-import Darcs.Patch.Prim.V3.Read ()-import Darcs.Patch.Prim.V3.Show ()--import Darcs.Patch.Prim.Class ( PrimPatch, PrimPatchBase(..), FromPrim(..) )-import Darcs.Patch.Patchy ( Patchy )--instance PrimPatch Prim-instance Patchy Prim--instance PrimPatchBase Prim where-  type PrimOf Prim = Prim--instance FromPrim Prim where-  fromPrim = id
− src/Darcs/Patch/Prim/V3/Apply.hs 
@@ -1,62 +0,0 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Prim.V3.Apply ( ObjectMap(..) ) where--import Darcs.Patch.Apply ( Apply(..) )-import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTrans(..), ToTree(..) )-import Darcs.Patch.Repair ( RepairToFL(..) )--import Darcs.Patch.Prim.Class ( PrimApply(..) )-import Darcs.Patch.Prim.V3.Core ( Prim(..), hunkEdit )-import Darcs.Patch.Prim.V3.ObjectMap--import Control.Monad.State( StateT, runStateT, gets, lift, put )-import qualified Data.Map as M---- import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )--import Darcs.Witnesses.Ordered ( FL(..) )-import Storage.Hashed.Hash( Hash(..) )--#include "gadts.h"-#include "impossible.h"--instance Apply Prim where-    type ApplyState Prim = ObjectMap-    apply (Manifest id (dirid, name)) = editDirectory dirid (M.insert name id)-    apply (Demanifest _ (dirid, name)) = editDirectory dirid (M.delete name)-    apply (TextHunk id hunk) = editFile id (hunkEdit hunk)-    apply (BinaryHunk id hunk) = editFile id (hunkEdit hunk)--instance RepairToFL Prim where-    applyAndTryToFixFL p = apply p >> return Nothing--instance PrimApply Prim where-    applyPrimFL NilFL = return ()-    applyPrimFL (p:>:ps) = apply p >> applyPrimFL ps--instance ToTree ObjectMap -- TODO--editObject :: (Monad m) => UUID -> (Maybe (Object m) -> Object m) -> (StateT (ObjectMap m) m) ()-editObject id edit = do load <- gets getObject-                        store <- gets putObject-                        obj <- lift $ load id-                        new <- lift $ store id $ edit obj-                        put new-                        return ()--instance (Functor m, Monad m) => ApplyMonad (StateT (ObjectMap m) m) ObjectMap where-    type ApplyMonadBase (StateT (ObjectMap m) m) = m-    editFile id edit = editObject id edit'-      where edit' (Just (Blob x _)) = Blob (edit `fmap` x) NoHash-            edit' (Just (Directory x)) = Directory x -- error?-            edit' Nothing = Blob (return $ edit "") NoHash-    editDirectory id edit = editObject id edit'-      where edit' (Just (Directory x)) = Directory $ edit x-            edit' (Just (Blob x y)) = Blob x y -- error?-            edit' Nothing = Directory $ edit M.empty--instance (Functor m, Monad m) => ApplyMonadTrans m ObjectMap where-  type ApplyMonadOver m ObjectMap = StateT (ObjectMap m) m-  runApplyMonad = runStateT-
− src/Darcs/Patch/Prim/V3/Coalesce.hs 
@@ -1,18 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Prim.V3.Coalesce () where--import Darcs.Patch.Prim.Class ( PrimCanonize(..) )-import Darcs.Witnesses.Ordered( FL(..) )-import Darcs.Patch.Prim.V3.Core( Prim )--#include "gadts.h"-#include "impossible.h"---- TODO-instance PrimCanonize Prim where-   tryToShrink = error "tryToShrink"-   tryShrinkingInverse _ = error "tryShrinkingInverse"-   sortCoalesceFL = id-   canonize = (:>: NilFL)-   canonizeFL = id-   join = const Nothing
− src/Darcs/Patch/Prim/V3/Commute.hs 
@@ -1,70 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Prim.V3.Commute-    ( CommuteMonad(..) )-    where--import Data.List ( intersect )--import qualified Data.ByteString as BS (length)--import Darcs.Witnesses.Ordered ( (:>)(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Patch.Prim.V3.Core ( Prim(..), Hunk(..), touches )-import Darcs.Patch.Commute ( Commute(..) )-import Darcs.Patch.Permutations () -- for Invert instance of FL--#include "impossible.h"-#include "gadts.h"--class Monad m => CommuteMonad m where-  commuteFail :: m a-  -- TODO we eventually have to get rid of runCommute with this signature,-  -- since m might involve IO at some point, which we can't "run";-  -- alternatively, for IO it could always yield Nothing, having a separate-  -- IO-specific function to "run" commutes in IO--instance CommuteMonad Maybe where-  commuteFail = Nothing--instance Commute Prim where-    commute = commute'--class Commute' p where-  commute' :: (CommuteMonad m) => (p :> p) wX wY -> m ((p :> p) wX wY)--typematch :: Prim wX wY -> Prim wY wZ -> Bool-typematch _ _ = True -- TODO--instance Commute' Prim where-  commute' (a :> b) | null (touches a `intersect` touches b) = return (unsafeCoerceP b :> unsafeCoerceP a)-                    | not (a `typematch` b) = commuteFail-                    | otherwise = commuteOverlapping (a :> b)---- Commute patches that have actual overlap in terms of touched objects, and their types allow -commuteOverlapping :: (CommuteMonad m) => (Prim :> Prim) wX wY -> m ((Prim :> Prim) wX wY)-commuteOverlapping ((BinaryHunk a x) :> (BinaryHunk _ y)) =-  do (y' :> x') <- commuteHunk (x :> y)-     return $ unsafeCoerceP (BinaryHunk a y' :> BinaryHunk a x')-commuteOverlapping ((TextHunk a x) :> (TextHunk _ y)) =-  do (y' :> x') <- commuteHunk (x :> y)-     return $ unsafeCoerceP (TextHunk a y' :> TextHunk a x')-commuteOverlapping _ = commuteFail--commuteHunk :: (CommuteMonad m) => (Hunk :> Hunk) C(x y) -> m ((Hunk :> Hunk) C(y x))-commuteHunk ((Hunk off1 old1 new1) :> (Hunk off2 old2 new2))-  | off1 + lengthnew1 < off2 =-    return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1-  | off2 + lengthold2 < off1 =-    return $ (Hunk off2 old2 new2) :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1-  | off1 + lengthnew1 == off2 &&-    lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 =-      return $ Hunk (off2 - lengthnew1 + lengthold1) old2 new2 :> Hunk off1 old1 new1-  | off2 + lengthold2 == off1 &&-    lengthold2 /= 0 && lengthold1 /= 0 && lengthnew2 /= 0 && lengthnew1 /= 0 =-      return $ Hunk off2 old2 new2 :> Hunk (off1 + lengthnew2 - lengthold2) old1 new1-  | otherwise = commuteFail-  where lengthnew1 = BS.length new1-        lengthnew2 = BS.length new2-        lengthold1 = BS.length old1-        lengthold2 = BS.length old2-commuteHunk _ = impossible
− src/Darcs/Patch/Prim/V3/Core.hs 
@@ -1,133 +0,0 @@-{-# LANGUAGE CPP, OverloadedStrings #-}---- Copyright (C) 2011 Petr Rockai------ 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--- SOFTWARE.--#include "gadts.h"--module Darcs.Patch.Prim.V3.Core-       ( Prim(..), Hunk(..), UUID(..), Location, Object(..), touches, hunkEdit )-       where--import qualified Data.ByteString as BS--import Darcs.Witnesses.Eq ( MyEq(..) )-import Darcs.Patch.FileHunk( IsHunk(..) )-import Darcs.Patch.Invert ( Invert(..) )-import Darcs.Patch.Inspect ( PatchInspect(..) )-import Darcs.Patch.Prim.Class ( PrimConstruct(..), PrimClassify(..) )-import Darcs.Patch.Prim.V3.ObjectMap---- TODO: elaborate--data Hunk C(x y) where-  Hunk :: !Int -> BS.ByteString -> BS.ByteString -> Hunk C(x y)--invertHunk :: Hunk C(x y) -> Hunk C(y x)-invertHunk (Hunk off old new) = Hunk off new old--hunkEdit :: Hunk C(x y) -> BS.ByteString -> BS.ByteString-hunkEdit (Hunk off old new) bs = case splice bs (off) (off + BS.length old) of-  x | x == old -> BS.concat [ BS.take off bs, new, BS.drop (off + BS.length old) bs ]-    | otherwise -> error $ "error applying hunk: " ++ show off ++ " " ++ show old ++ " "-                        ++ show new ++ " to " ++ show bs-  where splice bs' x y = BS.drop x $ BS.take y bs'--instance MyEq Hunk where-  unsafeCompare (Hunk i x y) (Hunk i' x' y') = i == i' && x == x' && y == y'--data Prim C(x y) where-    BinaryHunk :: !UUID -> Hunk C(x y) -> Prim C(x y)-    TextHunk :: !UUID -> Hunk C(x y) -> Prim C(x y)--    -- TODO: String is not the right type here. However, what it represents is-    -- a single file *name* (not a path). No slashes allowed, no "." and ".."-    -- allowed either.-    Manifest :: !UUID -> Location -> Prim C(x y)-    Demanifest :: !UUID -> Location -> Prim C(x y)-    Move :: !UUID -> Location -> Location -> Prim C(x y)-    Identity :: Prim C(x x)--touches :: Prim C(x y) -> [UUID]-touches (BinaryHunk x _) = [x]-touches (TextHunk x _) = [x]-touches (Manifest _ (x, _)) = [x]-touches (Demanifest _ (x, _)) = [x]-touches (Move _ (x, _) (y, _)) = [x, y]-touches Identity = []---- TODO: PrimClassify doesn't make sense for V3 prims-instance PrimClassify Prim where-   primIsAddfile _ = False-   primIsRmfile _ = False-   primIsAdddir _ = False-   primIsRmdir _ = False-   primIsHunk _ = False-   primIsMove _ = False-   primIsBinary _ = False-   primIsTokReplace _ = False-   primIsSetpref _ = False-   is_filepatch _ = Nothing---- TODO: PrimConstruct makes no sense for V3 prims-instance PrimConstruct Prim where-   addfile _ = error "PrimConstruct addfile"-   rmfile _ = error "PrimConstruct rmfile"-   adddir _ = error "PrimConstruct adddir"-   rmdir _ = error "PrimConstruct rmdir"-   move _ _ = error "PrimConstruct move"-   changepref _ _ _ = error "PrimConstruct changepref"-   hunk _ _ _ _ = error "PrimConstruct hunk"-   tokreplace _ _ _ _ = error "PrimConstruct tokreplace"-   binary _ _ _ = error "PrimConstruct binary"-   primFromHunk _ = error "PrimConstruct primFromHunk"-   anIdentity = Identity--instance IsHunk Prim where-   isHunk _ = Nothing--instance Invert Prim where-   invert (BinaryHunk x h) = BinaryHunk x $ invertHunk h-   invert (TextHunk x h) = TextHunk x $ invertHunk h-   invert (Manifest x y) = Demanifest x y-   invert (Demanifest x y) = Manifest x y-   invert (Move x y z) = Move x z y-   invert Identity = Identity--instance PatchInspect Prim where-    -- We don't need this for V3. Slashes are not allowed in Manifest and-    -- Demanifest patches and nothing else uses working-copy paths.-    listTouchedFiles _ = []--    -- TODO (used for --match 'hunk ...', presumably)-    hunkMatches _ _ = False--instance MyEq Prim where-    unsafeCompare (BinaryHunk a b) (BinaryHunk c d) = a == c && b `unsafeCompare` d-    unsafeCompare (TextHunk a b) (TextHunk c d) = a == c && b `unsafeCompare` d-    unsafeCompare (Manifest a b) (Manifest c d) = a == c && b == d-    unsafeCompare (Demanifest a b) (Demanifest c d) = a == c && b == d-    unsafeCompare Identity Identity = True-    unsafeCompare _ _ = False--instance Eq (Prim C(x y)) where-    (==) = unsafeCompare
− src/Darcs/Patch/Prim/V3/Details.hs 
@@ -1,13 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Prim.V3.Details-    ()-    where--import Darcs.Patch.Prim.Class ( PrimDetails(..) )-import Darcs.Patch.Prim.V3.Core ( Prim(..) )--#include "gadts.h"---- TODO-instance PrimDetails Prim where-  summarizePrim _ = []
− src/Darcs/Patch/Prim/V3/ObjectMap.hs 
@@ -1,40 +0,0 @@--- Copyright (C) 2011 Petr Rockai------ 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--- SOFTWARE.--module Darcs.Patch.Prim.V3.ObjectMap( UUID(..), Location, Object(..),-                                      ObjectMap(..), DirContent ) where--import Storage.Hashed.Hash( Hash )-import qualified Data.ByteString as BS (ByteString)-import qualified Data.Map as M---newtype UUID = UUID BS.ByteString deriving (Eq, Ord, Show)-type Location = (UUID, BS.ByteString)-type DirContent = M.Map BS.ByteString UUID-data Object (m :: * -> *) = Directory DirContent-                          | Blob (m BS.ByteString) !Hash--data ObjectMap (m :: * -> *) = ObjectMap { getObject :: UUID -> m (Maybe (Object m))-                                         , putObject :: UUID -> Object m -> m (ObjectMap m)-                                         , listObjects :: m [UUID]-                                         }
− src/Darcs/Patch/Prim/V3/Read.hs 
@@ -1,52 +0,0 @@-{-# LANGUAGE ViewPatterns, OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.Prim.V3.Read () where-import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.ReadMonads-import Darcs.Patch.Prim.Class( PrimRead(..) )-import Darcs.Patch.Prim.V3.Core( Prim(..), Hunk(..) )-import Darcs.Patch.Prim.V3.ObjectMap-import Darcs.Witnesses.Sealed( seal )--import Control.Applicative ( (<$>) )-import Control.Monad ( liftM, liftM2 )-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Data.Char ( chr )--instance PrimRead Prim where-  readPrim _ = do skipSpace-                  choice $ map (liftM seal) [-                    identity,-                    hunk "hunk" TextHunk,-                    hunk "binhunk" BinaryHunk,-                    manifest "manifest" Manifest,-                    manifest "demanifest" Demanifest ]--    where manifest kind ctor = liftM2 ctor (patch kind) location-          identity = lexString "identity" >> return Identity-          patch x = string x >> uuid-          uuid = UUID <$> myLex'-          filename = encoded-          encoded = decodeWhite <$> myLex'-          hunktext = skipSpace >> choice [ string "." >> encoded, string "!" >> return B.empty ]-          location = liftM2 (,) uuid filename-          hunk kind ctor = do uid <- patch kind-                              offset <- int-                              old <- hunktext-                              new <- hunktext-                              return $ ctor uid (Hunk offset old new)--instance ReadPatch Prim where- readPatch' = readPrim undefined---- XXX a bytestring version of decodeWhite from Darcs.FileName-decodeWhite :: B.ByteString -> B.ByteString-decodeWhite (BC.uncons -> Just ('\\', cs)) =-    case BC.break (=='\\') cs of-    (theord, BC.uncons -> Just ('\\', rest)) ->-        chr (read $ BC.unpack theord) `BC.cons` decodeWhite rest-    _ -> error "malformed filename"-decodeWhite (BC.uncons -> Just (c, cs)) = c `BC.cons` decodeWhite cs-decodeWhite (BC.uncons -> Nothing) = BC.empty-
− src/Darcs/Patch/Prim/V3/Show.hs 
@@ -1,76 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE ViewPatterns, OverloadedStrings #-}-module Darcs.Patch.Prim.V3.Show-    ( showHunk )-    where--import Prelude hiding ( pi )--import Data.Char ( isSpace, ord )-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC--import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) )-import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) )-import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )-import Darcs.Patch.Prim.Class ( PrimShow(..) )-import Darcs.Patch.Prim.V3.Core ( Prim(..), Hunk(..), UUID(..) )-import Darcs.Patch.Prim.V3.Details ()-import Darcs.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) )-import Printer ( renderString, text, packedString, blueText, (<+>), (<>), Doc )--#include "gadts.h"---- TODO this instance shouldn't really be necessary, as Prims aren't used generically-instance PatchListFormat Prim--instance ShowPatchBasic Prim where-    showPatch = showPrim OldFormat--instance ShowPatch Prim where-    showContextPatch p = return $ showPatch p-    summary = plainSummaryPrim-    summaryFL = plainSummaryPrims-    thing _ = "change"--instance Show (Prim C(x y)) where-    show = renderString . showPrim undefined--instance Show2 Prim where-   showDict2 = ShowDictClass--instance Show1 (Prim C(x)) where-   showDict1 = ShowDictClass--instance PrimShow Prim where-  showPrim _ (TextHunk u h) = showHunk "hunk" u h-  showPrim _ (BinaryHunk u h) = showHunk "binhunk" u h-  showPrim _ (Manifest f (d,p)) = showManifest "manifest" d f p-  showPrim _ (Demanifest f (d,p)) = showManifest "demanifest" d f p-  showPrim _ Identity = blueText "identity"--showManifest :: String -> UUID -> UUID -> BC.ByteString -> Doc-showManifest txt dir file path = blueText txt <+>-                                 formatUUID file <+>-                                 formatUUID dir <+>-                                 packedString (encodeWhite path)--showHunk :: String -> UUID -> Hunk C(x y) -> Doc-showHunk txt uid (Hunk off old new) = blueText txt <+>-                                      formatUUID uid <+>-                                      text (show off) <+>-                                      hunktext old <+>-                                      hunktext new-    where hunktext bit | B.null bit = text "!"-                       | otherwise = text "." <> packedString (encodeWhite bit)--formatUUID :: UUID -> Doc-formatUUID (UUID x) = packedString x---- XXX a bytestring version of encodeWhite from Darcs.FileName-encodeWhite :: B.ByteString -> B.ByteString-encodeWhite = BC.concatMap encode-  where encode c-          | isSpace c || c == '\\' = B.concat [ "\\", BC.pack $ show $ ord c, "\\" ]-          | otherwise = BC.singleton c-
+ src/Darcs/Patch/Prim/WithName.hs view
@@ -0,0 +1,136 @@+-- | Generic wrapper for prim patches to give them an identity.+module Darcs.Patch.Prim.WithName+  ( PrimWithName(..)+  ) where++import Darcs.Prelude++import Darcs.Patch.Annotate ( Annotate(..) )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.Ident+    ( Ident(..)+    , PatchId+    , SignedId(..)+    , StorableId(..)+    )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Prim.Class ( PrimApply(..), PrimDetails(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Merge ( CleanMerge(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Repair ( RepairToFL(..) )+import Darcs.Patch.Show+    ( ShowPatchBasic(..)+    , ShowPatch(..)+    , ShowContextPatch(..)+    )+import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered ( mapFL_FL, (:>)(..), (:\/:)(..), (:/\:)(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 )++import Darcs.Util.Printer++-- |A 'PrimWithName' is a general way of associating an identity+-- with an underlying (presumably unnamed) primitive type. This is+-- required, for example, for V3 patches.+-- Normally the members of the 'name' type will be generated in+-- some way when a patch is initially created, to guarantee global+-- unqiueness across all repositories.+data PrimWithName name p wX wY =+  PrimWithName { wnName :: !name, wnPatch :: !(p wX wY) }++type instance PatchId (PrimWithName name p) = name++instance SignedId name => Ident (PrimWithName name p) where+  ident = wnName++instance (Eq name, Eq2 p) => Eq2 (PrimWithName name p) where+  PrimWithName i p =\/= PrimWithName j q+    | i == j, IsEq <- p =\/= q = IsEq+    | otherwise = NotEq++instance (Invert p, SignedId name) => Invert (PrimWithName name p) where+  invert (PrimWithName i p) = PrimWithName (invertId i) (invert p)++instance PatchInspect p => PatchInspect (PrimWithName name p) where+  listTouchedFiles = listTouchedFiles . wnPatch+  hunkMatches m = hunkMatches m . wnPatch++instance (Show2 p, Show name) => Show (PrimWithName name p wX wY) where+  showsPrec d (PrimWithName i p) =+    showParen (d > appPrec)+      $ showString "PrimWithName "+      . showsPrec (appPrec + 1) i+      . showString " "+      . showsPrec2 (appPrec + 1) p++instance (Show2 p, Show name) => Show1 (PrimWithName name p wX)++instance (Show2 p, Show name) => Show2 (PrimWithName name p)++instance Apply p => Apply (PrimWithName name p) where+  type ApplyState (PrimWithName name p) = ApplyState p+  apply = apply . wnPatch+  unapply = unapply . wnPatch++instance PatchListFormat (PrimWithName name p)++instance Apply p => RepairToFL (PrimWithName name p) where+  applyAndTryToFixFL p = apply p >> return Nothing++instance Annotate p => Annotate (PrimWithName name p) where+  annotate = annotate . wnPatch++instance IsHunk p => IsHunk (PrimWithName name p) where+  isHunk = isHunk . wnPatch++instance PrimApply p => PrimApply (PrimWithName name p) where+  applyPrimFL = applyPrimFL . mapFL_FL wnPatch++instance PrimDetails p => PrimDetails (PrimWithName name p) where+  summarizePrim = summarizePrim . wnPatch++-- this is the most important definition:+-- it ensures that a patch conflicts with itself+instance (SignedId name, Commute p) => Commute (PrimWithName name p) where+  commute (PrimWithName i1 p1 :> PrimWithName i2 p2)+    -- We should never get into a situation where we try+    -- to commute identical patches+    | i1 == i2 = error "internal error: trying to commute identical patches"+    -- whereas this case is the equivalent of merging a patch+    -- with itself, so it is correct to just report that they don't commute+    | i1 == invertId i2 = Nothing+    | otherwise = do+        p2' :> p1' <- commute (p1 :> p2)+        return (PrimWithName i2 p2' :> PrimWithName i1 p1')++instance (SignedId name, CleanMerge p) => CleanMerge (PrimWithName name p) where+  cleanMerge (PrimWithName i1 p1 :\/: PrimWithName i2 p2)+    | i1 == i2 = error "cannot cleanMerge identical patches"+    | otherwise = do+        p2' :/\: p1' <- cleanMerge (p1 :\/: p2)+        return $ PrimWithName i2 p2' :/\: PrimWithName i1 p1'++instance (StorableId name, ReadPatch p) => ReadPatch (PrimWithName name p) where+  readPatch' = do+      name <- readId+      Sealed p <- readPatch'+      return (Sealed (PrimWithName name p))++instance (StorableId name, ShowPatchBasic p) => ShowPatchBasic (PrimWithName name p) where+  showPatch use (PrimWithName name p) = showId use name $$ showPatch use p++instance (StorableId name, PrimDetails p, ShowPatchBasic p) => ShowPatch (PrimWithName name p) where+  summary = plainSummaryPrim . wnPatch+  summaryFL = plainSummaryPrims False+  thing _ = "change"++instance (StorableId name, ShowContextPatch p) => ShowContextPatch (PrimWithName name p) where+  showPatchWithContextAndApply use (PrimWithName name p) = do+    r <- showPatchWithContextAndApply use p+    return $ showId use name $$ r
+ src/Darcs/Patch/Progress.hs view
@@ -0,0 +1,74 @@+module Darcs.Patch.Progress+    ( progressRL+    , progressFL+    , progressRLShowTags+    ) where++import Darcs.Prelude++import System.IO.Unsafe ( unsafePerformIO )++import Darcs.Patch.Info ( justName, isTag )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), lengthRL, lengthFL )++import Darcs.Util.Progress ( minlist, beginTedious, endTedious, progress,+                  progressKeepLatest, tediousSize, finishedOne )++startProgress :: a -> String -> Int -> a+startProgress x k len = unsafePerformIO $ do beginTedious k+                                             tediousSize k len+                                             return x++-- | Evaluate an 'FL' list and report progress.+progressFL :: String -> FL a wX wY -> FL a wX wY+progressFL _ NilFL = NilFL+progressFL k xxs@(x :>: xs) = if xxsLen < minlist+                                  then xxs+                                  else startProgress x k xxsLen :>: pl xs+  where+    xxsLen = lengthFL xxs++    pl :: FL a wX wY -> FL a wX wY+    pl NilFL = NilFL+    pl (y :>: NilFL) = unsafePerformIO $ do endTedious k+                                            return (y :>: NilFL)+    pl (y :>: ys) = progress k y :>: pl ys++-- | Evaluate an 'RL' list and report progress.+progressRL :: String -> RL a wX wY -> RL a wX wY+progressRL _ NilRL = NilRL+progressRL k xxs@(xs :<: x) =+    if xxsLen < minlist+        then xxs+        else pl xs :<: startProgress x k xxsLen+  where+    xxsLen = lengthRL xxs+    pl :: RL a wX wY -> RL a wX wY+    pl NilRL = NilRL+    pl (NilRL:<:y) = unsafePerformIO $ do endTedious k+                                          return (NilRL:<:y)+    pl (ys:<:y) = pl ys :<: progress k y++-- | Evaluate an 'RL' list and report progress. In addition to printing+-- the number of patches we got, show the name of the last tag we got.+progressRLShowTags :: String -> RL (PatchInfoAnd p) wX wY+                   -> RL (PatchInfoAnd p) wX wY+progressRLShowTags _ NilRL = NilRL+progressRLShowTags k xxs@(xs :<: x) =+    if xxsLen < minlist+        then xxs+        else pl xs :<: startProgress x k xxsLen+  where+    xxsLen = lengthRL xxs++    pl :: RL (PatchInfoAnd p) wX wY -> RL (PatchInfoAnd p) wX wY+    pl NilRL = NilRL+    pl (NilRL :<: y) = unsafePerformIO $ do endTedious k+                                            return (NilRL :<: y)+    pl (ys :<: y) =+        if isTag iy+            then pl ys :<: finishedOne k ("back to "++ justName iy) y+            else pl ys :<: progressKeepLatest k y+      where+        iy = info y
src/Darcs/Patch/Read.hs view
@@ -15,51 +15,54 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}--module Darcs.Patch.Read ( ReadPatch(..),-                          readPatch, readPatchPartial,-                          bracketedFL, peekfor,-                          readFileName )-             where+module Darcs.Patch.Read+    ( ReadPatch(..)+    , readPatch+    , readPatchPartial+    , bracketedFL+    , peekfor+    , readFileName+    ) where -import Prelude hiding ( pi )+import Darcs.Prelude -import ByteStringUtils ( dropSpace )-import qualified Data.ByteString       as B  (ByteString, null)+import Control.Applicative ( (<|>) )+import Control.Monad ( mzero, (<=<) )+import qualified Data.ByteString as B ( ByteString )+import qualified Data.ByteString.Char8 as BC ( ByteString, pack, stripPrefix )+import GHC.Stack ( HasCallStack )  import Darcs.Patch.Bracketed ( Bracketed(..), unBracketedFL )-import Darcs.Patch.FileName ( FileName, fp2fn, ps2fn, decodeWhite )-import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) )-import Darcs.Patch.ReadMonads (ParserM,-                               parseStrictly,-                               choice, lexChar, lexString,-                               checkConsumes )--import Darcs.Witnesses.Ordered ( FL(..), RL, reverseFL )-import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal )--import Control.Applicative ( (<$>), (<|>) )-import Control.Monad ( mzero )-import qualified Data.ByteString.Char8 as BC ( ByteString, unpack )+import Darcs.Patch.Format+    ( FileNameFormat(..)+    , ListFormat(..)+    , PatchListFormat(..)+    )+import Darcs.Util.Parser+    ( Parser+    , checkConsumes+    , choice+    , lexChar+    , lexString+    , lexWord+    , parse+    , parseAll+    )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL, reverseFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal ) -#include "gadts.h"+import Darcs.Util.ByteString ( decodeLocale, unpackPSFromUTF8 )+import Darcs.Util.Path ( AnchoredPath, decodeWhite, floatPath ) +-- | This class is used to decode patches from their binary representation. class ReadPatch p where-    readPatch'-        :: ParserM m => m (Sealed (p C(x )))+    readPatch' :: Parser (Sealed (p wX)) -readPatchPartial :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )), B.ByteString)-readPatchPartial ps-    = case parseStrictly readPatch' ps of-         Just (p, ps') -> Just (p, ps')-         _ -> Nothing+readPatchPartial :: ReadPatch p => B.ByteString -> Either String (Sealed (p wX), B.ByteString)+readPatchPartial = parse readPatch' -readPatch :: ReadPatch p => B.ByteString -> Maybe (Sealed (p C(x )))-readPatch ps-    = case readPatchPartial ps of-         Just (p, ps') | B.null (dropSpace ps') -> Just p-         _ -> Nothing+readPatch :: ReadPatch p => B.ByteString -> Either String (Sealed (p wX))+readPatch = parseAll readPatch'  instance ReadPatch p => ReadPatch (Bracketed p) where     readPatch' = mapSeal Braced <$> bracketedFL readPatch' '{' '}'@@ -78,7 +81,7 @@             = mapSeal unBracketedFL <$> readPatch'         | otherwise             = read_patches-     where read_patches :: ParserM m => m (Sealed (FL p C(x )))+     where read_patches :: Parser (Sealed (FL p wX))            read_patches = do --tracePeek "starting FL read"                              -- checkConsumes is needed to make sure that something is read,                              -- to avoid stack overflow when parsing FL (FL p)@@ -95,27 +98,40 @@     readPatch' = mapSeal reverseFL <$> readPatch'  {-# INLINE bracketedFL #-}-bracketedFL :: forall p m C(x) . (ParserM m) =>-               (FORALL(y) m (Sealed (p C(y)))) -> Char -> Char -> m (Sealed (FL p C(x)))+bracketedFL :: forall p wX .+               (forall wY . Parser (Sealed (p wY))) -> Char -> Char -> Parser (Sealed (FL p wX)) bracketedFL parser pre post =     peekforc pre bfl mzero-        where bfl :: FORALL(z) m (Sealed (FL p C(z)))+        where bfl :: forall wZ . Parser (Sealed (FL p wZ))               bfl = peekforc post (return $ Sealed NilFL)                                   (do Sealed p <- parser                                       Sealed ps <- bfl                                       return $ Sealed (p:>:ps))  {-# INLINE peekforc #-}-peekforc :: ParserM m => Char -> m a -> m a -> m a+peekforc :: Char -> Parser a -> Parser a -> Parser a peekforc c ifstr ifnot = choice [ lexChar c >> ifstr                                 , ifnot ] -peekfor :: ParserM m => BC.ByteString -> m a -> m a -> m a+peekfor :: BC.ByteString -> Parser a -> Parser a -> Parser a peekfor ps ifstr ifnot = choice [ do lexString ps                                      ifstr                                 , ifnot ] {-# INLINE peekfor #-} -readFileName :: FileNameFormat -> B.ByteString -> FileName-readFileName OldFormat = ps2fn-readFileName NewFormat = fp2fn . decodeWhite . BC.unpack+-- See also Darcs.Patch.Show.formatFileName.+readFileName :: HasCallStack => FileNameFormat -> Parser AnchoredPath+readFileName fmt = do+  raw <- lexWord+  case BC.stripPrefix (BC.pack "./") raw of+    Nothing -> fail $ "invalid file path"+    Just raw' ->+      case convert fmt raw' of+        Left e -> fail e+        Right r -> return r+  where+    convert FileNameFormatV1 =+      floatPath <=< decodeWhite . decodeLocale . BC.pack . unpackPSFromUTF8+    convert FileNameFormatV2 =+      floatPath <=< decodeWhite . decodeLocale+    convert FileNameFormatDisplay = error "readFileName called with FileNameFormatDisplay"
− src/Darcs/Patch/ReadMonads.hs 
@@ -1,280 +0,0 @@-{-# LANGUAGE BangPatterns #-}--- | This module defines our parsing monad.  In the past there have been lazy--- and strict parsers in this module.  Currently we have only the strict--- variant and it is used for parsing patch files.-module Darcs.Patch.ReadMonads (ParserM, Darcs.Patch.ReadMonads.take,-                        parse, parseStrictly, char, int,-                        option, choice, skipSpace, skipWhile, string,-                        lexChar, lexString, lexEof, takeTillChar,-                        myLex', anyChar, endOfInput, takeTill,-                        checkConsumes,-                        linesStartingWith, linesStartingWithEndingWith) where--import ByteStringUtils ( dropSpace, breakSpace, breakFirstPS,-                         readIntPS, breakLastPS )-import qualified Data.ByteString as B (null, drop, length, tail, empty,-                                       ByteString)-import qualified Data.ByteString.Char8 as BC ( uncons, dropWhile, break-                                             , splitAt, length, head )-import Control.Applicative ( Alternative(..), Applicative(..), (<$>) )-import Control.Monad ( MonadPlus(..) )---- | 'lexChar' checks if the next space delimited token from--- the input stream matches a specific 'Char'.--- Uses 'Maybe' inside 'ParserM' to handle failed matches, so--- that it always returns () on success.-lexChar :: ParserM m => Char -> m ()-lexChar c = do-  skipSpace-  char c-  return ()---- | 'lexString' fetches the next whitespace delimited token from--- from the input and checks if it matches the 'ByteString' input.--- Uses 'Maybe' inside 'ParserM' to handle failed matches, so--- that it always returns () on success.-lexString :: ParserM m => B.ByteString -> m ()-lexString str = work-           $ \s -> case myLex s of-                       Just (xs :*: ys) | xs == str -> Just (() :*: ys)-                       _ -> Nothing---- | Only succeeds if the characters in the input exactly match @str@.-string :: ParserM m => B.ByteString -> m ()-string str = work-        $ \s -> case BC.splitAt (BC.length str) s of-                  (h, t) | h == str -> Just (() :*: t)-                  _ -> Nothing---- | 'lexEof' looks for optional spaces followed by the end of input.--- Uses 'Maybe' inside 'ParserM' to handle failed matches, so--- that it always returns () on success.-lexEof :: ParserM m => m ()-lexEof = work-        $ \s -> if B.null (dropSpace s)-                then Just (() :*: B.empty)-                else Nothing---- | 'myLex' drops leading spaces and then breaks the string at the--- next space.  Returns 'Nothing' when the string is empty after--- dropping leading spaces, otherwise it returns the first sequence--- of non-spaces and the remainder of the input.-myLex :: B.ByteString -> Maybe (ParserState B.ByteString)-myLex s = let s' = dropSpace s-           in if B.null s'-              then Nothing-              else Just $ stuple $ breakSpace s'---- | Like 'myLex' except that it is in ParserM-myLex' :: ParserM m => m B.ByteString-myLex' = work myLex---- | Accepts the next character and returns it.  Only fails at end of--- input.-anyChar :: ParserM m => m Char-anyChar = work $ \s -> stuple <$> BC.uncons s---- | Only succeeds at end of input, consumes no characters.-endOfInput :: ParserM m => m ()-endOfInput = work $ \s -> if B.null s-                            then Just (() :*: s)-                            else Nothing---- | Accepts only the specified character.  Consumes a character, if--- available.-char :: ParserM m => Char -> m ()-char c = work $ \s ->-  case BC.uncons s of-  Just (c', s') | c == c' -> Just (() :*: s')-  _ -> Nothing---- | Parse an integer and return it.  Skips leading whitespaces and--- | uses the efficient ByteString readInt.-int :: ParserM m => m Int-int = work $ \s -> stuple <$> readIntPS s---- | Discards spaces until a non-space character is encountered.--- Always succeeds.-skipSpace :: ParserM m => m ()-skipSpace = alterInput dropSpace---- | Discards any characters as long as @p@ returns True.  Always--- | succeeds.-skipWhile :: ParserM m => (Char -> Bool) -> m ()-skipWhile p = alterInput (BC.dropWhile p)---- | Takes characters while @p@ returns True.  Always succeeds.-takeTill :: ParserM m => (Char -> Bool) -> m B.ByteString-takeTill p = work $ \s -> Just $ stuple (BC.break p s)---- | Equivalent to @takeTill (==c)@, except that it is optimized for--- | the equality case.-takeTillChar :: ParserM m => Char -> m B.ByteString-takeTillChar c = work $ \s -> Just $ stuple (BC.break (==c) s)---- | Takes exactly @n@ bytes, or fails.-take :: ParserM m => Int -> m B.ByteString-take n = work $ \s -> if B.length s >= n-                        then Just $ stuple $ BC.splitAt n s-                        else Nothing---- | This is a highly optimized way to read lines that start with a--- particular character.  To implement this efficiently we need access--- to the parser's internal state.  If this is implemented in terms of--- the other primitives for the parser it requires us to consume one--- character at a time.  That leads to @(>>=)@ wasting significant--- time.-linesStartingWith :: ParserM m => Char -> m [B.ByteString]-linesStartingWith c = work $ linesStartingWith' c---- | Helper function for 'linesStartingWith'.-linesStartingWith' :: Char -> B.ByteString -> Maybe (ParserState [B.ByteString])-linesStartingWith' c thes =-    Just (lsw [] thes)-    where lsw acc s | B.null s || BC.head s /= c = (reverse acc :*: s)-          lsw acc s = let s' = B.tail s-                  in case breakFirstPS '\n' s' of-                     Just (l, r) -> lsw (l:acc) r-                     Nothing -> (reverse (s':acc) :*: B.empty)---- | This is a highly optimized way to read lines that start with a--- particular character, and stops when it reaches a particular |--- character.  See 'linesStartingWith' for details on why this |--- defined here as a primitive.-linesStartingWithEndingWith :: ParserM m => Char -> Char -> m [B.ByteString]-linesStartingWithEndingWith st en = work $ linesStartingWithEndingWith' st en---- | Helper function for 'linesStartingWithEndingWith'.-linesStartingWithEndingWith' :: Char -> Char -> B.ByteString-                             -> Maybe (ParserState [B.ByteString])-linesStartingWithEndingWith' st en s = lswew s-    where-  lswew x | B.null x = Nothing-  lswew x =-    if BC.head x == en-    then Just ([] :*: B.tail x)-    else if BC.head x /= st-         then Nothing-         else case BC.break ((==) '\n') $ B.tail x of-              (l,r) -> case lswew $ B.tail r of-                       Just (ls :*: r') -> Just ((l:ls) :*: r')-                       Nothing ->-                           case breakLastPS en l of-                           Just (l2,_) ->-                               Just ([l2] :*: B.drop (B.length l2+2) x)-                           Nothing -> Nothing----- | Applies a function to the input stream and discards the--- result of the function.-alterInput :: ParserM m-            => (B.ByteString -> B.ByteString) -> m ()-alterInput f = work (\s -> Just (() :*: f s))---- | If @p@ fails it returns @x@, otherwise it returns the result of @p@.-option :: Alternative f => a -> f a -> f a-option x p = p <|> pure x---- | Attempts each option until one succeeds.-choice :: Alternative f => [f a] -> f a-choice = foldr (<|>) empty---- |Ensure that a parser consumes input when producing a result--- Causes the initial state of the input stream to be held on to while the--- parser runs, so use with caution.-checkConsumes :: ParserM m => m a -> m a-checkConsumes parser = do-   x <- B.length <$> peekInput-   res <- parser-   x' <- B.length <$> peekInput-   if x' < x then return res else mzero--class (Functor m, Applicative m, Alternative m, Monad m, MonadPlus m) => ParserM m where-    -- | Applies a parsing function inside the 'ParserM' monad.-    work :: (B.ByteString -> Maybe (ParserState a)) -> m a-    -- | Applies a parsing function, that can return 'Nothing',-    -- inside the 'ParserM' monad.-    maybeWork :: (B.ByteString -> Maybe (ParserState a)) -> m (Maybe a)-    -- | Allows for the inspection of the input that is yet to be parsed.-    peekInput :: m B.ByteString-    -- | Run the parser-    parse :: m a -> B.ByteString -> Maybe (a, B.ByteString)------- Strict Monad -------- | 'parseStrictly' applies the parser functions to a string--- and checks that each parser produced a result as it goes.--- The strictness is in the 'ParserM' instance for 'SM'.-parseStrictly :: SM a -> B.ByteString -> Maybe (a, B.ByteString)-parseStrictly (SM f) s = case f s of-  Just (a :*: r) -> Just (a, r)-  _ -> Nothing---- | ParserState represents the internal state of the parser.  We make it--- strict and specialize it on ByteString.  This is purely to help GHC--- optimize.  If performance were not a concern, it could be replaced--- with @(a, ByteString)@.-data ParserState a = !a :*: !B.ByteString---- | Convert from a lazy tuple to a strict tuple.-stuple :: (a, B.ByteString) -> ParserState a-stuple (a, b) = a :*: b---- | 'SM' is the Strict Monad for parsing.-newtype SM a = SM (B.ByteString -> Maybe (ParserState a))--bindSM :: SM a -> (a -> SM b) -> SM b-bindSM (SM m) k = SM $ \s -> case m s of-                             Nothing -> Nothing-                             Just (x :*: s') ->-                               case k x of-                               SM y -> y s'-{-# INLINE bindSM #-}-returnSM :: a -> SM a-returnSM x = SM (\s -> Just (x :*: s))-{-# INLINE returnSM #-}-failSM :: String -> SM a-failSM _ = SM (\_ -> Nothing)-{-# INLINE failSM #-}--instance Monad SM where-    (>>=)  = bindSM-    return = returnSM-    fail   = failSM--instance ParserM SM where-    work f = SM f-    maybeWork f = SM $ \s -> case f s of-                                  Just (x :*: s') -> Just (Just x :*: s')-                                  Nothing -> Just (Nothing :*: s)-    peekInput = SM $ \s -> Just (s :*: s)-    parse = parseStrictly---- The following instances allow us to use more conventional--- interfaces provided by other parser libraries. The instances are--- defined using bindSM, returnSM, and failSM to avoid any infinite,--- or even unneccessary, recursion of instances between between--- ParserM and Monad.  Other recursive uses will be fine, such as--- (<|>) = mplus.-instance MonadPlus SM where-  mzero = failSM ""-  -- | Over using mplus can lead to space leaks.  It's best to push-  -- the use of mplus as far down as possible, because until the the-  -- first parameter completes, we must hold on to the input.-  mplus (SM a) (SM b) = SM $ \s ->-    case a s of-      Nothing -> b s-      r -> r--instance Functor SM where-  fmap f m = m `bindSM` (returnSM . f)--instance Applicative SM where-  pure = returnSM-  a <*> b =-    a `bindSM` \c ->-    b `bindSM` \d ->-    returnSM (c d)--instance Alternative SM where-  empty = failSM ""-  (<|>) = mplus
+ src/Darcs/Patch/Rebase/Change.hs view
@@ -0,0 +1,505 @@+--  Copyright (C) 2009 Ganesh Sittampalam+--+--  BSD3+module Darcs.Patch.Rebase.Change+    ( RebaseChange(..)+    , extractRebaseChange+    , reifyRebaseChange+    , partitionUnconflicted+    , rcToPia+    , WithDroppedDeps(..)+    , WDDNamed+    , commuterIdWDD+    , simplifyPush, simplifyPushes+    , addNamedToRebase+    ) where++import Darcs.Prelude++import Darcs.Patch.Commute ( commuteFL, commuteRL )+import Darcs.Patch.CommuteFn+    ( CommuteFn+    , MergeFn+    , commuterFLId, commuterIdFL+    )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.Ident ( Ident(..), PatchId )+import Darcs.Patch.Info ( PatchInfo, patchinfo, displayPatchInfo )+import Darcs.Patch.Invert ( invert )+import Darcs.Patch.Merge ( selfMerger )+import Darcs.Patch.Named+    ( Named(..)+    , HasDeps(..)+    , infopatch+    , mergerIdNamed+    , patchcontents+    , ShowDepsFormat(..)+    , ShowWhichDeps(..)+    , showDependencies+    )++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Show ( ShowPatch(..) )+import Darcs.Patch.Summary+    ( ConflictState(..)+    , IsConflictedPrim(..)+    , Summary(..)+    , plainSummary+    , plainSummaryFL+    )+import Darcs.Patch.FromPrim ( PrimPatchBase(..), FromPrim(..) )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanFL )+import Darcs.Patch.Prim.Class ( PrimPatch )+import Darcs.Patch.Rebase.Fixup+    ( RebaseFixup(..)+    , commuteFixupNamed, commuteNamedFixup+    , flToNamesPrims+    , pushFixupFixup+    )+import Darcs.Patch.Rebase.Name ( RebaseName(..) )+import Darcs.Patch.Rebase.PushFixup+  ( PushFixupFn, dropFixups+  , pushFixupFLMB_FLFLMB+  , pushFixupIdMB_FLFLMB+  , pushFixupIdMB_FLIdFLFL+  )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(..), ShowContextPatch(..) )+import Darcs.Patch.Unwind ( Unwound(..), fullUnwind )+import Darcs.Patch.V3 ( RepoPatchV3 )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm )+import Darcs.Util.IsoDate ( getIsoDateTime )+import Darcs.Util.Parser ( lexString )+import Darcs.Util.Printer ( Doc, ($$), (<+>), blueText )++import qualified Data.ByteString.Char8 as BC ( pack )+import Data.List ( (\\) )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( fromMaybe )++data RebaseChange prim wX wY where+    RC :: FL (RebaseFixup prim) wX wY -> Named prim wY wZ -> RebaseChange prim wX wZ++instance Show2 prim => Show1 (RebaseChange prim wX)++instance Show2 prim => Show2 (RebaseChange prim)++deriving instance Show2 prim => Show (RebaseChange prim wX wY)++-- |Get hold of the 'Named' patch inside a 'RebaseChange' and wrap it in a+-- 'PatchInfoAnd'.+rcToPia :: RebaseChange prim wX wY -> Sealed2 (PatchInfoAnd prim)+rcToPia (RC _ toEdit) = Sealed2 (n2pia toEdit)++instance PrimPatch prim => PrimPatchBase (RebaseChange prim) where+  type PrimOf (RebaseChange prim) = prim++instance PatchDebug prim => PatchDebug (RebaseChange prim)++instance HasDeps (RebaseChange prim) where+  getdeps (RC _ toedit) = getdeps toedit++type instance PatchId (RebaseChange prim) = PatchInfo++instance Ident (RebaseChange prim) where+  ident (RC _ toedit) = ident toedit++instance Apply prim => Apply (RebaseChange prim) where+   type ApplyState (RebaseChange prim) = ApplyState prim+   apply (RC fixups toedit) = apply fixups >> apply toedit+   unapply (RC fixups toedit) = unapply toedit >> unapply fixups++instance Commute prim => Summary (RebaseChange prim) where+  conflictedEffect (RC fixups toedit) =+    case flToNamesPrims fixups of+      _names :> prims ->+        -- Report on the conflicts we would get if we unsuspended just this patch.+        -- An alternative implementation strategy would be to "force commute"+        -- prims :> toedit and report on the resulting conflicts in toedit.+        -- However this ties us to a specific RepoPatch type which isn't really+        -- needed for a simple calculation like this.+        --+        -- The rebase invariants should mean that 'fixups' (if non-empty) won't+        -- commute with 'changes' as a whole, but here we need to report each individual+        -- prim as conflicted or not, so we try to push the fixups as far through+        -- the individual prims as we can.+        --+        -- Taking the effect also means that any conflicts already present in the+        -- suspended patch won't be reported, but in general such conflicts+        -- are not supported anyway.+        case genCommuteWhatWeCanFL (commuterFLId commute) (prims :> patchcontents toedit) of+          unconflicted :> _ :> conflicted ->+            mapFL (IsC Okay) unconflicted ++ mapFL (IsC Conflicted) conflicted++instance PrimPatch prim => ShowPatchBasic (RebaseChange prim) where+  showPatch ForStorage (RC fixups toedit) =+    blueText "rebase-change"+      <+> blueText "(" $$ showPatch ForStorage fixups $$ blueText ")"+      $$ showPatch ForStorage toedit+  showPatch ForDisplay rc@(RC _ (NamedP n _ _)) =+    displayPatchInfo n $$ rebaseChangeContent rc++rebaseChangeContent+  :: forall prim wX wY . PrimPatch prim => RebaseChange prim wX wY -> Doc+rebaseChangeContent (RC fixups toedit) =+  case forceCommutes ((fixups :> WithDroppedDeps (fromPrimNamed toedit) []) ::+        (FL (RebaseFixup prim) :> WDDNamed (RepoPatchV3 prim)) wX wY) of+    WithDroppedDeps toedit' dds :> _ ->+      showDependencies ShowDroppedDeps ShowDepsVerbose dds $$+      -- eliminate leading inverse pair for display, see forceCommutePrim+      case toedit' of+        NamedP i ds (p1 :>: p2 :>: rest)+          | IsEq <- invert (effect p1) =\/= effect p2 ->+            content (NamedP i ds rest)+        _ -> content toedit'++droppedDeps :: FL (RebaseFixup prim) wX wY -> [PatchInfo]+droppedDeps NilFL = []+droppedDeps (NameFixup (AddName name) :>: fs) = name : droppedDeps fs+droppedDeps (_ :>: fs) = droppedDeps fs++instance PrimPatch prim => ShowPatch (RebaseChange prim) where+    -- This should really just call 'description' on the ToEdit patch,+    -- but that introduces a spurious dependency on Summary (PrimOf p),+    -- because of other methods in the Named instance, so we just inline+    -- the implementation from Named here.+    description (RC _ (NamedP n _ _)) = displayPatchInfo n+    -- TODO report conflict indicating name fixups (i.e. dropped deps)+    summary p@(RC fs (NamedP _ ds _)) =+      showDependencies ShowDroppedDeps ShowDepsSummary (droppedDeps fs) $$+      showDependencies ShowNormalDeps ShowDepsSummary (ds \\ droppedDeps fs) $$+      plainSummary p+    summaryFL ps =+      showDependencies ShowDroppedDeps ShowDepsSummary (droppedDepsFL ps) $$+      showDependencies ShowNormalDeps ShowDepsSummary (getdepsFL ps \\ droppedDepsFL ps) $$+      plainSummaryFL ps+      where+        getdepsFL = nubSort . concat . mapFL getdeps+        droppedDepsFL = concat . mapFL (unseal droppedDeps . getFixups)+        getFixups (RC fs _) = Sealed fs+    content = rebaseChangeContent++-- TODO this is a dummy instance that does not actually show context+instance PrimPatch prim => ShowContextPatch (RebaseChange prim) where+    showPatchWithContextAndApply f p = apply p >> return (showPatch f p)++instance (ReadPatch prim, PatchListFormat prim) => ReadPatch (RebaseChange prim) where+  readPatch' = do+    lexString (BC.pack "rebase-change")+    lexString (BC.pack "(")+    Sealed fixups <- readPatch'+    lexString (BC.pack ")")+    Sealed contents <- readPatch'+    return $ Sealed $ RC fixups contents++instance Commute prim => Commute (RebaseChange prim) where+  commute (RC fixups1 edit1 :> RC fixups2 edit2) = do+    fixups2' :> edit1' <- commuterIdFL commuteNamedFixup (edit1 :> fixups2)+    edit2' :> edit1'' <- commute (edit1' :> edit2)+    fixupsS :> (fixups2'' :> edit2'') :> fixups1' <-+      return $ pushThrough (fixups1 :> (fixups2' :> edit2'))+    return (RC (fixupsS +>+ fixups2'') edit2'' :> RC fixups1' edit1'')++instance PatchInspect prim => PatchInspect (RebaseChange prim) where+   listTouchedFiles (RC fixup toedit) = nubSort (listTouchedFiles fixup ++ listTouchedFiles toedit)+   hunkMatches f (RC fixup toedit) = hunkMatches f fixup || hunkMatches f toedit++-- |Split a list of rebase patches into those that will+-- have conflicts if unsuspended and those that won't.+partitionUnconflicted+    :: Commute prim+    => FL (RebaseChange prim) wX wY+    -> (FL (RebaseChange prim) :> RL (RebaseChange prim)) wX wY+partitionUnconflicted = partitionUnconflictedAcc NilRL++partitionUnconflictedAcc+  :: Commute prim+  => RL (RebaseChange prim) wX wY -> FL (RebaseChange prim) wY wZ+  -> (FL (RebaseChange prim) :> RL (RebaseChange prim)) wX wZ+partitionUnconflictedAcc right NilFL = NilFL :> right+partitionUnconflictedAcc right (p :>: ps) =+   case commuteRL (right :> p) of+     Just (p'@(RC NilFL _) :> right')+       -> case partitionUnconflictedAcc right' ps of+            left' :> right'' -> (p' :>: left') :> right''+     _ -> partitionUnconflictedAcc (right :<: p) ps++-- | A patch, together with a list of patch names that it used to depend on,+-- but were lost during the rebasing process. The UI can use this information+-- to report them to the user.+data WithDroppedDeps p wX wY =+    WithDroppedDeps {+        wddPatch :: p wX wY,+        wddDependedOn :: [PatchInfo]+    }++noDroppedDeps :: p wX wY -> WithDroppedDeps p wX wY+noDroppedDeps p = WithDroppedDeps p []++instance PrimPatchBase p => PrimPatchBase (WithDroppedDeps p) where+   type PrimOf (WithDroppedDeps p) = PrimOf p++instance Effect p => Effect (WithDroppedDeps p) where+   effect = effect . wddPatch++-- |Given a list of rebase items, try to push a new fixup as far as possible into+-- the list as possible, using both commutation and coalescing. If the fixup+-- commutes past all the 'ToEdit' patches then it is dropped entirely.+simplifyPush+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> RebaseFixup prim wX wY+  -> FL (RebaseChange prim) wY wZ+  -> Sealed (FL (RebaseChange prim) wX)+simplifyPush da fixup items = dropFixups $ pushFixupChanges da (fixup :> items)++-- |Like 'simplifyPush' but for a list of fixups.+simplifyPushes+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> FL (RebaseFixup prim) wX wY+  -> FL (RebaseChange prim) wY wZ+  -> Sealed (FL (RebaseChange prim) wX)+simplifyPushes _ NilFL ps = Sealed ps+simplifyPushes da (f :>: fs) ps = unseal (simplifyPush da f) (simplifyPushes da fs ps)++pushFixupChange+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> PushFixupFn+       (RebaseFixup prim) (RebaseChange prim)+       (RebaseChange prim) (Maybe2 (RebaseFixup prim))+pushFixupChange da (f1 :> RC fs2 e)+  = case pushFixupFLMB_FLFLMB (pushFixupFixup da) (f1 :> fs2) of+      fs2' :> Nothing2 -> RC fs2' e :> Nothing2+      fs2' :> Just2 f1' ->+        case commuteFixupNamed (f1' :> e) of+          -- The fixup is "stuck" so just attach it here+          Nothing -> RC (fs2' +>+ f1' :>: NilFL) e :> Nothing2+          Just (e' :> f1'') -> RC fs2' e' :> Just2 f1''++pushFixupChanges+  :: PrimPatch prim+  =>  D.DiffAlgorithm+  -> PushFixupFn+       (RebaseFixup prim) (FL (RebaseChange prim))+       (FL (RebaseChange prim)) (Maybe2 (RebaseFixup prim))+pushFixupChanges da = pushFixupIdMB_FLFLMB (pushFixupChange da)++pushFixupsChange+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> PushFixupFn+       (FL (RebaseFixup prim)) (RebaseChange prim)+       (RebaseChange prim) (FL (RebaseFixup prim))+pushFixupsChange da = pushFixupIdMB_FLIdFLFL (pushFixupChange da)+++-- Note, this could probably be rewritten using a generalised commuteWhatWeCanFL from+-- Darcs.Patch.Permutations.+-- |@pushThrough (ps :> (qs :> te))@ tries to commute as much of @ps@ as possible through+-- both @qs@ and @te@, giving @psStuck :> (qs' :> te') :> psCommuted@.+-- Anything that can be commuted ends up in @psCommuted@ and anything that can't goes in+-- @psStuck@.+pushThrough+  :: Commute prim+  => (FL (RebaseFixup prim) :> (FL (RebaseFixup prim) :> Named prim)) wX wY+  -> (FL (RebaseFixup prim) :> (FL (RebaseFixup prim) :> Named prim) :> FL (RebaseFixup prim)) wX wY+pushThrough (NilFL :> v) = NilFL :> v :> NilFL+pushThrough ((p :>: ps) :> v) =+  case pushThrough (ps :> v) of+   psS :> v'@(qs:>te) :> ps' ->+     fromMaybe ((p :>: psS) :> v' :> ps') $ do+       psS' :> p' <- commuteFL (p :> psS)+       qs' :> p'' <- commuteFL (p' :> qs)+       te' :> p''' <- commuteFixupNamed (p'' :> te)+       return (psS' :> (qs' :> te') :> (p''' :>: ps'))++type WDDNamed p = WithDroppedDeps (Named p)++mergerIdWDD :: MergeFn p1 p2 -> MergeFn p1 (WithDroppedDeps p2)+mergerIdWDD merger (p1 :\/: WithDroppedDeps p2 deps) =+   case merger (p1 :\/: p2) of+     p2' :/\: p1' -> WithDroppedDeps p2' deps :/\: p1'++commuterIdWDD :: CommuteFn p q -> CommuteFn p (WithDroppedDeps q)+commuterIdWDD commuter (p :> WithDroppedDeps q deps)+  = do -- no need to worry about names, because by definition a dropped dep+       -- is a name we no longer have+       -- TODO consistency checking?+       -- TODO consider inverse commutes, e.g. what happens if we wanted to+       -- commute (WithDroppedDeps ... [n] :> AddName n)?+       q' :> p' <- commuter (p :> q)+       return (WithDroppedDeps q' deps :> p')++-- |Forcibly commute a 'RebaseName' with a patch, dropping any dependencies+-- if necessary and recording them in the patch+forceCommuteName :: (RebaseName :> WDDNamed p) wX wY -> (WDDNamed p :> RebaseName) wX wY+forceCommuteName (AddName an :> WithDroppedDeps (NamedP pn deps body) ddeps)+  | an == pn = error "impossible case"+  | otherwise =+      WithDroppedDeps+        (NamedP pn (deps \\ [an]) (unsafeCoerceP body))+        (if an `elem` deps then an : ddeps else ddeps)+      :>+      AddName an+forceCommuteName (DelName dn :> p@(WithDroppedDeps (NamedP pn deps _body) _ddeps))+  | dn == pn = error "impossible case"+  | dn `elem` deps = error "impossible case"+  | otherwise = unsafeCoerceP p :> DelName dn+forceCommuteName (Rename old new :> WithDroppedDeps (NamedP pn deps body) ddeps)+  | old == pn = error "impossible case"+  | new == pn = error "impossible case"+  | old `elem` deps = error "impossible case"+  | otherwise =+      let newdeps = map (\dep -> if new == dep then old else dep) deps+      in WithDroppedDeps (NamedP pn newdeps (unsafeCoerceP body)) ddeps :> Rename old new++forceCommutePrim :: RepoPatch p+                 => (PrimOf p :> WDDNamed p) wX wY+                 -> (WDDNamed p :> FL (PrimOf p)) wX wY+forceCommutePrim (p :> wq) =+    -- rp and irp are not inverses for RepoPatchV3, only their effects are inverse+    let rp = fromAnonymousPrim p+        irp = fromAnonymousPrim (invert p)+    in case mergerIdWDD (mergerIdNamed selfMerger) (irp :\/: wq) of+        wq' :/\: irp' -> prefixWith (rp :>: irp :>: NilFL) wq' :> invert (effect irp')+    where+      -- TODO [V3INTEGRATION]:+      -- This is a hack to adapt forceCommutePrim to the stricter assumptions+      -- made by RepoPatchV3, for which resolveConflicts expects that we can+      -- find each patch we conflict with somewhere in the context.+      -- Force-commuting the fixups with the patch to be edited violates that+      -- assumption. It works for RepoPatchV1/2 because their conflictors are+      -- self-contained i.e. they contain the transitive set of conflicts in+      -- their representation, which is no longer true for RepoPatchV3.+      -- To restore the assumption for RepoPatchV3 we prefix the patches+      -- contained in the 'Named' patch with (rp;irp). The conflictor wq' can+      -- now refer to irp, and the effect of rp will cancel with that of irp+      -- on unsuspend.+      prefixWith xs (WithDroppedDeps (NamedP i ds ps) dds) =+          WithDroppedDeps (NamedP i ds (xs +>+ ps)) dds++forceCommutes :: RepoPatch p+              => (FL (RebaseFixup (PrimOf p)) :> WDDNamed p) wX wY+              -> (WDDNamed p :> FL (RebaseFixup (PrimOf p))) wX wY+forceCommutes (NilFL :> q) = q :> NilFL+forceCommutes ((NameFixup n :>: ps) :> q) =+    case forceCommutes (ps :> q) of+        q' :> ps' ->+            case forceCommuteName (n :> q') of+                q'' :> n' -> q'' :> (NameFixup n' :>: ps')+forceCommutes ((PrimFixup p :>: ps) :> q) =+    case forceCommutes (ps :> q) of+        q' :> ps' ->+            case forceCommutePrim (p :> q') of+                qs'' :> p' -> qs'' :> (mapFL_FL PrimFixup p' +>+ ps')++fromPrimNamed :: FromPrim p => Named (PrimOf p) wX wY -> Named p wX wY+fromPrimNamed (NamedP n deps ps) = NamedP n deps (fromPrims n ps)++-- |Turn a selected rebase patch back into a patch we can apply to+-- the main repository, together with residual fixups that need+-- to go back into the rebase state (unless the rebase is now finished).+-- Any fixups associated with the patch will turn into conflicts.+extractRebaseChange+  :: forall p wX wY+   . RepoPatch p+  => D.DiffAlgorithm+  -> FL (RebaseChange (PrimOf p)) wX wY+  -> (FL (WDDNamed p) :> FL (RebaseFixup (PrimOf p))) wX wY+extractRebaseChange da rcs = go (NilFL :> rcs)+  where+    go+      :: forall wA wB+       . (FL (RebaseFixup (PrimOf p)) :> FL (RebaseChange (PrimOf p))) wA wB+      -> (FL (WDDNamed p) :> FL (RebaseFixup (PrimOf p))) wA wB+    go (fixupsIn :> NilFL) = NilFL :> fixupsIn+    go (fixupsIn :> rc :>: rest) =+      -- First simplify any fixups coming from previous extract operations.+      -- Note that it's important to start at the front of the list so that+      -- we can do this, as it minimises the conflicts we end up with.+      case pushFixupsChange da (fixupsIn :> rc) of+        -- Now use 'fromPrimNamed' to change the toedit patch from+        -- Named (PrimOf p) that we store in the rebase to Named p+        -- that we store in the repository. Then, wrap it in WithDroppedDeps+        -- so we can track any explicit dependencies that were lost, and+        -- finally force-commute the fixups with this and any other patches we are+        -- unsuspending.+        RC fixups toedit :> fixupsOut2 ->+          case forceCommutes (fixups :> WithDroppedDeps (fromPrimNamed toedit) []) of+            toedit' :> fixupsOut1 ->+              case go (fixupsOut1 +>+ fixupsOut2 :> rest) of+                toedits' :> fixupsOut -> toedit' :>: toedits' :> fixupsOut++-- signature to be compatible with extractRebaseChange+-- | Like 'extractRebaseChange', but any fixups are "reified" into a separate patch.+reifyRebaseChange+  :: FromPrim p+  => String+  -> FL (RebaseChange (PrimOf p)) wX wY+  -> IO ((FL (WDDNamed p) :> FL (RebaseFixup (PrimOf p))) wX wY)+reifyRebaseChange author rs = do+    res <- concatFL <$> mapFL_FL_M reifyOne rs+    return (res :> NilFL)+  where+    reifyOne :: FromPrim p => RebaseChange (PrimOf p) wA wB -> IO (FL (WDDNamed p) wA wB)+    reifyOne (RC fixups toedit) =+      case flToNamesPrims fixups of+        names :> NilFL ->+          return $+            mapFL_FL (noDroppedDeps . mkDummy) names +>++            noDroppedDeps (fromPrimNamed toedit) :>:+            NilFL+        names :> prims -> do+          n <- mkReified author prims+          return $+            mapFL_FL (noDroppedDeps . mkDummy) names +>+ noDroppedDeps n :>:+            noDroppedDeps (fromPrimNamed toedit) :>:+            NilFL++mkReified :: FromPrim p => String -> FL (PrimOf p) wX wY -> IO (Named p wX wY)+mkReified author ps = do+     let name = "Reified fixup patch"+     let desc = []+     date <- getIsoDateTime+     info <- patchinfo date name author desc+     return $ infopatch info ps++mkDummy :: FromPrim p => RebaseName wX wY -> Named p wX wY+mkDummy (AddName pi) = infopatch pi (unsafeCoerceP NilFL)+mkDummy (DelName _) = error "internal error: can't make a dummy patch from a delete"+mkDummy (Rename _ _) = error "internal error: can't make a dummy patch from a rename"++instance IsHunk (RebaseChange prim) where+    -- RebaseChange is a compound patch, so it doesn't really make sense to+    -- ask whether it's a hunk. TODO: get rid of the need for this.+    isHunk _ = Nothing++instance PatchListFormat (RebaseChange prim)++addNamedToRebase+  :: RepoPatch p+  => D.DiffAlgorithm+  -> Named p wX wY+  -> FL (RebaseChange (PrimOf p)) wY wZ+  -> Sealed (FL (RebaseChange (PrimOf p)) wX)+addNamedToRebase da named@(NamedP n deps _) =+  case fullUnwind named of+    Unwound before underlying after ->+      unseal (simplifyPushes da (mapFL_FL PrimFixup before)) .+      mapSeal ((RC NilFL (NamedP n deps underlying) :>:)) .+      simplifyPushes da (mapFL_FL PrimFixup (reverseRL after))
+ src/Darcs/Patch/Rebase/Fixup.hs view
@@ -0,0 +1,198 @@+--  Copyright (C) 2011-2 Ganesh Sittampalam +--+--  BSD3++{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.Rebase.Fixup+    ( RebaseFixup(..)+    , commuteNamedFixup, commuteFixupNamed+    , pushFixupFixup+    , flToNamesPrims, namedToFixups+    ) where++import Darcs.Prelude++import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..), selfCommuter )+import Darcs.Patch.CommuteFn ( totalCommuterIdFL )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Named ( Named(..) )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )+import Darcs.Patch.Prim ( PrimPatch, canonizeFL )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Rebase.Name+    ( RebaseName(..)+    , commuteNamedName, commuteNameNamed+    , commuterNamedId, commuterIdNamed+    , commutePrimName, commuteNamePrim+    , pushFixupName+    )+import Darcs.Patch.Rebase.PushFixup ( PushFixupFn )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..), mapMB_MB )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), mapFL_FL, (:>)(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed, mapSeal )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, showsPrec2, appPrec )++import qualified Darcs.Util.Diff as D ( DiffAlgorithm )+import Darcs.Util.Parser ( Parser, lexString )+import Darcs.Util.Printer ( ($$), (<+>), blueText )++import Control.Applicative ( (<|>) )+import qualified Data.ByteString as B ( ByteString )+import qualified Data.ByteString.Char8 as BC ( pack )++-- |A single rebase fixup, needed to ensure that the actual patches+-- being stored in the rebase state have the correct context.+data RebaseFixup prim wX wY where+  PrimFixup :: prim wX wY -> RebaseFixup prim wX wY+  NameFixup :: RebaseName wX wY -> RebaseFixup prim wX wY++namedToFixups :: Effect p => Named p wX wY -> FL (RebaseFixup (PrimOf p)) wX wY+namedToFixups (NamedP p _ contents) = NameFixup (AddName p) :>: mapFL_FL PrimFixup (effect contents)++instance Show2 prim => Show (RebaseFixup prim wX wY) where+    showsPrec d (PrimFixup p) =+        showParen (d > appPrec) $ showString "PrimFixup " . showsPrec2 (appPrec + 1) p+    showsPrec d (NameFixup p) =+        showParen (d > appPrec) $ showString "NameFixup " . showsPrec2 (appPrec + 1) p++instance Show2 prim => Show1 (RebaseFixup prim wX)++instance Show2 prim => Show2 (RebaseFixup prim)++instance PrimPatch prim => PrimPatchBase (RebaseFixup prim) where+    type PrimOf (RebaseFixup prim) = prim++instance Apply prim => Apply (RebaseFixup prim) where+    type ApplyState (RebaseFixup prim) = ApplyState prim+    apply (PrimFixup p) = apply p+    apply (NameFixup _) = return ()+    unapply (PrimFixup p) = unapply p+    unapply (NameFixup _) = return ()++instance Invert prim => Invert (RebaseFixup prim) where+    invert (PrimFixup p) = PrimFixup (invert p)+    invert (NameFixup n) = NameFixup (invert n)++instance PatchInspect prim => PatchInspect (RebaseFixup prim) where+    listTouchedFiles (PrimFixup p) = listTouchedFiles p+    listTouchedFiles (NameFixup n) = listTouchedFiles n++    hunkMatches f (PrimFixup p) = hunkMatches f p+    hunkMatches f (NameFixup n) = hunkMatches f n++instance PatchListFormat (RebaseFixup prim)++instance ShowPatchBasic prim => ShowPatchBasic (RebaseFixup prim) where+  showPatch f (PrimFixup p) =+    blueText "rebase-fixup" <+> blueText "(" $$ showPatch f p $$ blueText ")"+  showPatch f (NameFixup p) =+    blueText "rebase-name" <+> blueText "(" $$ showPatch f p $$ blueText ")"++instance ReadPatch prim => ReadPatch (RebaseFixup prim) where+ readPatch' =+   mapSeal PrimFixup <$> readWith (BC.pack "rebase-fixup" ) <|>+   mapSeal NameFixup <$> readWith (BC.pack "rebase-name"  )+   where+     readWith :: forall q wX . ReadPatch q => B.ByteString -> Parser (Sealed (q wX))+     readWith str = do+       lexString str+       lexString (BC.pack "(")+       res <- readPatch'+       lexString (BC.pack ")")+       return res+++instance Commute prim => Commute (RebaseFixup prim) where+    commute (PrimFixup p :> PrimFixup q) = do+        q' :> p' <- commute (p :> q)+        return (PrimFixup q' :> PrimFixup p')++    commute (NameFixup p :> NameFixup q) = do+        q' :> p' <- commute (p :> q)+        return (NameFixup q' :> NameFixup p')++    commute (PrimFixup p :> NameFixup q) = do+        q' :> p' <- return $ commutePrimName (p :> q)+        return (NameFixup q' :> PrimFixup p')++    commute (NameFixup p :> PrimFixup q) = do+        q' :> p' <- return $ commuteNamePrim (p :> q)+        return (PrimFixup q' :> NameFixup p')++pushFixupPrim+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> PushFixupFn prim prim (FL prim) (Maybe2 prim)+pushFixupPrim da (f1 :> f2)+ | IsEq <- isInverse = NilFL :> Nothing2+ | otherwise+   = case commute (f1 :> f2) of+       Nothing -> canonizeFL da (f1 :>: f2 :>: NilFL) :> Nothing2+       Just (f2' :> f1') -> (f2' :>: NilFL) :> Just2 f1'+  where isInverse = invert f1 =\/= f2++pushFixupFixup+  :: PrimPatch prim+  => D.DiffAlgorithm+  -> PushFixupFn+       (RebaseFixup prim) (RebaseFixup prim)+       (FL (RebaseFixup prim)) (Maybe2 (RebaseFixup prim))++pushFixupFixup da (PrimFixup f1 :> PrimFixup f2)+  = case pushFixupPrim da (f1 :> f2) of+      fs2' :> f1' -> mapFL_FL PrimFixup fs2' :> mapMB_MB PrimFixup f1'++pushFixupFixup _da (PrimFixup f :> NameFixup n)+  = case commutePrimName (f :> n) of+      n' :> f' -> (NameFixup n' :>: NilFL) :> Just2 (PrimFixup f')++pushFixupFixup _da (NameFixup n1 :> NameFixup n2)+  = case pushFixupName (n1 :> n2) of+      ns2' :> n1' -> mapFL_FL NameFixup ns2' :> mapMB_MB NameFixup n1'++pushFixupFixup _da (NameFixup n :> PrimFixup f)+  = case commuteNamePrim (n :> f) of+      f' :> n' -> (PrimFixup f' :>: NilFL) :> Just2 (NameFixup n')+++-- |Split a sequence of fixups into names and prims+flToNamesPrims :: FL (RebaseFixup prim) wX wY+               -> (FL RebaseName :> FL prim) wX wY+flToNamesPrims NilFL = NilFL :> NilFL+flToNamesPrims (NameFixup n :>: fs) =+    case flToNamesPrims fs of+        names :> prims -> (n :>: names) :> prims+flToNamesPrims (PrimFixup p :>: fs) =+    case flToNamesPrims fs of+        names :> prims ->+            case totalCommuterIdFL commutePrimName (p :> names) of+                names' :> p' -> names' :> (p' :>: prims)++commuteNamedFixup+  :: Commute prim+  => (Named prim :> RebaseFixup prim) wX wY+  -> Maybe ((RebaseFixup prim :> Named prim) wX wY)+commuteNamedFixup (p :> PrimFixup q) = do+    q' :> p' <- commuterNamedId selfCommuter (p :> q)+    return (PrimFixup q' :> p')+commuteNamedFixup (p :> NameFixup n) = do+    n' :> p' <- commuteNamedName (p :> n)+    return (NameFixup n' :> p')++commuteFixupNamed+  :: Commute prim+  => (RebaseFixup prim :> Named prim) wX wY+  -> Maybe ((Named prim :> RebaseFixup prim) wX wY)+commuteFixupNamed (PrimFixup p :> q) = do+    q' :> p' <- commuterIdNamed selfCommuter (p :> q)+    return (q' :> PrimFixup p')+commuteFixupNamed (NameFixup n :> q) = do+    q' :> n' <- commuteNameNamed (n :> q)+    return (q' :> NameFixup n')
+ src/Darcs/Patch/Rebase/Legacy/Item.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.Rebase.Legacy.Item+    ( RebaseItem(..)+    , toRebaseChanges+    ) where++import Darcs.Prelude++import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.Named ( Named(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase, PrimOf )+import Darcs.Patch.Rebase.Change ( RebaseChange(..), addNamedToRebase )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Util.Parser ( Parser, lexString )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import qualified Darcs.Util.Diff as D++import Control.Applicative ( (<|>) )+import qualified Data.ByteString as B ( ByteString )+import qualified Data.ByteString.Char8 as BC ( pack )++-- |A single item in the rebase state consists of either+-- a patch that is being edited, or a fixup that adjusts+-- the context so that a subsequent patch that is being edited+-- \"makes sense\".+--+-- @ToEdit@ holds a patch that is being edited. The name ('PatchInfo') of+-- the patch will typically be the name the patch had before+-- it was added to the rebase state; if it is moved back+-- into the repository it must be given a fresh name to account+-- for the fact that it will not necessarily have the same+-- dependencies or content as the original patch. This is typically+-- done by changing the @Ignore-This@ junk.+--+-- @Fixup@ adjusts the context so that a subsequent @ToEdit@ patch+-- is correct. Where possible, @Fixup@ changes are commuted+-- as far as possible into the rebase state, so any remaining+-- ones will typically cause a conflict when the @ToEdit@ patch+-- is moved back into the repository.+data RebaseItem p wX wY where+    ToEdit :: Named p wX wY -> RebaseItem p wX wY+    Fixup :: RebaseFixup (PrimOf p) wX wY -> RebaseItem p wX wY++deriving instance (Show2 p, Show2 (PrimOf p)) => Show (RebaseItem p wX wY)++instance (Show2 p, Show2 (PrimOf p)) => Show1 (RebaseItem p wX)++instance (Show2 p, Show2 (PrimOf p)) => Show2 (RebaseItem p)++toRebaseChanges :: RepoPatch p+                => FL (RebaseItem p) wX wY+                -> Sealed (FL (RebaseChange (PrimOf p)) wX)+toRebaseChanges NilFL = Sealed NilFL+toRebaseChanges (Fixup f :>: ps) =+    case toRebaseChanges ps of+      Sealed (RC fixups toedit :>: rest) -> Sealed (RC (f :>: fixups) toedit :>: rest)+      Sealed NilFL -> error "rebase chain with Fixup at end"+toRebaseChanges (ToEdit te :>: ps) =+  unseal (addNamedToRebase D.MyersDiff te) (toRebaseChanges ps)++-- This Read instance partly duplicates the instances for RebaseFixup,+-- but are left this way given this code is now here only for backwards compatibility of the on-disk+-- format and we might want to make future changes to RebaseFixup.+instance (PrimPatchBase p, PatchListFormat p, ReadPatch p) => ReadPatch (RebaseItem p) where+   readPatch' = mapSeal ToEdit              <$> readWith (BC.pack "rebase-toedit") <|>+                mapSeal (Fixup . PrimFixup) <$> readWith (BC.pack "rebase-fixup" ) <|>+                mapSeal (Fixup . NameFixup) <$> readWith (BC.pack "rebase-name"  )+     where readWith :: forall q wX . ReadPatch q => B.ByteString -> Parser (Sealed (q wX))+           readWith str = do lexString str+                             lexString (BC.pack "(")+                             res <- readPatch'+                             lexString (BC.pack ")")+                             return res
+ src/Darcs/Patch/Rebase/Legacy/Wrapped.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.Rebase.Legacy.Wrapped+  ( WrappedNamed(..)+  , fromRebasing+  ) where++import Darcs.Prelude++import Control.Applicative ( (<|>) )+import Data.Coerce ( coerce )++import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.Format ( PatchListFormat(..), ListFormat )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.FromPrim ( FromPrim, PrimPatchBase(..) )+import Darcs.Patch.Named ( Named(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Rebase.Suspended ( Suspended, readSuspended )+import Darcs.Patch.RepoPatch ( RepoPatch )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL )++-- |A patch that lives in a repository where an old-style rebase is in+-- progress. Such a repository will consist of @Normal@ patches+-- along with exactly one @Suspended@ patch.+--+-- It is here only so that we can upgrade an old-style rebase.+--+-- @NormalP@ represents a normal patch within a respository where a+-- rebase is in progress. @NormalP p@ is given the same on-disk+-- representation as @p@, so a repository can be switched into+-- and out of rebasing mode simply by adding or removing a+-- @RebaseP@ patch and setting the appropriate format flag.+--+-- Note that the witnesses are such that the @RebaseP@+-- patch has no effect on the context of the rest of the+-- repository; in a sense the patches within it are+-- dangling off to one side from the main repository.+data WrappedNamed p wX wY where+  NormalP :: !(Named p wX wY) -> WrappedNamed p wX wY+  RebaseP+    :: (PrimPatchBase p, FromPrim p, Effect p)+    => !PatchInfo+    -> !(Suspended p wX)+    -> WrappedNamed p wX wX++fromRebasing :: WrappedNamed p wX wY -> Named p wX wY+fromRebasing (NormalP n) = n+fromRebasing (RebaseP {}) = error "internal error: found rebasing internal patch"++-- This is a local hack to maintain backwards compatibility with+-- the on-disk format for rebases. Previously the rebase container+-- was internally represented via a 'Rebasing' type that sat *inside*+-- a 'Named', and so the rebase container patch had the structure+-- 'NamedP i [] (Suspendended s :>: NilFL)'. This structure was reflected+-- in the way it was saved on disk.+-- The easiest to read this structure is to use an intermediate type+-- that reflects the old structure.+-- Cleaning this up is obsolete since this module is only here for upgrading+-- the legacy rebase format where the rebase patch was mixed in with regular+-- patches.+data ReadRebasing p wX wY where+  ReadNormal    :: p wX wY -> ReadRebasing p wX wY+  ReadSuspended :: Suspended p wX -> ReadRebasing p wX wX++instance RepoPatch p => ReadPatch (WrappedNamed p) where+  readPatch' = fmap (mapSeal wrapNamed) readPatch' where++    wrapNamed :: Named (ReadRebasing p) wX wY -> WrappedNamed p wX wY+    wrapNamed (NamedP i [] (ReadSuspended s :>: NilFL)) = RebaseP i s+    wrapNamed (NamedP i deps ps) = NormalP (NamedP i deps (mapFL_FL unRead ps))++    unRead (ReadNormal p) = p+    unRead (ReadSuspended _) = error "unexpected suspended patch"++instance PatchListFormat p => PatchListFormat (ReadRebasing p) where+  patchListFormat = coerce (patchListFormat :: ListFormat p)++instance RepoPatch p => ReadPatch (ReadRebasing p) where+  readPatch' =+    Sealed . ReadSuspended <$> readSuspended <|> mapSeal ReadNormal <$> readPatch'
+ src/Darcs/Patch/Rebase/Name.hs view
@@ -0,0 +1,216 @@+--  Copyright (C) 2011-2 Ganesh Sittampalam+--+--  BSD3++module Darcs.Patch.Rebase.Name+    ( RebaseName(..)+    , commuteNamePrim, commutePrimName+    , commuterIdNamed, commuterNamedId+    , commuteNameNamed, commuteNamedName+    , pushFixupName+    ) where++import Darcs.Prelude++import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.CommuteFn ( CommuteFn, commuterIdFL, commuterFLId )+import Darcs.Patch.Info ( PatchInfo, showPatchInfo, readPatchInfo )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Named ( Named(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )++import Darcs.Patch.Rebase.PushFixup ( PushFixupFn )++import Darcs.Util.Parser ( lexString )+import Darcs.Util.Printer ( empty, blueText, ($$) )++import Control.Applicative ( (<|>) )+import qualified Data.ByteString.Char8 as BC ( pack )++-- Note: in principle this is a general concept not limited to+-- rebase, and we might be able to generalise this type and+-- refactor named patches to use it too.++-- | A 'RebaseName' encapsulates the concept of the name of a patch,+-- without any contents. This allows us to track explicit dependencies+-- in the rebase state, changing them to follow uses of amend-record+-- or unsuspend on a depended-on patch, and warning the user if any+-- are lost entirely.+data RebaseName wX wY where+  AddName :: PatchInfo -> RebaseName wX wY+  DelName :: PatchInfo -> RebaseName wX wY+  Rename :: PatchInfo -> PatchInfo -> RebaseName wX wY+    deriving (Eq, Show)++instance Show1 (RebaseName wX)++instance Show2 RebaseName++instance ShowPatchBasic RebaseName where+   showPatch f (AddName n) = blueText "addname" $$ showPatchInfo f n+   showPatch f (DelName n) = blueText "delname" $$ showPatchInfo f n+   showPatch f (Rename old new) = blueText "rename" $$ showPatchInfo f old $$ showPatchInfo f new++instance ShowPatch RebaseName where+   summary _ = empty -- TODO improve this?+   summaryFL _ = empty++instance ReadPatch RebaseName where+   readPatch' = readAddName <|> readDelName <|> readRename+     where+       readAddName = do lexString (BC.pack "addname")+                        n <- readPatchInfo+                        return (Sealed (AddName n))+       readDelName = do lexString (BC.pack "delname")+                        n <- readPatchInfo+                        return (Sealed (DelName n))+       readRename  = do lexString (BC.pack "rename")+                        old <- readPatchInfo+                        new <- readPatchInfo+                        return (Sealed (Rename old new))++instance Commute RebaseName where+   commute (AddName n1 :> AddName n2)+      | n1 == n2 = error "impossible case"+      | otherwise = Just (AddName n2 :> AddName n1)+   commute (DelName n1 :> DelName n2)+      | n1 == n2 = error "impossible case"+      | otherwise = Just (DelName n2 :> DelName n1)+   commute (AddName n1 :> DelName n2)+      | n1 /= n2 = Just (DelName n2 :> AddName n1)+      | otherwise = Nothing+   commute (DelName n1 :> AddName n2)+      | n1 /= n2 = Just (AddName n2 :> DelName n1)+      | otherwise = Nothing+   commute (Rename old new :> AddName n)+      | n == old = Nothing+      | n == new = error "impossible case" -- precondition of Add is that n doesn't exist+      | otherwise = Just (AddName n :> Rename old new)+   commute (AddName n :> Rename old new)+      | n == old = Nothing+      | n == new = error "impossible case" -- precondition of Rename is that new doesn't exist+      | otherwise = Just (Rename old new :> AddName n)+   commute (Rename old new :> DelName n)+      | n == old = error "impossible case" -- precondition of Del is that n does exist+      | n == new = Nothing+      | otherwise = Just (DelName n :> Rename old new)+   commute (DelName n :> Rename old new)+      | n == old = error "impossible case" -- precondition of Rename is that old does exist+      | n == new = Nothing+      | otherwise = Just (Rename old new :> DelName n)+   commute (Rename old1 new1 :> Rename old2 new2)+      | old1 == old2 = error "impossible case"+      | new1 == new2 = error "impossible case"+      | old1 == new2 = Nothing+      | new1 == old2 = Nothing+      | otherwise = Just (Rename old2 new2 :> Rename old1 new1)++instance Invert RebaseName where+   invert (AddName n) = DelName n+   invert (DelName n) = AddName n+   invert (Rename old new) = Rename new old++instance PatchInspect RebaseName where+    listTouchedFiles _ = []+    hunkMatches _ _ = False++instance Eq2 RebaseName where+   p1 =\/= p2+      | p1 == unsafeCoercePEnd p2 = unsafeCoercePEnd IsEq+      | otherwise = NotEq++-- |Commute a 'RebaseName' and a primitive patch. They trivially+-- commute so this just involves changing the witnesses.+-- This is unsafe if the patch being commuted actually has a+-- name (e.g. Named or PatchInfo - PrimWithName is ok),+commuteNamePrim :: (RebaseName :> prim) wX wY -> (prim :> RebaseName) wX wY+commuteNamePrim (n :> f) = unsafeCoerceP f :> unsafeCoerceP n++-- |Commute a primitive patch and a 'RebaseName'. They trivially+-- commute so this just involves changing the witnesses.+-- This is unsafe if the patch being commuted actually has a+-- name (e.g. Named or PatchInfo - PrimWithName is ok),+commutePrimName :: (prim :> RebaseName) wX wY -> (RebaseName :> prim) wX wY+commutePrimName (f :> n) = unsafeCoerceP n :> unsafeCoerceP f++-- commuterIdNamed and commuterNamedId are defined here rather than in+-- Named given that they are unsafe, to reduce the chances of them+-- being used inappropriately.++-- |Commute an unnamed patch with a named patch. This is unsafe if the+-- second patch actually does have a name (e.g. Named, PatchInfoAnd, etc),+-- as it won't check the explicit dependencies.+commuterIdNamed :: CommuteFn p1 p2 -> CommuteFn p1 (Named p2)+commuterIdNamed commuter (p1 :> NamedP n2 d2 p2) =+   do p2' :> p1' <- commuterIdFL commuter (p1 :> p2)+      return (NamedP n2 d2 p2' :> p1')++-- |Commute an unnamed patch with a named patch. This is unsafe if the+-- first patch actually does have a name (e.g. Named, PatchInfoAnd, etc),+-- as it won't check the explicit dependencies.+commuterNamedId :: CommuteFn p1 p2 -> CommuteFn (Named p1) p2+commuterNamedId commuter (NamedP n1 d1 p1 :> p2) =+   do p2' :> p1' <- commuterFLId commuter (p1 :> p2)+      return (p2' :> NamedP n1 d1 p1')++-- |Commute a name patch and a named patch. In most cases this is+-- trivial but we do need to check explicit dependencies.+commuteNameNamed :: CommuteFn RebaseName (Named p)+commuteNameNamed (AddName an :> p@(NamedP pn deps _))+  | an == pn = error "impossible case"+  | an `elem` deps = Nothing+  | otherwise = Just (unsafeCoerceP p :> AddName an)+commuteNameNamed (DelName dn :> p@(NamedP pn deps _))+  -- this case can arise if a patch is suspended then a fresh copy is pulled from another repo+  | dn == pn = Nothing+  | dn `elem` deps = error "impossible case"+  | otherwise = Just (unsafeCoerceP p :> DelName dn)+commuteNameNamed (Rename old new :> NamedP pn deps body)+  | old == pn = error "impossible case"+  | new == pn = error "impossible case"+  | old `elem` deps = error "impossible case"+  | otherwise =+      let newdeps = map (\dep -> if new == dep then old else dep) deps+      in Just (NamedP pn newdeps (unsafeCoerceP body) :> Rename old new)++-- |Commute a named patch and a name patch. In most cases this is+-- trivial but we do need to check explicit dependencies.+commuteNamedName :: CommuteFn (Named p) RebaseName+commuteNamedName (p@(NamedP pn deps _) :> AddName an)+  | an == pn = error "impossible case"  -- the NamedP introduces pn, then AddName introduces it again+  | an `elem` deps = error "impossible case" -- the NamedP depends on an before it is introduced+  | otherwise = Just (AddName an :> unsafeCoerceP p)+commuteNamedName (p@(NamedP pn deps _) :> DelName dn)+  | dn == pn = Nothing+  | dn `elem` deps = Nothing+  | otherwise = Just (DelName dn :> unsafeCoerceP p)+commuteNamedName (NamedP pn deps body :> Rename old new)+  | old == pn = Nothing+  | new == pn = error "impossible case"+  | new `elem` deps = error "impossible case"+  | otherwise =+      let newdeps = map (\dep -> if old == dep then new else dep) deps+      in Just (Rename old new :> NamedP pn newdeps (unsafeCoerceP body))++canonizeNamePair :: (RebaseName :> RebaseName) wX wY -> FL RebaseName wX wY+canonizeNamePair (AddName n :> Rename old new) | n == old = AddName new :>: NilFL+canonizeNamePair (Rename old new :> DelName n) | n == new = DelName old :>: NilFL+canonizeNamePair (Rename old1 new1 :> Rename old2 new2) | new1 == old2 = Rename old1 new2 :>: NilFL+canonizeNamePair (n1 :> n2) = n1 :>: n2 :>: NilFL++pushFixupName :: PushFixupFn RebaseName RebaseName (FL RebaseName) (Maybe2 RebaseName)+pushFixupName (n1 :> n2)+ | IsEq <- isInverse = NilFL :> Nothing2+ | otherwise+   = case commute (n1 :> n2) of+       Nothing -> (canonizeNamePair (n1 :> n2)) :> Nothing2+       Just (n2' :> n1') -> (n2' :>: NilFL) :> Just2 n1'+  where isInverse = invert n1 =\/= n2
+ src/Darcs/Patch/Rebase/PushFixup.hs view
@@ -0,0 +1,108 @@+module Darcs.Patch.Rebase.PushFixup+  ( PushFixupFn, dropFixups+  , pushFixupFLFL_FLFLFL+  , pushFixupFLFL_FLFLFLFL+  , pushFixupFLMB_FLFLMB+  , pushFixupIdFL_FLFLFL+  , pushFixupIdMB_FLFLMB+  , pushFixupIdMB_FLIdFLFL+  ) where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Ordered+  ( (:>)(..), FL(..), (+>+)+  )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )++-- | During a rebase, we use "fixup" patches to maintain the correct+-- context for the real "items" that are being stored in the rebase+-- that the user wants to keep. As the context of the rebase changes,+-- new fixups get added to the beginning that then need to be pushed+-- past as many items as possible.+--+-- There are multiple fixup types and multiple ways of representing+-- the items being stored in the rebase, so this is polymorphic in+-- both types. Also, the structure of the results varies - in some+-- cases it will be a single value, sometimes an FL, or sometimes+-- zero or one values (Maybe2), so the output types are separate+-- variables. A typical instantiation would be something like+-- PushFixupFn Fixup Item (FL Item) (FL Fixup).+type PushFixupFn fixupIn itemIn itemOut fixupOut+  =  forall wX wY+  .  (fixupIn :> itemIn  ) wX wY+  -> (itemOut :> fixupOut) wX wY++dropFixups :: (item :> fixup) wX wY -> Sealed (item wX)+dropFixups (item :> _) = Sealed item++{-+The collection below of pushFixup combinators is quite annoying, but+there's no obvious generalisation, and inlining them at each use site+would be even worse.+-}++pushFixupFLFL_FLFLFL+  :: PushFixupFn fixup     item  (FL item) (FL fixup)+  -> PushFixupFn fixup (FL item) (FL item) (FL fixup)+pushFixupFLFL_FLFLFL _pushOne (fixup :> NilFL)+  = NilFL :> (fixup :>: NilFL)+pushFixupFLFL_FLFLFL pushOne (fixup :> (item1 :>: items2))+  = case pushOne (fixup :> item1) of+      items1' :> fixups' ->+        case pushFixupFLFL_FLFLFLFL pushOne (fixups' :> items2) of+          items2' :> fixups'' -> (items1' +>+ items2') :> fixups''++pushFixupFLFL_FLFLFLFL+  :: PushFixupFn     fixup      item  (FL item) (FL fixup)+  -> PushFixupFn (FL fixup) (FL item) (FL item) (FL fixup)+pushFixupFLFL_FLFLFLFL _pushOne (NilFL :> items)+  = items :> NilFL+pushFixupFLFL_FLFLFLFL pushOne ((fixup1 :>: fixups2) :> items)+  = case pushFixupFLFL_FLFLFLFL pushOne (fixups2 :> items) of+      items' :> fixups2' ->+        case pushFixupFLFL_FLFLFL pushOne (fixup1 :> items') of+          items'' :> fixups1' -> items'' :> (fixups1' +>+ fixups2')++pushFixupFLMB_FLFLMB+  :: PushFixupFn fixup     item  (FL item) (Maybe2 fixup)+  -> PushFixupFn fixup (FL item) (FL item) (Maybe2 fixup)+pushFixupFLMB_FLFLMB _pushOne (fixup :> NilFL)+  = NilFL :> Just2 fixup+pushFixupFLMB_FLFLMB pushOne (fixup :> (item1 :>: items2))+  = case pushOne (fixup :> item1) of+      items1' :> Nothing2 -> items1' +>+ items2 :> Nothing2+      items1' :> Just2 fixup' ->+        case pushFixupFLMB_FLFLMB pushOne (fixup' :> items2) of+          items2' :> fixup'' -> items1' +>+ items2' :> fixup''++pushFixupIdFL_FLFLFL+  :: PushFixupFn fixup     item      item  (FL fixup)+  -> PushFixupFn fixup (FL item) (FL item) (FL fixup)+pushFixupIdFL_FLFLFL pushOne+  = pushFixupFLFL_FLFLFL (mkList . pushOne)+  where+    mkList :: (item :> FL fixup) wX wY -> (FL item :> FL fixup) wX wY+    mkList (item :> fixups) = (item :>: NilFL) :> fixups++pushFixupIdMB_FLFLMB+  :: PushFixupFn fixup     item      item  (Maybe2 fixup)+  -> PushFixupFn fixup (FL item) (FL item) (Maybe2 fixup)+pushFixupIdMB_FLFLMB pushOne+  = pushFixupFLMB_FLFLMB (mkList . pushOne)+  where+    mkList :: (item :> Maybe2 fixup) wX wY -> (FL item :> Maybe2 fixup) wX wY+    mkList (item :> fixups) = (item :>: NilFL) :> fixups++pushFixupIdMB_FLIdFLFL+  :: PushFixupFn     fixup  item     item (Maybe2 fixup)+  -> PushFixupFn (FL fixup) item     item (FL     fixup)+pushFixupIdMB_FLIdFLFL _pushOne (NilFL :> item)+  = item :> NilFL+pushFixupIdMB_FLIdFLFL pushOne ((fixup :>: fixups) :> item)+  = case pushFixupIdMB_FLIdFLFL pushOne (fixups :> item) of+      item' :> fixups2' ->+        case pushOne (fixup :> item') of+          item'' :> Nothing2      -> item'' :>             fixups2'+          item'' :> Just2 fixup1' -> item'' :> fixup1' :>: fixups2'
+ src/Darcs/Patch/Rebase/Suspended.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.Rebase.Suspended+    ( Suspended(..)+    , countToEdit, simplifyPush, simplifyPushes+    , addFixupsToSuspended, removeFixupsFromSuspended+    , addToEditsToSuspended+    , readSuspended+    , showSuspended+    ) where++import Darcs.Prelude++import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.Invert ( invert )+import Darcs.Patch.Named ( Named(..) )+import Darcs.Patch.Info ( replaceJunk )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )+import Darcs.Patch.Read ( bracketedFL )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..), namedToFixups )+import Darcs.Patch.Rebase.Name ( RebaseName(..) )+import Darcs.Patch.RepoPatch ( RepoPatch )+import qualified Darcs.Patch.Rebase.Change as Change ( simplifyPush, simplifyPushes )+import Darcs.Patch.Rebase.Change ( RebaseChange(..), addNamedToRebase )+import Darcs.Patch.Rebase.Legacy.Item as Item ( toRebaseChanges )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor )+import Darcs.Util.Parser ( Parser, lexString, lexWord )+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show ( Show2 )+import Darcs.Util.Printer ( Doc, vcat, text, blueText, ($$), (<+>) )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm(MyersDiff) )++import Control.Applicative ( (<|>) )+import qualified Data.ByteString.Char8 as BC ( pack )++-- | A @Suspended@ patch contains the entire rebase state, in the form+-- of 'RebaseChange's. The end state is existientially quantified and+-- thus hidden.+data Suspended p wX where+    Items :: FL (RebaseChange (PrimOf p)) wX wY -> Suspended p wX++deriving instance (Show2 p, Show2 (PrimOf p)) => Show (Suspended p wX)++showSuspended :: PrimPatchBase p+              => ShowPatchFor -> Suspended p wX -> Doc+showSuspended f (Items ps)+       = blueText "rebase" <+> text "0.2" <+> blueText "{"+         $$ vcat (mapFL (showPatch f) ps)+         $$ blueText "}"++readSuspended :: forall p wX. RepoPatch p => Parser (Suspended p wX)+readSuspended =+    do lexString (BC.pack "rebase")+       version <- lexWord+       case () of+         _ | version == BC.pack "0.2" ->+              (lexString (BC.pack "{}") >> return (Items NilFL))+              <|>+              (unseal Items <$> bracketedFL readPatch' '{' '}')+           -- version 0.1 was a very temporary intermediate state on the way to 0.2+           -- and we don't offer an upgrade path for it.+           | version == BC.pack "0.0" ->+               -- Note that if we have an "old-style" rebase, i.e. the first+               -- rebase implementation in darcs, characterised by the format+               -- string "rebase-in-progress", then only version 0.0 is+               -- possible here. On the other hand, the more recent+               -- implementation could use any version including 0.0.+               -- Unlike version 0.2, version 0.0 rebase patches on disk can+               -- contain conflicts. These are removed when reading by+               -- Item.toRebaseChanges, which ultimately calls 'fullUnwind',+               -- the same machinery that is used when version 0.2 patches are+               -- created from scratch.+               (lexString (BC.pack "{}") >> return (Items NilFL))+               <|>+               (unseal Items . unseal (Item.toRebaseChanges @p) <$>+                bracketedFL readPatch' '{' '}')+           | otherwise -> error $ "can't handle rebase version " ++ show version++countToEdit :: Suspended p wX -> Int+countToEdit (Items ps) = lengthFL ps++-- |add fixups for the name and effect of a patch to a 'Suspended'+addFixupsToSuspended+  :: (PrimPatchBase p, Effect p)+  => Named p wX wY+  -> Suspended p wY+  -> Suspended p wX+addFixupsToSuspended p = simplifyPushes D.MyersDiff (namedToFixups p)++-- | Remove fixups (actually, add their inverse) for the name and effect of+-- a patch to a 'Suspended'.+removeFixupsFromSuspended+  :: (PrimPatchBase p, Effect p)+  => Named p wX wY+  -> Suspended p wX+  -> Suspended p wY+removeFixupsFromSuspended p =+  simplifyPushes D.MyersDiff (invert (namedToFixups p))++-- | Add 'Named' patches for editing to a 'Suspended'. The patches to be+-- suspended are renamed by replacing the junk in their 'Patchinfo'.+--+-- The reason we rename patches immediately when suspending them is that+-- the user may pull an identical copy from a clone, Which means we have+-- the same patch name twice, once in the normal repo and once suspended.+-- Furthermore, they can again suspend that copy, leaving us with multiple+-- copies of the same patch in the rebase state. This is bad because it+-- invalidates most of the invariants for RebaseName fixups. See issue2445+-- and tests/rebase-repull.sh for examples which lead to crashes when we+-- don't do the renaming here.+addToEditsToSuspended+  :: RepoPatch p+  => D.DiffAlgorithm+  -> FL (Named p) wX wY+  -> Suspended p wY+  -> IO (Suspended p wX)+addToEditsToSuspended _ NilFL items = return items+addToEditsToSuspended da (NamedP old ds ps :>: qs) items = do+  Items items' <- addToEditsToSuspended da qs items+  new <- replaceJunk old+  return $+    unseal Items $+    unseal (addNamedToRebase da (NamedP new ds ps)) $+    Change.simplifyPush da (NameFixup (Rename new old)) items'++simplifyPush+  :: PrimPatchBase p+  => D.DiffAlgorithm+  -> RebaseFixup (PrimOf p) wX wY+  -> Suspended p wY+  -> Suspended p wX+simplifyPush da fixups (Items ps) =+  unseal Items (Change.simplifyPush da fixups ps)++simplifyPushes+  :: PrimPatchBase p+  => D.DiffAlgorithm+  -> FL (RebaseFixup (PrimOf p)) wX wY+  -> Suspended p wY+  -> Suspended p wX+simplifyPushes da fixups (Items ps) =+  unseal Items (Change.simplifyPushes da fixups ps)
src/Darcs/Patch/RegChars.hs view
@@ -19,10 +19,12 @@ module Darcs.Patch.RegChars ( regChars,                 ) where -(&&&) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+import Darcs.Prelude++(&&&) :: (a -> Bool) -> (a -> Bool) -> a -> Bool (&&&) a b c = a c && b c -(|||) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+(|||) :: (a -> Bool) -> (a -> Bool) -> a -> Bool (|||) a b c = a c || b c  {-# INLINE regChars #-}@@ -38,7 +40,7 @@ -- if it is not escaped, but the default 'filename_toks' in -- Darcs.Commands.Replace uses an escaped dot (WHY?). -regChars :: String -> (Char -> Bool)+regChars :: String -> Char -> Bool regChars ('^':cs) = not . normalRegChars (unescapeChars cs) regChars ('\\':'^':cs) = normalRegChars $ unescapeChars $ '^':cs regChars cs = normalRegChars $ unescapeChars cs@@ -63,7 +65,7 @@ -- chars, and also unescaping of escaped special chars. If a non-special -- char is still escaped by now we get a failure. -normalRegChars :: String -> (Char -> Bool)+normalRegChars :: String -> Char -> Bool normalRegChars ('\\':'.':cs) = (=='.') ||| normalRegChars cs normalRegChars ('\\':'-':cs) = (=='-') ||| normalRegChars cs normalRegChars ('\\':'\\':cs) = (=='\\') ||| normalRegChars cs
src/Darcs/Patch/Repair.hs view
@@ -2,31 +2,34 @@     ( Repair(..), RepairToFL(..), mapMaybeSnd, Check(..) )     where +import Darcs.Prelude+ import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.ApplyMonad ( ApplyMonad )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), mapFL, mapRL, (+>+) )-import Printer ( Doc )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), mapFL, mapRL, (+>+) )+import Darcs.Util.Printer ( Doc )  import Data.Maybe ( catMaybes, listToMaybe ) -#include "gadts.h"  class Check p where-    isInconsistent :: p C(x y) -> Maybe Doc+    isInconsistent :: p wX wY -> Maybe Doc     isInconsistent _ = Nothing --- |'Repair' and 'RepairToFL' deal with repairing old patches that were--- were written out due to bugs or that we no longer wish to support.--- 'Repair' is implemented by collections of patches (FL, Named, PatchInfoAnd) that--- might need repairing.+-- |'Repair' and 'RepairToFL' deal with repairing old patches that were were+-- written out due to bugs or that we no longer wish to support. 'Repair' is+-- implemented by collections of patches (FL, Named, PatchInfoAnd) that might+-- need repairing. class Repair p where-    applyAndTryToFix :: ApplyMonad m (ApplyState p) => p C(x y) -> m (Maybe (String, p C(x y)))+    applyAndTryToFix+      :: ApplyMonad (ApplyState p) m => p wX wY -> m (Maybe (String, p wX wY)) --- |'RepairToFL' is implemented by single patches that can be repaired (Prim, Patch, RealPatch)--- There is a default so that patch types with no current legacy problems don't need to--- have an implementation.+-- |'RepairToFL' is implemented by single patches that can be repaired (Prim,+-- Patch, RepoPatchV2) There is a default so that patch types with no current+-- legacy problems don't need to have an implementation. class Apply p => RepairToFL p where-    applyAndTryToFixFL :: ApplyMonad m (ApplyState p) => p C(x y) -> m (Maybe (String, FL p C(x y)))+    applyAndTryToFixFL+      :: ApplyMonad (ApplyState p) m => p wX wY -> m (Maybe (String, FL p wX wY))     applyAndTryToFixFL p = do apply p; return Nothing  mapMaybeSnd :: (a -> b) -> Maybe (c, a) -> Maybe (c, b)@@ -41,12 +44,13 @@  instance RepairToFL p => Repair (FL p) where     applyAndTryToFix NilFL = return Nothing-    applyAndTryToFix (p:>:ps) = do mp <- applyAndTryToFixFL p-                                   mps <- applyAndTryToFix ps-                                   return $ case (mp,mps) of-                                            (Nothing, Nothing) -> Nothing-                                            (Just (e,p'),Nothing) -> Just (e,p'+>+ps)-                                            (Nothing, Just (e,ps')) -> Just (e,p:>:ps')-                                            (Just (e,p'), Just (es,ps')) ->-                                                Just (unlines [e,es], p'+>+ps')+    applyAndTryToFix (p :>: ps) = do+      mp <- applyAndTryToFixFL p+      mps <- applyAndTryToFix ps+      return $+        case (mp, mps) of+          (Nothing, Nothing) -> Nothing+          (Just (e, p'), Nothing) -> Just (e, p' +>+ ps)+          (Nothing, Just (e, ps')) -> Just (e, p :>: ps')+          (Just (e, p'), Just (es, ps')) -> Just (e ++ "\n" ++ es, p' +>+ ps')
src/Darcs/Patch/RepoPatch.hs view
@@ -1,18 +1,66 @@-module Darcs.Patch.RepoPatch ( RepoPatch ) where--import Darcs.Patch.Conflict ( Conflict, CommuteNoConflicts )-import Darcs.Patch.Effect ( Effect )-import Darcs.Patch.FileHunk ( IsHunk )-import Darcs.Patch.Format ( PatchListFormat )-import Darcs.Patch.Merge ( Merge )-import Darcs.Patch.Patchy ( Patchy )-import Darcs.Patch.Patchy.Instances ()-import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, FromPrim )-import Darcs.Patch.Repair ( RepairToFL, Check )+module Darcs.Patch.RepoPatch+    ( RepoPatch+    , AnnotateRP+    , Apply(..)+    , Check(..)+    , Commute(..)+    , Conflict(..)+    , Effect(..)+    , Eq2(..)+    , FromPrim(..)+    , IsHunk(..)+    , Merge(..)+    , PatchInspect(..)+    , PatchListFormat(..)+    , PrimPatchBase(..)+    , ReadPatch(..)+    , RepairToFL(..)+    , ShowContextPatch(..)+    , ShowPatch(..)+    , ShowPatchBasic(..)+    , Summary(..)+    , ToPrim(..)+    , Unwind(..)+    ) where -class (Patchy p, Merge p, Effect p, IsHunk p, FromPrim p, Conflict p, CommuteNoConflicts p,-       Check p, RepairToFL p, PatchListFormat p,-       PrimPatchBase p, Patchy (PrimOf p), IsHunk (PrimOf p)-      )-    => RepoPatch p+import Darcs.Patch.Annotate ( AnnotateRP )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Conflict ( Conflict(..) )+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.FromPrim ( PrimPatchBase(..), PrimOf(..), FromPrim(..), ToPrim(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Merge ( Merge(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Repair ( RepairToFL(..), Check(..) )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), ShowContextPatch(..) )+import Darcs.Patch.Summary ( Summary(..) )+import Darcs.Patch.Unwind ( Unwind(..) )+import Darcs.Patch.Witnesses.Eq ( Eq2(..) ) +type RepoPatch p =+    ( AnnotateRP p+    , Apply p+    , ApplyState p ~ ApplyState (PrimOf p)+    , Check p+    , Commute p+    , Conflict p+    , Effect p+    , Eq2 p+    , FromPrim p+    , IsHunk p+    , IsHunk (PrimOf p)+    , Merge p+    , PatchInspect p+    , PatchListFormat p+    , PrimPatchBase p+    , ReadPatch p+    , RepairToFL p+    , ShowContextPatch p+    , ShowPatch p+    , Summary p+    , ToPrim p+    , Unwind p+    )
src/Darcs/Patch/Set.hs view
@@ -15,62 +15,154 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, EmptyDataDecls #-}--#include "gadts.h"+module Darcs.Patch.Set+    ( PatchSet(..)+    , Tagged(..)+    , SealedPatchSet+    , Origin+    , progressPatchSet+    , patchSetInventoryHashes+    , patchSetTags+    , emptyPatchSet+    , appendPSFL+    , patchSet2RL+    , patchSet2FL+    , inOrderTags+    , patchSetSnoc+    , patchSetSplit+    , patchSetDrop+    ) where -module Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin,-                         progressPatchSet, tags, appendPSFL,-                         newset2RL, newset2FL ) where+import Darcs.Prelude+import Data.Maybe ( catMaybes )+import qualified Data.Set as S -import Progress ( progress )-import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Ident ( Ident(..), PatchId )+import Darcs.Patch.Info ( PatchInfo, piTag ) import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )-import Darcs.Witnesses.Ordered ( FL, RL(..), (+<+), reverseFL,-                                 reverseRL, mapRL_RL, concatRL, mapRL )-import Darcs.Witnesses.Sealed ( Sealed )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Ordered+    ( FL, RL(..), (+<+), (+<<+), (:>)(..), reverseRL,+    mapRL_RL, concatRL, mapRL )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 ) +import Darcs.Util.Progress ( progress )+import Darcs.Util.ValidHash ( InventoryHash )++-- |'Origin' is a type used to represent the initial context of a repo. data Origin -type SealedPatchSet p C(start) = Sealed ((PatchSet p) C(start))+type SealedPatchSet p wStart = Sealed ((PatchSet p) wStart) --- A PatchSet is a list of patches since the last tag, and a list of tagged--- patch lists that form a repo's history.-data PatchSet p C(start y) where-    PatchSet :: RL (PatchInfoAnd p) C(x y) -> RL (Tagged p) C(start x) -> PatchSet p C(start y)+-- |The patches in a repository are stored in chunks broken up at \"clean\"+-- tags. A tag is clean if the only patches before it in the current+-- repository ordering are ones that the tag depends on (either directly+-- or indirectly). Each chunk is stored in a separate inventory file on disk.+--+-- A 'PatchSet' represents a repo's history as the list of patches since the+-- last clean tag, and then a list of patch lists each delimited by clean tags.+--+-- Because the invariants about clean tags can only be maintained if a+-- 'PatchSet' contains the whole history, the first witness is always forced+-- to be 'Origin'. The type still has two witnesses so it can easily be used+-- with combinators like ':>' and 'Fork'.+--+-- The history is lazily loaded from disk so does not normally need to be all+-- kept in memory.+data PatchSet p wStart wY where+    PatchSet :: RL (Tagged p) Origin wX -> RL (PatchInfoAnd p) wX wY+             -> PatchSet p Origin wY --- A Tagged is a Tag, the hash of the 'previous' inventory (if it exists) and--- the list of patches since that previous inventory.-data Tagged p C(x z) where-    Tagged :: PatchInfoAnd p C(y z) -> Maybe String-           -> RL (PatchInfoAnd p) C(x y) -> Tagged p C(x z)+deriving instance Show2 p => Show (PatchSet p wStart wY) --- |newset2RL takes a PatchSet and returns an equivalent, linear RL of patches.-newset2RL :: PatchSet p C(start x) -> RL (PatchInfoAnd p) C(start x)-newset2RL (PatchSet ps ts) = ps +<+ concatRL (mapRL_RL ts2rl ts)-    where ts2rl :: Tagged p C(y z) -> RL (PatchInfoAnd p) C(y z)-          ts2rl (Tagged t _ ps2) = t :<: ps2+instance Show2 p => Show1 (PatchSet p wStart) --- |newset2FL takes a PatchSet and returns an equivalent, linear FL of patches.-newset2FL :: PatchSet p C(start x) -> FL (PatchInfoAnd p) C(start x)-newset2FL = reverseRL . newset2RL+instance Show2 p => Show2 (PatchSet p) --- |appendPSFL takes a PatchSet and a FL of patches that 'follow' the PatchSet,--- and concatenates the patches into the PatchSet.-appendPSFL :: PatchSet p C(start x) -> FL (PatchInfoAnd p) C(x y)-           -> PatchSet p C(start y)-appendPSFL (PatchSet ps ts) newps = PatchSet (reverseFL newps +<+ ps) ts+type instance PatchId (PatchSet p) = S.Set PatchInfo +instance Ident (PatchSet p) where+  ident = S.fromList . mapRL ident . patchSet2RL++emptyPatchSet :: PatchSet p Origin Origin+emptyPatchSet = PatchSet NilRL NilRL++-- |A 'Tagged' is a single chunk of a 'PatchSet'.+-- It has a 'PatchInfo' representing a clean tag,+-- the hash of the previous inventory (if it exists),+-- and the list of patches since that previous inventory.+data Tagged p wX wZ where+    Tagged :: RL (PatchInfoAnd p) wX wY -> PatchInfoAnd p wY wZ -> Maybe InventoryHash+           -> Tagged p wX wZ++deriving instance Show2 p => Show (Tagged p wX wZ)++instance Show2 p => Show1 (Tagged p wX)++instance Show2 p => Show2 (Tagged p)+++-- |'patchSet2RL' takes a 'PatchSet' and returns an equivalent, linear 'RL' of+-- patches.+patchSet2RL :: PatchSet p wStart wX -> RL (PatchInfoAnd p) wStart wX+patchSet2RL (PatchSet ts ps) = concatRL (mapRL_RL ts2rl ts) +<+ ps+  where+    ts2rl :: Tagged p wY wZ -> RL (PatchInfoAnd p) wY wZ+    ts2rl (Tagged ps2 t _) = ps2 :<: t++-- |'patchSet2FL' takes a 'PatchSet' and returns an equivalent, linear 'FL' of+-- patches.+patchSet2FL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wStart wX+patchSet2FL = reverseRL . patchSet2RL++-- |'appendPSFL' takes a 'PatchSet' and a 'FL' of patches that "follow" the+-- PatchSet, and concatenates the patches into the PatchSet.+appendPSFL :: PatchSet p wStart wX -> FL (PatchInfoAnd p) wX wY+           -> PatchSet p wStart wY+appendPSFL (PatchSet ts ps) newps = PatchSet ts (ps +<<+ newps)+ -- |Runs a progress action for each tag and patch in a given PatchSet, using -- the passed progress message. Does not alter the PatchSet.-progressPatchSet :: String -> PatchSet p C(start x) -> PatchSet p C(start x)-progressPatchSet k (PatchSet ps0 ts0) = PatchSet (mapRL_RL prog ps0) $ mapRL_RL pts ts0-    where prog = progress k-          pts :: Tagged p C(y z) -> Tagged p C(y z)-          pts (Tagged t h ps) = Tagged (prog t) h (mapRL_RL prog ps)+progressPatchSet :: String -> PatchSet p wStart wX -> PatchSet p wStart wX+progressPatchSet k (PatchSet ts ps) =+    PatchSet (mapRL_RL progressTagged ts) (mapRL_RL prog ps)+  where+    prog = progress k --- |tags returns the PatchInfos corresponding to the tags of a given PatchSet.-tags :: PatchSet p C(start x) -> [PatchInfo]-tags (PatchSet _ ts) = mapRL f ts-    where f :: Tagged p C(y z) -> PatchInfo-          f (Tagged t _ _) = info t+    progressTagged :: Tagged p wY wZ -> Tagged p wY wZ+    progressTagged (Tagged tps t h) = Tagged (mapRL_RL prog tps) (prog t) h++patchSetInventoryHashes :: PatchSet p wX wY -> [Maybe InventoryHash]+patchSetInventoryHashes (PatchSet ts _) = mapRL (\(Tagged _ _ mh) -> mh) ts++-- | The tag names of /all/ tags of a given 'PatchSet'.+patchSetTags :: PatchSet p wX wY -> [String]+patchSetTags = catMaybes . mapRL (piTag . info) . patchSet2RL++inOrderTags :: PatchSet p wS wX -> [PatchInfo]+inOrderTags (PatchSet ts _) = go ts+  where go :: RL(Tagged t1) wT wY -> [PatchInfo]+        go (ts' :<: Tagged _ t _) = info t : go ts'+        go NilRL = []++patchSetSnoc :: PatchSet p wX wY -> PatchInfoAnd p wY wZ -> PatchSet p wX wZ+patchSetSnoc (PatchSet ts ps) p = PatchSet ts (ps :<: p)++-- | Split a 'PatchSet' /before/ the latest known clean tag. The left part+-- is what comes before the tag, the right part is the tag and its+-- non-dependencies.+patchSetSplit :: PatchSet p wX wY+              -> (PatchSet p :> RL (PatchInfoAnd p)) wX wY+patchSetSplit (PatchSet (ts :<: Tagged ps' t _) ps) =+  PatchSet ts ps' :> ((NilRL :<: t) +<+ ps)+patchSetSplit (PatchSet NilRL ps) = PatchSet NilRL NilRL :> ps++-- | Drop the last @n@ patches from the given 'PatchSet'.+patchSetDrop :: Int+             -> PatchSet p wStart wX+             -> SealedPatchSet p wStart+patchSetDrop n ps | n <= 0 = Sealed ps+patchSetDrop n (PatchSet (ts :<: Tagged ps t _) NilRL) =+  patchSetDrop n $ PatchSet ts (ps :<: t)+patchSetDrop _ (PatchSet NilRL NilRL) = Sealed $ PatchSet NilRL NilRL+patchSetDrop n (PatchSet ts (ps :<: _)) = patchSetDrop (n - 1) $ PatchSet ts ps
src/Darcs/Patch/Show.hs view
@@ -15,67 +15,80 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}- module Darcs.Patch.Show-     ( ShowPatchBasic(..), ShowPatch(..)-     , showNamedPrefix-     , writePatch, gzWritePatch+     ( ShowPatchBasic(..)+     , displayPatch+     , ShowPatchFor(..)+     , ShowPatch(..)+     , ShowContextPatch(..)+     , showPatchWithContext      , formatFileName-     )-    where--import Prelude hiding ( pi )+     ) where -import Darcs.Lock ( writeDocBinFile, gzWriteDocFile )-import Darcs.Patch.FileName ( FileName, fn2ps, encodeWhite, fn2fp )-import Darcs.Patch.Format ( FileNameFormat(..) )-import Darcs.Patch.Info ( PatchInfo, showPatchInfo )-import Darcs.Witnesses.Ordered ( FL )+import Darcs.Prelude -import English ( plural, Noun(Noun) )-import Printer ( Doc, vcat, blueText, ($$), (<>), text, packedString )-import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, ApplyMonad ) import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.ApplyMonad ( ApplyMonad, ApplyMonadTrans, evalApplyMonad )+import Darcs.Patch.Object ( formatFileName )+import Darcs.Patch.Witnesses.Ordered ( FL, mapFL ) +import Darcs.Util.English ( plural, Noun(Noun) )+import Darcs.Util.Printer ( Doc, vcat ) -#include "gadts.h"+data ShowPatchFor = ForDisplay | ForStorage -showNamedPrefix :: PatchInfo -> [PatchInfo] -> Doc-showNamedPrefix n d = showPatchInfo n-                   $$ blueText "<"-                   $$ vcat (map showPatchInfo d)-                   $$ blueText ">"+displayPatch :: ShowPatchBasic p => p wX wY -> Doc+displayPatch p = showPatch ForDisplay p  class ShowPatchBasic p where-    showPatch :: p C(x y) -> Doc+    showPatch :: ShowPatchFor -> p wX wY -> Doc +-- | Like 'showPatchWithContextAndApply' but without applying the patch+-- in the monad @m@.+showPatchWithContext+    :: (ApplyMonadTrans (ApplyState p) m, ShowContextPatch p)+    => ShowPatchFor+    -> ApplyState p m+    -> p wX wY+    -> m Doc+showPatchWithContext f st p =+    evalApplyMonad (showPatchWithContextAndApply f p) st++class ShowPatchBasic p => ShowContextPatch p where+    -- | Show a patch with context lines added, as diff -u does. Thus, it+    -- differs from showPatch only for hunks. It is used for instance before+    -- putting it into a bundle. As this unified context is not included in+    -- patch representation, this requires access to the 'ApplyState'.+    --+    -- Note that this applies the patch in the 'ApplyMonad' given by the+    -- context. This is done in order to simplify showing multiple patches in a+    -- series, since each patch may change the context lines for later changes.+    --+    -- For a version that does not apply the patch see 'showPatchWithContext'.+    showPatchWithContextAndApply+        :: (ApplyMonad (ApplyState p) m)+        => ShowPatchFor -> p wX wY -> m Doc++-- | This class is used only for user interaction, not for storage. The default+-- implementations for 'description' and 'content' are suitable only for+-- 'PrimPatch' and 'RepoPatch' types. Logically, 'description' should default+-- to 'mempty' while 'content' should default to 'displayPatch'. We define them+-- the other way around so that 'Darcs.UI.PrintPatch.showFriendly' gives+-- reasonable results for all patch types. class ShowPatchBasic p => ShowPatch p where-    showNicely :: p C(x y) -> Doc-    showNicely = showPatch-    -- | showContextPatch is used to add context to a patch, as diff-    -- -u does. Thus, it differs from showPatch only for hunks. It is-    -- used for instance before putting it into a bundle. As this-    -- unified context is not included in patch representation, this-    -- requires access to the tree.-    showContextPatch :: (Monad m, ApplyMonadTrans m (ApplyState p),-                         ApplyMonad m (ApplyState p))-                     => p C(x y) -> m Doc-    showContextPatch p = return $ showPatch p-    description :: p C(x y) -> Doc-    description = showPatch-    summary :: p C(x y) -> Doc-    summaryFL :: FL p C(x y) -> Doc-    thing :: p C(x y) -> String-    thing _ = "patch"-    things :: p C(x y) -> String-    things x = plural (Noun $ thing x) ""+    content :: p wX wY -> Doc+    content = mempty -writePatch :: ShowPatchBasic p => FilePath -> p C(x y) -> IO ()-writePatch f p = writeDocBinFile f $ showPatch p <> text "\n"-gzWritePatch :: ShowPatchBasic p => FilePath -> p C(x y) -> IO ()-gzWritePatch f p = gzWriteDocFile f $ showPatch p <> text "\n"+    description :: p wX wY -> Doc+    description = displayPatch -formatFileName :: FileNameFormat -> FileName -> Doc-formatFileName OldFormat = packedString . fn2ps-formatFileName NewFormat = text . encodeWhite . fn2fp+    summary :: p wX wY -> Doc++    summaryFL :: FL p wX wY -> Doc+    summaryFL = vcat . mapFL summary++    thing :: p wX wY -> String+    thing _ = "patch"++    things :: p wX wY -> String+    things x = plural (Noun $ thing x) ""
src/Darcs/Patch/Split.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, RankNTypes, GADTs, ViewPatterns #-}+{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- Copyright (C) 2009 Ganesh Sittampalam --@@ -22,27 +22,38 @@ -- CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -- SOFTWARE. -module Darcs.Patch.Split ( Splitter(..), rawSplitter, noSplitter, primSplitter, reversePrimSplitter ) where+module Darcs.Patch.Split+    ( Splitter(..)+    , rawSplitter+    , noSplitter+    , primSplitter+    , reversePrimSplitter+    ) where +import Darcs.Prelude+ import Data.List ( intersperse ) -import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed +import Darcs.Patch.Apply ( ApplyState ) import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )-import Darcs.Patch.Patchy ( ReadPatch(..), showPatch, ShowPatch(..), Invert(..) )-import Darcs.Patch.Invert (invertFL)-import Darcs.Patch.Prim ( PrimPatch, canonize, canonizeFL, primFromHunk )-import Darcs.Patch.ReadMonads ( parseStrictly )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Show ( showPatch, ShowPatch(..) )+import Darcs.Patch.Invert( Invert(..), invertFL )+import Darcs.Patch.Prim ( PrimPatch, canonizeFL, primFromHunk )+import Darcs.Util.Parser ( parse ) import Darcs.Patch.Read ()+import Darcs.Patch.Show ( ShowPatchFor(ForDisplay) ) import Darcs.Patch.Viewing () -import Printer ( renderPS )+import Darcs.Util.Printer ( renderPS )+import qualified Darcs.Util.Diff as D ( DiffAlgorithm )  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC -#include "gadts.h"  -- |A splitter is something that can take a patch and (possibly) render it -- as text in some format of its own choosing.@@ -60,22 +71,20 @@ -- Prim (you shouldn't go editing named patches, you'll break them!) -- However you might want to compose splitters for FilePatchType to make -- splitters for Prim etc, and the generality doesn't cost anything.-data Splitter p-  = Splitter {-              applySplitter :: FORALL(x y) p C(x y)-                              -> Maybe (B.ByteString,-                                        B.ByteString -> Maybe (FL p C(x y)))-              -- canonization is needed to undo the effects of splitting-              -- Typically, the list returned by applySplitter will not-              -- be in the simplest possible form (since the user will have-              -- deliberately added extra stuff). Once the user has selected-              -- the pieces they want, we need to make sure that we eliminate-              -- any remaining redundancy in the selected pieces, otherwise-              -- we might record (or whatever) a rather strange looking patch.-              -- This hook allows the splitter to provide an appropriate-              -- function for doing this.-             ,canonizeSplit :: FORALL(x y) FL p C(x y) -> FL p C(x y)-             }+data Splitter p = Splitter+    { applySplitter :: forall wX wY. p wX wY+                    -> Maybe (B.ByteString, B.ByteString -> Maybe (FL p wX wY))+      -- canonization is needed to undo the effects of splitting+      -- Typically, the list returned by applySplitter will not+      -- be in the simplest possible form (since the user will have+      -- deliberately added extra stuff). Once the user has selected+      -- the pieces they want, we need to make sure that we eliminate+      -- any remaining redundancy in the selected pieces, otherwise+      -- we might record (or whatever) a rather strange looking patch.+      -- This hook allows the splitter to provide an appropriate+      -- function for doing this.+    , canonizeSplit :: forall wX wY. FL p wX wY -> FL p wX wY+    }  {- Some facts that probably ought to be true about splitters: should make some QC properties@@ -87,44 +96,51 @@ -}  -- Does not canonize as there is no generic operation to do this.-withEditedHead :: Invert p => p C(x y) -> p C(x z) -> FL p C(x y)+withEditedHead :: Invert p => p wX wY -> p wX wZ -> FL p wX wY withEditedHead p res = res :>: invert res :>: p :>: NilFL --- |This generic splitter just lets the user edit the printed representation of the patch--- Should not be used expect for testing and experimentation.+-- |This generic splitter just lets the user edit the printed representation of the+-- patch. Should not be used expect for testing and experimentation. rawSplitter :: (ShowPatch p, ReadPatch p, Invert p) => Splitter p-rawSplitter = Splitter {-                  applySplitter =-                     \p -> Just (renderPS . showPatch $ p,-                                 \str -> case parseStrictly readPatch' str of-                                          Just (Sealed res, _) -> Just (withEditedHead p res)-                                          _ -> Nothing-                                )-                 ,canonizeSplit = id-                }+rawSplitter = Splitter+    { applySplitter = \p ->+        Just (renderPS . showPatch ForDisplay $ p+             ,\str -> case parse readPatch' str of+                        Right (Sealed res, _) -> Just (withEditedHead p res)+                        Left _                -> Nothing)+    , canonizeSplit = id+    } --- |Never splits. In other code we normally pass around Maybe Splitter instead of using this--- as the default, because it saves clients that don't care about splitting from having to--- import this module just to get noSplitter.+-- |Never splits. In other code we normally pass around Maybe Splitter instead+-- of using this as the default, because it saves clients that don't care about+-- splitting from having to import this module just to get noSplitter. noSplitter :: Splitter p noSplitter = Splitter { applySplitter = const Nothing, canonizeSplit = id }  -doPrimSplit :: PrimPatch prim => prim C(x y) -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim C(x y)))-doPrimSplit = doPrimSplit_ True explanation+doPrimSplit :: PrimPatch prim => D.DiffAlgorithm -> prim wX wY+            -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim wX wY))+doPrimSplit da = doPrimSplit_ da True explanation   where-    explanation = map BC.pack-                   [ "Interactive hunk edit:"-                   , " - Edit the section marked 'AFTER'"-                   , " - Arbitrary editing is supported"-                   , " - This will only affect the patch, not your working copy"-                   , " - Hints:"-                   , "   - To split added text, delete the part you want to postpone"-                   , "   - To split removed text, copy back the part you want to retain"-                   , ""-                   ]+    explanation =+      map BC.pack+        [ "Interactive hunk edit:"+        , " - Edit the section marked 'AFTER'"+        , " - Arbitrary editing is supported"+        , " - This will only affect the patch, not your working tree"+        , " - Hints:"+        , "   - To split added text, delete the part you want to postpone"+        , "   - To split removed text, copy back the part you want to retain"+        , ""+        ] -doPrimSplit_ edit_before_part helptext (isHunk -> Just (FileHunk fn n before after))+doPrimSplit_ :: forall prim p wX wY. (PrimPatch prim, IsHunk p, ApplyState p ~ ApplyState prim)+             => D.DiffAlgorithm+             -> Bool+             -> [B.ByteString]+             -> p wX wY+             -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim wX wY))+doPrimSplit_ da edit_before_part helptext (isHunk -> Just (FileHunk fn n before after))  = Just (B.concat $ intersperse (BC.pack "\n") $ concat            [ helptext            , [mkSep " BEFORE (reference) =========================="]@@ -142,41 +158,42 @@                      then hunk before before' +>+ hunk before' after' +>+ hunk after' after                      else hunk before after' +>+ hunk after' after)     where sep = BC.pack "=========================="-          hunk :: PrimPatch prim => [B.ByteString] -> [B.ByteString] -> FL prim C(a b)-          hunk b a = canonize (primFromHunk (FileHunk fn n b a))+          hunk :: [B.ByteString] -> [B.ByteString] -> FL prim wA wB+          hunk b a = canonizeFL da (primFromHunk (FileHunk fn n b a) :>: NilFL)           mkSep s = BC.append sep (BC.pack s)           breakSep xs = case break (sep `BC.isPrefixOf`) xs of                            (_, []) -> Nothing                            (ys, _:zs) -> Just (ys, zs)-doPrimSplit_ _ _ _ = Nothing+doPrimSplit_ _ _ _ _ = Nothing --- |Split a primitive hunk patch up--- by allowing the user to edit both the before and after lines, then insert fixup patches--- to clean up the mess.-primSplitter :: PrimPatch p => Splitter p-primSplitter  = Splitter { applySplitter = doPrimSplit-                         , canonizeSplit = canonizeFL }+-- |Split a primitive hunk patch up by allowing the user to edit both the+-- before and after lines, then insert fixup patches to clean up the mess.+primSplitter :: PrimPatch p => D.DiffAlgorithm -> Splitter p+primSplitter da = Splitter { applySplitter = doPrimSplit da+                           , canonizeSplit = canonizeFL da } -doReversePrimSplit :: PrimPatch prim => prim C(x y) -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim C(x y)))-doReversePrimSplit prim = do-  (text, parser) <- doPrimSplit_ False reverseExplanation (invert prim)+doReversePrimSplit :: PrimPatch prim => D.DiffAlgorithm -> prim wX wY+                   -> Maybe (B.ByteString, B.ByteString -> Maybe (FL prim wX wY))+doReversePrimSplit da prim = do+  (text, parser) <- doPrimSplit_ da False reverseExplanation (invert prim)   let parser' p = do         patch <- parser  p         return . reverseRL $ invertFL patch   return (text, parser')   where     reverseExplanation =-      map BC.pack [ "Interactive hunk edit:"-                  , " - Edit the section marked 'AFTER' (representing the state to which you'll revert)"-                  , " - Arbitrary editing is supported"-                  , " - Your working copy will be returned to the 'AFTER' state"-                  , " - Do not touch the 'BEFORE' section"-                  , " - Hints:"-                  , "   - To revert only a part of a text addition, delete the part you want to get rid of"-                  , "   - To revert only a part of a removal, copy back the part you want to retain"-                  , ""-                                 ]+      map BC.pack+        [ "Interactive hunk edit:"+        , " - Edit the section marked 'AFTER' (representing the state to which you'll revert)"+        , " - Arbitrary editing is supported"+        , " - Your working tree will be returned to the 'AFTER' state"+        , " - Do not touch the 'BEFORE' section"+        , " - Hints:"+        , "   - To revert only a part of a text addition, delete the part you want to get rid of"+        , "   - To revert only a part of a removal, copy back the part you want to retain"+        , ""+        ] -reversePrimSplitter :: PrimPatch prim => Splitter prim-reversePrimSplitter = Splitter { applySplitter = doReversePrimSplit-                               , canonizeSplit = canonizeFL}+reversePrimSplitter :: PrimPatch prim => D.DiffAlgorithm -> Splitter prim+reversePrimSplitter da = Splitter { applySplitter = doReversePrimSplit da+                                  , canonizeSplit = canonizeFL da }
src/Darcs/Patch/Summary.hs view
@@ -1,32 +1,81 @@ module Darcs.Patch.Summary-    ( plainSummary, plainSummaryPrim, plainSummaryPrims,-      xmlSummary )-    where+    ( plainSummary+    , plainSummaryFL+    , plainSummaryPrim+    , plainSummaryPrims+    , xmlSummary+    , Summary(..)+    , ConflictState(..)+    , IsConflictedPrim(..)+    , listConflictedFiles+    ) where -import Darcs.Patch.FileName ( fn2fp )-import Darcs.Patch.Conflict ( Conflict(..), IsConflictedPrim(IsC), ConflictState(..) )-import Darcs.Patch.Effect ( Effect )-import Darcs.Patch.Prim.Class ( PrimDetails(..), PrimPatchBase )+import Darcs.Prelude++import Data.List.Ordered ( nubSort )+import Data.Maybe ( catMaybes )++import Darcs.Patch.Format ( FileNameFormat(FileNameFormatDisplay) )+import Darcs.Patch.FromPrim ( PrimPatchBase(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Prim ( PrimDetails(..) )+import Darcs.Patch.Show ( formatFileName ) import Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) )-import Darcs.Witnesses.Ordered ( FL, mapFL )+import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )+import Darcs.Patch.Witnesses.Show -import Printer ( Doc, empty, vcat,-                 text,-                 minus, plus, ($$), (<+>), (<>),-               )+import Darcs.Util.Path ( AnchoredPath, anchorPath )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , (<+>)+    , empty+    , minus+    , plus+    , text+    , vcat+    ) -#include "gadts.h"+-- | This type tags a patch with a 'ConflictState' and also hides the context+-- witnesses (as in 'Sealed2'), so we can put them in a list.+data IsConflictedPrim prim where+    IsC :: !ConflictState -> !(prim wX wY) -> IsConflictedPrim prim+data ConflictState = Okay | Conflicted | Duplicated deriving ( Eq, Ord, Show, Read) -plainSummaryPrim :: PrimDetails prim => prim C(x y) -> Doc-plainSummaryPrim = vcat . map summChunkToLine . genSummary . (:[]) . IsC Okay+class Summary p where+    conflictedEffect :: p wX wY -> [IsConflictedPrim (PrimOf p)] -plainSummaryPrims :: PrimDetails prim => FL prim C(x y) -> Doc-plainSummaryPrims = vcat . map summChunkToLine . genSummary . mapFL (IsC Okay)+instance Summary p => Summary (FL p) where+    conflictedEffect = concat . mapFL conflictedEffect -plainSummary :: (Conflict e, Effect e, PrimPatchBase e) => e C(x y) -> Doc-plainSummary = vcat . map summChunkToLine . genSummary . conflictedEffect+instance Show2 prim => Show (IsConflictedPrim prim) where+    showsPrec d (IsC cs prim) =+        showParen (d > appPrec) $+            showString "IsC " . showsPrec (appPrec + 1) cs .+            showString " " . showsPrec2 (appPrec + 1) prim -xmlSummary :: (Effect p, Conflict p, PrimPatchBase p) => p C(x y) -> Doc+listConflictedFiles+  :: (Summary p, PatchInspect (PrimOf p)) => p wX wY -> [AnchoredPath]+listConflictedFiles =+    nubSort . concat . catMaybes . map conflictedFiles . conflictedEffect+  where+    conflictedFiles (IsC Conflicted p) = Just (listTouchedFiles p)+    conflictedFiles _ = Nothing++plainSummaryPrim :: PrimDetails prim => prim wX wY -> Doc+plainSummaryPrim = vcat . map (summChunkToLine False) . genSummary . (:[]) . IsC Okay++plainSummaryPrims :: PrimDetails prim => Bool -> FL prim wX wY -> Doc+plainSummaryPrims machineReadable =+ vcat . map (summChunkToLine machineReadable) . genSummary . mapFL (IsC Okay)++plainSummary :: (Summary e, PrimDetails (PrimOf e)) => e wX wY -> Doc+plainSummary = vcat . map (summChunkToLine False) . genSummary . conflictedEffect++plainSummaryFL :: (Summary e, PrimDetails (PrimOf e)) => FL e wX wY -> Doc+plainSummaryFL = vcat . map (summChunkToLine False) . genSummary . concat . mapFL conflictedEffect++xmlSummary :: (Summary p, PrimDetails (PrimOf p)) => p wX wY -> Doc xmlSummary p = text "<summary>"              $$ (vcat . map summChunkToXML . genSummary . conflictedEffect $ p)              $$ text "</summary>"@@ -39,8 +88,8 @@ strReplace :: Char -> String -> String -> String strReplace _ _ [] = [] strReplace x y (z:zs)-  | x == z    = y ++ (strReplace x y zs)-  | otherwise = z : (strReplace x y zs)+  | x == z    = y ++ strReplace x y zs+  | otherwise = z : strReplace x y zs -- end yuck duplicated code.  -- | High-level representation of a piece of patch summary@@ -51,11 +100,11 @@ genSummary p     = combine $ concatMap s2 p     where s2 :: IsConflictedPrim p -> [SummChunk]-          s2 (IsC c x) = map (\d -> SummChunk d c) $ summarizePrim x+          s2 (IsC c x) = map (`SummChunk` c) $ summarizePrim x           combine (x1@(SummChunk d1 c1) : x2@(SummChunk d2 c2) : ss)               = case combineDetail d1 d2 of                   Nothing -> x1 : combine (x2:ss)-                  Just d3 -> combine $ SummChunk d3 (combineConflitStates c1 c2) : ss+                  Just d3 -> combine $ SummChunk d3 (combineConflictStates c1 c2) : ss           combine (x:ss) = x  : combine ss           combine [] = []           --@@ -64,11 +113,11 @@                return $ SummFile o3 f1 (r1 + r2) (a1 + a2) (x1 + x2)           combineDetail _ _ = Nothing           ---          combineConflitStates Conflicted _ = Conflicted-          combineConflitStates _ Conflicted = Conflicted-          combineConflitStates Duplicated _ = Duplicated-          combineConflitStates _ Duplicated = Duplicated-          combineConflitStates Okay Okay = Okay+          combineConflictStates Conflicted _ = Conflicted+          combineConflictStates _ Conflicted = Conflicted+          combineConflictStates Duplicated _ = Duplicated+          combineConflictStates _ Duplicated = Duplicated+          combineConflictStates Okay Okay = Okay           -- Don't combine AddFile and RmFile: (maybe an old revision of) darcs           -- allows a single patch to add and remove the same file, see issue 185           combineOp SummAdd SummRm  = Nothing@@ -94,7 +143,7 @@    xconf Okay t x       = text ('<':t++">") $$ x $$ text ("</"++t++">")    xconf Conflicted t x = text ('<':t++" conflict='true'>") $$ x $$ text ("</"++t++">")    xconf Duplicated t x = text ('<':t++" duplicate='true'>") $$ x $$ text ("</"++t++">")-   xfn = escapeXML . dropDotSlash .fn2fp+   xfn = escapeXML . anchorPath ""    --    xad 0 = empty    xad a = text "<added_lines num='" <> text (show a) <> text "'/>"@@ -103,23 +152,30 @@    xrp 0 = empty    xrp a = text "<replaced_tokens num='" <> text (show a) <> text "'/>" -summChunkToLine :: SummChunk -> Doc-summChunkToLine (SummChunk detail c) =+summChunkToLine :: Bool -> SummChunk -> Doc+summChunkToLine machineReadable (SummChunk detail c) =   case detail of-   SummRmDir f   -> lconf c "R" $ text (fn2fp f) <> text "/"-   SummAddDir f  -> lconf c "A" $ text (fn2fp f) <> text "/"-   SummFile SummRm  f _ _ _ -> lconf c "R" $ text (fn2fp f)-   SummFile SummAdd f _ _ _ -> lconf c "A" $ text (fn2fp f)-   SummFile SummMod f r a x -> lconf c "M" $ text (fn2fp f) <+> rm r <+> ad a <+> rp x-   SummMv f1 f2 -> text " "    <> text (fn2fp f1)-                <> text " -> " <> text (fn2fp f2)+   SummRmDir f   -> lconf c "R" $ formatFileName FileNameFormatDisplay f <> text "/"+   SummAddDir f  -> lconf c "A" $ formatFileName FileNameFormatDisplay f <> text "/"+   SummFile SummRm  f _ _ _ -> lconf c "R" $ formatFileName FileNameFormatDisplay f+   SummFile SummAdd f _ _ _ -> lconf c "A" $ formatFileName FileNameFormatDisplay f+   SummFile SummMod f r a x+     | machineReadable -> lconf c "M" $ formatFileName FileNameFormatDisplay f+     | otherwise       -> lconf c "M" $ formatFileName FileNameFormatDisplay f <+> rm r <+> ad a <+> rp x+   SummMv f1 f2+     | machineReadable -> text "F " <> formatFileName FileNameFormatDisplay f1+                       $$ text "T " <> formatFileName FileNameFormatDisplay f2+     | otherwise       -> text " "    <> formatFileName FileNameFormatDisplay f1+                       <> text " -> " <> formatFileName FileNameFormatDisplay f2    SummNone -> case c of                Okay -> empty                _    -> lconf c ""  empty   where    lconf Okay       t x = text t <+> x    lconf Conflicted t x = text (t ++ "!") <+> x-   lconf Duplicated t x = text t <+> x <+> text "duplicate"+   lconf Duplicated t x+     | machineReadable = text t <+> x+     | otherwise       = text t <+> x <+> text "duplicate"    --    ad 0 = empty    ad a = plus <> text (show a)@@ -127,8 +183,3 @@    rm a = minus <> text (show a)    rp 0 = empty    rp a = text "r" <> text (show a)--dropDotSlash :: FilePath -> FilePath-dropDotSlash ('.':'/':str) = dropDotSlash str-dropDotSlash str = str-
src/Darcs/Patch/SummaryData.hs view
@@ -1,11 +1,13 @@ module Darcs.Patch.SummaryData ( SummDetail(..), SummOp(..) ) where -import Darcs.Patch.FileName ( FileName )+import Darcs.Prelude -data SummDetail = SummAddDir FileName-                | SummRmDir  FileName-                | SummFile SummOp FileName Int Int Int-                | SummMv   FileName FileName+import Darcs.Util.Path ( AnchoredPath )++data SummDetail = SummAddDir AnchoredPath+                | SummRmDir  AnchoredPath+                | SummFile SummOp AnchoredPath Int Int Int+                | SummMv   AnchoredPath AnchoredPath                 | SummNone   deriving (Ord, Eq)
src/Darcs/Patch/TokenReplace.hs view
@@ -1,48 +1,100 @@ module Darcs.Patch.TokenReplace-    (-      tryTokInternal+    ( tryTokReplace     , forceTokReplace-    )-    where--import Darcs.Patch.RegChars ( regChars )+    , annotateReplace+    , breakToTokens+    , defaultToks+    ) where -import ByteStringUtils ( substrPS, linesPS, unlinesPS )+import Darcs.Prelude  import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC-import Data.Maybe ( isNothing ) -tryTokInternal :: String -> B.ByteString -> B.ByteString-                 -> B.ByteString -> Maybe [B.ByteString]-tryTokInternal _ o n s | isNothing (substrPS o s) &&-                           isNothing (substrPS n s) = Just [s]-tryTokInternal t o n s =-    case BC.break (regChars t) s of-    (before,s') ->-        case BC.break (not . regChars t) s' of-        (tok,after) ->-            case tryTokInternal t o n after of-            Nothing -> Nothing-            Just rest ->-                if tok == o-                then Just $ before : n : rest-                else if tok == n-                     then Nothing-                     else Just $ before : tok : rest+import Darcs.Patch.RegChars ( regChars ) -forceTokReplace :: String -> String -> String-                -> B.ByteString -> Maybe B.ByteString-forceTokReplace t os ns c = Just $ unlinesPS $ map forceReplace $ linesPS c-    where o = BC.pack os-          n = BC.pack ns-          tokchar = regChars t-          toks_and_intratoks ps | B.null ps = []-          toks_and_intratoks ps =-              let (before,s') = BC.break tokchar ps-                  (tok, after) = BC.break (not . tokchar) s'-                  in before : tok : toks_and_intratoks after-          forceReplace ps = B.concat $ map o_t_n $ toks_and_intratoks ps-          o_t_n s | s == o = n-                  | otherwise = s+-- | @breakOutToken tokChars input@ splits the @input@ 'ByteString' into+-- @'Just' (before, token, after)@, where @token@ is the first non-empty+-- substring consisting only of 'Char's in @tokChars@, or 'Nothing' if no token+-- was found. The 'Char's in @tokChars@ should not have code points larger than+-- 255 (0xff).+breakOutToken :: String -> BC.ByteString+              -> Maybe (BC.ByteString, BC.ByteString, BC.ByteString)+breakOutToken tokChars input+  | not (B.null tok) = Just (before, tok, remaining)+  | otherwise = Nothing+  where+    isTokChar = regChars tokChars+    (before, tokAndRest) = BC.break isTokChar input+    (tok, remaining) = BC.break (not . isTokChar) tokAndRest +-- | @tryTokReplace tokChars old new input@ tries to find the token @old@ and+-- replace it with the token @new@ everywhere in the @input@, returning 'Just'+-- the modified @input@, unless the token @new@ is already in the @input@ in+-- which case 'Nothing' is returned. A token is a sequence of bytes that match+-- the class defined by @tokChars@. This function is supposed to work+-- efficiently with large @input@s i.e. whole files.+tryTokReplace :: String -> B.ByteString -> B.ByteString+              -> B.ByteString -> Maybe B.ByteString+tryTokReplace tokChars old new+  | B.null old = error "tryTokReplace called with empty old token"+  | BC.any (not . isTokChar) old = error "tryTokReplace called with old non-token"+  | BC.any (not . isTokChar) new = error "tryTokReplace called with new non-token"+  | otherwise = fmap B.concat . loop 0+    where+      isTokChar = regChars tokChars+      loop !from input =+        case BC.findIndex isTokChar (B.drop from input) of+          Nothing -> Just [input]+          Just start ->+            case BC.span isTokChar (B.drop (from + start) input) of+              (tok, rest)+                | tok == old ->+                    (B.take (from + start) input :).(new :) <$> loop 0 rest+                | tok == new -> Nothing+                | otherwise ->+                    loop (from + start + B.length tok) input++-- | @forceTokReplace tokChars old new input@ replaces all occurrences of+-- the @old@ token with the @new@ one, throughout the @input@.+forceTokReplace :: String -> B.ByteString -> B.ByteString+                -> B.ByteString -> B.ByteString+forceTokReplace tokChars old new+  | B.null old = error "forceTokReplace called with empty old token"+  | BC.any (not . isTokChar) old = error "forceTokReplace called with old non-token"+  | BC.any (not . isTokChar) new = error "forceTokReplace called with new non-token"+  | otherwise = B.concat . loop 0+    where+      isTokChar = regChars tokChars+      len = B.length old+      loop !from input =+        case B.breakSubstring old (B.drop from input) of+          (before, match)+            | B.null match -> [input] -- not found+            | B.null before || not (isTokChar (BC.last before))+            , B.length match == len || not (isTokChar (BC.index match len)) ->+                -- found and is token+                B.take (from + B.length before) input : new :+                  loop 0 (B.drop len match)+            | otherwise ->+                -- found but not a token+                loop (from + B.length before + len) input++-- | Check if a token replace operation touches the given line.+annotateReplace :: String -> B.ByteString -> B.ByteString -> B.ByteString -> Bool+annotateReplace tokChars old new input =+  case breakOutToken tokChars input of+    Just (_, tok, remaining) ->+      (tok == old || annotateReplace tokChars old new remaining)+    Nothing -> False++-- | Break a 'Bytestring' into tokens, according to 'defaultToks',+-- discarding non-tokens.+breakToTokens :: BC.ByteString -> [BC.ByteString]+breakToTokens input =+  case breakOutToken defaultToks input of+    Nothing -> []+    Just (_, tok, remaining) -> tok : breakToTokens remaining++defaultToks :: String+defaultToks = "A-Za-z_0-9"
src/Darcs/Patch/TouchesFiles.hs view
@@ -15,100 +15,101 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}+module Darcs.Patch.TouchesFiles+    ( lookTouch+    , chooseTouching+    , deselectNotTouching+    , selectNotTouching+    ) where -#include "gadts.h"+import Darcs.Prelude -module Darcs.Patch.TouchesFiles ( lookTouch, chooseTouching, choosePreTouching,-                      selectTouching,-                      deselectNotTouching, selectNotTouching,-                    ) where-import Control.Applicative ( (<$>) )-import Data.List ( isSuffixOf, nub )+import Data.List ( nub ) -import Darcs.Patch.Choices ( PatchChoices, Tag, TaggedPatch,-                             patchChoices, tag, getChoices,-                      forceFirsts, forceLasts, tpPatch,-                    )-import Darcs.Patch ( Patchy, invert )-import Darcs.Patch.Apply ( ApplyState, applyToFilePaths, effectOnFilePaths )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), mapFL_FL, (+>+) )-import Darcs.Witnesses.Sealed ( Sealed, seal )-import Storage.Hashed.Tree( Tree )+import Darcs.Patch.Apply+       (Apply, ApplyState, applyToPaths)+import Darcs.Patch.Choices+       (PatchChoices, Label, LabelledPatch, patchChoices, label,+        getChoices, forceFirsts, forceLasts, unLabel)+import Darcs.Patch.Commute (Commute)+import Darcs.Patch.Inspect (PatchInspect)+import Darcs.Patch.Witnesses.Ordered+       (FL(..), (:>)(..), mapFL_FL, (+>+))+import Darcs.Patch.Witnesses.Sealed (Sealed, seal) -selectTouching :: (Patchy p, ApplyState p ~ Tree)-               => Maybe [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+import Darcs.Util.Path (AnchoredPath, isPrefix)+import Darcs.Util.Tree (Tree)++labelTouching+  :: (Apply p, PatchInspect p, ApplyState p ~ Tree)+  => Bool -> [AnchoredPath] -> FL (LabelledPatch p) wX wY -> [Label]+labelTouching _ _ NilFL = []+labelTouching wantTouching fs (lp :>: lps) =+  case lookTouchOnlyEffect fs (unLabel lp) of+    (doesTouch, fs') ->+      let rest = labelTouching wantTouching fs' lps+      in (if doesTouch == wantTouching+            then (label lp :)+            else id)+           rest++labelNotTouchingFM+  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)+  => [AnchoredPath] -> PatchChoices p wX wY -> [Label]+labelNotTouchingFM paths pc =+  case getChoices pc of+    fc :> mc :> _ -> labelTouching False paths (fc +>+ mc)++selectTouching+  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)+  => Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectTouching Nothing pc = pc-selectTouching (Just files) pc = forceFirsts xs pc-    where ct :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]-          ct _ NilFL = []-          ct fs (tp:>:tps) = case lookTouchOnlyEffect fs (tpPatch tp) of-                             (True, fs') -> tag tp:ct fs' tps-                             (False, fs') -> ct fs' tps-          xs = case getChoices pc of-               _ :> mc :> lc -> ct (map fix files) (mc +>+ lc)+selectTouching (Just paths) pc = forceFirsts xs pc+  where+    xs =+      case getChoices pc of+        _ :> mc :> lc -> labelTouching True paths (mc +>+ lc) -deselectNotTouching :: (Patchy p, ApplyState p ~ Tree)-                    => Maybe [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+deselectNotTouching+  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)+  => Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY deselectNotTouching Nothing pc = pc-deselectNotTouching (Just files) pc = forceLasts xs pc-    where ct :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]-          ct _ NilFL = []-          ct fs (tp:>:tps) = case lookTouchOnlyEffect fs (tpPatch tp) of-                             (True, fs') -> ct fs' tps-                             (False, fs') -> tag tp:ct fs' tps-          xs = case getChoices pc of-               fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)+deselectNotTouching (Just paths) pc =+  forceLasts (labelNotTouchingFM paths pc) pc -selectNotTouching :: (Patchy p, ApplyState p ~ Tree)-                  => Maybe [FilePath] -> PatchChoices p C(x y) -> PatchChoices p C(x y)+selectNotTouching+  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)+  => Maybe [AnchoredPath] -> PatchChoices p wX wY -> PatchChoices p wX wY selectNotTouching Nothing pc = pc-selectNotTouching (Just files) pc = forceFirsts xs pc-    where ct :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> FL (TaggedPatch p) C(x y) -> [Tag]-          ct _ NilFL = []-          ct fs (tp:>:tps) = case lookTouchOnlyEffect fs (tpPatch tp) of-                             (True, fs') -> ct fs' tps-                             (False, fs') -> tag tp:ct fs' tps-          xs = case getChoices pc of-               fc :> mc :> _ -> ct (map fix files) (fc +>+ mc)--fix :: FilePath -> FilePath-fix f | "/" `isSuffixOf` f = fix $ init f-fix "" = "."-fix "." = "."-fix f = "./" ++ f+selectNotTouching (Just paths) pc = forceFirsts (labelNotTouchingFM paths pc) pc -chooseTouching :: (Patchy p, ApplyState p ~ Tree)-               => Maybe [FilePath] -> FL p C(x y) -> Sealed (FL p C(x))+chooseTouching+  :: (Apply p, Commute p, PatchInspect p, ApplyState p ~ Tree)+  => Maybe [AnchoredPath] -> FL p wX wY -> Sealed (FL p wX) chooseTouching Nothing p = seal p-chooseTouching files p = case getChoices $ selectTouching files $ patchChoices p of-                          fc :> _ :> _ -> seal $ mapFL_FL tpPatch fc--choosePreTouching :: (Patchy p, ApplyState p ~ Tree)-                  => Maybe [FilePath] -> FL p C(x y) -> Sealed (FL p C(x))-choosePreTouching files patch = chooseTouching filesBeforePatch patch where-    filesBeforePatch = effectOnFilePaths (invert patch) <$> files+chooseTouching paths p =+  case getChoices $ selectTouching paths $ patchChoices p of+    fc :> _ :> _ -> seal $ mapFL_FL unLabel fc -lookTouchOnlyEffect :: (Patchy p, ApplyState p ~ Tree) => [FilePath] -> p C(x y)-    -> (Bool, [FilePath])-lookTouchOnlyEffect fs p = (wasTouched, fs') where+lookTouchOnlyEffect+  :: (Apply p, ApplyState p ~ Tree)+  => [AnchoredPath] -> p wX wY -> (Bool, [AnchoredPath])+lookTouchOnlyEffect fs p = (wasTouched, fs')+  where     (wasTouched, _, fs', _) = lookTouch Nothing fs p --lookTouch :: (Patchy p, ApplyState p ~ Tree) => Maybe [(FilePath, FilePath)]-    -> [FilePath] -> p C(x y)-    -> (Bool, [FilePath], [FilePath], [(FilePath, FilePath)])+lookTouch+  :: (Apply p, ApplyState p ~ Tree)+  => Maybe [(AnchoredPath, AnchoredPath)]+  -> [AnchoredPath]+  -> p wX wY+  -> (Bool, [AnchoredPath], [AnchoredPath], [(AnchoredPath, AnchoredPath)]) lookTouch renames fs p = (anyTouched, touchedFs, fs', renames')-    where-          touchedFs = nub . concatMap fsAffectedBy $ affected-          fsAffectedBy af = filter (affectedBy af) fs-          anyTouched = length touchedFs > 0-          affectedBy :: FilePath -> FilePath -> Bool-          touched `affectedBy` f =  touched == f-                                 || touched `isSubPathOf` f-                                 || f `isSubPathOf` touched-          isSubPathOf :: FilePath -> FilePath -> Bool-          path `isSubPathOf` parent = case splitAt (length parent) path of-                                 (path', '/':_) -> path' == parent-                                 _ -> False-          (affected, fs', renames') = applyToFilePaths p renames fs+  where+    touchedFs = nub . concatMap fsAffectedBy $ affected+    fsAffectedBy af = filter (affectedBy af) fs+    anyTouched = length touchedFs > 0+    affectedBy :: AnchoredPath -> AnchoredPath -> Bool+    touched `affectedBy` f =+      touched `isPrefix` f || f `isPrefix` touched+    (affected, fs', renames') = applyToPaths p renames fs
+ src/Darcs/Patch/Unwind.hs view
@@ -0,0 +1,241 @@+-- BSD3+module Darcs.Patch.Unwind+  ( Unwind(..)+  , Unwound(..)+  , mkUnwound+  , squashUnwound+  ) where++import Darcs.Prelude++import Darcs.Patch.Commute+  ( Commute, commute, selfCommuter+  )+import Darcs.Patch.CommuteFn+  ( commuterIdFL, commuterFLId+  )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Invert+  ( Invert(..), invertFL, invertRL+  )+import Darcs.Patch.Show ( ShowPatchBasic(..) )+import Darcs.Patch.Viewing ()+import Darcs.Patch.Witnesses.Eq ( EqCheck(..), Eq2(..) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Ordered+  ( FL(..), (:>)(..), (+>+), reverseFL+  , RL(..), (+<+), reverseRL+  )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, show2 )++import Darcs.Util.Printer ( blueText, vcat )++-- | An 'Unwound' represents a primitive patch, together with any+-- other primitives that are required to place the primitive in a+-- different context. Typically, the presence of context patches+-- indicates that the underlying primitive would be in conflict in+-- the given context.+--+-- We have the following invariants:+--  - if a context contains a patch, that context does not also+--    contain the inverse of that patch (when commuted next to each other)+--  - if either context contains a patch that commutes with the underlying+--    patch, then neither context contains the inverse of that patch+--    (when commuted next to each other)+-- Another way of putting it is that all possible pairs of patch+inverse+-- that can be reached by commutation are removed.+data Unwound prim wX wY where+  Unwound+    :: FL prim wA wB        -- ^context before+    -> FL prim wB wC        -- ^underlying primitives+    -> RL prim wC wD        -- ^context after+    -> Unwound prim wA wD++deriving instance Show2 prim => Show (Unwound prim wX wY)+instance Show2 prim => Show1 (Unwound prim wX)+instance Show2 prim => Show2 (Unwound prim)++instance (PatchListFormat prim, ShowPatchBasic prim)+  => ShowPatchBasic (Unwound prim) where+  showPatch f (Unwound before prims after) =+    vcat [+      blueText "before:",+      showPatch f before,+      blueText "prims:",+      showPatch f prims,+      blueText "after:",+      showPatch f after+    ]++instance Invert prim => Invert (Unwound prim) where+  invert (Unwound before prim after)+    = Unwound (invertRL after) (invert prim) (invertFL before)++class Unwind p where+  -- | Get hold of the underlying primitives for a given patch, placed in+  -- the context of the patch. If there are conflicts then context patches+  -- will be needed.+  fullUnwind :: p wX wY -> Unwound (PrimOf p) wX wY++mkUnwound+  :: (Commute prim, Invert prim, Eq2 prim)+  => FL prim wA wB+  -> FL prim wB wC+  -> FL prim wC wD+  -> Unwound prim wA wD+mkUnwound before ps after =+  consBefores before .+  flip consAfters after $+  Unwound NilFL ps NilRL++consBefores+  :: (Commute prim, Invert prim, Eq2 prim)+  => FL prim wA wB+  -> Unwound prim wB wC+  -> Unwound prim wA wC+consBefores NilFL u = u+consBefores (b :>: bs) u = consBefore b (consBefores bs u)++consAfters+  :: (Commute prim, Invert prim, Eq2 prim)+  => Unwound prim wA wB+  -> FL prim wB wC+  -> Unwound prim wA wC+consAfters u NilFL = u+consAfters u (a :>: as) = consAfters (consAfter u a) as++consBefore+  :: (Commute prim, Invert prim, Eq2 prim)+  => prim wA wB+  -> Unwound prim wB wC+  -> Unwound prim wA wC+consBefore b (Unwound NilFL ps after) =+  case commuterIdFL selfCommuter (b :> ps) of+    Nothing -> Unwound (b :>: NilFL) ps after+    -- It is possible for a context patch to commute with the+    -- underlying primitive. If that happens we want to see if we can eliminate it+    -- by propagating it through the other context ("after" in this case).+    -- "full unwind example 3" fails if this case is omitted, as (typically) do the standard+    -- 100 iteration QuickCheck tests+    Just (ps' :> b') -> Unwound NilFL ps' (propagateAfter (NilRL :> b' :> reverseRL after))+consBefore b1 (Unwound (b2 :>: bs) ps after)+  | IsEq <- invert b1 =\/= b2 = Unwound bs ps after+  | Just (b2' :> b1') <- commute (b1 :> b2)+     = case consBefore b1' (Unwound bs ps after) of+         Unwound bs' ps' after' -> Unwound (b2' :>: bs') ps' after'+consBefore b (Unwound bs ps after) = Unwound (b :>: bs) ps after++consAfter+  :: (Commute prim, Invert prim, Eq2 prim)+  => Unwound prim wA wB+  -> prim wB wC+  -> Unwound prim wA wC+consAfter (Unwound before ps NilRL) a =+  case commuterFLId selfCommuter (ps :> a) of+    Nothing -> Unwound before ps (NilRL :<: a)+    -- as with consBefore, we need to see if we can eliminate a context patch+    -- that commutes with the underlying primitive, by propagating it through the+    -- "before" context+    -- "full unwind example 3" fails if this case is omitted, as (typically) do the standard+    -- 100 iteration QuickCheck tests+    Just (a' :> ps') -> Unwound (propagateBefore (reverseFL before :> a' :> NilFL)) ps' NilRL+consAfter (Unwound before ps (as :<: a1)) a2+  | IsEq <- invert a1 =\/= a2 = Unwound before ps as+  | Just (a2' :> a1') <- commute (a1 :> a2)+      = case consAfter (Unwound before ps as) a2' of+          Unwound before' ps' as' -> Unwound before' ps' (as' :<: a1')+consAfter (Unwound before ps as) a = Unwound before ps (as :<: a)++propagateBefore+  :: (Commute prim, Invert prim, Eq2 prim)+  => (RL prim :> prim :> FL prim) wA wB+  -> FL prim wA wB+propagateBefore (NilRL :> p :> acc) = p :>: acc+propagateBefore (qs :<: q :> p :> acc)+  | IsEq <- invert q =\/= p = reverseRL qs +>+ acc+  | Just (p' :> q') <- commute (q :> p)+      = propagateBefore (qs :> p' :> q' :>: acc)+  | otherwise = reverseRL qs +>+ q :>: p :>: acc++propagateAfter+  :: (Commute prim, Invert prim, Eq2 prim)+  => (RL prim :> prim :> FL prim) wA wB+  -> RL prim wA wB+propagateAfter (acc :> p :> NilFL) = acc :<: p+propagateAfter (acc :> p :> q :>: qs)+  | IsEq <- invert p =\/= q = acc +<+ reverseFL qs+  | Just (q' :> p') <- commute (p :> q)+      = propagateAfter (acc :<: q' :> p' :> qs)+  | otherwise = acc :<: p :<: q +<+ reverseFL qs+++-- | Given a list of unwound patches, use commutation and cancellation of+-- inverses to remove intermediate contexts. This is not guaranteed to be+-- possible in general, but should be possible if the patches that were+-- unwound were all originally recorded (unconflicted) in the same context,+-- e.g. as part of the same 'Darcs.Patch.Named.Named'.+squashUnwound+  :: (Show2 prim, Commute prim, Eq2 prim, Invert prim)+  => FL (Unwound prim) wX wY+  -> Unwound prim wX wY+squashUnwound NilFL = Unwound NilFL NilFL NilRL+squashUnwound (u :>: us) =+  -- As described in consBefore/consAfter, it's possible for some of the elements+  -- in a context to commute with the underlying prim that context is attached to,+  -- so consBefore/consAfter try to cancel them by propagating through the other+  -- context.+  -- Sometimes they also won't cancel or commute with patches in the other context+  -- so when squashing we need to move them out of the way of the patches that really+  -- need to be squashed first.+  -- The unit test "full unwind example 3" fails if we remove the moveCommuting calls,+  -- as do QuickCheck tests with a lot of iterations (e.g. 100K)+  squashPair (moveCommutingToBefore u :> moveCommutingToAfter (squashUnwound us))++moveCommutingToBefore+  :: (Commute prim, Invert prim, Eq2 prim)+  => Unwound prim wA wB+  -> Unwound prim wA wB+moveCommutingToBefore (Unwound before ps after) =+  flip consAfters (reverseRL after) $+  Unwound before ps NilRL++moveCommutingToAfter+  :: (Commute prim, Invert prim, Eq2 prim)+  => Unwound prim wA wB+  -> Unwound prim wA wB+moveCommutingToAfter (Unwound before ps after) =+  consBefores before $+  Unwound NilFL ps after++squashPair+  :: (Show2 prim, Commute prim, Eq2 prim, Invert prim)+  => (Unwound prim :> Unwound prim) wX wY+  -> Unwound prim wX wY+squashPair (Unwound before ps1 NilRL :> Unwound NilFL ps2 after) =+  Unwound before (ps1 +>+ ps2) after+squashPair (Unwound before1 ps1 (after1 :<: a) :> Unwound before2 ps2 after2) =+  case pushPastForward (a :> before2) of+    before2' :> Nothing2 ->+      squashPair (Unwound before1 ps1 after1 :> Unwound before2' ps2 after2)+    before2' :> Just2 a' ->+      case commuterIdFL selfCommuter (a' :> ps2) of+        Nothing -> error $ "stuck patch: squashPair 1:\n" ++ show2 a' ++ "\n" ++ show2 ps2+        Just (ps2' :> a'') ->+          squashPair (Unwound before1 ps1 after1 :> Unwound before2' ps2' (NilRL :<: a'' +<+ after2))+squashPair (Unwound before1 ps1 NilRL :> Unwound (b :>: before2) ps2 after2) =+  case commuterFLId selfCommuter (ps1 :> b) of+    Nothing -> error "stuck patch: squashPair 2"+    Just (b' :> ps1') -> squashPair (Unwound (before1 +>+ b' :>: NilFL) ps1' NilRL :> Unwound before2 ps2 after2)++pushPastForward+  :: (Show2 prim, Commute prim, Eq2 prim, Invert prim)+  => (prim :> FL prim) wX wY+  -> (FL prim :> Maybe2 prim) wX wY+pushPastForward (p :> NilFL) = NilFL :> Just2 p+pushPastForward (p :> (q :>: qs))+  | IsEq <- invert p =\/= q = qs :> Nothing2+  | Just (q' :> p') <- commute (p :> q)+      = case pushPastForward (p' :> qs) of+          qs' :> p'' -> (q' :>: qs') :> p''+  | otherwise = error $ "stuck patch: pushPastForward:\n" ++ show2 p ++ "\n" ++ show2 q
src/Darcs/Patch/V1.hs view
@@ -1,16 +1,8 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.V1 ( Patch ) where--import Darcs.Patch.Patchy ( Patchy )-import Darcs.Patch.Prim ( PrimPatch )-import Darcs.Patch.RepoPatch ( RepoPatch )+module Darcs.Patch.V1 ( RepoPatchV1 ) where  import Darcs.Patch.V1.Apply () import Darcs.Patch.V1.Commute ()-import Darcs.Patch.V1.Core ( Patch )+import Darcs.Patch.V1.Core ( RepoPatchV1 ) import Darcs.Patch.V1.Read () import Darcs.Patch.V1.Show () import Darcs.Patch.V1.Viewing ()--instance PrimPatch prim => Patchy (Patch prim)-instance PrimPatch prim => RepoPatch (Patch prim)
src/Darcs/Patch/V1/Apply.hs view
@@ -1,24 +1,23 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Apply () where -import Darcs.Patch.Apply ( Apply, apply )+import Darcs.Prelude++import Darcs.Patch.Apply ( ApplyState, Apply, apply ) import Darcs.Patch.Prim ( PrimPatch, applyPrimFL ) import Darcs.Patch.Repair ( RepairToFL, applyAndTryToFixFL,                             mapMaybeSnd ) import Darcs.Patch.Effect ( effect )  import Darcs.Patch.V1.Commute ()-import Darcs.Patch.V1.Core ( Patch(..) )-import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.V1.Core ( RepoPatchV1(..) )+import Darcs.Patch.Witnesses.Ordered ( mapFL_FL ) -import Darcs.Witnesses.Ordered ( mapFL_FL ) -#include "gadts.h"--instance PrimPatch prim => Apply (Patch prim) where-    type ApplyState (Patch prim) = ApplyState prim+instance PrimPatch prim => Apply (RepoPatchV1 prim) where+    type ApplyState (RepoPatchV1 prim) = ApplyState prim     apply p = applyPrimFL $ effect p -instance PrimPatch prim => RepairToFL (Patch prim) where+instance PrimPatch prim => RepairToFL (RepoPatchV1 prim) where     applyAndTryToFixFL (PP x) = mapMaybeSnd (mapFL_FL PP) `fmap` applyAndTryToFixFL x     applyAndTryToFixFL x = do apply x; return Nothing
src/Darcs/Patch/V1/Commute.hs view
@@ -16,9 +16,7 @@ --  Boston, MA 02110-1301, USA.  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}--#include "gadts.h"+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module Darcs.Patch.V1.Commute     (@@ -28,62 +26,95 @@     )        where +import Darcs.Prelude+ import Control.Monad ( MonadPlus, mplus, msum, mzero, guard )+import Control.Applicative ( Alternative(..) )+import Data.Maybe ( fromMaybe )+import Safe ( headErr ) -import Darcs.Patch.Commute ( toFwdCommute )-import Darcs.Patch.ConflictMarking ( mangleUnravelled )-import Darcs.Patch.FileName ( FileName )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Commute ( selfCommuter )+import Darcs.Patch.CommuteFn ( commuterIdFL, commuterFLId ) import Darcs.Patch.Invert ( invertRL )-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Patchy ( Commute(..), PatchInspect(..), Invert(..) )-import Darcs.Patch.V1.Core ( Patch(..),+import Darcs.Patch.Merge ( CleanMerge(..), Merge(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.V1.Core ( RepoPatchV1(..),                              isMerger,                              mergerUndo )-import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..) )+import Darcs.Patch.CommuteNoConflicts+    ( CommuteNoConflicts(..)+    , mergeNoConflicts+    )+import Darcs.Patch.Conflict+  ( Conflict(..), combineConflicts, mangleOrFail+  )+import Darcs.Patch.Unwind ( Unwind(..), Unwound(..), mkUnwound ) import Darcs.Patch.Effect ( Effect(..) ) import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Prim ( FromPrim(..), PrimPatch,-                          is_filepatch, sortCoalesceFL,-                        )-import Darcs.Patch.Permutations ( headPermutationsRL, simpleHeadPermutationsFL,-                                  commuterIdFL, commuterFLId, selfCommuter )-import Printer ( text, vcat, ($$) )+import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Patch.Permutations+    ( headPermutationsRL+    , simpleHeadPermutationsFL+    , removeFL+    , nubFL+    )+import Darcs.Util.Printer ( renderString, text, vcat, ($$) ) import Darcs.Patch.V1.Show ( showPatch_ )-import Data.List ( nub, nubBy )-import Darcs.Witnesses.Sealed ( unsafeUnseal, unsafeUnsealFlipped )-import Darcs.Utils ( nubsort )-#include "impossible.h"-import Darcs.Witnesses.Sealed ( Sealed(..), mapSeal, unseal, FlippedSeal(..), mapFlipped )-import Darcs.Witnesses.Eq ( EqCheck(..), MyEq(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart-                              , unsafeCoercePEnd )-import Darcs.Witnesses.Ordered ( mapFL_FL,-                             FL(..), RL(..),-                             (:/\:)(..), (:<)(..), (:\/:)(..), (:>)(..),-                             lengthFL, mapRL,-                             reverseFL, reverseRL, concatFL-                           )----import Darcs.ColorPrinter ( traceDoc )---import Printer ( greenText )+import Data.List.Ordered ( nubSort )+import Darcs.Patch.Summary+    ( Summary(..)+    , ConflictState(..)+    , IsConflictedPrim(..)+    )+import Darcs.Patch.Witnesses.Sealed+    ( Sealed(..) , mapSeal, unseal+    , FlippedSeal(..), mapFlipped, unsealFlipped+    )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..), Eq2(..) )+import Darcs.Patch.Witnesses.Unsafe+    ( unsafeCoerceP, unsafeCoercePStart+    , unsafeCoercePEnd )+import Darcs.Patch.Witnesses.Ordered+    ( mapFL_FL, mapFL,+    FL(..), RL(..), (+>+),+    (:/\:)(..), (:\/:)(..), (:>)(..),+    lengthFL, mapRL,+    reverseFL, reverseRL, concatFL+    )  data Perhaps a = Unknown | Failed | Succeeded a +instance Functor Perhaps where+    fmap _ Unknown = Unknown+    fmap _ Failed = Failed+    fmap f (Succeeded x) = Succeeded (f x)++instance Applicative Perhaps where+    pure = Succeeded+    _ <*> Failed = Failed+    _ <*> Unknown = Unknown+    Failed <*> _ = Failed+    Unknown <*> _ = Unknown+    Succeeded f <*> Succeeded x = Succeeded (f x)+ instance  Monad Perhaps where     (Succeeded x) >>= k =  k x     Failed   >>= _      =  Failed     Unknown  >>= _      =  Unknown-    Failed   >> _       =  Failed-    (Succeeded _) >> k  =  k-    Unknown  >> k       =  k-    return              =  Succeeded-    fail _              =  Unknown+    return              =  pure +instance Alternative Perhaps where+    empty = Unknown+    Unknown <|> ys    = ys+    Failed  <|> _     = Failed+    (Succeeded x) <|> _ = Succeeded x+ instance  MonadPlus Perhaps where-    mzero                 = Unknown-    Unknown `mplus` ys    = ys-    Failed  `mplus` _     = Failed-    (Succeeded x) `mplus` _ = Succeeded x+    mzero = Unknown+    mplus = (<|>)  toMaybe :: Perhaps a -> Maybe a toMaybe (Succeeded x) = Just x@@ -93,35 +124,31 @@ toPerhaps (Just x) = Succeeded x toPerhaps Nothing = Failed +-- | 'cleverCommute' attempts to commute two patches @p1@ and @p2@, in their+-- original order, with the given commute function. If the commute function+-- doesn't know how to handle the patches (i.e. it returns Unknown as a+-- result), then we try again with @invert p2@ and @invert p1@ (inverting the+-- results, if succesful).+--+-- TODO: when can the first attempt fail, but the second not? What's so clever+-- in this function? cleverCommute :: Invert prim => CommuteFunction prim -> CommuteFunction prim-cleverCommute c (p1:<p2) =-    case c (p1 :< p2) of+cleverCommute c (p1 :> p2) = case c (p1 :> p2) of     Succeeded x -> Succeeded x     Failed -> Failed-    Unknown -> case c (invert p2 :< invert p1) of-               Succeeded (p1' :< p2') -> Succeeded (invert p2' :< invert p1')-               Failed -> Failed-               Unknown -> Unknown--speedyCommute :: PrimPatch prim => CommuteFunction prim-speedyCommute (p1 :< p2) -- Deal with common case quickly!-    | p1_modifies /= Nothing && p2_modifies /= Nothing &&-      p1_modifies /= p2_modifies = Succeeded (unsafeCoerceP p2 :< unsafeCoerceP p1)-    | otherwise = Unknown-    where p1_modifies = isFilepatchMerger p1-          p2_modifies = isFilepatchMerger p2+    Unknown -> case c (invert p2 :> invert p1) of+                 Succeeded (ip1' :> ip2') -> Succeeded (invert ip2' :> invert ip1')+                 Failed -> Failed+                 Unknown -> Unknown  everythingElseCommute :: forall prim . PrimPatch prim => CommuteFunction prim-everythingElseCommute x = eec x-    where-    eec :: CommuteFunction prim-    eec (PP px :< PP py) = toPerhaps $ do x' :> y' <- commute (py :> px)-                                          return (PP y' :< PP x')-    eec _xx =-        msum [-              cleverCommute commuteRecursiveMerger       _xx-             ,cleverCommute otherCommuteRecursiveMerger _xx-             ]+everythingElseCommute (PP p1 :> PP p2) = toPerhaps $ do+    p2' :> p1' <- commute (p1 :> p2)+    return (PP p2' :> PP p1')+everythingElseCommute ps =+    msum [ cleverCommute commuteRecursiveMerger      ps+         , cleverCommute otherCommuteRecursiveMerger ps+         ]  {- Note that it must be true that@@ -134,70 +161,55 @@ then commutex (B^-1, A^-1) == Just (A'^-1, B'^-1) -} -unsafeMerger :: PrimPatch prim => String -> Patch prim C(x y) -> Patch prim C(x z) -> Patch prim C(a b)-unsafeMerger x p1 p2 = unsafeCoercePStart $ unsafeUnseal $ merger x p1 p2+unsafeMerger :: PrimPatch prim => String -> RepoPatchV1 prim wX wY -> RepoPatchV1 prim wX wZ -> RepoPatchV1 prim wA wB+unsafeMerger x p1 p2 = unseal unsafeCoerceP $ merger x p1 p2 -mergerCommute :: PrimPatch prim => (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))-mergerCommute (Merger _ _ p1 p2 :< pA)-    | unsafeCompare pA p1 = Succeeded (unsafeMerger "0.0" p2 p1 :< unsafeCoercePStart p2)+-- | Attempt to commute two patches, the first of which is a Merger patch.+mergerCommute :: PrimPatch prim+              => (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY)+mergerCommute (pA :> Merger _ _ p1 p2)+    | unsafeCompare pA p1 = Succeeded (unsafeCoercePStart p2 :> unsafeMerger "0.0" p2 p1)     | unsafeCompare pA (invert (unsafeMerger "0.0" p2 p1)) = Failed-mergerCommute (Merger _ _-                (Merger _ _ c b)-                (Merger _ _ c' a) :<-                Merger _ _ b' c'')+mergerCommute (Merger _ _ b' c'' :> Merger _ _ (Merger _ _ c b) (Merger _ _ c' a))     | unsafeCompare b' b && unsafeCompare c c' && unsafeCompare c c'' =-        Succeeded (unsafeMerger "0.0" (unsafeMerger "0.0" b (unsafeCoercePStart a)) (unsafeMerger "0.0" b c) :<-                   unsafeMerger "0.0" b (unsafeCoercePStart a))+        Succeeded ( unsafeMerger "0.0" b (unsafeCoercePStart a) :>+                    unsafeMerger "0.0" (unsafeMerger "0.0" b (unsafeCoercePStart a)) (unsafeMerger "0.0" b c)+                  ) mergerCommute _ = Unknown -instance PrimPatch prim => Merge (Patch prim) where-    merge (y :\/: z) =-        case actualMerge (y:\/:z) of-        Sealed y' -> case commute (z :> y') of-                         Nothing -> bugDoc $ text "merge_patches bug"-                                    $$ showPatch_ y-                                   $$ showPatch_ z-                                   $$ showPatch_ y'-                         Just (_ :> z') -> -- actualMerge returns one arm of a-                                           -- merge result, so commuting then gives-                                           -- us the other arm but we have to assert-                                           -- that the starting context is correct-                                           unsafeCoercePStart z' :/\: y'+instance PrimPatch prim => CleanMerge (RepoPatchV1 prim) where+    cleanMerge = mergeNoConflicts -instance PrimPatch prim => Commute (Patch prim) where+instance PrimPatch prim => Merge (RepoPatchV1 prim) where+    merge (p1 :\/: p2) =+        case mergeNoConflicts (p1 :\/: p2) of+            Just r -> r+            Nothing ->+                case merger "0.0" p1 p2 of+                    Sealed p2' ->+                        case merger "0.0" p2 p1 of+                            Sealed p1' -> unsafeCoercePEnd p2' :/\: unsafeCoercePEnd p1'++instance PrimPatch prim => Commute (RepoPatchV1 prim) where     commute x = toMaybe $ msum-                  [toFwdCommute speedyCommute x,-                   toFwdCommute (cleverCommute mergerCommute) x,-                   toFwdCommute everythingElseCommute x+                  [(cleverCommute mergerCommute) x,+                   everythingElseCommute x                   ] -instance PrimPatch prim => PatchInspect (Patch prim) where+instance PrimPatch prim => PatchInspect (RepoPatchV1 prim) where     -- Recurse on everything, these are potentially spoofed patches-    listTouchedFiles (Merger _ _ p1 p2) = nubsort $ listTouchedFiles p1+    listTouchedFiles (Merger _ _ p1 p2) = nubSort $ listTouchedFiles p1                                             ++ listTouchedFiles p2-    listTouchedFiles c@(Regrem _ _ _ _) = listTouchedFiles $ invert c+    listTouchedFiles c@(Regrem{}) = listTouchedFiles $ invert c     listTouchedFiles (PP p) = listTouchedFiles p      hunkMatches f (Merger _ _ p1 p2) = hunkMatches f p1 || hunkMatches f p2-    hunkMatches f c@(Regrem _ _ _ _) = hunkMatches f $ invert c+    hunkMatches f c@(Regrem{}) = hunkMatches f $ invert c     hunkMatches f (PP p) = hunkMatches f p -commuteNoMerger :: PrimPatch prim => MaybeCommute prim-commuteNoMerger x =-    toMaybe $ msum [speedyCommute x,-                    everythingElseCommute x]--isFilepatchMerger :: PrimPatch prim => Patch prim C(x y) -> Maybe FileName-isFilepatchMerger (PP p) = is_filepatch p-isFilepatchMerger (Merger _ _ p1 p2) = do-     f1 <- isFilepatchMerger p1-     f2 <- isFilepatchMerger p2-     if f1 == f2 then return f1 else Nothing-isFilepatchMerger (Regrem und unw p1 p2)-    = isFilepatchMerger (Merger und unw p1 p2)--commuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))-commuteRecursiveMerger (p@(Merger _ _ p1 p2) :< pA) = toPerhaps $+commuteRecursiveMerger :: PrimPatch prim+    => (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY)+commuteRecursiveMerger (pA :> p@(Merger _ _ p1 p2)) = toPerhaps $   do (_ :> pA') <- commuterIdFL selfCommuter (pA :> undo)      _ <- commuterIdFL selfCommuter (pA' :> invert undo)      (_ :> pAmid) <- commute (pA :> unsafeCoercePStart (invert p1))@@ -212,13 +224,13 @@          undo' = mergerUndo p'      (pAo :> _) <- commuterFLId selfCommuter (undo' :> pA')      guard (pAo `unsafeCompare` pA)-     return (pA' :< p')+     return (p' :> pA')     where undo = mergerUndo p commuteRecursiveMerger _ = Unknown -otherCommuteRecursiveMerger :: PrimPatch prim => (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))-otherCommuteRecursiveMerger (pA':< p_old@(Merger _ _ p1' p2')) =-  toPerhaps $+otherCommuteRecursiveMerger :: PrimPatch prim+    => (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY)+otherCommuteRecursiveMerger (p_old@(Merger _ _ p1' p2') :> pA') = toPerhaps $   do (pA :> _) <- commuterFLId selfCommuter (mergerUndo p_old :> pA')      (pAmid :> p1) <- commute (unsafeCoercePEnd p1' :> pA)      (_ :> pAmido) <- commute (pA :> invert p1)@@ -233,27 +245,10 @@      guard (not $ pA `unsafeCompare` p1) -- special case here...      (_ :> pAo') <- commuterIdFL selfCommuter (pA :> undo)      guard (pAo' `unsafeCompare` pA')-     return (p :< pA)+     return (pA :> p) otherCommuteRecursiveMerger _ = Unknown -type CommuteFunction prim = FORALL(x y) (Patch prim :< Patch prim) C(x y) -> Perhaps ((Patch prim :< Patch prim) C(x y))-type MaybeCommute prim = FORALL(x y) (Patch prim :< Patch prim) C(x y) -> Maybe ((Patch prim :< Patch prim) C(x y))--revCommuteFLId :: MaybeCommute prim -> (FL (Patch prim) :< Patch prim) C(x y) -> Maybe ((Patch prim :< FL (Patch prim)) C(x y))-revCommuteFLId _        (NilFL :< p) = return (p :< NilFL)-revCommuteFLId commuter ((q :>: qs) :< p) = do-   p' :< q' <- commuter (q :< p)-   p'' :< qs' <- revCommuteFLId commuter (qs :< p')-   return (p'' :< (q' :>: qs'))--elegantMerge :: PrimPatch prim-              => (Patch prim :\/: Patch prim) C(x y)-              -> Maybe ((Patch prim :/\: Patch prim) C(x y))-elegantMerge (p1 :\/: p2) = do-  p1' :> ip2' <- commute (invert p2 :> p1)-  p1o :> _    <- commute (p2 :> p1')-  guard $ unsafeCompare p1o p1 -- should be a redundant check-  return $ invert ip2' :/\: p1'+type CommuteFunction prim = forall wX wY . (RepoPatchV1 prim :> RepoPatchV1 prim) wX wY -> Perhaps ((RepoPatchV1 prim :> RepoPatchV1 prim) wX wY)  {- A note about mergers and type witnesses@@ -278,164 +273,190 @@ -}  -actualMerge :: PrimPatch prim => (Patch prim :\/: Patch prim) C(x y) -> Sealed (Patch prim C(y))--actualMerge (p1 :\/: p2) = case elegantMerge (p1:\/:p2) of-                             Just (_ :/\: p1') -> Sealed p1'-                             Nothing -> merger "0.0" p2 p1--unwind :: Patch prim C(x y) -> Sealed (RL (Patch prim) C(x)) -- Recreates a patch history in reverse.+-- Recreates a patch history in reverse.+unwind :: RepoPatchV1 prim wX wY -> Sealed (RL (RepoPatchV1 prim) wX) unwind (Merger _ unwindings _ _) = Sealed unwindings-unwind p = Sealed (p :<: NilRL)+unwind p = Sealed (NilRL :<: p) -trueUnwind :: PrimPatch prim => Patch prim C(x y) -> Sealed (RL (Patch prim) C(x)) -- Recreates a patch history in reverse.-trueUnwind p@(Merger _ _ p1 p2) =-    case (unwind p1, unwind p2) of-    (Sealed (_:<:p1s),Sealed (_:<:p2s)) ->-         Sealed (p :<: unsafeCoerceP p1 :<: unsafeUnsealFlipped (reconcileUnwindings p p1s (unsafeCoercePEnd p2s)))-    _ -> impossible-trueUnwind _ = impossible+-- Recreates a patch history in reverse. The patch being unwound is always at+-- the start of the list of patches.+trueUnwind :: PrimPatch prim+    => RepoPatchV1 prim wC wX -> RepoPatchV1 prim wC wD -> Sealed ((RL (RepoPatchV1 prim) :> RepoPatchV1 prim) wX)+trueUnwind p1 p2 =+  let fake_p = Merger NilFL NilRL p1 p2+  in+  case (unwind p1, unwind p2) of+    (Sealed (p1s:<:_),Sealed (p2s:<:_)) ->+         Sealed (unsealFlipped unsafeCoerceP (reconcileUnwindings fake_p p1s (unsafeCoercePEnd p2s)) :<: unsafeCoerceP p1 :> fake_p)+    _ -> error "impossible case"  reconcileUnwindings :: PrimPatch prim-                    => Patch prim C(a b) -> RL (Patch prim) C(x z) -> RL (Patch prim) C(y z) -> FlippedSeal (RL (Patch prim)) C(z)+    => RepoPatchV1 prim wA wB -> RL (RepoPatchV1 prim) wX wZ -> RL (RepoPatchV1 prim) wY wZ -> FlippedSeal (RL (RepoPatchV1 prim)) wZ reconcileUnwindings _ NilRL p2s = FlippedSeal p2s reconcileUnwindings _ p1s NilRL = FlippedSeal p1s-reconcileUnwindings p (p1:<:p1s) p2s@(p2:<:tp2s) =+reconcileUnwindings p (p1s:<:p1) p2s@(tp2s:<:p2) =     case [(p1s', p2s')|-          p1s'@(hp1s':<:_) <- headPermutationsRL (p1:<:p1s),-          p2s'@(hp2s':<:_) <- headPermutationsRL p2s,+          p1s'@(_:<:hp1s') <- headPermutationsRL (p1s:<:p1),+          p2s'@(_:<:hp2s') <- headPermutationsRL p2s,           hp1s' `unsafeCompare` hp2s'] of-    ((p1':<:p1s', _:<:p2s'):_) ->-        mapFlipped (p1' :<:) $ reconcileUnwindings p p1s' (unsafeCoercePEnd p2s')+    ((p1s':<:p1', p2s':<:_):_) ->+        mapFlipped (:<:p1') $ reconcileUnwindings p p1s' (unsafeCoercePEnd p2s')     [] -> case reverseFL `fmap` putBefore p1 (reverseRL p2s) of-          Just p2s' -> mapFlipped (p1 :<:) $ reconcileUnwindings p p1s p2s'+          Just p2s' -> mapFlipped (:<:p1) $ reconcileUnwindings p p1s p2s'           Nothing ->               case fmap reverseFL $ putBefore p2 $-                   reverseRL (p1:<:p1s) of-              Just p1s' -> mapFlipped (p2 :<:) $+                   reverseRL (p1s:<:p1) of+              Just p1s' -> mapFlipped (:<:p2) $                            reconcileUnwindings p p1s' tp2s               Nothing ->-                  bugDoc $ text "in function reconcileUnwindings"-                        $$ text "Original patch:"-                        $$ showPatch_ p-    _ -> bug "in reconcileUnwindings"+                error $ renderString+                  $ text "in function reconcileUnwindings"+                  $$ text "Original patch:"+                  $$ showPatch_ p+    _ -> error "in reconcileUnwindings"  -- This code seems wrong, shouldn't the commute be invert p1 :> p2 ? And why isn't p1' re-inverted? -- it seems to have been this way forever: -- Fri May 23 10:27:04 BST 2003  droundy@abridgegame.org --    * fix bug in unwind and add docs on unwind algorithm.-putBefore :: PrimPatch prim => Patch prim C(y z) -> FL (Patch prim) C(x z) -> Maybe (FL (Patch prim) C(y w))+putBefore :: PrimPatch prim+    => RepoPatchV1 prim wY wZ -> FL (RepoPatchV1 prim) wX wZ -> Maybe (FL (RepoPatchV1 prim) wY wW) putBefore p1 (p2:>:p2s) =     do p1' :> p2' <- commute (unsafeCoerceP p2 :> invert p1)        _ <- commute (p2' :> p1)        (unsafeCoerceP p2' :>:) `fmap` putBefore p1' (unsafeCoerceP p2s) putBefore _ NilFL = Just (unsafeCoerceP NilFL) -instance PrimPatch prim => CommuteNoConflicts (Patch prim) where-  commuteNoConflicts (x:>y) =   do x' :< y' <- commuteNoMerger (y :< x)-                                   return (y':>x')+instance PrimPatch prim => CommuteNoConflicts (RepoPatchV1 prim) where+  commuteNoConflicts x = toMaybe $ everythingElseCommute x -instance PrimPatch prim => Conflict (Patch prim) where-  resolveConflicts patch = rcs NilFL (patch :<: NilRL)-    where rcs :: FL (Patch prim) C(y w) -> RL (Patch prim) C(x y) -> [[Sealed (FL prim C(w))]]-          rcs _ NilRL = []-          rcs passedby (p@(Merger _ _ _ _):<:ps) =-              case revCommuteFLId commuteNoMerger (passedby:<p) of-              Just (p'@(Merger _ _ p1 p2):<_) ->-                  (map Sealed $ nubBy unsafeCompare $-                        effect (unsafeCoercePStart $ unsafeUnseal (glump09 p1 p2)) : map (unsafeCoercePStart . unsafeUnseal) (unravel p'))-                  : rcs (p :>: passedby) ps-              Nothing -> rcs (p :>: passedby) ps-              _ -> impossible-          rcs passedby (p:<:ps) = seq passedby $-                                  rcs (p :>: passedby) ps+instance PrimPatch prim => Conflict (RepoPatchV1 prim) where+  isConflicted (PP _) = False+  isConflicted _ = True+  resolveConflicts _ = map mangleOrFail . combineConflicts resolveOne+    where+      resolveOne p | isMerger p = [publicUnravel p]+      resolveOne _ = [] +instance PrimPatch prim => Unwind (RepoPatchV1 prim) where+  fullUnwind (PP prim) = mkUnwound NilFL (prim :>: NilFL) NilFL+  fullUnwind (Merger a _ c d) =+    case fullUnwind d of+      Unwound before prim _after ->+        mkUnwound+          (invert (effect c) +>+ before)+          prim+          (invert prim +>+ invert before +>+ effect c +>+ effect a)+  fullUnwind (Regrem a b c d) = invert (fullUnwind (Merger a b c d))++instance PrimPatch prim => Summary (RepoPatchV1 prim) where+  conflictedEffect x+    | isMerger x = mapFL (IsC Conflicted) $ effect x+    | otherwise = mapFL (IsC Okay) $ effect x+ -- This type seems wrong - the most natural type for the result would seem to be--- [Sealed (FL Prim C(x))], given the type of unwind.--- However downstream code in darcs convert assumes the C(y) type, and I was unable+-- [Sealed (FL prim wX)], given the type of unwind.+-- However downstream code in darcs convert assumes the wY type, and I was unable -- to figure out whether this could/should reasonably be changed -- Ganesh 13/4/10-publicUnravel :: PrimPatch prim => Patch prim C(x y) -> [Sealed (FL prim C(y))]+--+-- bf says: the type here is correct, those of unwind and unravel are wrong,+-- because conflict resolution applies to the end of the repo.+publicUnravel :: PrimPatch prim => RepoPatchV1 prim wX wY -> [Sealed (FL prim wY)] publicUnravel = map (mapSeal unsafeCoercePStart) . unravel -unravel :: PrimPatch prim => Patch prim C(x y) -> [Sealed (FL prim C(x))]-unravel p = nub $ map (mapSeal (sortCoalesceFL . concatFL . mapFL_FL effect)) $+dropAllInverses :: (Commute p, Invert p, Eq2 p) => FL p wX wY -> FL p wX wY+dropAllInverses NilFL = NilFL+dropAllInverses (p :>: ps) =+  let ps' = dropAllInverses ps in+  fromMaybe (p :>: ps') $ removeFL (invert p) ps'++unravel :: PrimPatch prim => RepoPatchV1 prim wX wY -> [Sealed (FL prim wX)]+unravel p = nubFL $ map (mapSeal (dropAllInverses . concatFL . mapFL_FL effect)) $             getSupers $ map (mapSeal reverseRL) $ unseal (newUr p) $ unwind p -getSupers :: PrimPatch prim => [Sealed (FL (Patch prim) C(x))] -> [Sealed (FL (Patch prim) C(x))]+getSupers :: PrimPatch prim+    => [Sealed (FL (RepoPatchV1 prim) wX)] -> [Sealed (FL (RepoPatchV1 prim) wX)] getSupers (x:xs) =     case filter (not.(x `isSuperpatchOf`)) xs of-    xs' -> if or $ map (`isSuperpatchOf` x) xs'+    xs' -> if any (`isSuperpatchOf` x) xs'            then getSupers xs'            else x : getSupers xs' getSupers [] = [] -isSuperpatchOf :: PrimPatch prim => Sealed (FL (Patch prim) C(x)) -> Sealed (FL (Patch prim) C(x)) -> Bool+isSuperpatchOf :: PrimPatch prim+    => Sealed (FL (RepoPatchV1 prim) wX) -> Sealed (FL (RepoPatchV1 prim) wX) -> Bool Sealed x `isSuperpatchOf` Sealed y | lengthFL y > lengthFL x = False -- should be just an optimisation Sealed x `isSuperpatchOf` Sealed y = x `iso` y-    where iso :: PrimPatch prim => FL (Patch prim) C(x y) -> FL (Patch prim) C(x z) -> Bool+    where iso :: PrimPatch prim => FL (RepoPatchV1 prim) wX wY -> FL (RepoPatchV1 prim) wX wZ -> Bool           _ `iso` NilFL = True           NilFL `iso` _ = False           a `iso` (b:>:bs) =-              head $ ([as `iso` bs | (ah :>: as) <- simpleHeadPermutationsFL a, IsEq <- [ah =\/= b]] :: [Bool]) ++ [False]+              headErr $ ([as `iso` bs | (ah :>: as) <- simpleHeadPermutationsFL a, IsEq <- [ah =\/= b]] :: [Bool]) ++ [False] -merger :: PrimPatch prim => String -> Patch prim C(x y) -> Patch prim C(x z) -> Sealed (Patch prim C(y))-merger "0.0" p1 p2 = Sealed $ Merger undoit unwindings p1 p2-    where fake_p = Merger NilFL NilRL p1 p2-          unwindings = unsafeUnseal (trueUnwind fake_p)-          p = Merger NilFL unwindings p1 p2-          undoit =+-- | merger takes two patches, (which have been determined to conflict) and+-- constructs a Merger patch to represent the conflict. @p1@ is considered to+-- be conflicting with @p2@ (@p1@ is the "first" patch in the repo ordering),+-- the resulting Merger is therefore a representation of @p2@.+merger :: PrimPatch prim+    => String -> RepoPatchV1 prim wX wY -> RepoPatchV1 prim wX wZ -> Sealed (RepoPatchV1 prim wY)+merger "0.0" p1 p2 = final_p+    where+          sealed_unwindings = trueUnwind p1 p2+          final_p =+            case (sealed_undoit, sealed_unwindings) of+              (Sealed undoit, Sealed unwindings)+                -> Sealed $ Merger undoit ((\(a :> b) -> (a :<: b)) unwindings) p1 p2+          sealed_undoit =               case (isMerger p1, isMerger p2) of-              (True ,True ) -> case unwind p of-                                 Sealed (_:<:t) -> unsafeCoerceP $ invertRL t-                                 _ -> impossible-              (False,False) -> unsafeCoerceP $ invert p1 :>: NilFL-              (True ,False) -> unsafeCoerceP $ NilFL-              (False,True ) -> unsafeCoerceP $ invert p1 :>: mergerUndo p2+              (True ,True ) -> case sealed_unwindings of+                                 Sealed (t :> _) -> Sealed $ unsafeCoercePStart $ invertRL t+              (False,False) -> Sealed $ invert p1 :>: NilFL+              (True ,False) -> Sealed NilFL+              (False,True ) -> Sealed $ invert p1 :>: mergerUndo p2 merger g _ _ =     error $ "Cannot handle mergers other than version 0.0\n"++g     ++ "\nPlease use darcs optimize --modernize with an older darcs." -glump09 :: PrimPatch prim => Patch prim C(x y) -> Patch prim C(x z) -> Sealed (FL (Patch prim) C(y))-glump09 p1 p2 = mapSeal (mapFL_FL fromPrim) $ mangleUnravelled $ unseal unravel $ merger "0.0" p1 p2--instance PrimPatch prim => Effect (Patch prim) where-    effect p@(Merger _ _ _ _) = sortCoalesceFL $ effect $ mergerUndo p-    effect p@(Regrem _ _ _ _) = invert $ effect $ invert p+instance PrimPatch prim => Effect (RepoPatchV1 prim) where+    effect p@(Merger{}) = dropAllInverses $ effect $ mergerUndo p+    effect p@(Regrem{}) = invert $ effect $ invert p     effect (PP p) = p :>: NilFL -instance IsHunk prim => IsHunk (Patch prim) where+instance (PrimPatch prim, ApplyState prim ~ ApplyState (RepoPatchV1 prim)) =>+         IsHunk (RepoPatchV1 prim) where     isHunk p = do PP p' <- return p                   isHunk p' -newUr :: PrimPatch prim => Patch prim C(a b) -> RL (Patch prim) C(x y) -> [Sealed (RL (Patch prim) C(x))]-newUr p (Merger _ _ p1 p2 :<: ps) =-   case filter (\(pp:<:_) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of-   ((_:<:ps'):_) -> newUr p (unsafeCoercePStart p1:<:ps') ++ newUr p (unsafeCoercePStart p2:<:ps')-   _ -> bugDoc $ text "in function newUr"-              $$ text "Original patch:"-              $$ showPatch_ p-              $$ text "Unwound:"-              $$ vcat (unseal (mapRL showPatch_) $ unwind p)+newUr :: PrimPatch prim+    => RepoPatchV1 prim wA wB -> RL (RepoPatchV1 prim) wX wY -> [Sealed (RL (RepoPatchV1 prim) wX)]+newUr p (ps :<: Merger _ _ p1 p2) =+   case filter (\(_:<:pp) -> pp `unsafeCompare` p1) $ headPermutationsRL ps of+   ((ps':<:_):_) -> newUr p (ps':<:unsafeCoercePStart p1) ++ newUr p (ps':<:unsafeCoercePStart p2)+   _ -> error $ renderString $ text "in function newUr"+                 $$ text "Original patch:"+                 $$ showPatch_ p+                 $$ text "Unwound:"+                 $$ vcat (unseal (mapRL showPatch_) $ unwind p)  newUr op ps =-    case filter (\(p:<:_) -> isMerger p) $ headPermutationsRL ps of+    case filter (\(_:<:p) -> isMerger p) $ headPermutationsRL ps of     [] -> [Sealed ps]     (ps':_) -> newUr op ps' -instance Invert prim => Invert (Patch prim) where+instance Invert prim => Invert (RepoPatchV1 prim) where     invert (Merger undo unwindings p1 p2)         = Regrem undo unwindings p1 p2     invert (Regrem undo unwindings p1 p2)         = Merger undo unwindings p1 p2     invert (PP p) = PP (invert p) -instance MyEq prim => MyEq (Patch prim) where+instance Eq2 prim => Eq2 (RepoPatchV1 prim) where     unsafeCompare = eqPatches -instance MyEq prim => Eq (Patch prim C(x y)) where+instance Eq2 prim => Eq (RepoPatchV1 prim wX wY) where     (==) = unsafeCompare -eqPatches :: MyEq prim => Patch prim C(x y) -> Patch prim C(w z) -> Bool+eqPatches :: Eq2 prim => RepoPatchV1 prim wX wY -> RepoPatchV1 prim wW wZ -> Bool eqPatches (PP p1) (PP p2) = unsafeCompare p1 p2 eqPatches (Merger _ _ p1a p1b) (Merger _ _ p2a p2b)  = eqPatches p1a p2a &&
src/Darcs/Patch/V1/Core.hs view
@@ -1,51 +1,103 @@ module Darcs.Patch.V1.Core-    ( Patch(..),+    ( RepoPatchV1(..),       isMerger, mergerUndo     ) where -import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(ListFormatV1) )-import Darcs.Patch.Prim ( FromPrim(..), PrimOf, PrimPatchBase, PrimPatch )+import Darcs.Prelude++import Darcs.Patch.Format+    ( PatchListFormat(..)+    , ListFormat(ListFormatV1)+    )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.FromPrim+    ( FromPrim(..)+    , PrimPatchBase(..)+    , ToPrim(..)+    )+import Darcs.Patch.Ident ( PatchId )+import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Repair ( Check ) -import Darcs.Witnesses.Ordered ( FL(..), RL )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 ) -#include "gadts.h"-#include "impossible.h"+-- This haddock could be put on the individual bits of Merger instead+-- once haddock supports doc comments on GADT constructors+{- |+The format of a merger is @Merger undos unwindings conflicting original@. -data Patch prim C(x y) where-    PP :: prim C(x y) -> Patch prim C(x y)-    Merger :: FL (Patch prim) C(x y)-           -> RL (Patch prim) C(x b)-           -> Patch prim C(c b)-           -> Patch prim C(c d)-           -> Patch prim C(x y)-    Regrem :: FL (Patch prim) C(x y)-           -> RL (Patch prim) C(x b)-           -> Patch prim C(c b)-           -> Patch prim C(c a)-           -> Patch prim C(y x)+@undos@ = the effect of the merger -instance PrimPatch prim => PrimPatchBase (Patch prim) where-    type PrimOf (Patch prim) = prim+@unwindings@ = TODO: eh? -instance FromPrim (Patch prim) where-    fromPrim = PP+@conflicting@ = the patch we conflict with -isMerger :: Patch prim C(a b) -> Bool-isMerger (Merger _ _ _ _) = True-isMerger (Regrem _ _ _ _) = True+@original@ = the patch we really are+-}+data RepoPatchV1 prim wX wY where+    PP :: prim wX wY -> RepoPatchV1 prim wX wY+    Merger :: FL (RepoPatchV1 prim) wX wY+           -> RL (RepoPatchV1 prim) wX wB+           -> RepoPatchV1 prim wC wX+           -> RepoPatchV1 prim wC wD+           -> RepoPatchV1 prim wX wY+    Regrem :: FL (RepoPatchV1 prim) wX wY+           -> RL (RepoPatchV1 prim) wX wB+           -> RepoPatchV1 prim wC wX+           -> RepoPatchV1 prim wC wD+           -> RepoPatchV1 prim wY wX++instance Show2 prim => Show (RepoPatchV1 prim wX wY)  where+    showsPrec d (PP p) =+        showParen (d > appPrec) $ showString "PP " . showsPrec2 (appPrec + 1) p+    showsPrec d (Merger undos unwindings conflicting original) =+        showParen (d > appPrec) $+            showString "Merger " . showsPrec2 (appPrec + 1) undos .+            showString " " . showsPrec2 (appPrec + 1) unwindings .+            showString " " . showsPrec2 (appPrec + 1) conflicting .+            showString " " . showsPrec2 (appPrec + 1) original+    showsPrec d (Regrem undos unwindings conflicting original) =+        showParen (d > appPrec) $+            showString "Regrem " . showsPrec2 (appPrec + 1) undos .+            showString " " . showsPrec2 (appPrec + 1) unwindings .+            showString " " . showsPrec2 (appPrec + 1) conflicting .+            showString " " . showsPrec2 (appPrec + 1) original++instance Show2 prim => Show1 (RepoPatchV1 prim wX)++instance Show2 prim => Show2 (RepoPatchV1 prim)++instance PrimPatch prim => PrimPatchBase (RepoPatchV1 prim) where+    type PrimOf (RepoPatchV1 prim) = prim++type instance PatchId (RepoPatchV1 prim) = ()++instance FromPrim (RepoPatchV1 prim) where+    fromAnonymousPrim = PP++instance ToPrim (RepoPatchV1 prim) where+    toPrim (PP p) = Just p+    toPrim _ = Nothing++isMerger :: RepoPatchV1 prim wA wB -> Bool+isMerger (Merger{}) = True+isMerger (Regrem{}) = True isMerger _ = False -mergerUndo :: Patch prim C(x y) -> FL (Patch prim) C(x y)+mergerUndo :: RepoPatchV1 prim wX wY -> FL (RepoPatchV1 prim) wX wY mergerUndo (Merger undo _ _ _) = undo-mergerUndo _ = impossible+mergerUndo _ = error "impossible case" -instance PatchListFormat (Patch prim) where+instance PatchListFormat (RepoPatchV1 prim) where    -- In principle we could use ListFormatDefault when prim /= V1 Prim patches,    -- as those are the only case where we need to support a legacy on-disk    -- format. In practice we don't expect Patch to be used with any other argument    -- anyway, so it doesn't matter.    patchListFormat = ListFormatV1 -instance Check (Patch prim)+instance Check (RepoPatchV1 prim)    -- no checks++instance PatchDebug prim => PatchDebug (RepoPatchV1 prim)+
+ src/Darcs/Patch/V1/Prim.hs view
@@ -0,0 +1,89 @@+-- it is stupid that we need UndecidableInstances just to call another+-- type function (see instance Apply below which requires this)+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.V1.Prim ( Prim(..) ) where++import Darcs.Prelude++import Data.Coerce ( coerce )++import Darcs.Patch.Annotate ( Annotate(..) )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format+    ( PatchListFormat(..)+    , ListFormat(ListFormatV1)+    , FileNameFormat(FileNameFormatV1,FileNameFormatDisplay) )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.Merge ( CleanMerge )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Repair ( RepairToFL(..) )+import Darcs.Patch.Show+    ( ShowPatchBasic(..)+    , ShowPatchFor(..)+    , ShowPatch(..)+    , ShowContextPatch(..)+    )+import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )++import Darcs.Patch.Witnesses.Eq ( Eq2 )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Patch.Witnesses.Sealed ( mapSeal )++import Darcs.Patch.Prim.Class+    ( PrimConstruct(..), PrimCoalesce(..)+    , PrimDetails(..)+    , PrimShow(..), PrimRead(..)+    , PrimApply(..)+    , PrimSift(..)+    , PrimMangleUnravelled(..)+    )+import qualified Darcs.Patch.Prim.V1 as Base ( Prim )++newtype Prim x y = Prim { unPrim :: Base.Prim x y } deriving+    ( Annotate+    , Apply+    , CleanMerge+    , Commute+    , Invert+    , IsHunk+    , Eq2+    , PatchInspect+    , PrimApply+    , PrimCoalesce+    , PrimConstruct+    , PrimDetails+    , PrimMangleUnravelled+    , PrimSift+    , Show+    )++instance Show1 (Prim wX)++instance Show2 Prim++instance ReadPatch Prim where+  readPatch' = fmap (mapSeal Prim) (readPrim FileNameFormatV1)++fileNameFormat :: ShowPatchFor -> FileNameFormat+fileNameFormat ForDisplay = FileNameFormatDisplay+fileNameFormat ForStorage = FileNameFormatV1++instance ShowPatchBasic Prim where+  showPatch fmt = showPrim (fileNameFormat fmt) . unPrim++instance ShowContextPatch Prim where+  showPatchWithContextAndApply fmt = showPrimWithContextAndApply (fileNameFormat fmt) . unPrim++instance ShowPatch Prim where+  summary = plainSummaryPrim . unPrim+  summaryFL = plainSummaryPrims False+  thing _ = "change"++instance PatchListFormat Prim where+  patchListFormat = ListFormatV1++instance RepairToFL Prim where+  applyAndTryToFixFL = fmap coerce . applyAndTryToFixFL . unPrim
src/Darcs/Patch/V1/Read.hs view
@@ -1,33 +1,34 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Read () where +import Darcs.Prelude+ import Darcs.Patch.Invert ( invert ) import Darcs.Patch.Prim ( PrimPatch ) import Darcs.Patch.Read ( ReadPatch(..) )-import Darcs.Patch.ReadMonads ( ParserM, choice, string,-                                lexChar, myLex', skipSpace )+import Darcs.Util.Parser ( Parser, choice, string,+                                lexChar, lexWord, skipSpace ) -import Darcs.Patch.V1.Core ( Patch(..) )+import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) import Darcs.Patch.V1.Commute ( merger ) -import Darcs.Witnesses.Sealed ( Sealed(..), seal, mapSeal )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal, mapSeal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )  import Control.Monad ( liftM ) import qualified Data.ByteString.Char8 as BC ( unpack, pack ) import qualified Data.ByteString       as B  (ByteString ) -#include "gadts.h" -instance PrimPatch prim => ReadPatch (Patch prim) where+instance PrimPatch prim => ReadPatch (RepoPatchV1 prim) where  readPatch'    = choice [ liftM seal $ skipSpace >> readMerger True             , liftM seal $ skipSpace >> readMerger False-            , liftM (mapSeal PP) $ readPatch'+            , liftM (mapSeal PP) readPatch'             ]-readMerger :: (ParserM m, PrimPatch prim) => Bool -> m (Patch prim C(x y))+readMerger :: (PrimPatch prim) => Bool -> Parser (RepoPatchV1 prim wX wY) readMerger b = do string s-                  g <- myLex'+                  g <- lexWord                   lexChar '('                   Sealed p1 <- readPatch'                   Sealed p2 <- readPatch'
src/Darcs/Patch/V1/Show.hs view
@@ -1,34 +1,30 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Darcs.Patch.V1.Show ( showPatch_ ) where -import Darcs.Patch.Format ( FileNameFormat(..) )-import Darcs.Patch.Prim ( showPrim, PrimPatch )+import Darcs.Prelude -import Darcs.Patch.V1.Core ( Patch(..) )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(..) )+import Darcs.Patch.V1.Core ( RepoPatchV1(..) ) -import Darcs.Witnesses.Show ( Show1(..), Show2(..), ShowDict(..) )+import Darcs.Util.Printer ( Doc, text, blueText, ($$), (<+>) ) -import Printer ( Doc, renderString,-                 text, blueText,-                 ($$), (<+>) ) -#include "gadts.h"--instance PrimPatch prim => Show (Patch prim C(x y))  where-    show p = renderString (showPatch_ p) ++ "\n"-instance PrimPatch prim => Show1 (Patch prim C(x)) where-    showDict1 = ShowDictClass-instance PrimPatch prim => Show2 (Patch prim) where-    showDict2 = ShowDictClass--showPatch_ :: PrimPatch prim => Patch prim C(a b) -> Doc-showPatch_ (PP p) = showPrim OldFormat p-showPatch_ (Merger _ _ p1 p2) = showMerger "merger" p1 p2-showPatch_ (Regrem _ _ p1 p2) = showMerger "regrem" p1 p2+showPatch_ :: ShowPatchBasic prim => prim wX wY -> Doc+showPatch_ = showPatch ForDisplay -showMerger :: PrimPatch prim => String -> Patch prim C(a b) -> Patch prim C(d e) -> Doc-showMerger merger_name p1 p2 =+showMerger :: ShowPatchBasic prim+           => ShowPatchFor+           -> String+           -> RepoPatchV1 prim wA wB+           -> RepoPatchV1 prim wD wE+           -> Doc+showMerger f merger_name p1 p2 =     blueText merger_name <+> text "0.0" <+> blueText "("-                           $$ showPatch_ p1-                           $$ showPatch_ p2+                           $$ showPatch f p1+                           $$ showPatch f p2                            $$ blueText ")"++instance ShowPatchBasic prim => ShowPatchBasic (RepoPatchV1 prim) where+    showPatch f (PP p) = showPatch f p+    showPatch f (Merger _ _ p1 p2) = showMerger f "merger" p1 p2+    showPatch f (Regrem _ _ p1 p2) = showMerger f "regrem" p1 p2
src/Darcs/Patch/V1/Viewing.hs view
@@ -1,24 +1,22 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE ViewPatterns #-} module Darcs.Patch.V1.Viewing () where +import Darcs.Prelude++import Darcs.Patch.Apply ( apply ) import Darcs.Patch.Prim ( PrimPatch )-import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..) )-import Darcs.Patch.Summary ( plainSummary )+import Darcs.Patch.Show ( ShowPatch(..), ShowContextPatch(..), showPatch )+import Darcs.Patch.Summary ( plainSummary, plainSummaryFL )  import Darcs.Patch.V1.Apply ()-import Darcs.Patch.V1.Core ( Patch(..) )-import Darcs.Patch.V1.Show ( showPatch_ )--#include "gadts.h"+import Darcs.Patch.V1.Core ( RepoPatchV1(..) )+import Darcs.Patch.V1.Show () -instance PrimPatch prim => ShowPatchBasic (Patch prim) where-    showPatch = showPatch_+instance PrimPatch prim => ShowContextPatch (RepoPatchV1 prim) where+    showPatchWithContextAndApply f (PP p) = showPatchWithContextAndApply f p+    showPatchWithContextAndApply f p = apply p >> return (showPatch f p) -instance PrimPatch prim => ShowPatch (Patch prim) where-    showContextPatch (PP p) = showContextPatch p-    showContextPatch p = return $ showPatch p+instance PrimPatch prim => ShowPatch (RepoPatchV1 prim) where     summary = plainSummary-    summaryFL = plainSummary+    summaryFL = plainSummaryFL     thing _ = "change"-
src/Darcs/Patch/V2.hs view
@@ -1,9 +1,3 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Patch.V2 ( RealPatch, prim2real ) where--import Darcs.Patch.Prim ( PrimPatch )-import Darcs.Patch.RepoPatch ( RepoPatch )--import Darcs.Patch.V2.Real ( RealPatch, prim2real )+module Darcs.Patch.V2 ( RepoPatchV2 ) where -instance PrimPatch prim => RepoPatch (RealPatch prim)+import Darcs.Patch.V2.RepoPatch ( RepoPatchV2 )
src/Darcs/Patch/V2/Non.hs view
@@ -16,9 +16,8 @@ -- Boston, MA 02110-1301, USA.  {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}-{-# LANGUAGE CPP, FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE UndecidableInstances #-} -#include "gadts.h"  module Darcs.Patch.V2.Non     ( Non(..)@@ -40,103 +39,109 @@     , (>>*)     ) where -import Prelude hiding ( rem )+import Darcs.Prelude hiding ( (*>) )+ import Data.List ( delete ) import Control.Monad ( liftM, mzero )+import Darcs.Patch.Apply ( Apply(..) ) import Darcs.Patch.Commute ( commuteFL ) import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.Format ( PatchListFormat, FileNameFormat(..) )+import Darcs.Patch.Format ( PatchListFormat ) import Darcs.Patch.Invert ( Invert, invertFL, invertRL )-import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..),-                          PrimOf, PrimPatchBase,-                          showPrim, sortCoalesceFL,-                          readPrim )-import Darcs.Patch.Patchy ( Patchy, showPatch, ReadPatch(..),-                            Commute(..), invert )-import Darcs.Patch.ReadMonads ( ParserM, lexChar )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (+>+), mapRL_RL-                               , (:>)(..), reverseFL, reverseRL )+import Darcs.Patch.FromPrim+    ( FromPrim(..), ToFromPrim+    , PrimOf, PrimPatchBase, toPrim+    )+import Darcs.Patch.Prim ( sortCoalesceFL )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( Invert(invert) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Show ( showPatch )+import Darcs.Util.Parser ( Parser, lexChar )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), RL(..), (+>+), mapRL_RL+    , (:>)(..), reverseFL, reverseRL )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) ) import Darcs.Patch.Read ( peekfor )-import Darcs.Patch.Show ( ShowPatchBasic )+import Darcs.Patch.Show ( ShowPatchBasic, ShowPatchFor ) import Darcs.Patch.Viewing ()-import Darcs.Patch.Permutations ( removeFL, commuteWhatWeCanFL )-import Darcs.Witnesses.Show ( ShowDict(..), Show1(..), Show2(..), appPrec-                            , showsPrec2 )-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Printer ( Doc, empty, vcat, hiddenPrefix, blueText, ($$) )+import Darcs.Patch.Permutations ( (=\~/=), removeFL, commuteWhatWeCanFL )+import Darcs.Util.Printer ( Doc, empty, vcat, hiddenPrefix, blueText, ($$) ) import qualified Data.ByteString.Char8 as BC ( pack, singleton )  -- |A 'Non' stores a context with a 'Prim' patch. It is a patch whose effect -- isn't visible - a Non-affecting patch.-data Non p C(x) where-    Non :: FL p C(x y) -> PrimOf p C(y z) -> Non p C(x)+data Non p wX where+    Non :: FL p wX wY -> PrimOf p wY wZ -> Non p wX  -- |unNon converts a Non into a FL of its context followed by the primitive -- patch.-unNon :: FromPrim p => Non p C(x) -> Sealed (FL p C(x))-unNon (Non c x) = Sealed (c +>+ fromPrim x :>: NilFL)+unNon :: FromPrim p => Non p wX -> Sealed (FL p wX)+unNon (Non c x) = Sealed (c +>+ fromAnonymousPrim x :>: NilFL) -instance (Show2 p, Show2 (PrimOf p)) => Show (Non p C(x)) where+instance (Show2 p, Show2 (PrimOf p)) => Show (Non p wX) where     showsPrec d (Non cs p) = showParen (d > appPrec) $ showString "Non " .                              showsPrec2 (appPrec + 1) cs . showString " " .                              showsPrec2 (appPrec + 1) p -instance (Show2 p, Show2 (PrimOf p)) => Show1 (Non p) where-    showDict1 = ShowDictClass+instance (Show2 p, Show2 (PrimOf p)) => Show1 (Non p)  -- |showNons creates a Doc representing a list of Nons. showNons :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p)-         => [Non p C(x)] -> Doc-showNons [] = empty-showNons xs = blueText "{{" $$ vcat (map showNon xs) $$ blueText "}}"+         => ShowPatchFor -> [Non p wX] -> Doc+showNons _ [] = empty+showNons f xs = blueText "{{" $$ vcat (map (showNon f) xs) $$ blueText "}}"  -- |showNon creates a Doc representing a Non.-showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p) => Non p C(x)+showNon :: (ShowPatchBasic p, PatchListFormat p, PrimPatchBase p)+        => ShowPatchFor+        -> Non p wX         -> Doc-showNon (Non c p) = hiddenPrefix "|" (showPatch c)-                    $$ hiddenPrefix "|" (blueText ":")-                    $$ showPrim NewFormat p+showNon f (Non c p) = hiddenPrefix "|" (showPatch f c)+                      $$ hiddenPrefix "|" (blueText ":")+                      $$ showPatch f p  -- |readNons is a parser that attempts to read a list of Nons.-readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m)-         => m [Non p C(x)]+readNons :: (ReadPatch p, PatchListFormat p, PrimPatchBase p)+         => Parser [Non p wX] readNons = peekfor (BC.pack "{{") rns (return [])   where rns = peekfor (BC.pack "}}") (return []) $               do Sealed ps <- readPatch'                  lexChar ':'-                 Sealed p <- readPrim NewFormat+                 Sealed p <- readPatch'                  (Non ps p :) `liftM` rns  -- |readNon is a parser that attempts to read a single Non.-readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p, ParserM m)-        => m (Non p C(x))+readNon :: (ReadPatch p, PatchListFormat p, PrimPatchBase p)+        => Parser (Non p wX) readNon = do Sealed ps <- readPatch'-             let doReadPrim = do Sealed p <- readPrim NewFormat+             let doReadPrim = do Sealed p <- readPatch'                                  return $ Non ps p              peekfor (BC.singleton ':') doReadPrim mzero  -- |Nons are equal if their context patches are equal, and they have an equal -- prim patch.-instance (Commute p, MyEq p, MyEq (PrimOf p)) => Eq (Non p C(x)) where-    Non (cx :: FL p C(x y1)) (x :: PrimOf p C(y1 z1))-     == Non (cy :: FL p C(x y2)) (y :: PrimOf p C(y2 z2)) =-      case cx =\/= cy of-        IsEq -> case x =\/= y :: EqCheck C(z1 z2) of+instance (Commute p, Eq2 p, Eq2 (PrimOf p)) => Eq (Non p wX) where+    Non (cx :: FL p wX wY1) (x :: PrimOf p wY1 wZ1)+     == Non (cy :: FL p wX wY2) (y :: PrimOf p wY2 wZ2) =+      case cx =\~/= cy of+        IsEq -> case x =\/= y :: EqCheck wZ1 wZ2 of                   IsEq -> True                   NotEq -> False         NotEq -> False  -- |Nonable represents the class of patches that can be turned into a Non. class Nonable p where-    non :: p C(x y) -> Non p C(x)+    non :: p wX wY -> Non p wX  -- |'commuteOrAddToCtx' @x cy@ tries to commute @x@ past @cy@ and always -- returns some variant @cy'@. If commutation suceeds, the variant is just -- straightforwardly the commuted version. If commutation fails, the variant -- consists of @x@ prepended to the context of @cy@.-commuteOrAddToCtx :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y)-                  -> Non p C(x)+commuteOrAddToCtx :: (Commute p, ToFromPrim p) => p wX wY -> Non p wY+                  -> Non p wX commuteOrAddToCtx p n | Just n' <- p >* n = n' commuteOrAddToCtx p (Non c x) = Non (p:>:c) x @@ -152,32 +157,29 @@ -- > x1 [c1'' c2'' y''] x2' x3' -- -- and return @[x1 c1'' c2'' y'']@-commuteOrAddToCtxRL :: (Patchy p, ToFromPrim p) => RL p C(x y) -> Non p C(y)-                    -> Non p C(x)+commuteOrAddToCtxRL :: (Apply p, Commute p, Invert p, ToFromPrim p) => RL p wX wY -> Non p wY+                    -> Non p wX commuteOrAddToCtxRL NilRL n = n-commuteOrAddToCtxRL (p:<:ps) n = commuteOrAddToCtxRL ps $ commuteOrAddToCtx p n+commuteOrAddToCtxRL (ps:<:p) n = commuteOrAddToCtxRL ps $ commuteOrAddToCtx p n  -- |abstract over 'FL'/'RL' class WL l where-   toFL :: l p C(x y) -> FL p C(x y)-   toRL :: l p C(x y) -> RL p C(x y)-   invertWL :: Invert p => l p C(x y) -> l p C(y x)+   toRL :: l p wX wY -> RL p wX wY+   invertWL :: Invert p => l p wX wY -> l p wY wX  instance WL FL where-   toFL = id    toRL = reverseFL    invertWL = reverseRL . invertFL  instance WL RL where-   toFL = reverseRL    toRL = id    invertWL = reverseFL . invertRL  -- |commutePrimsOrAddToCtx takes a WL of prims and attempts to commute them -- past a Non.-commutePrimsOrAddToCtx :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) C(x y)-         -> Non p C(y) -> Non p C(x)-commutePrimsOrAddToCtx q = commuteOrAddToCtxRL (mapRL_RL fromPrim $ toRL q)+commutePrimsOrAddToCtx :: (WL l, Apply p, Commute p, Invert p, ToFromPrim p) => l (PrimOf p) wX wY+         -> Non p wY -> Non p wX+commutePrimsOrAddToCtx q = commuteOrAddToCtxRL (mapRL_RL fromAnonymousPrim $ toRL q)  -- TODO: Figure out what remNons is for; it's is only used in one place - when -- commuting two Conflictors:@@ -194,22 +196,22 @@ -- modify p2, so that it doesn't have any of a1' in its context.  -- remNons really only works right if the relevant nons are conflicting...-remNons :: (Nonable p, Effect p, Patchy p, ToFromPrim p, PrimPatchBase p,-        MyEq (PrimOf p)) => [Non p C(x)] -> Non p C(x) -> Non p C(x)+remNons :: (Nonable p, Effect p, Apply p, Commute p, Invert p, Eq2 p, ToFromPrim p, PrimPatchBase p)+        => [Non p wX] -> Non p wX -> Non p wX remNons ns n@(Non c x) = case remNonHelper ns c of                              NilFL :> c' -> Non c' x                              _ -> n   where-    remNonHelper :: (Nonable p, Effect p, Patchy p, ToFromPrim p,-                 PrimPatchBase p, MyEq (PrimOf p)) => [Non p C(x)]-                 -> FL p C(x y) -> (FL (PrimOf p) :> FL p) C(x y)+    remNonHelper :: (Nonable p, Effect p, Apply p, Commute p, Invert p, Eq2 p, ToFromPrim p,+                 PrimPatchBase p) => [Non p wX]+                 -> FL p wX wY -> (FL (PrimOf p) :> FL p) wX wY     remNonHelper [] x = NilFL :> x     remNonHelper _ NilFL = NilFL :> NilFL     remNonHelper ns (c:>:cs)         | non c `elem` ns =           let nsWithoutC = delete (non c) ns in           let commuteOrAddInvC = commuteOrAddToCtx $ invert c in-          case remNonHelper (map commuteOrAddInvC $ nsWithoutC) cs of+          case remNonHelper (map commuteOrAddInvC nsWithoutC) cs of               a :> z -> sortCoalesceFL (effect c +>+ a) :> z         | otherwise = case commuteWhatWeCanFL (c :> cs) of                           b :> c' :> d -> case remNonHelper ns b of@@ -223,44 +225,44 @@ -- -- TODO: understand if there is any case where p is equal to the prim patch of -- the Non, in which case, we return the original Non, is that right?-commuteOrRemFromCtx :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(x)-     -> Maybe (Non p C(y))+commuteOrRemFromCtx :: (Commute p, Invert p, Eq2 p, ToFromPrim p) => p wX wY -> Non p wX+     -> Maybe (Non p wY) commuteOrRemFromCtx p n | n'@(Just _) <- n *> p = n' commuteOrRemFromCtx p (Non pc x) = removeFL p pc >>= \c -> return (Non c x)  -- |commuteOrRemFromCtxFL attempts to remove a FL of patches from a Non, -- returning Nothing if any of the individual removes fail.-commuteOrRemFromCtxFL :: (Patchy p, ToFromPrim p) => FL p C(x y) -> Non p C(x)-                      -> Maybe (Non p C(y))+commuteOrRemFromCtxFL :: (Apply p, Commute p, Invert p, Eq2 p, ToFromPrim p) => FL p wX wY -> Non p wX+                      -> Maybe (Non p wY) commuteOrRemFromCtxFL NilFL n = Just n commuteOrRemFromCtxFL (p:>:ps) n = do n' <- commuteOrRemFromCtx p n                                       commuteOrRemFromCtxFL ps n'  -- |(*>) attemts to modify a Non by commuting it past a given patch.-(*>) :: (Patchy p, ToFromPrim p) => Non p C(x) -> p C(x y)-     -> Maybe (Non p C(y))+(*>) :: (Commute p, Invert p, ToFromPrim p) => Non p wX -> p wX wY+     -> Maybe (Non p wY) n *> p = invert p >* n  -- |(>*) attempts to modify a Non, by commuting a given patch past it.-(>*) :: (Patchy p, ToFromPrim p) => p C(x y) -> Non p C(y)-     -> Maybe (Non p C(x))+(>*) :: (Commute p, ToFromPrim p) => p wX wY -> Non p wY+     -> Maybe (Non p wX) y >* (Non c x) = do     c' :> y' <- commuteFL (y :> c)-    px' :> _ <- commute (y' :> fromPrim x)+    px' :> _ <- commute (y' :> fromAnonymousPrim x)     x' <- toPrim px'     return (Non c' x')  -- |(*>>) attempts to modify a Non by commuting it past a given WL of patches.-(*>>) :: (WL l, Patchy p, ToFromPrim p, PrimPatchBase p) => Non p C(x)-      -> l (PrimOf p) C(x y) -> Maybe (Non p C(y))+(*>>) :: (WL l, Apply p, Commute p, Invert p, ToFromPrim p, PrimPatchBase p) => Non p wX+      -> l (PrimOf p) wX wY -> Maybe (Non p wY) n *>> p = invertWL p >>* n  -- |(>>*) attempts to modify a Non by commuting a given WL of patches past it.-(>>*) :: (WL l, Patchy p, ToFromPrim p) => l (PrimOf p) C(x y) -> Non p C(y)-      -> Maybe (Non p C(x))+(>>*) :: (WL l, Apply p, Commute p, Invert p, ToFromPrim p) => l (PrimOf p) wX wY -> Non p wY+      -> Maybe (Non p wX) ps >>* n = commuteRLPastNon (toRL ps) n   where-    commuteRLPastNon :: (Patchy p, ToFromPrim p) => RL (PrimOf p) C(x y)-                     -> Non p C(y) -> Maybe (Non p C(x))+    commuteRLPastNon :: (Apply p, Commute p, Invert p, ToFromPrim p) => RL (PrimOf p) wX wY+                     -> Non p wY -> Maybe (Non p wX)     commuteRLPastNon NilRL n = Just n-    commuteRLPastNon (x:<:xs) n = fromPrim x >* n >>= commuteRLPastNon xs+    commuteRLPastNon (xs:<:x) n = fromAnonymousPrim x >* n >>= commuteRLPastNon xs
+ src/Darcs/Patch/V2/Prim.hs view
@@ -0,0 +1,95 @@+-- it is stupid that we need UndecidableInstances just to call another+-- type function (see instance Apply below which requires this)+{-# LANGUAGE UndecidableInstances #-}+module Darcs.Patch.V2.Prim ( Prim(..) ) where++import Darcs.Prelude++import Data.Coerce (coerce )++import Darcs.Patch.Annotate ( Annotate )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.FileHunk ( IsHunk )+import Darcs.Patch.Format+    ( PatchListFormat(..)+    , ListFormat(ListFormatV2)+    , FileNameFormat(FileNameFormatV2,FileNameFormatDisplay) )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.Merge ( CleanMerge )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Repair ( RepairToFL(..) )+import Darcs.Patch.Show+    ( ShowPatchBasic(..)+    , ShowPatchFor(..)+    , ShowPatch(..)+    , ShowContextPatch(..)+    )+import Darcs.Patch.Summary ( plainSummaryPrim, plainSummaryPrims )++import Darcs.Patch.Witnesses.Eq ( Eq2 )+import Darcs.Patch.Witnesses.Show ( Show1, Show2 )+import Darcs.Patch.Witnesses.Sealed ( mapSeal )++import Darcs.Patch.Prim.Class+    ( PrimConstruct(..), PrimCoalesce(..)+    , PrimDetails(..)+    , PrimShow(..), PrimRead(..)+    , PrimApply(..)+    , PrimSift(..)+    , PrimMangleUnravelled(..)+    )+import qualified Darcs.Patch.Prim.V1 as Base ( Prim )++newtype Prim x y = Prim { unPrim :: Base.Prim x y } deriving+    ( Annotate+    , Apply+    , CleanMerge+    , Commute+    , Invert+    , IsHunk+    , Eq2+    , PatchInspect+    , PrimApply+    , PrimCoalesce+    , PrimConstruct+    , PrimDetails+    , PrimMangleUnravelled+    , PrimSift+    , Show+    )++instance Show1 (Prim wX)++instance Show2 Prim++instance ReadPatch Prim where+  readPatch' = fmap (mapSeal Prim) (readPrim FileNameFormatV2)++fileNameFormat :: ShowPatchFor -> FileNameFormat+fileNameFormat ForDisplay = FileNameFormatDisplay+fileNameFormat ForStorage = FileNameFormatV2++instance ShowPatchBasic Prim where+  showPatch fmt = showPrim (fileNameFormat fmt) . unPrim++instance ShowContextPatch Prim where+  showPatchWithContextAndApply fmt = showPrimWithContextAndApply (fileNameFormat fmt) . unPrim++instance ShowPatch Prim where+  summary = plainSummaryPrim . unPrim+  summaryFL = plainSummaryPrims False+  thing _ = "change"++-- This instance is here so that FL Prim and RL Prim also get+-- ShowPatch instances, see Darcs.Patch.Viewing+instance PatchListFormat Prim where+  -- In principle we could use ListFormatDefault when prim /= V1 Prim patches,+  -- as those are the only case where we need to support a legacy on-disk+  -- format. In practice we don't expect RepoPatchV2 to be used with any other+  -- argument anyway, so it doesn't matter.+  patchListFormat = ListFormatV2++instance RepairToFL Prim where+  applyAndTryToFixFL = fmap coerce . applyAndTryToFixFL . unPrim
− src/Darcs/Patch/V2/Real.hs 
@@ -1,914 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-name-shadowing #-}-{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Patch.V2.Real-    ( RealPatch(..)-    , prim2real-    , isConsistent-    , isForward-    , isDuplicate-    , mergeUnravelled-    ) where--import Control.Monad ( mplus, liftM )-import qualified Data.ByteString.Char8 as BC ( ByteString, pack )-import Data.Maybe ( fromMaybe )-import Data.List ( partition, nub )--import Darcs.ColorPrinter ( errorDoc, assertDoc )-import Darcs.Patch.Commute ( commuteFL, commuteFLorComplain, commuteRL-                           , commuteRLFL )-import Darcs.Patch.Conflict ( Conflict(..), CommuteNoConflicts(..)-                            , IsConflictedPrim(..), ConflictState(..) )-import Darcs.Patch.ConflictMarking ( mangleUnravelled )-import Darcs.Patch.Effect ( Effect(..) )-import Darcs.Patch.FileHunk ( IsHunk(..) )-import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..)-                          , FileNameFormat(NewFormat) )-import Darcs.Patch.Invert ( invertFL, invertRL )-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Prim ( FromPrim(..), ToFromPrim(..), showPrim, showPrimFL-                        , readPrim, PrimOf, PrimPatchBase, PrimPatch )-import Darcs.Patch.Read ( bracketedFL )-import Darcs.Patch.ReadMonads ( skipSpace, string, choice )-import Darcs.Patch.Repair ( mapMaybeSnd, RepairToFL(..), Check(..) )-import Darcs.Patch.Patchy ( Patchy, Apply(..), Commute(..), PatchInspect(..)-                          , ReadPatch(..), ShowPatch(..), Invert(..) )-import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL-                                , genCommuteWhatWeCanRL, removeRL, removeFL-                                , removeSubsequenceFL )-import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Patch.Summary ( plainSummary )-import Darcs.Patch.V2.Non ( Non(..), Nonable(..), unNon, showNons, showNon-                          , readNons, readNon, commutePrimsOrAddToCtx-                          , commuteOrAddToCtx, commuteOrAddToCtxRL-                          , commuteOrRemFromCtx, commuteOrRemFromCtxFL-                          , remNons, (*>), (>*), (*>>), (>>*) )-import Darcs.Utils ( nubsort )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+), (+<+)-                               , mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..)-                               , reverseRL, lengthFL, lengthRL, nullFL )-import Darcs.Witnesses.Sealed ( FlippedSeal(..), Sealed(Sealed), mapSeal-                              , unseal )-import Darcs.Witnesses.Show ( Show2(..), ShowDict(..) )--import Printer ( Doc, renderString, blueText, redText, (<+>), ($$) )--#include "impossible.h"---- |'RealPatch' is used to represents prim patches that are duplicates of, or--- conflict with, another prim patch in the repository.------ @Normal prim@: A primitive patch------ @Duplicate x@: This patch has no effect since @x@ is already present in the--- repository.------ @Etacilpud x: invert (Duplicate x)@------ @Conflictor ix xx x@:--- @ix@ is the set of patches:---   * that conflict with @x@ and also conflict with another patch in the---     repository.---   * that conflict with a patch that conflict with @x@------ @xx@ is the sequence of patches that conflict *only* with @x@------ @x@ is the original, conflicting patch.------ @ix@ and @x@ are stored as @Non@ objects, which include any necessary---  context to uniquely define the patch that is referred to.------ The intuition is that a Conflictor should have the effect of inverting any--- patches that 'x' conflicts with, that haven't already been undone by another--- Conflictor in the repository.--- Therefore, the effect of a Conflictor is @invert xx@.------ @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@-data RealPatch prim C(x y) where-    Duplicate :: Non (RealPatch prim) C(x) -> RealPatch prim C(x x)-    Etacilpud :: Non (RealPatch prim) C(x) -> RealPatch prim C(x x)-    Normal :: prim C(x y) -> RealPatch prim C(x y)-    Conflictor :: [Non (RealPatch prim) C(x)] -> FL prim C(x y)-               -> Non (RealPatch prim) C(x) -> RealPatch prim C(y x)-    InvConflictor :: [Non (RealPatch prim) C(x)] -> FL prim C(x y)-                  -> Non (RealPatch prim) C(x) -> RealPatch prim C(x y)--instance PrimPatch prim => PrimPatchBase (RealPatch prim) where-   type PrimOf (RealPatch prim) = prim---- | 'isDuplicate' @p@ is @True@ if @p@ is either a 'Duplicate' or 'Etacilpud'--- patch.-isDuplicate :: RealPatch prim C(s y) -> Bool-isDuplicate (Duplicate _) = True-isDuplicate (Etacilpud _) = True-isDuplicate _ = False---- | 'isForward' @p@ is @True@ if @p@ is either an 'InvConflictor' or--- 'Etacilpud'.-isForward :: PrimPatch prim => RealPatch prim C(s y) -> Maybe Doc-isForward p = case p of-    p@(InvConflictor _ _ _) -> justRedP "An inverse conflictor" p-    p@(Etacilpud _) -> justRedP "An inverse duplicate" p-    _ -> Nothing-  where-    justRedP msg p = Just $ redText msg $$ showPatch p---- |'mergeUnravelled' is used when converting from Darcs V1 patches (Mergers)--- to Darcs V2 patches (Conflictors).-mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) C(x))]-                -> Maybe (FlippedSeal (RealPatch prim) C(x))-mergeUnravelled [] = Nothing-mergeUnravelled [_] = Nothing-mergeUnravelled ws =-    case mergeUnravelled_private ws of-        Nothing -> Nothing-        Just NilRL -> bug "found no patches in mergeUnravelled"-        Just (z :<: _) -> Just $ FlippedSeal z-  where-    notNullS :: PrimPatch prim => Sealed ((FL prim) C(x)) -> Bool-    notNullS (Sealed NilFL) = False-    notNullS _ = True--    mergeUnravelled_private :: PrimPatch prim => [Sealed (FL prim C(x))]-                            -> Maybe (RL (RealPatch prim) C(x x))-    mergeUnravelled_private xs = let nonNullXs = filter notNullS xs in-        reverseFL `fmap` mergeConflictingNons (map sealed2non nonNullXs)--    -- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'.-    -- @xs@ must be non-empty since we split this list at the last patch,-    -- taking @init xs@ as the context of @last xs@.-    sealed2non :: Sealed ((FL prim) C(x)) -> Non (RealPatch prim) C(x)-    sealed2non (Sealed xs) =-        case reverseFL xs of-            y :<: ys -> Non (mapFL_FL fromPrim $ reverseRL ys) y-            NilRL -> bug "NilFL encountered in sealed2non"--mergeConflictingNons :: PrimPatch prim => [Non (RealPatch prim) C(x)]-                     -> Maybe (FL (RealPatch prim) C(x x))-mergeConflictingNons ns = mcn $ map unNon ns-    where mcn :: PrimPatch prim => [Sealed (FL (RealPatch prim) C(x))]-              -> Maybe (FL (RealPatch prim) C(x x))-          mcn [] = Just NilFL-          -- Apparently, the joinEffects call is a safety check "and could be-          -- removed when we're sure of the code"!-          mcn [Sealed p] = case joinEffects p of-                               NilFL -> Just p-                               _ -> Nothing-          mcn (Sealed p1:Sealed p2:zs) =-            case pullCommon p1 p2 of-                Common c ps qs ->-                    case merge (ps :\/: qs) of-                        qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs)--joinEffects :: forall p C(x y) . (Effect p, Invert (PrimOf p),-            Commute (PrimOf p), MyEq (PrimOf p)) => p C(x y)-            -> FL (PrimOf p) C(x y)-joinEffects = joinInverses . effect-    where joinInverses :: FL (PrimOf p) C(a b) -> FL (PrimOf p) C(a b)-          joinInverses NilFL = NilFL-          joinInverses (p :>: ps) =-              let ps' = joinInverses ps in-              fromMaybe (p :>: ps') $ removeFL (invert p) ps'--assertConsistent :: PrimPatch prim => RealPatch prim C(x y)-                 -> RealPatch prim C(x y)-assertConsistent x = flip assertDoc x $ do-    e <- isConsistent x-    Just (redText "Inconsistent patch:" $$ showPatch x $$ e)---- | @mergeAfterConflicting@ takes as input a sequence of conflicting patches--- @xxx@ (which therefore have no effect) and a sequence of primitive patches--- @yyy@ that follow said sequence of conflicting patches, and may depend upon--- some of the conflicting patches (as a resolution).---- The output is two sequences of patches the first consisting of a set of--- mutually-conflicting patches, and the second having the same effect as the--- original primitive patch sequence in the input.---- So far as I can tell, the second output is always identical to @mapFL Normal--- yyy@---- The first output is the set of patches from @xxx@ that are depended upon by--- @yyy@.-mergeAfterConflicting :: PrimPatch prim => FL (RealPatch prim) C(x x)-                      -> FL prim C(x y) -> Maybe ( FL (RealPatch prim) C(x x)-                                                 , FL (RealPatch prim) C(x y))-mergeAfterConflicting xxx yyy = mac (reverseFL xxx) yyy NilFL-  where-    mac :: PrimPatch prim-        => RL (RealPatch prim) C(x y) -> FL prim C(y z)-        -> FL (RealPatch prim) C(z a)-        -> Maybe (FL (RealPatch prim) C(x x), FL (RealPatch prim) C(x a))-    mac NilRL xs goneby = case joinEffects goneby of-                              NilFL -> Just (NilFL, mapFL_FL Normal xs)-                              _ -> Nothing-    mac (p :<: ps) xs goneby =-        case commuteFLorComplain (p :> mapFL_FL Normal xs) of-            Left _ ->-                case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of-                    a :> p' :> b ->-                        do (b', xs') <- mac b xs goneby-                           let pa = joinEffects $ p' :<: a-                           NilFL <- return pa-                           return (reverseRL (p' :<: a) +>+ b', xs')-                        `mplus`-                        do NilFL <- return goneby-                           NilFL <- return $ joinEffects (p :<: ps)-                           return (reverseRL (p :<: ps), mapFL_FL Normal xs)-            Right (l :> p'') ->-                case allNormal l of-                    Just xs'' -> mac ps xs'' (p'' :>: goneby)-                    Nothing ->-                        case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of-                            a :> p' :> b ->-                                do (b', xs') <- mac b xs goneby-                                   let pa = joinEffects $ p' :<: a-                                   NilFL <- return pa-                                   return (reverseRL (p' :<: a) +>+ b', xs')--geteff :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y)-       -> ([Non (RealPatch prim) C(x)], FL (RealPatch prim) C(x y))-geteff _ NilFL = ([], NilFL)-geteff ix (x :>: xs) | Just ix' <- mapM (commuteOrRemFromCtx (Normal x)) ix =-    case geteff ix' xs of-        (ns, xs') -> ( non (Normal x) : map (commuteOrAddToCtx (Normal x)) ns-                     , Normal x :>: xs')-geteff ix xx =-    case mergeConflictingNons ix of-        Nothing -> errorDoc $-            redText "mergeConflictingNons failed in geteff: ix" $$-            showNons ix $$ redText "xx" $$ showPatch xx-        Just rix ->-            case mergeAfterConflicting rix xx of-                Just (a, x) ->-                    ( map (commuteOrAddToCtxRL (reverseFL a)) $ toNons x-                    , a +>+ x)-                Nothing ->-                    errorDoc $-                        redText "mergeAfterConflicting failed in geteff" $$-                        redText "where ix" $$ showNons ix $$-                        redText "and xx" $$ showPatch xx $$-                        redText "and rix" $$ showPatch rix--xx2nons :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y)-        -> [Non (RealPatch prim) C(x)]-xx2nons ix xx = fst $ geteff ix xx--xx2patches :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> FL prim C(x y)-           -> FL (RealPatch prim) C(x y)-xx2patches ix xx = snd $ geteff ix xx---- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns---   @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@).---   Otherwise, it returns 'Nothing'.-allNormal :: FL (RealPatch prim) C(x y) -> Maybe (FL prim C(x y))-allNormal (Normal x :>: xs) = (x  :>: ) `fmap` allNormal xs-allNormal NilFL = Just NilFL-allNormal _ = Nothing---- | This is used for unit-testing and for internal sanity checks-isConsistent :: PrimPatch prim => RealPatch prim C(x y) -> Maybe Doc-isConsistent (Normal _) = Nothing-isConsistent (Duplicate _) = Nothing-isConsistent (Etacilpud _) = Nothing-isConsistent c@(InvConflictor _ _ _) = isConsistent (invert c)-isConsistent (Conflictor im mm m@(Non deps _))-    | not $ everyoneConflicts im =-        Just $ redText "Someone doesn't conflict in im in isConsistent"-    | Just _ <- commuteOrRemFromCtxFL rmm m, _ :>: _ <- mm =-        Just $ redText "m doesn't conflict with mm in isConsistent"-    | any (\x -> any (x `conflictsWith`) nmm) im =-        Just $ redText "mm conflicts with im in isConsistent where nmm is" $$-               showNons nmm-    | Nothing <- (nmm ++ im) `minus` toNons deps =-        Just $ redText "dependencies not in conflict:" $$-               showNons (toNons deps) $$-               redText "compared with deps itself:" $$-               showPatch deps-    | otherwise =-        case allConflictsWith m im of-            (im1, []) | im1 `eqSet` im -> Nothing-            (_, imnc) -> Just $ redText ("m doesn't conflict with im in "-                                         ++ "isConsistent. unconflicting:") $$-                                showNons imnc-    where (nmm, rmm) = geteff im mm--everyoneConflicts :: PrimPatch prim => [Non (RealPatch prim) C(x)] -> Bool-everyoneConflicts [] = True-everyoneConflicts (x : xs) = case allConflictsWith x xs of-                                 ([], _) -> False-                                 (_, xs') -> everyoneConflicts xs'--prim2real :: prim C(x y) -> RealPatch prim C(x y)-prim2real = Normal--instance PrimPatch prim => Patchy (RealPatch prim)--mergeWith :: PrimPatch prim => Non (RealPatch prim) C(x)-          -> [Non (RealPatch prim) C(x)] -> Sealed (FL prim C(x))-mergeWith p [] = effect `mapSeal` unNon p-mergeWith p xs =-    mergeall . map unNon . (p :) . unconflicting_of $ nonDependsOrConflictsP xs-  where-    nonDependsOrConflictsP =-        filter (\x -> not ((p `dependsUpon` x) || (p `conflictsWith` x)))-    mergeall :: PrimPatch prim => [Sealed (FL (RealPatch prim) C(x))]-             -> Sealed (FL prim C(x))-    mergeall [Sealed x] = Sealed $ effect x-    mergeall [] = Sealed NilFL-    mergeall (Sealed x : Sealed y : rest) =-        case merge (x :\/: y) of-            y' :/\: _ -> mergeall (Sealed (x +>+ y') : rest)-    unconflicting_of [] = []-    unconflicting_of (q : qs) = case allConflictsWith q qs of-                                    ([], _) -> q : qs-                                    (_, nc) -> unconflicting_of nc--instance PrimPatch prim => Conflict (RealPatch prim) where-    conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x]-    conflictedEffect (Etacilpud _) = impossible-    conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x]-    conflictedEffect (InvConflictor _ _ _) = impossible-    conflictedEffect (Normal x) = [IsC Okay x]-    resolveConflicts (Conflictor ix xx x) = [mangledUnravelled : unravelled]-      where-        mangledUnravelled = mangleUnravelled unravelled-        unravelled = nub $ filter isCons $ map (`mergeWith` xIxNonXX) xIxNonXX-        xIxNonXX = x : ix ++ nonxx-        nonxx = nonxx_ (reverseFL $ xx2patches ix xx)-        -- |nonxx_ takes an RL of patches, and returns a singleton list-        -- containing a Non, in the case where we have a Normal patch at the-        -- end of the list (using the rest of the RL as context), and an empty-        -- list otherwise.-        nonxx_ :: RL (RealPatch prim) C(x y) -> [Non (RealPatch prim) C(x)]-        nonxx_ (Normal q :<: qs) = [Non (reverseRL qs) q]-        nonxx_ _ = []-        isCons = unseal (not . nullFL)-    resolveConflicts _ = []--instance PrimPatch prim => CommuteNoConflicts (RealPatch prim) where-    commuteNoConflicts (d1@(Duplicate _) :> d2@(Duplicate _)) = Just (d2 :> d1)-    commuteNoConflicts (e@(Etacilpud _) :> d@(Duplicate _)) = Just (d :> e)-    commuteNoConflicts (d@(Duplicate _) :> e@(Etacilpud _)) = Just (e :> d)-    commuteNoConflicts (e1@(Etacilpud _) :> e2@(Etacilpud _)) = Just (e2 :> e1)--    -- If the duplicate is @x@, as a 'Non', with @invert x@ as the context,-    -- then it is the patch the duplicate @d@ represents, so commuting results-    -- in the same two patches (since we'd make one a duplicate, and the other-    -- would become @x@ as it would no longer be duplicated).-    -- Otherwise, we commute past, or remove @invert x@ from the context of @d@-    -- to obtain a new Duplicate.-    commuteNoConflicts orig@(x :> Duplicate d) =-        if d == commuteOrAddToCtx (invert x) (non x)-            then Just orig-            else do d' <- commuteOrRemFromCtx (invert x) d-                    return (Duplicate d' :> x)--    -- Commuting a Duplicate and any other patch simply places @invert x@ into-    -- the context of the non @d@, by commuting past, or adding to the context.-    commuteNoConflicts (Duplicate d :> x) =-        Just (x :> Duplicate (commuteOrAddToCtx (invert x) d))--    -- handle Etacilpud cases by first inverting, then using the previous-    -- definitions.-    commuteNoConflicts c@(Etacilpud _ :> _) = invertCommuteNC c-    commuteNoConflicts c@(_ :> Etacilpud _) = invertCommuteNC c--    -- Two normal patches should be simply commuted (assuming the can).-    commuteNoConflicts (Normal x :> Normal y) = do-        y' :> x' <- commute (x :> y)-        return (Normal y' :> Normal x')--    -- Commuting a Normal patch past a Conflictor first commutes @x@ past the-    -- effect of the Conflictor, then commutes the resulting @x'@ past the-    -- conflicting patch and the already-undone patches. The commuting must be-    -- done in this order to make the contexts match up (@iy@ and @y@ are made-    -- in the context before @yy@ have their effect, so we need to commute past-    -- the effect of @yy@ first).-    commuteNoConflicts (Normal x :> Conflictor iy yy y) = do-        iyy' :> x' <- commuteFL (x :> invert yy)-        y' : iy' <- mapM (Normal x' >*) (y : iy)-        return (Conflictor iy' (invert iyy') y' :> Normal x')--    -- Handle via the previous case, using the inverting commuter.-    commuteNoConflicts c@(InvConflictor _ _ _ :> Normal _) = invertCommuteNC c--    -- Commuting a Conflictor past a Normal patch is the dual operation to-    -- commuting a Normal patch past a Conflictor.-    commuteNoConflicts (Conflictor iy yy y :> Normal x) = do-        y' : iy' <- mapM (*> Normal x) (y : iy)-        x' :> iyy' <- commuteRL (invertFL yy :> x)-        return (Normal x' :> Conflictor iy' (invertRL iyy') y')--    -- Handle via the previous case, using the inverting commuter.-    commuteNoConflicts c@(Normal _ :> InvConflictor _ _ _) = invertCommuteNC c--    -- Commuting two Conflictors, c1 and c2, first commutes the Conflictors'-    -- effects, then commutes the effect of c1 and c2 and the other's-    -- already-undone, and conflicting patch, to bring the already-undone and-    -- conflicting patch into the context of the commuted effects.-    commuteNoConflicts (Conflictor ix xx x :> Conflictor iy yy y) = do-        xx' :> yy' <- commute (yy :> xx)-        x':ix' <- mapM (yy >>*) (x:ix)-        y':iy' <- mapM (*>> xx') (y:iy)-        False <- return $ any (conflictsWith y) (x':ix')-        False <- return $ any (conflictsWith x') iy-        return (Conflictor iy' yy' y' :> Conflictor ix' xx' x')--    -- Handle via the previous case, using the inverting commuter.-    commuteNoConflicts c@(InvConflictor _ _ _ :> InvConflictor _ _ _) =-        invertCommuteNC c--    commuteNoConflicts (InvConflictor ix xx x :> Conflictor iy yy y) = do-        iyy' :> xx' <- commute (xx :> invert yy)-        y':iy' <- mapM (xx' >>*) (y:iy)-        x':ix' <- mapM (invertFL iyy' >>*) (x:ix)-        False <- return $ any (conflictsWith y') (x':ix')-        False <- return $ any (conflictsWith x') iy'-        return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x')--    commuteNoConflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') = do-        xx :> iyy <- commute (invert yy' :> xx')-        y:iy <- mapM (*>> xx') (y':iy')-        x:ix <- mapM (*>> yy') (x':ix')-        False <- return $ any (conflictsWith y') (x':ix')-        False <- return $ any (conflictsWith x') iy'-        return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y)--instance PrimPatch prim => Check (RealPatch prim) where-    isInconsistent = isConsistent--instance FromPrim (RealPatch prim) where-    fromPrim = prim2real--instance ToFromPrim (RealPatch prim) where-    toPrim (Normal p) = Just p-    toPrim _ = Nothing--instance PrimPatch prim => MyEq (RealPatch prim) where-    (Duplicate x) =\/= (Duplicate y) | x == y = IsEq-    (Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq-    (Normal x) =\/= (Normal y) = x =\/= y-    (Conflictor cx xx x) =\/= (Conflictor cy yy y)-        | map commuteOrAddIXX cx `eqSet` map commuteOrAddIYY cy-          && commuteOrAddIXX x == commuteOrAddIYY y = xx =/\= yy-      where-          commuteOrAddIXX = commutePrimsOrAddToCtx (invertFL xx)-          commuteOrAddIYY = commutePrimsOrAddToCtx (invertFL yy)-    (InvConflictor cx xx x) =\/= (InvConflictor cy yy y)-        | cx `eqSet` cy && x == y = xx =\/= yy-    _ =\/= _ = NotEq--eqSet :: Eq a => [a] -> [a] -> Bool-eqSet [] [] = True-eqSet (x:xs) xys | Just ys <- remove1 x xys = eqSet xs ys-eqSet _ _ = False--remove1 :: Eq a => a -> [a] -> Maybe [a]-remove1 x (y : ys) = if x == y then Just ys else (y :) `fmap` remove1 x ys-remove1 _ [] = Nothing--minus :: Eq a => [a] -> [a] -> Maybe [a]-minus xs [] = Just xs-minus xs (y:ys) = do xs' <- remove1 y xs-                     xs' `minus` ys--invertNon :: PrimPatch prim => Non (RealPatch prim) C(x)-          -> Non (RealPatch prim) C(x)-invertNon (Non c x)-    | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x)-    | otherwise = commuteOrAddToCtxRL (Normal x :<: reverseFL c) $ non nix-  where-    nix = Normal $ invert x--nonTouches :: PatchInspect prim => Non (RealPatch prim) C(x) -> [FilePath]-nonTouches (Non c x) = listTouchedFiles (c +>+ fromPrim x :>: NilFL)--nonHunkMatches :: PatchInspect prim => (BC.ByteString -> Bool)-               -> Non (RealPatch prim) C(x) -> Bool-nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x--toNons :: forall p C(x y) . (Conflict p, Patchy p, PatchListFormat p,-       ToFromPrim p, Nonable p, ShowPatchBasic (PrimOf p)) => FL p C(x y)-       -> [Non p C(x)]-toNons xs = map lastNon $ initsFL xs-    where lastNon :: Sealed ((p :> FL p) C(x)) -> Non p C(x)-          lastNon (Sealed xxx) =-              case lastNon_aux xxx of-                   deps :> p :> _ ->-                       case non p of-                           Non NilFL pp -> Non (reverseRL deps) pp-                           Non ds pp ->-                               errorDoc $ redText "Weird case in toNons" $$-                                          redText "please report this bug!" $$-                                          (case xxx of-                                           z :> zs -> showPatch (z :>: zs)) $$-                                          redText "ds are" $$ showPatch ds $$-                                          redText "pp is" $$ showPatch pp--          reverseFoo :: (p :> FL p) C(x z) -> (RL p :> p) C(x z)-          reverseFoo (p :> ps) = rf NilRL p ps-            where-              rf :: RL p C(a b) -> p C(b c) -> FL p C(c d)-                 -> (RL p :> p) C(a d)-              rf rs l NilFL = rs :> l-              rf rs x (y :>: ys) = rf (x :<: rs) y ys--          lastNon_aux :: (p :> FL p) C(x z) -> (RL p :> p :> RL p) C(x z)-          lastNon_aux = commuteWhatWeCanRL . reverseFoo--initsFL :: Patchy p => FL p C(x y) -> [Sealed ((p :> FL p) C(x))]-initsFL NilFL = []-initsFL (x :>: xs) =-    Sealed (x :> NilFL) :-    map (\(Sealed (y :> xs')) -> Sealed (x :> y :>: xs')) (initsFL xs)--filterConflictsFL :: PrimPatch prim => Non (RealPatch prim) C(x)-                  -> FL prim C(x y) -> (FL prim :> FL prim) C(x y)-filterConflictsFL _ NilFL = NilFL :> NilFL-filterConflictsFL n (p :>: ps)-    | Just n' <- commuteOrRemFromCtx (fromPrim p) n =-        case filterConflictsFL n' ps of-            p1 :> p2 -> p :>: p1 :> p2-    | otherwise = case commuteWhatWeCanFL (p :> ps) of-                      p1 :> p' :> p2 ->-                          case filterConflictsFL n p1 of-                              p1a :> p1b -> p1a :> p1b +>+ p' :>: p2--instance Invert prim => Invert (RealPatch prim) where-    invert (Duplicate d) = Etacilpud d-    invert (Etacilpud d) = Duplicate d-    invert (Normal p) = Normal (invert p)-    invert (Conflictor x c p) = InvConflictor x c p-    invert (InvConflictor x c p) = Conflictor x c p--instance PrimPatch prim => Commute (RealPatch prim) where-    commute (x :> y) | Just (y' :> x') <--        commuteNoConflicts (assertConsistent x :> assertConsistent y) =-        Just (y' :> x')--    -- These patches conflicted, since we failed to commuteNoConflicts in the-    -- case above.-    commute (Normal x :> Conflictor a1'nop2 n1'x p1')-        | Just rn1' <- removeRL x (reverseFL n1'x) = do-            let p2 : n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (x :<: rn1')-                a2 = p1' : a1'nop2 ++ n1nons-            case (a1'nop2, reverseRL rn1', p1') of-                ([], NilFL, Non c y) | NilFL <- joinEffects c ->-                    Just (Normal y :> Conflictor a1'nop2 (y :>: NilFL) p2)-                (a1, n1, _) ->-                    Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2)--    -- Handle using the inverting commuter, and the previous case.  N.b. this-    -- is innefficient, since we'll have to also try commuteNoConflicts again-    -- (which we know will fail, since we got here).-    commute c@(InvConflictor _ _ _ :> Normal _) = invertCommute c--    commute (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)-        | Just a2_minus_p1 <- remove1 p1' a2-        , not (p2 `dependsUpon` p1') = do-            let n1nons = map (commutePrimsOrAddToCtx n2) $ xx2nons a1 n1-                n2nons = xx2nons a2 n2-                Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons-                n2n1 = n2 +>+ n1-                a1' = map (commutePrimsOrAddToCtx n2) a1-                p2ooo = remNons a1' p2-            n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1-            let n1'n2'nons = xx2nons a2_minus_p1n1 (n1' +>+ n2')-                n1'nons = take (lengthFL n1') n1'n2'nons-                n2'nons = drop (lengthFL n1') n1'n2'nons-                Just a1'nop2 = (a2 ++ n2nons) `minus` (p1' : n1'nons)-                Just a2'o =-                    fst (allConflictsWith p2 $ a2_minus_p1 ++ n2nons)-                    `minus` n2'nons-                Just a2' =-                    mapM (commuteOrRemFromCtxFL (xx2patches a1'nop2 n1')) a2'o-                Just p2' = commuteOrRemFromCtxFL (xx2patches a1'nop2 n1') p2-            case (a2', n2', p2') of-                ([], NilFL, Non c x) ->-                    case joinEffects c of-                        NilFL -> let n1'x = n1' +>+ x :>: NilFL in-                                 Just (Normal x :> Conflictor a1'nop2 n1'x p1')-                        _ -> impossible-                _ -> Just (c1 :> c2)-                  where-                    c1 = Conflictor a2' n2' p2'-                    c2 = Conflictor (p2 : a1'nop2) n1' p1'--        where (_, rpn2) = geteff a2 n2-              p1' = commuteOrAddToCtxRL (reverseFL rpn2) p1--    -- Handle using the inverting commuter, and the previous case. This is also-    -- innefficient, since we'll have to also try commuteNoConflicts again-    -- (which we know will fail, since we got here).-    commute c@(InvConflictor _ _ _ :> InvConflictor _ _ _) = invertCommute c--    commute _ = Nothing--instance PrimPatch prim => Merge (RealPatch prim) where-    merge (InvConflictor _ _ _ :\/: _) = impossible-    merge (_ :\/: InvConflictor _ _ _) = impossible-    merge (Etacilpud _ :\/: _) = impossible-    merge (_ :\/: Etacilpud _) = impossible---    merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a-    -- We had a FIXME comment on this case, why?-    merge (Duplicate a :\/: b) =-        b :/\: Duplicate (commuteOrAddToCtx (invert b) a)--    -- Handle using the swap merge and the previous case.-    merge m@(_ :\/: Duplicate _) = swapMerge m--    -- When merging x and y, we do a bunch of what look like "consistency"-    -- check merges. If the resulting y'' and y are equal, then we succeed.-    -- If the first case fails, we check for equal patches (which wouldn't-    -- commute) and return a Duplicate on both sides of the merge, in that-    -- case.-    merge (x :\/: y)-        | Just (y' :> ix') <--            commute (invert (assertConsistent x) :> assertConsistent y)-        , Just (y'' :> _) <- commute (x :> y')-        , IsEq <- y'' =\/= y =-            assertConsistent y' :/\: invert (assertConsistent ix')-        -- If we detect equal patches, we have a duplicate.-        | IsEq <- x =\/= y-        , n <- commuteOrAddToCtx (invert x) $ non x =-            Duplicate n :/\: Duplicate n--    -- We know that these two patches conflict, and aren't Duplicates, since we-    -- failed the previous case. We therefore create basic Conflictors, which-    -- undo the other patch.-    merge (nx@(Normal x) :\/: ny@(Normal y)) = cy :/\: cx-      where-        cy = Conflictor [] (x :>: NilFL) (non ny)-        cx = Conflictor [] (y :>: NilFL) (non nx)--    -- If a Normal patch @x@ and a Conflictor @cy@ conflict, we add @x@ to the-    -- effect of @cy@ on one side, and create a Conflictor that has no effect,-    -- but has the already-undone and conflicted patch of @cy@ and some foos as-    -- the already-undone on the other side.-    ---    -- TODO: what is foo?-    -- Why do we need nyy? I think @x'@ is @x@ in the context of @yy@.-    merge (Normal x :\/: Conflictor iy yy y) =-          Conflictor iy yyx y :/\: Conflictor (y : iy ++ nyy) NilFL x'-              where yyx = yy +>+ x :>: NilFL-                    (x' : nyy) = reverse $ xx2nons iy yyx--    -- Handle using the swap merge and the previous case.-    merge m@(Conflictor _ _ _ :\/: Normal _) = swapMerge m--    -- mH see also cH-    merge (Conflictor ix xx x :\/: Conflictor iy yy y) =-        case pullCommonRL (reverseFL xx) (reverseFL yy) of-            CommonRL rxx1 ryy1 c ->-                case commuteRLFL (ryy1 :> invertRL rxx1) of-                    Just (ixx' :> ryy') ->-                        let xx' = invert ixx'-                            yy' = reverseRL ryy'-                            y' : iy' =-                                map (commutePrimsOrAddToCtx xx') (y : iy)-                            x' : ix' =-                                map (commutePrimsOrAddToCtx ryy') (x : ix)-                            nyy' = xx2nons iy' yy'-                            nxx' = xx2nons ix' xx'-                            icx = drop (lengthRL rxx1) $-                                xx2nons ix (reverseRL $ c +<+ rxx1)-                            ic' = map (commutePrimsOrAddToCtx ryy') icx-                            -- +++ is a more efficient version of nub (iy' ++-                            -- ix') given that we know each element shows up-                            -- only once in either list.-                            ixy' = ic' ++ (iy' +++ ix')-                            c1 = Conflictor (x' : ixy' ++ nxx') yy' y'-                            c2 = Conflictor (y' : ixy' ++ nyy') xx' x' in-                            c1 :/\: c2-                    Nothing -> impossible--instance PatchInspect prim => PatchInspect (RealPatch prim) where-    listTouchedFiles (Duplicate p) = nonTouches p-    listTouchedFiles (Etacilpud p) = nonTouches p-    listTouchedFiles (Normal p) = listTouchedFiles p-    listTouchedFiles (Conflictor x c p) =-        nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p-    listTouchedFiles (InvConflictor x c p) =-        nubsort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p--    hunkMatches f (Duplicate p) = nonHunkMatches f p-    hunkMatches f (Etacilpud p) = nonHunkMatches f p-    hunkMatches f (Normal p) = hunkMatches f p-    hunkMatches f (Conflictor x c p) =-        any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p-    hunkMatches f (InvConflictor x c p) =-        any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p--allConflictsWith :: PrimPatch prim => Non (RealPatch prim) C(x)-                 -> [Non (RealPatch prim) C(x)]-                 -> ([Non (RealPatch prim) C(x)], [Non (RealPatch prim) C(x)])-allConflictsWith x ys = acw $ partition (conflictsWith x) ys-  where-    acw ([], nc) = ([], nc)-    acw (c:cs, nc) = case allConflictsWith c nc of-                         (c1, nc1) -> case acw (cs, nc1) of-                                          (xs', nc') -> (c : c1 ++ xs', nc')--conflictsWith :: PrimPatch prim => Non (RealPatch prim) C(x)-              -> Non (RealPatch prim) C(x) -> Bool-conflictsWith x y | x `dependsUpon` y || y `dependsUpon` x = False-conflictsWith x (Non cy y) =-    case commuteOrRemFromCtxFL cy x of-        Just (Non cx' x') ->-            let iy = fromPrim $ invert y in-            case commuteFLorComplain (iy :> cx' +>+ fromPrim x' :>: NilFL) of-                Right _ -> False-                Left _ -> True-        Nothing -> True--dependsUpon :: PrimPatch prim => Non (RealPatch prim) C(x)-            -> Non (RealPatch prim) C(x) -> Bool-dependsUpon (Non xs _) (Non ys y) =-    case removeSubsequenceFL (ys +>+ fromPrim y :>: NilFL) xs of-        Just _ -> True-        Nothing -> False--(+++) :: Eq a => [a] -> [a] -> [a]-[] +++ x = x-x +++ [] = x-(x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys)-               | otherwise = x : (xs +++ xys)--swapMerge :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) C(x y)-          -> (RealPatch prim :/\: RealPatch prim) C(x y)-swapMerge (x :\/: y) = case merge (y :\/: x) of x' :/\: y' -> y' :/\: x'--invertCommute :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y)-              -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))-invertCommute (x :> y) = do ix' :> iy' <- commute (invert y :> invert x)-                            return (invert iy' :> invert ix')--invertCommuteNC :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y)-                -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))-invertCommuteNC (x :> y) = do-    ix' :> iy' <- commuteNoConflicts (invert y :> invert x)-    return (invert iy' :> invert ix')---- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted out--- of both @xs@ and @ys@ along with the remnants of both lists-pullCommon :: Patchy p => FL p C(o x) -> FL p C(o y) -> Common p C(o x y)-pullCommon NilFL ys = Common NilFL NilFL ys-pullCommon xs NilFL = Common NilFL xs NilFL-pullCommon (x :>: xs) xys | Just ys <- removeFL x xys =-    case pullCommon xs ys of-        Common c xs' ys' -> Common (x :>: c) xs' ys'-pullCommon (x :>: xs) ys =-    case commuteWhatWeCanFL (x :> xs) of-        xs1 :> x' :> xs2 -> case pullCommon xs1 ys of-            Common c xs1' ys' -> Common c (xs1' +>+ x' :>: xs2) ys'---- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in--- common, in other words @cs +>+ xs@ and @cs +>+ ys@-data Common p C(o x y) where-    Common :: FL p C(o i) -> FL p C(i x) -> FL p C(i y) -> Common p C(o x y)---- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted---   out of both @xs@ and @ys@ along with the remnants of both lists-pullCommonRL :: Patchy p => RL p C(x o) -> RL p C(y o) -> CommonRL p C(x y o)-pullCommonRL NilRL ys = CommonRL NilRL ys NilRL-pullCommonRL xs NilRL = CommonRL xs NilRL NilRL-pullCommonRL (x :<: xs) xys | Just ys <- removeRL x xys =-    case pullCommonRL xs ys of-        CommonRL xs' ys' c -> CommonRL xs' ys' (x :<: c)-pullCommonRL (x :<: xs) ys =-    case commuteWhatWeCanRL (xs :> x) of-        xs1 :> x' :> xs2 ->-            case pullCommonRL xs2 ys of-                CommonRL xs2' ys' c -> CommonRL (xs2' +<+ x' :<: xs1) ys' c---- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@--- in common, in other words @xs +<+ cs@ and @ys +<+ cs@-data CommonRL p C(x y f) where-    CommonRL :: RL p C(x i) -> RL p C(y i) -> RL p C(i f) -> CommonRL p C(x y f)--instance PrimPatch prim => Apply (RealPatch prim) where-    type ApplyState (RealPatch prim) = ApplyState prim-    apply p = apply (effect p)--instance PrimPatch prim => RepairToFL (RealPatch prim) where-    applyAndTryToFixFL (Normal p) =-        mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p-    applyAndTryToFixFL x = do apply x; return Nothing--instance PatchListFormat (RealPatch prim) where-   -- In principle we could use ListFormatDefault when prim /= V1 Prim patches,-   -- as those are the only case where we need to support a legacy on-disk-   -- format. In practice we don't expect RealPatch to be used with any other-   -- argument anyway, so it doesn't matter.-    patchListFormat = ListFormatV2--duplicate, etacilpud, conflictor, rotcilfnoc :: String-duplicate = "duplicate"-etacilpud = "etacilpud"-conflictor = "conflictor"-rotcilfnoc = "rotcilfnoc"--instance PrimPatch prim => ShowPatchBasic (RealPatch prim) where-    showPatch (Duplicate d) = blueText duplicate $$ showNon d-    showPatch (Etacilpud d) = blueText etacilpud $$ showNon d-    showPatch (Normal p) = showPrim NewFormat p-    showPatch (Conflictor i NilFL p) =-        blueText conflictor <+> showNons i <+> blueText "[]" $$ showNon p-    showPatch (Conflictor i cs p) =-        blueText conflictor <+> showNons i <+> blueText "[" $$-        showPrimFL NewFormat cs $$-        blueText "]" $$-        showNon p-    showPatch (InvConflictor i NilFL p) =-        blueText rotcilfnoc <+> showNons i <+> blueText "[]" $$ showNon p-    showPatch (InvConflictor i cs p) =-        blueText rotcilfnoc <+> showNons i <+> blueText "[" $$-        showPrimFL NewFormat cs $$-        blueText "]" $$-        showNon p--instance PrimPatch prim => ShowPatch (RealPatch prim) where-    showContextPatch (Normal p) = showContextPatch p-    showContextPatch c = return $ showPatch c-    summary = plainSummary-    summaryFL = plainSummary-    thing _ = "change"--instance PrimPatch prim => ReadPatch (RealPatch prim) where-    readPatch' = do-        skipSpace-        let str = string . BC.pack-            readConflictorPs = do-               i <- readNons-               ps <- bracketedFL (readPrim NewFormat) '[' ']'-               p <- readNon-               return (i, ps, p)-        choice [ do str duplicate-                    p <- readNon-                    return $ Sealed $ Duplicate p-               , do str etacilpud-                    p <- readNon-                    return $ Sealed $ Etacilpud p-               , do str conflictor-                    (i, Sealed ps, p) <- readConflictorPs-                    return $ Sealed $ Conflictor i (unsafeCoerceP ps) p-               , do str rotcilfnoc-                    (i, Sealed ps, p) <- readConflictorPs-                    return $ Sealed $ InvConflictor i ps p-               , do Sealed p <- readPrim NewFormat-                    return $ Sealed $ Normal p-               ]--instance PrimPatch prim => Show (RealPatch prim C(x y)) where-    show p = renderString $ showPatch p--instance PrimPatch prim => Show2 (RealPatch prim) where-    showDict2 = ShowDictClass--instance PrimPatch prim => Nonable (RealPatch prim) where-    non (Duplicate d) = d-    non (Etacilpud d) = invertNon d -- FIXME !!! ???-    non (Normal p) = Non NilFL p-    non (Conflictor _ xx x) = commutePrimsOrAddToCtx (invertFL xx) x-    non (InvConflictor _ _ n) = invertNon n--instance PrimPatch prim => Effect (RealPatch prim) where-    effect (Duplicate _) = NilFL-    effect (Etacilpud _) = NilFL-    effect (Normal p) = p :>: NilFL-    effect (Conflictor _ e _) = invert e-    effect (InvConflictor _ e _) = e-    effectRL (Duplicate _) = NilRL-    effectRL (Etacilpud _) = NilRL-    effectRL (Normal p) = p :<: NilRL-    effectRL (Conflictor _ e _) = invertFL e-    effectRL (InvConflictor _ e _) = reverseFL e--instance IsHunk prim => IsHunk (RealPatch prim) where-    isHunk rp = do Normal p <- return rp-                   isHunk p
+ src/Darcs/Patch/V2/RepoPatch.hs view
@@ -0,0 +1,945 @@+-- Copyright (C) 2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Darcs.Patch.V2.RepoPatch+    ( RepoPatchV2(..)+    , isConsistent+    , isForward+    , isDuplicate+    , mergeUnravelled+    ) where++import Darcs.Prelude hiding ( (*>) )++import Control.Monad ( mplus, liftM )+import qualified Data.ByteString.Char8 as BC ( ByteString, pack )+import Data.Maybe ( fromMaybe )+import Data.List ( partition )+import Data.List.Ordered ( nubSort )++import Darcs.Patch.Commute ( commuteFL, commuteRL+                           , commuteRLFL, Commute(..) )+import Darcs.Patch.CommuteFn ( CommuteFn, invertCommuter )+import Darcs.Patch.CommuteNoConflicts ( CommuteNoConflicts(..), mergeNoConflicts )+import Darcs.Patch.Conflict ( Conflict(..), combineConflicts, mangleOrFail )+import Darcs.Patch.Debug+import Darcs.Patch.Effect ( Effect(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(ListFormatV2) )+import Darcs.Patch.Ident ( PatchId )+import Darcs.Patch.Invert ( invertFL, invertRL, Invert(..) )+import Darcs.Patch.Merge ( CleanMerge(..), Merge(..), swapMerge )+import Darcs.Patch.FromPrim+    ( FromPrim(..)+    , ToPrim(..)+    , PrimPatchBase(..)+    )+import Darcs.Patch.Prim ( PrimPatch, applyPrimFL )+import Darcs.Patch.Read ( bracketedFL, ReadPatch(..) )+import Darcs.Util.Parser ( skipSpace, string, choice )+import Darcs.Patch.Repair ( mapMaybeSnd, RepairToFL(..), Check(..) )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch.Permutations ( commuteWhatWeCanFL, commuteWhatWeCanRL+                                , genCommuteWhatWeCanRL, removeRL, removeFL+                                , removeSubsequenceFL, nubFL, (=\~/=), (=/~\=) )+import Darcs.Patch.Show+    ( ShowPatch(..), ShowPatchBasic(..), ShowContextPatch(..), ShowPatchFor(..)+    , displayPatch )+import Darcs.Patch.Summary+    ( Summary(..)+    , ConflictState(..)+    , IsConflictedPrim(..)+    , plainSummary+    )+import Darcs.Patch.Unwind ( Unwind(..), mkUnwound )+import Darcs.Patch.V2.Non ( Non(..), Nonable(..), unNon, showNons, showNon+                          , readNons, readNon, commutePrimsOrAddToCtx+                          , commuteOrAddToCtx, commuteOrAddToCtxRL+                          , commuteOrRemFromCtx, commuteOrRemFromCtxFL+                          , remNons, (*>), (>*), (*>>), (>>*) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), RL(..), Fork(..), (:>)(..), (+>+), (+<+)+    , mapFL, mapFL_FL, reverseFL, (:\/:)(..), (:/\:)(..)+    , reverseRL, lengthFL, lengthRL, nullFL, initsFL )+import Darcs.Patch.Witnesses.Sealed+    ( FlippedSeal(..), Sealed(Sealed), mapSeal+    , unseal )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, showsPrec2, appPrec )++import Darcs.Util.Path ( AnchoredPath )+import Darcs.Util.Printer ( Doc, renderString, blueText, redText, (<+>), ($$), vcat )++-- |'RepoPatchV2' is used to represents prim patches that are duplicates of, or+-- conflict with, another prim patch in the repository.+--+-- @Normal prim@: A primitive patch+--+-- @Duplicate x@: This patch has no effect since @x@ is already present in the+-- repository.+--+-- @Etacilpud x: invert (Duplicate x)@+--+-- @Conflictor ix xx x@:+-- @ix@ is the set of patches:+--   * that conflict with @x@ and also conflict with another patch in the+--     repository.+--   * that conflict with a patch that conflict with @x@+--+-- @xx@ is the sequence of patches that conflict *only* with @x@+--+-- @x@ is the original, conflicting patch.+--+-- @ix@ and @x@ are stored as @Non@ objects, which include any necessary+--  context to uniquely define the patch that is referred to.+--+-- The intuition is that a Conflictor should have the effect of inverting any+-- patches that 'x' conflicts with, that haven't already been undone by another+-- Conflictor in the repository.+-- Therefore, the effect of a Conflictor is @invert xx@.+--+-- @InvConflictor ix xx x@: like @invert (Conflictor ix xx x)@+data RepoPatchV2 prim wX wY where+    Duplicate :: Non (RepoPatchV2 prim) wX -> RepoPatchV2 prim wX wX+    Etacilpud :: Non (RepoPatchV2 prim) wX -> RepoPatchV2 prim wX wX+    Normal :: prim wX wY -> RepoPatchV2 prim wX wY+    Conflictor :: [Non (RepoPatchV2 prim) wX] -> FL prim wX wY+               -> Non (RepoPatchV2 prim) wX -> RepoPatchV2 prim wY wX+    InvConflictor :: [Non (RepoPatchV2 prim) wX] -> FL prim wX wY+                  -> Non (RepoPatchV2 prim) wX -> RepoPatchV2 prim wX wY++instance PrimPatch prim => PrimPatchBase (RepoPatchV2 prim) where+   type PrimOf (RepoPatchV2 prim) = prim++-- | 'isDuplicate' @p@ is @True@ if @p@ is either a 'Duplicate' or 'Etacilpud'+-- patch.+isDuplicate :: RepoPatchV2 prim wS wY -> Bool+isDuplicate (Duplicate _) = True+isDuplicate (Etacilpud _) = True+isDuplicate _ = False++-- | 'isForward' @p@ is @True@ if @p@ is either an 'InvConflictor' or+-- 'Etacilpud'.+isForward :: PrimPatch prim => RepoPatchV2 prim wS wY -> Maybe Doc+isForward p = case p of+    p@(InvConflictor{}) -> justRedP "An inverse conflictor" p+    p@(Etacilpud _) -> justRedP "An inverse duplicate" p+    _ -> Nothing+  where+    justRedP msg p = Just $ redText msg $$ displayPatch p++-- |'mergeUnravelled' is used when converting from Darcs V1 patches (Mergers)+-- to Darcs V2 patches (Conflictors).+mergeUnravelled :: PrimPatch prim => [Sealed ((FL prim) wX)]+                -> Maybe (FlippedSeal (RepoPatchV2 prim) wX)+mergeUnravelled [] = Nothing+mergeUnravelled [_] = Nothing+mergeUnravelled ws =+    case mergeUnravelled_private ws of+        Nothing -> Nothing+        Just NilRL -> error "found no patches in mergeUnravelled"+        Just (_ :<: z) -> Just $ FlippedSeal z+  where+    notNullS :: Sealed ((FL prim) wX) -> Bool+    notNullS (Sealed NilFL) = False+    notNullS _ = True++    mergeUnravelled_private :: PrimPatch prim => [Sealed (FL prim wX)]+                            -> Maybe (RL (RepoPatchV2 prim) wX wX)+    mergeUnravelled_private xs = let nonNullXs = filter notNullS xs in+        reverseFL `fmap` mergeConflictingNons (map sealed2non nonNullXs)++    -- | 'sealed2non' @(Sealed xs)@ converts @xs@ to a 'Non'.+    -- @xs@ must be non-empty since we split this list at the last patch,+    -- taking @init xs@ as the context of @last xs@.+    sealed2non :: Sealed ((FL prim) wX) -> Non (RepoPatchV2 prim) wX+    sealed2non (Sealed xs) =+        case reverseFL xs of+            ys :<: y -> Non (mapFL_FL Normal $ reverseRL ys) y+            NilRL -> error "NilFL encountered in sealed2non"++mergeConflictingNons :: PrimPatch prim => [Non (RepoPatchV2 prim) wX]+                     -> Maybe (FL (RepoPatchV2 prim) wX wX)+mergeConflictingNons ns = mcn $ map unNon ns+    where mcn :: PrimPatch prim => [Sealed (FL (RepoPatchV2 prim) wX)]+              -> Maybe (FL (RepoPatchV2 prim) wX wX)+          mcn [] = Just NilFL+          -- Apparently, the joinEffects call is a safety check "and could be+          -- removed when we're sure of the code"!+          mcn [Sealed p] = case joinEffects p of+                               NilFL -> Just p+                               _ -> Nothing+          mcn (Sealed p1:Sealed p2:zs) =+            case pullCommon p1 p2 of+                Fork c ps qs ->+                    case merge (ps :\/: qs) of+                        qs' :/\: _ -> mcn (Sealed (c +>+ ps +>+ qs'):zs)++joinEffects :: forall p wX wY . (Effect p, Invert (PrimOf p),+            Commute (PrimOf p), Eq2 (PrimOf p)) => p wX wY+            -> FL (PrimOf p) wX wY+joinEffects = joinInverses . effect+    where joinInverses :: FL (PrimOf p) wA wB -> FL (PrimOf p) wA wB+          joinInverses NilFL = NilFL+          joinInverses (p :>: ps) =+              let ps' = joinInverses ps in+              fromMaybe (p :>: ps') $ removeFL (invert p) ps'++assertConsistent :: PrimPatch prim => RepoPatchV2 prim wX wY+                 -> RepoPatchV2 prim wX wY+assertConsistent x = maybe x (error . renderString) $ do+    e <- isConsistent x+    Just (redText "Inconsistent patch:" $$ displayPatch x $$ e)++-- | @mergeAfterConflicting@ takes as input a sequence of conflicting patches+-- @xxx@ (which therefore have no effect) and a sequence of primitive patches+-- @yyy@ that follow said sequence of conflicting patches, and may depend upon+-- some of the conflicting patches (as a resolution).++-- The output is two sequences of patches the first consisting of a set of+-- mutually-conflicting patches, and the second having the same effect as the+-- original primitive patch sequence in the input.++-- So far as I can tell, the second output is always identical to @mapFL Normal+-- yyy@++-- The first output is the set of patches from @xxx@ that are depended upon by+-- @yyy@.+mergeAfterConflicting :: PrimPatch prim => FL (RepoPatchV2 prim) wX wX+                      -> FL prim wX wY -> Maybe ( FL (RepoPatchV2 prim) wX wX+                                                 , FL (RepoPatchV2 prim) wX wY)+mergeAfterConflicting xxx yyy = mac (reverseFL xxx) yyy NilFL+  where+    mac :: PrimPatch prim+        => RL (RepoPatchV2 prim) wX wY -> FL prim wY wZ+        -> FL (RepoPatchV2 prim) wZ wA+        -> Maybe (FL (RepoPatchV2 prim) wX wX, FL (RepoPatchV2 prim) wX wA)+    mac NilRL xs goneby = case joinEffects goneby of+                              NilFL -> Just (NilFL, mapFL_FL Normal xs)+                              _ -> Nothing+    mac (ps :<: p) xs goneby =+        case commuteFL (p :> mapFL_FL Normal xs) of+            Nothing ->+                case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of+                    a :> p' :> b ->+                        do (b', xs') <- mac b xs goneby+                           let pa = joinEffects $ a :<: p'+                           NilFL <- return pa+                           return (reverseRL (a :<: p') +>+ b', xs')+                        `mplus`+                        do NilFL <- return goneby+                           NilFL <- return $ joinEffects (ps :<: p)+                           return (reverseRL (ps :<: p), mapFL_FL Normal xs)+            Just (l :> p'') ->+                case allNormal l of+                    Just xs'' -> mac ps xs'' (p'' :>: goneby)+                    Nothing ->+                        case genCommuteWhatWeCanRL commuteNoConflicts (ps :> p) of+                            a :> p' :> b ->+                                do (b', xs') <- mac b xs goneby+                                   let pa = joinEffects $ a :<: p'+                                   NilFL <- return pa+                                   return (reverseRL (a :<: p') +>+ b', xs')++geteff :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> FL prim wX wY+       -> ([Non (RepoPatchV2 prim) wX], FL (RepoPatchV2 prim) wX wY)+geteff _ NilFL = ([], NilFL)+geteff ix (x :>: xs) | Just ix' <- mapM (commuteOrRemFromCtx (Normal x)) ix =+    case geteff ix' xs of+        (ns, xs') -> ( non (Normal x) : map (commuteOrAddToCtx (Normal x)) ns+                     , Normal x :>: xs')+geteff ix xx =+    case mergeConflictingNons ix of+        Nothing -> error $ renderString $+            redText "mergeConflictingNons failed in geteff: ix" $$+            displayNons ix $$ redText "xx" $$ displayPatch xx+        Just rix ->+            case mergeAfterConflicting rix xx of+                Just (a, x) ->+                    ( map (commuteOrAddToCtxRL (reverseFL a)) $ toNons x+                    , a +>+ x)+                Nothing ->+                    error $ renderString $+                        redText "mergeAfterConflicting failed in geteff" $$+                        redText "where ix" $$ displayNons ix $$+                        redText "and xx" $$ displayPatch xx $$+                        redText "and rix" $$ displayPatch rix++xx2nons :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> FL prim wX wY+        -> [Non (RepoPatchV2 prim) wX]+xx2nons ix xx = fst $ geteff ix xx++xx2patches :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> FL prim wX wY+           -> FL (RepoPatchV2 prim) wX wY+xx2patches ix xx = snd $ geteff ix xx++-- | If @xs@ consists only of 'Normal' patches, 'allNormal' @xs@ returns+--   @Just pxs@ those patches (so @lengthFL pxs == lengthFL xs@).+--   Otherwise, it returns 'Nothing'.+allNormal :: FL (RepoPatchV2 prim) wX wY -> Maybe (FL prim wX wY)+allNormal (Normal x :>: xs) = (x  :>: ) `fmap` allNormal xs+allNormal NilFL = Just NilFL+allNormal _ = Nothing++-- | This is used for unit-testing and for internal sanity checks+isConsistent :: PrimPatch prim => RepoPatchV2 prim wX wY -> Maybe Doc+isConsistent (Normal _) = Nothing+isConsistent (Duplicate _) = Nothing+isConsistent (Etacilpud _) = Nothing+isConsistent c@(InvConflictor{}) = isConsistent (invert c)+isConsistent (Conflictor im mm m@(Non deps _))+    | not $ everyoneConflicts im =+        Just $ redText "Someone doesn't conflict in im in isConsistent"+    | Just _ <- commuteOrRemFromCtxFL rmm m, _ :>: _ <- mm =+        Just $ redText "m doesn't conflict with mm in isConsistent"+    | any (\x -> any (x `conflictsWith`) nmm) im =+        Just $ redText "mm conflicts with im in isConsistent where nmm is" $$+               displayNons nmm+    | Nothing <- (nmm ++ im) `minus` toNons deps =+        Just $ redText "dependencies not in conflict:" $$+               displayNons (toNons deps) $$+               redText "compared with deps itself:" $$+               displayPatch deps+    | otherwise =+        case allConflictsWith m im of+            (im1, []) | im1 `eqSet` im -> Nothing+            (_, imnc) -> Just $ redText ("m doesn't conflict with im in "+                                         ++ "isConsistent. unconflicting:") $$+                                displayNons imnc+    where (nmm, rmm) = geteff im mm++everyoneConflicts :: PrimPatch prim => [Non (RepoPatchV2 prim) wX] -> Bool+everyoneConflicts [] = True+everyoneConflicts (x : xs) = case allConflictsWith x xs of+                                 ([], _) -> False+                                 (_, xs') -> everyoneConflicts xs'++instance PatchDebug prim => PatchDebug (RepoPatchV2 prim)++mergeWith :: PrimPatch prim => Non (RepoPatchV2 prim) wX+          -> [Non (RepoPatchV2 prim) wX] -> Sealed (FL prim wX)+mergeWith p [] = effect `mapSeal` unNon p+mergeWith p xs =+    mergeall . map unNon . (p :) . unconflicting_of $ nonDependsOrConflictsP xs+  where+    nonDependsOrConflictsP =+        filter (\x -> not ((p `dependsUpon` x) || (p `conflictsWith` x)))+    mergeall :: PrimPatch prim => [Sealed (FL (RepoPatchV2 prim) wX)]+             -> Sealed (FL prim wX)+    mergeall [Sealed x] = Sealed $ effect x+    mergeall [] = Sealed NilFL+    mergeall (Sealed x : Sealed y : rest) =+        case merge (x :\/: y) of+            y' :/\: _ -> mergeall (Sealed (x +>+ y') : rest)+    unconflicting_of [] = []+    unconflicting_of (q : qs) = case allConflictsWith q qs of+                                    ([], _) -> q : qs+                                    (_, nc) -> unconflicting_of nc++instance Summary (RepoPatchV2 prim) where+    conflictedEffect (Duplicate (Non _ x)) = [IsC Duplicated x]+    conflictedEffect (Etacilpud _) = error "impossible case"+    conflictedEffect (Conflictor _ _ (Non _ x)) = [IsC Conflicted x]+    conflictedEffect (InvConflictor{}) = error "impossible case"+    conflictedEffect (Normal x) = [IsC Okay x]++instance PrimPatch prim => Conflict (RepoPatchV2 prim) where+    isConflicted (Conflictor {}) = True+    isConflicted (InvConflictor {}) = True+    isConflicted _ = False+    resolveConflicts _ = map mangleOrFail . combineConflicts resolveOne+      where+        resolveOne :: RepoPatchV2 prim wX wY -> [[Sealed (FL prim wY)]]+        resolveOne (Conflictor ix xx x) = [unravelled]+          where+            unravelled = nubFL $ filter isCons $ map (`mergeWith` xIxNonXX) xIxNonXX+            xIxNonXX = x : ix ++ nonxx+            nonxx = nonxx_ (reverseFL $ xx2patches ix xx)+        resolveOne _ = []+        -- |nonxx_ takes an RL of patches, and returns a singleton list+        -- containing a Non, in the case where we have a Normal patch at the+        -- end of the list (using the rest of the RL as context), and an empty+        -- list otherwise.+        nonxx_ :: RL (RepoPatchV2 prim) wX wY -> [Non (RepoPatchV2 prim) wX]+        nonxx_ (qs :<: Normal q) = [Non (reverseRL qs) q]+        nonxx_ _ = []+        isCons = unseal (not . nullFL)++instance PrimPatch prim => Unwind (RepoPatchV2 prim) where+  fullUnwind (Normal p) =+    mkUnwound NilFL (p :>: NilFL) NilFL+  fullUnwind (Duplicate (Non ps p)) =+    mkUnwound (effect ps) (p :>: NilFL) (invert p :>: effect (invert ps))+  fullUnwind (Conflictor _ es (Non ps p)) =+    mkUnwound (invert es +>+ effect ps) (p :>: NilFL) (invert p :>: effect (invert ps))+  fullUnwind (Etacilpud non) =+    invert (fullUnwind (Duplicate non))+  fullUnwind (InvConflictor ix xx x) =+    invert (fullUnwind (Conflictor ix xx x))++instance PrimPatch prim => CommuteNoConflicts (RepoPatchV2 prim) where+    commuteNoConflicts (d1@(Duplicate _) :> d2@(Duplicate _)) = Just (d2 :> d1)+    commuteNoConflicts (e@(Etacilpud _) :> d@(Duplicate _)) = Just (d :> e)+    commuteNoConflicts (d@(Duplicate _) :> e@(Etacilpud _)) = Just (e :> d)+    commuteNoConflicts (e1@(Etacilpud _) :> e2@(Etacilpud _)) = Just (e2 :> e1)++    -- If the duplicate is @x@, as a 'Non', with @invert x@ as the context,+    -- then it is the patch the duplicate @d@ represents, so commuting results+    -- in the same two patches (since we'd make one a duplicate, and the other+    -- would become @x@ as it would no longer be duplicated).+    -- Otherwise, we commute past, or remove @invert x@ from the context of @d@+    -- to obtain a new Duplicate.+    commuteNoConflicts orig@(x :> Duplicate d) =+        if d == commuteOrAddToCtx (invert x) (non x)+            then Just orig+            else do d' <- commuteOrRemFromCtx (invert x) d+                    return (Duplicate d' :> x)++    -- Commuting a Duplicate and any other patch simply places @invert x@ into+    -- the context of the non @d@, by commuting past, or adding to the context.+    commuteNoConflicts (Duplicate d :> x) =+        Just (x :> Duplicate (commuteOrAddToCtx (invert x) d))++    -- handle Etacilpud cases by first inverting, then using the previous+    -- definitions.+    commuteNoConflicts c@(Etacilpud _ :> _) = invertCommuteNC c+    commuteNoConflicts c@(_ :> Etacilpud _) = invertCommuteNC c++    -- Two normal patches should be simply commuted (assuming the can).+    commuteNoConflicts (Normal x :> Normal y) = do+        y' :> x' <- commute (x :> y)+        return (Normal y' :> Normal x')++    -- Commuting a Normal patch past a Conflictor first commutes @x@ past the+    -- effect of the Conflictor, then commutes the resulting @x'@ past the+    -- conflicting patch and the already-undone patches. The commuting must be+    -- done in this order to make the contexts match up (@iy@ and @y@ are made+    -- in the context before @yy@ have their effect, so we need to commute past+    -- the effect of @yy@ first).+    commuteNoConflicts (Normal x :> Conflictor iy yy y) = do+        iyy' :> x' <- commuteFL (x :> invert yy)+        y' : iy' <- mapM (Normal x' >*) (y : iy)+        return (Conflictor iy' (invert iyy') y' :> Normal x')++    -- Handle via the previous case, using the inverting commuter.+    commuteNoConflicts c@(InvConflictor{} :> Normal _) = invertCommuteNC c++    -- Commuting a Conflictor past a Normal patch is the dual operation to+    -- commuting a Normal patch past a Conflictor.+    commuteNoConflicts (Conflictor iy yy y :> Normal x) = do+        y' : iy' <- mapM (*> Normal x) (y : iy)+        x' :> iyy' <- commuteRL (invertFL yy :> x)+        return (Normal x' :> Conflictor iy' (invertRL iyy') y')++    -- Handle via the previous case, using the inverting commuter.+    commuteNoConflicts c@(Normal _ :> InvConflictor{}) = invertCommuteNC c++    -- Commuting two Conflictors, c1 and c2, first commutes the Conflictors'+    -- effects, then commutes the effect of c1 and c2 and the other's+    -- already-undone, and conflicting patch, to bring the already-undone and+    -- conflicting patch into the context of the commuted effects.+    commuteNoConflicts (Conflictor ix xx x :> Conflictor iy yy y) = do+        xx' :> yy' <- commute (yy :> xx)+        x':ix' <- mapM (yy >>*) (x:ix)+        y':iy' <- mapM (*>> xx') (y:iy)+        False <- return $ any (conflictsWith y) (x':ix')+        False <- return $ any (conflictsWith x') iy+        return (Conflictor iy' yy' y' :> Conflictor ix' xx' x')++    -- Handle via the previous case, using the inverting commuter.+    commuteNoConflicts c@(InvConflictor{} :> InvConflictor{}) =+        invertCommuteNC c++    commuteNoConflicts (InvConflictor ix xx x :> Conflictor iy yy y) = do+        iyy' :> xx' <- commute (xx :> invert yy)+        y':iy' <- mapM (xx' >>*) (y:iy)+        x':ix' <- mapM (invertFL iyy' >>*) (x:ix)+        False <- return $ any (conflictsWith y') (x':ix')+        False <- return $ any (conflictsWith x') iy'+        return (Conflictor iy' (invert iyy') y' :> InvConflictor ix' xx' x')++    commuteNoConflicts (Conflictor iy' yy' y' :> InvConflictor ix' xx' x') = do+        xx :> iyy <- commute (invert yy' :> xx')+        y:iy <- mapM (*>> xx') (y':iy')+        x:ix <- mapM (*>> yy') (x':ix')+        False <- return $ any (conflictsWith y') (x':ix')+        False <- return $ any (conflictsWith x') iy'+        return (InvConflictor ix xx x :> Conflictor iy (invert iyy) y)++instance PrimPatch prim => Check (RepoPatchV2 prim) where+    isInconsistent = isConsistent++type instance PatchId (RepoPatchV2 prim) = ()++instance FromPrim (RepoPatchV2 prim) where+    fromAnonymousPrim = Normal++instance ToPrim (RepoPatchV2 prim) where+    toPrim (Normal p) = Just p+    toPrim _ = Nothing++instance PrimPatch prim => Eq2 (RepoPatchV2 prim) where+    (Duplicate x) =\/= (Duplicate y) | x == y = IsEq+    (Etacilpud x) =\/= (Etacilpud y) | x == y = IsEq+    (Normal x) =\/= (Normal y) = x =\/= y+    (Conflictor cx xx x) =\/= (Conflictor cy yy y)+        | map commuteOrAddIXX cx `eqSet` map commuteOrAddIYY cy+          && commuteOrAddIXX x == commuteOrAddIYY y = reverseFL xx =/~\= reverseFL yy+      where+          commuteOrAddIXX = commutePrimsOrAddToCtx (invertFL xx)+          commuteOrAddIYY = commutePrimsOrAddToCtx (invertFL yy)+    (InvConflictor cx xx x) =\/= (InvConflictor cy yy y)+        | cx `eqSet` cy && x == y = xx =\~/= yy+    _ =\/= _ = NotEq++eqSet :: Eq a => [a] -> [a] -> Bool+eqSet [] [] = True+eqSet (x:xs) xys | Just ys <- remove1 x xys = eqSet xs ys+eqSet _ _ = False++remove1 :: Eq a => a -> [a] -> Maybe [a]+remove1 x (y : ys) = if x == y then Just ys else (y :) `fmap` remove1 x ys+remove1 _ [] = Nothing++minus :: Eq a => [a] -> [a] -> Maybe [a]+minus xs [] = Just xs+minus xs (y:ys) = do xs' <- remove1 y xs+                     xs' `minus` ys++invertNon :: PrimPatch prim => Non (RepoPatchV2 prim) wX+          -> Non (RepoPatchV2 prim) wX+invertNon (Non c x)+    | Just rc' <- removeRL nix (reverseFL c) = Non (reverseRL rc') (invert x)+    | otherwise = commuteOrAddToCtxRL (reverseFL c :<: Normal x) $ non nix+  where+    nix = Normal $ invert x++nonTouches :: PatchInspect prim => Non (RepoPatchV2 prim) wX -> [AnchoredPath]+nonTouches (Non c x) = listTouchedFiles (c +>+ Normal x :>: NilFL)++nonHunkMatches :: PatchInspect prim => (BC.ByteString -> Bool)+               -> Non (RepoPatchV2 prim) wX -> Bool+nonHunkMatches f (Non c x) = hunkMatches f c || hunkMatches f x++toNons :: forall p wX wY . (Commute p, PatchListFormat p,+       Nonable p, ShowPatchBasic (PrimOf p), ShowPatchBasic p)+       => FL p wX wY -> [Non p wX]+toNons xs = map lastNon $ initsFL xs+    where lastNon :: Sealed ((p :> FL p) wX) -> Non p wX+          lastNon (Sealed xxx) =+              case lastNon_aux xxx of+                   deps :> p :> _ ->+                       case non p of+                           Non NilFL pp -> Non (reverseRL deps) pp+                           Non ds pp ->+                               error $ renderString $+                                  redText "Weird case in toNons" $$+                                  redText "please report this bug!" $$+                                  (case xxx of+                                   z :> zs -> displayPatch (z :>: zs)) $$+                                  redText "ds are" $$ displayPatch ds $$+                                  redText "pp is" $$ displayPatch pp++          reverseFoo :: (p :> FL p) wX wZ -> (RL p :> p) wX wZ+          reverseFoo (p :> ps) = rf NilRL p ps+            where+              rf :: RL p wA wB -> p wB wC -> FL p wC wD+                 -> (RL p :> p) wA wD+              rf rs l NilFL = rs :> l+              rf rs x (y :>: ys) = rf (rs :<: x) y ys++          lastNon_aux :: (p :> FL p) wX wZ -> (RL p :> p :> RL p) wX wZ+          lastNon_aux = commuteWhatWeCanRL . reverseFoo++filterConflictsFL :: PrimPatch prim => Non (RepoPatchV2 prim) wX+                  -> FL prim wX wY -> (FL prim :> FL prim) wX wY+filterConflictsFL _ NilFL = NilFL :> NilFL+filterConflictsFL n (p :>: ps)+    | Just n' <- commuteOrRemFromCtx (Normal p) n =+        case filterConflictsFL n' ps of+            p1 :> p2 -> p :>: p1 :> p2+    | otherwise = case commuteWhatWeCanFL (p :> ps) of+                      p1 :> p' :> p2 ->+                          case filterConflictsFL n p1 of+                              p1a :> p1b -> p1a :> p1b +>+ p' :>: p2++instance Invert prim => Invert (RepoPatchV2 prim) where+    invert (Duplicate d) = Etacilpud d+    invert (Etacilpud d) = Duplicate d+    invert (Normal p) = Normal (invert p)+    invert (Conflictor x c p) = InvConflictor x c p+    invert (InvConflictor x c p) = Conflictor x c p++-- | Commute conflicting patches, i.e. one of them is the result of a+-- conflicted 'merge' with the other.+commuteConflicting :: PrimPatch prim+                   => CommuteFn (RepoPatchV2 prim) (RepoPatchV2 prim)+commuteConflicting (Normal x :> Conflictor a1'nop2 n1'x p1')+    | Just rn1' <- removeRL x (reverseFL n1'x) = do+        let p2 : n1nons = reverse $ xx2nons a1'nop2 $ reverseRL (rn1' :<: x)+            a2 = p1' : a1'nop2 ++ n1nons+        case (a1'nop2, reverseRL rn1', p1') of+            ([], NilFL, Non c y) | NilFL <- joinEffects c ->+                Just (Normal y :> Conflictor a1'nop2 (y :>: NilFL) p2)+            (a1, n1, _) ->+                Just (Conflictor a1 n1 p1' :> Conflictor a2 NilFL p2)+commuteConflicting c@(InvConflictor{} :> Normal _) = invertCommuteC c+commuteConflicting (Conflictor a1 n1 p1 :> Conflictor a2 n2 p2)+    | Just a2_minus_p1 <- remove1 p1' a2+    , not (p2 `dependsUpon` p1') = do+        let n1nons = map (commutePrimsOrAddToCtx n2) $ xx2nons a1 n1+            n2nons = xx2nons a2 n2+            Just a2_minus_p1n1 = a2_minus_p1 `minus` n1nons+            n2n1 = n2 +>+ n1+            a1' = map (commutePrimsOrAddToCtx n2) a1+            p2ooo = remNons a1' p2+        n1' :> n2' <- return $ filterConflictsFL p2ooo n2n1+        let n1'n2'nons = xx2nons a2_minus_p1n1 (n1' +>+ n2')+            n1'nons = take (lengthFL n1') n1'n2'nons+            n2'nons = drop (lengthFL n1') n1'n2'nons+            Just a1'nop2 = (a2 ++ n2nons) `minus` (p1' : n1'nons)+            Just a2'o =+                fst (allConflictsWith p2 $ a2_minus_p1 ++ n2nons)+                `minus` n2'nons+            Just a2' =+                mapM (commuteOrRemFromCtxFL (xx2patches a1'nop2 n1')) a2'o+            Just p2' = commuteOrRemFromCtxFL (xx2patches a1'nop2 n1') p2+        case (a2', n2', p2') of+            ([], NilFL, Non c x) ->+                case joinEffects c of+                    NilFL -> let n1'x = n1' +>+ x :>: NilFL in+                             Just (Normal x :> Conflictor a1'nop2 n1'x p1')+                    _ -> error "impossible case"+            _ -> Just (c1 :> c2)+              where+                c1 = Conflictor a2' n2' p2'+                c2 = Conflictor (p2 : a1'nop2) n1' p1'+    where (_, rpn2) = geteff a2 n2+          p1' = commuteOrAddToCtxRL (reverseFL rpn2) p1+commuteConflicting c@(InvConflictor{} :> InvConflictor{}) = invertCommuteC c+commuteConflicting _ = Nothing++instance PrimPatch prim => Commute (RepoPatchV2 prim) where+    commute pair@(x :> y) =+      commuteNoConflicts (assertConsistent x :> assertConsistent y)+      `mplus`+      commuteConflicting pair++instance PrimPatch prim => CleanMerge (RepoPatchV2 prim) where+    cleanMerge = mergeNoConflicts++instance PrimPatch prim => Merge (RepoPatchV2 prim) where+    merge (InvConflictor{} :\/: _) = error "impossible case"+    merge (_ :\/: InvConflictor{}) = error "impossible case"+    merge (Etacilpud _ :\/: _) = error "impossible case"+    merge (_ :\/: Etacilpud _) = error "impossible case"+++    merge (Duplicate a :\/: Duplicate b) = Duplicate b :/\: Duplicate a+    -- We had a FIXME comment on this case, why?+    merge (Duplicate a :\/: b) =+        b :/\: Duplicate (commuteOrAddToCtx (invert b) a)++    -- Handle using the swap merge and the previous case.+    merge m@(_ :\/: Duplicate _) = swapMerge m++    merge (x :\/: y)+        -- First try the non-conflicting merge.+        | Just (y' :/\: x') <-+            mergeNoConflicts ((assertConsistent x) :\/: (assertConsistent y))+              = assertConsistent y' :/\: assertConsistent x'+        -- If we detect equal patches, we have a duplicate.+        | IsEq <- x =\/= y+        , n <- commuteOrAddToCtx (invert x) $ non x =+            Duplicate n :/\: Duplicate n++    -- We know that these two patches conflict, and aren't Duplicates, since we+    -- failed the previous case. We therefore create basic Conflictors, which+    -- undo the other patch.+    merge (nx@(Normal x) :\/: ny@(Normal y)) = cy :/\: cx+      where+        cy = Conflictor [] (x :>: NilFL) (non ny)+        cx = Conflictor [] (y :>: NilFL) (non nx)++    -- If a Normal patch @x@ and a Conflictor @cy@ conflict, we add @x@ to the+    -- effect of @cy@ on one side, and create a Conflictor that has no effect,+    -- but has the already-undone and conflicted patch of @cy@ and some foos as+    -- the already-undone on the other side.+    --+    -- TODO: what is foo?+    -- Why do we need nyy? I think @x'@ is @x@ in the context of @yy@.+    merge (Normal x :\/: Conflictor iy yy y) =+          Conflictor iy yyx y :/\: Conflictor (y : iy ++ nyy) NilFL x'+              where yyx = yy +>+ x :>: NilFL+                    (x' : nyy) = reverse $ xx2nons iy yyx++    -- Handle using the swap merge and the previous case.+    merge m@(Conflictor{} :\/: Normal _) = swapMerge m++    -- mH see also cH+    merge (Conflictor ix xx x :\/: Conflictor iy yy y) =+        case pullCommonRL (reverseFL xx) (reverseFL yy) of+            CommonRL rxx1 ryy1 c ->+                case commuteRLFL (ryy1 :> invertRL rxx1) of+                    Just (ixx' :> ryy') ->+                        let xx' = invert ixx'+                            yy' = reverseRL ryy'+                            y' : iy' =+                                map (commutePrimsOrAddToCtx xx') (y : iy)+                            x' : ix' =+                                map (commutePrimsOrAddToCtx ryy') (x : ix)+                            nyy' = xx2nons iy' yy'+                            nxx' = xx2nons ix' xx'+                            icx = drop (lengthRL rxx1) $+                                xx2nons ix (reverseRL $ rxx1 +<+ c)+                            ic' = map (commutePrimsOrAddToCtx ryy') icx+                            -- +++ is a more efficient version of nub (iy' +++                            -- ix') given that we know each element shows up+                            -- only once in either list.+                            ixy' = ic' ++ (iy' +++ ix')+                            c1 = Conflictor (x' : ixy' ++ nxx') yy' y'+                            c2 = Conflictor (y' : ixy' ++ nyy') xx' x' in+                            c1 :/\: c2+                    Nothing -> error "impossible case"++instance PatchInspect prim => PatchInspect (RepoPatchV2 prim) where+    listTouchedFiles (Duplicate p) = nonTouches p+    listTouchedFiles (Etacilpud p) = nonTouches p+    listTouchedFiles (Normal p) = listTouchedFiles p+    listTouchedFiles (Conflictor x c p) =+        nubSort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p+    listTouchedFiles (InvConflictor x c p) =+        nubSort $ concatMap nonTouches x ++ listTouchedFiles c ++ nonTouches p++    hunkMatches f (Duplicate p) = nonHunkMatches f p+    hunkMatches f (Etacilpud p) = nonHunkMatches f p+    hunkMatches f (Normal p) = hunkMatches f p+    hunkMatches f (Conflictor x c p) =+        any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p+    hunkMatches f (InvConflictor x c p) =+        any (nonHunkMatches f) x || hunkMatches f c || nonHunkMatches f p++-- | Split the rhs into those that /transitively/ conflict with the+-- lhs and those that don't.+allConflictsWith :: PrimPatch prim => Non (RepoPatchV2 prim) wX+                 -> [Non (RepoPatchV2 prim) wX]+                 -> ([Non (RepoPatchV2 prim) wX], [Non (RepoPatchV2 prim) wX])+allConflictsWith x ys = acw $ partition (conflictsWith x) ys+  where+    acw ([], nc) = ([], nc)+    acw (c:cs, nc) = case allConflictsWith c nc of+                         (c1, nc1) -> case acw (cs, nc1) of+                                          (xs', nc') -> (c : c1 ++ xs', nc')++conflictsWith :: PrimPatch prim => Non (RepoPatchV2 prim) wX+              -> Non (RepoPatchV2 prim) wX -> Bool+conflictsWith x y | x `dependsUpon` y || y `dependsUpon` x = False+conflictsWith x (Non cy y) =+    case commuteOrRemFromCtxFL cy x of+        Just (Non cx' x') ->+            let iy = Normal $ invert y in+            case commuteFL (iy :> cx' +>+ Normal x' :>: NilFL) of+                Just _ -> False+                Nothing -> True+        Nothing -> True++dependsUpon :: PrimPatch prim => Non (RepoPatchV2 prim) wX+            -> Non (RepoPatchV2 prim) wX -> Bool+dependsUpon (Non xs _) (Non ys y) =+    case removeSubsequenceFL (ys +>+ Normal y :>: NilFL) xs of+        Just _ -> True+        Nothing -> False++(+++) :: Eq a => [a] -> [a] -> [a]+[] +++ x = x+x +++ [] = x+(x:xs) +++ xys | Just ys <- remove1 x xys = x : (xs +++ ys)+               | otherwise = x : (xs +++ xys)++invertCommuteC :: PrimPatch prim => CommuteFn (RepoPatchV2 prim) (RepoPatchV2 prim)+invertCommuteC = invertCommuter commuteConflicting++invertCommuteNC :: PrimPatch prim => CommuteFn (RepoPatchV2 prim) (RepoPatchV2 prim)+invertCommuteNC = invertCommuter commuteNoConflicts++-- | 'pullCommon' @xs ys@ returns the set of patches that can be commuted out+-- of both @xs@ and @ys@ along with the remnants of both lists+pullCommon :: (Commute p, Eq2 p) => FL p wO wX -> FL p wO wY -> Common p wO wX wY+pullCommon NilFL ys = Fork NilFL NilFL ys+pullCommon xs NilFL = Fork NilFL xs NilFL+pullCommon (x :>: xs) xys | Just ys <- removeFL x xys =+    case pullCommon xs ys of+        Fork c xs' ys' -> Fork (x :>: c) xs' ys'+pullCommon (x :>: xs) ys =+    case commuteWhatWeCanFL (x :> xs) of+        xs1 :> x' :> xs2 -> case pullCommon xs1 ys of+            Fork c xs1' ys' -> Fork c (xs1' +>+ x' :>: xs2) ys'++-- | 'Common' @cs xs ys@ represents two sequences of patches that have @cs@ in+-- common, in other words @cs +>+ xs@ and @cs +>+ ys@+type Common p wO wX wY = Fork (FL p) (FL p) (FL p) wO wX wY++-- | 'pullCommonRL' @xs ys@ returns the set of patches that can be commuted+--   out of both @xs@ and @ys@ along with the remnants of both lists+pullCommonRL :: (Commute p, Eq2 p) => RL p wX wO -> RL p wY wO -> CommonRL p wX wY wO+pullCommonRL NilRL ys = CommonRL NilRL ys NilRL+pullCommonRL xs NilRL = CommonRL xs NilRL NilRL+pullCommonRL (xs :<: x) xys | Just ys <- removeRL x xys =+    case pullCommonRL xs ys of+        CommonRL xs' ys' c -> CommonRL xs' ys' (c :<: x)+pullCommonRL (xs :<: x) ys =+    case commuteWhatWeCanRL (xs :> x) of+        xs1 :> x' :> xs2 ->+            case pullCommonRL xs2 ys of+                CommonRL xs2' ys' c -> CommonRL (xs1 :<: x' +<+ xs2') ys' c++-- | 'CommonRL' @xs ys cs@' represents two sequences of patches that have @cs@+-- in common, in other words @xs +<+ cs@ and @ys +<+ cs@+data CommonRL p wX wY wF where+    CommonRL :: RL p wX wI -> RL p wY wI -> RL p wI wF -> CommonRL p wX wY wF++instance PrimPatch prim => Apply (RepoPatchV2 prim) where+    type ApplyState (RepoPatchV2 prim) = ApplyState prim+    apply p = applyPrimFL (effect p)++instance PrimPatch prim => RepairToFL (RepoPatchV2 prim) where+    applyAndTryToFixFL (Normal p) =+        mapMaybeSnd (mapFL_FL Normal) `liftM` applyAndTryToFixFL p+    applyAndTryToFixFL x = do apply x; return Nothing++instance PatchListFormat (RepoPatchV2 prim) where+   -- In principle we could use ListFormatDefault when prim /= V1 Prim patches,+   -- as those are the only case where we need to support a legacy on-disk+   -- format. In practice we don't expect RepoPatchV2 to be used with any other+   -- argument anyway, so it doesn't matter.+    patchListFormat = ListFormatV2++duplicate, etacilpud, conflictor, rotcilfnoc :: String+duplicate = "duplicate"+etacilpud = "etacilpud"+conflictor = "conflictor"+rotcilfnoc = "rotcilfnoc"++instance PrimPatch prim => ShowPatchBasic (RepoPatchV2 prim) where+    showPatch f (Duplicate d) = blueText duplicate $$ showNon f d+    showPatch f (Etacilpud d) = blueText etacilpud $$ showNon f d+    showPatch f (Normal p) = showPatch f p+    showPatch f (Conflictor i NilFL p) =+        blueText conflictor <+> showNons f i <+> blueText "[]" $$ showNon f p+    showPatch f (Conflictor i cs p) =+        blueText conflictor <+> showNons f i <+> blueText "[" $$+        showFL f cs $$+        blueText "]" $$+        showNon f p+    showPatch f (InvConflictor i NilFL p) =+        blueText rotcilfnoc <+> showNons f i <+> blueText "[]" $$ showNon f p+    showPatch f (InvConflictor i cs p) =+        blueText rotcilfnoc <+> showNons f i <+> blueText "[" $$+        showFL f cs $$+        blueText "]" $$+        showNon f p++instance PrimPatch prim => ShowContextPatch (RepoPatchV2 prim) where+    showPatchWithContextAndApply f (Normal p) = showPatchWithContextAndApply f p+    showPatchWithContextAndApply f p = apply p >> return (showPatch f p)++instance PrimPatch prim => ShowPatch (RepoPatchV2 prim) where+    summary = plainSummary+    summaryFL = plainSummary+    thing _ = "change"++instance PrimPatch prim => ReadPatch (RepoPatchV2 prim) where+    readPatch' = do+        skipSpace+        let str = string . BC.pack+            readConflictorPs = do+               i <- readNons+               ps <- bracketedFL readPatch' '[' ']'+               p <- readNon+               return (i, ps, p)+        choice [ do str duplicate+                    p <- readNon+                    return $ Sealed $ Duplicate p+               , do str etacilpud+                    p <- readNon+                    return $ Sealed $ Etacilpud p+               , do str conflictor+                    (i, Sealed ps, p) <- readConflictorPs+                    return $ Sealed $ Conflictor i (unsafeCoerceP ps) p+               , do str rotcilfnoc+                    (i, Sealed ps, p) <- readConflictorPs+                    return $ Sealed $ InvConflictor i ps p+               , do Sealed p <- readPatch'+                    return $ Sealed $ Normal p+               ]++instance Show2 prim => Show (RepoPatchV2 prim wX wY) where+    showsPrec d (Normal prim) =+        showParen (d > appPrec) $ showString "Normal " . showsPrec2 (appPrec + 1) prim++    showsPrec d (Duplicate x) =+        showParen (d > appPrec) $ showString "Duplicate " . showsPrec (appPrec + 1) x++    showsPrec d (Etacilpud x) =+        showParen (d > appPrec) $ showString "Etacilpud " . showsPrec (appPrec + 1) x++    showsPrec d (Conflictor ix xx x) =+        showParen (d > appPrec) $+            showString "Conflictor " . showsPrec (appPrec + 1) ix .+            showString " " . showsPrec (appPrec + 1) xx .+            showString " " . showsPrec (appPrec + 1) x++    showsPrec d (InvConflictor ix xx x) =+        showParen (d > appPrec) $+            showString "InvConflictor " . showsPrec (appPrec + 1) ix .+            showString " " . showsPrec (appPrec + 1) xx .+            showString " " . showsPrec (appPrec + 1) x++instance Show2 prim => Show1 (RepoPatchV2 prim wX)++instance Show2 prim => Show2 (RepoPatchV2 prim)++instance PrimPatch prim => Nonable (RepoPatchV2 prim) where+    non (Duplicate d) = d+    non (Etacilpud d) = invertNon d -- FIXME !!! ???+    non (Normal p) = Non NilFL p+    non (Conflictor _ xx x) = commutePrimsOrAddToCtx (invertFL xx) x+    non (InvConflictor _ _ n) = invertNon n++instance PrimPatch prim => Effect (RepoPatchV2 prim) where+    effect (Duplicate _) = NilFL+    effect (Etacilpud _) = NilFL+    effect (Normal p) = p :>: NilFL+    effect (Conflictor _ e _) = invert e+    effect (InvConflictor _ e _) = e++instance IsHunk prim => IsHunk (RepoPatchV2 prim) where+    isHunk rp = do Normal p <- return rp+                   isHunk p++displayNons :: (PatchListFormat p, ShowPatchBasic p, PrimPatchBase p) =>+               [Non p wX] -> Doc+displayNons p = showNons ForDisplay p++showFL :: ShowPatchBasic p => ShowPatchFor -> FL p wX wY -> Doc+showFL f = vcat . mapFL (showPatch f)
+ src/Darcs/Patch/V3.hs view
@@ -0,0 +1,27 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Patch.V3 ( RepoPatchV3 ) where++import Darcs.Prelude++import Darcs.Patch.FromPrim ( FromPrim(..) )+import Darcs.Patch.Prim.Named+  ( PrimPatchId+  , anonymousNamedPrim, namedPrim, positivePrimPatchIds+  )+import Darcs.Patch.Witnesses.Ordered ( FL(..) )+import qualified Darcs.Patch.V3.Core as Core ( RepoPatchV3(..) )+import Darcs.Patch.V3.Resolution ()++type RepoPatchV3 = Core.RepoPatchV3 PrimPatchId++-- This instance is specialised to PrimPatchId because it is dependent+-- on the relationship between PatchInfo and PrimPatchId+instance FromPrim (RepoPatchV3 prim) where+  fromAnonymousPrim = Core.Prim . anonymousNamedPrim+  fromPrim pid p = Core.Prim (namedPrim pid p)+  fromPrims = go . positivePrimPatchIds+    where+      go :: [PrimPatchId] -> FL prim wX wY -> FL (RepoPatchV3 prim) wX wY+      go _ NilFL = NilFL+      go (pid:pids) (p:>:ps) = fromPrim pid p :>: go pids ps+      go [] _ = error "positivePrimPatchIds should return an infinite list"
+ src/Darcs/Patch/V3/Contexted.hs view
@@ -0,0 +1,252 @@+-- | 'Contexted' patches.++{-# LANGUAGE ViewPatterns #-}+module Darcs.Patch.V3.Contexted+    ( -- * Contexted patches+      Contexted+      -- * Query+    , ctxId+    , ctxView+    , ctxNoConflict+    , ctxToFL+    , ctxDepends+      -- * Construct / Modify+    , ctx+    , ctxAdd+    , ctxAddRL+    , ctxAddInvFL+    , ctxAddFL+    , commutePast+    , commutePastRL+      -- * 'PatchInspect' helpers+    , ctxTouches+    , ctxHunkMatches+      -- * 'ReadPatch' and 'ShowPatch' helpers+    , showCtx+    , readCtx+      -- * Properties+    , prop_ctxInvariants+    , prop_ctxEq+    , prop_ctxPositive+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC ( pack )+import Data.Maybe ( isNothing, isJust )++import Darcs.Prelude++import Darcs.Patch.Commute+import Darcs.Patch.Format ( PatchListFormat(..) )+import Darcs.Patch.Ident+import Darcs.Patch.Invert+import Darcs.Patch.Inspect+import Darcs.Patch.Merge ( CleanMerge(..) )+import Darcs.Patch.Read ( ReadPatch(..) )+import Darcs.Patch.Permutations ( (=\~/=) )+import Darcs.Util.Parser ( Parser, lexString )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor )+import Darcs.Patch.Viewing ()+import Darcs.Patch.Witnesses.Eq+import Darcs.Patch.Witnesses.Ordered+import Darcs.Patch.Witnesses.Sealed+import Darcs.Patch.Witnesses.Show++import Darcs.Util.Path ( AnchoredPath )+import Darcs.Util.Printer++{-+| (Definition 10.1) A 'Contexted' patch is a patch transferred to, or viewed+from, a different context.++More precisely we make the following definitions:++* A /context/ for a patch @p@ is a sequence of patches that @p@ depends on,+  and such that it never contains a patch and its inverse.++* A 'Contexted' patch is a patch @p@ together with a context for @p@, such+  that the end state of the patch and its context is hidden (existentially+  quantified).++The definition of context above is chosen so that this sequence is minimal.+-}+data Contexted p wX where+  Contexted :: FL p wX wY -> p wY wZ -> Contexted p wX++-- | Equality between 'Contexted' patches reduces to equality of the+-- identifiers of the patches referred to /if/ we look at them from the same+-- context. (This assumes witnesses aren't coerced in an unsafe manner.)+instance Ident p => Eq (Contexted p wX) where+  c1 == c2 = ctxId c1 == ctxId c2++instance Ident p => Ord (Contexted p wX) where+  cp `compare` cq = ctxId cp `compare` ctxId cq++instance Show2 p => Show (Contexted p wX) where+  showsPrec d (Contexted ps p) =+    showParen (d > appPrec) $ showString "Contexted " .+    showsPrec2 (appPrec + 1) ps . showString " " .+    showsPrec2 (appPrec + 1) p++instance Show2 p => Show1 (Contexted p)++-- | This property states that no prefix of the context commutes with the rest+-- of the 'Contexted' patch and that the context never contains a patch+-- and its inverse.+prop_ctxInvariants :: (Commute p, Invert p, SignedIdent p) => Contexted p wX -> Bool+prop_ctxInvariants (Contexted NilFL _) = True+prop_ctxInvariants c@(Contexted (_ :>: ps) q) =+  prop_ctxInvariants (Contexted ps q) && prop_ctxNotCom c && prop_ctxNotInv c++-- | This property states that the first patch in the context must not+-- commute with the rest of the 'Contexted' patch.+prop_ctxNotCom :: Commute p => Contexted p wX -> Bool+prop_ctxNotCom (Contexted NilFL _) = True+prop_ctxNotCom (Contexted (p :>: ps) q) =+  isNothing $ commuteFL (p :> ps +>+ q :>: NilFL)++-- | This property states that patches in the context of a 'Contexted' patch as+-- well as the patch itself are positive. It does /not/ necessarily hold for all+-- 'Contexted' patches.+prop_ctxPositive :: SignedIdent p => Contexted p wX -> Bool+prop_ctxPositive (Contexted ps p) =+  allFL (positiveId . ident) ps && positiveId (ident p)++-- | This property states that the inverse of the first patch in the context+-- is not contained in the rest of the context.+prop_ctxNotInv :: SignedIdent p => Contexted p wX -> Bool+prop_ctxNotInv (Contexted NilFL _) = True+prop_ctxNotInv (Contexted (p :>: ps) _) =+  invertId (ident p) `notElem` mapFL ident ps++-- | This property states that equal 'Contexted' patches have equal content+-- up to reorderings of the context patches.+prop_ctxEq :: (Commute p, Eq2 p, Ident p) => Contexted p wX -> Contexted p wX -> Bool+prop_ctxEq cp@(Contexted ps p) cq@(Contexted qs q)+  | cp == cq =+      case ps =\~/= qs of+        IsEq -> isIsEq (p =\/= q)+        NotEq -> False+prop_ctxEq _ _ = True++-- * Query++-- | Identity of a contexted patch.+{-# INLINE ctxId #-}+ctxId :: Ident p => Contexted p wX -> PatchId p+ctxId (Contexted _ p) = ident p++-- | Wether the first argument is contained (identity-wise) in the context of+-- the second, in other words, the second depends on the first. This does not+-- include equality, only proper dependency.+ctxDepends :: Ident p => Contexted p wX -> Contexted p wX -> Bool+ctxDepends (Contexted _ p1) (Contexted c2 _) = ident p1 `elem` mapFL ident c2++-- | 'Contexted' patches conflict with each other if the identity of one is in+-- the context of the other or they cannot be merged cleanly.+ctxNoConflict :: (CleanMerge p, Commute p, Ident p)+              => Contexted p wX -> Contexted p wX -> Bool+ctxNoConflict cp cq | cp == cq = True+ctxNoConflict (Contexted ps p) (Contexted qs q)+  | ident p `elem` mapFL ident qs || ident q `elem` mapFL ident ps = False+  | otherwise =+      case findCommonFL ps qs of+        Fork _ ps' qs' ->+          isJust $ cleanMerge (ps' +>+ p :>: NilFL :\/: qs' +>+ q :>: NilFL)++{-+-- This is (Definition 10.4) of the paper.+-- It misses a case for equal contexted patches and is also quite slow.+ctxNoConflict (Contexted cs p) cq =+  isJust $ commutePast (invert p) (ctxAddInvFL cs cq)+-}++-- | We sometimes want to pattern match on a 'Contexted' patch but still guard+-- against violation of the invariants. So we export a view that is isomorphic+-- to the 'Contexted' type but doesn't allow to manipulate the internals.+ctxView :: Contexted p wX -> Sealed ((FL p :> p) wX)+ctxView (Contexted cs p) = Sealed (cs :> p)++-- | Convert a 'Contexted' patch into a plain 'FL' with the patch at the end.+ctxToFL :: Contexted p wX -> Sealed (FL p wX)+ctxToFL (ctxView -> Sealed (ps :> p)) = Sealed (ps +>+ p :>: NilFL)++-- * Construct++-- | A 'Contexted' patch with empty context.+ctx :: p wX wY -> Contexted p wX+ctx p = Contexted NilFL p++-- | Add a patch to the context of a 'Contexted' patch. This is+-- the place where we take care of the invariants.+ctxAdd :: (Commute p, Invert p, Ident p)+       => p wX wY -> Contexted p wY -> Contexted p wX+ctxAdd p (Contexted ps q)+  | Just ps' <- fastRemoveFL (invert p) ps = Contexted ps' q+ctxAdd p c@(Contexted ps q) =+  case commutePast p c of+    Just c' -> c'+    Nothing -> Contexted (p :>: ps) q++-- | Add an 'RL' of patches to the context.+ctxAddRL :: (Commute p, Invert p, Ident p)+         => RL p wX wY -> Contexted p wY -> Contexted p wX+ctxAddRL NilRL cp = cp+ctxAddRL (ps :<: p) cp = ctxAddRL ps (ctxAdd p cp)++-- | Add an 'FL' of patches to the context but invert it first.+ctxAddInvFL :: (Commute p, Invert p, Ident p)+            => FL p wX wY -> Contexted p wX -> Contexted p wY+ctxAddInvFL = ctxAddRL . invertFL++-- | Add an 'FL' of patches to the context.+ctxAddFL :: (Commute p, Invert p, Ident p)+         => FL p wX wY -> Contexted p wY -> Contexted p wX+ctxAddFL NilFL t = t+ctxAddFL (p :>: ps) t = ctxAdd p (ctxAddFL ps t)++-- | (Definition 10.2) Commute a patch past a 'Contexted' patch. This+-- commutes it past the context and then past the patch itself. If it+-- succeeds, the patch that we commuted past gets dropped.+-- Note that this does /not/ succeed if the inverted patch is in the+-- 'Contexted' patch.+commutePast :: Commute p+            => p wX wY -> Contexted p wY -> Maybe (Contexted p wX)+commutePast q (Contexted ps p) = do+  ps' :> q' <- commuteFL (q :> ps)+  p' :> _ <- commute (q' :> p)+  return (Contexted ps' p')++-- | Not defined in the paper but used in the commute algorithm.+commutePastRL :: Commute p+              => RL p wX wY -> Contexted p wY -> Maybe (Contexted p wX)+commutePastRL = foldRL_M commutePast++-- * 'PatchInspect' helpers++ctxTouches :: PatchInspect p => Contexted p wX -> [AnchoredPath]+ctxTouches (Contexted ps p) =+  concat $ listTouchedFiles p : mapFL listTouchedFiles ps++ctxHunkMatches :: PatchInspect p => (B.ByteString -> Bool)+               -> Contexted p wX -> Bool+ctxHunkMatches f (Contexted ps p) = hunkMatches f ps || hunkMatches f p++-- * 'ReadPatch' and 'ShowPatch' helpers++-- For storage it would be enough to read/write the patch identifiers in the+-- context. But this means that we need access to the patches preceding us.+-- So these functions would no longer be independent of context.++showCtx :: (ShowPatchBasic p, PatchListFormat p)+        => ShowPatchFor -> Contexted p wX -> Doc+showCtx f (Contexted c p) =+  hiddenPrefix "|" (showPatch f c) $$ hiddenPrefix "|" (blueText ":") $$ showPatch f p++readCtx :: (ReadPatch p, PatchListFormat p)+        => Parser (Contexted p wX)+readCtx = do+  Sealed ps <- readPatch'+  lexString (BC.pack ":")+  Sealed p <- readPatch'+  return $ Contexted ps p
+ src/Darcs/Patch/V3/Core.hs view
@@ -0,0 +1,578 @@+{- | 'Conflictor's a la camp.++Similar to the camp paper, but with a few differences:++* no reverse conflictors and no Invert instance++* instead we directly implement cleanMerge++* minor details of merge and commute due to bug fixes++The proofs in this module assume that whenever we create a conflictor we+maintain the following invariants:++(1) A conflictor reverts a patch in its context iff it is the first patch+    that conflicts with it. This implies that any patch a conflictor reverts+    exists in its context as an unconflicted Prim.++(2) If v depends on u and p conflicts with u then it also conflicts with v.++-}++{-# LANGUAGE ViewPatterns, PatternSynonyms #-}+module Darcs.Patch.V3.Core+    ( RepoPatchV3(..)+    , pattern PrimP+    , pattern ConflictorP+    , (+|)+    , (-|)+    ) where++import Control.Applicative ( Alternative(..) )+import Control.Monad ( guard )+import qualified Data.ByteString.Char8 as BC+import Data.List.Ordered ( nubSort )+import qualified Data.Set as S++import Darcs.Prelude++import Darcs.Patch.Commute ( commuteFL, commuteRL, commuteRLFL )+import Darcs.Patch.CommuteFn ( CommuteFn )+import Darcs.Patch.CommuteNoConflicts ( CommuteNoConflicts(..) )+import Darcs.Patch.Debug ( PatchDebug(..) )+import Darcs.Patch.FileHunk ( IsHunk(..) )+import Darcs.Patch.Format ( ListFormat(ListFormatV3) )+import Darcs.Patch.FromPrim ( ToPrim(..) )+import Darcs.Patch.Ident+    ( Ident(..)+    , PatchId+    , SignedId(..)+    , StorableId(..)+    , commuteToPrefix+    , fastRemoveFL+    , findCommonFL+    , (=\^/=)+    )+import Darcs.Patch.Invert ( Invert, invert )+import Darcs.Patch.Merge+    ( CleanMerge(..)+    , Merge(..)+    , cleanMergeFL+    , swapCleanMerge+    , swapMerge+    )+import Darcs.Patch.Prim ( PrimPatch, applyPrimFL, sortCoalesceFL )+import Darcs.Patch.Prim.WithName ( PrimWithName, wnPatch )+import Darcs.Patch.Read ( bracketedFL )+import Darcs.Patch.Repair (RepairToFL(..), Check(..) )+import Darcs.Patch.RepoPatch+    ( Apply(..)+    , Commute(..)+    , Effect(..)+    , Eq2(..)+    , PatchInspect(..)+    , PatchListFormat(..)+    , PrimPatchBase(..)+    , ReadPatch(..)+    , Summary(..)+    )+import Darcs.Patch.Show hiding ( displayPatch )+import Darcs.Patch.Summary+    ( ConflictState(..)+    , IsConflictedPrim(..)+    , plainSummary+    , plainSummaryFL+    )+import Darcs.Patch.Unwind ( Unwind(..), mkUnwound )+import Darcs.Patch.V3.Contexted+    ( Contexted+    , ctxId+    , ctxView+    , ctxNoConflict+    , ctx+    , ctxAddRL+    , ctxAddInvFL+    , ctxAddFL+    , commutePast+    , ctxToFL+    , ctxTouches+    , ctxHunkMatches+    , showCtx+    , readCtx+    )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+    ( (:/\:)(..)+    , (:>)(..)+    , (:\/:)(..)+    , FL(..)+    , Fork(..)+    , (+>+)+    , mapFL+    , mapFL_FL+    , reverseFL+    , reverseRL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, unseal )+import Darcs.Patch.Witnesses.Show ( Show1, Show2, appPrec, showsPrec2 )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP1 )++import Darcs.Test.TestOnly++import Darcs.Util.Parser ( string, lexString, choice, skipSpace )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , (<+>)+    , blueText+    , redText+    , renderString+    , vcat+    )++data RepoPatchV3 name prim wX wY where+  Prim :: PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY+  Conflictor :: FL (PrimWithName name prim) wX wY             -- ^ effect+             -> S.Set (Contexted (PrimWithName name prim) wY) -- ^ conflicts+             -> Contexted (PrimWithName name prim) wY         -- ^ identity+             -> RepoPatchV3 name prim wX wY++{- Naming convention: If we don't examine the contents of a RepoPatchV3, we+use @p@ (on the lhs) and @q@ (on the rhs), otherwise these names refer to+the (uncontexted) prims they represent (regardless of whether they are+conflicted or not). The components of Conflictors are named as follows: On+the lhs we use @Conflictor r x cp@, on the rhs @Conflictor s y cq@, execpt+when we have two conflictors that may have common prims in their effects. In+that case we use @com_r@ and @com_s@ for the effects and use @r@ and @s@ for+the uncommon parts (and @com@ for the common part). Primed versions always+refer to things with the same ident/name i.e. they are commuted versions of+the un-primed ones. -}++-- TODO now that we export the constructors of RepoPatchV3 these+-- pattern synonyms could probably be removed+pattern PrimP :: TestOnly => PrimWithName name prim wX wY -> RepoPatchV3 name prim wX wY+pattern PrimP prim <- Prim prim++pattern ConflictorP+  :: TestOnly+  => FL (PrimWithName name prim) wX wY+  -> S.Set (Contexted (PrimWithName name prim) wY)+  -> Contexted (PrimWithName name prim) wY+  -> RepoPatchV3 name prim wX wY+pattern ConflictorP r x cp <- Conflictor r x cp++-- * Effect++instance Effect (RepoPatchV3 name prim) where+  effect (Prim p) = wnPatch p :>: NilFL+  effect (Conflictor r _ _) = mapFL_FL wnPatch r++-- * Ident++type instance PatchId (RepoPatchV3 name prim) = name++instance SignedId name => Ident (RepoPatchV3 name prim) where+  ident (Prim p) = ident p+  ident (Conflictor _ _ cp) = ctxId cp++-- * Merge++-- We only use displayPatch for error messages here, so it makes sense+-- to use the storage format that contains the patch names.+displayPatch :: ShowPatchBasic p => p wX wY -> Doc+displayPatch p = showPatch ForStorage p++instance (SignedId name, StorableId name, PrimPatch prim) =>+         CleanMerge (RepoPatchV3 name prim) where+  cleanMerge (p :\/: q)+    | ident p == ident q = error "merging identical patches is undefined"+  cleanMerge (Prim p :\/: Prim q) = do+    q' :/\: p' <- cleanMerge (p :\/: q)+    return $ Prim q' :/\: Prim p'+  cleanMerge (Prim p :\/: Conflictor s y cq) = do+    -- note: p cannot occur in y, because every element of y already+    -- exists in the history /before/ the rhs, and PatchIds must be+    -- unique in a repo+    s' :/\: p' <- cleanMergeFL (p :\/: s)+    let ip' = invert p'+    cq' <- commutePast ip' cq+    y' <- S.fromList <$> mapM (commutePast ip') (S.toList y)+    return $ Conflictor s' y' cq' :/\: Prim p'+  cleanMerge pair@(Conflictor {} :\/: Prim {}) = swapCleanMerge pair+  cleanMerge (Conflictor com_r x cp :\/: Conflictor com_s y cq) =+    case findCommonFL com_r com_s of+      Fork _ rev_r rev_s -> do+        s' :/\: r' <- cleanMerge (rev_r :\/: rev_s)+        -- the paper uses commutePast to calculate cp' and cq', but this must+        -- succeed (and then give the same result as adding to the context)+        -- because of the ctxNoConflict guards below+        let cp' = ctxAddInvFL s' cp+        let cq' = ctxAddInvFL r' cq+        let x' = S.map (ctxAddInvFL s') x+        let y' = S.map (ctxAddInvFL r') y+        guard (ctxNoConflict cq' cp')+        guard $ all (ctxNoConflict cq') (S.difference x' y')+        guard $ all (ctxNoConflict cp') (S.difference y' x')+        return $ Conflictor s' y' cq' :/\: Conflictor r' x' cp'++instance (SignedId name, StorableId name, PrimPatch prim) =>+         Merge (RepoPatchV3 name prim) where+  -- * no conflict+  merge pq | Just r <- cleanMerge pq = r+  -- * conflicting prim patches:+  -- If we have p and pull conflicting q, we make a conflictor+  -- that inverts p, conflicts with p, and represents q.+  merge (Prim p :\/: Prim q) =+    Conflictor (invert p :>: NilFL) (S.singleton (ctx p)) (ctx q)+    :/\:+    Conflictor (invert q :>: NilFL) (S.singleton (ctx q)) (ctx p)+  -- * prim patch p conflicting with conflictor on the rhs:+  -- The rhs is the first to conflict with p, so we must add invert p+  -- to its effect, and to its conflicts (adding invert r as context for p).+  -- For the other branch, we add a new conflictor representing p. It+  -- conflicts with q and has no effect, since q is already conflicted.+  merge (Prim p :\/: Conflictor r x cq) =+    Conflictor (invert p :>: r) (ctxAddInvFL r (ctx p) +| x) cq+    :/\:+    Conflictor NilFL (S.singleton cq) (ctxAddInvFL r (ctx p))+  -- same as previous case with both sides swapped+  merge pair@(Conflictor {} :\/: Prim {}) = swapMerge pair+  -- * conflictor c1 conflicts with conflictor c2:+  -- If we pull c2 onto c1, we remove everything common to both effects+  -- from the effect of c2 (but still remember that we conflict with them).+  -- We also record that we now conflict with c1, too, and as before keep+  -- our identity unchanged. The rest consists of adapting contexts.+  merge (lhs@(Conflictor com_r x cp) :\/: rhs@(Conflictor com_s y cq)) =+    case findCommonFL com_r com_s of+      Fork _ r s ->+        case cleanMerge (r :\/: s) of+          Just (s' :/\: r') ->+            let cp' = ctxAddInvFL s' cp+                cq' = ctxAddInvFL r' cq+                x' = cq' +| S.map (ctxAddInvFL s') x+                y' = cp' +| S.map (ctxAddInvFL r') y+            in Conflictor s' y' cq' :/\: Conflictor r' x' cp'+          Nothing ->+            -- Proof that this is impossible:+            --+            -- A conflictor reverts another patch only if it is the first that+            -- conflicts with it. Thus every patch it reverts is contained in+            -- its context as an unconflicted Prim patch. This holds for both+            -- lhs and rhs, which share the same context. Thus there can be no+            -- conflict between the effects of lhs and rhs. QED+            error $ renderString $ redText "uncommon effects can't be merged cleanly:"+              $$ redText "lhs:" $$ displayPatch lhs+              $$ redText "rhs:" $$ displayPatch rhs+              $$ redText "r:" $$ displayPatch r+              $$ redText "s:" $$ displayPatch s++-- * CommuteNoConflicts++instance (SignedId name, StorableId name, PrimPatch prim)+  => CommuteNoConflicts (RepoPatchV3 name prim) where++  -- The various side-conditions here include checks that the two sides+  -- are not in conflict with each other (if the rhs is a Conflictor).+  commuteNoConflicts (Prim p :> Prim q) = do+    q' :> p' <- commute (p :> q)+    return $ Prim q' :> Prim p'+  commuteNoConflicts (Conflictor r x cp :> Prim q) = do+    q' :> r' <- commuteRL (reverseFL r :> q)+    let iq = invert q+    cp' <- commutePast iq cp+    x' <- S.fromList <$> mapM (commutePast iq) (S.toList x)+    return $ Prim q' :> Conflictor (reverseRL r') x' cp'+  -- this case is completely symmetric to the previous one+  commuteNoConflicts (Prim p :> Conflictor s y cq) = do+    s' :> p' <- commuteFL (p :> s)+    cq' <- commutePast p' cq+    y' <- S.fromList <$> mapM (commutePast p') (S.toList y)+    return $ Conflictor s' y' cq' :> Prim p'+  commuteNoConflicts (Conflictor com_r x cp :> Conflictor s y cq) = do+    -- com = prims in the effect of the lhs that the rhs also conflicts with;+    -- these remain on the lhs+    com :> rr <- commuteToPrefix (S.map (invertId . ctxId) y) com_r+    s' :> rr' <- commuteRLFL (rr :> s)+    let cp' = ctxAddInvFL s cp+        cq' = ctxAddRL rr' cq+    -- obviously p and q must not conflict, nor depend on each other+    guard (ctxNoConflict cq cp')+    let x' = S.map (ctxAddInvFL s) x+        y' = S.map (ctxAddRL rr') y+    -- somewhat less obviously, p must not conflict with the patches that only+    -- q conflicts with, nor depend on them, and vice versa+    guard $ all (ctxNoConflict cp') (S.difference y x')+    guard $ all (ctxNoConflict cq) (S.difference x' y)+    return $ Conflictor (com +>+ s') y' cq' :> Conflictor (reverseRL rr') x' cp'++-- * Commute++-- | Commute conflicting patches. These cases follow directly from merge.+commuteConflicting+  :: (SignedId name, StorableId name, PrimPatch prim)+  => CommuteFn (RepoPatchV3 name prim) (RepoPatchV3 name prim)+-- if we have a prim and a conflictor that only conflicts with that prim,+-- they trade places+-- [p] :> [p^, {:p}, :q] <-> [q] :> [q^, {:q}, :p]+commuteConflicting (Prim p :> Conflictor (ip:>:NilFL) ys cq@(ctxView -> Sealed (NilFL :> q)))+  | [ctxView -> Sealed (NilFL :> p')] <- S.toList ys+  , IsEq <- invert p =\/= ip+  , IsEq <- p =\/= p' =+      Just (Prim q :> Conflictor (invert q :>: NilFL) (S.singleton cq) (ctx p))+-- similar to above case: a prim and a conflictor that conflicts with the prim+-- but also conflicts with other patches+-- [p] :> [p^ s, {s^:p} U Y, cq] <-> [s, Y, cq] :> [, {cq}, s^:p]+commuteConflicting (Prim p :> Conflictor s y cq)+  | ident p `S.member` S.map ctxId y =+      case fastRemoveFL (invert p) s of+        Nothing ->+          -- Proof that this is impossible:+          --+          -- The case assumption (that p is in conflict with q) together+          -- with the fact that the rhs is obviously the first patch that+          -- conflicts with the lhs, imply that p^ is contained in s. It+          -- remains to be shown that p^ does not depend on any prim contained+          -- in s. Suppose there were such a prim, then p would be in conflict+          -- with it, which means p would have to be a conflictor. QED+          error $ renderString+            $ redText "commuteConflicting: cannot remove (invert lhs):"+            $$ displayPatch (invert p)+            $$ redText "from effect of rhs:"+            $$ displayPatch s+        Just r ->+          let cp = ctxAddInvFL r (ctx p)+          in Just (Conflictor r (cp -| y) cq :> Conflictor NilFL (S.singleton cq) cp)+-- if we have two conflictors where the rhs conflicts /only/ with the lhs,+-- the latter becomes a prim patch+-- [r, X, cp] [, {cp}, r^:q] <-> [q] [q^r, {r^:q} U X, cp]+commuteConflicting (lhs@(Conflictor r x cp) :> rhs@(Conflictor NilFL y cq))+  | y == S.singleton cp =+      case ctxView (ctxAddFL r cq) of+        Sealed (NilFL :> q') ->+          Just $ Prim q' :> Conflictor (invert q' :>: r) (cq +| x) cp+        Sealed (c' :> _) ->+          -- Proof that this is impossible:+          --+          -- First, it must be true that commutePastFL r cq = Just cq'. For if+          -- not, then there would be a conflict between the rhs and one of the+          -- prims that the lhs reverts, in contradiction to our case+          -- assumption that the rhs conflicts only with the lhs.+          --+          -- Second, suppose that cq' has residual nonempty context. That means+          -- there is a patch x in the history that the rhs depends on, and+          -- which is in conflict with at least one other patch y in our+          -- history (the history being the patches that precede the lhs);+          -- because otherwise cq' appended to the history would be a sequence+          -- that contains x twice without an intermediate revert. But then the+          -- rhs would also have to conflict with the patch x, again in+          -- contradiction to our case assumption. QED+          error $ renderString $ redText "remaining context in commute:"+            $$ displayPatch c'+            $$ redText "lhs:" $$ displayPatch lhs+            $$ redText "rhs:" $$ displayPatch rhs+-- conflicting conflictors where the rhs conflicts with lhs but+-- also conflicts with other patches+-- [com r, X, cp] [s, y=({s^cp} U Y'), cq] <-> [com s', r'Y', r'cq] [r', {cq} U s^X, s^cp]+commuteConflicting (Conflictor com_r x cp :> Conflictor s y cq)+  | let cp' = ctxAddInvFL s cp+  , cp' `S.member` y+  , let y' = cp' -| y =+      case commuteToPrefix (S.map (invertId . ctxId) y') com_r of+        Nothing ->+          -- Proof that the above commute must suceed:+          --+          -- Let u and v be prims that the lhs reverts, and suppose v also+          -- conflicts with the rhs. If v^ depends on u^, then u depends on v+          -- and thus u also conflicts with the rhs. Thus any v^ in com_r such+          -- that v conflicts with the rhs can depend only on other elements of+          -- com_r that also conflict with the rhs. QED+          error "commuteConflicting: cannot commute common effects"+        Just (com :> rr) ->+          case commuteRLFL (rr :> s) of+            Nothing ->+              -- Proof that the above commute must succeed:+              --+              -- This is equivalent to the statement: a prim v that conflicts+              -- only with the lhs cannot depend on another prim u that+              -- conflicts only with the rhs. Again, this is a consequence of+              -- the fact that if v depends on u and u conflicts with q, then v+              -- must also conflict with q.+              error "commuteConflicting: cannot commute uncommon effects"+            Just (s' :> rr') ->+              Just $+                Conflictor (com +>+ s') (S.map (ctxAddRL rr') y') (ctxAddRL rr' cq)+                :>+                Conflictor (reverseRL rr') (cq +| S.map (ctxAddInvFL s) x) cp'+commuteConflicting _ = Nothing++instance (SignedId name, StorableId name, PrimPatch prim) =>+         Commute (RepoPatchV3 name prim) where+  commute pair = commuteConflicting pair <|> commuteNoConflicts pair++-- * PatchInspect++-- Note: in contrast to RepoPatchV2 we do not look at the list of conflicts+-- here. I see no reason why we should: the conflicts are only needed for the+-- instance Commute. We do however look at the patches that we undo.+instance PatchInspect prim => PatchInspect (RepoPatchV3 name prim) where+  listTouchedFiles (Prim p) = listTouchedFiles p+  listTouchedFiles (Conflictor r _ cp) =+    nubSort $ concat (mapFL listTouchedFiles r) ++ ctxTouches cp+  hunkMatches f (Prim p) = hunkMatches f p+  hunkMatches f (Conflictor r _ cp) = hunkMatches f r || ctxHunkMatches f cp++-- * Boilerplate instances++instance (SignedId name, Eq2 prim, Commute prim) => Eq2 (RepoPatchV3 name prim) where+    (Prim p) =\/= (Prim q) = p =\/= q+    (Conflictor r x cp) =\/= (Conflictor s y cq)+        | IsEq <- r =\^/= s -- more efficient than IsEq <- r =\/= s+        , x == y+        , cp == cq = IsEq+    _ =\/= _ = NotEq++instance (Show name, Show2 prim) => Show (RepoPatchV3 name prim wX wY) where+  showsPrec d rp = showParen (d > appPrec) $+    case rp of+      Prim prim ->+        showString "Prim " . showsPrec2 (appPrec + 1) prim+      Conflictor r x cp -> showString "Conflictor " . showContent r x cp+    where+      showContent r x cp =+        showsPrec (appPrec + 1) r .+          showString " " . showsPrec (appPrec + 1) x .+          showString " " . showsPrec (appPrec + 1) cp++instance (Show name, Show2 prim) => Show1 (RepoPatchV3 name prim wX)++instance (Show name, Show2 prim) => Show2 (RepoPatchV3 name prim)++instance PrimPatch prim => PrimPatchBase (RepoPatchV3 name prim) where+  type PrimOf (RepoPatchV3 name prim) = prim++instance ToPrim (RepoPatchV3 name prim) where+  toPrim (Conflictor {}) = Nothing+  toPrim (Prim p) = Just (wnPatch p)++instance PatchDebug prim => PatchDebug (RepoPatchV3 name prim)++instance PrimPatch prim => Apply (RepoPatchV3 name prim) where+  type ApplyState (RepoPatchV3 name prim) = ApplyState prim+  apply = applyPrimFL . effect+  unapply = applyPrimFL . invert . effect++instance PatchListFormat (RepoPatchV3 name prim) where+  patchListFormat = ListFormatV3++instance IsHunk prim => IsHunk (RepoPatchV3 name prim) where+  isHunk rp = do+    Prim p <- return rp+    isHunk p++instance Summary (RepoPatchV3 name prim) where+  conflictedEffect (Conflictor _ _ (ctxView -> Sealed (_ :> p))) = [IsC Conflicted (wnPatch p)]+  conflictedEffect (Prim p) = [IsC Okay (wnPatch p)]++instance (Invert prim, Commute prim, Eq2 prim) => Unwind (RepoPatchV3 name prim) where+  fullUnwind (Prim p)+    = mkUnwound NilFL (wnPatch p :>: NilFL) NilFL+  fullUnwind+    (Conflictor+      (mapFL_FL wnPatch -> es)+      _+      (ctxView -> Sealed ((mapFL_FL wnPatch -> cs) :> (wnPatch -> i)))+    ) =+    mkUnwound+      (es +>+ cs)+      (i :>: NilFL)+      (invert i :>: invert cs +>+ NilFL)++-- * More boilerplate instances++instance PrimPatch prim => Check (RepoPatchV3 name prim)+  -- use the default implementation for method isInconsistent++instance PrimPatch prim => RepairToFL (RepoPatchV3 name prim)+  -- use the default implementation for method applyAndTryToFixFL++instance (SignedId name, StorableId name, PrimPatch prim)+  => ShowPatch (RepoPatchV3 name prim) where++  summary = plainSummary+  summaryFL = plainSummaryFL+  thing _ = "change"++instance (SignedId name, StorableId name, PrimPatch prim)+  => ShowContextPatch (RepoPatchV3 name prim) where++  showPatchWithContextAndApply f (Prim p) = showPatchWithContextAndApply f p+  showPatchWithContextAndApply f p = apply p >> return (showPatch f p)++-- * Read and Write++instance (SignedId name, StorableId name, PrimPatch prim)+  => ReadPatch (RepoPatchV3 name prim) where++  readPatch' = do+    skipSpace+    choice+      [ do string (BC.pack "conflictor")+           (Sealed r, x, p) <- readContent+           return (Sealed (Conflictor r (S.map unsafeCoerceP1 x) (unsafeCoerceP1 p)))+      , do mapSeal Prim <$> readPatch'+      ]+    where+      readContent = do+        r <- bracketedFL readPatch' '[' ']'+        x <- readCtxSet+        p <- readCtx+        return (r, x, p)+      readCtxSet = (lexString (BC.pack "{{") >> go) <|> pure S.empty+        where+          go = (lexString (BC.pack "}}") >> pure S.empty) <|> S.insert <$> readCtx <*> go++instance (SignedId name, StorableId name, PrimPatch prim)+  => ShowPatchBasic (RepoPatchV3 name prim) where++  showPatch fmt rp =+    case rp of+      Prim p -> showPatch fmt p+      Conflictor r x cp ->+        case fmt of+          ForStorage -> blueText "conflictor" <+> showContent r x cp+          ForDisplay ->+            vcat+            [ blueText "conflictor"+            , vcat (mapFL displayPatch r)+            , redText "v v v v v v v"+            , vcat [ displayCtx p $$ redText "*************" | p <- S.toList x ]+            , displayCtx cp+            , redText "^ ^ ^ ^ ^ ^ ^"+            ]+    where+      showContent r x cp = showEffect r <+> showCtxSet x $$ showCtx fmt cp+      showEffect NilFL = blueText "[]"+      showEffect ps = blueText "[" $$ vcat (mapFL (showPatch fmt) ps) $$ blueText "]"+      showCtxSet xs =+        case S.minView xs of+          Nothing -> mempty+          Just _ ->+            blueText "{{"+              $$ vcat (map (showCtx fmt) (S.toAscList xs))+              $$ blueText "}}"+      displayCtx c =+        -- need to use ForStorage to see the prim patch IDs+        showId ForStorage (ctxId c) $$+        unseal (showPatch ForDisplay . sortCoalesceFL . mapFL_FL wnPatch) (ctxToFL c)++-- * Local helper functions++infixr +|, -|++-- | A handy synonym for 'S.insert'.+(+|) :: Ord a => a -> S.Set a -> S.Set a+c +| cs = S.insert c cs++-- | A handy synonym for 'S.delete'.+(-|) :: Ord a => a -> S.Set a -> S.Set a+c -| cs = S.delete c cs
+ src/Darcs/Patch/V3/Resolution.hs view
@@ -0,0 +1,228 @@+{- | Conflict resolution for 'RepoPatchV3' -}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Darcs.Patch.V3.Resolution () where++import qualified Data.Set as S++import Darcs.Prelude+import Data.List ( partition, sort )++import Darcs.Patch.Commute ( commuteFL )+import Darcs.Patch.Conflict ( Conflict(..), mangleOrFail )+import Darcs.Patch.Ident ( Ident(..), SignedId(..), StorableId(..) )+import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Patch.Prim.WithName ( PrimWithName, wnPatch )+import Darcs.Patch.V3.Contexted ( Contexted, ctxDepends, ctxId, ctxToFL )+import Darcs.Patch.V3.Core ( RepoPatchV3(..), (+|), (-|) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), mapFL_FL, (:>)(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )+++-- * Conflict Resolution++{- This gives an overview of the algorithm for marking conflicts.++The goal is to calculate the markup for a trailing RL of patches, usually+the ones we are going to add to our repo. But since in V3 we store only the+direct conflicts, not the transitive set, we also require the full context+of all previous patches.++The markup presents each /transitive/ unresolved conflict in the form of a+set of alternative changes that all apply at the end of the repo. These+alternatives form the vertices of an undirected graph, where an edge exists+between two vertices iff they conflict. We represent this graph as a list of+connected 'Component's; thus each 'Component' represents one transitive+conflict.++The graph is constructed by commuting any patch that is part of a conflict+to the head. If that succeeds, the resulting conflictor gives us all+participents of the (direct) conflict in the form of contexted patches that+apply to the end of the repo. We check if there is an overlap between this+set and any already constructed components. If this is the case, we join+them into a larger component, otherwise we add a new component. If commuting+to the head fails, we only remember the set of conflicting patch names, and+use that afterwards to connect components that might otherwise appear as+unconnected. The docs for 'findComponents' explain this in greater detail.++Each resulting 'Component' is then converted to a set of plain prim 'FL's+(removing the prim patch IDs) and passed to the mangling function to+calculate the conflict markup as a single prim patch.++The result differs from that for RepoPatchV1 in that we do not merge the+maximal independent (i.e. non-conflicting) sets for each component. While+the latter gives a theoretically valid and more compact presentation,+typically with fewer alternatives, it has some disadvantages in practice:++  * Merging means that a single alternative no longer corresponds to a+    single named patch in our repo. Thus, even if we annotate alternatives+    with patch names or hashes (as planned for V3), identifying which part+    of an alternative belongs to which named patch requires additional+    mental effort during manual resolution.++  * The same original prim is now contained in more than one alternative,+    making it harder to manually resolve the conflict in a systematic way by+    applying difference between alternatives and the baseline step by step.++-}++instance (SignedId name, StorableId name, PrimPatch prim) =>+         Conflict (RepoPatchV3 name prim) where+  isConflicted Conflictor{} = True+  isConflicted Prim{} = False+  resolveConflicts context =+      map resolveOne . conflictingAlternatives context+    where+      resolveOne = mangleOrFail . map (mapSeal (mapFL_FL wnPatch))++conflictingAlternatives+  :: (SignedId name, StorableId name, PrimPatch prim)+  => RL (RepoPatchV3 name prim) wO wX+  -> RL (RepoPatchV3 name prim) wX wY+  -> [[Sealed (FL (PrimWithName name prim) wY)]]+conflictingAlternatives context =+  map (map ctxToFL . S.toList) . findComponents context++-- | A connected component of the conflict graph.+type Component name prim wY = S.Set (Contexted (PrimWithName name prim) wY)++{- | Construct the conflict graph by searching the history for unresolved+conflicts. The history is split into an initial 'RL' of patches (the+context) and a trailing 'RL' of patches we are interested in.++We examine patches starting with the head and going backwards, maintaining+the following state:++  @done@++    A list of 'Component's, initially empty, which will become the resulting+    conflict graph.++  @todo@++    A set of @name@s, initially empty, that are candidates for inspection,+    in addition to conflicted patches in the trailing 'RL'. We maintain the+    invariant that this set never contains the @name@ of any patch we have+    already traversed.++  @res@++    A list of sets of @name@s, initially empty, with the @name@s of patches+    involved in conflicts that are (partially) resolved. Used to post+    process the result (see below).++We inspect any conflictor in the trailing 'RL', as well as any patch whose+@name@ is in @todo@ throughout the history, terminating early if the+trailing 'RL' and @todo@ are both exhausted.++For each such candidate we first try to commute it to the head.++If that succeeds, then its commuted version must be a conflictor. (Either it+was a conflictor to begin with, in which case it remains one; or it is a+patch that a later conflictor conflicted with, and that means it must itself+become conflicted when commuted to the head.) The contexted patch that the+(commuted) conflictor represents, together with its set of conflicts, is+either added as a new component to @done@, or else is joined with some+already found component.++If the commute does not succeed, then this indicates that some later patch+has resolved (parts of) the conflict. So this patch makes no direct+contribution to the confict graph. However, it may still be part of a larger+transitive conflict and not all patches involved may have been fully+resolved. (Remember that the commute rules for V3 are such that a patch+depends on a conflictor if it depends on /any/ of the patches involved in+the conflict.) To make sure that the result is independent of the order of+patches, we need to remember the set of directly conflicting patches (by+adding it to @res@). When the traversal terminates, we use this information+to join any components connected by these sets into larger components. See+the discussion below for details.++In both cases, if the patch is conflicted, we insert any patch that the+candidate conflicts with into @todo@ (and remove the patch itself). Note+that in order to maintain our invariant, we must extract the set of+conflicts from the patch /in its uncommuted form/. (If we took them from the+commuted version, then we might mark patches that we already traversed.)++The necessity to remember information about all direct conflicts until the+end, regardless of partial resolutions, can be seen with the following+example. Suppose we have patches A;B;C;D;E where E (a partial resolution)+depends (only) on C, and we have direct conflicts A/C, C/B, B/D. So D+commutes past E but conflicts only indirectly with C. Thus when we encounter+C and fail to remember the fact that it conflicts with A, we end up with two+components [{C,B},{A,D}] instead of a single transitive conflict [{A,B,C,D}]+that we would get when examining the patches in the order A;C;B;D;E.++On the other hand, suppose we have A;B;C;D;E;F, where A;B;C;D;E form a+transitive conflict chain (i.e. we have direct conflicts A/B, B/C, C/D,+D/E), and the partial resolution F depends on {B,C,D}. Note that /all/+direct conflicts involving C are resolved by F, so we expect to get the two+components {A,B} and {D,E}. Indeed, suppose the order were B;D;C;F;A;E, then+at the point after F is added we have a repo with all conflicts resolved.+Thus after adding A and E we should only see the direct conflicts of A and+E, i.e. A, B, D, and E. The slightly subtle implication is that when we+finally join components, we must do so for one conflict set at a time; it+would be wrong to first join conflict sets and then use those to join+components, since that would join {A,B} and {D,E}, even though there is no+conflict between the two sets.+-}+findComponents+  :: forall name prim wO wX wY+   . (SignedId name, StorableId name, PrimPatch prim)+  => RL (RepoPatchV3 name prim) wO wX+  -> RL (RepoPatchV3 name prim) wX wY+  -> [Component name prim wY]+findComponents context patches = go S.empty [] [] context patches NilFL where+  go :: S.Set name+     -> [Component name prim wY]+     -> [S.Set name]+     -> RL (RepoPatchV3 name prim) wO wA+     -> RL (RepoPatchV3 name prim) wA wB+     -> FL (RepoPatchV3 name prim) wB wY+     -> [Component name prim wY]+  go todo done res cs (ps :<: p) passedby+    | isConflicted p || ident p `S.member` todo+    , Just (_ :> p') <- commuteFL (p :> passedby) =+        go (updTodo p todo) (updDone p' done) res cs ps (p :>: passedby)+    | otherwise =+        go (updTodo p todo) done (updRes p res) cs ps (p :>: passedby)+  go todo done res _ NilRL _+    | S.null todo = sort $ map purgeDeps $ foldr joinOverlapping done res+  go todo done res (cs :<: p) NilRL passedby+    | ident p `S.member` todo+    , Just (_ :> p') <- commuteFL (p :> passedby) =+        go (updTodo p todo) (updDone p' done) res cs NilRL (p :>: passedby)+    | otherwise =+        go (updTodo p todo) done (updRes p res) cs NilRL (p :>: passedby)+  go _ _ _ NilRL NilRL _ = error "autsch, hit the bottom"++  updTodo p todo = S.map ctxId (conflicts p) <> (ident p -| todo)+  updDone p' done = joinOrAddNew (allConflicts p') done+  updRes p res = S.map ctxId (allConflicts p) : res++  conflicts (Conflictor _ x _) = x+  conflicts _ = S.empty++  allConflicts (Conflictor _ x cp) = cp +| x+  allConflicts _ = S.empty++  -- Join all components which overlap with the given set of IDs+  joinOverlapping ids cs =+    case partition (not . S.disjoint ids . S.map ctxId) cs of+      ([], to_keep) -> to_keep -- avoid adding empty components+      (to_join, to_keep) -> S.unions to_join : to_keep++  -- remove vertices that others depend on+  purgeDeps :: Component name prim wY -> Component name prim wY+  purgeDeps c = S.filter (\a -> not $ any (a `ctxDepends`) (a -| c)) c++-- | Add a set to a disjoint list of sets, such that we maintain the invariant+-- that the resulting list of sets is disjoint, and such that their unions are+-- equal to the unions of the inputs.+--+-- The tricky point here is that the new set may overlap with any number of+-- list elements; we must ensure they are all joined into a single set.+joinOrAddNew :: Ord a => S.Set a -> [S.Set a] -> [S.Set a]+joinOrAddNew c [] = [c]+joinOrAddNew c (d:ds)+  | not $ all (S.disjoint d) ds = error "precondition: sets are not disjoint"+  | c `S.disjoint` d = d : joinOrAddNew c ds+  | otherwise = joinOrAddNew (c `S.union` d) ds
src/Darcs/Patch/Viewing.hs view
@@ -16,138 +16,175 @@ -- Boston, MA 02110-1301, USA.  {-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}-+{-# LANGUAGE UndecidableInstances #-} module Darcs.Patch.Viewing-    ( showContextHunk, showContextSeries-    )-    where+    ( showContextHunk+    ) where -import Prelude hiding ( pi, readFile )-import Control.Applicative( (<$>) )+import Darcs.Prelude -import Storage.Hashed.Monad( TreeIO, fileExists, readFile, tree, virtualTreeMonad )-import Storage.Hashed.Tree( Tree )-import Storage.Hashed.AnchoredPath( floatPath )-import ByteStringUtils (linesPS )-import qualified Data.ByteString as BS (null, concat)-import qualified Data.ByteString.Lazy as BL (toChunks)-import Darcs.Patch.FileName ( fn2fp )-import Printer ( Doc, empty, vcat,-                 text, blueText, Color(Cyan,Magenta), lineColor,-                 ($$), (<+>),-                 prefix,-                 userchunkPS,-               )-import Darcs.Patch.Format ( PatchListFormat(..), ListFormat(..), FileNameFormat(..) )-import Darcs.Patch.FileHunk ( IsHunk(..), FileHunk(..), showFileHunk )-import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatch(..), formatFileName )-import Darcs.Patch.Apply ( Apply(..), applyToState )-import Darcs.Patch.ApplyMonad ( ApplyMonadTrans, runApplyMonad, getApplyState-                              , ApplyMonadOver, ApplyMonad(..), toTree )-#include "gadts.h"-import Darcs.Witnesses.Ordered ( RL(..), FL(..),-                             mapFL, mapFL_FL, reverseRL, concatFL )+import qualified Data.ByteString as B ( null ) -showContextSeries :: forall p m x y. (Apply p, ShowPatch p, IsHunk p,-                      ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState p))-                  => FL p C(x y) -> m Doc-showContextSeries patches = scs Nothing patches-    where scs :: forall m' ww xx yy.-                 (ApplyMonadTrans m' (ApplyState p), ApplyMonad m' (ApplyState p), ApplyMonadBase m ~ ApplyMonadBase m')-              => Maybe (FileHunk C(ww xx)) -> FL p C(xx yy) -> m' Doc-          scs pold (p:>:ps) = do-            (_, s') <- nestedApply (apply p) =<< getApplyState-            case isHunk p of-              Nothing -> do a <- showContextPatch p-                            b <- nestedApply (scs Nothing ps) s'-                            return $ a $$ fst b-              Just fh ->-                  case ps of-                  NilFL -> fst <$> liftApply (cool pold fh Nothing) s'-                  (p2:>:_) -> do a <- fst <$> liftApply (cool pold fh (isHunk p2)) s'-                                 b <- nestedApply (scs (Just fh) ps) s'-                                 return $ a $$ fst b-          scs _ NilFL = return empty-          cool :: Maybe (FileHunk C(a b))-                  -> FileHunk C(b c)-                  -> Maybe (FileHunk C(c d))-                  -> (ApplyState p) (ApplyMonadBase m)-                  -> (ApplyMonadBase m) Doc-          cool pold fh ps s = fst <$> virtualTreeMonad (coolContextHunk pold fh ps) (toTree s)+import Darcs.Patch.Apply ( Apply(..), ObjectIdOfPatch )+import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )+import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..), showContextFileHunk )+import Darcs.Patch.Format ( FileNameFormat(..), ListFormat(..), PatchListFormat(..) )+import Darcs.Patch.Object ( ObjectId(..), ObjectIdOf )+import Darcs.Patch.Show+    ( ShowContextPatch(..)+    , ShowPatch(..)+    , ShowPatchBasic(..)+    , ShowPatchFor(..)+    )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , RL(..)+    , concatFL+    , mapFL+    , mapFL_FL+    , reverseRL+    )+import Darcs.Util.ByteString ( linesPS )+import Darcs.Util.Printer ( Doc, blueText, empty, vcat, ($$) ) -showContextHunk :: (ApplyMonad m Tree) => FileHunk C(x y) -> m Doc-showContextHunk h = coolContextHunk Nothing h Nothing+showContextSeries+  :: forall p m wX wY+   . ( Apply p+     , ShowContextPatch p+     , IsHunk p+     , ApplyMonad (ApplyState p) m+     , ObjectId (ObjectIdOfPatch p)+     )+  => ShowPatchFor+  -> FileNameFormat+  -> FL p wX wY+  -> m Doc+showContextSeries use fmt = scs Nothing+  where+    scs :: Maybe (FileHunk (ObjectIdOfPatch p) wA wB) -> FL p wB wC -> m Doc+    scs pold (p :>: ps) = do+        case isHunk p of+            Nothing -> do+                a <- showPatchWithContextAndApply use p+                b <- scs Nothing ps+                return $ a $$ b+            Just fh -> case ps of+                NilFL -> do+                  r <- coolContextHunk fmt pold fh Nothing+                  apply p+                  return r+                (p2 :>: _) -> do+                    a <- coolContextHunk fmt pold fh (isHunk p2)+                    apply p+                    b <- scs (Just fh) ps+                    return $ a $$ b+    scs _ NilFL = return empty -coolContextHunk :: (ApplyMonad m Tree, ApplyMonadTrans m Tree)-                => Maybe (FileHunk C(a b)) -> FileHunk C(b c) -> Maybe (FileHunk C(c d)) -> m Doc-coolContextHunk prev fh@(FileHunk f l o n) next = do-  have <- mDoesFileExist f-  content <- if have then Just `fmap` mReadFilePS f else return Nothing-  case linesPS `fmap` content of-    Nothing -> return $ showFileHunk OldFormat fh -- This is a weird error...-    Just ls ->-        let numpre = case prev of-                     Just (FileHunk f' lprev _ nprev)-                         | f' == f &&-                           l - (lprev + length nprev + 3) < 3 &&-                           lprev < l ->-                             max 0 $ l - (lprev + length nprev + 3)-                     _ -> if l >= 4 then 3 else l - 1-            pre = take numpre $ drop (l - numpre - 1) ls-            numpost = case next of-                      Just (FileHunk f' lnext _ _)-                          | f' == f && lnext < l+length n+4 &&-                            lnext > l ->-                              lnext - (l+length n)-                      _ -> 3-            cleanedls = case reverse ls of-                        (x:xs) | BS.null x -> reverse xs-                        _ -> ls-            post = take numpost $ drop (max 0 $ l+length o-1) cleanedls-            in return $ blueText "hunk" <+> formatFileName OldFormat f <+> text (show l)-            $$ prefix " " (vcat $ map userchunkPS pre)-            $$ lineColor Magenta (prefix "-" (vcat $ map userchunkPS o))-            $$ lineColor Cyan    (prefix "+" (vcat $ map userchunkPS n))-            $$ prefix " " (vcat $ map userchunkPS post)+showContextHunk+  :: (ApplyMonad state m, oid ~ ObjectIdOf state, ObjectId oid)+  => FileNameFormat+  -> FileHunk oid wX wY+  -> m Doc+showContextHunk fmt h = coolContextHunk fmt Nothing h Nothing +coolContextHunk :: (ApplyMonad state m, oid ~ ObjectIdOf state, ObjectId oid)+                => FileNameFormat+                -> Maybe (FileHunk oid wA wB) -> FileHunk oid wB wC+                -> Maybe (FileHunk oid wC wD) -> m Doc+coolContextHunk fmt prev fh@(FileHunk f l o n) next = do+    ls <- linesPS <$> readFilePS f+    let pre = take numpre $ drop (l - numpre - 1) ls+        -- This removes the last line if that is empty. This is because if a+        -- file ends with a newline, this would add an unintuitive "empty last+        -- line"; in other words, we regard the newline as a terminator, not a+        -- separator. See also the long comment in Darcs.Repository.Diff.+        cleanedls = case reverse ls of+            (x : xs)+                | B.null x -> reverse xs+            _ -> ls+        post = take numpost $ drop (max 0 $ l + length o - 1) cleanedls+    return $ showContextFileHunk fmt pre fh post+  where+    numpre = case prev of+        Just (FileHunk f' lprev _ nprev)+            | f' == f && l - (lprev + length nprev + 3) < 3 && lprev < l+            -> max 0 $ l - (lprev + length nprev + 3)+        _ -> if l >= 4 then 3 else l - 1+    numpost = case next of+        Just (FileHunk f' lnext _ _)+            | f' == f && lnext < l + length n + 4 && lnext > l+            -> lnext - (l + length n)+        _ -> 3+ instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (FL p) where-    showPatch = showPatchInternal patchListFormat-      where showPatchInternal :: ListFormat p -> FL p C(x y) -> Doc-            showPatchInternal ListFormatV1      (p :>: NilFL) = showPatch p-            showPatchInternal ListFormatV1      NilFL         = blueText "{" $$ blueText "}"-            showPatchInternal ListFormatV1      ps            = blueText "{" $$ vcat (mapFL showPatch ps) $$ blueText "}"-            showPatchInternal ListFormatV2      ps            = vcat (mapFL showPatch ps)-            showPatchInternal ListFormatDefault ps            = vcat (mapFL showPatch ps)+    showPatch ForDisplay = vcat . mapFL (showPatch ForDisplay)+    showPatch ForStorage = showPatchInternal patchListFormat+      where+        showPatchInternal :: ListFormat p -> FL p wX wY -> Doc+        showPatchInternal ListFormatV1 (p :>: NilFL) = (showPatch ForStorage) p+        showPatchInternal ListFormatV1 NilFL = blueText "{" $$ blueText "}"+        showPatchInternal ListFormatV1 ps = blueText "{"+                                            $$ vcat (mapFL (showPatch ForStorage) ps)+                                            $$ blueText "}"+        showPatchInternal ListFormatV2 ps = vcat (mapFL (showPatch ForStorage) ps)+        showPatchInternal ListFormatDefault ps = vcat (mapFL (showPatch ForStorage) ps)+        showPatchInternal ListFormatV3 ps = vcat (mapFL (showPatch ForStorage) ps) -instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p) => ShowPatch (FL p) where-    showContextPatch = showContextPatchInternal patchListFormat-      where showContextPatchInternal :: (ApplyMonadTrans m (ApplyState p), ApplyMonad m (ApplyState (FL p)))-                                     => ListFormat p -> FL p C(x y) -> m Doc-            showContextPatchInternal ListFormatV1      (p :>: NilFL) = showContextPatch p-            showContextPatchInternal ListFormatV1      NilFL         = return $ blueText "{" $$ blueText "}"-            showContextPatchInternal ListFormatV1      ps            = do x <- showContextSeries ps-                                                                          return $ blueText "{" $$ x $$ blueText "}"-            showContextPatchInternal ListFormatV2      ps            = showContextSeries ps-            showContextPatchInternal ListFormatDefault ps            = showContextSeries ps+instance ( Apply p+         , IsHunk p+         , PatchListFormat p+         , ShowContextPatch p+         , ObjectId (ObjectIdOfPatch p)+         ) =>+         ShowContextPatch (FL p) where+    showPatchWithContextAndApply ForDisplay = showContextSeries ForDisplay FileNameFormatDisplay+    showPatchWithContextAndApply ForStorage = showContextPatchInternal patchListFormat+      where+        showContextPatchInternal :: (ApplyMonad (ApplyState (FL p)) m)+                                 => ListFormat p -> FL p wX wY -> m Doc+        showContextPatchInternal ListFormatV1 (p :>: NilFL) =+            showPatchWithContextAndApply ForStorage p+        showContextPatchInternal ListFormatV1 NilFL =+            return $ blueText "{" $$ blueText "}"+        showContextPatchInternal ListFormatV1 ps = do+            x <- showContextSeries ForStorage FileNameFormatV1 ps+            return $ blueText "{" $$ x $$ blueText "}"+        showContextPatchInternal ListFormatV2 ps = showContextSeries ForStorage FileNameFormatV2 ps+        showContextPatchInternal ListFormatDefault ps = showContextSeries ForStorage FileNameFormatV2 ps+        showContextPatchInternal ListFormatV3 ps = return $ showPatch ForStorage ps +instance (PatchListFormat p, ShowPatch p) => ShowPatch (FL p) where+    content = vcat . mapFL content+     description = vcat . mapFL description+     summary = summaryFL+     summaryFL = summaryFL . concatFL+     thing x = thing (helperx x) ++ "s"-        where helperx :: FL a C(x y) -> a C(x y)-              helperx _ = undefined+      where+        helperx :: FL a wX wY -> a wX wY+        helperx _ = undefined+     things = thing  instance (PatchListFormat p, ShowPatchBasic p) => ShowPatchBasic (RL p) where-    showPatch = showPatch . reverseRL+    showPatch f = showPatch f . reverseRL -instance (Apply p, IsHunk p, PatchListFormat p, ShowPatch p) => ShowPatch (RL p) where-    showContextPatch = showContextPatch . reverseRL+instance (ShowContextPatch p, Apply p, IsHunk p, PatchListFormat p, ObjectId (ObjectIdOfPatch p))+        => ShowContextPatch (RL p) where+    showPatchWithContextAndApply use = showPatchWithContextAndApply use . reverseRL++instance (PatchListFormat p, ShowPatch p) => ShowPatch (RL p) where+    content = content . reverseRL+     description = description . reverseRL+     summary = summary . reverseRL+     summaryFL = summaryFL . mapFL_FL reverseRL-    thing = thing . reverseRL-    things = things . reverseRL +    thing = thing . reverseRL +    things = things . reverseRL
+ src/Darcs/Patch/Witnesses/Eq.hs view
@@ -0,0 +1,59 @@+module Darcs.Patch.Witnesses.Eq+    ( EqCheck(..)+    , Eq2(..)+    , isIsEq+    ) where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++-- |'EqCheck' is used to pass around evidence (or lack thereof) of+-- two witness types being equal.+data EqCheck wA wB where+    IsEq :: EqCheck wA wA+    NotEq :: EqCheck wA wB++instance Eq (EqCheck wA wB) where+    IsEq == IsEq = True+    NotEq == NotEq = True+    _ == _ = False++instance Show (EqCheck wA wB) where+    show IsEq = "IsEq"+    show NotEq = "NotEq"++-- |An witness aware equality class.+-- A minimal definition defines any one of 'unsafeCompare', '=\/=' and '=/\='.+class Eq2 p where+    -- |It is unsafe to define a class instance via this method, because+    -- if it returns True then the default implementations of '=\/=' and '=/\='+    -- will coerce the equality of two witnesses.+    --+    -- Calling this method is safe, although '=\/=' or '=/\=' would be better+    -- choices as it is not usually meaningul to compare two patches that+    -- don't share either a starting or an ending context+    unsafeCompare :: p wA wB -> p wC wD -> Bool+    unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b)++    -- |Compare two things with the same starting witness. If the things+    -- compare equal, evidence of the ending witnesses being equal will+    -- be returned.+    (=\/=) :: p wA wB -> p wA wC -> EqCheck wB wC+    a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq+             | otherwise = NotEq++    -- |Compare two things with the same ending witness. If the things+    -- compare equal, evidence of the starting witnesses being equal will+    -- be returned.+    (=/\=) :: p wA wC -> p wB wC -> EqCheck wA wB+    a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq+             | otherwise = NotEq++    {-# MINIMAL unsafeCompare | (=\/=) | (=/\=) #-}++infix 4 =\/=, =/\=++isIsEq :: EqCheck wA wB -> Bool+isIsEq IsEq = True+isIsEq NotEq = False
+ src/Darcs/Patch/Witnesses/Maybe.hs view
@@ -0,0 +1,23 @@+module Darcs.Patch.Witnesses.Maybe+  ( Maybe2(..)+  , maybeToFL, maybeToRL+  , mapMB_MB+  ) where++import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..) )++data Maybe2 p wX wY where+  Nothing2 :: Maybe2 p wX wX+  Just2 :: p wX wY -> Maybe2 p wX wY++maybeToFL :: Maybe2 p wX wY -> FL p wX wY+maybeToFL Nothing2 = NilFL+maybeToFL (Just2 v) = v :>: NilFL++maybeToRL :: Maybe2 p wX wY -> RL p wX wY+maybeToRL Nothing2 = NilRL+maybeToRL (Just2 v) = NilRL :<: v++mapMB_MB :: (p wX wY -> q wX wY) -> Maybe2 p wX wY -> Maybe2 q wX wY+mapMB_MB _ Nothing2 = Nothing2+mapMB_MB f (Just2 v) = Just2 (f v)
+ src/Darcs/Patch/Witnesses/Ordered.hs view
@@ -0,0 +1,554 @@+-- Copyright (C) 2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Patch.Witnesses.Ordered+    ( +    -- * Directed Types+    -- $DirectedTypes+      (:>)(..)+    , FL(..)+    , RL(..)+    -- * Merge Types+    -- $MergeTypes+    , (:\/:)(..)+    , (:/\:)(..)+    , (:||:)(..)+    , Fork(..)+    -- * Functions for 'FL's and 'RL's+    , nullFL+    , nullRL+    , lengthFL+    , lengthRL+    , mapFL+    , mapRL+    , mapFL_FL+    , mapRL_RL+    , foldrFL+    , foldlRL+    , foldrwFL+    , foldlwRL+    , foldlwFL+    , foldrwRL+    , allFL+    , allRL+    , anyFL+    , anyRL+    , filterFL+    , filterRL+    , foldFL_M+    , foldRL_M+    , splitAtFL+    , splitAtRL+    , filterOutFLFL+    , filterOutRLRL+    , reverseFL+    , reverseRL+    , (+>+)+    , (+<+)+    , (+>>+)+    , (+<<+)+    , concatFL+    , concatRL+    , dropWhileFL+    , dropWhileRL+    -- * 'FL' only+    , bunchFL+    , spanFL+    , spanFL_M+    , zipWithFL+    , consGapFL+    , concatGapsFL+    , joinGapsFL+    , mapFL_FL_M+    , sequenceFL_+    , initsFL+    -- * 'RL' only+    , isShorterThanRL+    , spanRL+    , breakRL+    , takeWhileRL+    , concatRLFL+    ) where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Sealed+    ( FlippedSeal(..)+    , flipSeal+    , Sealed(..)+    , Sealed2(..)+    , seal+    , Gap(..)+    , emptyGap+    , joinGap+    )+import Darcs.Patch.Witnesses.Eq ( Eq2(..), EqCheck(..) )++-- * Directed Types++-- $DirectedTypes+-- Darcs patches have a notion of transforming between contexts. This+-- naturally leads us to container types that are \"directed\" and +-- transform from one context to another.+-- +-- For example, the swap of names of files x and y could be represented +-- with the following sequence of patches:+-- +-- @ Move x z ':>' Move y x ':>' Move z y @+-- +-- or using forward lists, like+-- +-- @ Move x z ':>:' Move y x ':>:' Move z y ':>:' NilFL @++-- | Directed Forward Pairs+data (a1 :> a2) wX wY = forall wZ . (a1 wX wZ) :> (a2 wZ wY)+infixr 1 :>++-- | Forward lists+data FL a wX wZ where+    (:>:) :: a wX wY -> FL a wY wZ -> FL a wX wZ+    NilFL :: FL a wX wX++-- | Reverse lists+data RL a wX wZ where+    (:<:) :: RL a wX wY -> a wY wZ -> RL a wX wZ+    NilRL :: RL a wX wX++instance Show2 a => Show (FL a wX wZ) where+   showsPrec _ NilFL = showString "NilFL"+   showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .+                            showString " :>: " . showsPrec (prec + 1) xs+       where prec = 5++instance Show2 a => Show1 (FL a wX)+instance Show2 a => Show2 (FL a)++instance Show2 a => Show (RL a wX wZ) where+   showsPrec _ NilRL = showString "NilRL"+   showsPrec d (xs :<: x) = showParen (d > prec) $ showsPrec (prec + 1) xs .+                            showString " :<: " . showsPrec2 (prec + 1) x+       where prec = 5++instance Show2 a => Show1 (RL a wX)++instance Show2 a => Show2 (RL a)++instance (Show2 a, Show2 b) => Show1 ((a :> b) wX)++-- * Merge Types++-- $MergeTypes+-- When we have two patches which commute and share the same pre-context we can+-- merge the patches. Whenever patches, or sequences of patches, share a+-- pre-context we say they are Forking Pairs (':\/:'). The same way, when+-- patches or sequences of patches, share a post-context we say they are+-- Joining Pairs (':/\:').+-- +-- The following diagram shows the symmetry of merge types:+-- +-- @          wZ+--         ':/\:'+--     a3 &#47;    &#92; a4  +--       &#47;      &#92;    +--      wX      wY       +--       &#92;      &#47;    +--     a1 &#92;    &#47; a2  +--         ':\/:'      +--          wZ+-- @++-- +-- (non-haddock version)+--      wZ+--     :/\:+--  a3 /  \ a4+--    /    \+--  wX      wY+--    \    /+--  a1 \  / a2+--     :\/:+--      wZ+-- ++infix 1 :/\:, :\/:, :||:+-- | Forking Pairs (Implicit starting context)+data (a1 :\/: a2) wX wY = forall wZ . (a1 wZ wX) :\/: (a2 wZ wY)++-- | Joining Pairs+data (a3 :/\: a4) wX wY = forall wZ . (a3 wX wZ) :/\: (a4 wY wZ)++-- | Forking Pair (Explicit starting context)+-- +-- @      wX     wY       +--       &#92;     &#47;    +--        &#92;   &#47;+--         &#92; &#47;     +--          wU+--          &#124;+--          &#124;+--          &#124;+--          wA+-- @++-- +-- (non-haddock version)+-- +--  wX      wY+--   \      /+--    \    /+--     \  /+--      wU+--      |+--      |+--      |+--      wA+-- ++data Fork common left right wA wX wY =+    forall wU. Fork (common wA wU) (left wU wX) (right wU wY)++-- | Parallel Pairs+data (a1 :||: a2) wX wY = (a1 wX wY) :||: (a2 wX wY)++instance (Show2 a, Show2 b) => Show ( (a :> b) wX wY ) where+    showsPrec d (x :> y) = showOp2 1 ":>" d x y++instance (Eq2 a, Eq2 b) => Eq2 (a :> b) where+    (a1 :> b1) =\/= (a2 :> b2) | IsEq <- a1 =\/= a2 = b1 =\/= b2+                               | otherwise = NotEq++instance (Eq2 a, Eq2 b) => Eq ((a :> b) wX wY) where+    (==) = unsafeCompare++instance Eq2 p => Eq2 (FL p) where+  NilFL =\/= NilFL = IsEq+  a:>:as =\/= b:>:bs+    | IsEq <- a =\/= b = as =\/= bs+    | otherwise = NotEq+  _ =\/= _ = NotEq+  xs =/\= ys = reverseFL xs =/\= reverseFL ys++instance Eq2 p => Eq2 (RL p) where+  NilRL =/\= NilRL = IsEq+  as:<:a =/\= bs:<:b+    | IsEq <- a =/\= b = as =/\= bs+    | otherwise = NotEq+  _ =/\= _ = NotEq++instance (Show2 a, Show2 b) => Show2 (a :> b)++instance (Show2 a, Show2 b) => Show ( (a :\/: b) wX wY ) where+    showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y++instance (Show2 a, Show2 b) => Show2 (a :\/: b)++instance (Show2 a, Show2 b) => Show ( (a :/\: b) wX wY ) where+    showsPrec d (x :/\: y) = showOp2 1 ":/\\:" d x y++instance (Show2 a, Show2 b) => Show2 ( (a :/\: b) )++-- * Functions++infixr 5 :>:, +>++infixl 5 :<:, +<+++nullFL :: FL a wX wZ -> Bool+nullFL NilFL = True+nullFL _ = False++nullRL :: RL a wX wZ -> Bool+nullRL NilRL = True+nullRL _ = False++-- | @filterOutFLFL p xs@ deletes any @x@ in @xs@ for which @p x == IsEq@+--   (indicating that @x@ has no effect as far as we are concerned, and can be+--    safely removed from the chain)+filterOutFLFL :: (forall wX wY . p wX wY -> EqCheck wX wY) -> FL p wW wZ -> FL p wW wZ+filterOutFLFL _ NilFL = NilFL+filterOutFLFL f (x:>:xs) | IsEq <- f x = filterOutFLFL f xs+                         | otherwise = x :>: filterOutFLFL f xs++filterOutRLRL :: (forall wX wY . p wX wY -> EqCheck wX wY) -> RL p wW wZ -> RL p wW wZ+filterOutRLRL _ NilRL = NilRL+filterOutRLRL f (xs:<:x) | IsEq <- f x = filterOutRLRL f xs+                         | otherwise = filterOutRLRL f xs :<: x++filterRL :: (forall wX wY . p wX wY -> Bool) -> RL p wA wB ->  [Sealed2 p]+filterRL _ NilRL = []+filterRL f (xs :<: x) | f x = Sealed2 x : (filterRL f xs)+                      | otherwise = filterRL f xs++-- | Concatenate two 'FL's. This traverses only the left hand side.+(+>+) :: FL a wX wY -> FL a wY wZ -> FL a wX wZ+NilFL +>+ ys = ys+(x:>:xs) +>+ ys = x :>: xs +>+ ys++-- | Concatenate two 'RL's. This traverses only the right hand side.+(+<+) :: RL a wX wY -> RL a wY wZ -> RL a wX wZ+xs +<+ NilRL = xs+xs +<+ (ys:<:y) = xs +<+ ys :<: y++reverseFL :: FL a wX wZ -> RL a wX wZ+reverseFL xs = r NilRL xs+  where r :: RL a wL wM -> FL a wM wO -> RL a wL wO+        r ls NilFL = ls+        r ls (a:>:as) = r (ls:<:a) as++reverseRL :: RL a wX wZ -> FL a wX wZ+reverseRL xs = r NilFL xs+  where r :: FL a wM wO -> RL a wL wM -> FL a wL wO+        r ls NilRL = ls+        r ls (as:<:a) = r (a:>:ls) as++concatFL :: FL (FL a) wX wZ -> FL a wX wZ+concatFL NilFL = NilFL+concatFL (a:>:as) = a +>+ concatFL as++concatRL :: RL (RL a) wX wZ -> RL a wX wZ+concatRL NilRL = NilRL+concatRL (as:<:a) = concatRL as +<+ a++spanFL :: (forall wW wY . a wW wY -> Bool) -> FL a wX wZ -> (FL a :> FL a) wX wZ+spanFL f (x:>:xs) | f x = case spanFL f xs of+                            ys :> zs -> (x:>:ys) :> zs+spanFL _ xs = NilFL :> xs++spanFL_M :: forall a m wX wZ. Monad m =>+            (forall wW wY . a wW wY -> m Bool) -> FL a wX wZ+            -> m ((FL a :> FL a) wX wZ)+spanFL_M f (x:>:xs) =+    do+      continue <- f x+      if continue+       then do (ys :> zs) <- spanFL_M f xs+               return $ (x :>: ys) :> zs+       else return $ NilFL :> (x :>: xs)++spanFL_M _ (NilFL) = return $ NilFL :> NilFL++splitAtFL :: Int -> FL a wX wZ -> (FL a :> FL a) wX wZ+splitAtFL 0 xs = NilFL :> xs+splitAtFL _ NilFL = NilFL :> NilFL+splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of+                       (xs':>xs'') -> (x:>:xs' :> xs'')++splitAtRL :: Int -> RL a wX wZ -> (RL a :> RL a) wX wZ+splitAtRL 0 xs = xs :> NilRL+splitAtRL _ NilRL = NilRL :> NilRL+splitAtRL n (xs:<:x) = case splitAtRL (n-1) xs of+                       (xs'':>xs') -> (xs'':> xs':<:x)++-- 'bunchFL n' groups patches into batches of n, except that it always puts+-- the first patch in its own group, this being a recognition that the+-- first patch is often *very* large.++bunchFL :: Int -> FL a wX wY -> FL (FL a) wX wY+bunchFL _ NilFL = NilFL+bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs+    where bFL :: FL a wX wY -> FL (FL a) wX wY+          bFL NilFL = NilFL+          bFL bs = case splitAtFL n bs of+                   a :> b -> a :>: bFL b++-- | Monadic fold over an 'FL' associating to the left, sequencing+-- effects from left to right.+-- The order of arguments follows the standard 'foldM' from base.+foldFL_M :: Monad m+         => (forall wA wB. r wA -> p wA wB -> m (r wB))+         -> r wX -> FL p wX wY -> m (r wY)+foldFL_M _ r NilFL = return r+foldFL_M f r (x :>: xs) = f r x >>= \r' -> foldFL_M f r' xs++-- | Monadic fold over an 'FL' associating to the right, sequencing+-- effects from right to left.+-- Mostly useful for prepend-like operations with an effect where the+-- order of effects is not relevant.+foldRL_M :: Monad m+         => (forall wA wB. p wA wB -> r wB -> m (r wA))+         -> RL p wX wY -> r wY -> m (r wX)+foldRL_M _ NilRL r = return r+foldRL_M f (xs :<: x) r = f x r >>= foldRL_M f xs++allFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> Bool+allFL f xs = and $ mapFL f xs++anyFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> Bool+anyFL f xs = or $ mapFL f xs++allRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> Bool+allRL f xs = and $ mapRL f xs++anyRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> Bool+anyRL f xs = or $ mapRL f xs++-- | The "natural" fold over an 'FL' i.e. associating to the right.+-- Like 'Prelude.foldr' only with the more useful order of arguments.+foldrFL :: (forall wA wB . p wA wB -> r -> r) -> FL p wX wY -> r -> r+foldrFL _ NilFL r = r+foldrFL f (p:>:ps) r = f p (foldrFL f ps r)++-- | The "natural" fold over an RL i.e. associating to the left.+foldlRL :: (forall wA wB . r -> p wA wB -> r) -> r -> RL p wX wY -> r+foldlRL _ r NilRL = r+foldlRL f r (ps:<:p) = f (foldlRL f r ps) p++-- | Right associative fold for 'FL's that transforms a witnessed state+-- in the direction opposite to the 'FL'.+-- This is the "natural" fold for 'FL's i.e. the one which replaces the+-- ':>:' with the passed operator.+foldrwFL :: (forall wA wB . p wA wB -> r wB -> r wA) -> FL p wX wY -> r wY -> r wX+foldrwFL _ NilFL r = r+foldrwFL f (p:>:ps) r = f p (foldrwFL f ps r)++-- | The analog of 'foldrwFL' for 'RL's.+-- This is the "natural" fold for 'RL's i.e. the one which replaces the+-- ':<:' with the (flipped) passed operator.+foldlwRL :: (forall wA wB . p wA wB -> r wA -> r wB) -> RL p wX wY -> r wX -> r wY+foldlwRL _ NilRL r = r+foldlwRL f (ps:<:p) r = f p (foldlwRL f ps r)++-- | Strict left associative fold for 'FL's that transforms a witnessed state+-- in the direction of the patches. This is for apply-like functions that+-- transform the witnesses in forward direction.+foldlwFL :: (forall wA wB . p wA wB -> r wA -> r wB) -> FL p wX wY -> r wX -> r wY+foldlwFL _ NilFL r = r+foldlwFL f (p:>:ps) r = let r' = f p r in r' `seq` foldlwFL f ps r'++-- | Strict right associative fold for 'RL's that transforms a witnessed state+-- in the opposite direction of the patches. This is for unapply-like functions+-- that transform the witnesses in backward direction.+foldrwRL :: (forall wA wB . p wA wB -> r wB -> r wA) -> RL p wX wY -> r wY -> r wX+foldrwRL _ NilRL r = r+foldrwRL f (ps:<:p) r = let r' = f p r in r' `seq` foldrwRL f ps r'++mapFL_FL :: (forall wW wY . a wW wY -> b wW wY) -> FL a wX wZ -> FL b wX wZ+mapFL_FL _ NilFL = NilFL+mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as++mapFL_FL_M :: Monad m => (forall wW wY . a wW wY -> m (b wW wY)) -> FL a wX wZ -> m (FL b wX wZ)+mapFL_FL_M _ NilFL = return NilFL+mapFL_FL_M f (a:>:as) = do b <- f a+                           bs <- mapFL_FL_M f as+                           return (b:>:bs)++sequenceFL_ :: Monad m => (forall wW wZ . a wW wZ -> m b) -> FL a wX wY -> m ()+sequenceFL_ f = sequence_ . mapFL f++zipWithFL :: (forall wX wY . a -> p wX wY -> q wX wY)+          -> [a] -> FL p wW wZ -> FL q wW wZ+zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys+zipWithFL _ _ NilFL = NilFL+zipWithFL _ [] (_:>:_) = error "zipWithFL called with too short a list"++mapRL_RL :: (forall wW wY . a wW wY -> b wW wY) -> RL a wX wZ -> RL b wX wZ+mapRL_RL _ NilRL = NilRL+mapRL_RL f (as:<:a) = mapRL_RL f as :<: f a++{-# INLINABLE mapFL #-}+mapFL :: (forall wW wZ . a wW wZ -> b) -> FL a wX wY -> [b]+mapFL _ NilFL = []+mapFL f (a :>: b) = f a : mapFL f b++filterFL :: (forall wX wY . a wX wY -> Bool) -> FL a wW wZ -> [Sealed2 a]+filterFL _ NilFL = []+filterFL f (a :>: b) = if f a+                       then (Sealed2 a):(filterFL f b)+                       else filterFL f b++mapRL :: (forall wW wZ . a wW wZ -> b) -> RL a wX wY -> [b]+mapRL _ NilRL = []+mapRL f (as :<: a) = f a : mapRL f as++lengthFL :: FL a wX wZ -> Int+lengthFL xs = l xs 0+  where l :: FL a wX wZ -> Int -> Int+        l NilFL n = n+        l (_:>:as) n = l as $! n+1++lengthRL :: RL a wX wZ -> Int+lengthRL xs = l xs 0+  where l :: RL a wX wZ -> Int -> Int+        l NilRL n = n+        l (as:<:_) n = l as $! n+1++isShorterThanRL :: RL a wX wY -> Int -> Bool+isShorterThanRL _ n | n <= 0 = False+isShorterThanRL NilRL _ = True+isShorterThanRL (xs:<:_) n = isShorterThanRL xs (n-1)++consGapFL :: Gap w => (forall wX wY. p wX wY) -> w (FL p) -> w (FL p)+consGapFL p = joinGap (:>:) (freeGap p)++joinGapsFL :: Gap w => [w p] -> w (FL p)+joinGapsFL = foldr (joinGap (:>:)) (emptyGap NilFL)++concatGapsFL :: Gap w => [w (FL p)] -> w (FL p)+concatGapsFL = foldr (joinGap (+>+)) (emptyGap NilFL)++dropWhileFL :: (forall wX wY . a wX wY -> Bool) -> FL a wR wV -> FlippedSeal (FL a) wV+dropWhileFL _ NilFL       = flipSeal NilFL+dropWhileFL p xs@(x:>:xs')+          | p x       = dropWhileFL p xs'+          | otherwise = flipSeal xs++dropWhileRL :: (forall wX wY . a wX wY -> Bool) -> RL a wR wV -> Sealed (RL a wR)+dropWhileRL _ NilRL = seal NilRL+dropWhileRL p xs@(xs':<:x)+          | p x       = dropWhileRL p xs'+          | otherwise = seal xs++-- | Like 'takeWhile' only for 'RL's. This function is supposed to be lazy:+-- elements before the split point should not be touched.+takeWhileRL :: (forall wA wB . a wA wB -> Bool) -> RL a wX wY -> FlippedSeal (RL a) wY+takeWhileRL f xs = case spanRL f xs of _ :> r -> flipSeal r ++-- | Like 'span' only for 'RL's. This function is supposed to be lazy:+-- elements before the split point should not be touched.+spanRL :: (forall wA wB . p wA wB -> Bool) -> RL p wX wY -> (RL p :> RL p) wX wY+spanRL _ NilRL = NilRL :> NilRL+spanRL f left@(ps :<: p)+    | f p = case spanRL f ps of left' :> right -> left' :> right :<: p+    | otherwise = left :> NilRL++-- | Like 'break' only for 'RL's. This function is supposed to be lazy:+-- elements before the split point should not be touched.+breakRL :: (forall wA wB . p wA wB -> Bool) -> RL p wX wY -> (RL p :> RL p) wX wY+breakRL f = spanRL (not . f)++infixr 5 +>>++infixl 5 +<<+++-- | Prepend an 'RL' to an 'FL'. This traverses only the left hand side.+(+>>+) :: RL p wX wY -> FL p wY wZ -> FL p wX wZ+NilRL +>>+ ys = ys+(xs:<:x) +>>+ ys = xs +>>+ (x :>: ys)++-- | Append an 'FL' to an 'RL'. This traverses only the right hand side.+(+<<+) :: RL p wX wY -> FL p wY wZ -> RL p wX wZ+xs +<<+ NilFL = xs+xs +<<+ (y:>:ys) = (xs:<:y) +<<+ ys++initsFL :: FL p wX wY -> [Sealed ((p :> FL p) wX)]+initsFL NilFL = []+initsFL (x :>: xs) =+    Sealed (x :> NilFL) :+    map (\(Sealed (y :> xs')) -> Sealed (x :> y :>: xs')) (initsFL xs)++concatRLFL :: RL (FL p) wX wY -> RL p wX wY+concatRLFL NilRL = NilRL+concatRLFL (ps :<: p) = concatRLFL ps +<<+ p
+ src/Darcs/Patch/Witnesses/Sealed.hs view
@@ -0,0 +1,196 @@+-- Copyright (C) 2007 David Roundy, 2009 Ganesh Sittampalam+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# OPTIONS_HADDOCK ignore-exports #-}++module Darcs.Patch.Witnesses.Sealed+    ( Sealed(..)+    , seal+    , unseal+    , mapSeal+    , Sealed2(..)+    , seal2+    , unseal2+    , mapSeal2+    , FlippedSeal(..)+    , flipSeal+    , unsealFlipped+    , mapFlipped+    , Dup(..)+    , Gap(..)+    , FreeLeft+    , unFreeLeft+    , FreeRight+    , unFreeRight+    ) where++import Darcs.Prelude++import Data.Functor.Compose ( Compose(..) )++import Darcs.Patch.Witnesses.Eq ( Eq2, EqCheck(..) )+import Darcs.Patch.Witnesses.Show+import Darcs.Patch.Witnesses.Eq ( (=\/=) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP1, unsafeCoerceP )++-- |A 'Sealed' type is a way of hide an existentially quantified type parameter,+-- in this case wX, inside the type. Note that the only thing we can currently+-- recover about the existentially quantified type wX is that it exists.+data Sealed a where+    Sealed :: a wX -> Sealed a++seal :: a wX -> Sealed a+seal = Sealed++instance Eq2 a => Eq (Sealed (a wX)) where+    Sealed x == Sealed y | IsEq <- x =\/= y = True+                         | otherwise = False++-- |The same as 'Sealed' but for two parameters (wX and wY).+data Sealed2 a where+    Sealed2 :: !(a wX wY) -> Sealed2 a++seal2 :: a wX wY -> Sealed2 a+seal2 = Sealed2++data FlippedSeal a wY where+    FlippedSeal :: !(a wX wY) -> FlippedSeal a wY++flipSeal :: a wX wY -> FlippedSeal a wY+flipSeal = FlippedSeal++unsafeUnseal :: Sealed a -> a wX+unsafeUnseal (Sealed a) = unsafeCoerceP1 a++unsafeUnseal2 :: Sealed2 a -> a wX wY+unsafeUnseal2 (Sealed2 a) = unsafeCoerceP a++unseal :: (forall wX . a wX -> b) -> Sealed a -> b+unseal f x = f (unsafeUnseal x)++-- laziness property:+-- unseal (const True) undefined == True+--+-- Pattern-matching on Sealed is currently strict in GHC because it's an existential:+-- https://gitlab.haskell.org/ghc/ghc/issues/17130+-- Implementing unseal via unsafeUnseal (with the unsafeCoerceP1 underneath) works+-- around that, and we rely on that occasionally for performance, e.g. when reading+-- the history of a repository.+--+-- TODO: this is quite obscure and makes it hard to know whether we really need+-- laziness in a certain place or are just getting it incidentally because someone+-- chose to use unseal rather than pattern-matching. We should introduce an explicit+-- "Make this Sealed lazy" combinator (also using unsafeCoerceP1 in the implementation)+-- and then make the seal implementation itself be strict.+--+-- The combinator would work by making a value with a fresh Sealed constructor, so even+-- though the subsequent pattern-match/unseal on that would itself be strict, it would+-- only force as far as the newly introduced Sealed.+--+-- All this applies to Sealed2 too, and FlippedSeal if we ever need a lazy one (but+-- the implementation of unsealFlipped has been strict for a long time without causing+-- trouble).++mapSeal :: (forall wX . a wX -> b wX) -> Sealed a -> Sealed b+mapSeal f = unseal (seal . f)++mapFlipped :: (forall wX . a wX wY -> b wX wZ) -> FlippedSeal a wY -> FlippedSeal b wZ+mapFlipped f (FlippedSeal x) = FlippedSeal (f x)++unseal2 :: (forall wX wY . a wX wY -> b) -> Sealed2 a -> b+unseal2 f a = f (unsafeUnseal2 a)++mapSeal2 :: (forall wX wY . a wX wY -> b wX wY) -> Sealed2 a -> Sealed2 b+mapSeal2 f = unseal2 (seal2 . f)++unsealFlipped :: (forall wX wY . a wX wY -> b) -> FlippedSeal a wZ -> b+unsealFlipped f (FlippedSeal a) = f a++instance Show1 a => Show (Sealed a) where+    showsPrec d (Sealed x) = showParen (d > appPrec) $ showString "Sealed " . showsPrec1 (appPrec + 1) x+instance Show2 a => Show (Sealed2 a) where+    showsPrec d (Sealed2 x) = showParen (d > appPrec) $ showString "Sealed2 " . showsPrec2 (appPrec + 1) x++-- | Duplicate a single witness. This is for situations where a patch-like type+-- is expected, i.e. a type with two witnesses, but we have only a type with one+-- witness. Naturally, any concrete value must have both witnesses agreeing.+--+-- Note that @'Sealed' ('Dup' p wX)@ is isomorphic to @p wX@.+data Dup p wX wY where+  Dup :: p wX -> Dup p wX wX++-- |'Poly' is similar to 'Sealed', but the type argument is+-- universally quantified instead of being existentially quantified.+newtype Poly a = Poly { unPoly :: forall wX . a wX }++-- |'FreeLeft' p is @ \forall x . \exists y . p x y @+-- In other words the caller is free to specify the left witness,+-- and then the right witness is an existential.+-- Note that the order of the type constructors is important for ensuring+-- that @ y @ is dependent on the @ x @ that is supplied.+-- This is why 'Stepped' is needed, rather than writing the more obvious+-- 'Sealed' ('Poly' p) which would notionally have the same quantification+-- of the type witnesses.+newtype FreeLeft p = FLInternal (Poly (Compose Sealed p))++-- |'FreeRight' p is @ \forall y . \exists x . p x y @+-- In other words the caller is free to specify the right witness,+-- and then the left witness is an existential.+-- Note that the order of the type constructors is important for ensuring+-- that @ x @ is dependent on the @ y @ that is supplied.+newtype FreeRight p = FRInternal (Poly (FlippedSeal p))++-- |Unwrap a 'FreeLeft' value+unFreeLeft :: FreeLeft p -> Sealed (p wX)+unFreeLeft (FLInternal x) = getCompose (unPoly x)++-- |Unwrap a 'FreeRight' value+unFreeRight :: FreeRight p -> FlippedSeal p wX+unFreeRight (FRInternal x) = unPoly x++-- |'Gap' abstracts over 'FreeLeft' and 'FreeRight' for code constructing these values+class Gap w where+  -- |An empty 'Gap', e.g. 'NilFL' or 'NilRL'+  emptyGap :: (forall wX . p wX wX) -> w p+  -- |A 'Gap' constructed from a completely polymorphic value, for example the constructors+  -- for primitive patches+  freeGap :: (forall wX wY . p wX wY) -> w p++  -- |Compose two 'Gap' values together in series, e.g. 'joinGap (+>+)' or 'joinGap (:>:)'+  joinGap :: (forall wX wY wZ . p wX wY -> q wY wZ -> r wX wZ) -> w p -> w q -> w r++instance Gap FreeLeft where+  emptyGap e = FLInternal (Poly (Compose (Sealed e)))+  freeGap e =  FLInternal (Poly (Compose (Sealed e)))+  joinGap op (FLInternal p) (FLInternal q) =+    FLInternal+      (Poly+         (case unPoly p of+            Compose (Sealed p') ->+              case unPoly q of+                Compose (Sealed q') -> Compose (Sealed (p' `op` q'))))++instance Gap FreeRight where+  emptyGap e = FRInternal (Poly (FlippedSeal e))+  freeGap e =  FRInternal (Poly (FlippedSeal e))+  joinGap op (FRInternal p) (FRInternal q) =+    FRInternal+      (Poly+         (case unPoly q of+            FlippedSeal q' ->+              case unPoly p of+                FlippedSeal p' -> FlippedSeal (p' `op` q')))
+ src/Darcs/Patch/Witnesses/Show.hs view
@@ -0,0 +1,50 @@+module Darcs.Patch.Witnesses.Show+    ( Show1(..)+    , Show2(..)+    , show1+    , showsPrec1+    , show2+    , showsPrec2+    , showOp2+    , appPrec+    ) where++import Darcs.Prelude++import Darcs.Util.Show ( appPrec )++import Data.Constraint ( Dict(..) )++type ShowDict a = Dict (Show a)++showsPrecD :: ShowDict a -> Int -> a -> ShowS+showsPrecD Dict       = showsPrec++showD :: ShowDict a -> a -> String+showD Dict       = show++class Show1 a where+  showDict1 :: Dict (Show (a wX))+  default showDict1 :: Show (a wX) => ShowDict (a wX)+  showDict1 = Dict++showsPrec1 :: Show1 a => Int -> a wX -> ShowS+showsPrec1 = showsPrecD showDict1++show1 :: Show1 a => a wX -> String+show1 = showD showDict1++class Show2 a where+  showDict2 :: ShowDict (a wX wY)+  default showDict2 :: Show (a wX wY) => ShowDict (a wX wY)+  showDict2 = Dict++showsPrec2 :: Show2 a => Int -> a wX wY -> ShowS+showsPrec2 = showsPrecD showDict2++show2 :: Show2 a => a wX wY -> String+show2 = showD showDict2++showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a wW wX -> b wY wZ -> String -> String+showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x .+                          showString opstr . showsPrec2 (prec + 1) y
+ src/Darcs/Patch/Witnesses/Unsafe.hs view
@@ -0,0 +1,20 @@+module Darcs.Patch.Witnesses.Unsafe+    ( unsafeCoerceP+    , unsafeCoercePStart+    , unsafeCoercePEnd+    , unsafeCoerceP1+    ) where++import Unsafe.Coerce++unsafeCoerceP :: a wX wY -> a wB wC+unsafeCoerceP = unsafeCoerce++unsafeCoercePStart :: a wX1 wY -> a wX2 wY+unsafeCoercePStart = unsafeCoerce++unsafeCoercePEnd :: a wX wY1 -> a wX wY2+unsafeCoercePEnd = unsafeCoerce++unsafeCoerceP1 :: a wX -> a wY+unsafeCoerceP1 = unsafeCoerce
+ src/Darcs/Patch/Witnesses/WZipper.hs view
@@ -0,0 +1,100 @@+-- Copyright (C) 2009 Florent Becker+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Patch.Witnesses.WZipper+    ( FZipper(..)+    , focus+    , leftmost+    , left+    , rightmost+    , right+    , jokers+    , clowns+    , flToZipper+    , lengthFZ+    , nullFZ+    , toEnd+    , toStart+    )+where++import Darcs.Prelude++import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , RL(..)+    , nullFL+    , nullRL+    , lengthFL+    , lengthRL+    , reverseFL+    , reverseRL+    , (+<+)+    , (+>+)+    )+import Darcs.Patch.Witnesses.Sealed(Sealed2(..), Sealed(..), FlippedSeal(..))++-- forward zipper+data FZipper a wX wZ where+    FZipper :: RL a wX wY -> FL a wY wZ -> FZipper a wX wZ++-- Constructors+flToZipper :: FL a wX wY -> FZipper a wX wY+flToZipper = FZipper NilRL++--destructors+nullFZ :: FZipper a wX wY -> Bool+nullFZ (FZipper l r) = nullRL l && nullFL r++lengthFZ :: FZipper a wX wY -> Int+lengthFZ (FZipper l r) = lengthRL l + lengthFL r++focus :: FZipper a wX wY -> Maybe (Sealed2 a)+focus (FZipper _ (x :>: _)) = Just $ Sealed2 x+focus _ = Nothing++-- | \"Clowns to the left of me, jokers to the right.  Here I am, stuck+--   in the middle of you\"+--   <http://en.wikipedia.org/wiki/Stuck_in_the_Middle>+clowns :: FZipper a wX wY -> Sealed ((RL a) wX)+clowns (FZipper l _) = Sealed l++-- | See 'clowns'+jokers :: FZipper a wX wY -> FlippedSeal (FL a) wY+jokers (FZipper _ r) = FlippedSeal r++rightmost :: FZipper p wX wY -> Bool+rightmost (FZipper _ NilFL) = True+rightmost _ = False++right :: FZipper p wX wY -> FZipper p wX wY+right (FZipper l (m:>:r)) = FZipper (l :<: m) r+right x@(FZipper _ NilFL) = x++leftmost :: FZipper p wX wY -> Bool+leftmost (FZipper NilRL _) = True+leftmost _ = False++left :: FZipper p wX wY -> FZipper p wX wY+left (FZipper (l :<: m) r) = FZipper l (m :>: r)+left x@(FZipper NilRL _) = x++toEnd :: FZipper p wX wY -> FZipper p wX wY+toEnd (FZipper l r) = FZipper (l +<+ reverseFL r) NilFL++toStart :: FZipper p wX wY -> FZipper p wX wY+toStart (FZipper l r) = FZipper NilRL $ reverseRL l +>+ r
+ src/Darcs/Prelude.hs view
@@ -0,0 +1,67 @@+-- Copyright (C) 2015 Ganesh Sittampalam+-- BSD3++{-+This module abstracts over the differences in the Haskell Prelude over+multiple GHC versions, and also hides some symbols that are exported by the+Prelude but clash with common names in the Darcs code.++Broadly it exports everything that the latest Prelude supports, minus the+things we explicitly exclude. Since we now use the NoImplicitPrelude extension,+every module must import it explicitly.++By convention everything from Darcs.Prelude is imported:++    import Darcs.Prelude++If necessary more things can be hidden in the 'Darcs.Prelude' import if they+clash with something local, but consider whether to either hide them+globally instead or to choose a different name for the local thing.++If something is needed from the Prelude that's hidden by default, then add+it to the Prelude import.+-}++{-# LANGUAGE CPP #-}+module Darcs.Prelude+    ( module Prelude+    , module Control.Applicative+    , module Data.Monoid+    , Semigroup(..)+    , module Data.Traversable+    ) where++import Prelude hiding+    (+      -- because it's a good name for a PatchInfo+      pi+    ,+      -- because they're in the new Prelude but only in Control.Applicative+      -- in older GHCs+      Applicative(..), (<$>), (<*>)+    ,+      -- because it's in the new Prelude but only in Data.Monoid in older GHCs+      Monoid(..)+#if MIN_VERSION_base(4,11,0)+    ,+      -- because it's in the new Prelude but only in Data.Semigroup in older GHCs+      Semigroup(..)+#endif+    ,+      -- because it's in the new Prelude but only in Data.Traversable in older GHCs+      traverse+    ,+      -- because it's a good name for a patch log+      log+    ,+      -- used by the options system+      (^)+    ,+      -- used by various code for no particularly good reason+      lookup, pred+    )++import Control.Applicative ( Applicative(..), (<$>), (<*>) )+import Data.Monoid ( Monoid(..) )+import Data.Semigroup ( Semigroup(..) )+import Data.Traversable ( traverse )
− src/Darcs/PrintPatch.hs 
@@ -1,54 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.PrintPatch ( printPatch, contextualPrintPatch,-                          printPatchPager, printFriendly ) where--import Darcs.Patch ( Patchy, showContextPatch, showPatch )-import Darcs.Patch.Apply ( ApplyState )-import Storage.Hashed.Tree( Tree )-import Storage.Hashed.Monad( virtualTreeIO )-import Darcs.Arguments ( DarcsFlag, showFriendly )-import Darcs.Flags ( isUnified )-import Printer ( putDocLnWith )-import Darcs.ColorPrinter ( fancyPrinters )-import Darcs.External ( viewDocWith )---- | @'printFriendly' opts patch@ prints @patch@ in accordance with the--- flags in opts, ie, whether @--verbose@ or @--summary@ were passed at--- the command-line.-printFriendly :: (Patchy p, ApplyState p ~ Tree)  => (Maybe (Tree IO)) -> [DarcsFlag] -> p C(x y) -> IO ()-printFriendly (Just pristine) opts p- | isUnified opts = virtualTreeIO (showContextPatch p) pristine >>= putDocLnWith fancyPrinters . fst-printFriendly _ opts p = putDocLnWith fancyPrinters $ showFriendly opts p---- | 'printPatch' prints a patch on standard output.-printPatch :: Patchy p => p C(x y) -> IO ()-printPatch p = putDocLnWith fancyPrinters $ showPatch p---- | 'printPatchPager' runs '$PAGER' and shows a patch in it.-printPatchPager :: Patchy p => p C(x y) -> IO ()-printPatchPager p = viewDocWith fancyPrinters $ showPatch p---- | 'contextualPrintPatch' prints a patch, together with its context,--- on standard output.-contextualPrintPatch :: (Patchy p, ApplyState p ~ Tree) => Tree IO -> p C(x y) -> IO ()-contextualPrintPatch s p = virtualTreeIO (showContextPatch p) s >>= putDocLnWith fancyPrinters . fst
− src/Darcs/ProgressPatches.hs 
@@ -1,65 +0,0 @@-{-# LANGUAGE CPP, GADTs #-}--#include "gadts.h"-module Darcs.ProgressPatches (progressRL, progressFL, progressRLShowTags)-where-import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthRL, lengthFL )-import Darcs.Patch.PatchInfoAnd (PatchInfoAnd,info)-import System.IO.Unsafe ( unsafePerformIO )-import Progress (minlist, beginTedious,-                 endTedious, progress, progressKeepLatest,-                 tediousSize, finishedOne)-import Darcs.Patch.Info (justName, isTag)----- | Evaluate an 'FL' list and report progress.-progressFL :: String -> FL a C(x y) -> FL a C(x y)-progressFL _ NilFL = NilFL-progressFL k (x:>:xs) = if l < minlist then x:>:xs-                                       else startit x :>: pl xs-    where l = lengthFL (x:>:xs)-          startit y = unsafePerformIO $ do beginTedious k-                                           tediousSize k l-                                           return y-          pl :: FL a C(x y) -> FL a C(x y)-          pl NilFL = NilFL-          pl (y:>:NilFL) = unsafePerformIO $ do endTedious k-                                                return (y:>:NilFL)-          pl (y:>:ys) = progress k y :>: pl ys---- | Evaluate an 'RL' list and report progress.-progressRL :: String -> RL a C(x y) -> RL a C(x y)-progressRL _ NilRL = NilRL-progressRL k (x:<:xs) = if l < minlist then x:<:xs-                                       else startit x :<: pl xs-    where l = lengthRL (x:<:xs)-          startit y = unsafePerformIO $ do beginTedious k-                                           tediousSize k l-                                           return y-          pl :: RL a C(x y) -> RL a C(x y)-          pl NilRL = NilRL-          pl (y:<:NilRL) = unsafePerformIO $ do endTedious k-                                                return (y:<:NilRL)-          pl (y:<:ys) = progress k y :<: pl ys---- | Evaluate an 'RL' list and report progress. In addition to printing--- the number of patches we got, show the name of the last tag we got.-progressRLShowTags :: String -> RL (PatchInfoAnd p) C(x y)-                   -> RL (PatchInfoAnd p) C(x y)-progressRLShowTags _ NilRL = NilRL-progressRLShowTags k (x:<:xs) = if l < minlist then x:<:xs-                                       else startit x :<: pl xs-    where l = lengthRL (x:<:xs)-          startit y = unsafePerformIO $ do beginTedious k-                                           tediousSize k l-                                           return y-          pl :: RL (PatchInfoAnd p) C(x y) -> RL (PatchInfoAnd p) C(x y)-          pl NilRL = NilRL-          pl (y:<:NilRL) = unsafePerformIO $ do endTedious k-                                                return (y:<:NilRL)-          pl (y:<:ys) =-              if isTag iy-              then finishedOne k ("back to "++ justName iy) y :<: pl ys-              else progressKeepLatest k y :<: pl ys-                  where-                    iy = info y
− src/Darcs/RemoteApply.hs 
@@ -1,60 +0,0 @@--- | This module is used by the push and put commands to apply the a bundle to a--- remote repository. By remote I do not necessarily mean a repository on another--- machine, it is just not the repository we're located in.-module Darcs.RemoteApply ( remoteApply, applyAs ) where--import System.Exit ( ExitCode )--import Darcs.Flags ( DarcsFlag( ApplyAs, Debug ), remoteDarcs )-import Darcs.Utils ( breakCommand )-import Darcs.URL ( isHttpUrl, isSshUrl, splitSshUrl, SshFilePath(..) )-import Darcs.External ( darcsProgram, pipeDoc, pipeDocSSH, maybeURLCmd )-import qualified Darcs.Ssh as Ssh ( remoteDarcs )-import Printer ( Doc )--remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode-remoteApply opts repodir bundle-    = case applyAs opts of-        Nothing -> if isSshUrl repodir-                   then applyViaSsh opts (splitSshUrl repodir) bundle-                   else if isHttpUrl repodir-                        then applyViaUrl opts repodir bundle-                        else applyViaLocal opts repodir bundle-        Just un -> if isSshUrl repodir-                   then applyViaSshAndSudo opts (splitSshUrl repodir) un bundle-                   else applyViaSudo un repodir bundle--applyAs :: [DarcsFlag] -> Maybe String-applyAs (ApplyAs user:_) = Just user-applyAs (_:fs) = applyAs fs-applyAs [] = Nothing-applyViaSudo :: String -> String -> Doc -> IO ExitCode-applyViaSudo user repo bundle =-    darcsProgram >>= \darcs ->-    pipeDoc "sudo" ["-u",user,darcs,"apply","--all","--repodir",repo] bundle-applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode-applyViaLocal opts repo bundle =-    darcsProgram >>= \darcs ->-    pipeDoc darcs ("apply":"--all":"--repodir":repo:applyopts opts) bundle--applyViaUrl :: [DarcsFlag] -> String -> Doc -> IO ExitCode-applyViaUrl opts repo bundle =-    do maybeapply <- maybeURLCmd "APPLY" repo-       case maybeapply of-         Nothing -> applyViaLocal opts repo bundle-         Just apply ->-           do let (cmd, args) = breakCommand apply-              pipeDoc cmd (args ++ [repo]) bundle--applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode-applyViaSsh opts repo bundle =-    pipeDocSSH repo [Ssh.remoteDarcs (remoteDarcs opts) ++" apply --all "++unwords (applyopts opts)++-                     " --repodir '"++(sshRepo repo)++"'"] bundle--applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode-applyViaSshAndSudo opts repo username bundle =-    pipeDocSSH repo ["sudo -u "++username++" "++Ssh.remoteDarcs (remoteDarcs opts)++-                     " apply --all --repodir '"++(sshRepo repo)++"'"] bundle--applyopts :: [DarcsFlag] -> [String]-applyopts opts = if Debug `elem` opts then ["--debug"] else []
− src/Darcs/RepoPath.hs 
@@ -1,264 +0,0 @@-{-# LANGUAGE CPP #-}---- Copyright (C) 2007 Eric Kow------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- | Various abstractions for dealing with paths.-module Darcs.RepoPath (-  -- * AbsolutePath-  AbsolutePath,-  makeAbsolute,-  ioAbsolute,-  rootDirectory,-  -- * AbsolutePathOrStd-  AbsolutePathOrStd,-  makeAbsoluteOrStd,-  ioAbsoluteOrStd,-  useAbsoluteOrStd,-  stdOut,-  -- * AbsoluteOrRemotePath-  AbsoluteOrRemotePath,-  ioAbsoluteOrRemote,-  isRemote,-  -- * SubPath-  SubPath,-  makeSubPathOf,-  simpleSubPath,-  -- * Miscellaneous-  sp2fn,-  FilePathOrURL(..),-  FilePathLike(toFilePath),-  getCurrentDirectory,-  setCurrentDirectory-) where--import Control.Applicative ( (<$>) )-import Data.List ( isPrefixOf, isSuffixOf )-import Control.Exception ( tryJust, bracket )-import System.IO.Error ( isDoesNotExistError )--import Darcs.URL ( isAbsolute, isRelative, isSshNopath )-import qualified Workaround ( getCurrentDirectory )-import qualified System.Directory ( setCurrentDirectory )-import System.Directory ( doesDirectoryExist )-import qualified System.FilePath.Posix as FilePath ( normalise )-import qualified System.FilePath as NativeFilePath ( takeFileName, takeDirectory )-import qualified Darcs.Patch.FileName as PatchFileName ( FileName, fp2fn, fn2fp )-import System.Posix.Files ( isDirectory, getSymbolicLinkStatus )-#include "impossible.h"--class FilePathOrURL a where- toPath :: a -> String--class FilePathOrURL a => FilePathLike a where- toFilePath :: a -> FilePath---- | Paths which are relative to the local darcs repository and normalized.--- Note: These are understood not to have the dot in front.-newtype SubPath      = SubPath FilePath deriving (Eq, Ord)--newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)---- | This is for situations where a string (e.g. a command line argument)--- may take the value \"-\" to mean stdin or stdout (which one depends on--- context) instead of a normal file path.-data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord)-data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord)--instance FilePathOrURL AbsolutePath where- toPath (AbsolutePath x) = x-instance FilePathOrURL SubPath where- toPath (SubPath x) = x-instance CharLike c => FilePathOrURL [c] where- toPath = toFilePath--instance FilePathOrURL AbsoluteOrRemotePath where- toPath (AbsP a) = toPath a- toPath (RmtP r) = r--instance FilePathOrURL PatchFileName.FileName where-    toPath = PatchFileName.fn2fp-instance FilePathLike PatchFileName.FileName where-    toFilePath = PatchFileName.fn2fp--instance FilePathLike AbsolutePath where- toFilePath (AbsolutePath x) = x-instance FilePathLike SubPath where- toFilePath (SubPath x) = x--class CharLike c where-    toChar :: c -> Char-    fromChar :: Char -> c-instance CharLike Char where-    toChar = id-    fromChar = id--instance CharLike c => FilePathLike [c] where-    toFilePath = map toChar---- | Make the second path relative to the first, if possible-makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath-makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =- -- The slash prevents "foobar" from being treated as relative to "foo"- if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2-    then Just $ SubPath $ drop (length p1 + 1) p2-    else Nothing--simpleSubPath :: FilePath -> Maybe SubPath-simpleSubPath x | null x = bug "simpleSubPath called with empty path"-                | isRelative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x-                | otherwise = Nothing---- | Ensure directory exists and is not a symbolic link.-doesDirectoryReallyExist :: FilePath -> IO Bool-doesDirectoryReallyExist f = do-    x <- tryJust (\x -> if isDoesNotExistError x then Just () else Nothing) $-        isDirectory <$> getSymbolicLinkStatus f-    return $ case x of-        Left () -> False-        Right y -> y---- | Interpret a possibly relative path wrt the current working directory.-ioAbsolute :: FilePath -> IO AbsolutePath-ioAbsolute dir =-    do isdir <- doesDirectoryReallyExist dir-       here <- getCurrentDirectory-       if isdir-         then bracket (setCurrentDirectory dir)-                      (const $ setCurrentDirectory $ toFilePath here)-                      (const getCurrentDirectory)-         else let super_dir = case NativeFilePath.takeDirectory dir of-                                "" ->  "."-                                d  -> d-                  file = NativeFilePath.takeFileName dir-              in do abs_dir <- if dir == super_dir-                               then return $ AbsolutePath dir-                               else ioAbsolute super_dir-                    return $ makeAbsolute abs_dir file---- | Take an absolute path and a string representing a (possibly relative)--- path and combine them into an absolute path. If the second argument is--- already absolute, then the first argument gets ignored. This function also--- takes care that the result is converted to Posix convention and--- normalized. Also, parent directories (\"..\") at the front of the string--- argument get canceled out against trailing directory parts of the--- absolute path argument.------ Regarding the last point, someone more familiar with how these functions--- are used should verify that this is indeed necessary or at least useful.-makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath-makeAbsolute a dir = if not (null dir) && isAbsolute dir-                     then AbsolutePath (normSlashes dir')-                     else ma a dir'-  where-    dir' = FilePath.normalise $ pathToPosix dir-    -- Why do we care to reduce ".." here?-    -- Why not do this throughout the whole path, i.e. "x/y/../z" -> "x/z" ?-    ma here ('.':'.':'/':r) = ma (takeDirectory here) r-    ma here ".." = takeDirectory here-    ma here "." = here-    ma here "" = here-    ma here r = here /- ('/':r)--(/-) :: AbsolutePath -> String -> AbsolutePath-x /- ('/':r) = x /- r-(AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r)-(AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r)---- | Convert to posix, remove trailing slashes, and (under Posix)--- reduce multiple leading slashes to one.-simpleClean :: String -> String-simpleClean = normSlashes . reverse . dropWhile (=='/') . reverse . pathToPosix---- | The root directory as an absolute path.-rootDirectory :: AbsolutePath-rootDirectory = AbsolutePath "/"--makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd-makeAbsoluteOrStd _ "-" = APStd-makeAbsoluteOrStd a p = AP $ makeAbsolute a p--stdOut :: AbsolutePathOrStd-stdOut = APStd--ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd-ioAbsoluteOrStd "-" = return APStd-ioAbsoluteOrStd p = AP `fmap` ioAbsolute p---- | Execute either the first or the second argument action, depending on--- whether the given path is an 'AbsolutePath' or stdin/stdout.-useAbsoluteOrStd :: (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a-useAbsoluteOrStd _ f APStd = f-useAbsoluteOrStd f _ (AP x) = f x--ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath-ioAbsoluteOrRemote p = do-  isdir <- doesDirectoryExist p-  if not isdir-     then return $ RmtP $-          case () of _ | isSshNopath p    -> p++"."-                       | "/" `isSuffixOf` p -> init p-                       | otherwise          -> p-     else AbsP `fmap` ioAbsolute p--isRemote :: AbsoluteOrRemotePath -> Bool-isRemote (RmtP _) = True-isRemote _ = False--takeDirectory :: AbsolutePath -> AbsolutePath-takeDirectory (AbsolutePath x) =-    case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of-    "" -> AbsolutePath "/"-    x' -> AbsolutePath x'--instance Show AbsolutePath where- show = show . toFilePath-instance Show SubPath where- show = show . toFilePath-instance Show AbsolutePathOrStd where-    show (AP a) = show a-    show APStd = "standard input/output"-instance Show AbsoluteOrRemotePath where-    show (AbsP a) = show a-    show (RmtP r) = show r---- | Normalize the path separator to Posix style (slash, not backslash).--- This only affects Windows systems.-pathToPosix :: FilePath -> FilePath-pathToPosix = map convert where-#ifdef WIN32-  convert '\\' = '/'-#endif-  convert c = c---- | Reduce multiple leading slashes to one. This only affects Posix systems.-normSlashes :: FilePath -> FilePath-#ifndef WIN32--- multiple slashes in front are ignored under Posix-normSlashes ('/':p) = '/' : dropWhile (== '/') p-#endif-normSlashes p = p--getCurrentDirectory :: IO AbsolutePath-getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory--setCurrentDirectory :: FilePathLike p => p -> IO ()-setCurrentDirectory = System.Directory.setCurrentDirectory . toFilePath--{-# INLINE sp2fn #-}-sp2fn :: SubPath -> PatchFileName.FileName-sp2fn = PatchFileName.fp2fn . toFilePath
src/Darcs/Repository.hs view
@@ -16,496 +16,161 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, ScopedTypeVariables #-}--#include "gadts.h"- module Darcs.Repository-    ( Repository, HashedDir(..), Cache(..), CacheLoc(..), WritableOrNot(..)-    , RepoJob(..), maybeIdentifyRepository, identifyRepositoryFor-    , withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory-    , withGutsOf, makePatchLazy, writePatchSet, findRepository, amInRepository-    , amNotInRepository, amInHashedRepository, replacePristine-    , withRecorded, readRepo, prefsUrl, readRepoUsingSpecificInventory-    , addToPending, tentativelyAddPatch, tentativelyRemovePatches-    , tentativelyAddToPending, tentativelyReplacePatches, readTentativeRepo-    , tentativelyMergePatches, considerMergeToWorking, revertRepositoryChanges-    , finalizeRepositoryChanges, createRepository, copyRepository-    , patchSetToRepository, unrevertUrl, applyToWorking-    , patchSetToPatches, createPristineDirectoryTree-    , createPartialsPristineDirectoryTree, optimizeInventory, cleanRepository-    , PatchSet, SealedPatchSet, PatchInfoAnd-    , setScriptsExecutable, setScriptsExecutablePatches-    , checkUnrelatedRepos, testTentative, testRecorded-    , extractOptions, modifyCache, reportBadSources+    ( Repository+    , AccessType(..)+    , repoLocation+    , repoFormat+    , repoPristineType+    , repoCache+    , PristineType(..)+    , HashedDir(..)+    , Cache+    , CacheLoc(..)+    , CacheType(..)+    , WritableOrNot(..)+    , cacheEntries+    , mkCache+    , reportBadSources+    , RepoJob(..)+    , maybeIdentifyRepository+    , identifyRepositoryFor+    , ReadingOrWriting(..)+    , withRepoLock+    , withRepoLockCanFail+    , withRepository+    , withRepositoryLocation+    , withUMaskFlag+    , findRepository+    , amInRepository+    , amNotInRepository+    , amInHashedRepository+    , writePristine+    , readPatches+    , prefsUrl+    , addToPending+    , unsafeAddToPending+    , tentativelyAddPatch+    , tentativelyAddPatches+    , tentativelyRemovePatches+    , setTentativePending+    , tentativelyRemoveFromPW+    , withManualRebaseUpdate+    , tentativelyMergePatches+    , considerMergeToWorking+    , revertRepositoryChanges+    , UpdatePending(..)+    , finalizeRepositoryChanges+    , createRepository+    , createRepositoryV1+    , createRepositoryV2+    , EmptyRepository(..)+    , cloneRepository+    , applyToWorking+    , createPristineDirectoryTree+    , reorderInventory+    , cleanRepository+    , PatchSet+    , SealedPatchSet+    , PatchInfoAnd+    , setAllScriptsExecutable+    , setScriptsExecutablePatches+    , modifyCache     -- * Recorded and unrecorded and pending.-    , readRecorded, readUnrecorded, unrecordedChanges, readPending-    , readRecordedAndPending-    -- * Index.-    , readIndex, invalidateIndex+    , readPristine+    , readUnrecorded+    , unrecordedChanges+    , readPendingAndWorking+    , filterOutConflicts+    , readPristineAndPending     ) where -import Prelude hiding ( catch )--import System.Exit ( ExitCode(..), exitWith )-#if MIN_VERSION_tar(0,4,0)-import Control.Exception ( Exception, throwIO, catch )-#else-import Control.Exception ( catch )-#endif-import Data.List ( isPrefixOf)-import Data.Maybe( catMaybes, isJust, listToMaybe )--import Darcs.Repository.State( readRecorded, readUnrecorded, readWorking, unrecordedChanges-                             , readPending, readIndex, invalidateIndex-                             , readRecordedAndPending )--import Darcs.Repository.Internal-    (Repository(..), RepoType(..), RepoJob(..),-     maybeIdentifyRepository, identifyRepositoryFor, identifyDarcsRepository,-     IdentifyRepo(..),-     findRepository, amInRepository, amNotInRepository, amInHashedRepository,-     makePatchLazy,-     withRecorded,-     readRepo, readTentativeRepo, readRepoUsingSpecificInventory,-     prefsUrl,-     withRepoLock, withRepoReadLock, withRepository, withRepositoryDirectory, withGutsOf,-     tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,-     tentativelyReplacePatches,-     revertRepositoryChanges, finalizeRepositoryChanges,-     unrevertUrl,-     applyToWorking, patchSetToPatches,-     createPristineDirectoryTree, createPartialsPristineDirectoryTree,-     optimizeInventory, cleanRepository,-     setScriptsExecutable, setScriptsExecutablePatches,-     testTentative, testRecorded,-     makeNewPending, seekRepo+import Darcs.Repository.State+    ( readPristine+    , readUnrecorded+    , unrecordedChanges+    , readPendingAndWorking+    , readPristineAndPending+    , filterOutConflicts+    , unsafeAddToPending+    , addToPending     )-import Darcs.Repository.Merge( tentativelyMergePatches, considerMergeToWorking )-import Darcs.Repository.Cache ( unionRemoteCaches, fetchFileUsingCache,-                                speculateFileUsingCache, HashedDir(..), Cache(..),-                                CacheLoc(..), WritableOrNot(..), hashedDir ,-                                CacheType(Directory), reportBadSources )-import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2RL, newset2FL, progressPatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import URL ( maxPipelineLength ) -import Control.Exception ( finally )-import Control.Concurrent ( forkIO )-import Control.Concurrent.MVar ( MVar, newMVar, putMVar, takeMVar )-import Control.Monad ( unless, when )-import System.Directory ( createDirectory, createDirectoryIfMissing, renameFile,-                          doesFileExist, removeFile, getDirectoryContents,-                          getCurrentDirectory, setCurrentDirectory )-import System.IO ( stderr )-import System.IO.Error ( isAlreadyExistsError )-import System.Posix.Files ( createLink )--import qualified Darcs.Repository.HashedRepo as HashedRepo--import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash )-import Darcs.Repository.ApplyPatches ( applyPatches )-import Darcs.Repository.HashedRepo ( applyToTentativePristine, pris2inv, revertTentativeChanges,-                                     copySources )-import Darcs.Repository.InternalTypes ( extractOptions, modifyCache )-import Darcs.Patch ( RepoPatch, PrimOf )-import Darcs.Patch.Apply( ApplyState )--import Darcs.Witnesses.Ordered ( FL(..), RL(..), bunchFL, mapFL, mapRL-                               , lengthRL, (+>+), (:\/:)(..) )-import Darcs.Repository.Format ( RepoProperty ( HashedInventory ), RepoFormat,-                                 createRepoFormat, formatHas, writeRepoFormat,-                                 readfromAndWritetoProblem)-import Darcs.Repository.Prefs ( writeDefaultPrefs )-import Darcs.Patch.Depends ( areUnrelatedRepos, findUncommon )--import Darcs.Utils ( withCurrentDirectory, catchall, promptYorn )-import Darcs.External ( copyFileOrUrl, Cachable(..), fetchFileLazyPS )-import Progress ( debugMessage, tediousSize, beginTedious, endTedious )-import Darcs.ProgressPatches (progressRLShowTags, progressFL)-import Darcs.Lock ( writeBinFile, writeDocBinFile, withTemp )-import Darcs.Witnesses.Sealed ( Sealed(..) )--import Darcs.Flags ( DarcsFlag( Verbose, Quiet, Lazy, Complete,-                                AllowUnrelatedRepos, NoUpdateWorking)-                   , compression, UseIndex(..), ScanKnown(..), remoteDarcs-                   , usePacks )-import Darcs.Global ( darcsdir )-import Darcs.URL ( isFile )-import Darcs.SignalHandler ( catchInterrupt )-import Printer ( Doc, text, hPutDocLn, putDocLn )--import Storage.Hashed.Tree( Tree, emptyTree )-import Storage.Hashed.Hash( encodeBase16 )-import Storage.Hashed.Darcs( writeDarcsHashed, darcsAddMissingHashes )-import ByteStringUtils( gzReadFilePS )--import System.FilePath( (</>), takeFileName, splitPath, joinPath-                      , takeDirectory )-import qualified Codec.Archive.Tar as Tar-import Codec.Compression.GZip ( compress, decompress )-import qualified Data.ByteString.Char8 as BS-import qualified Data.ByteString.Lazy.Char8 as BL--#include "impossible.h"--createRepository :: [DarcsFlag] -> IO ()-createRepository opts = do-  createDirectory darcsdir `catch`-      (\e-> if isAlreadyExistsError e-            then fail "Tree has already been initialized!"-            else fail $ "Error creating directory `"++darcsdir++"'.")-  cwd <- getCurrentDirectory-  x <- seekRepo-  when (isJust x) $ do-      setCurrentDirectory cwd-      putStrLn $ "WARNING: creating a nested repository."-  let rf = createRepoFormat opts-  createDirectory $ darcsdir ++ "/pristine.hashed"-  createDirectory $ darcsdir ++ "/patches"-  createDirectory $ darcsdir ++ "/prefs"-  writeDefaultPrefs-  writeRepoFormat rf (darcsdir++"/format")-  writeBinFile (darcsdir++"/hashed_inventory") ""-  writePristine "." emptyTree--data RepoSort = Hashed | Old--repoSort :: RepoFormat -> RepoSort-repoSort f-  | formatHas HashedInventory f = Hashed-  | otherwise = Old--copyInventory :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-copyInventory fromRepo@(Repo fromDir opts fromFormat (DarcsRepository _ fromCache)) = do-  toRepo@(Repo toDir opts' toFormat (DarcsRepository toPristine toCache)) <--    identifyDarcsRepository opts "."-  let (_ :: Repository p C(r u t)) = toRepo --The witnesses are wrong, but cannot escape-  case readfromAndWritetoProblem fromFormat toFormat of-    Just e ->  fail $ "Incompatibility with repository " ++ fromDir ++ ":\n" ++ e-    Nothing -> return ()-  toCache2 <- unionRemoteCaches toCache fromCache fromDir-  let toRepo2 :: Repository p C(r u t)-      toRepo2 = Repo toDir opts' toFormat $ DarcsRepository toPristine toCache2-      copyHashedHashed = HashedRepo.copyRepo toRepo2 (remoteDarcs opts) fromDir-  case repoSort fromFormat of-    Hashed -> copyHashedHashed-    Old -> withCurrentDirectory toDir $ do-                HashedRepo.revertTentativeChanges-                patches <- readRepo fromRepo-                let k = "Copying patch"-                beginTedious k-                tediousSize k (lengthRL $ newset2RL patches)-                let patches' = progressPatchSet k patches-                HashedRepo.writeTentativeInventory toCache (compression opts) patches'-                endTedious k-                HashedRepo.finalizeTentativeChanges toRepo $ compression opts--copyRepository :: forall p C(r u t). (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)-               => Repository p C(r u t) -> Bool -> IO ()-copyRepository fromRepo@(Repo fromDir opts _ _) withWorkingDir = do-  debugMessage "Copying prefs"-  copyFileOrUrl (remoteDarcs opts) (fromDir ++ "/" ++ darcsdir ++ "/prefs/prefs")-    (darcsdir ++ "/prefs/prefs") (MaxAge 600) `catchall` return ()-  -- try packs for remote repositories-  if (not . isFile) fromDir && usePacks opts-    then copyPackedRepository fromRepo withWorkingDir-    else copyNotPackedRepository fromRepo withWorkingDir--putInfo :: [DarcsFlag] -> Doc -> IO ()-putInfo opts = unless (Quiet `elem` opts) . hPutDocLn stderr--copyNotPackedRepository :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) ->-                           Bool -> IO ()-copyNotPackedRepository fromrepository@(Repo _ opts rffrom _) withWorkingDir = do-  copyInventory fromrepository-  debugMessage "Grabbing lock in new repository..."-  withRepoLock opts $ RepoJob $ \torepository ->-      if formatHas HashedInventory rffrom-      then do-        when withWorkingDir $ do-          debugMessage "Writing working directory contents..."-          createPristineDirectoryTree torepository "."-        fetchPatchesIfNecessary opts torepository `catchInterrupt`-          (putInfo opts $ text "Using lazy repository.")-      else      do local_patches <- readRepo torepository-                   replacePristine torepository emptyTree-                   let patchesToApply = progressFL "Applying patch" $ newset2FL local_patches-                   sequence_ $ mapFL applyToTentativePristine $ bunchFL 100 patchesToApply-                   finalizeRepositoryChanges torepository-                   when withWorkingDir $ do-                     debugMessage "Writing working directory contents..."-                     createPristineDirectoryTree torepository "."--copyPackedRepository ::-  forall p C(r u t). (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)-  => Repository p C(r u t) -> Bool -> IO ()-copyPackedRepository r withWorkingDir =-  -- fallback to no-packs get in case of error-  copyPackedRepository2 r withWorkingDir `catchall` copyNotPackedRepository r withWorkingDir--copyPackedRepository2 ::-  forall p C(r u t). (RepoPatch p, ApplyState (PrimOf p) ~ Tree, ApplyState p ~ Tree)-  => Repository p C(r u t) -> Bool -> IO ()-copyPackedRepository2 fromRepo@(Repo fromDir opts _ (DarcsRepository _ fromCache)) withWorkingDir = do-  b <- fetchFileLazyPS (fromDir ++ "/" ++ darcsdir ++ "/packs/basic.tar.gz") Uncachable-  when (Verbose `elem` opts) $ putDocLn $ text "Getting packed repository."-  Repo toDir _ toFormat (DarcsRepository toPristine toCache) <--    identifyRepositoryFor fromRepo "."-  toCache2 <- unionRemoteCaches toCache fromCache fromDir-  let toRepo :: Repository p C(r u r) -- In empty repo, t(entative) = r(ecorded)-      toRepo = Repo toDir opts toFormat $ DarcsRepository toPristine toCache2-      fromPacksDir = fromDir ++ "/" ++ darcsdir ++ "/packs/"-  createDirectoryIfMissing False $ darcsdir </> "inventories"-  copySources toRepo fromDir-  Repo _ _ _ (DarcsRepository _ toCache3) <--    identifyRepositoryFor toRepo "."-  -- unpack inventory & pristine cache-  let isLazy = Lazy `elem` opts-  cleanDir "pristine.hashed"-  removeFile $ darcsdir </> "hashed_inventory"-  unpackBasic toCache3 . Tar.read $ decompress b-  when withWorkingDir $-    createPristineDirectoryTree toRepo "."-  -- pull new patches-  us <- readRepo toRepo-  them <- readRepo fromRepo-  us' :\/: them' <- return $ findUncommon us them-  revertTentativeChanges-  Sealed pw <- tentativelyMergePatches toRepo "get" opts us' them'-  invalidateIndex toRepo-  withGutsOf toRepo $ do-    finalizeRepositoryChanges toRepo-    when withWorkingDir $-      applyToWorking toRepo opts pw >> return ()-    return ()-  -- get old patches-  unless isLazy $ (do-    cleanDir "patches"-    putInfo opts $ text "Copying patches, to get lazy repository hit ctrl-C..."-    unpackPatches toCache3 (mapFL hashedPatchFileName $ newset2FL us) .-      Tar.read . decompress =<< fetchFileLazyPS (fromPacksDir ++-      "patches.tar.gz") Uncachable-    ) `catchInterrupt` (putInfo opts $ text "Using lazy repository.")- where-  cleanDir d = mapM_ (\x -> removeFile $ darcsdir </> d </> x) .-    filter (\x -> head x /= '.') =<< getDirectoryContents (darcsdir </> d)--withControlMVar :: (MVar () -> IO ()) -> IO ()-withControlMVar f = do-  mv <- newMVar ()-  f mv-  takeMVar mv--forkWithControlMVar :: MVar () -> IO () -> IO ()-forkWithControlMVar mv f = do-  takeMVar mv-  _ <- forkIO $ flip finally (putMVar mv ()) f-  return ()--removeMetaFiles :: IO ()-removeMetaFiles = mapM_ (removeFile . (darcsdir </>)) .-  filter ("meta-" `isPrefixOf`) =<< getDirectoryContents darcsdir--#if MIN_VERSION_tar(0,4,0)-unpackBasic :: Exception e => Cache -> Tar.Entries e -> IO ()-#else-unpackBasic :: Cache -> Tar.Entries -> IO ()-#endif-unpackBasic c x = do-  withControlMVar $ \mv -> unpackTar c (basicMetaHandler c mv) x-  removeMetaFiles--#if MIN_VERSION_tar(0,4,0)-unpackPatches :: Exception e => Cache -> [String] -> Tar.Entries e -> IO ()-#else-unpackPatches :: Cache -> [String] -> Tar.Entries -> IO ()-#endif-unpackPatches c ps x = do-  withControlMVar $ \mv -> unpackTar c (patchesMetaHandler c ps mv) x-  removeMetaFiles--#if MIN_VERSION_tar(0,4,0)-unpackTar :: Exception e => Cache -> IO () -> Tar.Entries e -> IO ()-#else-unpackTar :: Cache -> IO () -> Tar.Entries -> IO ()-#endif-unpackTar  _ _ Tar.Done = return ()-#if MIN_VERSION_tar(0,4,0)-unpackTar  _ _ (Tar.Fail e)= throwIO e-#else-unpackTar  _ _ (Tar.Fail e)= fail e-#endif-unpackTar c mh (Tar.Next x xs) = case Tar.entryContent x of-  Tar.NormalFile x' _ -> do-    let p = Tar.entryPath x-    if "meta-" `isPrefixOf` takeFileName p-      then do-        BL.writeFile p x'-        mh-        unpackTar c mh xs-      else do-        ex <- doesFileExist p-        if ex-          then debugMessage $ "Tar thread: STOP " ++ p-          else do-            if p == darcsdir </> "hashed_inventory"-              then writeFile' Nothing p x'-              else writeFile' (cacheDir c) p $ compress x'-            debugMessage $ "Tar thread: GET " ++ p-            unpackTar c mh xs-  _ -> fail "Unexpected non-file tar entry"- where-  writeFile' Nothing z y = withTemp $ \x' -> do-    BL.writeFile x' y-    renameFile x' z-  writeFile' (Just ca) z y = do-    let x' = joinPath . tail $ splitPath z -- drop darcsdir-    ex <- doesFileExist $ ca </> x'-    if ex-      then createLink' (ca </> x') z-      else withTemp $ \x'' -> do-        BL.writeFile x'' y-        createLink' x'' $ ca </> x'-        renameFile x'' z-  createLink' z y = do-    createDirectoryIfMissing True $ takeDirectory y-    createLink z y `catchall` return ()--basicMetaHandler :: Cache -> MVar () -> IO ()-basicMetaHandler ca mv = do-  ex <- doesFileExist $ darcsdir </> "meta-filelist-pristine"-  when ex . forkWithControlMVar mv $-    fetchFilesUsingCache ca HashedPristineDir . lines =<<-      readFile (darcsdir </> "meta-filelist-pristine")-  return ()--patchesMetaHandler :: Cache -> [String] -> MVar () -> IO ()-patchesMetaHandler ca ps mv = do-  ex <- doesFileExist $ darcsdir </> "meta-filelist-inventories"-  when ex $ do-    forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPristineDir .-      lines =<< readFile (darcsdir </> "meta-filelist-inventories")-    forkWithControlMVar mv $ fetchFilesUsingCache ca HashedPatchesDir ps-  return ()--cacheDir :: Cache -> Maybe String-cacheDir (Ca cs) = listToMaybe . catMaybes .flip map cs $ \x -> case x of-  Cache Directory Writable x' -> Just x'-  _ -> Nothing--hashedPatchFileName :: PatchInfoAnd p C(a b) -> String-hashedPatchFileName x = case extractHash x of-  Left _ -> fail "unexpected unhashed patch"-  Right h -> h- --- | fetchFilesUsingCache is similar to mapM fetchFileUsingCache, exepts--- it stops execution if file it's going to fetch already exists.-fetchFilesUsingCache :: Cache -> HashedDir -> [FilePath] -> IO ()-fetchFilesUsingCache _ _ [] = return ()-fetchFilesUsingCache c d (f:fs) = do-  ex <- doesFileExist $ darcsdir </> hashedDir d </> f-  if ex-    then debugMessage $ "Cache thread: STOP " ++-      (darcsdir </> hashedDir d </> f)-    else do-      debugMessage $ "Cache thread: GET " ++-        (darcsdir </> hashedDir d </> f)--- Warning:  A do-notation statement discarded a result of type (String, BS.ByteString).-      _ <- fetchFileUsingCache c d f-      fetchFilesUsingCache c d fs---- | writePatchSet is like patchSetToRepository, except that it doesn't--- touch the working directory or pristine cache.-writePatchSet :: (RepoPatch p, ApplyState p ~ Tree) => PatchSet p C(Origin x) -> [DarcsFlag] -> IO (Repository p C(r u t))-writePatchSet patchset opts = do-    maybeRepo <- maybeIdentifyRepository opts "."-    let repo@(Repo _ _ _ (DarcsRepository _ c)) =-          case maybeRepo of-            GoodRepository r -> r-            BadRepository e -> bug ("Current directory is a bad repository in writePatchSet: " ++ e)-            NonRepository e -> bug ("Current directory not a repository in writePatchSet: " ++ e)-    debugMessage "Writing inventory"-    HashedRepo.writeTentativeInventory c (compression opts) patchset-    HashedRepo.finalizeTentativeChanges repo (compression opts)-    return repo---- | patchSetToRepository takes a patch set, and writes a new repository in the current directory---   that contains all the patches in the patch set. This function is used when 'darcs get'ing a---   repository with the --to-match flag and the new repository is not in hashed format.---   This function does not (yet) work for hashed repositories. If the passed @DarcsFlag@s tell---   darcs to create a hashed repository, this function will call @error@.-patchSetToRepository :: (RepoPatch p, ApplyState p ~ Tree)-                     => Repository p C(r1 u1 r1) -> PatchSet p C(Origin x)-                     -> [DarcsFlag] -> IO (Repository p C(r u t))-patchSetToRepository (Repo fromrepo _ rf _) patchset opts = do-    when (formatHas HashedInventory rf) $ -- set up sources and all that-       do writeFile "_darcs/tentative_pristine" "" -- this is hokey-          repox <- writePatchSet patchset opts-          HashedRepo.copyRepo repox (remoteDarcs opts) fromrepo-    repo <- writePatchSet patchset opts-    readRepo repo >>= (applyPatches . newset2FL)-    debugMessage "Writing the pristine"-    pristineFromWorking repo-    return repo--checkUnrelatedRepos :: RepoPatch p => [DarcsFlag] -> PatchSet p C(start x) -> PatchSet p C(start y)-                    -> IO ()-checkUnrelatedRepos opts _ _ | AllowUnrelatedRepos `elem` opts = return ()-checkUnrelatedRepos _ us them =-    if areUnrelatedRepos us them-    then do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?"-            unless confirmed $ do putStrLn "Cancelled."-                                  exitWith ExitSuccess-    else return ()---- | Unless a flag has been given in the first argument that tells darcs not to do so (--lazy,---   or --partial), this function fetches all patches that the given repository has---   with fetchFileUsingCache. This is used as a helper in copyRepository.-fetchPatchesIfNecessary :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree) => [DarcsFlag] -> Repository p C(r u t) -> IO ()-fetchPatchesIfNecessary opts torepository@(Repo _ _ _ (DarcsRepository _ c)) =-    unless (Lazy `elem` opts) $-             do unless (Complete `elem` opts) $-                       putInfo opts $ text "Copying patches, to get lazy repository hit ctrl-C..."-                r <- readRepo torepository-                pipelineLength <- maxPipelineLength-                let patches = newset2RL r-                    ppatches = progressRLShowTags "Copying patches" patches-                    (first, other) = splitAt (pipelineLength - 1) $ tail $ hashes patches-                    speculate | pipelineLength > 1 = [] : first : map (:[]) other-                              | otherwise = []-                mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat [])-  where hashes :: FORALL(x y) RL (PatchInfoAnd p) C(x y) -> [String]-        hashes = catMaybes . mapRL ((either (const Nothing) Just) . extractHash)-        fetchAndSpeculate :: (String, [String]) -> IO ()-        fetchAndSpeculate (f, ss) = do--- Warning:  A do-notation statement discarded a result of type (String, BS.ByteString).-          _ <- fetchFileUsingCache c HashedPatchesDir f-          mapM_ (speculateFileUsingCache c HashedPatchesDir) ss--addToPending :: (RepoPatch p, ApplyState p ~ Tree)-             => Repository p C(r u t) -> FL (PrimOf p) C(u y) -> IO ()-addToPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-addToPending repo@(Repo{}) p =-    do pend <- unrecordedChanges (UseIndex, ScanKnown) repo Nothing-       invalidateIndex repo-       makeNewPending repo (pend +>+ p)---- | Replace the existing pristine with a new one (loaded up in a Tree object).-replacePristine :: Repository p C(r u t) -> Tree IO -> IO ()-replacePristine (Repo r _ _ _) = writePristine r--writePristine :: FilePath -> Tree IO -> IO ()-writePristine r tree = withCurrentDirectory r $-    do let t = darcsdir </> "hashed_inventory"-       i <- gzReadFilePS t-       tree' <- darcsAddMissingHashes tree-       root <- writeDarcsHashed tree' $ darcsdir </> "pristine.hashed"-       writeDocBinFile t $ pris2inv (BS.unpack $ encodeBase16 root) i+import Darcs.Repository.Prefs ( prefsUrl ) -pristineFromWorking :: RepoPatch p => Repository p C(r u t) -> IO ()-pristineFromWorking repo@(Repo dir _ _ _) =-  withCurrentDirectory dir $ readWorking >>= replacePristine repo+import Darcs.Repository.Identify+    ( maybeIdentifyRepository+    , identifyRepositoryFor+    , ReadingOrWriting(..)+    , findRepository+    , amInRepository+    , amNotInRepository+    , amInHashedRepository+    )+import Darcs.Repository.Hashed+    ( readPatches+    , tentativelyAddPatch+    , tentativelyAddPatches+    , tentativelyRemovePatches+    , reorderInventory+    )+import Darcs.Repository.Pristine+    ( createPristineDirectoryTree+    , writePristine+    )+import Darcs.Repository.Transaction+    ( revertRepositoryChanges+    , finalizeRepositoryChanges+    )+import Darcs.Repository.Traverse ( cleanRepository )+import Darcs.Repository.Pending ( setTentativePending, tentativelyRemoveFromPW )+import Darcs.Repository.Working+    ( applyToWorking+    , setAllScriptsExecutable+    , setScriptsExecutablePatches+    )+import Darcs.Repository.Job+    ( RepoJob(..)+    , withRepoLock+    , withRepoLockCanFail+    , withRepository+    , withRepositoryLocation+    , withUMaskFlag+    )+import Darcs.Repository.Rebase ( withManualRebaseUpdate )+import Darcs.Repository.Merge( tentativelyMergePatches+                             , considerMergeToWorking+                             )+import Darcs.Util.Cache+    ( Cache+    , CacheLoc(..)+    , CacheType(..)+    , HashedDir(..)+    , WritableOrNot(..)+    , cacheEntries+    , mkCache+    , reportBadSources+    )+import Darcs.Repository.InternalTypes+    ( Repository+    , AccessType(..)+    , PristineType(..)+    , modifyCache+    , repoLocation+    , repoFormat+    , repoPristineType+    , repoCache+    )+import Darcs.Repository.Clone+    ( cloneRepository+    )+import Darcs.Repository.Create+    ( createRepository+    , createRepositoryV1+    , createRepositoryV2+    , EmptyRepository(..)+    )+import Darcs.Repository.Flags ( UpdatePending(..) ) +import Darcs.Patch.Set ( PatchSet, SealedPatchSet )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )
src/Darcs/Repository/ApplyPatches.hs view
@@ -15,25 +15,153 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-methods #-}+{-# LANGUAGE MultiParamTypeClasses #-} -#include "gadts.h"+module Darcs.Repository.ApplyPatches+    ( runTolerantly+    , runSilently+    , DefaultIO, runDefault+    ) where -module Darcs.Repository.ApplyPatches ( applyPatches ) where+import Control.Exception ( IOException, SomeException, catch )+import Control.Monad ( unless )+import Control.Monad.Catch ( MonadThrow )+import qualified Data.ByteString as B ( empty, null, readFile )+import Data.Char ( toLower )+import Data.List ( isSuffixOf )+import System.Directory+    ( createDirectory+    , doesDirectoryExist+    , doesFileExist+    , removeDirectory+    , removeFile+    , renamePath+    )+import System.IO ( hPutStrLn, stderr )+import System.IO.Error+    ( catchIOError+    , isAlreadyExistsError+    , isDoesNotExistError+    , isPermissionError+    ) -import Darcs.Patch.ApplyMonad( ApplyMonad )-import Darcs.MonadProgress ( MonadProgress, ProgressAction(..), runProgressActions)-import Darcs.Patch ( Patchy, apply )-import Darcs.IO () -- for ApplyMonad IO-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )-import Darcs.Patch.Info ( humanFriendly )-import Darcs.Patch.Apply( ApplyState )-import Darcs.Witnesses.Ordered ( FL(..), mapFL )-import Printer ( text, ($$) )+import Darcs.Prelude -applyPatches :: (MonadProgress m, ApplyMonad m (ApplyState p), Patchy p) => FL (PatchInfoAnd p) C(x y) -> m ()-applyPatches ps = runProgressActions "Applying patch" (mapFL doApply ps)-   where doApply hp =-            ProgressAction { paAction = apply (hopefully hp)-                           , paMessage = humanFriendly (info hp)-                           , paOnError = text "Unapplicable patch:" $$ humanFriendly (info hp) }+import Darcs.Patch.ApplyMonad ( ApplyMonad(..), ApplyMonadTree(..) )+import Darcs.Repository.Prefs ( changePrefval )+import Darcs.Util.Exception ( prettyException )+import Darcs.Util.File ( backupByCopying, backupByRenaming )+import Darcs.Util.Lock ( writeAtomicFilePS )+import Darcs.Util.Path ( AnchoredPath, realPath )+import Darcs.Util.Tree ( Tree )++newtype DefaultIO a = DefaultIO { runDefaultIO :: IO a }+    deriving (Functor, Applicative, Monad, MonadThrow)++instance ApplyMonad Tree DefaultIO where++instance ApplyMonadTree DefaultIO where+    mDoesDirectoryExist = DefaultIO . doesDirectoryExist . realPath+    mChangePref a b c = DefaultIO $ changePrefval a b c+    mModifyFilePS f j = DefaultIO $ B.readFile (realPath f) >>= runDefaultIO . j >>= writeAtomicFilePS (realPath f)+    mCreateDirectory = DefaultIO . createDirectory . realPath+    mCreateFile f = DefaultIO $+                    do exf <- doesFileExist (realPath f)+                       if exf then fail $ "File '"++realPath f++"' already exists!"+                              else do exd <- doesDirectoryExist $ realPath f+                                      if exd then fail $ "File '"++realPath f++"' already exists!"+                                             else writeAtomicFilePS (realPath f) B.empty+    mRemoveFile f = DefaultIO $+                    do let fp = realPath f+                       x <- B.readFile fp+                       unless (B.null x) $+                            fail $ "Cannot remove non-empty file "++fp+                       removeFile fp+    mRemoveDirectory = DefaultIO . removeDirectory . realPath+    mRename a b = DefaultIO $ renamePath x y+      where x = realPath a+            y = realPath b++class (Functor m, MonadThrow m) => TolerantMonad m where+    warning :: IO () -> m ()+    runIO :: m a -> IO a+    runTM :: IO a -> m a++newtype TolerantIO a = TIO { runTIO :: IO a }+    deriving (Functor, Applicative, Monad, MonadThrow)++instance TolerantMonad TolerantIO where+    warning io = TIO $ io `catch` \e -> hPutStrLn stderr $ "Warning: " ++ prettyException e+    runIO (TIO io) = io+    runTM = TIO++newtype SilentIO a = SIO { runSIO :: IO a }+    deriving (Functor, Applicative, Monad, MonadThrow)++instance TolerantMonad SilentIO where+    warning io = SIO $ io `catch` \(_ :: SomeException) -> return ()+    runIO (SIO io) = io+    runTM = SIO++newtype TolerantWrapper m a = TolerantWrapper { runTolerantWrapper :: m a }+    deriving (Functor, Applicative, Monad, TolerantMonad)++deriving instance MonadThrow m => MonadThrow (TolerantWrapper m)++-- | Apply patches, emitting warnings if there are any IO errors+runTolerantly :: TolerantWrapper TolerantIO a -> IO a+runTolerantly = runTIO . runTolerantWrapper++-- | Apply patches, ignoring all errors+runSilently :: TolerantWrapper SilentIO a -> IO a+runSilently = runSIO . runTolerantWrapper++-- | The default mode of applying patches: fail if the directory is not+-- as we expect+runDefault :: DefaultIO a -> IO a+runDefault action =+  catchIOError (runDefaultIO action) $ \e ->+    fail $ "Cannot apply some patch:\n"++show e+++      "\nYou may want to run 'darcs check' to find out if there are broken"+++      "\npatches in your repo, and perhaps 'darcs repair' to fix them."++instance TolerantMonad m => ApplyMonad Tree (TolerantWrapper m) where++instance TolerantMonad m => ApplyMonadTree (TolerantWrapper m) where+    mDoesDirectoryExist d = runTM $ runDefaultIO $ mDoesDirectoryExist d+    mReadFilePS f = runTM $ runDefaultIO $ mReadFilePS f+    mChangePref a b c = warning $ runDefaultIO $ mChangePref a b c+    mModifyFilePS f j = warning $ runDefaultIO $ mModifyFilePS f (DefaultIO . runIO . j)+    mCreateFile f = warning $ backup f >> runDefaultIO (mCreateFile f)+    mCreateDirectory d = warning $ backup d >> runDefaultIO (mCreateDirectory d)+    mRemoveFile f = warning $ runDefaultIO (mRemoveFile f)+    mRemoveDirectory d = warning $ catch+                                 (runDefaultIO (mRemoveDirectory d))+                                 (\(e :: IOException) ->+                                   if "(Directory not empty)" `isSuffixOf` show e+                                   then ioError $ userError $+                                            "Not deleting " ++ realPath d ++ " because it is not empty."+                                   else ioError $ userError $+                                            "Not deleting " ++ realPath d ++ " because:\n" ++ show e)+    mRename a b = warning $ catch+                          (let do_backup = if map toLower x == map toLower y+                                           then backupByCopying (realPath b) -- avoid making the original vanish+                                           else backupByRenaming (realPath b)+                           in do_backup >> runDefaultIO (mRename a b))+                          (\e -> case () of+                                 _ | isPermissionError e -> ioError $ userError $+                                       couldNotRename ++ "."+                                   | isDoesNotExistError e -> ioError $ userError $+                                       couldNotRename ++ " because " ++ x ++ " does not exist."+                                   | isAlreadyExistsError e -> ioError $ userError $+                                       couldNotRename ++ " because " ++ y ++ " already exists."+                                   | otherwise -> ioError e+                          )+       where+        x = realPath a+        y = realPath b+        couldNotRename = "Could not rename " ++ x ++ " to " ++ y++backup :: AnchoredPath -> IO ()+backup f = backupByRenaming (realPath f)
− src/Darcs/Repository/Cache.hs 
@@ -1,420 +0,0 @@-{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Repository.Cache (-                   cacheHash, okayHash, takeHash,-                   Cache(..), CacheType(..), CacheLoc(..), WritableOrNot(..),-                   HashedDir(..), hashedDir,-                   unionCaches, unionRemoteCaches, cleanCaches, cleanCachesWithHint,-                   fetchFileUsingCache, speculateFileUsingCache, speculateFilesUsingCache,-                   writeFileUsingCache,-                   peekInCache,-                   repo2cache,-                   writable, isthisrepo, hashedFilePath, allHashedDirs, compareByLocality,-                   reportBadSources-                 ) where--import Control.Monad ( liftM, when, guard, unless, filterM, forM_, mplus )-import Data.List ( nub, intercalate )-import Data.Maybe ( catMaybes, listToMaybe, isJust, fromMaybe )-import System.Directory ( removeFile, doesFileExist, doesDirectoryExist,-                          getDirectoryContents, getPermissions )-import qualified System.Directory as SD ( writable )-import System.Posix.Files ( linkCount, getSymbolicLinkStatus )-import System.IO ( hPutStrLn, stderr )--import Crypt.SHA256 ( sha256sum )--import ByteStringUtils ( gzWriteFilePS, linesPS )-import qualified Data.ByteString as B (length, drop, ByteString )-import qualified Data.ByteString.Char8 as BC (unpack)--import SHA1 ( sha1PS )-import System.Posix.Files ( createLink )-import System.FilePath.Posix ( (</>) )-import System.Directory ( createDirectoryIfMissing )--import Darcs.External ( gzFetchFilePS, fetchFilePS, speculateFileOrUrl, copyFileOrUrl,-                        Cachable( Cachable ) )-import Darcs.Flags ( Compression( .. ), RemoteDarcs(..) )-import Darcs.Global ( darcsdir, addBadSource, isBadSource,-                      addReachableSource, isReachableSource,-                      getBadSourcesList )-import Darcs.Lock ( writeAtomicFilePS, gzWriteAtomicFilePS, withTemp )-import Progress ( progressList, debugMessage, debugFail )-import English ( englishNum, Noun(..), Pronoun(..) )-import Darcs.URL ( isFile, isHttpUrl, isSshUrl )-import Darcs.Utils ( withCurrentDirectory, catchall )-import Darcs.SignalHandler ( catchNonSignal )-import qualified URL ( ConnectionError(..) )--data HashedDir = HashedPristineDir | HashedPatchesDir | HashedInventoriesDir-hashedDir :: HashedDir -> String-hashedDir HashedPristineDir = "pristine.hashed"-hashedDir HashedPatchesDir = "patches"-hashedDir HashedInventoriesDir = "inventories"--allHashedDirs :: [HashedDir]-allHashedDirs = [HashedPristineDir, HashedPatchesDir, HashedInventoriesDir]--data WritableOrNot = Writable | NotWritable deriving ( Show )-data CacheType = Repo | Directory deriving ( Eq, Show )-data CacheLoc = Cache { cacheType:: !CacheType, cacheWritable:: !WritableOrNot, cacheSource:: !String }-newtype Cache = Ca [CacheLoc] -- abstract type for hiding cache--instance Eq CacheLoc where-    (Cache Repo _ a) == (Cache Repo _ b) = a == b-    (Cache Directory _ a) == (Cache Directory _ b) = a == b-    _ == _ = False-instance Show CacheLoc where-    show (Cache Repo Writable a) = "thisrepo:" ++ a-    show (Cache Repo NotWritable a) = "repo:" ++ a-    show (Cache Directory Writable a) = "cache:" ++ a-    show (Cache Directory NotWritable a) = "readonly:" ++ a-instance Show Cache where-    show (Ca cs) = unlines $ map show cs--unionCaches :: Cache -> Cache -> Cache-unionCaches (Ca a) (Ca b) = Ca (nub (a++b))---- | unionRemoteCaches merges caches. It tries to do better than just blindly---   copying remote cache entries:------   * If remote repository is accessed through network, do not copy any cache---     entries from it. Taking local entries does not make sense and using---     network entries can lead to darcs hang when it tries to get to---     unaccessible host.------   * If remote repositoty is local, copy all network cache entries. For local---     cache entries if the cache directory exists and is writable it is added---     as writable cache, if it exists but is not writable it is added as---     read-only cache.------   This approach should save us from bogus cache entries. One case it does not---   work very well is when you fetch from partial repository over network.---   Hopefully this is not a common case.-unionRemoteCaches :: Cache -> Cache -> String -> IO (Cache)-unionRemoteCaches local (Ca remote) repourl-    | isFile repourl =  do f <- filtered-                           return $ local `unionCaches` Ca f-    | otherwise = return local-  where filtered = mapM (\x -> fn x `catchall` return Nothing) remote >>=-                   return . catMaybes-        fn :: CacheLoc -> IO (Maybe CacheLoc)-        fn (Cache Repo Writable _) = return Nothing-        fn c@(Cache t _ url)-          | isFile url = do-              ex <- doesDirectoryExist url-              if ex then do p <- getPermissions url-                            return $ Just $-                              if writable c && SD.writable p-                              then c else Cache t NotWritable url-                    else return Nothing-          | otherwise = return $ Just c---- | Compares two caches, a remote cache is greater than a local one.--- The order of the comparison is given by: local < http < ssh-compareByLocality :: CacheLoc -> CacheLoc -> Ordering-compareByLocality (Cache _ _  x) (Cache _ _ y)-  | isLocal x &&  isRemote y  = LT-  | isRemote x && isLocal y = GT-  | isHttpUrl x && isSshUrl y = LT-  | isSshUrl x && isHttpUrl y = GT-  | otherwise = EQ-    where-      isRemote r= isHttpUrl r || isSshUrl r-      isLocal = isFile--repo2cache :: String -> Cache-repo2cache r = Ca [Cache Repo NotWritable r]---- | 'cacheHash' computes the cache hash (i.e. filename) of a packed string.-cacheHash :: B.ByteString -> String-cacheHash ps = case show (B.length ps) of-                 x | l > 10 -> sha256sum ps-                   | otherwise -> replicate (10-l) '0' ++ x ++'-':sha256sum ps-                                        where l = length x--okayHash :: String -> Bool-okayHash s = length s == 40 || length s == 64 || length s == 75--takeHash :: B.ByteString -> Maybe (String, B.ByteString)-takeHash ps = do h <- listToMaybe $ linesPS ps-                 let v = BC.unpack h-                 guard $ okayHash v-                 Just (v, B.drop (B.length h) ps)--checkHash :: String -> B.ByteString -> Bool-checkHash h s | length h == 40 = sha1PS s == h-              | length h == 64 = sha256sum s == h-              | length h == 75 = B.length s == read (take 10 h) && sha256sum s == drop 11 h-              | otherwise = False---- |@fetchFileUsingCache cache dir hash@ receives a list of caches---  @cache@, the directory for which that file belongs @dir@ and the---  @hash@ of the file to fetch.  It tries to fetch the file from one---  of the sources, trying them in order one by one.  If the file---  cannot be fetched from any of the sources, this operation fails.-fetchFileUsingCache :: Cache -> HashedDir -> String -> IO (String, B.ByteString)-fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere--writable :: CacheLoc -> Bool-writable (Cache _ NotWritable _) = False-writable (Cache _ Writable _) = True--isthisrepo :: CacheLoc -> Bool-isthisrepo (Cache Repo Writable _) = True-isthisrepo _ = False---- | @hashedFilePath cachelocation subdir hash@ returns the physical filename of--- hash @hash@ in the @subdir@ section of @cachelocation@.-hashedFilePath :: CacheLoc -> HashedDir -> String -> String-hashedFilePath (Cache Directory _ d) s f = d ++ "/" ++ (hashedDir s) ++ "/" ++ f-hashedFilePath (Cache Repo _ r) s f =-    r ++ "/"++darcsdir++"/" ++ (hashedDir s) ++ "/" ++ f---- | @peekInCache cache subdir hash@ tells whether @cache@ and--- contains an object with hash @hash@ in a writable position.--- Florent: why do we want it to be in a writable position?-peekInCache :: Cache -> HashedDir -> String -> IO Bool-peekInCache (Ca cache) subdir f = cacheHasIt cache `catchall` return False-    where cacheHasIt [] = return False-          cacheHasIt (c:cs) | not $ writable c = cacheHasIt cs-                            | otherwise = do ex <- doesFileExist $ fn c-                                             if ex then return True-                                                   else cacheHasIt cs-          fn c = hashedFilePath c subdir f---- | @speculateFileUsingCache cache subdirectory name@ takes note that--- the file @name@ is likely to be useful soon: pipelined downloads--- will add it to the (low-priority) queue, for the rest it is a noop.-speculateFileUsingCache :: Cache -> HashedDir -> String -> IO ()-speculateFileUsingCache c sd h = do debugMessage $ "Speculating on "++h-                                    copyFileUsingCache OnlySpeculate c sd h---- | Note that the files are likely to be useful soon: pipelined downloads will--- add them to the (low-priority) queue, for the rest it is a noop.-speculateFilesUsingCache :: Cache -> HashedDir -> [String] -> IO ()-speculateFilesUsingCache _ _ [] = return ()-speculateFilesUsingCache cache sd hs =-    do --debugMessage $ "Thinking about speculating on "++unwords hs-       hs' <- filterM (fmap not . peekInCache cache sd) hs-       unless (null hs') $ do debugMessage $ "Speculating on "++unwords hs'-                              copyFilesUsingCache OnlySpeculate cache sd hs'--data OrOnlySpeculate = ActuallyCopy | OnlySpeculate deriving ( Eq )---- | @copyFileUsingCache oos cache subdir f@ copy or hardlinks the---   file @f@ to one of the caches in @cache@,usually the global cache.---   If a writable cache doesn't exist the function will fail.-copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> String -> IO ()-copyFileUsingCache oos (Ca cache) subdir f =-    do debugMessage $ "I'm doing copyFileUsingCache on "++(hashedDir subdir)++"/"++f-       Just stickItHere <- cacheLoc cache-       createDirectoryIfMissing False (reverse $ dropWhile (/='/') $ reverse stickItHere)-       filterBadSources cache >>= (flip sfuc) stickItHere-    `catchall` return ()-    where cacheLoc [] = return Nothing-          cacheLoc (c:cs) | not $ writable c = cacheLoc cs-                          | otherwise =-              do ex <- doesFileExist $ fn c-                 if ex then fail "Bug in darcs: This exception should be caught in speculateFileUsingCache"-                       else do othercache <- cacheLoc cs-                               return $ othercache `mplus` Just (fn c)-          sfuc [] _ = return ()-          sfuc (c:cs) out-            | not (writable c) =-              if oos == OnlySpeculate-               then speculateFileOrUrl (fn c) out `catchNonSignal` (\e -> checkCacheReachability (show e) c)-               else copyFileOrUrl DefaultRemoteDarcs (fn c) out Cachable `catchNonSignal` (\e -> checkCacheReachability (show e) c)-            | otherwise = sfuc cs out-          fn c = hashedFilePath c subdir f--copyFilesUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> [String] -> IO ()-copyFilesUsingCache oos cache subdir hs =-    forM_ hs $ copyFileUsingCache oos cache subdir---data FromWhere = LocalOnly | Anywhere deriving ( Eq )---- | Checks if a given cache entry is reachable or not.--- It receives an error caught during execution and the cache entry.--- If the caches is not reachable it is blacklisted and not longer tried for--- the rest of the session. If it is reachable it is whitelisted and future errors with such--- cache get ignore.--- To determine reachability:---  * For a local cache, if the given source doesn't exist anymore, it is blacklisted.---  * For remote sources if the error is timeout, it is blacklisted, if not,---    it checks if _darcs/hashed_inventory  exist, if it does, the entry is whitelisted, if---    it doesn't, it is blacklisted.-checkCacheReachability :: String -> CacheLoc -> IO ()-checkCacheReachability e cache- | isFile source = do-     reachable <- isReachableSource-     unless (reachable source) $ do-       exist <- doesDirectoryExist source-       if exist-        then-         addReachableSource source-        else-         addBadSource source- | isHttpUrl source = do-     reachable <- isReachableSource-     unless (reachable source) $ do-            let string = case dropWhile (/='(') e of-                          (_:xs) -> fst (break (==')') xs)-                          _      -> e-            let cerror = case reads string ::[(URL.ConnectionError,String)] of-                           [(ce,_)] -> Just ce-                           _        -> Nothing-            if isJust cerror-             then addBadSource source-             else checkFileReachability-- | isSshUrl source = do-   reachable <- isReachableSource-   unless (reachable source) checkFileReachability-- | otherwise = fail $ "unknown transport protocol for: " ++ source- where source = cacheSource cache-       checkFileReachability = do-         reachable <- checkHashedInventoryReachability cache-         if reachable-          then-           addReachableSource source-          else-           addBadSource source---- | Returns a list of reachables cache entries,---   taking out the blacklisted entries-filterBadSources :: [CacheLoc] -> IO [CacheLoc]-filterBadSources cache = do-   badSource <- isBadSource-   return $ filter (not . badSource . cacheSource) cache---- | Checks if the  _darcs/hashed_inventory exist and is reachable-checkHashedInventoryReachability :: CacheLoc -> IO Bool-checkHashedInventoryReachability cache =-     withTemp $ \tempout -> do-       let f = cacheSource cache </> darcsdir </> "hashed_inventory"-       copyFileOrUrl DefaultRemoteDarcs f tempout Cachable-       return True-     `catchNonSignal` (\_ -> return False)--fetchFileUsingCachePrivate :: FromWhere -> Cache -> HashedDir -> String -> IO (String, B.ByteString)-fetchFileUsingCachePrivate fromWhere (Ca cache) subdir f =-    do when (fromWhere == Anywhere) $ copyFileUsingCache ActuallyCopy (Ca cache) subdir f-       filterBadSources cache >>= ffuc-    `catchall` debugFail ("Couldn't fetch `"++f++"'\nin subdir "++ hashedDir subdir ++-                          " from sources:\n\n"++show (Ca cache))-    where ffuc (c:cs)-           | not (writable c) && (Anywhere == fromWhere || isFile (fn c)) =-              do debugMessage $ "In fetchFileUsingCachePrivate I'm going manually"-                 debugMessage $ "    getting "++f-                 debugMessage $ "    from " ++ fn c-                 x <- gzFetchFilePS (fn c) Cachable-                 if not $ checkHash f x-                    then do x' <- fetchFilePS (fn c) Cachable-                            when (not $ checkHash f x') $-                                 do hPutStrLn stderr $ "Hash failure in " ++ fn c-                                    fail $ "Hash failure in " ++ fn c-                            return (fn c, x')-                    else return (fn c, x) -- FIXME: create links in caches-              `catchNonSignal` (\e -> do-                                      checkCacheReachability (show e) c-                                      filterBadSources cs >>= ffuc)---           | writable c =-              do x1 <- gzFetchFilePS (fn c) Cachable-                 x <- if not $ checkHash f x1-                      then do x2 <- fetchFilePS (fn c) Cachable-                              when (not $ checkHash f x2) $-                                 do hPutStrLn stderr $ "Hash failure in " ++ fn c-                                    removeFile $ fn c-                                    fail $ "Hash failure in " ++ fn c-                              return x2-                      else return x1-                 mapM_ (tryLinking (fn c)) cs-                 return (fn c, x)-              `catchNonSignal` (\ e ->-                                 do createCache c subdir `catchall` return () -- don't worry-                                    checkCacheReachability (show e) c-                                    (fname,x) <- filterBadSources cs >>= ffuc-                                    do createLink fname (fn c)-                                       return (fn c, x)-                                     `catchall`-                                      do gzWriteFilePS (fn c) x `catchall` return ()-                                         return (fname,x))-           | otherwise = ffuc cs--          ffuc [] = debugFail $ "No sources from which to fetch file `"++f++"'\n"++ show (Ca cache)--          tryLinking ff c@(Cache Directory Writable d) =-              do createDirectoryIfMissing False (d++"/"++(hashedDir subdir))-                 createLink ff (fn c)-              `catchall` return ()-          tryLinking _ _ = return ()-          fn c = hashedFilePath c subdir f--createCache :: CacheLoc -> HashedDir -> IO ()-createCache (Cache Directory _ d) subdir =-    createDirectoryIfMissing True (d ++ "/" ++ (hashedDir subdir))-createCache _ _ = return ()---- | @write compression filename content@ writes @content@ to the file @filename@ according--- to the policy given by @compression@.-write :: Compression -> String -> B.ByteString -> IO ()-write NoCompression = writeAtomicFilePS-write GzipCompression = gzWriteAtomicFilePS---- | @writeFileUsingCache cache compression subdir contents@ write the string @contents@ to--- the directory subdir, except if it is already in the cache, in which case it is a noop.--- Warning (?) this means that in case of a hash collision, writing using writeFileUsingCache is--- a noop. The returned value is the filename that was given to the string.-writeFileUsingCache :: Cache -> Compression -> HashedDir -> B.ByteString -> IO String-writeFileUsingCache (Ca cache) compr subdir ps =-    (fetchFileUsingCachePrivate LocalOnly (Ca cache) subdir hash >> return hash) `catchall`-    wfuc cache `catchall`-         debugFail ("Couldn't write `"++hash++"'\nin subdir "++(hashedDir subdir)++" to sources:\n\n"++-                    show (Ca cache))-    where hash = cacheHash ps-          wfuc (c:cs) | not $ writable c = wfuc cs-                      | otherwise = do createCache c subdir-                                       write compr (fn c) ps -- FIXME: create links in caches-                                       return hash-          wfuc [] = debugFail $ "No location to write file `" ++ (hashedDir subdir) ++"/"++hash ++ "'"-          fn c = hashedFilePath c subdir hash--cleanCaches :: Cache -> HashedDir -> IO ()-cleanCaches c d = cleanCachesWithHint' c d Nothing--cleanCachesWithHint :: Cache -> HashedDir -> [String] -> IO ()-cleanCachesWithHint c d h = cleanCachesWithHint' c d (Just h)--cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO ()-cleanCachesWithHint' (Ca cs) subdir hint = mapM_ cleanCache cs-    where cleanCache (Cache Directory Writable d) =-             (withCurrentDirectory (d++"/"++(hashedDir subdir)) $-              do fs' <- getDirectoryContents "."-                 let fs = fromMaybe fs' hint-                 mapM_ clean $ progressList ("Cleaning cache "++d++"/"++(hashedDir subdir)) $-                       filter okayHash fs) `catchall` return ()-          cleanCache _ = return ()-          clean f = do lc <- linkCount `liftM` getSymbolicLinkStatus f-                       when (lc < 2) $ removeFile f-                    `catchall` return ()---- | Prints an error message with a list of bad caches.-reportBadSources :: IO ()-reportBadSources = do-  sources <- getBadSourcesList-  let size = length sources-  unless (null sources) $-   hPutStrLn stderr $-    concat [ "\nHINT: I could not reach the following ", englishNum size  (Noun "repository") ":"-           , "\n", (intercalate "\n" (map ("        " ++) sources))-           , "\n      If you're not using ", englishNum size It ", you should probably delete"-           , "\n      the corresponding ", englishNum size (Noun "entry") " from _darcs/prefs/sources."-           ]
+ src/Darcs/Repository/Clone.hs view
@@ -0,0 +1,438 @@+module Darcs.Repository.Clone+    ( cloneRepository+    ) where++import Darcs.Prelude++import Control.Exception ( catch, SomeException )+import Control.Monad ( forM, unless, void, when )+import qualified Data.ByteString.Char8 as BC+import Data.List( intercalate )+import Data.Maybe( catMaybes )+import Safe ( tailErr )+import System.FilePath.Posix ( (</>) )+import System.Directory+    ( removeFile+    , listDirectory+    )++import Darcs.Repository.Create+    ( EmptyRepository(..)+    , createRepository+    )+import Darcs.Repository.Identify ( identifyRepositoryFor, ReadingOrWriting(..) )+import Darcs.Repository.Pristine+    ( applyToTentativePristine+    , createPristineDirectoryTree+    , writePristine+    )+import Darcs.Repository.Hashed+    ( copyHashedInventory+    , readPatches+    , tentativelyRemovePatches+    , writeTentativeInventory+    )+import Darcs.Repository.Transaction+    ( finalizeRepositoryChanges+    , revertRepositoryChanges+    )+import Darcs.Repository.Working+    ( setAllScriptsExecutable+    , setScriptsExecutablePatches )+import Darcs.Repository.InternalTypes+    ( Repository+    , AccessType(..)+    , repoLocation+    , repoFormat+    , repoCache+    , modifyCache+    )+import Darcs.Repository.Job ( withUMaskFlag )+import Darcs.Util.Cache+    ( filterRemoteCaches+    , fetchFileUsingCache+    , speculateFileUsingCache+    , dropNonRepos+    )++import Darcs.Repository.ApplyPatches ( runDefault )+import Darcs.Repository.Inventory+    ( PatchHash+    , encodeValidHash+    , peekPristineHash+    )+import Darcs.Repository.Format+    ( RepoProperty ( HashedInventory, Darcs2, Darcs3 )+    , RepoFormat+    , formatHas+    )+import Darcs.Repository.Prefs ( addRepoSource, deleteSources )+import Darcs.Repository.Match ( getOnePatchset )+import Darcs.Util.File+    ( copyFileOrUrl+    , Cachable(..)+    , gzFetchFilePS+    )+import Darcs.Repository.PatchIndex+    ( doesPatchIndexExist+    , createPIWithInterrupt+    )+import Darcs.Repository.Packs+    ( fetchAndUnpackBasic+    , fetchAndUnpackPatches+    , packsDir+    )+import Darcs.Repository.Paths ( hashedInventoryPath, pristineDirPath )+import Darcs.Repository.Resolution+    ( StandardResolution(..)+    , patchsetConflictResolutions+    , announceConflicts+    )+import Darcs.Repository.Working ( applyToWorking )+import Darcs.Util.Lock ( writeTextFile, withNewDirectory )+import Darcs.Repository.Flags+    ( UpdatePending(..)+    , UseCache(..)+    , RemoteDarcs (..)+    , remoteDarcs+    , CloneKind (..)+    , Verbosity (..)+    , DryRun (..)+    , UMask (..)+    , SetScriptsExecutable (..)+    , SetDefault (..)+    , InheritDefault (..)+    , WithWorkingDir (..)+    , ForgetParent (..)+    , WithPatchIndex (..)+    , PatchFormat (..)+    , AllowConflicts(..)+    , ResolveConflicts(..)+    , WithPrefsTemplates(..)+    )++import Darcs.Patch ( RepoPatch, description )+import Darcs.Patch.Depends ( findUncommon )+import Darcs.Patch.Invertible ( mkInvertible )+import Darcs.Patch.Set+    ( Origin+    , patchSet2FL+    , patchSet2RL+    , patchSetInventoryHashes+    , progressPatchSet+    )+import Darcs.Patch.Match ( MatchFlag(..), patchSetMatch )+import Darcs.Patch.Progress ( progressRLShowTags, progressFL )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Ordered+    ( (:\/:)(..)+    , FL(..)+    , RL(..)+    , lengthFL+    , mapRL+    , lengthRL+    , nullFL+    )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, extractHash )++import Darcs.Util.Tree( Tree, emptyTree )++import Darcs.Util.Exception ( catchall )+import Darcs.Util.English ( englishNum, Noun(..) )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.URL ( isValidLocalPath )+import Darcs.Util.SignalHandler ( catchInterrupt, withSignalsBlocked )+import Darcs.Util.Ssh ( resetSshConnections )+import Darcs.Util.Printer ( Doc, ($$), hsep, putDocLn, text )+import Darcs.Util.Printer.Color ( unsafeRenderStringColored )+import Darcs.Util.Progress+    ( debugMessage+    , tediousSize+    , beginTedious+    , endTedious+    )++joinUrl :: [String] -> String+joinUrl = intercalate "/"++cloneRepository ::+    String    -- origin repository path+    -> String -- new repository name (for relative path)+    -> Verbosity -> UseCache+    -> CloneKind+    -> UMask -> RemoteDarcs+    -> SetScriptsExecutable+    -> SetDefault+    -> InheritDefault+    -> [MatchFlag]+    -> RepoFormat+    -> WithWorkingDir+    -> WithPatchIndex   -- use patch index+    -> Bool   -- use packs+    -> ForgetParent+    -> WithPrefsTemplates+    -> IO ()+cloneRepository repourl mysimplename v useCache cloneKind um rdarcs sse+                setDefault inheritDefault matchFlags rfsource withWorkingDir+                usePatchIndex usePacks forget withPrefsTemplates =+  withUMaskFlag um $ withNewDirectory mysimplename $ do+      let patchfmt+            | formatHas Darcs3 rfsource = PatchFormat3+            | formatHas Darcs2 rfsource = PatchFormat2+            | otherwise                 = PatchFormat1+      EmptyRepository _toRepo <-+        createRepository patchfmt withWorkingDir+          (if cloneKind == LazyClone then NoPatchIndex else usePatchIndex)+          useCache withPrefsTemplates+      debugMessage "Finished initializing new repository."+      addRepoSource repourl NoDryRun setDefault inheritDefault False++      debugMessage "Identifying remote repository..."+      fromRepo <- identifyRepositoryFor Reading _toRepo useCache repourl+      let fromLoc = repoLocation fromRepo++      debugMessage "Copying prefs..."+      copyFileOrUrl (remoteDarcs rdarcs)+        (joinUrl [fromLoc, darcsdir, "prefs", "prefs"])+        (darcsdir </> "prefs/prefs") (MaxAge 600) `catchall` return ()++      debugMessage "Filtering remote sources..."+      cache <- filterRemoteCaches (repoCache fromRepo)+      _toRepo <- return $ modifyCache (const cache) _toRepo+      writeTextFile+        (darcsdir </> "prefs/sources")+        (unlines [show $ dropNonRepos cache])+      debugMessage $ "Considering sources:\n"++show (repoCache _toRepo)++      if formatHas HashedInventory (repoFormat fromRepo) then do+       debugMessage "Copying basic repository (hashed_inventory and pristine)"+       if usePacks && (not . isValidLocalPath) fromLoc+         then copyBasicRepoPacked    fromRepo _toRepo v rdarcs withWorkingDir+         else copyBasicRepoNotPacked fromRepo _toRepo v rdarcs withWorkingDir+       when (cloneKind /= LazyClone) $ do+         when (cloneKind /= CompleteClone) $+           putInfo v $ text "Copying patches, to get lazy repository hit ctrl-C..."+         debugMessage "Copying complete repository (inventories and patches)"+         if usePacks && (not . isValidLocalPath) fromLoc+           then copyCompleteRepoPacked    fromRepo _toRepo v cloneKind+           else copyCompleteRepoNotPacked fromRepo _toRepo v cloneKind+      else+       -- old-fashioned repositories are cloned differently since+       -- we need to copy all patches first and then build pristine+       copyRepoOldFashioned fromRepo _toRepo v withWorkingDir+      when (sse == YesSetScriptsExecutable) setAllScriptsExecutable+      case patchSetMatch matchFlags of+       Nothing -> return ()+       Just psm -> do+        putInfo v $ text "Going to specified version..."+        -- the following is necessary to be able to read _toRepo's patches+        _toRepo <- revertRepositoryChanges _toRepo+        patches <- readPatches _toRepo+        Sealed context <- getOnePatchset _toRepo psm+        to_remove :\/: only_in_context <- return $ findUncommon patches context+        case only_in_context of+          NilFL -> do+            let num_to_remove = lengthFL to_remove+            putInfo v $ hsep $ map text+              [ "Unapplying"+              , show num_to_remove+              , englishNum num_to_remove (Noun "patch") ""+              ]+            _toRepo <-+              tentativelyRemovePatches _toRepo NoUpdatePending to_remove+            _toRepo <- finalizeRepositoryChanges _toRepo NoDryRun+            runDefault (unapply to_remove) `catch` \(e :: SomeException) ->+                fail ("Couldn't undo patch in working tree.\n" ++ show e)+            when (sse == YesSetScriptsExecutable) $ setScriptsExecutablePatches to_remove+          _ ->+            -- This can only happen if the user supplied a context file that+            -- doesn't specify a subset of the remote repo.+            fail $ unsafeRenderStringColored+              $ text "Missing patches from context:"+              $$ description only_in_context+      when (forget == YesForgetParent) deleteSources+      -- check for unresolved conflicts+      patches <- readPatches _toRepo+      let conflicts = patchsetConflictResolutions patches+      _ <- announceConflicts "clone" (YesAllowConflicts MarkConflicts) conflicts+      Sealed mangled_res <- return $ mangled conflicts+      unless (nullFL mangled_res) $+        withSignalsBlocked $ void $ applyToWorking _toRepo v mangled_res++putInfo :: Verbosity -> Doc -> IO ()+putInfo Quiet _ = return ()+putInfo _ d = putDocLn d++putVerbose :: Verbosity -> Doc -> IO ()+putVerbose Verbose d = putDocLn d+putVerbose _ _ = return ()++copyBasicRepoNotPacked  :: forall p wU wR.+                           Repository 'RO p wU wR -- remote+                        -> Repository 'RO p wU wR -- existing empty local+                        -> Verbosity+                        -> RemoteDarcs+                        -> WithWorkingDir+                        -> IO ()+copyBasicRepoNotPacked fromRepo toRepo verb rdarcs withWorkingDir = do+  putVerbose verb $ text "Copying hashed inventory from remote repo..."+  copyHashedInventory toRepo rdarcs (repoLocation fromRepo)+  putVerbose verb $ text "Writing pristine and working tree contents..."+  createPristineDirectoryTree toRepo "." withWorkingDir++copyCompleteRepoNotPacked :: forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)+                        => Repository 'RO p wU wR -- remote+                        -> Repository rt p wU wR -- existing basic local+                        -> Verbosity+                        -> CloneKind+                        -> IO ()+copyCompleteRepoNotPacked _ toRepo verb cloneKind = do+       let cleanup = putInfo verb $ text "Using lazy repository."+       allowCtrlC cloneKind cleanup $ do+         fetchPatchesIfNecessary toRepo+         pi <- doesPatchIndexExist (repoLocation toRepo)+         ps <- readPatches toRepo+         when pi $ createPIWithInterrupt toRepo ps++copyBasicRepoPacked ::+  forall p wU wR.+     Repository 'RO p wU wR -- remote+  -> Repository 'RO p wU wR -- existing empty local repository+  -> Verbosity+  -> RemoteDarcs+  -> WithWorkingDir+  -> IO ()+copyBasicRepoPacked fromRepo toRepo verb rdarcs withWorkingDir =+  do let fromLoc = repoLocation fromRepo+     let hashURL = joinUrl [fromLoc, darcsdir, packsDir, "pristine"]+     mPackHash <- (Just <$> gzFetchFilePS hashURL Uncachable) `catchall` (return Nothing)+     let hiURL = fromLoc </> hashedInventoryPath+     i <- gzFetchFilePS hiURL Uncachable+     let currentHash = BC.pack $ encodeValidHash $ peekPristineHash i+     let copyNormally = copyBasicRepoNotPacked fromRepo toRepo verb rdarcs withWorkingDir+     case mPackHash of+      Just packHash | packHash == currentHash+              -> ( do copyBasicRepoPacked2 fromRepo toRepo verb withWorkingDir+                      -- need to obtain a fresh copy of hashed_inventory as reference+                      putVerbose verb $ text "Copying hashed inventory from remote repo..."+                      copyHashedInventory toRepo rdarcs (repoLocation fromRepo)+                   `catch` \(e :: SomeException) ->+                               do putStrLn ("Exception while getting basic pack:\n" ++ show e)+                                  copyNormally)+      _       -> do putVerbose verb $+                      text "Remote repo has no basic pack or outdated basic pack, copying normally."+                    copyNormally++copyBasicRepoPacked2 ::+  forall rt p wU wR.+     Repository 'RO p wU wR -- remote+  -> Repository rt p wU wR -- existing empty local repository+  -> Verbosity+  -> WithWorkingDir+  -> IO ()+copyBasicRepoPacked2 fromRepo toRepo verb withWorkingDir = do+  putVerbose verb $ text "Cloning packed basic repository."+  -- unpack inventory & pristine cache+  cleanDir pristineDirPath+  removeFile hashedInventoryPath+  fetchAndUnpackBasic (repoCache toRepo) (repoLocation fromRepo)+  putInfo verb $ text "Done fetching and unpacking basic pack."+  createPristineDirectoryTree toRepo "." withWorkingDir++copyCompleteRepoPacked ::+  forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)+  => Repository 'RO p wU wR -- remote+  -> Repository rt p wU wR -- existing basic local repository+  -> Verbosity+  -> CloneKind+  -> IO ()+copyCompleteRepoPacked from to verb cloneKind =+    copyCompleteRepoPacked2 from to verb cloneKind+  `catch`+    \(e :: SomeException) -> do+      putStrLn ("Exception while getting patches pack:\n" ++ show e)+      putVerbose verb $ text "Problem while copying patches pack, copying normally."+      copyCompleteRepoNotPacked from to verb cloneKind++copyCompleteRepoPacked2 ::+  forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)+  => Repository 'RO p wU wR+  -> Repository rt p wU wR+  -> Verbosity+  -> CloneKind+  -> IO ()+copyCompleteRepoPacked2 fromRepo toRepo verb cloneKind = do+  us <- readPatches toRepo+  -- get old patches+  let cleanup = putInfo verb $ text "Using lazy repository."+  allowCtrlC cloneKind cleanup $ do+    putVerbose verb $ text "Using patches pack."+    is <-+      forM (patchSetInventoryHashes us) $+        maybe (fail "unexpected unhashed inventory") return+    hs <-+      forM (mapRL hashedPatchHash $ patchSet2RL us) $+        maybe (fail "unexpected unhashed patch") return+    fetchAndUnpackPatches is hs (repoCache toRepo) (repoLocation fromRepo)+    pi <- doesPatchIndexExist (repoLocation toRepo)+    when pi $ createPIWithInterrupt toRepo us -- TODO or do another readPatches?++cleanDir :: FilePath -> IO ()+cleanDir d = mapM_ (\x -> removeFile $ d </> x) =<< listDirectory d++copyRepoOldFashioned :: forall p wU wR. (RepoPatch p, ApplyState p ~ Tree)+                        => Repository 'RO p wU wR  -- remote repo+                        -> Repository 'RO p Origin Origin -- local empty repo+                        -> Verbosity+                        -> WithWorkingDir+                        -> IO ()+copyRepoOldFashioned fromRepo _toRepo verb withWorkingDir = do+  _toRepo <- revertRepositoryChanges _toRepo+  _ <- writePristine _toRepo emptyTree+  patches <- readPatches fromRepo+  let k = "Copying patch"+  beginTedious k+  tediousSize k (lengthRL $ patchSet2RL patches)+  let patches' = progressPatchSet k patches+  writeTentativeInventory _toRepo patches'+  endTedious k+  local_patches <- readPatches _toRepo+  let patchesToApply = progressFL "Applying patch" $ patchSet2FL local_patches+  applyToTentativePristine _toRepo (mkInvertible patchesToApply)+  _toRepo <- finalizeRepositoryChanges _toRepo NoDryRun+  putVerbose verb $ text "Writing the working tree..."+  createPristineDirectoryTree _toRepo "." withWorkingDir++-- | This function fetches all patches that the given repository has+--   with fetchFileUsingCache.+fetchPatchesIfNecessary :: forall rt p wU wR. RepoPatch p+                        => Repository rt p wU wR+                        -> IO ()+fetchPatchesIfNecessary toRepo =+  do  ps <- readPatches toRepo+      let patches = patchSet2RL ps+          ppatches = progressRLShowTags "Copying patches" patches+          (first, other) = splitAt (100 - 1) $ tailErr $ hashes patches+          speculate = [] : first : map (:[]) other+      mapM_ fetchAndSpeculate $ zip (hashes ppatches) (speculate ++ repeat [])+  where hashes :: forall wX wY . RL (PatchInfoAnd p) wX wY -> [PatchHash]+        hashes = catMaybes . mapRL hashedPatchHash+        fetchAndSpeculate :: (PatchHash, [PatchHash]) -> IO ()+        fetchAndSpeculate (f, ss) = do+          _ <- fetchFileUsingCache c f+          mapM_ (speculateFileUsingCache c) ss+        c = repoCache toRepo++allowCtrlC :: CloneKind -> IO () -> IO () -> IO ()+allowCtrlC CompleteClone _ action = action+allowCtrlC _ cleanup action =+  action `catchInterrupt` do+    debugMessage "Cleanup after SIGINT in allowCtrlC"+    -- the SIGINT has also killed our running ssh connections,+    -- this will cause them to be restarted+    resetSshConnections+    cleanup++hashedPatchHash :: PatchInfoAnd p wA wB -> Maybe PatchHash+hashedPatchHash = either (const Nothing) Just . extractHash
+ src/Darcs/Repository/Create.hs view
@@ -0,0 +1,165 @@+module Darcs.Repository.Create+    ( createRepository+    , createRepositoryV1+    , createRepositoryV2+    , EmptyRepository(..)+    ) where++import Darcs.Prelude++import Control.Monad ( when )+import qualified Data.ByteString as B+import Data.Maybe( isJust )+import System.Directory+    ( createDirectory+    , getCurrentDirectory+    , setCurrentDirectory+    )+import System.IO.Error+    ( catchIOError+    , isAlreadyExistsError+    )++import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Set ( Origin, emptyPatchSet )+import Darcs.Patch.V1 ( RepoPatchV1 )+import Darcs.Patch.V2 ( RepoPatchV2 )+import Darcs.Patch.V3 ( RepoPatchV3 )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )++import Darcs.Util.Cache ( Cache )+import Darcs.Repository.Format+    ( RepoFormat+    , createRepoFormat+    , unsafeWriteRepoFormat+    )+import Darcs.Repository.Flags+    ( PatchFormat(..)+    , UseCache(..)+    , WithPatchIndex(..)+    , WithPrefsTemplates(..)+    , WithWorkingDir(..)+    )+import Darcs.Repository.Paths+    ( pristineDirPath+    , patchesDirPath+    , inventoriesDirPath+    , hashedInventoryPath+    , formatPath+    )+import Darcs.Repository.Identify ( seekRepo )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , PristineType(..)+    , Repository+    , mkRepo+    )+import Darcs.Repository.PatchIndex ( createOrUpdatePatchIndexDisk )+import Darcs.Repository.Prefs+    ( writeDefaultPrefs+    , getCaches+    , prefsDirPath+    )+import Darcs.Repository.Pristine ( writePristine )++import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Lock ( writeBinFile )+import Darcs.Util.Path ( AbsoluteOrRemotePath, ioAbsoluteOrRemote )+import Darcs.Util.Tree( Tree, emptyTree )++createRepositoryFiles :: PatchFormat -> WithWorkingDir -> WithPrefsTemplates -> IO RepoFormat+createRepositoryFiles patchfmt withWorkingDir withPrefsTemplates = do+  cwd <- getCurrentDirectory+  x <- seekRepo+  when (isJust x) $ do+      setCurrentDirectory cwd+      putStrLn "WARNING: creating a nested repository."+  createDirectory darcsdir `catchIOError`+      (\e-> if isAlreadyExistsError e+            then fail "Tree has already been initialized!"+            else fail $ "Error creating directory `"++darcsdir++"'.")+  createDirectory pristineDirPath+  createDirectory patchesDirPath+  createDirectory inventoriesDirPath+  createDirectory prefsDirPath+  writeDefaultPrefs withPrefsTemplates+  let repo_format = createRepoFormat patchfmt withWorkingDir+  unsafeWriteRepoFormat repo_format formatPath+  -- note: all repos we create nowadays are hashed+  writeBinFile hashedInventoryPath B.empty+  return repo_format++data EmptyRepository where+  EmptyRepository :: (RepoPatch p, ApplyState p ~ Tree)+                  => Repository 'RO p Origin Origin+                  -> EmptyRepository++createRepository :: PatchFormat -> WithWorkingDir -> WithPatchIndex -> UseCache -> WithPrefsTemplates+                 -> IO EmptyRepository+createRepository patchfmt withWorkingDir withPatchIndex useCache withPrefsTemplates = do+  rfmt <- createRepositoryFiles patchfmt withWorkingDir withPrefsTemplates+  rdir <- ioAbsoluteOrRemote here+  cache <- getCaches useCache Nothing+  repo@(EmptyRepository r) <- case patchfmt of+    PatchFormat1 -> return $ EmptyRepository $ mkRepoV1 rdir rfmt cache+    PatchFormat2 -> return $ EmptyRepository $ mkRepoV2 rdir rfmt cache+    PatchFormat3 -> return $ EmptyRepository $ mkRepoV3 rdir rfmt cache+  _ <- writePristine r emptyTree+  maybeCreatePatchIndex withPatchIndex r+  return repo++mkRepoV1+  :: AbsoluteOrRemotePath+  -> RepoFormat+  -> Cache+  -> Repository 'RO (RepoPatchV1 V1.Prim) Origin Origin+mkRepoV1 rdir repofmt cache = mkRepo rdir repofmt HashedPristine cache++mkRepoV2+  :: AbsoluteOrRemotePath+  -> RepoFormat+  -> Cache+  -> Repository 'RO (RepoPatchV2 V2.Prim) Origin Origin+mkRepoV2 rdir repofmt cache = mkRepo rdir repofmt HashedPristine cache++mkRepoV3+  :: AbsoluteOrRemotePath+  -> RepoFormat+  -> Cache+  -> Repository 'RO (RepoPatchV3 V2.Prim) Origin Origin+mkRepoV3 rdir repofmt cache = mkRepo rdir repofmt HashedPristine cache++createRepositoryV1+  :: WithWorkingDir -> WithPatchIndex -> UseCache -> WithPrefsTemplates+  -> IO (Repository 'RO (RepoPatchV1 V1.Prim) Origin Origin)+createRepositoryV1 withWorkingDir withPatchIndex useCache withPrefsTemplates = do+  rfmt <- createRepositoryFiles PatchFormat1 withWorkingDir withPrefsTemplates+  rdir <- ioAbsoluteOrRemote here+  cache <- getCaches useCache Nothing+  let repo = mkRepoV1 rdir rfmt cache+  _ <- writePristine repo emptyTree+  maybeCreatePatchIndex withPatchIndex repo+  return repo++createRepositoryV2+  :: WithWorkingDir -> WithPatchIndex -> UseCache -> WithPrefsTemplates+  -> IO (Repository 'RO (RepoPatchV2 V2.Prim) Origin Origin)+createRepositoryV2 withWorkingDir withPatchIndex useCache withPrefsTemplates = do+  rfmt <- createRepositoryFiles PatchFormat2 withWorkingDir withPrefsTemplates+  rdir <- ioAbsoluteOrRemote here+  cache <- getCaches useCache Nothing+  let repo = mkRepoV2 rdir rfmt cache+  _ <- writePristine repo emptyTree+  maybeCreatePatchIndex withPatchIndex repo+  return repo++maybeCreatePatchIndex :: (RepoPatch p, ApplyState p ~ Tree)+                      => WithPatchIndex -> Repository 'RO p wU Origin -> IO ()+maybeCreatePatchIndex NoPatchIndex _ = return ()+maybeCreatePatchIndex YesPatchIndex repo =+  createOrUpdatePatchIndexDisk repo emptyPatchSet++here :: String+here = "."
+ src/Darcs/Repository/Diff.hs view
@@ -0,0 +1,188 @@+-- Copyright (C) 2009 Petr Rockai+--+-- 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+-- SOFTWARE.++-- |+-- Module      : Darcs.Repository.Diff+-- Copyright   : 2009 Petr Rockai+-- License     : MIT+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.Repository.Diff+    (+      treeDiff+    ) where++import Darcs.Prelude++import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++import Data.List ( sortBy )++import Darcs.Util.Tree      ( diffTrees+                            , zipTrees+                            , TreeItem(..)+                            , Tree+                            , readBlob+                            , emptyBlob+                            )+import Darcs.Util.Path( AnchoredPath, anchorPath )+++import Darcs.Util.ByteString ( isFunky )+import Darcs.Patch  ( PrimPatch+                    , hunk+                    , canonizeFL+                    , binary+                    , addfile+                    , rmfile+                    , adddir+                    , rmdir+                    , invert+                    )+import Darcs.Repository.Prefs ( FileType(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), concatGapsFL, consGapFL )+import Darcs.Patch.Witnesses.Sealed ( Gap(..) )+import Darcs.Repository.Flags ( DiffAlgorithm(..) )++data Diff m = Added (TreeItem m)+            | Removed (TreeItem m)+            | Changed (TreeItem m) (TreeItem m)+++getDiff :: AnchoredPath+        -> Maybe (TreeItem m)+        -> Maybe (TreeItem m)+        -> (AnchoredPath, Diff m)+getDiff p Nothing (Just t) = (p, Added t)+getDiff p (Just from) (Just to) = (p, Changed from to)+getDiff p (Just t) Nothing = (p, Removed t)+getDiff _ Nothing Nothing = error "impossible case" -- zipTrees should never return this+++treeDiff :: forall m w prim . (Monad m, Gap w, PrimPatch prim)+         => DiffAlgorithm+         -> (FilePath -> FileType)+         -> Tree m+         -> Tree m+         -> m (w (FL prim))+treeDiff da ft t1 t2 = do+    (from, to) <- diffTrees t1 t2+    diffs <- mapM (uncurry diff) $ sortBy organise $ zipTrees getDiff from to+    return $ concatGapsFL diffs+  where+    -- sort into removes, changes, adds, with removes in reverse-path order+    -- and everything else in forward order+    organise :: (AnchoredPath, Diff m) -> (AnchoredPath, Diff m) -> Ordering++    organise (p1, Changed _ _ ) (p2, Changed _ _) = compare p1 p2+    organise (p1, Added _)      (p2, Added _)   = compare p1 p2+    organise (p1, Removed _)    (p2, Removed _) = compare p2 p1++    organise (_, Removed _) _ = LT+    organise _ (_, Removed _) = GT++    organise (_, Changed _ _) _ = LT+    organise _ (_, Changed _ _) = GT++    diff :: AnchoredPath -> Diff m -> m (w (FL prim))+    diff _ (Changed (SubTree _) (SubTree _)) = return (emptyGap NilFL)+    diff p (Removed (SubTree _)) =+        -- Note: With files we first make the file empty before removing it.+        -- But for subtrees this has already been done in previous recursive calls.+        return $ freeGap (rmdir p :>: NilFL)+    diff p (Added (SubTree _)) =+        return $ freeGap (adddir p :>: NilFL)+    diff p (Added b'@(File _)) =+        do diff' <- diff p (Changed (File emptyBlob) b')+           return $ consGapFL (addfile p) diff'+    diff p (Removed a'@(File _)) =+        do diff' <- diff p (Changed a' (File emptyBlob))+           return $ joinGap (+>+) diff' (freeGap (rmfile p :>: NilFL))+    diff p (Changed (File a') (File b')) =+        do a <- readBlob a'+           b <- readBlob b'+           case ft (anchorPath "" p) of+             TextFile | no_bin a && no_bin b ->+                          return $ text_diff p a b+             _ -> return $ if a /= b+                              then freeGap (binary p (strict a) (strict b) :>: NilFL)+                              else emptyGap NilFL+    diff p (Changed a'@(File _) subtree@(SubTree _)) =+        do rmFileP <- diff p (Removed a')+           addDirP <- diff p (Added subtree)+           return $ joinGap (+>+) rmFileP addDirP+    diff p (Changed subtree@(SubTree _) b'@(File _)) =+        do rmDirP <- diff p (Removed subtree)+           addFileP <- diff p (Added b')+           return $ joinGap (+>+) rmDirP addFileP+    diff p _ = error $ "Missing case at path " ++ show (anchorPath "" p)++    text_diff p a b+        | BL.null a && BL.null b = emptyGap NilFL+        | BL.null a = freeGap (diff_from_empty p b)+        | BL.null b = freeGap (diff_to_empty p a)++        -- What is 'a line'? One view is that a line is something that is+        -- /terminated/ by either a newline or end of file. Another view is+        -- that lines are /separated/ by newline symbols.+        --+        -- The first view is the more "intuitive" one. The second is more+        -- "technical", it has the simpler definition and the highly desirable+        -- property that splitting a text into lines and joining them with+        -- newline symbols are inverse operations. The last point is the reason+        -- we never use the standard versions of 'unlines' for ByteString+        -- anywhere in darcs.+        --+        -- The two views differ mostly when enumerating the lines of a file+        -- that ends with a newline symbol: here, the technical view counts one+        -- more (empty) line. This leads to un-intuitive (though technically+        -- not incorrect) results when calculating the diff for a change that+        -- appends an empty line to a file that already has a newline at the+        -- end. For instance, for a file with a single, newline-terminated line+        -- of text, the LCS algorithm would tell us that a *third* (empty) line+        -- is being added.+        --+        -- To avoid this, we add a special case here: we strip off common+        -- newline symbols at the end. When we later split the result into+        -- lines for the diff algorithm, it never gets to see the empty+        -- last lines in both files and thus gives us the more intuitive result.++        | BLC.last a == '\n' && BLC.last b == '\n'+                    = freeGap (line_diff p (linesB $ BLC.init a) (linesB $ BLC.init b))+        | otherwise = freeGap (line_diff p (linesB a) (linesB b))++    line_diff p a b = canonizeFL da (hunk p 1 a b :>: NilFL)++    diff_to_empty p x | BLC.last x == '\n' = line_diff p (init $ linesB x) []+                      | otherwise = line_diff p (linesB x) [B.empty]++    diff_from_empty p x = invert (diff_to_empty p x)++    no_bin = not . isFunky . strict . BL.take 4096++    linesB = map strict . BLC.split '\n'++    strict = B.concat . BL.toChunks
+ src/Darcs/Repository/Flags.hs view
@@ -0,0 +1,133 @@+module Darcs.Repository.Flags+    ( RemoteDarcs (..)+    , remoteDarcs+    , Reorder (..)+    , Verbosity (..)+    , UpdatePending (..)+    , UseCache (..)+    , DryRun (..)+    , UMask (..)+    , LookForAdds (..)+    , LookForReplaces (..)+    , DiffAlgorithm (..)+    , LookForMoves (..)+    , DiffOpts (..)+    , RunTest (..)+    , SetScriptsExecutable (..)+    , LeaveTestDir (..)+    , SetDefault (..)+    , InheritDefault (..)+    , UseIndex (..)+    , CloneKind (..)+    , AllowConflicts (..)+    , ResolveConflicts (..)+    , WorkRepo (..)+    , WantGuiPause (..)+    , WithPatchIndex (..)+    , WithWorkingDir (..)+    , ForgetParent (..)+    , PatchFormat (..)+    , WithPrefsTemplates (..)+    , OptimizeDeep (..)+    ) where++import Darcs.Prelude++import Darcs.Util.Diff ( DiffAlgorithm(..) )+import Darcs.Util.Global ( defaultRemoteDarcsCmd )++data Verbosity = Quiet | NormalVerbosity | Verbose+    deriving ( Eq, Show )++data WithPatchIndex = YesPatchIndex | NoPatchIndex+    deriving ( Eq, Show )++data RemoteDarcs = RemoteDarcs String+                 | DefaultRemoteDarcs+    deriving ( Eq, Show )++remoteDarcs :: RemoteDarcs -> String+remoteDarcs DefaultRemoteDarcs = defaultRemoteDarcsCmd+remoteDarcs (RemoteDarcs x) = x++data Reorder = NoReorder | Reorder+    deriving ( Eq )++data UpdatePending = YesUpdatePending | NoUpdatePending+    deriving ( Eq, Show )++data UseCache = YesUseCache | NoUseCache+    deriving ( Eq, Show )++data DryRun = YesDryRun | NoDryRun+    deriving ( Eq, Show )++data UMask = YesUMask String | NoUMask+    deriving ( Eq, Show )++data LookForAdds = NoLookForAdds | YesLookForAdds | EvenLookForBoring+    deriving ( Eq, Show )++data LookForReplaces = YesLookForReplaces | NoLookForReplaces+    deriving ( Eq, Show )++data LookForMoves = YesLookForMoves | NoLookForMoves+    deriving ( Eq, Show )++data DiffOpts = DiffOpts+  { withIndex :: UseIndex+  , lookForAdds :: LookForAdds+  , lookForReplaces :: LookForReplaces+  , lookForMoves :: LookForMoves+  , diffAlg :: DiffAlgorithm+  } deriving Show++data RunTest = YesRunTest | NoRunTest+    deriving ( Eq, Show )++data SetScriptsExecutable = YesSetScriptsExecutable | NoSetScriptsExecutable+    deriving ( Eq, Show )++data LeaveTestDir = YesLeaveTestDir | NoLeaveTestDir+    deriving ( Eq, Show )++data SetDefault = YesSetDefault Bool | NoSetDefault Bool+    deriving ( Eq, Show )++data InheritDefault = YesInheritDefault | NoInheritDefault+    deriving ( Eq, Show )++data UseIndex = UseIndex | IgnoreIndex deriving ( Eq, Show )++-- Various kinds of getting repositories+data CloneKind = LazyClone       -- ^Just copy pristine and inventories+               | NormalClone     -- ^First do a lazy clone then copy everything+               | CompleteClone   -- ^Same as Normal but omit telling user they can interrumpt+    deriving ( Eq, Show )++data AllowConflicts = NoAllowConflicts | YesAllowConflicts ResolveConflicts+    deriving ( Eq, Show )++data ResolveConflicts = NoResolveConflicts | MarkConflicts | ExternalMerge String+    deriving ( Eq, Show )++data WorkRepo = WorkRepoDir String | WorkRepoPossibleURL String | WorkRepoCurrentDir+    deriving ( Eq, Show )++data WantGuiPause = YesWantGuiPause | NoWantGuiPause+    deriving ( Eq, Show )++data WithWorkingDir = WithWorkingDir | NoWorkingDir+    deriving ( Eq, Show )++data ForgetParent = YesForgetParent | NoForgetParent+    deriving ( Eq, Show )++data PatchFormat = PatchFormat1 | PatchFormat2 | PatchFormat3+    deriving ( Eq, Show )++data WithPrefsTemplates =  WithPrefsTemplates | NoPrefsTemplates+    deriving ( Eq, Show )++data OptimizeDeep = OptimizeShallow | OptimizeDeep+    deriving ( Eq, Show )
src/Darcs/Repository/Format.hs view
@@ -2,161 +2,296 @@ -- -- This file is licensed under the GPL, version two or later. -{-# LANGUAGE CPP #-}+{- | The format file. -module Darcs.Repository.Format ( RepoFormat(..), RepoProperty(..),-                    identifyRepoFormat, tryIdentifyRepoFormat,-                    createRepoFormat, writeRepoFormat,-                    writeProblem, readProblem, readfromAndWritetoProblem,-                    formatHas,-                  ) where+The purpose of the format file is to check compatibility between+repositories in different formats and to allow the addition of new features+without risking corruption by old darcs versions that do not yet know about+these features. -import Data.Maybe ( isJust, mapMaybe )-import Control.Monad ( mplus, (<=<) )+This allows a limited form of forward compatibility between darcs versions.+Old versions of darcs that are unaware of features added in later versions+will fail with a decent error message instead of crashing or misbehaving or+even corrupting new repos. -import Darcs.SignalHandler ( catchNonSignal )-import Darcs.External ( fetchFilePS, Cachable( Cachable ) )-import Darcs.Flags ( DarcsFlag ( UseFormat2, UseHashedInventory, UseNoWorkingDir ) )-import Darcs.Lock ( writeBinFile )-import Darcs.Utils ( catchall, prettyException )-import Progress ( beginTedious, endTedious, finishedOneIO )-import Darcs.Global ( darcsdir )+The format file lives at _darcs/format and must only contain printable ASCII+characters and must not contain the characters @<@ and @>@. -import ByteStringUtils ( linesPS )-import qualified Data.ByteString.Char8 as BC (split, unpack, singleton, elemIndex, pack)-import qualified Data.ByteString       as B (ByteString, null, empty)-import qualified ByteStringUtils       as BU ( intercalate )+(We currently do not strip whitespace from the lines, but may want to do so+in the future.) -#include "impossible.h"+The file consists of format properties. A format property can contain any+allowed ASCII character except the vertical bar (@|@) and newlines. Empty+lines are ignored and multiple properties on the same line are separated+with a @|@. -data RepoProperty = Darcs1_0 | Darcs2 | HashedInventory | NoWorkingDir+If multiple properties appear on the same line (separated by vertical bars),+then this indicates alternative format properties. These have a generic+meaning: --- | @RepoFormat@ is the representation of the format of a--- repository. Each sublist corresponds to a line in the format--- file. Each line is decomposed into words.-newtype RepoFormat = RF [[B.ByteString]] deriving ( Show )+ * If we know *any* of these properties, then we can read the repo. --- | The file where the format information should be.-df :: FilePath-df = darcsdir++"/format"+ * If we know *all* of them, we can also write the repo. --- | @identifyRepoFormat URL@ identifies the format of the repository--- at the given address. Fails if we weren't able to identify the format.-identifyRepoFormat :: String -> IO RepoFormat-identifyRepoFormat = either fail return <=< tryIdentifyRepoFormat+The above rules are necessary conditions, not sufficient ones. It is allowed+to further restrict read and/or write access for specific commands, but care+should be taken to not unnecessarily break forward compatibility. It is not+recommended, but sometimes necessary, to impose ad-hoc restrictions on the+format, see 'transferProblem' and 'readProblem' for examples. --- | @tryIdentifyRepoFormat URL@ identifies the format of the repository--- at the given address. Return @Left reason@ if it fails, where--- @reason@ explains why we weren't able to identify the format.-tryIdentifyRepoFormat :: String -> IO (Either String RepoFormat)-tryIdentifyRepoFormat repo =- do let k = "Identifying repository "++repo-    beginTedious k-    finishedOneIO k "format"-    dff <- fetchFilePS (repo ++ "/" ++ df) Cachable `catchall` return B.empty-    -- below is a workaround for servers that don't return a 404 on nonexistent files-    rf <- if B.null dff || isJust (BC.elemIndex '<' dff)-          then do finishedOneIO k "inventory"-                  have_inventory <- doesRemoteFileExist (repo++"/"++darcsdir++"/inventory")-                  return $-                    case have_inventory of-                        Right _ -> Right defaultRepoFormat-                        Left e -> Left . unlines $-                                    [ "Not a repository: "++repo++" ("++e++")"-                                    , ""-                                    , "HINT: Do you have the right URI for the repository?"-                                    , ""-                                    , "      If so, check with the repository owner to see if the following files"-                                    , "      are readable:"-                                    , ""-                                    , "        1. _darcs/format    - might not exist; that's OK"-                                    , "        2. _darcs/inventory - should exist if #1 is missing"-                                    , "        3. _darcs/hashed_inventory - should exist if #2 is missing"-                                    ]-          else return $ Right $ parseRepoFormat dff-    endTedious k-    return rf-    where drfe x = fetchFilePS x Cachable >> return True-          doesRemoteFileExist x = fmap Right (drfe x) `catchNonSignal`-                                  (\e -> return (Left (prettyException e)))+The no-working-dir property is an example for how to use alternative+properties. An old darcs version that does not know this format can perform+most read-only operations correctly even if there is no working tree;+however, whatsnew will report that the whole tree was removed, so the+solution is not perfect. --- | @writeRepoFormat@ writes the repo format to the given file.-writeRepoFormat :: RepoFormat -> FilePath -> IO ()-writeRepoFormat (RF rf) loc = writeBinFile loc $ unlines $-                              map (BC.unpack . BU.intercalate (BC.singleton '|')) rf+When you add a new property as an alternative to an existing one, you should+make sure that the old format remains to be updated in parallel to the new+one, so that reading the repo with old darcs versions behaves correctly. If+this cannot be guaranteed, it is better to add the new format on a separate+line. -parseRepoFormat :: B.ByteString -> RepoFormat-parseRepoFormat ps =-    RF $ map (BC.split '|') $ filter (not . B.null) $ linesPS ps+It is not advisable for commands to modify an existing format file. However,+sometimes compatibility requirements may leave us no other choice. In this+case make sure to write the format file only after having checked that the+existing repo format allows modification of the repo, and that you have+taken the repo lock. --- | The repo format we assume if we do not find a format file.-defaultRepoFormat :: RepoFormat-defaultRepoFormat = RF [[rp2ps Darcs1_0]]+-} -createRepoFormat :: [DarcsFlag] -> RepoFormat-createRepoFormat fs = RF (map rp2ps (HashedInventory:flags2wd): maybe2)-    where maybe2 = if UseFormat2 `notElem` fs && (UseHashedInventory `elem` fs)-                   then []-                   else [[rp2ps Darcs2]]-          flags2wd = if UseNoWorkingDir `elem` fs-                      then [NoWorkingDir]-                      else []+{-# LANGUAGE OverloadedStrings #-}+module Darcs.Repository.Format+    ( RepoFormat(..)+    , RepoProperty(..)+    , identifyRepoFormat+    , tryIdentifyRepoFormat+    , createRepoFormat+    , unsafeWriteRepoFormat+    , writeProblem+    , readProblem+    , transferProblem+    , formatHas+    , addToFormat+    , removeFromFormat+    ) where --- | @writeProblem form@ tells if we can write to a repo in format @form@.--- It returns @Nothing@ if there's no problem writing to such a repository.-writeProblem :: RepoFormat -> Maybe String-writeProblem rf = readProblem rf `mplus` allProblems rf wp-    where wp x | all isKnown x = Nothing-          wp [] = impossible-          wp x = Just $ unwords $ "Can't write repository format: " :-                 map BC.unpack (filter (not . isKnown) x)+import Darcs.Prelude +import Control.Exception ( try )+import Control.Monad ( mplus, (<=<) )+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString  as B+import Data.List ( partition, intercalate, (\\) )+import Data.Maybe ( mapMaybe )+import Data.String ( IsString )+import System.FilePath.Posix( (</>) ) --- | @readfromAndWritetoProblem form@ tells if we can read from and write to a repo in--- format @form@. It returns @Nothing@ if there's no problem reading--- and writing to such a repository.-readfromAndWritetoProblem :: RepoFormat -> RepoFormat -> Maybe String-readfromAndWritetoProblem inrf outrf-    | formatHas Darcs2 inrf /= formatHas Darcs2 outrf-        = Just "Cannot mix darcs-2 repositories with older formats"-    | otherwise = readProblem inrf `mplus` writeProblem outrf+import Darcs.Util.File+    ( fetchFilePS+    , Cachable( Cachable )+    )+import Darcs.Util.Lock ( writeBinFile )+import qualified Darcs.Repository.Flags as F+    ( WithWorkingDir (..), PatchFormat (..)  )+import Darcs.Repository.Paths ( formatPath, oldInventoryPath )+import Darcs.Util.Exception ( prettyException ) +import Darcs.Util.ByteString ( linesPS ) --- | @readProblem form@ tells if we can read from a repo in format @form@.--- It returns @Nothing@ if there's no problem reading from such a repository.-readProblem :: RepoFormat -> Maybe String-readProblem rf | formatHas Darcs1_0 rf && formatHas Darcs2 rf-                    = Just "Invalid repositoryformat:  format 2 is incompatible with format 1"-readProblem rf = allProblems rf rp-    where rp x | any isKnown x = Nothing-          rp [] = impossible-          rp x = Just $ unwords $-                 "Can't understand repository format:" : map BC.unpack x+data RepoProperty = Darcs1+                  | Darcs2+                  | Darcs3+                  | HashedInventory+                  | NoWorkingDir+                  | RebaseInProgress+                  | RebaseInProgress_2_16+                  | UnknownFormat B.ByteString+                  deriving ( Eq ) +-- | Define string constants in one place, for reuse in show/parse functions.+darcs1Format, darcs2Format, darcs3Format,+  hashedInventoryFormat, noWorkingDirFormat,+  rebaseInProgressFormat, rebaseInProgress_2_16,+  newStyleRebaseInProgress :: IsString s => s -allProblems :: RepoFormat -> ([B.ByteString] -> Maybe String) -> Maybe String-allProblems (RF ks) repoFormatLineProblem = maybeSingleError $ mapMaybe repoFormatLineProblem ks-    where-        maybeSingleError [] = Nothing-        maybeSingleError xs = Just $ unlines xs+darcs1Format = "darcs-1.0"+darcs2Format = "darcs-2"+darcs3Format = "darcs-3"+hashedInventoryFormat = "hashed"+noWorkingDirFormat = "no-working-dir"+rebaseInProgressFormat = "rebase-in-progress"+rebaseInProgress_2_16 = "rebase-in-progress-2-16"+-- compatibility alias, may want to remove this at some point in the future+newStyleRebaseInProgress = "new-style-rebase-in-progress" +instance Show RepoProperty where+    show Darcs1 = darcs1Format+    show Darcs2 = darcs2Format+    show Darcs3 = darcs3Format+    show HashedInventory = hashedInventoryFormat+    show NoWorkingDir = noWorkingDirFormat+    show RebaseInProgress = rebaseInProgressFormat+    show RebaseInProgress_2_16 = rebaseInProgress_2_16+    show (UnknownFormat f) = BC.unpack f --- | Does this version of darcs know how to handle this property?-isKnown :: B.ByteString -> Bool-isKnown p = p `elem` map rp2ps knownProperties+readRepoProperty :: B.ByteString -> RepoProperty+readRepoProperty input+    | input == darcs1Format = Darcs1+    | input == darcs2Format = Darcs2+    | input == darcs3Format = Darcs3+    | input == hashedInventoryFormat = HashedInventory+    | input == noWorkingDirFormat = NoWorkingDir+    | input == rebaseInProgressFormat = RebaseInProgress+    | input == newStyleRebaseInProgress = RebaseInProgress_2_16+    | input == rebaseInProgress_2_16 = RebaseInProgress_2_16+    | otherwise = UnknownFormat input --- | This is the list of properties which this version of darcs knows--- how to handle.-knownProperties :: [RepoProperty]-knownProperties = [Darcs1_0, Darcs2, HashedInventory, NoWorkingDir]+-- | Representation of the format of a repository. Each+-- sublist corresponds to a line in the format file.+newtype RepoFormat = RF [[RepoProperty]] +-- | Is a given property contained within a given format? formatHas :: RepoProperty -> RepoFormat -> Bool-formatHas f (RF ks) = rp2ps f `elem` concat ks+formatHas f (RF rps) = f `elem` concat rps -instance Show RepoProperty where-  show Darcs1_0 = "darcs-1.0"-  show Darcs2 = "darcs-2"-  show HashedInventory = "hashed"-  show NoWorkingDir = "no-working-dir"-rp2ps :: RepoProperty -> B.ByteString-rp2ps = BC.pack . show+-- | Add a single property to an existing format.+addToFormat :: RepoProperty -> RepoFormat -> RepoFormat+addToFormat f (RF rps) = RF (rps ++ [[f]])++-- | Remove a single property from an existing format.+removeFromFormat :: RepoProperty -> RepoFormat -> RepoFormat+removeFromFormat f (RF rps) = RF (rps \\ [[f]])++instance Show RepoFormat where+    show (RF rf) = unlines $ map (intercalate "|" . map show) rf++-- | Identify the format of the repository at the+-- given location (directory, URL, or SSH path).+-- Fails if we weren't able to identify the format.+identifyRepoFormat :: String -> IO RepoFormat+identifyRepoFormat = either fail return <=< tryIdentifyRepoFormat++-- | Identify the format of the repository at the+-- given location (directory, URL, or SSH path).+-- Return @'Left' reason@ if it fails, where @reason@ explains why+-- we weren't able to identify the format. Note that we do no verification of+-- the format, which is handled by 'readProblem' or 'writeProblem' on the+-- resulting 'RepoFormat'.+tryIdentifyRepoFormat :: String -> IO (Either String RepoFormat)+tryIdentifyRepoFormat repo = do+  formatResult <-+    fetchFile formatPath >>= \case+      Left e ->+        return $ Left $ prettyException e+      Right content | BC.elem '<' content ->+        -- We use a workaround for servers that don't return a 404 on nonexistent+        -- files (we trivially check for something that looks like a HTML/XML tag).+        return $ Left $ "invalid file content of " ++ (repo </> formatPath) ++ ":\n"+          ++ BC.unpack content+      Right content ->+        return $ Right $ readFormat content+  case formatResult of+    Right _ -> return formatResult+    Left formatError ->+      fetchFile oldInventoryPath >>= \case+        Right _ ->+          return $ Right $ RF [[Darcs1]]+        Left inventoryError ->+          -- report only the formatError+          return $ Left $ makeErrorMsg $+            formatError ++ "\nAnd also:\n" ++ prettyException inventoryError+  where+    readFormat =+      RF . map (map (readRepoProperty . fixupUnknownFormat)) . splitFormat++    -- silently fixup unknown format entries broken by previous darcs versions+    fixupUnknownFormat s =+      case B.stripPrefix "Unknown format: " s of+        Nothing -> s+        Just s' -> fixupUnknownFormat s' -- repeat until not found anymore++    -- split into lines, then split each non-empty line on '|'+    splitFormat = map (BC.split '|') . filter (not . B.null) . linesPS++    fetchFile path = try (fetchFilePS (repo </> path) Cachable)++    makeErrorMsg e =  "Not a repository: " ++ repo ++ ":\n" ++ e++-- | Write the repo format to the given file.+-- This is unsafe because we don't check that we are allowed to write+-- to the repo.+unsafeWriteRepoFormat :: RepoFormat -> FilePath -> IO ()+unsafeWriteRepoFormat rf loc = writeBinFile loc $ BC.pack $ show rf+-- note: this assumes show returns ascii++-- | Create a repo format. The first argument specifies the patch+-- format; the second says whether the repo has a working tree.+createRepoFormat :: F.PatchFormat -> F.WithWorkingDir -> RepoFormat+createRepoFormat fmt wwd = RF $ (HashedInventory : flags2wd wwd) : flags2format fmt+  where+    flags2format F.PatchFormat1 = []+    flags2format F.PatchFormat2 = [[Darcs2]]+    flags2format F.PatchFormat3 = [[Darcs3]]+    flags2wd F.NoWorkingDir   = [NoWorkingDir]+    flags2wd F.WithWorkingDir = []++-- | @'writeProblem' source@ returns 'Just' an error message if we cannot write+-- to a repo in format @source@, or 'Nothing' if there's no such problem.+writeProblem :: RepoFormat -> Maybe String+writeProblem target = readProblem target `mplus` findProblems target wp+  where+    wp [] = error "impossible case"+    wp x = case partition isKnown x of+               (_, []) -> Nothing+               (_, unknowns) -> Just . unwords $+                    "Can't write repository: unknown formats:" : map show unknowns++-- | @'transferProblem' source target@ returns 'Just' an error message if we+-- cannot transfer patches from a repo in format @source@ to a repo in format+-- @target@, or 'Nothing' if there are no such problem.+transferProblem :: RepoFormat -> RepoFormat -> Maybe String+transferProblem source target+    | formatHas Darcs3 source /= formatHas Darcs3 target =+        Just "Cannot mix darcs-3 repositories with older formats"+    | formatHas Darcs2 source /= formatHas Darcs2 target =+        Just "Cannot mix darcs-2 repositories with older formats"+    | formatHas RebaseInProgress source =+        Just "Cannot transfer patches from a repository \+          \where an old-style rebase is in progress"+    | otherwise = readProblem source `mplus` writeProblem target++-- | @'readProblem' source@ returns 'Just' an error message if we cannot read+-- from a repo in format @source@, or 'Nothing' if there's no such problem.+readProblem :: RepoFormat -> Maybe String+readProblem source+    | formatHas Darcs1 source && formatHas Darcs2 source =+        Just "Invalid repository format: format 2 is incompatible with format 1"+    | formatHas RebaseInProgress source && formatHas RebaseInProgress_2_16 source =+        Just "Invalid repository format: \+          \cannot have both old-style and new-style rebase in progress"+readProblem source = findProblems source rp+  where+    rp x | any isKnown x = Nothing+    rp [] = error "impossible case"+    rp x = Just . unwords $ "Can't read repository: unknown formats:" : map show x++-- |'findProblems' applies a function that maps format-entries to an optional+-- error message, to each repoformat entry. Returning any errors.+findProblems :: RepoFormat -> ([RepoProperty] -> Maybe String) -> Maybe String+findProblems (RF ks) formatHasProblem = case mapMaybe formatHasProblem ks of+                                            [] -> Nothing+                                            xs -> Just $ unlines xs++-- | Does this version of darcs know how to handle this property?+isKnown :: RepoProperty -> Bool+isKnown p = p `elem` knownProperties+  where+    knownProperties :: [RepoProperty]+    knownProperties = [ Darcs1+                      , Darcs2+                      , Darcs3+                      , HashedInventory+                      , NoWorkingDir+                      , RebaseInProgress+                      , RebaseInProgress_2_16+                      ]
+ src/Darcs/Repository/Hashed.hs view
@@ -0,0 +1,414 @@+-- Copyright (C) 2006-2007 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; if not, write to the Free Software Foundation,+-- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.+{-# LANGUAGE OverloadedStrings #-}+module Darcs.Repository.Hashed+    ( revertTentativeChanges+    , finalizeTentativeChanges+    , addToTentativeInventory+    , readPatches+    , readTentativePatches+    , writeAndReadPatch+    , writeTentativeInventory+    , copyHashedInventory+    , writePatchIfNecessary+    , tentativelyAddPatch+    , tentativelyRemovePatches+    , tentativelyRemovePatches_+    , tentativelyAddPatch_+    , tentativelyAddPatches+    , tentativelyAddPatches_+    , reorderInventory+    , UpdatePristine(..)+    , repoXor+    ) where++import Darcs.Prelude++import Control.Monad ( unless, when )+import Data.List ( foldl' )+import System.Directory+    ( copyFile+    , createDirectoryIfMissing+    , renameFile+    )+import System.FilePath.Posix ( (</>) )+import System.IO.Unsafe ( unsafeInterleaveIO )++import Darcs.Patch ( RepoPatch, effect, invert, invertFL, readPatch )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Depends+    ( cleanLatestTag+    , removeFromPatchSet+    , slightlyOptimizePatchset+    , fullyOptimizePatchSet+    )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Info ( displayPatchInfo, makePatchname, piName )+import Darcs.Patch.Invertible ( mkInvertible )+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , createHashed+    , hopefully+    , info+    , patchInfoAndPatch+    )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Rebase.Suspended+    ( addFixupsToSuspended+    , removeFixupsFromSuspended+    )+import Darcs.Patch.Set ( Origin, PatchSet(..), patchSet2RL )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , foldlwFL+    , foldrwFL+    , mapRL+    , sequenceFL_+    , (+>+)+    , (+>>+)+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++import Darcs.Repository.Flags+    ( OptimizeDeep(..)+    , RemoteDarcs+    , UpdatePending(..)+    , remoteDarcs+    )+import Darcs.Repository.Format+    ( RepoProperty(HashedInventory)+    , formatHas+    )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , Repository+    , SAccessType(..)+    , repoAccessType+    , repoCache+    , repoFormat+    , repoLocation+    , unsafeCoerceR+    , withRepoDir+    )+import Darcs.Repository.Inventory+    ( peekPristineHash+    , pokePristineHash+    , readPatchesFromInventoryFile+    , showInventoryEntry+    , writeInventory+    , writePatchIfNecessary+    )+import qualified Darcs.Repository.Old as Old ( oldRepoFailMsg, readOldRepo )+import Darcs.Repository.Paths+import Darcs.Repository.Pending+    ( readTentativePending+    , writeTentativePending+    )+import Darcs.Repository.Pristine+    ( applyToTentativePristine+    , convertSizePrefixedPristine+    )+import Darcs.Repository.Rebase+    ( withTentativeRebase+    )+import Darcs.Repository.Traverse ( cleanRepository )+import Darcs.Repository.Unrevert+    ( removeFromUnrevertContext+    )++import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Cache ( Cache, fetchFileUsingCache )+import Darcs.Util.File ( Cachable(Uncachable), copyFileOrUrl )+import Darcs.Util.Hash ( SHA1, sha1Xor, sha1zero )+import Darcs.Util.Lock+    ( appendDocBinFile+    , writeAtomicFilePS+    , writeDocBinFile+    )+import Darcs.Util.Printer ( renderString )+import Darcs.Util.Progress ( beginTedious, debugMessage, endTedious )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Tree ( Tree )++-- |revertTentativeChanges swaps the tentative and "real" hashed inventory+-- files, and then updates the tentative pristine with the "real" inventory+-- hash.+revertTentativeChanges :: Repository 'RO p wU wR -> IO ()+revertTentativeChanges repo = do+    copyFile hashedInventoryPath tentativeHashedInventoryPath+    inv <- gzReadFilePS tentativeHashedInventoryPath+    pristineHash <- convertSizePrefixedPristine (repoCache repo) (peekPristineHash inv)+    writeDocBinFile tentativePristinePath $ pokePristineHash pristineHash mempty+{-+    -- this is not needed, as we never again access the pristine hash in+    -- tentativeHashedInventoryPath, only that in tentativePristinePath+    writeDocBinFile tentativeHashedInventoryPath $+      pokePristineHash pristineHash inv+-}++-- |finalizeTentativeChanges trys to atomically swap the tentative+-- inventory/pristine pointers with the "real" pointers; it first re-reads the+-- inventory to optimize it, presumably to take account of any new tags, and+-- then writes out the new tentative inventory, and finally does the atomic+-- swap. In general, we can't clean the pristine cache at the same time, since+-- a simultaneous get might be in progress.+finalizeTentativeChanges :: RepoPatch p+                         => Repository 'RW p wU wR -> IO ()+finalizeTentativeChanges r = do+    debugMessage "Optimizing the inventory..."+    -- Read the tentative patches+    ps <- readTentativePatches r+    writeTentativeInventory r ps+    i <- gzReadFilePS tentativeHashedInventoryPath+    p <- gzReadFilePS tentativePristinePath+    -- Write out the "optimised" tentative inventory.+    writeDocBinFile tentativeHashedInventoryPath $+        pokePristineHash (peekPristineHash p) i+    -- Atomically swap.+    renameFile tentativeHashedInventoryPath hashedInventoryPath++-- | Add (append) a patch to the tentative inventory.+-- Warning: this allows to add any arbitrary patch!+-- Used by convert import and 'tentativelyAddPatch_'.+addToTentativeInventory :: RepoPatch p => Cache+                        -> PatchInfoAnd p wX wY -> IO ()+addToTentativeInventory c p = do+    hash <- snd <$> writePatchIfNecessary c p+    appendDocBinFile tentativeHashedInventoryPath $ showInventoryEntry (info p, hash)++-- | Read the recorded 'PatchSet' of a hashed 'Repository'.+readPatchesHashed :: (PatchListFormat p, ReadPatch p) => Repository rt p wU wR+                  -> IO (PatchSet p Origin wR)+readPatchesHashed repo =+  case repoAccessType repo of+    SRO -> readPatchesFromInventoryFile hashedInventoryPath repo+    SRW -> readPatchesFromInventoryFile tentativeHashedInventoryPath repo++-- | Read the tentative 'PatchSet' of a (hashed) 'Repository'.+readTentativePatches :: (PatchListFormat p, ReadPatch p)+                     => Repository 'RW p wU wR+                     -> IO (PatchSet p Origin wR)+readTentativePatches = readPatchesHashed++-- |Copy the hashed inventory from the given location to the given repository,+-- possibly using the given remote darcs binary.+copyHashedInventory :: Repository 'RO p wU wR -> RemoteDarcs -> String -> IO ()+copyHashedInventory outrepo rdarcs inloc | remote <- remoteDarcs rdarcs = do+    let outloc = repoLocation outrepo+    createDirectoryIfMissing False (outloc </> inventoriesDirPath)+    copyFileOrUrl remote (inloc </> hashedInventoryPath)+                         (outloc </> hashedInventoryPath)+                  Uncachable+    debugMessage "Done copying hashed inventory."++-- |writeAndReadPatch makes a patch lazy, by writing it out to disk (thus+-- forcing it), and then re-reads the patch lazily.+writeAndReadPatch :: RepoPatch p => Cache+                  -> PatchInfoAnd p wX wY -> IO (PatchInfoAnd p wX wY)+writeAndReadPatch c p = do+    (i, h) <- writePatchIfNecessary c p+    unsafeInterleaveIO $ readp h i+  where+    parse i h = do+        debugMessage $ "Rereading patch file for: " ++ piName i+        (fn, ps) <- fetchFileUsingCache c h+        case readPatch ps of+            Right x -> return x+            Left e -> fail $ unlines+                [ "Couldn't parse patch file " ++ fn+                , "which is"+                , renderString $ displayPatchInfo i+                , e+                ]++    readp h i = do Sealed x <- createHashed h (parse i)+                   return . patchInfoAndPatch i $ unsafeCoerceP x++-- | Write a 'PatchSet' to the tentative inventory.+writeTentativeInventory :: RepoPatch p+                        => Repository 'RW p wU wR+                        -> PatchSet p Origin wX+                        -> IO ()+writeTentativeInventory repo patchSet = do+    debugMessage "in writeTentativeInventory..."+    createDirectoryIfMissing False inventoriesDirPath+    let cache = repoCache repo+        tediousName = "Writing inventory"+    beginTedious tediousName+    hash <-+      writeInventory tediousName cache $ slightlyOptimizePatchset patchSet+    endTedious tediousName+    debugMessage "still in writeTentativeInventory..."+    (_filepath, content) <- fetchFileUsingCache cache hash+    writeAtomicFilePS tentativeHashedInventoryPath content++tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)+                    => Repository 'RW p wU wR+                    -> UpdatePending+                    -> PatchInfoAnd p wR wY+                    -> IO (Repository 'RW p wU wY)+tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine++tentativelyAddPatches :: (RepoPatch p, ApplyState p ~ Tree)+                      => Repository 'RW p wU wR+                      -> UpdatePending+                      -> FL (PatchInfoAnd p) wR wY+                      -> IO (Repository 'RW p wU wY)+tentativelyAddPatches = tentativelyAddPatches_ UpdatePristine++data UpdatePristine = UpdatePristine +                    | DontUpdatePristine+                    | DontUpdatePristineNorRevert deriving Eq++tentativelyAddPatches_ :: (RepoPatch p, ApplyState p ~ Tree)+                       => UpdatePristine+                       -> Repository 'RW p wU wR+                       -> UpdatePending+                       -> FL (PatchInfoAnd p) wR wY+                       -> IO (Repository 'RW p wU wY)+tentativelyAddPatches_ upr r upe ps = do+    let r' = unsafeCoerceR r+    withTentativeRebase r r' (foldlwFL (removeFixupsFromSuspended . hopefully) ps)+    withRepoDir r $ do+       sequenceFL_ (addToTentativeInventory (repoCache r)) ps+       when (upr == UpdatePristine) $ do+          applyToTentativePristine r $+            mkInvertible $ progressFL "Applying to pristine" ps+       when (upe == YesUpdatePending) $ do+          debugMessage "Updating pending..."+          Sealed pend <- readTentativePending r+          writeTentativePending r' $ invertFL (effect ps) +>>+ pend+       return r'++tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree)+                     => UpdatePristine+                     -> Repository 'RW p wU wR+                     -> UpdatePending+                     -> PatchInfoAnd p wR wY+                     -> IO (Repository 'RW p wU wY)+tentativelyAddPatch_ upr r upe p =+    tentativelyAddPatches_ upr r upe (p :>: NilFL)++tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree)+                         => Repository 'RW p wU wR+                         -> UpdatePending+                         -> FL (PatchInfoAnd p) wX wR+                         -> IO (Repository 'RW p wU wX)+tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine++tentativelyRemovePatches_ :: (RepoPatch p, ApplyState p ~ Tree)+                          => UpdatePristine+                          -> Repository 'RW p wU wR+                          -> UpdatePending+                          -> FL (PatchInfoAnd p) wX wR+                          -> IO (Repository 'RW p wU wX)+tentativelyRemovePatches_ upr r upe ps+  | formatHas HashedInventory (repoFormat r) = do+      withRepoDir r $ do+        ref <- readTentativePatches r+        unless (upr == DontUpdatePristineNorRevert) $ removeFromUnrevertContext ref ps+        debugMessage "Removing changes from tentative inventory..."+        r' <- removeFromTentativeInventory r ps+        withTentativeRebase r r' (foldrwFL (addFixupsToSuspended . hopefully) ps)+        when (upr == UpdatePristine) $+          applyToTentativePristine r $+            invert $ mkInvertible $ progressFL "Applying inverse to pristine" ps+        when (upe == YesUpdatePending) $ do+          debugMessage "Adding changes to pending..."+          Sealed pend <- readTentativePending r+          writeTentativePending r' $ effect ps +>+ pend+        return r'+  | otherwise = fail Old.oldRepoFailMsg++-- | Attempt to remove an FL of patches from the tentative inventory.+--+-- Precondition: it must be possible to remove the patches, i.e.+--+-- * the patches are in the repository+--+-- * any necessary commutations will succeed+removeFromTentativeInventory :: forall p wU wR wX. RepoPatch p+                             => Repository 'RW p wU wR+                             -> FL (PatchInfoAnd p) wX wR+                             -> IO (Repository 'RW p wU wX)+removeFromTentativeInventory repo to_remove = do+    debugMessage $ "Start removeFromTentativeInventory"+    allpatches :: PatchSet p Origin wR <- readTentativePatches repo+    remaining :: PatchSet p Origin wX <-+      case removeFromPatchSet to_remove allpatches of+        Nothing -> error "Hashed.removeFromTentativeInventory: precondition violated"+        Just r -> return r+    let repo' = unsafeCoerceR repo+    writeTentativeInventory repo' remaining+    debugMessage $ "Done removeFromTentativeInventory"+    return repo'++-- | Writes out a fresh copy of the inventory that minimizes the+-- amount of inventory that need be downloaded when people pull from+-- the repository. The exact beavior depends on the 3rd parameter:+--+-- For 'OptimizeShallow' it breaks up the inventory on the most recent tag.+-- This speeds up most commands when run remotely, both because a+-- smaller file needs to be transfered (only the most recent+-- inventory).  It also gives a guarantee that all the patches prior+-- to a given tag are included in that tag, so less commutation and+-- history traversal is needed.  This latter issue can become very+-- important in large repositories.+--+-- For 'OptimizeDeep', the whole repo is traversed, from oldest to newest+-- patch. Every tag we encounter is made clean, but only if that doesn't make+-- any previous clean tag unclean. Every clean tags gets its own inventory.+-- This speeds up "deep" operations, too, such as cloning a specific tag.+-- It does not necessarily make the latest tag clean, but the benefits are+-- similar to the shallow case.+reorderInventory :: (RepoPatch p, ApplyState p ~ Tree)+                 => Repository 'RW p wU wR+                 -> OptimizeDeep+                 -> IO ()+reorderInventory r deep+  | formatHas HashedInventory (repoFormat r) = do+      let optimize =+            case deep of+              OptimizeDeep -> fullyOptimizePatchSet+              OptimizeShallow -> cleanLatestTag+      readPatches r >>= return . optimize >>= writeTentativeInventory r+      cleanRepository r+      withSignalsBlocked $ finalizeTentativeChanges r+  | otherwise = fail Old.oldRepoFailMsg++-- | Read inventories and patches from a 'Repository' and return them as a+-- 'PatchSet'. Note that patches and inventories are read lazily.+readPatches :: RepoPatch p+            => Repository rt p wU wR+            -> IO (PatchSet p Origin wR)+readPatches r+    | formatHas HashedInventory (repoFormat r) = readPatchesHashed r+    | otherwise = do Sealed ps <- Old.readOldRepo (repoLocation r)+                     return $ unsafeCoerceP ps++-- | XOR of all hashes of the patches' metadata.+-- It enables to quickly see whether two repositories+-- have the same patches, independently of their order.+-- It relies on the assumption that the same patch cannot+-- be present twice in a repository.+-- This checksum is not cryptographically secure,+-- see http://robotics.stanford.edu/~xb/crypto06b/ .+repoXor :: RepoPatch p => Repository rt p wU wR -> IO SHA1+repoXor repo = do+  hashes <- mapRL (makePatchname . info) . patchSet2RL <$> readPatches repo+  return $ foldl' sha1Xor sha1zero hashes
− src/Darcs/Repository/HashedIO.hs 
@@ -1,295 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; if not, write to the Free Software Foundation,--- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.--{-# LANGUAGE CPP, TypeSynonymInstances, FlexibleInstances, MultiParamTypeClasses #-}--#include "gadts.h"--module Darcs.Repository.HashedIO ( HashedIO,-                                   copyHashed, copyPartialsHashed,-                                   cleanHashdir,-                                   RW(RW) -- only exported to make warning go away-                                 ) where--import Darcs.Global ( darcsdir )-import qualified Data.Set as Set-import System.Directory ( getDirectoryContents, createDirectoryIfMissing )-import Control.Monad.State ( StateT, runStateT, modify, get, put, gets, lift )-import Control.Monad ( when )-import Control.Applicative ( (<$>) )-import Data.Maybe ( isJust )-import System.IO.Unsafe ( unsafeInterleaveIO )--import Darcs.Repository.Cache ( Cache(..), fetchFileUsingCache, writeFileUsingCache,-                                peekInCache, speculateFileUsingCache,-                                okayHash, cleanCachesWithHint, HashedDir(..), hashedDir )-import Darcs.RepoPath ( FilePathLike, toFilePath )-import Darcs.Patch.ApplyMonad ( ApplyMonad(..) )-import Darcs.Flags ( Compression( .. ) )-import Darcs.Lock ( writeAtomicFilePS, removeFileMayNotExist )-import Darcs.Utils ( withCurrentDirectory )-import Progress ( debugMessage, tediousSize, finishedOneIO )-import Darcs.Patch.FileName ( FileName, normPath, fp2fn, fn2fp, fn2niceps, niceps2fn,-                              breakOnDir, ownName, superName )--import ByteStringUtils ( linesPS, unlinesPS )-import qualified Data.ByteString       as B  (ByteString, length, empty)-import qualified Data.ByteString.Char8 as BC (unpack, pack)--import Storage.Hashed.Darcs( readDarcsHashedDir, darcsLocation,-                             decodeDarcsHash, decodeDarcsSize )-import Storage.Hashed.Tree( ItemType(..), Tree )-import Darcs.CommandsAux---- | @readHashFile c subdir hash@ reads the file with hash @hash@ in dir subdir,--- fetching it from 'Cache' @c@ if needed.-readHashFile :: Cache -> HashedDir -> String -> IO (String,B.ByteString)-readHashFile c subdir hash =-    do debugMessage $ "Reading hash file "++hash++" from "++(hashedDir subdir)++"/"-       fetchFileUsingCache c subdir hash--data HashDir r p = HashDir { permissions :: !r, cache :: !Cache,-                             compress :: !Compression, rootHash :: !String }-type HashedIO p = StateT (HashDir RW p) IO--data RW = RW-{--class Readable r where-    isRO :: r -> Bool-    isRO = const False-instance Readable RW-instance Readable RO where-    isRO RO = True--}--mWithCurrentDirectory :: FileName -> HashedIO p a -> HashedIO p a-mWithCurrentDirectory fn j-    | fn' == fp2fn "" = j-    | otherwise =-        case breakOnDir fn' of-        Nothing -> do c <- readroot-                      case geta D fn' c of-                        Nothing -> fail "dir doesn't exist in mWithCurrentDirectory..."-                        Just h -> do (h',x) <- withh h j-                                     writeroot $ seta D fn' h' c-                                     return x-        Just (d,fn'') -> do c <- readroot-                            case geta D d c of-                              Nothing -> fail "dir doesn't exist..."-                              Just h -> do (h',x) <- withh h $ mWithCurrentDirectory fn'' j-                                           writeroot $ seta D d h' c-                                           return x-    where fn' = normPath fn--mInCurrentDirectory :: FileName -> HashedIO p a -> HashedIO p a-mInCurrentDirectory fn j | fn' == fp2fn "" = j-                         | otherwise =-                             case breakOnDir fn' of-                             Nothing -> do c <- readroot-                                           case geta D fn' c of-                                             Nothing -> fail "dir doesn't exist mInCurrentDirectory..."-                                             Just h -> inh h j-                             Just (d,fn'') -> do c <- readroot-                                                 case geta D d c of-                                                   Nothing -> fail "dir doesn't exist..."-                                                   Just h -> inh h $ mInCurrentDirectory fn'' j-    where fn' = normPath fn--instance ApplyMonad (HashedIO p) Tree where-    type ApplyMonadBase (HashedIO p) = IO-    mDoesDirectoryExist fn = do thing <- identifyThing fn-                                case thing of Just (D,_) -> return True-                                              _ -> return False-    mReadFilePS fn = mInCurrentDirectory (superName fn) $ do-                                          c <- readroot-                                          case geta F (ownName fn) c of-                                            Nothing -> fail $ " file don't exist... "++ fn2fp fn-                                            Just h -> readhash h-    mCreateDirectory fn = do h <- writeHashFile B.empty-                             exists <- isJust `fmap` identifyThing fn-                             when exists $ fail "can't mCreateDirectory over an existing object."-                             makeThing fn (D,h)-    mRename o n = do nexists <- isJust `fmap` identifyThing n-                     when nexists $ fail "mRename failed..."-                     mx <- identifyThing o-                     -- for backwards compatibility accept rename of nonexistent files.-                     case mx of Nothing -> return ()-                                Just x -> do rmThing o-                                             makeThing n x-    mRemoveDirectory = rmThing-    mRemoveFile f = do x <- mReadFilePS f-                       when (B.length x /= 0) $-                            fail $ "Cannot remove non-empty file "++fn2fp f-                       rmThing f--identifyThing :: FileName -> HashedIO p (Maybe (ObjType,String))-identifyThing fn | fn' == fp2fn "" = do h <- gets rootHash-                                        return $ Just (D, h)-                 | otherwise = case breakOnDir fn' of-                               Nothing -> getany fn' `fmap` readroot-                               Just (d,fn'') -> do c <- readroot-                                                   case geta D d c of-                                                     Nothing -> return Nothing-                                                     Just h -> inh h $ identifyThing fn''-        where fn' = normPath fn--makeThing :: FileName -> (ObjType,String) -> HashedIO p ()-makeThing fn (o,h) = mWithCurrentDirectory (superName $ normPath fn) $-                     seta o (ownName $ normPath fn) h `fmap` readroot >>= writeroot--rmThing :: FileName -> HashedIO p ()-rmThing fn = mWithCurrentDirectory (superName $ normPath fn) $-             do c <- readroot-                let c' = filter (\(_,x,_)->x/= ownName (normPath fn)) c-                if length c' == length c - 1-                  then writeroot c'-                  else fail "obj doesn't exist in rmThing"--readhash :: String -> HashedIO p B.ByteString-readhash h = do c <- gets cache-                z <- lift $ unsafeInterleaveIO $ readHashFile c HashedPristineDir h-                let (_,out) = z-                return out--withh :: String -> HashedIO p a -> HashedIO p (String,a)-withh h j = do hd <- get-               put $ hd { rootHash = h }-               x <- j-               h' <- gets rootHash-               put hd-               return (h',x)--inh :: String -> HashedIO p a -> HashedIO p a-inh h j = do hd <- get-             put $ hd { rootHash = h }-             x <- j-             put hd-             return x--readroot :: HashedIO p [(ObjType, FileName, String)]-readroot = do haveitalready <- peekroot-              cc <- gets rootHash >>= readdir-              when (not haveitalready) $ speculate cc-              return cc-    where speculate :: [(a,b,String)] -> HashedIO q ()-          speculate c = do cac <- gets cache-                           mapM_ (\(_,_,z) -> lift $ speculateFileUsingCache cac HashedPristineDir z) c-          peekroot :: HashedIO p Bool-          peekroot = do HashDir _ c _ h <- get-                        lift $ peekInCache c HashedPristineDir h--writeroot :: [(ObjType, FileName, String)] -> HashedIO p ()-writeroot c = do h <- writedir c-                 modify $ \hd -> hd { rootHash = h }--data ObjType = F | D deriving Eq---- | @geta objtype name stuff@ tries to get an object of type @objtype@ named @name@--- in @stuff@.-geta :: ObjType -> FileName -> [(ObjType, FileName, String)] -> Maybe String-geta o f c = do (o',h) <- getany f c-                if o == o' then Just h else Nothing--getany :: FileName -> [(ObjType, FileName, String)] -> Maybe (ObjType,String)-getany _ [] = Nothing-getany f ((o,f',h):_) | f == f' = Just (o,h)-getany f (_:r) = getany f r--seta :: ObjType -> FileName -> String -> [(ObjType, FileName, String)] -> [(ObjType, FileName, String)]-seta o f h [] = [(o,f,h)]-seta o f h ((_,f',_):r) | f == f' = (o,f,h):r-seta o f h (x:xs) = x : seta o f h xs--readdir :: String -> HashedIO p [(ObjType, FileName, String)]-readdir hash = (parsed . linesPS) `fmap` readhash hash-    where parsed (t:n:h:rest) | t == dir = (D, niceps2fn n, BC.unpack h) : parsed rest-                              | t == file = (F, niceps2fn n, BC.unpack h) : parsed rest-          parsed _ = []-dir :: B.ByteString-dir = BC.pack "directory:"-file :: B.ByteString-file = BC.pack "file:"---writedir :: [(ObjType, FileName, String)] -> HashedIO p String-writedir c = writeHashFile cps-    where cps = unlinesPS $ concatMap (\ (o,d,h) -> [showO o,fn2niceps d,BC.pack h]) c++[B.empty]-          showO D = dir-          showO F = file--writeHashFile :: B.ByteString -> HashedIO p String-writeHashFile ps = do c <- gets cache-                      compr <- gets compress-                      lift $ writeFileUsingCache c compr HashedPristineDir ps--copyHashed :: String -> Cache -> Compression -> String -> IO ()--- Warning:  A do-notation statement discarded a result of type ((), HashDir RO ghc-prim-copyHashed k c compr z = do _ <- runStateT cph $ HashDir { permissions = RW, cache = c,-                                                      compress = compr, rootHash = z }-                            return ()-    where cph = do cc <- readroot-                   lift $ tediousSize k (length cc)-                   mapM_ cp cc-          cp (F,n,h) = do ps <- readhash h-                          lift $ finishedOneIO k (fn2fp n)-                          lift $ writeAtomicFilePS (fn2fp n) ps-          cp (D,n,h) = if isMaliciousSubPath (fn2fp n)-                          then fail ("Caught malicious path: " ++ fn2fp n)-                          else do-                          lift $ createDirectoryIfMissing False (fn2fp n)-                          lift $ finishedOneIO k (fn2fp n)-                          lift $ withCurrentDirectory (fn2fp n) $ copyHashed k c compr h--copyPartialsHashed :: FilePathLike fp =>-                      Cache -> Compression -> String -> [fp] -> IO ()-copyPartialsHashed c compr root = mapM_ (copyPartialHashed c compr root)--copyPartialHashed :: FilePathLike fp => Cache -> Compression -> String -> fp -> IO ()-copyPartialHashed c compr root ff =-    do createDirectoryIfMissing True (basename $ toFilePath ff)--- Warning:  A do-notation statement discarded a result of type ((), HashDir RO ghc-prim-       _ <- runStateT (cp $ fp2fn $ toFilePath ff) $-                 HashDir { permissions = RW, cache = c,-                           compress=compr, rootHash = root }-       return ()- where basename = reverse . dropWhile ('/' /=) . dropWhile ('/' ==) . reverse-       cp f = do mt <- identifyThing f-                 case mt of-                   Just (D,h) -> do lift $ createDirectoryIfMissing True (fn2fp f)-                                    lift $ withCurrentDirectory (fn2fp f) $ copyHashed "" c compr h-                   Just (F,h) -> do ps <- readhash h-                                    lift $ writeAtomicFilePS (fn2fp f) ps-                   Nothing -> return ()--cleanHashdir :: Cache -> HashedDir -> [String] -> IO ()-cleanHashdir c dir_ hashroots =-   do -- we'll remove obsolete bits of "dir"-      debugMessage $ "Cleaning out " ++ (hashedDir dir_) ++ "..."-      let hashdir = darcsdir ++ "/" ++ (hashedDir dir_) ++ "/"-          listone h = do let size = decodeDarcsSize $ BC.pack h-                             hash = decodeDarcsHash $ BC.pack h-                         x <- readDarcsHashedDir hashdir (size, hash)-                         let subs = [ fst $ darcsLocation "" (s, h') | (TreeType, _, s, h') <- x ]-                             hashes = h : [ fst $ darcsLocation "" (s, h') | (_, _, s, h') <- x ]-                         (hashes++) . concat <$> mapM listone subs-      hs <- set . concat <$> mapM listone hashroots-      fs <- set . filter okayHash <$> getDirectoryContents hashdir-      mapM_ (removeFileMayNotExist . (hashdir++)) (unset $ fs `Set.difference` hs)-      -- and also clean out any global caches.-      debugMessage "Cleaning out any global caches..."-      cleanCachesWithHint c dir_ (unset $ fs `Set.difference` hs)-   where set = Set.fromList . map BC.pack-         unset = map BC.unpack . Set.toList
− src/Darcs/Repository/HashedRepo.hs 
@@ -1,484 +0,0 @@--- Copyright (C) 2006-2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; if not, write to the Free Software Foundation,--- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.--{-# LANGUAGE CPP, ScopedTypeVariables #-}--#include "gadts.h"--module Darcs.Repository.HashedRepo ( revertTentativeChanges, finalizeTentativeChanges,-                                     cleanPristine,-                                     copyPristine, copyPartialsPristine,-                                     applyToTentativePristine, addToSpecificInventory,-                                     addToTentativeInventory, removeFromTentativeInventory,-                                     readRepo, readTentativeRepo,-                                     readRepoUsingSpecificInventory, writeAndReadPatch,-                                     writeTentativeInventory, copyRepo,-                                     readHashedPristineRoot, pris2inv, copySources,-                                     listInventories, writePatchIfNecessary,-                                     readRepoFromInventoryList, readPatchIds-                                   ) where--import Prelude hiding ( catch )--import System.Directory ( createDirectoryIfMissing )-import System.FilePath.Posix( (</>) )-import System.IO.Unsafe ( unsafeInterleaveIO )-import System.IO ( stderr, hPutStrLn )-import Data.List ( delete )-import Control.Monad ( unless )-import Control.Applicative ( (<$>) )-import Control.Exception ( catch, IOException )--import Workaround ( renameFile )-import Darcs.Flags ( Compression, RemoteDarcs )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.RepoPath ( FilePathLike, ioAbsoluteOrRemote, toPath )-import Darcs.Repository.Cache ( Cache(..), CacheLoc(..), fetchFileUsingCache,-                                speculateFilesUsingCache, writeFileUsingCache,-                                unionCaches, repo2cache, okayHash, takeHash,-                                HashedDir(..), hashedDir,-                                peekInCache )-import qualified Darcs.Repository.Cache as DarcsCache-import Darcs.Repository.HashedIO ( copyHashed, copyPartialsHashed,-                                   cleanHashdir )-import Darcs.Repository.InternalTypes ( Repository(..), extractCache, modifyCache )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, patchInfoAndPatch, info,-                         extractHash, createHashed )-import Darcs.Patch ( RepoPatch, Patchy, showPatch, readPatch, apply )-import Darcs.Patch.Apply ( Apply, ApplyState )-import Darcs.Patch.ReadMonads ( parseStrictly )-import Darcs.Patch.Depends ( commuteToEnd, slightlyOptimizePatchset )-import Darcs.Patch.Info ( PatchInfo, showPatchInfo, humanFriendly, readPatchInfo )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Ordered ( reverseRL, reverseFL, (+<+) )--import ByteStringUtils ( gzReadFilePS, dropSpace )-import qualified Data.ByteString as B (null, length, empty-                                      ,tail, take, drop, ByteString)-import qualified Data.ByteString.Char8 as BC (unpack, dropWhile, break, pack)--import Printer ( Doc, hcat, (<>), ($$), renderString, renderPS, text, invisiblePS )-import Darcs.ColorPrinter () -- for instance Show Doc-import Crypt.SHA256 ( sha256sum )-import Darcs.External ( copyFileOrUrl, cloneFile, fetchFilePS, gzFetchFilePS,-    Cachable( Uncachable ) )-import Darcs.Lock ( writeBinFile, writeDocBinFile, writeAtomicFilePS, appendBinFile, appendDocBinFile )-import Darcs.Utils ( withCurrentDirectory )-import Progress ( beginTedious, endTedious, debugMessage, finishedOneIO )-#include "impossible.h"-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), mapRL, mapFL )-import Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal )-import Darcs.Global ( darcsdir )--import Storage.Hashed.Darcs( hashedTreeIO, readDarcsHashedNosize, readDarcsHashed,-                             writeDarcsHashed,-                             decodeDarcsHash, decodeDarcsSize )-import Storage.Hashed.Tree( treeHash, Tree )-import Storage.Hashed.Hash( encodeBase16, Hash(..) )--applyHashed'-   :: (Apply p, ApplyState p ~ Tree) => Hash -> p C(x y) -> IO String-applyHashed' root p = do case root of-                              (SHA256 _) -> return ()-                              _ -> fail $ "Cannot handle hash: " ++ show root-                         s <- readDarcsHashedNosize "_darcs/pristine.hashed" root-                         (_, t) <- (hashedTreeIO (apply p) s "_darcs/pristine.hashed")-                         return $ BC.unpack . encodeBase16 $ treeHash t--applyHashed :: (ApplyState q ~ Tree, Patchy q) => String -> q C(x y) -> IO String-applyHashed h p = applyHashed' hash p `catch` \(_ :: IOException) -> do-                          hPutStrLn stderr warn-                          inv <- gzReadFilePS invpath-                          let oldroot = BC.pack $ inv2pris inv-                              oldroot_hash = decodeDarcsHash oldroot-                              oldroot_size = decodeDarcsSize oldroot-                          old <- readDarcsHashed "_darcs/pristine.hashed" (oldroot_size, oldroot_hash)-                          root <- writeDarcsHashed old "_darcs/pristine.hashed"-                          let newroot = BC.unpack $ encodeBase16 root-                          writeDocBinFile invpath $ pris2inv newroot inv-                          cleanHashdir (Ca []) HashedPristineDir [newroot]-                          hPutStrLn stderr "Pristine conversion done..."-                          applyHashed' root p-  where invpath = darcsdir ++ "/hashed_inventory"-        hash = decodeDarcsHash $ BC.pack h-        warn = "WARNING: Doing a one-time conversion of pristine format.\n" ++-               "This may take a while. The new format is backwards-compatible."--revertTentativeChanges :: IO ()-revertTentativeChanges =-    do cloneFile (darcsdir++"/hashed_inventory") (darcsdir++"/tentative_hashed_inventory")-       i <- gzReadFilePS (darcsdir++"/hashed_inventory")-       writeBinFile (darcsdir++"/tentative_pristine") $ "pristine:" ++ inv2pris i--finalizeTentativeChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> Compression -> IO ()-finalizeTentativeChanges r compr =-    do let t = darcsdir++"/tentative_hashed_inventory"-       -- first let's optimize it...-       debugMessage "Optimizing the inventory..."-       ps <- readTentativeRepo r "."-       writeTentativeInventory (extractCache r) compr ps-       -- then we'll add in the pristine cache,-       i <- gzReadFilePS t-       p <- gzReadFilePS $ darcsdir++"/tentative_pristine"-       writeDocBinFile t $ pris2inv (inv2pris p) i-       -- and rename it to its final value-       renameFile t $ darcsdir++"/hashed_inventory"-       -- note: in general we can't clean the pristine cache, because a-       -- simultaneous get might be in progress--readHashedPristineRoot :: Repository p C(r u t) -> IO (Maybe String)-readHashedPristineRoot (Repo d _ _ _) =-    withCurrentDirectory d $ do-      i <- (Just `fmap` gzReadFilePS (darcsdir++"/hashed_inventory")) `catch` (\(_ :: IOException) -> return Nothing)-      return $ inv2pris `fmap` i--cleanPristine :: Repository p C(r u t) -> IO ()-cleanPristine r@(Repo d _ _ _) = withCurrentDirectory d $-   do -- we'll remove obsolete bits of our pristine cache-      debugMessage "Cleaning out the pristine cache..."-      i <- gzReadFilePS (darcsdir++"/hashed_inventory")-      cleanHashdir (extractCache r) HashedPristineDir [inv2pris i]--addToSpecificInventory :: RepoPatch p => String -> Cache -> Compression-                           -> PatchInfoAnd p C(x y) -> IO FilePath-addToSpecificInventory invPath c compr p = do-  let invFile = darcsdir </> invPath-  hash <- snd `fmap` writePatchIfNecessary c compr p-  appendDocBinFile invFile $ showPatchInfo $ info p-  appendBinFile invFile $ "\nhash: " ++ hash ++ "\n"-  return $ darcsdir </> "patches" </> hash--addToTentativeInventory :: RepoPatch p => Cache -> Compression-                           -> PatchInfoAnd p C(x y) -> IO FilePath-addToTentativeInventory = addToSpecificInventory "tentative_hashed_inventory"--removeFromTentativeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> Compression-                                -> FL (PatchInfoAnd p) C(x t) -> IO ()-removeFromTentativeInventory repo compr to_remove =-       -- FIXME: This algorithm should be *far* simpler.  All we need do is-       -- to to remove the patches from a patchset and then write that-       -- patchset.  The commutation behavior of PatchInfoAnd should track-       -- which patches need to be rewritten for us.-    do allpatches <- readTentativeRepo repo "."-       _ :> skipped <- return $ commuteToEnd (reverseFL to_remove) allpatches-       okay <- simpleRemoveFromTentativeInventory repo compr-               (mapFL info to_remove ++ mapRL info skipped)-       unless okay $ bug "bug in HashedRepo.removeFromTentativeInventory"-       sequence_ $ mapFL (addToTentativeInventory (extractCache repo) compr) (reverseRL skipped)--simpleRemoveFromTentativeInventory :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree) =>-                                          Repository p C(r u t) -> Compression -> [PatchInfo] -> IO Bool-simpleRemoveFromTentativeInventory repo compr pis = do-    inv <- readTentativeRepo repo "."-    case cut_inv pis inv of-      Nothing -> return False-      Just (Sealed inv') -> do writeTentativeInventory (extractCache repo) compr inv'-                               return True-    where cut_inv :: [PatchInfo] -> PatchSet p C(start x) -> Maybe (SealedPatchSet p C(start))-          cut_inv [] x = Just $ seal x-          cut_inv x (PatchSet NilRL (Tagged t _ ps :<: ts))-              = cut_inv x (PatchSet (t :<: ps) ts)-          cut_inv xs (PatchSet (hp:<:r) ts)-              | info hp `elem` xs = cut_inv (info hp `delete` xs) (PatchSet r ts)-          cut_inv _ _ = Nothing--writeHashFile :: Cache -> Compression -> HashedDir -> Doc -> IO String-writeHashFile c compr subdir d = do debugMessage $ "Writing hash file to "++(hashedDir subdir)-                                    writeFileUsingCache c compr subdir $ renderPS d--readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> String -> IO (PatchSet p C(Origin r))-readRepo repo d = readRepoUsingSpecificInventory "hashed_inventory" repo d--readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> String -> IO (PatchSet p C(Origin t))-readTentativeRepo repo d =-  readRepoUsingSpecificInventory "tentative_hashed_inventory" repo d--readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p C(r u t)-  -> String -> IO (PatchSet p C(Origin s))-readRepoUsingSpecificInventory invPath repo dir = do-  realdir <- toPath `fmap` ioAbsoluteOrRemote dir-  Sealed ps <- readRepoPrivate (extractCache repo) realdir invPath `catch`-                 (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)-                           ioError e)-  return $ unsafeCoerceP ps--readRepoPrivate :: (RepoPatch p, ApplyState p ~ Tree) => Cache -> FilePath -> FilePath -> IO (SealedPatchSet p C(Origin))-readRepoPrivate cache d iname = do-  inventory <- readInventoryPrivate cache (d </> "_darcs") iname-  readRepoFromInventoryList cache inventory--readRepoFromInventoryList :: (RepoPatch p, ApplyState p ~ Tree) => Cache-  -> (Maybe String, [(PatchInfo, String)]) -> IO (SealedPatchSet p C(Origin))-readRepoFromInventoryList cache inventory = parseinvs inventory-    where read_patches :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]-                       -> IO (Sealed (RL (PatchInfoAnd p) C(x)))-          read_patches [] = return $ seal NilRL-          read_patches allis@((i1,h1):is1) =-              lift2Sealed (\p rest -> i1 `patchInfoAndPatch` p :<: rest)-                          (rp is1)-                          (createHashed h1 (const $ speculate h1 allis >> parse i1 h1))-              where rp :: (RepoPatch p, ApplyState p ~ Tree) => [(PatchInfo, String)]-                       -> IO (Sealed (RL (PatchInfoAnd p) C(x)))-                    rp [] = return $ seal NilRL-                    rp [(i,h),(il,hl)] =-                        lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)-                                    (rp [(il,hl)])-                                    (createHashed h (const $ speculate h (reverse allis) >> parse i h))-                    rp ((i,h):is) = lift2Sealed (\p rest -> i `patchInfoAndPatch` p :<: rest)-                                                (rp is)-                                                (createHashed h (parse i))-          read_tag :: (RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) -> IO (Sealed (PatchInfoAnd p C(x)))-          read_tag (i,h) = mapSeal (patchInfoAndPatch i) `fmap` createHashed h (parse i)-          speculate :: String -> [(PatchInfo, String)] -> IO ()-          speculate h is =-              do already_got_one <- peekInCache cache HashedPatchesDir h-                 unless already_got_one $-                        speculateFilesUsingCache cache HashedPatchesDir (map snd is)-          parse :: Patchy p => PatchInfo -> String -> IO (Sealed (p C(x)))-          parse i h = do debugMessage ("Reading patch file: "++ show (humanFriendly i))-                         (fn,ps) <- fetchFileUsingCache cache HashedPatchesDir h-                         case readPatch ps of-                           Just p -> return p-                           Nothing -> fail $ unlines ["Couldn't parse file "++fn,-                                                      "which is patch",-                                                      renderString $ humanFriendly i]-          parseinvs :: (RepoPatch p, ApplyState p ~ Tree) => (Maybe String, [(PatchInfo, String)])-                    -> IO (SealedPatchSet p C(Origin))-          parseinvs (Nothing, ris) = mapSeal (\ps -> PatchSet ps NilRL)-                                     `fmap` (read_patches $ reverse ris)-          parseinvs (Just h, []) = bug $ "bad inventory "++h++" (no tag) in parseinvs!"-          parseinvs (Just h, t:ris) = do Sealed ts <- unseal seal `fmap`-                                                      unsafeInterleaveIO (read_ts t h)-                                         Sealed ps <- unseal seal `fmap`-                                             unsafeInterleaveIO (read_patches $-                                                                 reverse ris)-                                         return $ seal $ PatchSet ps ts-          read_ts :: (RepoPatch p, ApplyState p ~ Tree) => (PatchInfo, String) -> String -> IO (Sealed (RL (Tagged p) C(Origin)))-          read_ts tag0 h0 =-              do contents <- unsafeInterleaveIO $ readTaggedInventory cache h0-                 let is = reverse $ case contents of (Just _, _:ris0) -> ris0-                                                     (Nothing, ris0) -> ris0-                                                     (Just _, []) -> bug "inventory without tag!!!!"-                 Sealed ts <- fmap (unseal seal) $ unsafeInterleaveIO $-                              case contents of-                              (Just h', t':_) -> read_ts t' h'-                              (Just _, []) -> bug "inventory without tag!!!!"-                              (Nothing, _) -> return $ seal NilRL-                 Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches is)-                 Sealed tag00 <- read_tag tag0-                 return $ seal $ Tagged tag00 (Just h0) ps :<: ts-          lift2Sealed :: (FORALL(y z) q C(y z) -> p C(x y) -> r C(x z))-                      -> IO (Sealed (p C(x))) -> (FORALL(b) IO (Sealed (q C(b))))-                      -> IO (Sealed (r C(x)))-          lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap`-                                                 unsafeInterleaveIO iox-                                     Sealed y <- unseal seal `fmap`-                                                 unsafeInterleaveIO ioy-                                     return $ seal $ f y x--readTaggedInventory :: Cache -> String -> IO (Maybe String, [(PatchInfo, String)])-readTaggedInventory cache ihash = do-    (fn,i_and_p) <- fetchFileUsingCache cache HashedInventoriesDir ihash-    let i = skipPristine i_and_p-    (rest,str) <- case BC.break ((==)'\n') i of-                  (swt,pistr) | swt == BC.pack "Starting with inventory:" ->-                    case BC.break ((==)'\n') $ B.tail pistr of-                    (h,thisinv) | okayHash hash -> return (Just hash, thisinv)-                                where hash = BC.unpack h-                    _ -> fail $ "Bad hash in file " ++ fn-                  _ -> return (Nothing,i)-    return (rest, readPatchIds str)--copyRepo :: RepoPatch p => Repository p C(r u t) -> RemoteDarcs -> String -> IO ()-copyRepo repo@(Repo outr _ _ _) remote inr = do-    createDirectoryIfMissing False (outr++"/"++darcsdir++"/inventories")-    copyFileOrUrl remote (inr </> darcsdir </> "hashed_inventory")-                         (outr </> darcsdir </> "hashed_inventory")-                  Uncachable -- no need to copy anything but hashed_inventory!-    copySources repo inr-    debugMessage "Done copying hashed inventory."---- |'copySources' copies the prefs/sources file to the local repo, from the--- remote, having first filtered the local filesystem sources.-copySources :: RepoPatch p => Repository p C(r u t) -> String -> IO ()-copySources repo@(Repo outr _ _ _) inr = do-    let repoCache = extractCache $ modifyCache repo dropNonRepos-    appendBinFile (outr++"/"++darcsdir++"/prefs/sources") (show $ repo2cache inr `unionCaches` repoCache )-  where-    dropNonRepos (Ca cache) = Ca $ filter notRepo cache-    notRepo xs = case xs of-        Cache DarcsCache.Directory _ _ -> False-        Cache _ DarcsCache.Writable _  -> False-        _                              -> True--writeAndReadPatch :: RepoPatch p => Cache -> Compression -> PatchInfoAnd p C(x y)-                     -> IO (PatchInfoAnd p C(x y))-writeAndReadPatch c compr p =    do (i,h) <- writePatchIfNecessary c compr p-                                    unsafeInterleaveIO $ readp h i-    where parse i h = do debugMessage ("Rereading patch file: "++ show (humanFriendly i))-                         (fn,ps) <- fetchFileUsingCache c HashedPatchesDir h-                         case readPatch ps of-                           Just x -> return x-                           Nothing -> fail $ unlines ["Couldn't parse patch file "++fn,-                                                      "which is",-                                                      renderString $ humanFriendly i]-          readp h i = do Sealed x <- createHashed h (parse i)-                         return $ patchInfoAndPatch i $ unsafeCoerceP x--writeTentativeInventory :: RepoPatch p => Cache -> Compression -> PatchSet p C(Origin x) -> IO ()-writeTentativeInventory cache compr = writeEitherInventory cache compr "tentative_hashed_inventory"--writeEitherInventory :: RepoPatch p => Cache -> Compression -> String -> PatchSet p C(Origin x) -> IO ()-writeEitherInventory cache compr iname x =-    do debugMessage "in writeEitherInventory..."-       createDirectoryIfMissing False $ "_darcs/inventories"-       let k = "Writing inventory"-       beginTedious k-       hsh <- writeInventoryPrivate cache k compr $ slightlyOptimizePatchset x-       endTedious k-       debugMessage "still in writeEitherInventory..."-       case hsh of-         Nothing -> writeBinFile ("_darcs" </> iname) ""-         Just h -> fmap snd (fetchFileUsingCache cache HashedInventoriesDir h)-                   >>= writeAtomicFilePS ("_darcs" </> iname)--writeInventoryPrivate :: RepoPatch p => Cache -> String -> Compression-                        -> PatchSet p C(Origin x) -> IO (Maybe String)-writeInventoryPrivate _ _ _ (PatchSet NilRL NilRL) = return Nothing-writeInventoryPrivate cache _ compr (PatchSet x NilRL) =-  do inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) x-     let inventorylist = hcat (map pihash $ reverse inventory)-     hash <- writeHashFile cache compr HashedInventoriesDir inventorylist-     return $ Just hash-writeInventoryPrivate cache k compr (PatchSet x xs@(Tagged t _ _ :<: _)) =-  do resthash <- write_ts xs-     finishedOneIO k $ maybe "" id resthash-     inventory <- sequence $ mapRL (writePatchIfNecessary cache compr) (x+<+t:<:NilRL)-     let inventorylist = hcat (map pihash $ reverse inventory)-         inventorycontents =-             case resthash of-               Just h -> text ("Starting with inventory:\n"++h) $$ inventorylist-               Nothing -> inventorylist-     hash <- writeHashFile cache compr HashedInventoriesDir inventorycontents-     return $ Just hash-    where write_ts :: RepoPatch p => RL (Tagged p) C(Origin x) -> IO (Maybe String)-          write_ts (Tagged _ (Just h) _ :<: _) = return (Just h) -- already written!-          write_ts (Tagged _ Nothing pps :<: tts) =-              writeInventoryPrivate cache k compr $ PatchSet pps tts-          write_ts NilRL = return Nothing--writePatchIfNecessary :: RepoPatch p => Cache -> Compression-                        -> PatchInfoAnd p C(x y) -> IO (PatchInfo, String)-writePatchIfNecessary c compr hp =-    seq infohp $ case extractHash hp of-                   Right h -> return (infohp, h)-                   Left p -> (\h -> (infohp, h)) `fmap`-                             writeHashFile c compr HashedPatchesDir (showPatch p)-    where infohp = info hp--pihash :: (PatchInfo,String) -> Doc-pihash (pinf,hash) = showPatchInfo pinf $$ text ("hash: " ++ hash ++ "\n")--readInventoryPrivate :: Cache -> String -> String -> IO (Maybe String, [(PatchInfo, String)])-readInventoryPrivate _ d iname = do-    i <- skipPristine `fmap` gzFetchFilePS (d </> iname) Uncachable-    (rest,str) <- case BC.break ((==)'\n') i of-                  (swt,pistr) | swt == BC.pack "Starting with inventory:" ->-                    case BC.break ((==)'\n') $ B.tail pistr of-                    (h,thisinv) | okayHash hash -> return (Just hash, thisinv)-                                where hash = BC.unpack h-                    _ -> fail $ "Bad hash in " ++ toPath d ++ "/_darcs/" ++ iname-                  _ -> return (Nothing, i)-    return (rest, readPatchIds str)--listInventories :: IO [String]-listInventories = do-  x <- fst <$> readInventoryPrivate (Ca []) darcsdir "hashed_inventory"-  maybe (return []) f x- where-  f i = do-    x <- fst <$> readInventoryPrivate (Ca []) (darcsdir </> "inventories") i-    (i :) <$> maybe (return []) f x---- | 'readPatchIds inventory' parses the content of a hashed_inventory file--- after the "pristine:" and "Starting with inventory:" header lines have--- been removed.  The second value in the resulting tuples is the file hash--- of the associated patch (the "hash:" line).-readPatchIds :: B.ByteString -> [(PatchInfo, String)]-readPatchIds inv | B.null inv = []-readPatchIds inv = case parseStrictly readPatchInfo inv of-                     Nothing -> []-                     Just (pinfo,r) ->-                         case readHash r of-                         Nothing -> []-                         Just (h,r') -> (pinfo,h) : readPatchIds r'--readHash :: B.ByteString -> Maybe (String, B.ByteString)-readHash s = let s' = dropSpace s-                 (l,r) = BC.break ((==)'\n') s'-                 (kw,h) = BC.break ((==)' ') l-             in if kw /= BC.pack "hash:" || B.length h <= 1-                then Nothing-                else Just (BC.unpack $ B.tail h,r)--applyPristine :: (ApplyState q ~ Tree, Patchy q) => String -> String -> q C(x y) -> IO ()-applyPristine d iname p =-    do i <- gzReadFilePS (d++"/"++iname)-       h <- applyHashed (inv2pris i) p-       writeDocBinFile (d++"/"++iname) $ pris2inv h i--applyToTentativePristine :: (ApplyState q ~ Tree, Patchy q) => q C(x y) -> IO ()-applyToTentativePristine p = applyPristine "." (darcsdir++"/tentative_pristine") p--copyPristine :: Cache -> Compression -> String -> String -> IO ()-copyPristine c compr d iname = do-    i <- fetchFilePS (d++"/"++iname) Uncachable-    debugMessage $ "Copying hashed pristine tree: "++inv2pris i-    let k = "Copying pristine"-    beginTedious k-    copyHashed k c compr $ inv2pris i-    endTedious k--copyPartialsPristine :: FilePathLike fp =>-                          Cache -> Compression -> String -> String -> [fp] -> IO ()-copyPartialsPristine c compr d iname fps =-  do i <- fetchFilePS (d++"/"++iname) Uncachable-     copyPartialsHashed c compr (inv2pris i) fps--inv2pris :: B.ByteString -> String-inv2pris inv | B.take pristineNameLength inv == pristineName =-                 case takeHash $ B.drop pristineNameLength inv of-                 Just (h,_) -> h-                 Nothing -> error "Bad hash in inventory!"-             | otherwise = sha256sum B.empty--pris2inv :: String -> B.ByteString -> Doc-pris2inv h inv = invisiblePS pristineName <> text h $$ invisiblePS (skipPristine inv)--pristineName :: B.ByteString-pristineName = BC.pack "pristine:"--skipPristine :: B.ByteString -> B.ByteString-skipPristine ps-    | B.take pristineNameLength ps == pristineName = B.drop 1 $ BC.dropWhile (/= '\n') $-                                                        B.drop pristineNameLength ps-    | otherwise = ps--pristineNameLength :: Int-pristineNameLength = B.length pristineName
+ src/Darcs/Repository/Identify.hs view
@@ -0,0 +1,223 @@+{-|+License : GPL-2++A set of functions to identify and find Darcs repositories+from a given @URL@ or a given filesystem path.+-}++module Darcs.Repository.Identify+    ( maybeIdentifyRepository -- exported for darcsden+    , identifyRepository+    , identifyRepositoryFor+    , IdentifyRepo(..) -- exported for darcsden+    , ReadingOrWriting(..)+    , findRepository+    , amInRepository+    , amNotInRepository+    , amInHashedRepository+    , seekRepo+    ) where++import Darcs.Prelude++import Darcs.Repository.Format ( tryIdentifyRepoFormat+                               , readProblem+                               , transferProblem+                               )+import System.Directory ( doesDirectoryExist+                        , setCurrentDirectory+                        , createDirectoryIfMissing+                        , doesFileExist+                        )+import System.IO ( hPutStrLn, stderr )+import System.IO.Error ( catchIOError )+import Data.Maybe ( fromMaybe )++import Darcs.Repository.Old ( oldRepoFailMsg )+import Darcs.Repository.Flags ( UseCache(..), WorkRepo (..) )+import Darcs.Util.Path+    ( toFilePath+    , ioAbsoluteOrRemote+    , toPath+    )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.URL ( isValidLocalPath )+import Darcs.Util.Workaround+    ( getCurrentDirectory+    )+import Darcs.Repository.Paths+    ( hashedInventoryPath+    , oldCurrentDirPath+    , oldPristineDirPath+    )+import Darcs.Repository.Prefs ( getCaches )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , PristineType(..)+    , Repository+    , mkRepo+    , repoFormat+    )+import Darcs.Util.Global ( darcsdir )++import System.Mem( performGC )++-- | The status of a given directory: is it a darcs repository?+data IdentifyRepo rt p wU wR+    = BadRepository String -- ^ looks like a repository with some error+    | NonRepository String -- ^ safest guess+    | GoodRepository (Repository rt p wU wR)++-- | Try to identify the repository at a given location, passed as a 'String'.+-- If the lcation is ".", then we assume we are identifying the local repository.+-- Otherwise we assume we are dealing with a remote repo, which could be a URL+-- or an absolute path.+maybeIdentifyRepository :: UseCache -> String -> IO (IdentifyRepo 'RO p wU wR)+maybeIdentifyRepository useCache "." =+    do darcs <- doesDirectoryExist darcsdir+       if not darcs+        then return (NonRepository $ "Missing " ++ darcsdir ++ " directory")+        else do+        repoFormatOrError <- tryIdentifyRepoFormat "."+        here <- ioAbsoluteOrRemote "."+        case repoFormatOrError of+          Left err -> return $ NonRepository err+          Right rf ->+              case readProblem rf of+              Just err -> return $ BadRepository err+              Nothing -> do pris <- identifyPristine+                            cs <- getCaches useCache Nothing+                            return $ GoodRepository $ mkRepo here rf pris cs+maybeIdentifyRepository useCache url' =+ do url <- ioAbsoluteOrRemote url'+    repoFormatOrError <- tryIdentifyRepoFormat (toPath url)+    case repoFormatOrError of+      Left e -> return $ NonRepository e+      Right rf -> case readProblem rf of+                  Just err -> return $ BadRepository err+                  Nothing ->  do cs <- getCaches useCache (Just url)+                                 return $ GoodRepository $ mkRepo url rf NoPristine cs++identifyPristine :: IO PristineType+identifyPristine =+    do pristine <- doesDirectoryExist oldPristineDirPath+       current  <- doesDirectoryExist oldCurrentDirPath+       hashinv  <- doesFileExist      hashedInventoryPath+       case (pristine || current, hashinv) of+           (False, False) -> return NoPristine+           (True,  False) -> return PlainPristine+           (False, True ) -> return HashedPristine+           _ -> fail "Multiple pristine trees."++-- | identifyRepository identifies the repo at 'url'. Warning:+-- you have to know what kind of patches are found in that repo.+identifyRepository :: UseCache -> String -> IO (Repository 'RO p wU wR)+identifyRepository useCache url =+    do er <- maybeIdentifyRepository useCache url+       case er of+         BadRepository s -> fail s+         NonRepository s -> fail s+         GoodRepository r -> return r++data ReadingOrWriting = Reading | Writing++-- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url',+-- but fails if it is not compatible for reading from and writing to.+identifyRepositoryFor :: ReadingOrWriting+                      -> Repository rt p wU wR+                      -> UseCache+                      -> String+                      -> IO (Repository 'RO p vR vU)+identifyRepositoryFor what us useCache them_loc = do+  them <- identifyRepository useCache them_loc+  case+    case what of+      Reading -> transferProblem (repoFormat them) (repoFormat us)+      Writing -> transferProblem (repoFormat us) (repoFormat them) +    of+      Just e -> fail $ "Incompatibility with repository " ++ them_loc ++ ":\n" ++ e+      Nothing -> return them++amInRepository :: WorkRepo -> IO (Either String ())+amInRepository (WorkRepoDir d) =+  do+    setCurrentDirectory d+    status <- maybeIdentifyRepository YesUseCache "."+    case status of+      GoodRepository _ -> return (Right ())+      BadRepository  e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e)+      NonRepository  _ -> return (Left "You need to be in a repository directory to run this command.")+  `catchIOError`+    \e -> return (Left (show e))+  +amInRepository _ =+  fromMaybe (Left "You need to be in a repository directory to run this command.") <$> seekRepo++amInHashedRepository :: WorkRepo -> IO (Either String ())+amInHashedRepository wd+ = do inrepo <- amInRepository wd+      case inrepo of+       Right _ -> do pristine <- identifyPristine+                     case pristine of+                       HashedPristine -> return (Right ())+                       _ -> return (Left oldRepoFailMsg)+       left    -> return left++-- | hunt upwards for the darcs repository+-- This keeps changing up one parent directory, testing at each+-- step if the current directory is a repository or not.+-- The result is:+--   Nothing, if no repository found+--   Just (Left errorMessage), if bad repository found+--   Just (Right ()), if good repository found.+-- WARNING this changes the current directory for good if matchFn succeeds+seekRepo :: IO (Maybe (Either String ()))+seekRepo = getCurrentDirectory >>= helper where+  helper startpwd = do+    status <- maybeIdentifyRepository YesUseCache "."+    case status of+      GoodRepository _ -> return . Just $ Right ()+      BadRepository e -> return . Just $ Left e+      NonRepository _ ->+        catchIOError+          (do cd <- toFilePath `fmap` getCurrentDirectory+              setCurrentDirectory ".."+              cd' <- toFilePath `fmap` getCurrentDirectory+              if cd' /= cd+                then helper startpwd+                else do+                  setCurrentDirectory startpwd+                  return Nothing)+          (\e -> do+             hPutStrLn stderr ("Warning: " ++ show e)+             return Nothing)++-- The performGC in this function is a workaround for a library/GHC bug,+-- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a+-- problem on fast machines, but virtual ones trip this from time to time)+amNotInRepository :: WorkRepo -> IO (Either String ())+amNotInRepository (WorkRepoDir d) = do+    createDirectoryIfMissing False d+       `catchall` (performGC >> createDirectoryIfMissing False d)+    -- note that the above could always fail+    setCurrentDirectory d+    amNotInRepository WorkRepoCurrentDir+amNotInRepository _ = do+       status <- maybeIdentifyRepository YesUseCache "."+       case status of+         GoodRepository _ -> return (Left "You may not run this command in a repository.")+         BadRepository e  -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e)+         NonRepository _  -> return (Right ())++findRepository :: WorkRepo -> IO (Either String ())+findRepository workrepo =+  case workrepo of+    WorkRepoPossibleURL d | isValidLocalPath d -> do+      setCurrentDirectory d+      findRepository WorkRepoCurrentDir+    WorkRepoDir d -> do+      setCurrentDirectory d+      findRepository WorkRepoCurrentDir+    _ -> fromMaybe (Right ()) <$> seekRepo+  `catchIOError` \e ->+    return (Left (show e))
− src/Darcs/Repository/Internal.hs 
@@ -1,884 +0,0 @@--- Copyright (C) 2002-2004,2007-2008 David Roundy--- Copyright (C) 2005 Juliusz Chroboczek------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, ScopedTypeVariables, Rank2Types, RankNTypes, PatternGuards #-}--#include "gadts.h"--module Darcs.Repository.Internal ( Repository(..), RepoType(..), RIO(unsafeUnRIO), RepoJob(..),--                    maybeIdentifyRepository, identifyDarcsRepository, identifyRepositoryFor,-                    IdentifyRepo(..),-                    findRepository, amInRepository, amNotInRepository,-                    amInHashedRepository,-                    revertRepositoryChanges,-                    announceMergeConflicts, setTentativePending,-                    checkUnrecordedConflicts,-                    withRecorded,-                    readRepo, readTentativeRepo, readRepoUsingSpecificInventory,-                    prefsUrl, makePatchLazy,-                    withRepoLock, withRepoReadLock,-                    withRepository, withRepositoryDirectory, withGutsOf,-                    tentativelyAddPatch, tentativelyRemovePatches, tentativelyAddToPending,-                    tentativelyAddPatch_,-                    tentativelyReplacePatches,-                    finalizeRepositoryChanges,-                    unrevertUrl,-                    applyToWorking, patchSetToPatches,-                    createPristineDirectoryTree, createPartialsPristineDirectoryTree,-                    optimizeInventory, cleanRepository,-                    setScriptsExecutable, setScriptsExecutablePatches,-                    getRepository, rIO,-                    testTentative, testRecorded,-                    UpdatePristine(..), MakeChanges(..), applyToTentativePristine,-                    makeNewPending, seekRepo-                  ) where--import Prelude hiding ( catch )--import Printer ( putDocLn, (<+>), text, ($$), redText, putDocLnWith, (<>), ($$))-import Darcs.ColorPrinter (fancyPrinters)--import Darcs.Repository.Prefs ( getPrefval )-import Darcs.Repository.State ( readRecorded, readWorking )-import Darcs.Repository.LowLevel-    ( readPending, readTentativePending-    , writeTentativePending-    , readNewPending, writeNewPending-    , pendingName )-import System.Exit ( ExitCode(..), exitWith )-import System.Cmd ( system )-import Darcs.IO ( runTolerantly, runSilently )--import Darcs.SignalHandler ( withSignalsBlocked )-import Darcs.Repository.Format ( RepoFormat, RepoProperty( Darcs2 , HashedInventory, NoWorkingDir ),-                                 tryIdentifyRepoFormat, formatHas,-                                 writeProblem, readProblem, readfromAndWritetoProblem )-import System.Directory ( doesDirectoryExist, setCurrentDirectory,-                          createDirectoryIfMissing, doesFileExist )-import Control.Monad ( when, unless, filterM )-import Control.Applicative ( (<$>) )-import Control.Exception ( catch, IOException )--import Workaround ( getCurrentDirectory, renameFile, setExecutable )--import qualified Data.ByteString as B ( readFile, isPrefixOf )-import qualified Data.ByteString.Char8 as BC (pack)--import Darcs.Patch ( Effect, primIsHunk, primIsBinary, description,-                     tryToShrink, commuteFLorComplain, commute, fromPrim )--import Darcs.Patch.Dummy ( DummyPatch )--import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.V1 ( Patch )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.Prim.V1 ( Prim )--import Darcs.Patch.Inspect ( PatchInspect )-import Darcs.Patch.Prim ( PrimPatchBase, PrimOf, tryShrinkingInverse, PrimPatch )-import Darcs.Patch.Bundle ( scanBundle, makeBundleN )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )-import qualified Darcs.Repository.HashedRepo as HashedRepo-                            ( revertTentativeChanges, finalizeTentativeChanges,-                              removeFromTentativeInventory,-                              copyPristine, copyPartialsPristine,-                              applyToTentativePristine,-                              writeTentativeInventory, writeAndReadPatch,-                              addToTentativeInventory,-                              readRepo, readTentativeRepo,-                              readRepoUsingSpecificInventory, cleanPristine )-import qualified Darcs.Repository.Old as Old-                            ( readOldRepo, revertTentativeChanges, oldRepoFailMsg )-import Darcs.Flags ( DarcsFlag(Verbose, Quiet,-                               MarkConflicts, AllowConflicts, NoUpdateWorking,-                               WorkRepoUrl, WorkRepoDir, UMask, Test, LeaveTestDir,-                               SetScriptsExecutable, DryRun ),-                     wantExternalMerge, compression, Compression )-import Darcs.Witnesses.Eq ( EqCheck(..) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart )-import Darcs.Witnesses.Ordered ( FL(..), RL(..),-                             (:\/:)(..), (:/\:)(..), (:>)(..),-                             (+>+), lengthFL,-                             allFL, filterFLFL,-                             reverseFL, mapFL_FL, concatFL )-import Darcs.Patch ( RepoPatch, Patchy, merge,-                     listConflictedFiles, listTouchedFiles,-                     Named,-                     commuteRL, fromPrims,-                     readPatch,-                     effect, invert,-                     primIsAddfile, primIsAdddir,-                     primIsSetpref,-                     apply, applyToTree,-                   )-import Darcs.Patch.Permutations ( commuteWhatWeCanFL, removeFL )-import Darcs.Patch.Set ( PatchSet(..), SealedPatchSet, newset2FL )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Patch.Depends ( deepOptimizePatchset, removeFromPatchSet, mergeThem )-import Darcs.RepoPath ( FilePathLike, AbsolutePath, toFilePath,-                        ioAbsoluteOrRemote, toPath )-import Darcs.Utils ( promptYorn, catchall, withCurrentDirectory, withUMask, nubsort )-import Progress ( debugMessage )-import Darcs.ProgressPatches (progressFL)-import Darcs.URL ( isFile )-import Darcs.Repository.Prefs ( getCaches )-import Darcs.Lock ( withLock, writeDocBinFile, removeFileMayNotExist,-                    withTempDir, withPermDir )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, FlippedSeal(FlippedSeal), flipSeal, mapSeal )-import Darcs.Repository.InternalTypes( Repository(..), RepoType(..), Pristine(..) )-import Darcs.Global ( darcsdir )--import System.Mem( performGC )--import qualified Storage.Hashed.Tree as Tree-import Storage.Hashed.Tree ( Tree )-import Storage.Hashed.AnchoredPath( anchorPath )--#include "impossible.h"---- | Repository IO monad.  This monad-like datatype is responsible for--- sequencing IO actions that modify the tentative recorded state of--- the repository.-newtype RIO p C(r u t t1) a = RIO {-        unsafeUnRIO :: Repository p C(r u t) -> IO a -- ^ converts @RIO a@ to @IO a@.-   }---- | This is just like @>>=@ from the Monad class except that it--- respects type witness safe repository transformations.  Even so, it--- only tracks modifications to the tentative recorded state.-(>>>=) :: RIO p C(r u t t1) a -> (a -> RIO p C(r u t1 t2) b) -> RIO p C(r u t t2) b-m >>>= k = RIO $ \ (Repo x y z w) ->-             do a <- unsafeUnRIO m (Repo x y z w)-                unsafeUnRIO (k a) (Repo x y z w)---- | This corresponds to @>>@ from the Monad class.-(>>>) :: RIO p C(r u t t1) a -> RIO p C(r u t1 t2) b -> RIO p C(r u t t2) b-a >>> b = a >>>= (const b)---- | This corresponds to @return@ from the Monad class.-returnR :: a -> RIO p C(r u t t) a-returnR = rIO . return---- | This the @RIO@ equivalent of @liftIO@.-rIO :: IO a -> RIO p C(r u t t) a-rIO = RIO . const--instance Functor (RIO p C(r u t t)) where-    fmap f m = RIO $ \r -> fmap f (unsafeUnRIO m r)---- | We have an instance of Monad so that IO actions that do not--- change the tentative recorded state are convenient in the IO monad.-instance Monad (RIO p C(r u t t)) where- (>>=) = (>>>=)- (>>) = (>>>)- return = returnR- fail = rIO . fail---- | Similar to the @ask@ function of the MonadReader class.--- This allows actions in the RIO monad to get the current--- repository.--- FIXME: Don't export this.  If we don't export this--- it makes it harder for arbitrary IO actions to access--- the repository and hence our code is easier to audit.-getRepository :: RIO p C(r u t t) (Repository p C(r u t))-getRepository = RIO return---- | The status of a given directory: is it a darcs repository?-data IdentifyRepo p C(r u t) = BadRepository String -- ^ looks like a repository with some error-                             | NonRepository String -- ^ safest guess-                             | GoodRepository (Repository p C(r u t))---- | Tries to identify the repository in a given directory-maybeIdentifyRepository :: [DarcsFlag] -> String -> IO (IdentifyRepo p C(r u t))-maybeIdentifyRepository opts "." =-    do darcs <- doesDirectoryExist darcsdir-       rf_or_e <- tryIdentifyRepoFormat "."-       here <- toPath `fmap` ioAbsoluteOrRemote "."-       case rf_or_e of-         Left err -> return $ NonRepository err-         Right rf ->-             case readProblem rf of-             Just err -> return $ BadRepository err-             Nothing -> if darcs then do pris <- identifyPristine-                                         cs <- getCaches opts here-                                         return $ GoodRepository $ Repo here opts rf (DarcsRepository pris cs)-                                 else return (NonRepository "Not a repository")-maybeIdentifyRepository opts url' =- do url <- toPath `fmap` ioAbsoluteOrRemote url'-    rf_or_e <- tryIdentifyRepoFormat url-    case rf_or_e of-      Left e -> return $ NonRepository e-      Right rf -> case readProblem rf of-                  Just err -> return $ BadRepository err-                  Nothing ->  do cs <- getCaches opts url-                                 return $ GoodRepository $ Repo url opts rf (DarcsRepository NoPristine cs)--identifyPristine :: IO Pristine-identifyPristine =-    do pristine <- doesDirectoryExist $ darcsdir++"/pristine"-       current  <- doesDirectoryExist $ darcsdir++"/current"-       hashinv  <- doesFileExist      $ darcsdir++"/hashed_inventory"-       case (pristine || current, hashinv) of-           (False, False) -> return NoPristine-           (True,  False) -> return PlainPristine-           (False, True ) -> return HashedPristine-           _ -> fail "Multiple pristine trees."---- | identifyDarcsRepository identifies the repo at 'url'. Warning:--- you have to know what kind of patches are found in that repo.-identifyDarcsRepository :: forall p C(r u t). [DarcsFlag] -> String-                           -> IO (Repository p C(r u t))-identifyDarcsRepository opts url =-    do er <- maybeIdentifyRepository opts url-       case er of-         BadRepository s -> fail s-         NonRepository s -> fail s-         GoodRepository r -> return r---- | @identifyRepositoryFor repo url@ identifies (and returns) the repo at 'url',--- but fails if it is not compatible for reading from and writing to.-identifyRepositoryFor :: forall p C(r u t). RepoPatch p => Repository p C(r u t) -> String -> IO (Repository p C(r u t))-identifyRepositoryFor (Repo _ opts rf _) url =-    do Repo absurl _ rf_ t <- identifyDarcsRepository opts url-       let t' = case t of DarcsRepository x c -> DarcsRepository x c-       case readfromAndWritetoProblem rf_ rf of-         Just e -> fail $ "Incompatibility with repository " ++ url ++ ":\n" ++ e-         Nothing -> return $ Repo absurl opts rf_ t'--amInRepository :: [DarcsFlag] -> IO (Either String ())-amInRepository (WorkRepoDir d:_) =-    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)-       status <- maybeIdentifyRepository [] "."-       case status of-         GoodRepository _ -> return (Right ())-         BadRepository  e -> return (Left $ "While " ++ d ++ " looks like a repository directory, we have a problem with it:\n" ++ e)-         NonRepository  _ -> return (Left "You need to be in a repository directory to run this command.")-amInRepository (_:fs) = amInRepository fs-amInRepository [] = do-    maybe (Left $ "You need to be in a repository directory " ++-        "to run this command.") id <$> seekRepo--amInHashedRepository :: [DarcsFlag] -> IO (Either String ())-amInHashedRepository flags- = do inrepo <- amInRepository flags-      case inrepo of-       Right _ -> do pristine <- identifyPristine-                     case pristine of-                       HashedPristine -> return (Right ())-                       _ -> return (Left Old.oldRepoFailMsg)-       left    -> return left---- | hunt upwards for the darcs repository--- This keeps changing up one parent directory, testing at each--- step if the current directory is a repository or not.  $--- The result is:---   Nothing, if no repository found---   Just (Left errorMessage), if bad repository found---   Just (Right ()), if good repository found.--- WARNING this changes the current directory for good if matchFn succeeds-seekRepo :: IO (Maybe (Either String ()))-seekRepo = getCurrentDirectory >>= helper where-   helper startpwd = do-    status <- maybeIdentifyRepository [] "."-    case status of-      GoodRepository _ -> return . Just $ Right ()-      BadRepository e  -> return . Just $ Left e-      NonRepository _ ->-            do cd <- toFilePath `fmap` getCurrentDirectory-               setCurrentDirectory ".."-               cd' <- toFilePath `fmap` getCurrentDirectory-               if cd' /= cd-                  then helper startpwd-                  else do setCurrentDirectory startpwd-                          return Nothing---- The performGC in this function is a workaround for a library/GHC bug,--- http://hackage.haskell.org/trac/ghc/ticket/2924 -- (doesn't seem to be a--- problem on fast machines, but virtual ones trip this from time to time)-amNotInRepository :: [DarcsFlag] -> IO (Either String ())-amNotInRepository (WorkRepoDir d:_) = do createDirectoryIfMissing False d-                                            `catchall` (performGC >> createDirectoryIfMissing False d)-                                         -- note that the above could always fail-                                         setCurrentDirectory d-                                         amNotInRepository []-amNotInRepository (_:f) = amNotInRepository f-amNotInRepository [] =-    do status <- maybeIdentifyRepository [] "."-       case status of-         GoodRepository _ -> return (Left $ "You may not run this command in a repository.")-         BadRepository e  -> return (Left $ "You may not run this command in a repository.\nBy the way, we have a problem with it:\n" ++ e)-         NonRepository _  -> return (Right ())--findRepository :: [DarcsFlag] -> IO (Either String ())-findRepository (WorkRepoUrl d:_) | isFile d =-    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)-       findRepository []-findRepository (WorkRepoDir d:_) =-    do setCurrentDirectory d `catchall` (fail $ "can't set directory to "++d)-       findRepository []-findRepository (_:fs) = findRepository fs-findRepository [] = maybe (Right ()) id <$> seekRepo---- TODO: see also Repository.State.readPendingLL ... to be removed after GHC 7.2-readNewPendingLL :: (RepoPatch p, ApplyState p ~ Tree)-              => Repository p C(r u t) -> IO (Sealed ((FL p) C(t)))-readNewPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` readNewPending repo--makeNewPending :: forall p C(r u t y). (RepoPatch p, ApplyState p ~ Tree)-                 => Repository p C(r u t) -> FL (PrimOf p) C(t y) -> IO ()-makeNewPending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-makeNewPending repo@(Repo r _ _ tp) origp =-    withCurrentDirectory r $-    do let newname = pendingName tp ++ ".new"-       debugMessage $ "Writing new pending:  " ++ newname-       Sealed sfp <- return $ siftForPending origp-       writeNewPending repo sfp-       cur <- readRecorded repo-       Sealed p <- readNewPendingLL repo -- :: IO (Sealed (FL (PrimOf p) C(t)))--- Warning:  A do-notation statement discarded a result of type Tree.Tree IO.-       _ <- catch (applyToTree p cur) $ \(err :: IOException) -> do-         let buggyname = pendingName tp ++ "_buggy"-         renameFile newname buggyname-         bugDoc $ text ("There was an attempt to write an invalid pending! " ++ show err)-                    $$ text "If possible, please send the contents of"-                    <+> text buggyname-                    $$ text "along with a bug report."-       renameFile newname (pendingName tp)-       debugMessage $ "Finished writing new pending:  " ++ newname--siftForPending :: forall prim C(x y) . PrimPatch prim => FL prim C(x y) -> Sealed (FL prim C(x))-siftForPending simple_ps =- let oldps = maybe simple_ps id $ tryShrinkingInverse $ crudeSift simple_ps- in if allFL (\p -> primIsAddfile p || primIsAdddir p) $ oldps-    then seal oldps-    else fromJust $ do-      Sealed x <- return $ sfp NilFL $ reverseFL oldps-      return (case tryToShrink x of-              ps | lengthFL ps < lengthFL oldps -> siftForPending ps-                 | otherwise -> seal ps)-      where sfp :: FL prim C(a b) -> RL prim C(c a) -> Sealed (FL prim C(c))-            sfp sofar NilRL = seal sofar-            sfp sofar (p:<:ps)-                | primIsHunk p || primIsBinary p-                    = case commuteFLorComplain (p :> sofar) of-                      Right (sofar' :> _) -> sfp sofar' ps-                      Left _ -> sfp (p:>:sofar) ps-            sfp sofar (p:<:ps) = sfp (p:>:sofar) ps---- @todo: we should not have to open the result of HashedRepo and--- seal it.  Instead, update this function to work with type witnesses--- by fixing DarcsRepo to match HashedRepo in the handling of--- Repository state.-readRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO (PatchSet p C(Origin r))-readRepo repo@(Repo r _ rf _)-    | formatHas HashedInventory rf = HashedRepo.readRepo repo r-    | otherwise = do Sealed ps <- Old.readOldRepo r-                     return $ unsafeCoerceP ps--readTentativeRepo :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO (PatchSet p C(Origin t))-readTentativeRepo repo@(Repo r _ rf _)-    | formatHas HashedInventory rf = HashedRepo.readTentativeRepo repo r-    | otherwise = fail Old.oldRepoFailMsg--readRepoUsingSpecificInventory :: (RepoPatch p, ApplyState p ~ Tree) => String -> Repository p C(r u t)-  -> IO (PatchSet p C(Origin t))-readRepoUsingSpecificInventory invPath repo@(Repo r _ rf _)-    | formatHas HashedInventory rf =-        HashedRepo.readRepoUsingSpecificInventory invPath repo r-    | otherwise = fail Old.oldRepoFailMsg--makePatchLazy :: RepoPatch p => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO (PatchInfoAnd p C(x y))-makePatchLazy (Repo r opts rf (DarcsRepository _ c)) p-    | formatHas HashedInventory rf = withCurrentDirectory r $ HashedRepo.writeAndReadPatch c (compression opts) p-    | otherwise = fail Old.oldRepoFailMsg--prefsUrl :: Repository p C(r u t) -> String-prefsUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/prefs"--unrevertUrl :: Repository p C(r u t) -> String-unrevertUrl (Repo r _ _ (DarcsRepository _ _)) = r ++ "/"++darcsdir++"/patches/unrevert"--applyToWorking :: (ApplyState (PrimOf p) ~ Tree, RepoPatch p)-               => Repository p C(r u t) -> [DarcsFlag] -> FL (PrimOf p) C(u y)-               -> IO (Repository p C(r y t))-applyToWorking (Repo r ropts rf (DarcsRepository t c)) opts patch =-  do-    unless (formatHas NoWorkingDir rf) $-      withCurrentDirectory r $ if Quiet `elem` opts-                               then runSilently $ apply patch-                               else runTolerantly $ apply patch-    return (Repo r ropts rf (DarcsRepository t c))--handlePendForAdd :: forall p C(r u t x y). (RepoPatch p)-                    => Repository p C(r u t) -> PatchInfoAnd p C(x y) -> IO ()-handlePendForAdd (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-handlePendForAdd repo p =-    do-       Sealed pend <- readTentativePending repo-       let effectp = if allFL isSimple pend then crudeSift $ effect p-                                             else effect p-       Sealed newpend <- return $ rmpend (progressFL "Removing from pending:" effectp) (unsafeCoercePStart pend)-       writeTentativePending repo (unsafeCoercePStart newpend)-    where rmpend :: FL (PrimOf p) C(a b) -> FL (PrimOf p) C(a c) -> Sealed (FL (PrimOf p) C(b))-          rmpend NilFL x = Sealed x-          rmpend _ NilFL = Sealed NilFL-          rmpend (x:>:xs) xys | Just ys <- removeFL x xys = rmpend xs ys-          rmpend (x:>:xs) ys =-              case commuteWhatWeCanFL (x:>xs) of-              a:>x':>b -> case rmpend a ys of-                          Sealed ys' -> case commute (invert (x':>:b) :> ys') of-                                        Just (ys'' :> _) -> seal ys''-                                        Nothing -> seal $ invert (x':>:b)+>+ys'-                                        -- DJR: I don't think this-                                        -- last case should be-                                        -- reached, but it also-                                        -- shouldn't lead to-                                        -- corruption.--isSimple :: PrimPatch prim => prim C(x y) -> Bool-isSimple x = primIsHunk x || primIsBinary x || primIsSetpref x--crudeSift :: forall prim C(x y) . PrimPatch prim => FL prim C(x y) -> FL prim C(x y)-crudeSift xs = if allFL isSimple xs then filterFLFL ishunkbinary xs else xs-    where ishunkbinary :: prim C(a b) -> EqCheck C(a b)-          ishunkbinary x | primIsHunk x || primIsBinary x = unsafeCoerceP IsEq-                         | otherwise = NotEq--data HashedVsOld a = HvsO { old, hashed :: a }--decideHashedOrNormal :: Monad m => RepoFormat -> HashedVsOld (m a) -> m a-decideHashedOrNormal rf (HvsO { hashed = h, old = o })-    | formatHas HashedInventory rf = h-    | otherwise = o--data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq )--announceMergeConflicts :: (PrimPatch p, PatchInspect p) => String -> [DarcsFlag] -> FL p C(x y) -> IO Bool-announceMergeConflicts cmd opts resolved_pw =-    case nubsort $ listTouchedFiles resolved_pw of-    [] -> return False-    cfs -> if MarkConflicts `elem` opts || AllowConflicts `elem` opts-              || wantExternalMerge opts /= Nothing-           then do putDocLnWith fancyPrinters $ -                     redText "We have conflicts in the following files:" $$ text (unwords cfs)-                   return True-           else do putDocLnWith fancyPrinters $-                     redText "There are conflicts in the following files:" $$ text (unwords cfs)-                   fail $ "Refusing to "++cmd++" patches leading to conflicts.\n"++-                          "If you would rather apply the patch and mark the conflicts,\n"++-                          "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"++-                          "These can set as defaults by adding\n"++-                          " "++cmd++" mark-conflicts\n"++-                          "to "++darcsdir++"/prefs/defaults in the target repo. "--checkUnrecordedConflicts :: forall p C(t y). RepoPatch p => [DarcsFlag] -> FL (Named p) C(t y) -> IO Bool-checkUnrecordedConflicts opts _ | NoUpdateWorking `elem` opts = return False-checkUnrecordedConflicts opts pc =-    do repository <- identifyDarcsRepository opts "."-       cuc repository-    where cuc :: Repository p C(r u t) -> IO Bool-          cuc r = do Sealed (mpend :: FL (PrimOf p) C(t x)) <- readPending r :: IO (Sealed (FL (PrimOf p) C(t)))-                     case mpend of-                       NilFL -> return False-                       pend ->-                           case merge (fromPrims_ pend :\/: fromPrims_ (concatFL $ mapFL_FL effect pc)) of-                           _ :/\: pend' ->-                               case listConflictedFiles pend' of-                               [] -> return False-                               fs -> do putStrLn ("You have conflicting local changes to:\n"-                                                 ++ unwords fs)-                                        confirmed <- promptYorn "Proceed?"-                                        unless confirmed $-                                             do putStrLn "Cancelled."-                                                exitWith ExitSuccess-                                        return True-          fromPrims_ :: FL (PrimOf p) C(a b) -> FL p C(a b)-          fromPrims_ = fromPrims--tentativelyAddPatch :: (RepoPatch p, ApplyState p ~ Tree)-                    => Repository p C(r u t) -> Compression -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))-tentativelyAddPatch = tentativelyAddPatch_ UpdatePristine--data UpdatePristine = UpdatePristine | DontUpdatePristine deriving Eq---- TODO re-add a safety catch for --dry-run? Maybe using a global, like dryRun--- :: Bool, with dryRun = unsafePerformIO $ readIORef ...-tentativelyAddPatch_ :: (RepoPatch p, ApplyState p ~ Tree)-                     => UpdatePristine -> Repository p C(r u t) -> Compression-                     -> PatchInfoAnd p C(t y) -> IO (Repository p C(r u y))-tentativelyAddPatch_ up r@(Repo dir ropts rf (DarcsRepository t c)) compr p =-    withCurrentDirectory dir $--- Warning:  A do-notation statement discarded a result of type FilePath.-    do _ <- decideHashedOrNormal rf $ HvsO {-          hashed = HashedRepo.addToTentativeInventory c compr p,-          old = fail Old.oldRepoFailMsg}-       when (up == UpdatePristine) $ do debugMessage "Applying to pristine cache..."-                                        applyToTentativePristine r p-                                        debugMessage "Updating pending..."-                                        handlePendForAdd r p-       return (Repo dir ropts rf (DarcsRepository t c))--applyToTentativePristine :: (ApplyState q ~ Tree, Effect q, Patchy q, PrimPatchBase q)-                         => Repository p C(r u t) -> q C(t y) -> IO ()-applyToTentativePristine (Repo dir opts rf (DarcsRepository _ _)) p =-    withCurrentDirectory dir $-    do when (Verbose `elem` opts) $ putDocLn $ text "Applying to pristine..." <+> description p-       decideHashedOrNormal rf $ HvsO {hashed = HashedRepo.applyToTentativePristine p,-                                       old = fail Old.oldRepoFailMsg}---- | This fuction is unsafe because it accepts a patch that works on the tentative--- pending and we don't currently track the state of the tentative pending.-tentativelyAddToPending :: forall p C(r u t x y). RepoPatch p-                        => Repository p C(r u t) -> [DarcsFlag] -> FL (PrimOf p) C(x y) -> IO ()-tentativelyAddToPending (Repo _ opts _ _) _ _-    | NoUpdateWorking `elem` opts = return ()-    | DryRun `elem` opts = bug "tentativelyAddToPending called when --dry-run is specified"-tentativelyAddToPending repo@(Repo dir _ _ _) _ patch =-    withCurrentDirectory dir $ do-      Sealed pend <- readTentativePending repo-      FlippedSeal newpend_ <- return $ newpend (unsafeCoerceP pend :: FL (PrimOf p) C(a x)) patch-      writeTentativePending repo (unsafeCoercePStart newpend_)-      where newpend :: FL prim C(a b) -> FL prim C(b c) -> FlippedSeal (FL prim) C(c)-            newpend NilFL patch_ = flipSeal patch_-            newpend p     patch_ = flipSeal $ p +>+ patch_---- | setTentativePending is basically unsafe.  It overwrites the pending state with a new one, not related to--- the repository state.-setTentativePending :: forall p C(r u t x y). RepoPatch p => Repository p C(r u t) -> FL (PrimOf p) C(x y) -> IO ()-setTentativePending (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-setTentativePending repo@(Repo dir _ _ _) patch = do-    Sealed prims <- return $ siftForPending patch-    withCurrentDirectory dir $ writeTentativePending repo (unsafeCoercePStart prims)---- | prepend is basically unsafe.  It overwrites the pending state--- with a new one, not related to the repository state.-prepend :: forall p C(r u t x y). RepoPatch p =>-           Repository p C(r u t) -> FL (PrimOf p) C(x y) -> IO ()-prepend (Repo _ opts _ _) _ | NoUpdateWorking `elem` opts = return ()-prepend repo@(Repo _ _ _ _) patch =-    do-       Sealed pend <- readTentativePending repo-       Sealed newpend_ <- return $ newpend (unsafeCoerceP pend) patch-       writeTentativePending repo (unsafeCoercePStart $ crudeSift newpend_)-      where newpend :: FL prim C(b c) -> FL prim C(a b) -> Sealed (FL prim C(a))-            newpend NilFL patch_ = seal patch_-            newpend p     patch_ = seal $ patch_ +>+ p--tentativelyRemovePatches :: (RepoPatch p, ApplyState p ~ Tree)-                         => Repository p C(r u t) -> Compression-                         -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))-tentativelyRemovePatches = tentativelyRemovePatches_ UpdatePristine--tentativelyRemovePatches_ :: forall p C(r u t x). (RepoPatch p, ApplyState p ~ Tree)-                          => UpdatePristine-                          -> Repository p C(r u t) -> Compression-                          -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u x))-tentativelyRemovePatches_ up repository@(Repo dir ropts rf (DarcsRepository t c)) compr ps =-    withCurrentDirectory dir $ do-      when (up == UpdatePristine) $ do debugMessage "Adding changes to pending..."-                                       prepend repository $ effect ps-      removeFromUnrevertContext repository ps-      debugMessage "Removing changes from tentative inventory..."-      if formatHas HashedInventory rf-        then do HashedRepo.removeFromTentativeInventory repository compr ps-                when (up == UpdatePristine) $-                     HashedRepo.applyToTentativePristine $-                     progressFL "Applying inverse to pristine" $ invert ps-        else fail Old.oldRepoFailMsg-      return (Repo dir ropts rf (DarcsRepository t c))--tentativelyReplacePatches :: forall p C(r u t x). (RepoPatch p, ApplyState p ~ Tree)-                          => Repository p C(r u t) -> Compression-                          -> FL (PatchInfoAnd p) C(x t) -> IO (Repository p C(r u t))-tentativelyReplacePatches repository compr ps =-    do repository' <- tentativelyRemovePatches_ DontUpdatePristine repository compr ps-       mapAdd repository' ps-  where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j))-        mapAdd r NilFL = return r-        mapAdd r (a:>:as) =-               do r' <- tentativelyAddPatch_ DontUpdatePristine r compr a-                  mapAdd r' as--finalizePending :: (RepoPatch p, ApplyState p ~ Tree)-                => Repository p C(r u t) -> IO ()-finalizePending (Repo dir opts _ rt)-    | NoUpdateWorking `elem` opts =-        withCurrentDirectory dir $ removeFileMayNotExist $ (pendingName rt)-finalizePending repository@(Repo dir _ _ _) = do-  withCurrentDirectory dir $ do-                                Sealed tpend <- readTentativePending repository-                                Sealed new_pending <- return $ siftForPending tpend-                                makeNewPending repository new_pending--finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-finalizeRepositoryChanges (Repo _ opts _ _)-    | DryRun `elem` opts = bug "finalizeRepositoryChanges called when --dry-run specified"-finalizeRepositoryChanges repository@(Repo dir opts rf _)-    | formatHas HashedInventory rf =-        withCurrentDirectory dir $ do debugMessage "Considering whether to test..."-                                      _ <- testTentative repository-                                      debugMessage "Finalizing changes..."-                                      withSignalsBlocked $ do HashedRepo.finalizeTentativeChanges repository (compression opts)-                                                              finalizePending repository-                                      debugMessage "Done finalizing changes..."-    | otherwise = fail Old.oldRepoFailMsg--testTentative :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO (ExitCode)-testTentative = testAny withTentative--testRecorded :: (RepoPatch p, ApplyState p ~ Tree)  => Repository p C(r u t) -> IO (ExitCode)-testRecorded = testAny withRecorded--testAny :: RepoPatch p => (Repository p C(r u t)-                               -> ((AbsolutePath -> IO (ExitCode)) -> IO (ExitCode))-                               -> ((AbsolutePath -> IO (ExitCode)) -> IO (ExitCode)))-        ->  Repository p C(r u t) -> IO (ExitCode)-testAny withD repository@(Repo dir opts _ _) =-    debugMessage "Considering whether to test..." >>-    if not $ Test `elem` opts then return ExitSuccess else withCurrentDirectory dir $-    do let putInfo = if Quiet `elem` opts then const (return ()) else putStrLn-       debugMessage "About to run test if it exists."-       testline <- getPrefval "test"-       case testline of-         Nothing -> return ExitSuccess-         Just testcode ->-             withD repository (wd "testing") $ \_ ->-             do putInfo "Running test...\n"-                when (SetScriptsExecutable `elem` opts) setScriptsExecutable-                ec <- system testcode-                if ec == ExitSuccess-                  then putInfo "Test ran successfully.\n"-                  else putInfo "Test failed!\n"-                return ec-    where wd = if LeaveTestDir `elem` opts then withPermDir else withTempDir--revertRepositoryChanges :: RepoPatch p => Repository p C(r u t) -> IO ()-revertRepositoryChanges (Repo _ opts _ _)-    | DryRun `elem` opts = bug "revertRepositoryChanges called when --dry-run is specified"-revertRepositoryChanges r@(Repo dir opts rf dr@(DarcsRepository _ _)) =-    withCurrentDirectory dir $-    do removeFileMayNotExist (pendingName dr ++ ".tentative")-       Sealed x <- readPending r-       setTentativePending r x-       when (NoUpdateWorking `elem` opts) $ removeFileMayNotExist $ pendingName dr-       decideHashedOrNormal rf $ HvsO { hashed = HashedRepo.revertTentativeChanges,-                                        old = Old.revertTentativeChanges }--patchSetToPatches :: RepoPatch p => PatchSet p C(x y) -> FL (Named p) C(x y)-patchSetToPatches patchSet = mapFL_FL hopefully $ newset2FL patchSet--getUMask :: [DarcsFlag] -> Maybe String-getUMask [] = Nothing-getUMask ((UMask u):_) = Just u-getUMask (_:l) = getUMask l--withUMaskFromOpts :: [DarcsFlag] -> IO a -> IO a-withUMaskFromOpts = maybe id withUMask . getUMask--withGutsOf :: Repository p C(r u t) -> IO a -> IO a-withGutsOf (Repo _ _ rf _) | formatHas HashedInventory rf = id-                           | otherwise = withSignalsBlocked--data RepoJob a-    -- = RepoJob (forall p C(r u) . RepoPatch p => Repository p C(r u r) -> IO a)-    -- TODO: Unbind Tree from RepoJob, possibly renaming existing RepoJob-    = RepoJob (forall p C(r u) . (RepoPatch p, ApplyState p ~ Tree, ApplyState (PrimOf p) ~ Tree)-               => Repository p C(r u r) -> IO a)-    | V1Job (forall C(r u) . Repository (Patch Prim) C(r u r) -> IO a)-    | V2Job (forall C(r u) . Repository (RealPatch Prim) C(r u r) -> IO a)-    | PrimV1Job (forall p C(r u) . (RepoPatch p, ApplyState p ~ Tree, PrimOf p ~ Prim)-               => Repository p C(r u r) -> IO a)--onRepoJob :: RepoJob a-          -> (forall p C(r u) . RepoPatch p => (Repository p C(r u r) -> IO a) -> (Repository p C(r u r) -> IO a))-          -> RepoJob a-onRepoJob (RepoJob job) f = RepoJob (f job)--- onRepoJob (TreeJob job) f = TreeJob (f job)-onRepoJob (V1Job job) f = V1Job (f job)-onRepoJob (V2Job job) f = V2Job (f job)-onRepoJob (PrimV1Job job) f = PrimV1Job (f job)--withRepository :: [DarcsFlag] -> RepoJob a -> IO a-withRepository opts1 = withRepositoryDirectory opts1 "."--withRepositoryDirectory :: forall a. [DarcsFlag] -> String -> RepoJob a -> IO a-withRepositoryDirectory opts1 url repojob =-    do Repo dir opts rf (DarcsRepository t c) <- identifyDarcsRepository opts1 url-       if formatHas Darcs2 rf-         then do debugMessage $ "Identified darcs-2 repo: " ++ dir-                 let therepo = Repo dir opts rf (DarcsRepository t c) :: Repository (RealPatch Prim) C(r u r)-                 case repojob of-                   RepoJob job -> job therepo-                   -- TreeJob job -> job therepo-                   V2Job job -> job therepo-                   PrimV1Job job -> job therepo-                   V1Job _ -> fail "This repository contains darcs v1 patches, but the command requires darcs v2 patches."-         else do debugMessage $ "Identified darcs-1 repo: " ++ dir-                 let therepo = Repo dir opts rf (DarcsRepository t c) :: Repository (Patch Prim) C(r u r)-                 case repojob of-                   RepoJob job -> job therepo-                   -- TreeJob job -> job therepo-                   V1Job job -> job therepo-                   PrimV1Job job -> job therepo-                   V2Job _ -> fail "This repository contains darcs v2 patches, but the command requires darcs v1 patches."--withRepoLock :: [DarcsFlag] -> RepoJob a -> IO a-withRepoLock opts repojob =-    withRepository opts $ onRepoJob repojob $ \job repository@(Repo _ _ rf _) ->-    do maybe (return ()) fail $ writeProblem rf-       let name = "./"++darcsdir++"/lock"-       withUMaskFromOpts opts $ if DryRun `elem` opts-                                then job repository-                                else withLock name (revertRepositoryChanges repository >> job repository)--withRepoReadLock :: [DarcsFlag] -> RepoJob a -> IO a-withRepoReadLock opts repojob =-    withRepository opts $ onRepoJob repojob $ \job repository@(Repo _ _ rf _) ->-    do maybe (return ()) fail $ writeProblem rf-       let name = "./"++darcsdir++"/lock"-       withUMaskFromOpts opts $ if formatHas HashedInventory rf || DryRun `elem` opts-                                then job repository-                                else withLock name (revertRepositoryChanges repository >> job repository)--removeFromUnrevertContext :: forall p C(r u t x). (RepoPatch p, ApplyState p ~ Tree)-                             => Repository p C(r u t) -> FL (PatchInfoAnd p) C(x t) -> IO ()-removeFromUnrevertContext repository ps = do-  Sealed bundle <- unrevert_patch_bundle `catchall` (return $ seal (PatchSet NilRL NilRL))-  remove_from_unrevert_context_ bundle-  where unrevert_impossible =-            do confirmed <- promptYorn "This operation will make unrevert impossible!\nProceed?"-               if confirmed then removeFileMayNotExist (unrevertUrl repository)-                            else fail "Cancelled."-        unrevert_patch_bundle :: IO (SealedPatchSet p C(Origin))-        unrevert_patch_bundle = do pf <- B.readFile (unrevertUrl repository)-                                   case scanBundle pf of-                                     Right foo -> return foo-                                     Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err-        remove_from_unrevert_context_ :: PatchSet p C(Origin z) -> IO ()-        remove_from_unrevert_context_ (PatchSet NilRL NilRL) = return ()-        remove_from_unrevert_context_ bundle =-         do debugMessage "Adjusting the context of the unrevert changes..."-            debugMessage $ "Removing "++ show (lengthFL ps) ++-                                  " patches in removeFromUnrevertContext!"-            ref <- readTentativeRepo repository-            let withSinglet :: Sealed (FL ppp C(xxx))-                            -> (FORALL(yyy) ppp C(xxx yyy) -> IO ()) -> IO ()-                withSinglet (Sealed (x :>: NilFL)) j = j x-                withSinglet _ _ = return ()-            withSinglet (mergeThem ref bundle) $ \h_us ->-                  case commuteRL (reverseFL ps :> h_us) of-                    Nothing -> unrevert_impossible-                    Just (us' :> _) ->-                      case removeFromPatchSet ps ref of-                      Nothing -> unrevert_impossible-                      Just common ->-                          do debugMessage "Have now found the new context..."-                             bundle' <- makeBundleN Nothing common (hopefully us':>:NilFL)-                             writeDocBinFile (unrevertUrl repository) bundle'-            debugMessage "Done adjusting the context of the unrevert changes!"---- | Writes out a fresh copy of the inventory that minimizes the--- amount of inventory that need be downloaded when people pull from--- the repository.------ Specifically, it breaks up the inventory on the most recent tag.--- This speeds up most commands when run remotely, both because a--- smaller file needs to be transfered (only the most recent--- inventory).  It also gives a guarantee that all the patches prior--- to a given tag are included in that tag, so less commutation and--- history traversal is needed.  This latter issue can become very--- important in large repositories.-optimizeInventory :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO ()-optimizeInventory repository@(Repo _ opts rf (DarcsRepository _ c)) =-    do ps <- readRepo repository-       decideHashedOrNormal rf $-           HvsO { hashed = do revertRepositoryChanges repository-                              HashedRepo.writeTentativeInventory c (compression opts) $ deepOptimizePatchset ps-                              finalizeRepositoryChanges repository,-                  old = fail Old.oldRepoFailMsg}--cleanRepository :: RepoPatch p => Repository p C(r u t) -> IO ()-cleanRepository repository@(Repo _ _ rf _) =-    decideHashedOrNormal rf $-    HvsO { hashed = HashedRepo.cleanPristine repository,-           old = fail Old.oldRepoFailMsg}--createPristineDirectoryTree :: RepoPatch p => Repository p C(r u t) -> FilePath -> IO ()-createPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) reldir-    | formatHas HashedInventory rf =-        do createDirectoryIfMissing True reldir-           withCurrentDirectory reldir $ HashedRepo.copyPristine c (compression opts) r (darcsdir++"/hashed_inventory")-    | otherwise = fail Old.oldRepoFailMsg---- fp below really should be FileName--- | Used by the commands dist and diff-createPartialsPristineDirectoryTree :: (FilePathLike fp, RepoPatch p) => Repository p C(r u t) -> [fp] -> FilePath -> IO ()-createPartialsPristineDirectoryTree (Repo r opts rf (DarcsRepository _ c)) prefs dir-    | formatHas HashedInventory rf =-        do createDirectoryIfMissing True dir-           withCurrentDirectory dir $-               HashedRepo.copyPartialsPristine c (compression opts) r (darcsdir++"/hashed_inventory") prefs-    | otherwise = fail Old.oldRepoFailMsg--withRecorded :: RepoPatch p => Repository p C(r u t)-             -> ((AbsolutePath -> IO a) -> IO a) -> (AbsolutePath -> IO a) -> IO a-withRecorded repository mk_dir f-    = mk_dir $ \d -> do createPristineDirectoryTree repository (toFilePath d)-                        f d--withTentative :: forall p a C(r u t). (RepoPatch p, ApplyState p ~ Tree) =>-                 Repository p C(r u t) -> ((AbsolutePath -> IO a) -> IO a)-              -> (AbsolutePath -> IO a) -> IO a-withTentative (Repo dir opts rf (DarcsRepository _ c)) mk_dir f-    | formatHas HashedInventory rf =-        mk_dir $ \d -> do HashedRepo.copyPristine c (compression opts) dir (darcsdir++"/tentative_pristine")-                          f d-withTentative repository@(Repo dir _ _ _) mk_dir f =-    withRecorded repository mk_dir $ \d ->-    do Sealed ps <- read_patches (dir ++ "/"++darcsdir++"/tentative_pristine")-       apply ps-       f d-    where read_patches :: FilePath -> IO (Sealed (FL p C(x)))-          read_patches fil = do ps <- B.readFile fil-                                return $ maybe (seal NilFL) id $ readPatch ps---- | Sets scripts in or below the current directory executable. A script is any file that starts---   with the bytes '#!'. This is used for --set-scripts-executable.-setScriptsExecutable_ :: Patchy p => Maybe (p C(x y)) -> IO ()-setScriptsExecutable_ pw = do-    debugMessage "Making scripts executable"-    tree <- readWorking-    paths <- case pw of-          Just ps -> filterM doesFileExist $ listTouchedFiles ps-          Nothing -> return [ anchorPath "." p | (p, Tree.File _) <- Tree.list tree ]-    let setExecutableIfScript f =-              do contents <- B.readFile f-                 when (BC.pack "#!" `B.isPrefixOf` contents) $ do-                   debugMessage ("Making executable: " ++ f)-                   setExecutable f True-    mapM_ setExecutableIfScript paths---setScriptsExecutable :: IO ()-setScriptsExecutable = setScriptsExecutable_ (Nothing :: Maybe (FL DummyPatch C(x y)))--setScriptsExecutablePatches :: Patchy p => p C(x y) -> IO ()-setScriptsExecutablePatches = setScriptsExecutable_ . Just
src/Darcs/Repository/InternalTypes.hs view
@@ -13,41 +13,124 @@ -- You should have received a copy of the GNU General Public License -- along with this program; if not, write to the Free Software Foundation, -- Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"+module Darcs.Repository.InternalTypes+    ( Repository+    , PristineType(..)+    , AccessType(..)+    , SAccessType(..)+    , repoAccessType+    , repoCache+    , modifyCache+    , repoFormat+    , modifyRepoFormat+    , repoLocation+    , withRepoDir+    , repoPristineType+    , unsafeCoerceRepoType+    , unsafeCoercePatchType+    , unsafeCoerceR+    , unsafeCoerceU+    , unsafeEndTransaction+    , unsafeStartTransaction+    , mkRepo+    ) where -module Darcs.Repository.InternalTypes ( Repository(..), RepoType(..), Pristine(..)-                                      , extractCache, extractOptions, modifyCache-                                      ) where+import Darcs.Prelude -import Data.List ( nub, sortBy )-import Darcs.Repository.Cache ( Cache (..) , compareByLocality )-import Darcs.Flags ( DarcsFlag )-import Darcs.Repository.Format ( RepoFormat )-import Darcs.Patch ( RepoPatch )+import Darcs.Util.Cache ( Cache )+import Darcs.Repository.Format ( RepoFormat, unsafeWriteRepoFormat )+import Darcs.Repository.Paths ( formatPath )+import Darcs.Util.Path ( AbsoluteOrRemotePath, toPath )+import System.Directory ( withCurrentDirectory )+import Unsafe.Coerce ( unsafeCoerce ) -data Pristine+data PristineType   = NoPristine   | PlainPristine   | HashedPristine     deriving ( Show, Eq ) -data Repository (p :: * C(-> * -> *)) C(recordedstate unrecordedstate tentativestate) =-  Repo !String ![DarcsFlag] !RepoFormat !(RepoType p) deriving ( Show )+data AccessType = RO | RW deriving (Eq) -data RepoType (p :: * C(-> * -> *)) = DarcsRepository !Pristine Cache deriving ( Show )+data SAccessType (rt :: AccessType) where+  SRO :: SAccessType 'RO+  SRW :: SAccessType 'RW -extractCache :: Repository p C(r u t) -> Cache-extractCache (Repo _ _ _ (DarcsRepository _ c)) = c+-- |A @Repository@ is a token representing the state of a repository on disk.+-- It is parameterized by+--+-- [@rt@] the access type (whether we are in a transaction or not),+-- [@p@]  the patch type,+-- [@wU@] the witness for the unrecorded state (what's in the working tree now).+-- [@wR@] the witness for+--+--        * the recorded state when outside a transaction, or+--        * the tentative state when inside a transaction.+data Repository (rt :: AccessType) (p :: * -> * -> *) wU wR =+  Repo !String !RepoFormat !PristineType Cache (SAccessType rt) -extractOptions :: Repository p C(r u t) -> [DarcsFlag]-extractOptions (Repo _ opts _ _) = opts+type role Repository nominal nominal nominal nominal --- | 'modifyCache' @repository function@ modifies the cache of---   @repository@ with @function@, remove duplicates and sort the results with 'compareByLocality'.-modifyCache :: FORALL(p r u t) (RepoPatch p)  => Repository p C(r u t) -> (Cache -> Cache) -> Repository p C(r u t)-modifyCache (Repo dir opts rf (DarcsRepository pristine cache)) f = Repo dir opts rf dr-  where dr            = DarcsRepository pristine . cmap ( sortBy compareByLocality . nub ) $ f cache-        cmap g (Ca c) = Ca (g c)+repoLocation :: Repository rt p wU wR -> String+repoLocation (Repo loc _ _ _ _) = loc++-- | Perform an action with the current working directory set to the+-- 'repoLocation'.+withRepoDir :: Repository rt p wU wR -> IO a -> IO a+withRepoDir repo = withCurrentDirectory (repoLocation repo)++repoFormat :: Repository rt p wU wR -> RepoFormat+repoFormat (Repo _ fmt _ _ _) = fmt++repoPristineType :: Repository rt p wU wR -> PristineType+repoPristineType (Repo _ _ pr _ _) = pr++repoCache :: Repository rt p wU wR -> Cache+repoCache (Repo _ _ _ c _) = c++modifyCache :: (Cache -> Cache) -> Repository rt p wU wR -> Repository rt p wU wR+modifyCache g (Repo l f p c a) = Repo l f p (g c) a++repoAccessType :: Repository rt p wU wR -> SAccessType rt+repoAccessType (Repo _ _ _ _ s) = s++unsafeCoerceRepoType :: Repository rt p wU wR -> Repository rt' p wU wR+unsafeCoerceRepoType = unsafeCoerce++unsafeCoercePatchType :: Repository rt p wU wR -> Repository rt p' wU wR+unsafeCoercePatchType = unsafeCoerce++unsafeCoerceR :: Repository rt p wU wR -> Repository rt p wU wR'+unsafeCoerceR = unsafeCoerce++unsafeCoerceU :: Repository rt p wU wR -> Repository rt p wU' wR+unsafeCoerceU = unsafeCoerce++-- | Both 'unsafeStartTransaction' and 'unsafeEndTransaction' are "unsafe" in+-- the sense that they merely "coerce" the type but do not actually perform the+-- steps ('IO' actions) required to start or end a transaction (this is done by+-- 'revertRepositoryChanges' and 'finalizeRepositoryChanges'). Technically this+-- is not an actual coercion like with e.g. 'unsafeCoerceR', due to the+-- singleton typed member, but in practical terms it is no less unsafe, because+-- 'RO' vs. 'RW' changes whether @wR@ refers to the recorded or the tentative+-- state, respectively. In particular, you will get different results if you+-- are inside a transaction and read the patchset with a "coerced" Repository+-- of access type 'RO. The same holds for other state that is modified in a+-- transaction, like the pending patch or the rebase state.+unsafeStartTransaction :: Repository 'RO p wU wR -> Repository 'RW p wU wR+unsafeStartTransaction (Repo l f p c SRO) = Repo l f p c SRW++unsafeEndTransaction :: Repository 'RW p wU wR -> Repository 'RO p wU wR+unsafeEndTransaction (Repo l f p c SRW) = Repo l f p c SRO++mkRepo :: AbsoluteOrRemotePath -> RepoFormat -> PristineType -> Cache -> Repository 'RO p wU wR+mkRepo p f pr c = Repo (toPath p) f pr c SRO++modifyRepoFormat+  :: (RepoFormat -> RepoFormat)+  -> Repository 'RW p wU wR+  -> IO (Repository 'RW p wU wR)+modifyRepoFormat f (Repo l fmt p c a) = do+  let fmt' = f fmt+  unsafeWriteRepoFormat fmt' formatPath+  return $ Repo l fmt' p c a
+ src/Darcs/Repository/Inventory.hs view
@@ -0,0 +1,233 @@+module Darcs.Repository.Inventory+    ( module Darcs.Repository.Inventory.Format+    , readPatchesFromInventoryFile+    , readPatchesFromInventory+    , readSinglePatch+    , readOneInventory+    , writeInventory+    , writePatchIfNecessary+    , writeHashFile+    ) where++import Darcs.Prelude++import Control.Exception ( catch )+import Control.Monad ( unless )+import System.FilePath.Posix ( (</>) )+import System.IO ( hPutStrLn, stderr )+import System.IO.Unsafe ( unsafeInterleaveIO )++import Darcs.Patch ( RepoPatch, readPatch, showPatch )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Info ( PatchInfo, displayPatchInfo, piName )+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , PatchInfoAndG+    , createHashed+    , extractHash+    , info+    , patchInfoAndPatch+    )+import Darcs.Patch.Read ( ReadPatch )+import Darcs.Patch.Set ( Origin, PatchSet(..), SealedPatchSet, Tagged(..) )+import Darcs.Patch.Show ( ShowPatchFor(..) )+import Darcs.Patch.Witnesses.Ordered ( RL(..), mapRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, seal, unseal )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation )+import Darcs.Repository.Inventory.Format+import Darcs.Util.Cache+    ( Cache+    , fetchFileUsingCache+    , peekInCache+    , speculateFilesUsingCache+    , writeFileUsingCache+    )+import Darcs.Util.File ( Cachable(Uncachable), gzFetchFilePS )+import Darcs.Util.Printer ( Doc, renderPS, renderString, text, ($$) )+import Darcs.Util.Progress ( debugMessage, finishedOneIO )++-- | Read a 'PatchSet' starting with a specific inventory inside a 'Repository'.+readPatchesFromInventoryFile+  :: (PatchListFormat p, ReadPatch p)+  => FilePath+  -> Repository rt p wU wR+  -> IO (PatchSet p Origin wS)+readPatchesFromInventoryFile invPath repo = do+  let repodir = repoLocation repo+  Sealed ps <-+    catch+      (readInventoryPrivate (repodir </> invPath) >>=+       readPatchesFromInventory (repoCache repo))+      (\e -> hPutStrLn stderr ("Invalid repository: " ++ repodir) >> ioError e)+  return $ unsafeCoerceP ps++-- | Read a complete 'PatchSet' from a 'Cache', by following the chain of+-- 'Inventory's, starting with the given one.+readPatchesFromInventory :: (PatchListFormat p, ReadPatch p)+                         => Cache+                         -> Inventory+                         -> IO (SealedPatchSet p Origin)+readPatchesFromInventory cache = parseInv+  where+    parseInv :: (PatchListFormat p, ReadPatch p)+             => Inventory+             -> IO (SealedPatchSet p Origin)+    parseInv (Inventory Nothing ris) =+        mapSeal (PatchSet NilRL) <$> readPatchesFromInventoryEntries cache ris+    parseInv (Inventory (Just h) []) =+        -- TODO could be more tolerant and create a larger PatchSet+        error $ "bad inventory " ++ encodeValidHash h ++ " (no tag) in parseInv!"+    parseInv (Inventory (Just h) (t : ris)) = do+        Sealed ts <- delaySealed (read_ts t h)+        Sealed ps <- delaySealed (readPatchesFromInventoryEntries cache ris)+        return $ seal $ PatchSet ts ps++    read_ts :: (PatchListFormat p, ReadPatch p) => InventoryEntry+            -> InventoryHash -> IO (Sealed (RL (Tagged p) Origin))+    read_ts tag0 h0 = do+        contents <- unsafeInterleaveIO $ readTaggedInventory h0+        let is = case contents of+                    Inventory (Just _) (_ : ris0) -> ris0+                    Inventory Nothing ris0 -> ris0+                    Inventory (Just _) [] -> error "inventory without tag!"+        Sealed ts <-+            delaySealed $+                case contents of+                    Inventory (Just h') (t' : _) -> read_ts t' h'+                    Inventory (Just _) [] -> error "inventory without tag!"+                    Inventory Nothing _ -> return $ seal NilRL+        Sealed ps <- delaySealed (readPatchesFromInventoryEntries cache is)+        Sealed tag00 <- read_tag tag0+        return $ seal $ ts :<: Tagged ps tag00 (Just h0)++    read_tag :: (PatchListFormat p, ReadPatch p) => InventoryEntry+             -> IO (Sealed (PatchInfoAnd p wX))+    read_tag (i, h) =+        mapSeal (patchInfoAndPatch i) <$> createHashed h (readSinglePatch cache i)++    readTaggedInventory :: InventoryHash -> IO Inventory+    readTaggedInventory invHash = do+        (fileName, inventory) <- fetchFileUsingCache cache invHash+        case parseInventory inventory of+          Right r -> return r+          Left e -> fail $ unlines [unwords ["parse error in file", fileName],e]++-- | Read patches from a 'Cache' as specified by a list of 'InventoryEntry'.+readPatchesFromInventoryEntries :: ReadPatch np+                                => Cache+                                -> [InventoryEntry]+                                -> IO (Sealed (RL (PatchInfoAndG np) wX))+readPatchesFromInventoryEntries cache ris = read_patches (reverse ris)+  where+    read_patches [] = return $ seal NilRL+    read_patches allis@((i1, h1) : is1) =+        lift2Sealed (\p rest -> rest :<: i1 `patchInfoAndPatch` p) (rp is1)+                    (createHashed h1 (const $ speculateAndParse h1 allis i1))+      where+        rp [] = return $ seal NilRL+        rp [(i, h), (il, hl)] =+            lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)+                        (rp [(il, hl)])+                        (createHashed h+                            (const $ speculateAndParse h (reverse allis) i))+        rp ((i, h) : is) =+            lift2Sealed (\p rest -> rest :<: i `patchInfoAndPatch` p)+                        (rp is)+                        (createHashed h (readSinglePatch cache i))++    lift2Sealed :: (forall wY wZ . q wY wZ -> p wX wY -> r wX wZ)+                -> IO (Sealed (p wX))+                -> (forall wB . IO (Sealed (q wB)))+                -> IO (Sealed (r wX))+    lift2Sealed f iox ioy = do+        Sealed x <- delaySealed iox+        Sealed y <- delaySealed ioy+        return $ seal $ f y x++    speculateAndParse h is i = speculate h is >> readSinglePatch cache i h++    speculate :: PatchHash -> [InventoryEntry] -> IO ()+    speculate pHash is = do+        already_got_one <- peekInCache cache pHash+        unless already_got_one $+            speculateFilesUsingCache cache (map snd is)++-- | We have to unseal and then reseal, otherwise the 'unsafeInterleaveIO' has+-- no effect.+delaySealed :: IO (Sealed (p wX)) -> IO (Sealed (p wX))+delaySealed = fmap (unseal seal) . unsafeInterleaveIO++-- | Read a single patch from a 'Cache', given its 'PatchInfo' and 'PatchHash'.+-- Fails with an error message if the patch file cannot be parsed.+readSinglePatch :: ReadPatch p+                => Cache+                -> PatchInfo -> PatchHash -> IO (Sealed (p wX))+readSinglePatch cache i h = do+    debugMessage $ "Reading patch file for: " ++ piName i+    (fn, ps) <- fetchFileUsingCache cache h+    case readPatch ps of+        Right p -> return p+        Left e -> fail $ unlines+            [ "Couldn't parse file " ++ fn+            , "which is patch"+            , renderString $ displayPatchInfo i+            , e+            ]++readOneInventory :: ReadPatch p+                 => Cache -> FilePath -> IO (Sealed (RL (PatchInfoAndG p) wX))+readOneInventory cache path = do+  Inventory _ invEntries <- readInventoryPrivate path+  readPatchesFromInventoryEntries cache invEntries++-- | Read an 'Inventory' from a file. Fails with an error message if+-- file is not there or cannot be parsed.+readInventoryPrivate :: FilePath -> IO Inventory+readInventoryPrivate path = do+    inv <- skipPristineHash <$> gzFetchFilePS path Uncachable+    case parseInventory inv of+      Right r -> return r+      Left e -> fail $ unlines [unwords ["parse error in file", path],e]++writeInventory :: RepoPatch p => String -> Cache+               -> PatchSet p Origin wX -> IO InventoryHash+writeInventory tediousName cache = go+  where+    go :: RepoPatch p => PatchSet p Origin wX -> IO InventoryHash+    go (PatchSet ts ps) = do+      entries <- sequence $ mapRL (writePatchIfNecessary cache) ps+      content <- write_ts ts entries+      writeHashFile cache content+    write_ts NilRL entries = return $ showInventoryPatches (reverse entries)+    write_ts (tts :<: Tagged tps t maybeHash) entries = do+      -- if the Tagged has a hash, then we know that it has already been+      -- written; otherwise recurse without the tag+      parenthash <- maybe (go (PatchSet tts tps)) return maybeHash+      let parenthash_str = encodeValidHash parenthash+      finishedOneIO tediousName parenthash_str+      tag_entry <- writePatchIfNecessary cache t+      return $+        text ("Starting with inventory:\n" ++ parenthash_str) $$+        showInventoryPatches (tag_entry : reverse entries)++-- | Write a 'PatchInfoAnd' to disk and return an 'InventoryEntry' i.e. the+-- patch info and hash. However, if we patch already contains a hash, assume it+-- has already been written to disk at some point and merely return the info+-- and hash.+writePatchIfNecessary :: RepoPatch p => Cache+                      -> PatchInfoAnd p wX wY -> IO InventoryEntry+writePatchIfNecessary c hp = infohp `seq`+    case extractHash hp of+        Right h -> return (infohp, h)+        Left p ->+          (infohp,) <$>+            writeHashFile c (showPatch ForStorage p)+  where+    infohp = info hp++-- | Wrapper around 'writeFileUsingCache' that takes a 'Doc' instead of a+-- 'ByteString'.+writeHashFile :: ValidHash h => Cache -> Doc -> IO h+writeHashFile c d = writeFileUsingCache c (renderPS d)+
+ src/Darcs/Repository/Inventory/Format.hs view
@@ -0,0 +1,198 @@+module Darcs.Repository.Inventory.Format+    ( Inventory(..)+    , HeadInventory+    , InventoryEntry+    , ValidHash(..) -- re-export+    , decodeValidHash -- re-export+    , encodeValidHash -- re-export+    , InventoryHash+    , PatchHash+    , PristineHash+    , inventoryPatchNames+    , parseInventory+    , parseHeadInventory -- not used+    , showInventory+    , showInventoryPatches+    , showInventoryEntry+    , emptyInventory+    , pokePristineHash+    , peekPristineHash+    , skipPristineHash+    , pristineName+    -- properties+    , prop_inventoryParseShow+    , prop_peekPokePristineHash+    , prop_skipPokePristineHash+    ) where++import Darcs.Prelude++import Control.Applicative ( optional, many )++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC++import Darcs.Patch.Info ( PatchInfo, showPatchInfo, readPatchInfo )+import Darcs.Util.Parser+    ( Parser, char, parse, string, skipSpace )+import Darcs.Patch.Show ( ShowPatchFor(..) )+import Darcs.Util.Printer+    ( Doc, (<+>), ($$), hcat, text, invisiblePS, packedString, renderPS )+import Darcs.Util.ValidHash+    ( InventoryHash+    , PatchHash+    , PristineHash+    , ValidHash(..)+    , calcValidHash+    , decodeValidHash+    , encodeValidHash+    , parseValidHash+    )++-- * Inventories++-- This type and the parser combinators for it aren't actually used. They are+-- here to serve as documentation for the API we would like to use but won't+-- because of efficiency: we want to be able to access the pristine hash+-- without forcing a complete parse of the head inventory. Thus we retain the+-- lower-level peek/poke/skip API for the pristine hash.+type HeadInventory = (PristineHash, Inventory)++data Inventory = Inventory+  { inventoryParent :: Maybe InventoryHash+  , inventoryPatches :: [InventoryEntry]+  } deriving (Eq, Show)++-- The 'String' is the (hashed) patch filename.+type InventoryEntry = (PatchInfo, PatchHash)++inventoryPatchNames :: Inventory -> [String]+inventoryPatchNames = map (encodeValidHash . snd) . inventoryPatches++emptyInventory :: Inventory+emptyInventory = Inventory Nothing []++-- * Parsing++parseHeadInventory :: B.ByteString -> Either String HeadInventory+parseHeadInventory = fmap fst . parse pHeadInv++parseInventory :: B.ByteString -> Either String Inventory+parseInventory = fmap fst . parse pInv++pHeadInv :: Parser HeadInventory+pHeadInv = (,) <$> pPristineHash <*> pInv++pPristineHash :: Parser PristineHash+pPristineHash = do+  string pristineName+  skipSpace+  pHash++pInv :: Parser Inventory+pInv = Inventory <$> pInvParent <*> pInvPatches++pInvParent :: Parser (Maybe InventoryHash)+pInvParent = optional $ do+  string parentName+  skipSpace+  pHash++pHash :: ValidHash h => Parser h+pHash = parseValidHash <* char '\n'++pInvPatches :: Parser [InventoryEntry]+pInvPatches = many pInvEntry++pInvEntry :: Parser InventoryEntry+pInvEntry = do+  info <- readPatchInfo+  skipSpace+  string hashName+  skipSpace+  hash <- pHash+  return (info, hash)++-- * Showing++showInventory :: Inventory -> Doc+showInventory inv =+  showParent (inventoryParent inv) <>+  showInventoryPatches (inventoryPatches inv)++showInventoryPatches :: [InventoryEntry] -> Doc+showInventoryPatches = hcat . map showInventoryEntry++showInventoryEntry :: InventoryEntry -> Doc+showInventoryEntry (pinf, hash) =+  showPatchInfo ForStorage pinf $$+  packedString hashName <+> text (encodeValidHash hash) <> packedString newline++showParent :: Maybe InventoryHash -> Doc+showParent (Just hash) =+  packedString parentName $$ text (encodeValidHash hash) <> packedString newline+showParent Nothing = mempty++-- * Accessing the pristine hash++-- | Replace the pristine hash at the start of a raw, unparsed 'HeadInventory'+-- or add it if none is present.+pokePristineHash :: PristineHash -> B.ByteString -> Doc+pokePristineHash hash inv =+  invisiblePS pristineName <> text (encodeValidHash hash) $$ invisiblePS (skipPristineHash inv)++takeHash :: B.ByteString -> Maybe (PristineHash, B.ByteString)+takeHash input = do+  let (hline,rest) = BC.breakSubstring newline input+  ph <- decodeValidHash (BC.unpack hline)+  return (ph, rest)++peekPristineHash :: B.ByteString -> PristineHash+peekPristineHash inv =+  case tryDropPristineName inv of+    Just rest ->+      case takeHash rest of+        Just (h, _) -> h+        Nothing -> error $ "Bad hash in inventory!"+    Nothing -> calcValidHash B.empty++-- |skipPristineHash drops the 'pristine: HASH' prefix line, if present.+skipPristineHash :: B.ByteString -> B.ByteString+skipPristineHash ps =+  case tryDropPristineName ps of+    Just rest -> B.drop 1 $ BC.dropWhile (/= '\n') rest+    Nothing -> ps++tryDropPristineName :: B.ByteString -> Maybe B.ByteString+tryDropPristineName input =+    if prefix == pristineName then Just rest else Nothing+  where+    (prefix, rest) = B.splitAt (B.length pristineName) input++-- * Key phrases++pristineName :: B.ByteString+pristineName = BC.pack "pristine:"++parentName :: B.ByteString+parentName = BC.pack "Starting with inventory:"++hashName :: B.ByteString+hashName = BC.pack "hash:"++newline :: B.ByteString+newline = BC.pack "\n"++-- * Properties++prop_inventoryParseShow :: Inventory -> Bool+prop_inventoryParseShow inv =+  Right inv == parseInventory (renderPS (showInventory inv))++prop_peekPokePristineHash :: (PristineHash, B.ByteString) -> Bool+prop_peekPokePristineHash (hash, raw) =+  hash == peekPristineHash (renderPS (pokePristineHash hash raw))++prop_skipPokePristineHash :: (PristineHash, B.ByteString) -> Bool+prop_skipPokePristineHash (hash, raw) =+  raw == skipPristineHash (renderPS (pokePristineHash hash raw))
+ src/Darcs/Repository/Job.hs view
@@ -0,0 +1,270 @@+-- Copyright (C) 2002-2004,2007-2008 David Roundy+-- Copyright (C) 2005 Juliusz Chroboczek+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE MultiWayIf #-}++module Darcs.Repository.Job+    ( RepoJob(..)+    , IsPrimV1(..)+    , withRepoLock+    , withOldRepoLock+    , withRepoLockCanFail+    , withRepository+    , withRepositoryLocation+    , withUMaskFlag+    ) where++import Darcs.Prelude++import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.V1 ( RepoPatchV1 )+import Darcs.Patch.V2 ( RepoPatchV2 )+import Darcs.Patch.V3 ( RepoPatchV3 )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )+import Darcs.Patch ( PrimOf )+import Darcs.Patch.Prim.V1 ( Prim )+import Darcs.Patch.RepoPatch ( RepoPatch )++import Darcs.Repository.Flags ( UMask(..), UseCache(..) )+import Darcs.Repository.Format+    ( RepoProperty( Darcs2+                  , Darcs3+                  , HashedInventory+                  )+    , formatHas+    , writeProblem+    )+import Darcs.Repository.Identify ( identifyRepository )+import Darcs.Repository.Transaction( revertRepositoryChanges )+import Darcs.Repository.InternalTypes+    ( Repository+    , AccessType(..)+    , repoFormat+    , unsafeCoercePatchType+    , unsafeStartTransaction+    )+import Darcs.Repository.Paths ( lockPath )+import Darcs.Repository.Rebase+    ( displayRebaseStatus+    , checkOldStyleRebaseStatus+    )+import Darcs.Util.Lock ( withLock, withLockCanFail )++import Darcs.Util.Progress ( debugMessage )++import Control.Monad ( when )+import Control.Exception ( bracket_, finally )+import Data.Constraint ( Dict(..) )++import Foreign.C.String ( CString, withCString )+import Foreign.C.Error ( throwErrno )+import Foreign.C.Types ( CInt(..) )++import Darcs.Util.Tree ( Tree )++withUMaskFlag :: UMask -> IO a -> IO a+withUMaskFlag NoUMask = id+withUMaskFlag (YesUMask umask) = withUMask umask++foreign import ccall unsafe "umask.h set_umask" set_umask+    :: CString -> IO CInt+foreign import ccall unsafe "umask.h reset_umask" reset_umask+    :: CInt -> IO CInt++withUMask :: String+          -> IO a+          -> IO a+withUMask umask job =+    do rc <- withCString umask set_umask+       when (rc < 0) (throwErrno "Couldn't set umask")+       bracket_+           (return ())+           (reset_umask rc)+           job++type Job rt p wR wU a = Repository rt p wU wR -> IO a++type TreePatch p = (RepoPatch p, ApplyState p ~ Tree)+type V1Patch p = p ~ RepoPatchV1 V1.Prim+type V2Patch p = p ~ RepoPatchV2 V2.Prim+type PrimV1Patch p = (TreePatch p, IsPrimV1 (PrimOf p))++type TreePatchJob rt a = forall p wR wU . TreePatch p => Job rt p wR wU a+type V1PatchJob rt a = forall p wR wU . V1Patch p => Job rt p wR wU a+type V2PatchJob rt a = forall p wR wU . V2Patch p => Job rt p wR wU a+type PrimV1PatchJob rt a = forall p wR wU . PrimV1Patch p => Job rt p wR wU a++-- |A @RepoJob@ wraps up an action to be performed with a repository. Because+-- repositories can contain different types of patches, such actions typically+-- need to be polymorphic in the kind of patch they work on. @RepoJob@ is used+-- to wrap up the polymorphism, and the various functions that act on a+-- @RepoJob@ are responsible for instantiating the underlying action with the+-- appropriate patch type.+data RepoJob rt a+    -- TODO: Unbind Tree from RepoJob, possibly renaming existing RepoJob++    -- |The most common 'RepoJob'; the underlying action can accept any patch+    -- whose 'ApplyState' is 'Tree'.+    = RepoJob (TreePatchJob rt a)+    -- |A job that only works on darcs 1 patches+    | V1Job (V1PatchJob rt a)+    -- |A job that only works on darcs 2 patches+    | V2Job (V2PatchJob rt a)+    -- |A job that works on any repository where the patch type @p@ has+    -- 'PrimOf' @p@ = 'Prim'. This was added to support darcsden, which+    -- inspects the internals of V1 prim patches. In future it should be+    -- replaced with a more abstract inspection API as part of 'PrimPatch'.+    | PrimV1Job (PrimV1PatchJob rt a)+    -- |A job that works even if there is an old-style rebase in progress.+    | OldRebaseJob (TreePatchJob rt a)++onRepoJob+  :: RepoJob rt1 a -- original repojob passed to withXxx+  -> (  forall p wR wU+      . TreePatch p+     => (Repository rt1 p wU wR -> IO a)+     -> (Repository rt2 p wU wR -> IO a)+     )+  -> RepoJob rt2 a -- result job takes a Repo rt2+onRepoJob (RepoJob job) f = RepoJob (f job)+onRepoJob (V1Job job) f = V1Job (f job)+onRepoJob (V2Job job) f = V2Job (f job)+onRepoJob (PrimV1Job job) f = PrimV1Job (f job)+onRepoJob (OldRebaseJob job) f = OldRebaseJob (f job)++-- | This is just an internal type to Darcs.Repository.Job for+-- calling runJob in a strongly-typed way+data RepoPatchType p where+  RepoV1 :: RepoPatchType (RepoPatchV1 V1.Prim)+  RepoV2 :: RepoPatchType (RepoPatchV2 V2.Prim)+  RepoV3 :: RepoPatchType (RepoPatchV3 V2.Prim)++-- | Check multiple patch types against the+-- constraints required by most repository jobs+checkTree :: RepoPatchType p -> Dict (ApplyState p ~ Tree)+checkTree RepoV1 = Dict+checkTree RepoV2 = Dict+checkTree RepoV3 = Dict++class IsPrimV1 p where+  toPrimV1 :: p wX wY -> Prim wX wY+instance IsPrimV1 V1.Prim where+  toPrimV1 = V1.unPrim+instance IsPrimV1 V2.Prim where+  toPrimV1 = V2.unPrim++-- | Check multiple patch types against the+-- constraints required by 'PrimV1Job'+checkPrimV1 :: RepoPatchType p -> Dict (IsPrimV1 (PrimOf p))+checkPrimV1 RepoV1 = Dict+checkPrimV1 RepoV2 = Dict+checkPrimV1 RepoV3 = Dict++runJob+  :: forall rt p pDummy wR wU a+   . RepoPatch p+  => RepoPatchType p+  -> Repository rt pDummy wU wR+  -> RepoJob rt a+  -> IO a+runJob patchType repo repojob = do+  -- The actual type the repository should have is only known when+  -- when this function is called, so we need to "cast" it to its proper type+  let+    therepo = unsafeCoercePatchType repo :: Repository rt p wU wR+    incompatible want got = fail $+      "This repository contains darcs "++got++" patches,\+      \ but the command requires darcs "++want++" patches."+  Dict <- return $ checkTree patchType+  let thejob =+        case repojob of+          RepoJob job -> do+            checkOldStyleRebaseStatus therepo+            job therepo+          PrimV1Job job -> do+            Dict <- return $ checkPrimV1 patchType+            checkOldStyleRebaseStatus therepo+            job therepo+          V2Job job ->+            case patchType of+              RepoV2 -> do+                checkOldStyleRebaseStatus therepo+                job therepo+              RepoV1 -> incompatible "v2" "v1"+              RepoV3 -> incompatible "v2" "v3"+          V1Job job ->+            case patchType of+              RepoV1 -> do+                checkOldStyleRebaseStatus therepo+                job therepo+              RepoV2 -> incompatible "v1" "v2"+              RepoV3 -> incompatible "v1" "v3"+          OldRebaseJob job -> job therepo+  thejob `finally` displayRebaseStatus therepo++-- | apply a given RepoJob to a repository in a given url+withRepositoryLocation :: UseCache -> String -> RepoJob 'RO a -> IO a+withRepositoryLocation useCache url repojob = do+  repo <- identifyRepository useCache url+  let rf = repoFormat repo+  if | formatHas Darcs3 rf -> runJob RepoV3 repo repojob+     | formatHas Darcs2 rf -> runJob RepoV2 repo repojob+     | otherwise -> runJob RepoV1 repo repojob++-- | apply a given RepoJob to a repository in the current working directory+withRepository :: UseCache -> RepoJob 'RO a -> IO a+withRepository useCache = withRepositoryLocation useCache "."++-- | Apply a given RepoJob to a repository in the current working directory.+-- However, before doing the job, take the repo lock and initializes a repo+-- transaction.+withRepoLock :: UseCache -> UMask -> RepoJob 'RW a -> IO a+withRepoLock useCache um repojob =+  withLock lockPath $+    withRepository useCache $ onRepoJob repojob $ \job repository -> do+      maybe (return ()) fail $ writeProblem (repoFormat repository)+      withUMaskFlag um $ revertRepositoryChanges repository >>= job++-- | run a lock-taking job in an old-fashion repository.+--   only used by `darcs optimize upgrade`.+withOldRepoLock :: RepoJob 'RW a -> IO a+withOldRepoLock repojob =+  withRepository NoUseCache $ onRepoJob repojob $ \job repository ->+    withLock lockPath $ job $ unsafeStartTransaction repository++-- | Apply a given RepoJob to a repository in the current working directory,+-- taking a lock. If lock not takeable, do nothing. If old-fashioned+-- repository, do nothing. The job must not touch pending or pending.tentative,+-- because there is no call to revertRepositoryChanges. This entry point is+-- currently only used for attemptCreatePatchIndex.+withRepoLockCanFail :: UseCache -> RepoJob 'RO () -> IO ()+withRepoLockCanFail useCache repojob = do+  eitherDone <-+    withLockCanFail lockPath $+      withRepository useCache $ onRepoJob repojob $ \job repository -> do+        let rf = repoFormat repository+        if formatHas HashedInventory rf then do+          maybe (return ()) fail $ writeProblem rf+          job repository+        else+          debugMessage+            "Not doing the job because this is an old-fashioned repository."+  case eitherDone of+    Left  _ -> debugMessage "Lock could not be obtained, not doing the job."+    Right _ -> return ()
− src/Darcs/Repository/LowLevel.hs 
@@ -1,107 +0,0 @@--- Copyright (C) 2002-2004,2007-2008 David Roundy--- Copyright (C) 2005 Juliusz Chroboczek------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Repository.LowLevel-    ( readPending, readTentativePending-    , writeTentativePending-    -- deprecated interface:-    , readNewPending, writeNewPending-    , pendingName )-    where--import Darcs.Repository.InternalTypes ( RepoType(..), Repository(..) )-import Darcs.Patch ( readPatch, writePatch, RepoPatch, PrimOf )-import Darcs.Patch.Read ( ReadPatch(..), bracketedFL )-import Darcs.Patch.ReadMonads ( ParserM )-import Darcs.Patch.Show ( ShowPatchBasic(..) )-import Darcs.Global ( darcsdir )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), mapSeal )-import Darcs.Witnesses.Ordered ( FL(..), mapFL )-import Darcs.Utils ( catchall )-import ByteStringUtils ( gzReadFilePS )-import Printer ( Doc, ($$), text, vcat )--import Control.Applicative-import qualified Data.ByteString as BS ( ByteString, empty )--pendingName :: RepoType p -> String-pendingName (DarcsRepository _ _) = darcsdir++"/patches/pending"---- | Read the contents of pending. CWD should be the repository directory.--- The return type is currently incorrect as it refers to the tentative--- state rather than the recorded state.-readPending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL (PrimOf p) C(t)))-readPending (Repo _ _ _ tp) =-    readPendingFile (pendingName tp)---- |Read the contents of tentative pending. CWD should be the repository directory.-readTentativePending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL (PrimOf p) C(t)))-readTentativePending (Repo _ _ _ tp) =-    readPendingFile (pendingName tp ++ ".tentative")---- |Read the contents of tentative pending. CWD should be the repository directory.-readNewPending :: RepoPatch p => Repository p C(r u t) -> IO (Sealed (FL (PrimOf p) C(t)))-readNewPending (Repo _ _ _ tp) =-    readPendingFile (pendingName tp ++ ".new")--readPendingFile :: ReadPatch prim => String -> IO (Sealed (FL prim C(x)))-readPendingFile name = do-  pend <- gzReadFilePS name `catchall` return BS.empty-  return $ readPendingContents pend---- Wrapper around FL where printed format uses { } except around singletons--- Now that the Show behaviour of FL p can be customised (using showFLBehavior),--- we could instead change the general behaviour of FL Prim; but since the pending--- code can be kept nicely compartmentalised, it's nicer to do it this way.-newtype FLM p C(x y) = FLM { unFLM :: FL p C(x y) }--instance ReadPatch p => ReadPatch (FLM p) where-   readPatch' = mapSeal FLM <$> readMaybeBracketedFL readPatch' '{' '}'--instance ShowPatchBasic p => ShowPatchBasic (FLM p) where-   showPatch = showMaybeBracketedFL showPatch '{' '}' . unFLM--readPendingContents :: ReadPatch prim => BS.ByteString -> Sealed (FL prim C(x))-readPendingContents = maybe (Sealed NilFL) (mapSeal unFLM) . readPatch--writePendingFile :: ShowPatchBasic prim => String -> FL prim C(x y) -> IO ()-writePendingFile name = writePatch name . FLM--readMaybeBracketedFL :: forall m p C(x) . ParserM m =>-                         (FORALL(y) m (Sealed (p C(y)))) -> Char -> Char -> m (Sealed (FL p C(x)))-readMaybeBracketedFL parser pre post =-  bracketedFL parser pre post <|> (mapSeal (:>:NilFL) <$> parser)--showMaybeBracketedFL :: (FORALL(x y) p C(x y) -> Doc) -> Char -> Char -> FL p C(a b) -> Doc-showMaybeBracketedFL _       pre post NilFL         = text [pre] $$ text [post]-showMaybeBracketedFL printer _   _    (p :>: NilFL) = printer p-showMaybeBracketedFL printer pre post ps            = text [pre] $$ vcat (mapFL printer ps) $$ text [post]---- |Read the contents of tentative pending. CWD should be the repository directory.-writeTentativePending :: RepoPatch p => Repository p C(r u t) -> FL (PrimOf p) C(t y) -> IO ()-writeTentativePending (Repo _ _ _ tp) pend =-    writePendingFile (pendingName tp ++ ".tentative") pend---- |Read the contents of new pending. CWD should be the repository directory.-writeNewPending :: RepoPatch p => Repository p C(r u t) -> FL (PrimOf p) C(t y) -> IO ()-writeNewPending (Repo _ _ _ tp) pend =-    writePendingFile (pendingName tp ++ ".new") pend
+ src/Darcs/Repository/Match.hs view
@@ -0,0 +1,72 @@+--  Copyright (C) 2004-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.Repository.Match+    (+      getPristineUpToMatch+    , getOnePatchset+    ) where++import Darcs.Prelude++import Darcs.Patch.Match+    ( rollbackToPatchSetMatch+    , PatchSetMatch(..)+    , getMatchingTag+    , matchAPatchset+    )++import Darcs.Patch.Bundle ( readContextFile )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Set ( Origin, SealedPatchSet, patchSetDrop )++import Darcs.Repository.InternalTypes ( Repository )+import Darcs.Repository.Hashed ( readPatches )+import Darcs.Repository.Pristine ( readPristine )++import Darcs.Util.Tree ( Tree )+import Darcs.Util.Tree.Monad ( virtualTreeIO )++import Darcs.Util.Path ( toFilePath )++-- | Return the pristine tree up to the given 'PatchSetMatch'.+-- In the typical case where the match is closer to the end of the repo than+-- its beginning, this is (a lot) more efficient than applying the result of+-- 'getOnePatchset' to an empty tree.+getPristineUpToMatch :: (RepoPatch p, ApplyState p ~ Tree)+                     => Repository rt p wU wR+                     -> PatchSetMatch+                     -> IO (Tree IO)+getPristineUpToMatch r psm = do+  ps <- readPatches r+  tree <- readPristine r+  snd <$> virtualTreeIO (rollbackToPatchSetMatch psm ps) tree++-- | Return the patches up to the given 'PatchSetMatch'.+getOnePatchset :: RepoPatch p+               => Repository rt p wU wR+               -> PatchSetMatch+               -> IO (SealedPatchSet p Origin)+getOnePatchset repository pm =+  case pm of+    IndexMatch n -> patchSetDrop (n-1) <$> readPatches repository+    PatchMatch m -> matchAPatchset m <$> readPatches repository+    TagMatch m -> getMatchingTag m <$> readPatches repository+    ContextMatch path -> do+      ref <- readPatches repository+      readContextFile ref (toFilePath path)
src/Darcs/Repository/Merge.hs view
@@ -17,102 +17,333 @@ -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, -- Boston, MA 02110-1301, USA. -#include "gadts.h" -module Darcs.Repository.Merge ( tentativelyMergePatches, considerMergeToWorking ) where+module Darcs.Repository.Merge+    ( tentativelyMergePatches+    , considerMergeToWorking+    ) where -import Darcs.Resolution ( standardResolution, externalResolution )-import Darcs.External ( backupByCopying )+import Darcs.Prelude+ import Control.Monad ( when, unless )+import System.Exit ( exitSuccess )+import System.IO.Error+    ( catchIOError+    , ioeGetErrorType+    , isIllegalOperationErrorType+    ) -import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )-import Darcs.Flags-    ( DarcsFlag( AllowConflicts, NoAllowConflicts ), wantExternalMerge, diffingOpts, compression )-import Darcs.Witnesses.Ordered-    ( FL(..), (:\/:)(..), (:/\:)(..), (+>+), mapFL_FL )+import Darcs.Util.Tree( Tree )+import Darcs.Util.File ( backupByCopying )+ import Darcs.Patch-    ( RepoPatch, PrimOf, merge, joinPatches, listTouchedFiles-    , patchcontents, anonymous, fromPrims, effect )+    ( RepoPatch, PrimOf, merge+    , effect+    , listConflictedFiles ) import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Depends( merge2FL )-import Progress( debugMessage )-import Darcs.ProgressPatches( progressFL )-import Darcs.Witnesses.Sealed( Sealed(Sealed), seal )-import Darcs.Repository.InternalTypes( Repository(..) )+import Darcs.Patch.Depends ( slightlyOptimizePatchset )+import Darcs.Patch.Invertible ( mkInvertible )+import Darcs.Patch.Named ( patchcontents, anonymous )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia, hopefully )+import Darcs.Patch.Progress( progressFL, progressRL )+import Darcs.Patch.Set ( PatchSet, Origin, appendPSFL, patchSet2RL )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), RL(..), Fork(..), (:\/:)(..), (:/\:)(..), (+>+), (+<<+)+    , lengthFL, mapFL_FL, concatFL, reverseFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal ) -import Darcs.Repository.State( unrecordedChanges, readUnrecorded )+import Darcs.Repository.Flags+    ( DiffOpts (..)+    , AllowConflicts (..)+    , ResolveConflicts (..)+    , Reorder (..)+    , UpdatePending (..)+    , WantGuiPause (..)+    )+import Darcs.Repository.Hashed+    ( tentativelyAddPatches_+    , tentativelyRemovePatches_+    , UpdatePristine(..)+    )+import Darcs.Repository.Pristine+    ( applyToTentativePristine+    )+import Darcs.Repository.InternalTypes ( AccessType(RW), Repository, repoLocation )+import Darcs.Repository.Pending ( setTentativePending )+import Darcs.Repository.Resolution+    ( StandardResolution(..)+    , announceConflicts+    , haveConflicts+    , externalResolution+    , patchsetConflictResolutions+    , standardResolution+    )+import Darcs.Repository.State ( unrecordedChanges, readUnrecorded ) -import Darcs.Repository.Internal-    ( announceMergeConflicts, checkUnrecordedConflicts-    , MakeChanges(..), setTentativePending-    , tentativelyAddPatch_, applyToTentativePristine, UpdatePristine(..) )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.Path ( anchorPath, displayPath )+import Darcs.Util.Progress( debugMessage )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.Printer ( redText, vcat ) -import Storage.Hashed.Tree( Tree )+data MakeChanges = MakeChanges | DontMakeChanges deriving ( Eq ) -tentativelyMergePatches_ :: forall p C(r u t y x). (RepoPatch p, ApplyState p ~ Tree)+{- 'tentativelyMergePatches' is not easy to understand by just staring at+the code. So here is an in-depth explanation.++We start out at the state X at which our repo and the their repo deviate,+assuming any patches common to both repos have first been commuted to the+common part before X. So X is the intermediate state that is existentially+hiddden inside the Fork we get passed as argument. R is our recorded state+and Y is the recorded state of their repo.++ Y       R+  \     /+ them  us+    \ /+     X+     |+   common+     |+     O++We will elide the common part from now on. It doesn't change and we only+pass it unmodified to standardResolution, see below.++The easy part is to merge the local patches (us) with the remote ones+(them), giving us them' and us'.++     T+    / \+  us'  them'+  /     \+ Y       R+  \     /+ them  us+    \ /+     X+++We can ignore us' and just add them' on top of us (which are already in our+repo), unless --reorder-patches is in effect, in which case we remove us and+then first add them and afterwards us'. The new state on top is T which+stands for the new /tentative/ state i.e. what will become the recorded+state after we finalize our changes.++But we're not done yet: we must also adapt the pending patch and the working+tree. Note that changing the working tree is not done in this procedure, we+merely return a list of prims to apply to working. Let us add the difference+between pristine and working, which we call pw, to the picture.++     T       U+    / \     /+ us' them' pw+  /     \ /+ Y       R+  \     /+ them  us+    \ /+     X++It is easy to see now that we must merge pw with them', as both start at the+(old) recorded state. This gives us pw' and them''.++         U'+        / \+      pw' them''+      /     \+     T       U+    / \     /+ us' them' pw+  /     \ /+ Y       R+  \     /+ them  us+    \ /+     X++Since U is our unrecorded state, them'' leads us from our old unrecorded+state to the new one, so this is what we will return (if there are no+conflicts; if there are, see below).++What about the pending patch? It starts at R and goes half-way toward U+since it is a prefix of pw. The new pending should start at T and go+half-way toward the new working state U'. Instead of adapting the old+pending patch, we set the new pending patch to pw', ignoring the old one.+This relies on sifting to commute out and drop the parts that need not be in+the pending patch, which is done when we finalize the tentative changes.++Up to now we did not consider conflicts. Any new conflicts arising from the+merges we made so far must be "resolved", that is, marked for manual+resolution, if possible, or at least reported to the user. We made two+merges, one with us and one with pw. It is important now to realize that our+existing repo, and in particular the sequence us, could already be+conflicted. Our job is to resolve only /new/ conflicts and not any+unresolved conflicts that were already in our repo. So, from the rightmost+branch of our double merge us+>+pw+>+them'', we should /not/ resolve us. And+since the original pw cannot be conflicted (it consists of prim patches+only) we can disregard it. This leaves only them'' which is what we pass to+standardResolution to generate the markup, along with its full context,+consisting of (common +>+ us +>+ pw).++The resulting "resolution" goes on top, leading to our final unrecorded+state U'':++         U''+         |+        res+         |+         U'+        / \+      pw' them''+      /     \+     T       U+    / \     /+ us' them' pw+  /     \ /+ Y       R+  \     /+ them  us+    \ /+     X++In case the patches we pull are in conflict with local /unrecorded/ changes+(i.e. pw), we want to warn the user about that and allow them to cancel the+operation. The reason is that it is hard to reconstruct the original+unrecorded changes when they are messed up with conflict resolution markup.+To see if this is the case we check whether pw' has conflicts. As an extra+precaution we backup any conflicted files, so the user can refer to them to+restore things or compare in a diff viewer.++The patches we return are what we need to update U to U'' i.e. them''+>+res.+The new pending patch starts out at the new tentative state, so as explained+above, we set it to pw'+>+res, and again rely on sifting to commute out and+drop anything we don't need.++TODO: We should return a properly coerced @Repository 'RW p wU wR@.+-}++tentativelyMergePatches_ :: (RepoPatch p, ApplyState p ~ Tree)                          => MakeChanges-                         -> Repository p C(r u t) -> String -> [DarcsFlag]-                         -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y)-                         -> IO (Sealed (FL (PrimOf p) C(u)))-tentativelyMergePatches_ mc r cmd opts usi themi =-  do let us = mapFL_FL hopefully usi-         them = mapFL_FL hopefully themi-     Sealed pc <- return $ merge2FL (progressFL "Merging us" usi) (progressFL "Merging them" themi)-     pend <- unrecordedChanges (diffingOpts opts) r Nothing-     anonpend <- n2pia `fmap` anonymous (fromPrims pend)-     pend' :/\: pw <- return $ merge (pc :\/: anonpend :>: NilFL)-     let pwprim = joinPatches $ progressFL "Examining patches for conflicts" $-                                mapFL_FL (patchcontents . hopefully) pw-     Sealed standard_resolved_pw <- return $ standardResolution pwprim-     debugMessage "Checking for conflicts..."-     unless (AllowConflicts `elem` opts || NoAllowConflicts `elem` opts) $-       mapM_ backupByCopying $ listTouchedFiles standard_resolved_pw-     debugMessage "Announcing conflicts..."-     have_conflicts <- announceMergeConflicts cmd opts standard_resolved_pw-     debugMessage "Checking for unrecorded conflicts..."-     have_unrecorded_conflicts <- checkUnrecordedConflicts opts $ mapFL_FL hopefully pc-     debugMessage "Reading working directory..."-     working <- readUnrecorded r Nothing-     debugMessage "Working out conflicts in actual working directory..."-     Sealed pw_resolution <--          case (wantExternalMerge opts, have_conflicts || have_unrecorded_conflicts) of-          (Nothing,_) -> return $ if AllowConflicts `elem` opts-                                  then seal NilFL-                                  else seal standard_resolved_pw-          (_,False) -> return $ seal standard_resolved_pw-          (Just c, True) -> externalResolution working c opts-                                                    (effect us +>+ pend)-                                                    (effect them) pwprim-     debugMessage "Applying patches to the local directories..."-     when (mc == MakeChanges) $-          do let doChanges :: FL (PatchInfoAnd p) C(x t) -> IO ()-                 doChanges NilFL = applyps r themi-                 doChanges _     = applyps r pc-             doChanges usi-             setTentativePending r (effect pend' +>+ pw_resolution)-     return $ seal (effect pwprim +>+ pw_resolution)-  where mapAdd :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO (Repository p C(m l j))-        mapAdd repo NilFL = return repo-        mapAdd repo (a:>:as) =-               do repo' <- tentativelyAddPatch_ DontUpdatePristine repo (compression opts) a-                  mapAdd repo' as-        applyps :: Repository p C(m l i) -> FL (PatchInfoAnd p) C(i j) -> IO ()-        applyps repo ps = do debugMessage "Adding patches to inventory..."--- Warning:  A do-notation statement discarded a result of type Repository p m l j.-                             _ <- mapAdd repo ps-                             debugMessage "Applying patches to pristine..."-                             applyToTentativePristine repo ps+                         -> Repository 'RW p wU wR -> String+                         -> AllowConflicts+                         -> WantGuiPause+                         -> Reorder+                         -> DiffOpts+                         -> Fork (PatchSet p)+                                 (FL (PatchInfoAnd p))+                                 (FL (PatchInfoAnd p)) Origin wR wY+                         -> IO (Sealed (FL (PrimOf p) wU))+tentativelyMergePatches_ mc _repo cmd allowConflicts wantGuiPause+  reorder diffingOpts@DiffOpts{..} (Fork context us them) = do+    (them' :/\: us') <-+      return $ merge (progressFL "Merging us" us :\/: progressFL "Merging them" them)+    pw <- unrecordedChanges diffingOpts _repo Nothing+    -- Note: we use anonymous here to wrap the unrecorded changes.+    -- This is benign because we only retain the effect of the results+    -- of the merge (pw' and them'').+    anonpw <- n2pia `fmap` anonymous pw+    pw' :/\: them'' <- return $ merge (them' :\/: anonpw :>: NilFL)+    let them''content = concatFL $ mapFL_FL (patchcontents . hopefully) them''+        no_conflicts_in_them =+          not $ haveConflicts $ patchsetConflictResolutions $+          slightlyOptimizePatchset (appendPSFL context them)+        conflicts =+          let us'' = us' +>+ pw' in+          -- This optimization is valid only if @them@ didn't have+          -- (unresolved) conflicts in the first place+          if lengthFL us'' < lengthFL them'' && no_conflicts_in_them then+            standardResolution+              (patchSet2RL context +<<+ them)+              (progressRL "Examining patches for conflicts" $ reverseFL us'')+          else+            standardResolution+              (patchSet2RL context +<<+ us :<: anonpw)+              (progressRL "Examining patches for conflicts" $ reverseFL them'') +    debugMessage "Checking for conflicts..."+    when (allowConflicts == YesAllowConflicts MarkConflicts) $+        mapM_ backupByCopying $+        map (anchorPath (repoLocation _repo)) $+        conflictedPaths conflicts++    debugMessage "Announcing conflicts..."+    have_conflicts <- announceConflicts cmd allowConflicts conflicts++    debugMessage "Checking for unrecorded conflicts..."+    let pw'content = concatFL $ mapFL_FL (patchcontents . hopefully) pw'+    case listConflictedFiles pw'content of+        [] -> return ()+        fs -> do+          ePutDocLn $ vcat $ map redText $+            "You have conflicting unrecorded changes to:" : map displayPath fs+          -- we catch "hIsTerminalDevice: illegal operation (handle is closed)"+          -- which can be thrown when we apply patches remotely (i.e. during push)+          confirmed <- promptYorn "Proceed?" `catchIOError` (\e ->+            if isIllegalOperationErrorType (ioeGetErrorType e)+              then return True+              else ioError e)+          unless confirmed $ do+            putStrLn "Cancelled."+            exitSuccess++    debugMessage "Reading working tree..."+    working <- readUnrecorded _repo withIndex Nothing++    debugMessage "Working out conflict markup..."+    Sealed resolution <-+      if have_conflicts then+        case allowConflicts of+          YesAllowConflicts (ExternalMerge merge_cmd) ->+            externalResolution diffAlg working merge_cmd wantGuiPause+              (effect us +>+ pw) (effect them) them''content+          YesAllowConflicts NoResolveConflicts -> return $ seal NilFL+          YesAllowConflicts MarkConflicts -> return $ mangled conflicts+          NoAllowConflicts -> error "impossible" -- was handled in announceConflicts+      else return $ seal NilFL++    debugMessage "Adding patches to the inventory and writing new pending..."+    when (mc == MakeChanges) $ do+        applyToTentativePristine _repo $ mkInvertible $+          progressFL "Applying patches to pristine" them'+        -- these two cases result in the same trees (that's the idea of+        -- merging), so we only operate on the set of patches and do the+        -- adaption of pristine and pending in the common code below+        _repo <- case reorder of+            NoReorder -> do+                tentativelyAddPatches_ DontUpdatePristine _repo NoUpdatePending them'+            Reorder -> do+                -- we do not actually remove any effect in the end, so+                -- it would be wrong to update the unrevert bundle or+                -- the working tree or pending+                _repo <- tentativelyRemovePatches_ DontUpdatePristineNorRevert _repo+                          NoUpdatePending us+                _repo <- tentativelyAddPatches_ DontUpdatePristine _repo+                          NoUpdatePending them+                tentativelyAddPatches_ DontUpdatePristine _repo NoUpdatePending us'+        setTentativePending _repo (effect pw' +>+ resolution)+    return $ seal (effect them''content +>+ resolution)+ tentativelyMergePatches :: (RepoPatch p, ApplyState p ~ Tree)-                        => Repository p C(r u t) -> String -> [DarcsFlag]-                        -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y)-                        -> IO (Sealed (FL (PrimOf p) C(u)))+                        => Repository 'RW p wU wR -> String+                        -> AllowConflicts+                        -> WantGuiPause+                        -> Reorder+                        -> DiffOpts+                        -> Fork (PatchSet p)+                                (FL (PatchInfoAnd p))+                                (FL (PatchInfoAnd p)) Origin wR wY+                        -> IO (Sealed (FL (PrimOf p) wU)) tentativelyMergePatches = tentativelyMergePatches_ MakeChanges - considerMergeToWorking :: (RepoPatch p, ApplyState p ~ Tree)-                       => Repository p C(r u t) -> String -> [DarcsFlag]-                       -> FL (PatchInfoAnd p) C(x t) -> FL (PatchInfoAnd p) C(x y)-                       -> IO (Sealed (FL (PrimOf p) C(u)))+                       => Repository 'RW p wU wR -> String+                       -> AllowConflicts+                       -> WantGuiPause+                       -> Reorder+                       -> DiffOpts+                       -> Fork (PatchSet p)+                               (FL (PatchInfoAnd p))+                               (FL (PatchInfoAnd p)) Origin wR wY+                       -> IO (Sealed (FL (PrimOf p) wU)) considerMergeToWorking = tentativelyMergePatches_ DontMakeChanges-
− src/Darcs/Repository/Motd.hs 
@@ -1,40 +0,0 @@---  Copyright (C) 2002-2004 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Repository.Motd (getMotd, showMotd) where--import Control.Monad ( unless )-import Darcs.Flags ( DarcsFlag( Quiet, XMLOutput ) )-import Darcs.External ( fetchFilePS, Cachable(..) )-import Darcs.Global ( darcsdir )-import qualified Data.ByteString as B (null, hPut, empty, ByteString)-import Darcs.Utils ( catchall )-import System.IO ( stdout )---- | Fetch and return the message of the day for a given repository.-getMotd :: String -> IO B.ByteString-getMotd repo = fetchFilePS (repo++"/"++darcsdir++"/prefs/motd") (MaxAge 600)-                     `catchall` return B.empty---- | Display the message of the day for a given repository,---   unless either the 'XMLOutput' or the 'Quiet' flags are passed in-showMotd :: [DarcsFlag] -> String -> IO ()-showMotd opts repo = unless (Quiet `elem` opts || XMLOutput `elem` opts) $ do-  motd <- getMotd repo-  unless (B.null motd)-      $ do B.hPut stdout motd-           putStrLn "**********************"
src/Darcs/Repository/Old.hs view
@@ -15,17 +15,14 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. -{-# LANGUAGE CPP, ScopedTypeVariables #-}--#include "gadts.h"- module Darcs.Repository.Old ( readOldRepo,-                              revertTentativeChanges, oldRepoFailMsg ) where+                              oldRepoFailMsg ) where -import Prelude hiding ( catch )+import Darcs.Prelude -import Progress ( debugMessage, beginTedious, endTedious, finishedOneIO )-import Darcs.RepoPath ( ioAbsoluteOrRemote, toPath )+import Control.Applicative ( many )+import Darcs.Util.Progress ( debugMessage, beginTedious, endTedious, finishedOneIO )+import Darcs.Util.Path ( ioAbsoluteOrRemote, toPath ) import System.IO ( hPutStrLn, stderr ) import System.IO.Unsafe ( unsafeInterleaveIO ) import System.FilePath.Posix ( (</>) )@@ -33,104 +30,126 @@                          patchInfoAndPatch,                          actually, unavailable ) -import qualified Data.ByteString.Char8 as BC (break, pack)--import Darcs.Patch ( RepoPatch, Named,-                     readPatch )+import qualified Data.ByteString as B ( ByteString )+import qualified Data.ByteString.Char8 as BC ( break, pack, unpack ) -import Darcs.Witnesses.Ordered ( RL(..) )-import Darcs.Patch.Info ( PatchInfo, makeFilename, readPatchInfos )-import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.External ( gzFetchFilePS, Cachable(..),-                        cloneFile )-import Darcs.Lock ( writeBinFile )-import Darcs.Global ( darcsdir )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal )+import Darcs.Patch ( RepoPatch, Named, readPatch )+import qualified Darcs.Util.Parser as P ( parse )+import Darcs.Patch.Witnesses.Ordered ( RL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unseal, mapSeal )+import Darcs.Patch.Info ( PatchInfo(..), makePatchname, readPatchInfo, displayPatchInfo )+import Darcs.Patch.Set ( PatchSet(..), Tagged(..), SealedPatchSet, Origin )+import Darcs.Util.File+    ( gzFetchFilePS+    , Cachable(..)+    )+import Darcs.Util.Printer ( renderString )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Hash ( sha1PS )+import Darcs.Util.IsoDate ( readUTCDateOldFashioned, showIsoDateTime )  import Control.Exception ( catch, IOException ) -#include "impossible.h"--readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet p C(Origin))-readOldRepo d = do-  realdir <- toPath `fmap` ioAbsoluteOrRemote d-  let k = "Reading inventory of repository "++d-  beginTedious k-  readRepoPrivate k realdir "inventory" `catch`+readOldRepo :: RepoPatch p => String -> IO (SealedPatchSet p Origin)+readOldRepo repo_dir = do+  realdir <- toPath `fmap` ioAbsoluteOrRemote repo_dir+  let task = "Reading inventory of repository "++repo_dir+  beginTedious task+  readRepoPrivate task realdir "inventory" `catch`                         (\e -> do hPutStrLn stderr ("Invalid repository:  " ++ realdir)                                   ioError e) -readRepoPrivate :: RepoPatch p => String -> FilePath -> FilePath -> IO (SealedPatchSet p C(Origin))-readRepoPrivate k d iname = do-    i <- gzFetchFilePS (d </> "_darcs" </> iname) Uncachable-    finishedOneIO k iname-    let parse inf = parse2 inf $ d </> "_darcs/patches" </> makeFilename inf-        (mt, is) = case BC.break ((==) '\n') i of-                   (swt,pistr) | swt == BC.pack "Starting with tag:" ->-                                     case readPatchInfos pistr of-                                     (t:ids) -> (Just t,reverse ids)-                                     [] -> bug "bad inventory in readRepoPrivate"-                   _ -> (Nothing, reverse $ readPatchInfos i)+readRepoPrivate :: RepoPatch p+                => String -> FilePath -> FilePath -> IO (SealedPatchSet p Origin)+readRepoPrivate task repo_dir inventory_name = do+    inventory <- gzFetchFilePS (repo_dir </> darcsdir </> inventory_name) Uncachable+    finishedOneIO task inventory_name+    let parse inf = parse2 inf $ repo_dir </> darcsdir </> "patches" </> makeFilename inf+    (mt, is) <- readInventory inventory     Sealed ts <- unseal seal `fmap` unsafeInterleaveIO (read_ts parse mt)     Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is)-    return $ seal (PatchSet ps ts)+    return $ seal (PatchSet ts ps)     where read_ts :: RepoPatch p =>-                     (FORALL(b) PatchInfo -> IO (Sealed (PatchInfoAnd p C(b))))-                  -> Maybe PatchInfo -> IO (Sealed (RL (Tagged p) C(Origin)))-          read_ts _ Nothing = do endTedious k+                     (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd p wB)))+                  -> Maybe PatchInfo -> IO (Sealed (RL (Tagged p) Origin))+          read_ts _ Nothing = do endTedious task                                  return $ seal NilRL           read_ts parse (Just tag0) =-              do debugMessage $ "Looking for inventory for:\n"++ show tag0+              do debugMessage $ "Looking for inventory for:\n"++ renderString (displayPatchInfo tag0)                  i <- unsafeInterleaveIO $-                      do x <- gzFetchFilePS (d</>"_darcs/inventories"</>makeFilename tag0) Uncachable-                         finishedOneIO k (show tag0)+                      do x <- gzFetchFilePS (repo_dir </> darcsdir </> "inventories" </> makeFilename tag0) Uncachable+                         finishedOneIO task (renderString (displayPatchInfo tag0))                          return x-                 let (mt, is) = case BC.break ((==) '\n') i of-                                (swt,pistr) | swt == BC.pack "Starting with tag:" ->-                                                case readPatchInfos pistr of-                                                (t:ids) -> (Just t,reverse ids)-                                                [] -> bug "bad inventory in readRepoPrivate"-                                _ -> (Nothing, reverse $ readPatchInfos i)+                 (mt, is) <- readInventory i                  Sealed ts <- fmap (unseal seal) $ unsafeInterleaveIO $ read_ts parse mt                  Sealed ps <- unseal seal `fmap` unsafeInterleaveIO (read_patches parse is)                  Sealed tag00 <-  parse tag0 `catch`                                   \(e :: IOException) ->                                         return $ seal $                                         patchInfoAndPatch tag0 $ unavailable $ show e-                 return $ seal $ Tagged tag00 Nothing ps :<: ts-          parse2 :: RepoPatch p => PatchInfo -> FilePath-                                -> IO (Sealed (PatchInfoAnd p C(x)))+                 return $ seal $ ts :<: Tagged ps tag00 Nothing+          parse2 :: RepoPatch p+                 => PatchInfo -> FilePath+                 -> IO (Sealed (PatchInfoAnd p wX))           parse2 i fn = do ps <- unsafeInterleaveIO $ gzFetchFilePS fn Cachable                            return $ patchInfoAndPatch i                              `mapSeal` hopefullyNoParseError (toPath fn) (readPatch ps)-          hopefullyNoParseError :: String -> Maybe (Sealed (Named a1dr C(x)))-                                -> Sealed (Hopefully (Named a1dr) C(x))-          hopefullyNoParseError _ (Just (Sealed x)) = seal $ actually x-          hopefullyNoParseError s Nothing = seal $ unavailable $ "Couldn't parse file "++s+          hopefullyNoParseError :: String -> Either String (Sealed (Named a1dr wX))+                                -> Sealed (Hopefully (Named a1dr) wX)+          hopefullyNoParseError _ (Right (Sealed x)) = seal $ actually x+          hopefullyNoParseError s (Left e) =+              seal $ unavailable $ unlines ["Couldn't parse file " ++ s, e]           read_patches :: RepoPatch p =>-                          (FORALL(b) PatchInfo -> IO (Sealed (PatchInfoAnd p C(b))))-                       -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) C(x)))+                          (forall wB . PatchInfo -> IO (Sealed (PatchInfoAnd p wB)))+                       -> [PatchInfo] -> IO (Sealed (RL (PatchInfoAnd p) wX))           read_patches _ [] = return $ seal NilRL           read_patches parse (i:is) =-              lift2Sealed (:<:)+              lift2Sealed (flip (:<:))                           (read_patches parse is)                           (parse i `catch` \(e :: IOException) ->                            return $ seal $ patchInfoAndPatch i $ unavailable $ show e)-          lift2Sealed :: (FORALL(y z) q C(y z) -> pp C(y) -> r C(z))-                      -> IO (Sealed pp) -> (FORALL(b) IO (Sealed (q C(b)))) -> IO (Sealed r)+          lift2Sealed :: (forall wY wZ . q wY wZ -> pp wY -> r wZ)+                      -> IO (Sealed pp) -> (forall wB . IO (Sealed (q wB))) -> IO (Sealed r)           lift2Sealed f iox ioy = do Sealed x <- unseal seal `fmap` unsafeInterleaveIO iox                                      Sealed y <- unseal seal `fmap` unsafeInterleaveIO ioy                                      return $ seal $ f y x --revertTentativeChanges :: IO ()-revertTentativeChanges =-    do cloneFile (darcsdir++"/inventory") (darcsdir++"/tentative_inventory")-       writeBinFile (darcsdir++"/tentative_pristine") ""- oldRepoFailMsg :: String-oldRepoFailMsg = "ERROR: repository upgrade required, try `darcs optimize --upgrade`\n"+oldRepoFailMsg = "ERROR: repository upgrade required, try `darcs optimize upgrade`\n"               ++ "See http://wiki.darcs.net/OF for more details."++-- | This makes darcs-1 (non-hashed repos) filenames.+--+-- The name consists of three segments:+--+--  * timestamp (ISO8601-compatible yyyymmmddHHMMSS;+--    note that the old-fashioned (non-hashed) format expects this date to+--    be exactly as in the patch, /ignoring/ any timezone info,+--    which is why we use 'readUTCDateOldFashioned' here)+--+--  * SHA1 hash of the author+--+--  * SHA1 hash of the patch name, author, date, log, and \"inverted\"+--    flag.+makeFilename :: PatchInfo -> String+makeFilename pi = showIsoDateTime d++"-"++sha1_a++"-"++ (show $ makePatchname pi) ++ ".gz"+    where d = readUTCDateOldFashioned $ BC.unpack $ _piDate pi+          sha1_a = take 5 $ show $ sha1PS $ _piAuthor pi++readPatchInfos :: B.ByteString -> IO [PatchInfo]+readPatchInfos inv =+    case P.parse (many readPatchInfo) inv of+        Right (r, _) -> return r+        Left e -> fail $ unlines ["cannot parse inventory:", e]++readInventory :: B.ByteString -> IO (Maybe PatchInfo, [PatchInfo])+readInventory inv =+    case BC.break ('\n' ==) inv of+        (swt,pistr) | swt == BC.pack "Starting with tag:" -> do+            infos <- readPatchInfos pistr+            case infos of+                (t:ids) -> return (Just t, reverse ids)+                [] -> fail $ unlines ["empty parent inventory:", BC.unpack pistr]+        _ -> do+            infos <- readPatchInfos inv+            return (Nothing, reverse infos)
+ src/Darcs/Repository/Packs.hs view
@@ -0,0 +1,198 @@+{-|+License : GPL-2++Packs are an optimization that enable faster repository cloning over HTTP.+A pack is actually a @tar.gz@ file that contains many files that would otherwise+have to be transfered one by one (which is much slower over HTTP).++Two packs are created at the same time by 'createPacks':++  1. The basic pack, contains the pristine tree.+  2. The patches pack, contains the set of patches of the repository.++The paths of these files are @_darcs\/packs\/basic.tar.gz@ and+@_darcs\/packs\/patches.tar.gz@. There is also @_darcs\/packs\/pristine@ which+indicates the pristine hash at the moment of the creation of the packs. This+last file is useful to determine whether the basic pack is in sync with the+current pristine of the repository.+-}++module Darcs.Repository.Packs+    ( fetchAndUnpackBasic+    , fetchAndUnpackPatches+    , packsDir+    , createPacks+    ) where++import qualified Codec.Archive.Tar as Tar+import Codec.Archive.Tar.Entry ( fileEntry, toTarPath )+import Codec.Compression.GZip as GZ ( compress, decompress )+import Control.Concurrent.Async ( withAsync )+import Control.Exception ( Exception, IOException, throwIO, catch, finally )+import Control.Monad ( forM_, when )+import System.IO.Error ( isAlreadyExistsError )+import System.IO.Unsafe ( unsafeInterleaveIO )++import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.List ( isPrefixOf, sort )++import System.Directory ( createDirectoryIfMissing+                        , renameFile+                        , removeFile+                        , doesFileExist+                        , getModificationTime+                        , listDirectory+                        )+import System.FilePath ( (</>)+                       , (<.>)+                       , takeFileName+                       , splitPath+                       , joinPath+                       , takeDirectory+                       )+import System.Posix.Files ( createLink )++import Darcs.Prelude++import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Cache+    ( Cache+    , bucketFolder+    , closestWritableDirectory+    , fetchFileUsingCache+    )+import Darcs.Util.File ( Cachable(..), fetchFileLazyPS, withTemp )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Progress ( debugMessage, progressList )+import Darcs.Util.ValidHash ( InventoryHash, PatchHash, encodeValidHash )++import Darcs.Patch ( RepoPatch )+import Darcs.Patch.PatchInfoAnd ( extractHash )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Patch.Witnesses.Ordered ( mapFL )+import Darcs.Patch.Set ( patchSet2FL )++import Darcs.Repository.Traverse ( listInventories )+import Darcs.Repository.InternalTypes ( Repository, AccessType(RW), withRepoDir )+import Darcs.Repository.Hashed ( readPatches )+import Darcs.Repository.Paths+    ( hashedInventoryPath+    , inventoriesDirPath+    , patchesDirPath+    , pristineDirPath+    )+import Darcs.Repository.Pristine ( readHashedPristineRoot )++packsDir, basicPack, patchesPack :: String+packsDir     = "packs"+basicPack    = "basic.tar.gz"+patchesPack  = "patches.tar.gz"++fetchAndUnpack :: FilePath+               -> Cache+               -> FilePath+               -> IO ()+fetchAndUnpack filename cache remote = do+  unpackTar cache . Tar.read . GZ.decompress =<<+    fetchFileLazyPS (remote </> darcsdir </> packsDir </> filename) Uncachable++fetchAndUnpackPatches :: [InventoryHash] -> [PatchHash] -> Cache -> FilePath -> IO ()+fetchAndUnpackPatches ihs phs cache remote =+  -- Patches pack can miss some new patches of the repository.+  -- So we download pack asynchonously and always do a complete pass+  -- of individual patch and inventory files.+  withAsync (fetchAndUnpack patchesPack cache remote) $ \_ -> do+    forM_ ihs (fetchFileUsingCache cache)+    forM_ phs (fetchFileUsingCache cache)++fetchAndUnpackBasic :: Cache -> FilePath -> IO ()+fetchAndUnpackBasic = fetchAndUnpack basicPack++unpackTar :: Exception e => Cache -> Tar.Entries e -> IO ()+unpackTar _ Tar.Done = return ()+unpackTar _ (Tar.Fail e) = throwIO e+unpackTar c (Tar.Next e es) = case Tar.entryContent e of+  Tar.NormalFile bs _ -> do+    let p = Tar.entryPath e+    if "meta-" `isPrefixOf` takeFileName p+      then unpackTar c es -- just ignore them+      else do+        ex <- doesFileExist p+        if ex+          then debugMessage $ "TAR thread: exists " ++ p ++ "\nStopping TAR thread."+          else do+            if p == hashedInventoryPath+              then writeFile' Nothing p bs+              else writeFile' (closestWritableDirectory c) p $ GZ.compress bs+            debugMessage $ "TAR thread: GET " ++ p+            unpackTar c es+  _ -> fail "Unexpected non-file tar entry"+ where+  writeFile' Nothing path content = withTemp $ \tmp -> do+    BLC.writeFile tmp content+    renameFile tmp path+  writeFile' (Just ca) path content = do+    let fileFullPath = case splitPath path of+          _:hDir:hFile:_  -> joinPath [ca, hDir, bucketFolder hFile, hFile]+          _               -> fail "Unexpected file path"+    createDirectoryIfMissing True $ takeDirectory path+    createLink fileFullPath path `catch` (\(ex :: IOException) -> do+      if isAlreadyExistsError ex then+        return () -- so much the better+      else+        -- ignore cache if we cannot link+        writeFile' Nothing path content)++-- | Create packs from the current recorded version of the repository.+createPacks :: RepoPatch p => Repository 'RW p wU wR -> IO ()+createPacks repo =+ withRepoDir repo $+  flip finally (mapM_ removeFileIfExists+  [ darcsdir </> "meta-filelist-inventories"+  , darcsdir </> "meta-filelist-pristine"+  , basicTar <.> "part"+  , patchesTar <.> "part"+  ]) $ do+  -- pristine hash+  hash <- readHashedPristineRoot repo+  createDirectoryIfMissing False (darcsdir </> packsDir)+  writeFile ( darcsdir </> packsDir </> "pristine" ) $ encodeValidHash hash+  -- pack patchesTar+  ps <- mapFL hashedPatchFileName . progressFL "Packing patches" . patchSet2FL <$>+    readPatches repo+  is <- map (inventoriesDirPath </>) <$> listInventories+  writeFile (darcsdir </> "meta-filelist-inventories") . unlines $+    map takeFileName is+  -- Note: tinkering with zlib's compression parameters does not make+  -- any noticeable difference in generated archive size;+  -- switching to bzip2 would provide ~25% gain OTOH.+  BLC.writeFile (patchesTar <.> "part") . GZ.compress . Tar.write =<<+    mapM fileEntry' ((darcsdir </> "meta-filelist-inventories") : ps ++ reverse is)+  renameFile (patchesTar <.> "part") patchesTar+  -- pack basicTar+  pr <- sortByMTime =<< dirContents pristineDirPath+  writeFile (darcsdir </> "meta-filelist-pristine") . unlines $+    map takeFileName pr+  BLC.writeFile (basicTar <.> "part") . GZ.compress . Tar.write =<< mapM fileEntry' (+    [ darcsdir </> "meta-filelist-pristine"+    -- unclean: we should not access the non-tentative version here;+    -- will work because we do not modify the tentative state+    , hashedInventoryPath+    ] ++ progressList "Packing pristine" (reverse pr))+  renameFile (basicTar <.> "part") basicTar+ where+  basicTar = darcsdir </> packsDir </> basicPack+  patchesTar = darcsdir </> packsDir </> patchesPack+  fileEntry' x = unsafeInterleaveIO $ do+    content <- BLC.fromChunks . return <$> gzReadFilePS x+    tp <- either fail return $ toTarPath False x+    return $ fileEntry tp content+  dirContents dir = map (dir </>) <$> listDirectory dir+  hashedPatchFileName x = case extractHash x of+    Left _ -> fail "unexpected unhashed patch"+    Right h -> patchesDirPath </> encodeValidHash h+  sortByMTime xs = map snd . sort <$> mapM (\x -> (\t -> (t, x)) <$>+    getModificationTime x) xs+  removeFileIfExists x = do+    ex <- doesFileExist x+    when ex $ removeFile x
+ src/Darcs/Repository/PatchIndex.hs view
@@ -0,0 +1,772 @@+{-# LANGUAGE NamedFieldPuns #-}++{-|+License : GPL-2++The patch-index stores additional information that is extracted from+the PatchSet for the repository to speed up certain commands (namely+@log@ and @annotate@). More precisely, for every file tracked by the+repository, it stores the list of patches that touch it.++When created, patch-index lives in @_darcs\/patch_index\/@, and it+should be automatically maintained each time the set of patches of+the repository is updated.++Patch-index can also be explicitely disabled by creating a file+@_darcs\/no_patch_index@. "Explicitely disabed" means that no command+should attempt to automatically create the patch-index.++See <http://darcs.net/Internals/PatchIndex> for more information.+-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+module Darcs.Repository.PatchIndex+    ( doesPatchIndexExist+    , isPatchIndexDisabled+    , isPatchIndexInSync+    , canUsePatchIndex+    , createPIWithInterrupt+    , createOrUpdatePatchIndexDisk+    , deletePatchIndex+    , attemptCreatePatchIndex+    , PatchFilter+    , maybeFilterPatches+    , getRelevantSubsequence+    , dumpPatchIndex+    , piTest+    ) where++import Darcs.Prelude++import Control.Exception ( catch )+import Control.Monad ( forM_, unless, when, (>=>) )+import Control.Monad.State.Strict ( evalState, execState, State, gets, modify )++import Data.Binary ( Binary, encodeFile, decodeFileOrFail )+import qualified Data.ByteString as B+import Data.Int ( Int8 )+import Data.List ( mapAccumL, sort, nub, (\\) )+import Data.Maybe ( catMaybes, fromJust, fromMaybe )+import qualified Data.IntSet as I+import qualified Data.Map as M+import qualified Data.Set as S++import Safe ( tailErr )++import System.Directory+    ( createDirectory+    , doesDirectoryExist+    , doesFileExist+    , removeDirectoryRecursive+    , removeFile+    , renameDirectory+    , copyPermissions+    )+import System.FilePath( (</>) )+import System.IO ( openFile, IOMode(WriteMode), hClose )++import Darcs.Patch ( RepoPatch, listTouchedFiles )+import Darcs.Patch.Apply ( ApplyState, Apply )+import Darcs.Patch.Index.Types+    ( FileId(..)+    , PatchId+    , makePatchID+    , pid2string+    , short+    , showFileId+    , zero+    )+import Darcs.Patch.Index.Monad ( FileMod(..), applyToFileMods )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )+import Darcs.Patch.Progress (progressFL )+import Darcs.Patch.Set ( PatchSet, patchSet2FL, Origin, patchSet2FL )+import Darcs.Patch.Witnesses.Ordered ( mapFL, RL(..), FL(..), reverseRL )+import Darcs.Patch.Witnesses.Sealed+    ( Sealed2(..)+    , Sealed(..)+    , seal+    , seal2+    , unseal+    , unseal2+    )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )++import Darcs.Repository.Format ( formatHas, RepoProperty( HashedInventory ) )+import Darcs.Repository.InternalTypes ( Repository, repoLocation, repoFormat )+import Darcs.Repository.Paths ( hashedInventoryPath )++import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Hash ( sha256sum, showAsHex )+import Darcs.Util.Lock ( withPermDir )+import Darcs.Util.Path ( AnchoredPath, displayPath, isRoot, parents, toFilePath )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.SignalHandler ( catchInterrupt )+import Darcs.Util.Tree ( Tree(..) )++type Map = M.Map+type Set = S.Set+type IntSet = I.IntSet++data FileIdSpan = FidSpan+  !FileId                   -- ^ the fileid has some fixed name in the+  !PatchId                  -- ^ span starting here+  !(Maybe PatchId)          -- ^ and (maybe) ending here+  deriving (Show, Eq, Ord)++data FilePathSpan = FpSpan+  !AnchoredPath             -- ^ the file path has some fixed fileid in the+  !PatchId                  -- ^ span starting here+  !(Maybe PatchId)          -- ^ and (maybe) ending here+  deriving (Show, Eq, Ord)++-- | info about a given fileid+data FileInfo = FileInfo+  { isFile :: Bool          -- ^ whether file or dir+  , touching :: IntSet      -- ^ first words of patch hashes+  } deriving (Show, Eq, Ord)++-- | timespans where a certain filename corresponds to a file with a given id+type FileIdSpans = Map AnchoredPath [FileIdSpan]++-- | timespans where a file with a certain id corresponds to given filenames+type FilePathSpans = Map FileId [FilePathSpan]++-- | information file with a given ID+type InfoMap = Map FileId FileInfo++-- | the patch-index+data PatchIndex = PatchIndex+  { pids :: [PatchId]+    -- ^ all the 'PatchId's tracked by this patch index, with the most+    -- recent patch at the head of the list (note, stored in the+    -- reverse order on disk for backwards compatibility+    -- with an older format).+  , fidspans :: FileIdSpans+  , fpspans :: FilePathSpans+  , infom :: InfoMap+  }++-- | On-disk version of patch index+--   version 1 is the one introduced in darcs 2.10+--           2 changes the pids order to newer-to-older+--           3 changes FileName to AnchoredPath everywhere, which has+--             different Binary (and Ord) instances+--           4 adds all parent dirs of each file or dir as+--             being touched by a patch+--           5 replaces Set Word32 with IntSet++version :: Int8+version = 5++type PIM a = State PatchIndex a++-- | 'applyPatchMods pmods pindex' applies a list of PatchMods to the given+--   patch index pindex+applyPatchMods :: [(PatchId, [FileMod AnchoredPath])] -> PatchIndex -> PatchIndex+applyPatchMods pmods pindex =+  flip execState pindex $ mapM_ goList pmods+ where goList :: (PatchId, [FileMod AnchoredPath]) -> PIM ()+       goList (pid, mods) = do+           modify (\pind -> pind{pids = pid:pids pind})+           mapM_ (curry go pid) mods+       go :: (PatchId, FileMod AnchoredPath) -> PIM ()+       go (pid, PCreateFile fn) = do+         fid <- createFidStartSpan fn pid+         startFpSpan fid fn pid+         createInfo fid True+         insertTouch pid fid+         insertParentsTouch pid fn+       go (pid, PCreateDir fn) = do+         fid <- createFidStartSpan fn pid+         startFpSpan fid fn pid+         createInfo fid False+         insertTouch pid fid+         insertParentsTouch pid fn+       go (pid, PTouch fn) = do+         fid <- lookupFid fn+         insertTouch pid fid+         insertParentsTouch pid fn+       go (pid, PRename oldfn newfn) = do+         fid <- lookupFid oldfn+         stopFpSpan fid pid+         startFpSpan fid newfn pid+         insertTouch pid fid+         insertParentsTouch pid oldfn+         insertParentsTouch pid newfn+         stopFidSpan oldfn pid+         startFidSpan newfn pid fid+       go (pid, PRemove fn) = do+         fid <- lookupFid fn+         insertTouch pid fid+         insertParentsTouch pid fn+         stopFidSpan fn pid+         stopFpSpan fid pid+       go (pid, PDuplicateTouch fn) = do+         fidm <- gets fidspans+         case M.lookup fn fidm of+           Just (FidSpan fid _ _:_) -> do+             insertTouch pid fid+             insertParentsTouch pid fn+           Nothing -> return ()+           Just [] -> error $ "applyPatchMods: impossible, no entry for "++show fn+                              ++" in FileIdSpans in duplicate, empty list"++-- | create new filespan for created file+createFidStartSpan :: AnchoredPath -> PatchId -> PIM FileId+createFidStartSpan fn pstart = do+  fidspans <- gets fidspans+  case M.lookup fn fidspans of+    Nothing -> do+      let fid = FileId fn 1+      modify (\pind -> pind {fidspans=M.insert fn [FidSpan fid pstart Nothing] fidspans})+      return fid+    Just fspans -> do+      let fid = FileId fn (length fspans+1)+      modify (\pind -> pind {fidspans=M.insert fn (FidSpan fid pstart Nothing:fspans) fidspans})+      return fid++-- | start new span for name fn for file fid starting with patch pid+startFpSpan :: FileId -> AnchoredPath -> PatchId -> PIM ()+startFpSpan fid fn pstart = modify (\pind -> pind {fpspans=M.alter alt fid (fpspans pind)})+  where alt Nothing = Just [FpSpan fn pstart Nothing]+        alt (Just spans) = Just (FpSpan fn pstart Nothing:spans)++-- | stop current span for file name fn+stopFpSpan :: FileId -> PatchId -> PIM ()+stopFpSpan fid pend = modify (\pind -> pind {fpspans=M.alter alt fid (fpspans pind)})+  where alt Nothing = error $ "impossible: no span for " ++ show fid+        alt (Just []) = error $ "impossible: no span for " ++ show fid++", empty list"+        alt (Just (FpSpan fp pstart Nothing:spans)) =+          Just (FpSpan fp pstart (Just pend):spans)+        alt _ = error $ "impossible: span already ended for " ++ show fid++-- | start new span for name fn for file fid starting with patch pid+startFidSpan :: AnchoredPath -> PatchId -> FileId -> PIM ()+startFidSpan fn pstart fid = modify (\pind -> pind {fidspans=M.alter alt fn (fidspans pind)})+  where alt Nothing = Just [FidSpan fid pstart Nothing]+        alt (Just spans) = Just (FidSpan fid pstart Nothing:spans)++-- | stop current span for file name fn+stopFidSpan :: AnchoredPath -> PatchId -> PIM ()+stopFidSpan fn pend = modify (\pind -> pind {fidspans=M.alter alt fn (fidspans pind)})+  where alt Nothing = error $ "impossible: no span for " ++ show fn+        alt (Just []) = error $ "impossible: no span for " ++ show fn++", empty list"+        alt (Just (FidSpan fid pstart Nothing:spans)) =+          Just (FidSpan fid pstart (Just pend):spans)+        alt _ = error $ "impossible: span already ended for " ++ show fn++-- | insert touching patchid for given file id+createInfo :: FileId -> Bool -> PIM ()+createInfo fid isF = modify (\pind -> pind {infom=M.alter alt fid (infom pind)})+  where alt Nothing = Just (FileInfo isF I.empty)+        alt (Just _) = Just (FileInfo isF I.empty) -- forget old false positives++-- | insert touching patchid for given file id+insertTouch :: PatchId -> FileId -> PIM ()+insertTouch pid fid = modify (\pind -> pind {infom=M.alter alt fid (infom pind)})+  where alt Nothing =  error "impossible: Fileid does not exist"+        alt (Just (FileInfo isF pids)) = Just (FileInfo isF (I.insert (short pid) pids))++-- | insert touching patchid for the parents of a given path+insertParentsTouch :: PatchId -> AnchoredPath -> PIM ()+insertParentsTouch pid path =+  forM_ (filter (not . isRoot) (parents path)) $+    lookupFid >=> insertTouch pid++-- | lookup current fid of filepath+lookupFid :: AnchoredPath -> PIM FileId+lookupFid fn = do+    maybeFid <- lookupFid' fn+    case maybeFid of+        Nothing -> error $ "couldn't find " ++ displayPath fn ++ " in patch index"+        Just fid -> return fid++-- | lookup current fid of filepatch, returning a Maybe to allow failure+lookupFid' :: AnchoredPath -> PIM (Maybe FileId)+lookupFid' fn = do+   fidm <- gets fidspans+   case M.lookup fn fidm of+    Just (FidSpan fid _ _:_) -> return $ Just fid+    _ -> return Nothing+++-- | Creates patch index that corresponds to all patches in repo.+createPatchIndexDisk+  :: (RepoPatch p, ApplyState p ~ Tree)+  => Repository rt p wU wR+  -> PatchSet p Origin wR+  -> IO ()+createPatchIndexDisk repository ps = do+  let patches = mapFL Sealed2 $ progressFL "Create patch index" $ patchSet2FL ps+  createPatchIndexFrom repository $ patches2fileMods patches S.empty++-- | convert patches to patchmods+patches2fileMods :: (Apply p, PatchInspect p, ApplyState p ~ Tree)+                  => [Sealed2 (PatchInfoAnd p)] -> Set AnchoredPath -> [(PatchId, [FileMod AnchoredPath])]+patches2fileMods patches fns = snd $ mapAccumL go fns patches+  where+    go filenames (Sealed2 p) = (filenames', (pid, pmods_effect ++ pmods_dup))+      where pid = makePatchID . info $ p+            (filenames', pmods_effect) = applyToFileMods p filenames+            -- applyToFileMods only returns patchmods that actually modify a file,+            -- i.e., never duplicate patches+            touched pm = case pm of {PTouch f -> [f]; PRename a b -> [a,b];+                                     PCreateDir f -> [f]; PCreateFile f -> [f];+                                     PRemove f -> [f]; _ -> []}+            touched_all = listTouchedFiles p+            touched_effect = concatMap touched pmods_effect+            -- listTouchedFiles returns all files that touched by these+            --  patches, even if they have no effect, e.g. by duplicate patches+            pmods_dup = map PDuplicateTouch . S.elems+                            $ S.difference (S.fromList touched_all)+                                           (S.fromList touched_effect)++-- | return set of current filenames in patch index+fpSpans2fileNames :: FilePathSpans -> Set AnchoredPath+fpSpans2fileNames fpSpans =+  S.fromList [fn | (FpSpan fn _ Nothing:_)<- M.elems fpSpans]++-- | remove all patch effects of given patches from patch index.+--   assumes that the given list of patches is a suffix of the+--   patches tracked by the patch-index+removePidSuffix :: Map PatchId Int -> [PatchId] -> PatchIndex -> PatchIndex+removePidSuffix _ [] pindex = pindex+removePidSuffix pid2idx oldpids@(oldpid:_) (PatchIndex pids fidspans fpspans infom) =+    PatchIndex (pids \\ oldpids)+               (M.mapMaybe removefid fidspans)+               (M.mapMaybe removefp fpspans)+               infom -- leave hashes in infom, false positives are harmless+  where+    findIdx pid = fromMaybe (error "impossible case") (M.lookup pid pid2idx)+    oldidx = findIdx oldpid+    from `after` idx = findIdx from > idx+    mto `afterM` idx | Just to <- mto, findIdx to > idx = True+                     | otherwise = False+    removefid fidsps = if null fidsps' then Nothing else Just fidsps'+      where+        fidsps' = concatMap go fidsps+        go (FidSpan fid from mto)+          | from `after` oldidx && mto `afterM` oldidx = [FidSpan fid from mto]+          | from `after` oldidx = [FidSpan fid from Nothing]+          | otherwise = []+    removefp fpsps = if null fpsps' then Nothing else Just fpsps'+      where+        fpsps' = concatMap go fpsps+        go (FpSpan fn from mto)+          | from `after` oldidx && mto `afterM` oldidx = [FpSpan fn from mto]+          | from `after` oldidx = [FpSpan fn from Nothing]+          | otherwise = []++-- | update the patch index to the current state of the repository+updatePatchIndexDisk+    :: (RepoPatch p, ApplyState p ~ Tree)+    => Repository rt p wU wR+    -> PatchSet p Origin wR+    -> IO ()+updatePatchIndexDisk repo patches = do+    let repodir = repoLocation repo+    (_,_,pid2idx,pindex) <- loadPatchIndex repodir+    -- check that patch index is up to date+    let flpatches = progressFL "Update patch index" $ patchSet2FL patches+    let pidsrepo = mapFL (makePatchID . info) flpatches+        (oldpids,_,len_common) = uncommon (reverse $ pids pindex) pidsrepo+        pindex' = removePidSuffix pid2idx oldpids pindex+        filenames = fpSpans2fileNames (fpspans pindex')+        cdir = repodir </> indexDir+    -- reread to prevent holding onto patches for too long+    let newpatches = drop len_common $ mapFL seal2 flpatches+        newpmods = patches2fileMods newpatches filenames+    inv_hash <- getInventoryHash repodir+    storePatchIndex cdir inv_hash (applyPatchMods newpmods pindex')+  where+    -- return uncommon suffixes and length of common prefix of as and bs+    uncommon = uncommon' 0+    uncommon' x (a:as) (b:bs)+      | a == b     = uncommon' (x+1) as bs+      | otherwise  =  (a:as,b:bs,x)+    uncommon' x as bs = (as,bs,x)++-- | 'createPatchIndexFrom repo pmods' creates a patch index from the given+--   patchmods.+createPatchIndexFrom :: Repository rt p wU wR+                     -> [(PatchId, [FileMod AnchoredPath])] -> IO ()+createPatchIndexFrom repo pmods = do+    inv_hash <- getInventoryHash repodir+    storePatchIndex cdir inv_hash (applyPatchMods pmods emptyPatchIndex)+  where repodir = repoLocation repo+        cdir = repodir </> indexDir+        emptyPatchIndex = PatchIndex [] M.empty M.empty M.empty++getInventoryHash :: FilePath -> IO String+getInventoryHash repodir = do+  inv <- B.readFile (repodir </> hashedInventoryPath)+  return $ sha256sum inv++-- | Load patch-index from disk along with some meta data.+loadPatchIndex :: FilePath -> IO (Int8, String, Map PatchId Int, PatchIndex)+loadPatchIndex repodir = do+  let pindex_dir = repodir </> indexDir+  (v,inv_hash) <- loadRepoState (pindex_dir </> repoStateFile)+  pids <- loadPatchIds (pindex_dir </> pidsFile)+  let pid2idx  = M.fromList $ zip pids [(1::Int)..]+  infom <- loadInfoMap (pindex_dir </> touchMapFile)+  fidspans <- loadFidMap (pindex_dir </> fidMapFile)+  fpspans <- loadFpMap (pindex_dir </> fpMapFile)+  return (v, inv_hash, pid2idx, PatchIndex pids fidspans fpspans infom)++-- | If patch-index is useful as it is now, read it. If not, create or update it, then read it.+loadSafePatchIndex :: (RepoPatch p, ApplyState p ~ Tree)+                   => Repository rt p wU wR+                   -> PatchSet p Origin wR     -- ^ PatchSet of the repository, used if we need to create the patch-index.+                   -> IO PatchIndex+loadSafePatchIndex repo ps = do+   let repodir = repoLocation repo+   can_use <- isPatchIndexInSync repo+   (_,_,_,pi) <-+     if can_use+       then do+          debugMessage "Loading patch index..."+          r <- loadPatchIndex repodir+          debugMessage "Done."+          return r+       else do createOrUpdatePatchIndexDisk repo ps+               loadPatchIndex repodir+   return pi++-- | Read-only. Checks if patch-index exists for this repository+--   it works by checking if:+--+--     1. @_darcs\/patch_index\/@ and its corresponding files are all present+--     2. patch index version is the one handled by this version of Darcs+doesPatchIndexExist :: FilePath -> IO Bool+doesPatchIndexExist repodir = do+ filesArePresent <- and <$> mapM (doesFileExist . (pindex_dir </>))+                    [repoStateFile, pidsFile, touchMapFile, fidMapFile, fpMapFile]+ if filesArePresent+  then do v <- piVersion+          return (v == version)   -- consider PI only of on-disk format is the current one+  else return False+   where pindex_dir = repodir </> indexDir+         piVersion = fst <$> loadRepoState (pindex_dir </> repoStateFile)++-- | Read-only. Checks if @_darcs\/noPatchIndex@ exists, that is, if patch-index is explicitely disabled.+isPatchIndexDisabled :: FilePath -> IO Bool+isPatchIndexDisabled repodir = doesFileExist (repodir </> darcsdir  </> noPatchIndex)++-- | Create or update patch index+--+--   1. if @_darcs\/no_patch_index@ exists, delete it+--   2. if patch index exists, update it+--   3. if not, create it from scratch+createOrUpdatePatchIndexDisk :: (RepoPatch p, ApplyState p ~ Tree)+                             => Repository rt p wU wR -> PatchSet p Origin wR -> IO ()+createOrUpdatePatchIndexDisk repo ps = do+   debugMessage "createOrUpdatePatchIndexDisk: start"+   let repodir = repoLocation repo+   removeFile (repodir </> darcsdir </> noPatchIndex) `catch` \(_ :: IOError) -> return ()+   dpie <- doesPatchIndexExist repodir+   if dpie+      then updatePatchIndexDisk repo ps+      else createPatchIndexDisk repo ps+   debugMessage "createOrUpdatePatchIndexDisk: done"++-- | Read-only. Checks the two following things:+--+--   1. 'doesPatchIndexExist'+--   2. 'isPatchIndexDisabled'+--+-- Then only if it exists and it is not explicitely disabled, returns @True@, else returns @False@+-- (or an error if it exists and is explicitely disabled at the same time).+canUsePatchIndex :: Repository rt p wU wR -> IO Bool+canUsePatchIndex repo = do+     let repodir = repoLocation repo+     piExists <- doesPatchIndexExist repodir+     piDisabled <- isPatchIndexDisabled repodir+     case (piExists, piDisabled) of+        (True, False) -> return True+        (False, True) -> return False+        (True, True) -> fail "patch index exists, and patch index is disabled. run optimize enable-patch-index or disable-patch-index to rectify."+        (False, False) -> return False++-- | Creates patch-index (ignoring whether it is explicitely disabled).+--   If it is ctrl-c'ed, then aborts, delete patch-index and mark it as disabled.+createPIWithInterrupt :: (RepoPatch p, ApplyState p ~ Tree)+                      => Repository rt p wU wR -> PatchSet p Origin wR -> IO ()+createPIWithInterrupt repo ps = do+    let repodir = repoLocation repo+    putStrLn "Creating a patch index, please wait. To stop press Ctrl-C"+    (do+      createPatchIndexDisk repo ps+      putStrLn "Created patch index.") `catchInterrupt` (putStrLn "Patch Index Disabled" >> deletePatchIndex repodir)++-- | Checks if patch-index exists and is in sync with repository.+--   That is, checks if patch-index can be used as it is now.+isPatchIndexInSync :: Repository rt p wU wR -> IO Bool+isPatchIndexInSync repo = do+   let repodir = repoLocation repo+   dpie <- doesPatchIndexExist repodir+   if dpie+    then do+      (_, inv_hash_pindex, _, _) <- loadPatchIndex repodir+      inv_hash <- getInventoryHash repodir+      return (inv_hash == inv_hash_pindex)+    else return False++-- | Stores patch-index on disk.+storePatchIndex :: FilePath -> String -> PatchIndex -> IO ()+storePatchIndex cdir inv_hash (PatchIndex pids fidspans fpspans infom) = do+  createDirectory cdir `catch` \(_ :: IOError) -> return ()+  tmpdir <- withPermDir cdir $ \dir -> do+              debugMessage "About to create patch index..."+              let tmpdir = toFilePath dir+              storeRepoState (tmpdir </> repoStateFile) inv_hash+              storePatchIds (tmpdir </> pidsFile) pids+              storeInfoMap (tmpdir </> touchMapFile) infom+              storeFidMap (tmpdir </> fidMapFile) fidspans+              storeFpMap (tmpdir </> fpMapFile) fpspans+              debugMessage "Patch index created"+              return tmpdir+  removeDirectoryRecursive cdir `catch` \(_ :: IOError) -> return ()+  copyPermissions darcsdir tmpdir+  renameDirectory tmpdir cdir++decodeFile :: Binary a => FilePath -> IO a+decodeFile path = do+  result <- decodeFileOrFail path+  case result of+    Left (offset, msg) ->+      fail $+        "Patch index is corrupt (file "++path++" at offset "++show offset++"): "++msg+++        "\nPlease remove the corrupt file and then try again."+    Right r -> return r++storeRepoState :: FilePath -> String -> IO ()+storeRepoState fp inv_hash = encodeFile fp (version,inv_hash)++loadRepoState :: FilePath -> IO (Int8, String)+loadRepoState = decodeFile++storePatchIds :: FilePath -> [PatchId] -> IO ()+storePatchIds = encodeFile++loadPatchIds :: FilePath -> IO [PatchId]+loadPatchIds = decodeFile++storeFidMap :: FilePath -> FileIdSpans -> IO ()+storeFidMap fp fidm =+  encodeFile fp $ M.map (map (\(FidSpan a b c) -> (a, b, toIdxM c))) fidm+ where toIdxM Nothing = zero+       toIdxM (Just pid) = pid++loadFidMap :: FilePath -> IO FileIdSpans+loadFidMap fp = M.map (map (\(a,b,c) -> FidSpan a b (toPidM c))) <$> decodeFile fp+  where toPidM pid | pid == zero = Nothing+                   | otherwise   = Just pid++storeFpMap :: FilePath -> FilePathSpans -> IO ()+storeFpMap fp fidm =+  encodeFile fp $ M.map (map (\(FpSpan a b c) -> (a, b, toIdxM c))) fidm+ where toIdxM Nothing = zero+       toIdxM (Just pid) = pid++loadFpMap :: FilePath -> IO FilePathSpans+loadFpMap fp = M.map (map (\(a,b,c) -> FpSpan a b (toPidM c))) <$> decodeFile fp+  where toPidM pid | pid == zero = Nothing+                   | otherwise   = Just pid++storeInfoMap :: FilePath -> InfoMap -> IO ()+storeInfoMap fp infom =+  encodeFile fp $ M.map (\fi -> (isFile fi, touching fi)) infom++loadInfoMap :: FilePath -> IO InfoMap+loadInfoMap fp = M.map (\(isF,pids) -> FileInfo isF pids) <$> decodeFile fp++indexDir, repoStateFile, pidsFile, fidMapFile, fpMapFile,+  touchMapFile, noPatchIndex :: String+indexDir = darcsdir </> "patch_index"+repoStateFile = "repo_state"+pidsFile = "patch_ids"+fidMapFile = "fid_map"+fpMapFile = "fp_map"+touchMapFile = "touch_map"+noPatchIndex = "no_patch_index"++-- | Deletes patch-index (@_darcs\/patch_index\/@ and its contents) and mark repository as disabled (creates @_darcs\/no_patch_index@).+deletePatchIndex :: FilePath -> IO ()+deletePatchIndex repodir = do+    exists <- doesDirectoryExist indexDir+    when exists $+         removeDirectoryRecursive indexDir+            `catch` \(e :: IOError) -> fail $ "Error: Could not delete patch index\n" ++ show e+    (openFile (repodir </> darcsdir </> noPatchIndex) WriteMode >>= hClose)+            `catch` \(e :: IOError) -> fail $ "Error: Could not disable patch index\n" ++ show e++dumpRepoState :: [PatchId] -> String+dumpRepoState = unlines . map pid2string++dumpFileIdSpans :: FileIdSpans -> String+dumpFileIdSpans fidspans =+  unlines [displayPath fn++" -> "++showFileId fid++" from "++pid2string from++" to "++maybe "-" pid2string mto+           | (fn, fids) <- M.toList fidspans, FidSpan fid from mto <- fids]++dumpFilePathSpans :: FilePathSpans -> String+dumpFilePathSpans fpspans =+  unlines [showFileId fid++" -> "++ displayPath fn++" from "++pid2string from++" to "++maybe "-" pid2string mto+           | (fid, fns) <- M.toList fpspans, FpSpan fn from mto <- fns]++dumpTouchingMap :: InfoMap -> String+dumpTouchingMap infom = unlines [showFileId fid++(if isF then "" else "/")++" -> "++ showAsHex (fromIntegral i)+                                | (fid,FileInfo isF w32s) <- M.toList infom, i <- I.elems w32s]++-- | return set of current filepaths in patch index+fpSpans2filePaths :: FilePathSpans -> InfoMap -> [FilePath]+fpSpans2filePaths fpSpans infom =+  sort [displayPath fn ++ (if isF then "" else "/") | (fid,FpSpan fn _ Nothing:_) <- M.toList fpSpans,+                                                let Just (FileInfo isF _) = M.lookup fid infom]++-- | Checks if patch index can be created and build it with interrupt.+attemptCreatePatchIndex+  :: (RepoPatch p, ApplyState p ~ Tree)+  => Repository rt p wU wR -> PatchSet p Origin wR -> IO ()+attemptCreatePatchIndex repo ps = do+  canCreate <- canCreatePI repo+  when canCreate $ createPIWithInterrupt repo ps++-- | Checks whether a patch index can (and should) be created. If we are not in+-- an old-fashioned repo, and if we haven't been told not to, then we should+-- create a patch index if it doesn't already exist.+canCreatePI :: Repository rt p wU wR -> IO Bool+canCreatePI repo =+    (not . or) <$> sequence [ doesntHaveHashedInventory (repoFormat repo)+                            , isPatchIndexDisabled repodir+                            , doesPatchIndexExist repodir+                            ]+  where+    repodir = repoLocation repo+    doesntHaveHashedInventory = return . not . formatHas HashedInventory++-- | Returns an RL in which the order of patches matters. Useful for the+-- @annotate@ command. If patch-index does not exist and is not explicitely+-- disabled, silently create it. (Also, if it is out-of-sync, which should not+-- happen, silently update it).+getRelevantSubsequence+    :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p)+    => Sealed ((RL a) wK)+    -- ^ Sequence of patches you want to filter+    -> Repository rt p wU wR+    -- ^ The repository (to attempt loading patch-index from its path)+    -> PatchSet p Origin wR+    -- ^ PatchSet of repository (in case we need to create patch-index)+    -> [AnchoredPath]+    -- ^ File(s) about which you want patches from given sequence+    -> IO (Sealed ((RL a) Origin))+    -- ^ Filtered sequence of patches+getRelevantSubsequence pxes repository ps fns = do+    pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repository ps+    let fids = map (\fn -> evalState (lookupFid fn) pi) fns+        pidss = map ((\(FileInfo _ a) -> a) . fromJust . (`M.lookup` infom)) fids+        pids = I.unions pidss+    let flpxes = reverseRL $ unseal unsafeCoercePEnd pxes+    return . seal $ keepElems flpxes NilRL pids+  where+    keepElems :: (RepoPatch p, ApplyState p ~ Tree, a ~ PatchInfoAnd p)+              => FL a wX wY -> RL a wB wX -> IntSet -> RL a wP wQ+    keepElems NilFL acc _ = unsafeCoerceP acc+    keepElems (x :>: xs) acc pids+      | short (makePatchID $ info x) `I.member` pids = keepElems xs (acc :<: x) pids+      | otherwise = keepElems (unsafeCoerceP xs) acc pids++type PatchFilter p = [AnchoredPath] -> [Sealed2 (PatchInfoAnd p)] -> IO [Sealed2 (PatchInfoAnd p)]++-- | If a patch index is available, returns a filter that takes a list of files+--   and returns a @PatchFilter@ that only keeps patches that modify the given+--   list of files. If patch-index cannot be used, return the original input.+--   If patch-index does not exist and is not explicitely disabled, silently+--   create it. (Also, if it is out-of-sync, which should not happen, silently+--   update it).+maybeFilterPatches+    :: (RepoPatch p, ApplyState p ~ Tree)+    => Repository rt p wU wR  -- ^ The repository+    -> PatchSet p Origin wR   -- ^ PatchSet of patches of repository (in case patch-index needs to be created)+    -> PatchFilter p          -- ^ PatchFilter ready to be used by SelectChanges.+maybeFilterPatches repo ps fps ops = do+    usePI <- canUsePatchIndex repo+    if usePI+      then do+        pi@(PatchIndex _ _ _ infom) <- loadSafePatchIndex repo ps+        let fids = catMaybes $ map ((\fn -> evalState (lookupFid' fn) pi)) fps+            npids = I.unions $ map (touching.fromJust.(`M.lookup` infom)) fids+        return $ filter+          (flip I.member npids . (unseal2 (short . makePatchID . info))) ops+      else return ops++-- | Dump information in patch index. Patch-index should be checked to exist beforehand. Read-only.+dumpPatchIndex :: FilePath -> IO ()+dumpPatchIndex repodir = do+  (_,inv_hash,_,PatchIndex pids fidspans fpspans infom) <- loadPatchIndex repodir+  putStrLn $ unlines $+    [ "Inventory hash:" ++ inv_hash+    , "================="+    , "Repo state:"+    , "==========="+    , dumpRepoState pids+    , "Fileid spans:"+    , "============="+    , dumpFileIdSpans fidspans+    , "Filepath spans:"+    , "=============="+    , dumpFilePathSpans fpspans+    , "Info Map:"+    , "========="+    , dumpTouchingMap infom+    , "Files:"+    , "=============="+    ] ++ fpSpans2filePaths fpspans infom++-- | Read-only sanity check on patch-index. Patch-index should be checked to exist beforehand. It may not be in sync with repository.+piTest :: FilePath -> IO ()+piTest repodir = do+   (_,_,_,PatchIndex rpids fidspans fpspans infom) <- loadPatchIndex repodir+   let pids = reverse rpids++   -- test fidspans+   putStrLn "fidspans"+   putStrLn "==========="+   forM_ (M.toList fidspans) $ \(fn, spans) -> do+      let g :: FileIdSpan -> [PatchId]+          g (FidSpan _ x (Just y)) = [y,x]+          g (FidSpan _ x _) = [x]+          ascTs = reverse . nub . concat $ map g spans+      unless (isInOrder ascTs pids) (fail $ "In order test failed! filename: " ++ show fn)+      forM_ spans $ \(FidSpan fid _ _) -> unless (M.member fid fpspans) (fail $ "Valid file id test failed! fid: " ++ show fid)+   putStrLn "fidspans tests passed"++   -- test fpspans+   putStrLn "fpspans"+   putStrLn "==========="+   forM_ (M.toList fpspans) $ \(fid, spans) -> do+      let g :: FilePathSpan -> [PatchId]+          g (FpSpan _ x (Just y)) = [y,x]+          g (FpSpan _ x _) = [x]+          ascTs = reverse . nub . concat $ map g spans+      unless (isInOrder ascTs pids) (fail $ "In order test failed! fileid: " ++ show fid)+      forM_ spans $ \(FpSpan fn _ _) -> unless (M.member fn fidspans) (fail $ "Valid file name test failed! file name: " ++ show fn)+      let f :: FilePathSpan -> FilePathSpan -> Bool+          f (FpSpan _ x _) (FpSpan _ _ (Just y)) = x == y+          f _ _ = error "adj test of fpspans fail"+      unless (and $ zipWith f spans (tailErr spans)) (fail $ "Adjcency test failed! fid: " ++ show fid)+   putStrLn "fpspans tests passed"++   -- test infomap+   putStrLn "infom"+   putStrLn "==========="+   putStrLn $ "Valid fid test: " ++ (show.and $ map (`M.member` fpspans) (M.keys infom))+   putStrLn $ "Valid pid test: " ++ (show.flip I.isSubsetOf (I.fromList $ map short pids)  . I.unions . map touching . M.elems $ infom)+   where+          isInOrder :: Eq a => [a] -> [a] -> Bool+          isInOrder (x:xs) (y:ys) | x == y = isInOrder xs ys+                                  | otherwise = isInOrder (x:xs) ys+          isInOrder [] _ = True+          isInOrder _ [] = False++
+ src/Darcs/Repository/Paths.hs view
@@ -0,0 +1,66 @@+-- everything here has type String/FilePath+{-# OPTIONS_GHC -Wno-missing-signatures #-}+module Darcs.Repository.Paths where++import Darcs.Prelude+import Darcs.Util.Cache ( HashedDir(..), hashedDir )+import Darcs.Util.Global ( darcsdir )+import System.FilePath.Posix( (</>) )++makeDarcsdirPath :: String -> String+makeDarcsdirPath name = darcsdir </> name++-- | Location of the lock file.+lockPath = makeDarcsdirPath "lock"++-- | Location of the prefs directory.+prefsDir = "prefs"+prefsDirPath = makeDarcsdirPath prefsDir++-- | Location of the (one and only) head inventory.+hashedInventory = "hashed_inventory"+hashedInventoryPath = makeDarcsdirPath hashedInventory++-- | Location of the (one and only) tentative head inventory.+tentativeHashedInventory = "tentative_hashed_inventory"+tentativeHashedInventoryPath = makeDarcsdirPath tentativeHashedInventory++-- | Location of parent inventories.+inventoriesDir = hashedDir HashedInventoriesDir+inventoriesDirPath = makeDarcsdirPath inventoriesDir++-- | Location of pristine trees.+tentativePristinePath = makeDarcsdirPath "tentative_pristine"+pristineDir = hashedDir HashedPristineDir+pristineDirPath = makeDarcsdirPath pristineDir++-- | Location of patches.+patchesDir = hashedDir HashedPatchesDir+patchesDirPath = makeDarcsdirPath patchesDir++-- | Location of index files.+indexPath = darcsdir </> "index"+indexInvalidPath = darcsdir </> "index_invalid"++-- | Location of the rebase patch+rebasePath = makeDarcsdirPath "rebase"+tentativeRebasePath = makeDarcsdirPath "rebase.tentative"++-- | Location of format file+formatPath = makeDarcsdirPath "format"++-- | Location of pending files+pendingPath = patchesDirPath </> "pending"+tentativePendingPath = patchesDirPath </> "pending.tentative"+newPendingPath = patchesDirPath </> "pending.new"++-- | Location of unrevert bundle.+unrevertPath = patchesDirPath </> "unrevert"+tentativeUnrevertPath = patchesDirPath </> "unrevert.tentative"++-- | Location of old style (unhashed) files and directories.+oldPristineDirPath = makeDarcsdirPath "pristine"+oldCurrentDirPath = makeDarcsdirPath "current"+oldCheckpointDirPath = makeDarcsdirPath "checkpoints"+oldInventoryPath = makeDarcsdirPath "inventory"+oldTentativeInventoryPath = makeDarcsdirPath "tentative_inventory"
+ src/Darcs/Repository/Pending.hs view
@@ -0,0 +1,257 @@+-- Copyright (C) 2002-2004,2007-2008 David Roundy+-- Copyright (C) 2005 Juliusz Chroboczek+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Repository.Pending+    ( readPending+    , readTentativePending+    , writeTentativePending+    , siftForPending+    , tentativelyRemoveFromPW+    , revertPending+    , finalizePending+    , setTentativePending+    ) where++import Darcs.Prelude++import Control.Applicative+import System.Directory ( copyFile, renameFile )++import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, commuteFL, readPatch )+import Darcs.Patch.Commute ( Commute(..) )+import Darcs.Patch.Invert ( invertFL )+import Darcs.Patch.Permutations ( partitionFL )+import Darcs.Patch.Prim+    ( PrimCoalesce(tryToShrink)+    , PrimSift(primIsSiftable)+    , coalesce+    )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Patch.Read ( ReadPatch(..), bracketedFL )+import Darcs.Patch.Show ( ShowPatchBasic(..), ShowPatchFor(ForStorage) )+import Darcs.Patch.Witnesses.Maybe ( Maybe2(..) )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , RL(..)+    , mapFL+    , (+>+)+    , (:>)(..)+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, unseal )++import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , Repository+    , SAccessType(..)+    , repoAccessType+    , unsafeStartTransaction+    , withRepoDir+    )+import Darcs.Repository.Paths ( pendingPath, tentativePendingPath )++import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Exception ( catchDoesNotExistError, ifDoesNotExistError )+import Darcs.Util.Lock ( writeDocBinFile )+import Darcs.Util.Parser ( Parser )+import Darcs.Util.Printer ( Doc, text, vcat, ($$) )+++tentativeSuffix :: String+tentativeSuffix = ".tentative"++-- | Read the contents of pending.+readPending :: RepoPatch p => Repository rt p wU wR+            -> IO (Sealed (FL (PrimOf p) wR))+readPending repo =+  case repoAccessType repo of+    SRO -> readPendingFile "" repo+    SRW -> readPendingFile tentativeSuffix repo++-- |Read the contents of tentative pending.+readTentativePending :: RepoPatch p => Repository 'RW p wU wR+                     -> IO (Sealed (FL (PrimOf p) wR))+readTentativePending = readPendingFile tentativeSuffix++-- |Read the pending file with the given suffix. CWD should be the repository+-- directory. Unsafe!+readPendingFile :: ReadPatch prim => String -> Repository rt p wU wR+                -> IO (Sealed (FL prim wX))+readPendingFile suffix _ =+  ifDoesNotExistError (Sealed NilFL) $ do+    let filepath = pendingPath ++ suffix+    raw <- gzReadFilePS filepath+    case readPatch raw of+      Right p -> return (mapSeal unFLM p)+      Left e -> fail $ unlines ["Corrupt pending patch: " ++ show filepath, e]++-- Wrapper around FL where printed format uses { } except around singletons.+-- Now that the Show behaviour of FL p can be customised (using+-- showFLBehavior (*)), we could instead change the general behaviour of FL Prim;+-- but since the pending code can be kept nicely compartmentalised, it's nicer+-- to do it this way.+-- (*) bf: This function does not exist.+newtype FLM p wX wY = FLM { unFLM :: FL p wX wY }++instance ReadPatch p => ReadPatch (FLM p) where+    readPatch' = mapSeal FLM <$> readMaybeBracketedFL readPatch' '{' '}'++instance ShowPatchBasic p => ShowPatchBasic (FLM p) where+    showPatch f = showMaybeBracketedFL (showPatch f) '{' '}' . unFLM++readMaybeBracketedFL :: (forall wY . Parser (Sealed (p wY))) -> Char -> Char+                     -> Parser (Sealed (FL p wX))+readMaybeBracketedFL parser pre post =+    bracketedFL parser pre post <|> (mapSeal (:>:NilFL) <$> parser)++showMaybeBracketedFL :: (forall wX wY . p wX wY -> Doc) -> Char -> Char+                     -> FL p wA wB -> Doc+showMaybeBracketedFL _ pre post NilFL = text [pre] $$ text [post]+showMaybeBracketedFL printer _ _ (p :>: NilFL) = printer p+showMaybeBracketedFL printer pre post ps = text [pre] $$+                                           vcat (mapFL printer ps) $$+                                           text [post]++-- |Write the contents of tentative pending.+writeTentativePending :: RepoPatch p => Repository 'RW p wU wR+                      -> FL (PrimOf p) wR wP -> IO ()+writeTentativePending _ ps =+    unseal (writePatch name . FLM) (siftForPending ps)+  where+    name = pendingPath ++ tentativeSuffix++writePatch :: ShowPatchBasic p => FilePath -> p wX wY -> IO ()+writePatch f p = writeDocBinFile f $ showPatch ForStorage p <> text "\n"++-- | Remove as much as possible of the given list of prim patches from the+-- pending patch. It is used by record and amend to update pending.+--+-- The "as much as possible" is due to --look-for-* options which cause changes+-- that normally must be explicitly done by the user (such as add, move, and+-- replace) to be inferred from the the diff between pristine and working.+-- Also, before we present prims to the user to select for recording, we+-- coalesce prims from pending and working, which is reason we have to use+-- decoalescing.+tentativelyRemoveFromPW :: forall p wR wO wP wU. RepoPatch p+                        => Repository 'RW p wU wR+                        -> FL (PrimOf p) wO wR -- added repo changes+                        -> FL (PrimOf p) wO wP -- O = old recorded state+                        -> FL (PrimOf p) wP wU -- P = (old) pending state+                        -> IO ()+tentativelyRemoveFromPW r changes pending _working = do+  let inverted_changes = invertFL (progressFL "Removing from pending:" changes)+  unseal (writeTentativePending r) (updatePendingRL inverted_changes pending)++-- | Iterate 'updatePending' for all recorded changes.+updatePendingRL :: PrimPatch p => RL p wR wO -> FL p wO wP -> Sealed (FL p wR)+updatePendingRL NilRL ys = Sealed ys+updatePendingRL (xs :<: x) ys = unseal (updatePendingRL xs) (updatePending x ys)++{- | Given an (inverted) single recorded change @x@ and the old pending+@ys@, for each prim @y@ in pending either cancel @x@ against @y@, or+coalesce them. If they coalesce, either commute the result past pending, or+continue with the rest of pending. If coalescing fails, commute @x@ forward+and try again with the next prim from pending. Repeat until we reach the end+of pending or @x@ becomes stuck, in which case we keep it there.++The idea of this algorithm is best explained in terms of an analogy with+arithmetic, where coalescing is addition. Let's say we start out with @a@ in+pending and @b@ in working and record the coalesced @a+b@. We now want to+remove (only) the @a@ from pending. To do that we coalesce @-(a+b)+a@ and+the result (if successful) is @-b@. If this can be commuted past pending, we+are done: the part that came from pending (@a@) is removed and the other+part cancels against what remains in working.++However, we should also guard against the possibility that we recorded a+change that was coalesced from more than one prim in pending. For instance,+suppose we recorded @a+b+c@, where @a@ and @b@ are both from pending and @c@+is form working; after coalescing with @a@ we would be left with+@-(a+b+c)+a=-(b+c)@ which would then be stuck against the remaining @b@.+This is why we continue coalescing, giving us @-(b+c)+b=-c@ which we again+try to commute out etc.++Finally, note that a change can legitimately be stuck in pending i.e. it can+neither be coalesced nor commuted further. For instance, if we have a hunk+in pending and some other prim that depends on it, such as a replace, and+the user records (only) a split-off version of the hunk but not the replace.+This will coalesce with the remaining hunk but then be stuck at the replace.+This is how it should be and thus keeping it there is the correct behavior.+-}++updatePending :: PrimCoalesce p => p wR wO -> FL p wO wP -> Sealed (FL p wR)+updatePending _ NilFL = Sealed NilFL+updatePending x (y :>: ys) =+  case coalesce (x :> y) of+    Just Nothing2 -> Sealed ys -- cancelled out+    Just (Just2 y') ->+      case commuteFL (y' :> ys) of+        Just (ys' :> _) -> Sealed ys' -- drop result if we can commute it past+        Nothing -> updatePending y' ys -- continue coalescing with with y'+    Nothing ->+      case commute (x :> y) of+        Just (y' :> x') -> mapSeal (y' :>:) (updatePending x' ys)+        Nothing -> Sealed (x :>: y :>: ys) -- x is stuck, keep it there++-- | Replace the pending patch with the tentative pending+finalizePending :: Repository 'RW p wU wR -> IO ()+finalizePending _ = renameFile tentativePendingPath pendingPath++-- | Copy the pending patch to the tentative pending, or write a new empty+-- tentative pending if regular pending does not exist.+revertPending :: RepoPatch p => Repository 'RO p wU wR -> IO ()+revertPending r =+  copyFile pendingPath tentativePendingPath `catchDoesNotExistError`+    (readPending r >>= unseal (writeTentativePending (unsafeStartTransaction r)))++-- | Overwrites the pending patch with a new one, starting at the tentative state.+setTentativePending :: forall p wU wR wP. RepoPatch p+                    => Repository 'RW p wU wR+                    -> FL (PrimOf p) wR wP+                    -> IO ()+setTentativePending repo ps = do+    withRepoDir repo $ writeTentativePending repo ps++-- | Simplify the candidate pending patch through a combination of looking+-- for self-cancellations (sequences of patches followed by their inverses),+-- coalescing, and getting rid of any hunk or binary patches we can commute+-- out the back.+--+-- More abstractly, for an argument @p@, pristine state @R@, and working+-- state @U@, define+--+-- > unrecorded p = p +>+ diff (pureApply p R) U+--+-- Then the resulting sequence @p'@ must maintain that equality, i.e.+--+-- > unrecorded p = unrecorded (siftForPending p)+--+-- while trying to "minimize" @p@.+siftForPending+  :: (PrimCoalesce prim, PrimSift prim) => FL prim wX wY -> Sealed (FL prim wX)+siftForPending ps =+  -- Alternately 'sift' and 'tryToShrink' until shrinking no longer reduces+  -- the length of the sequence. Here, 'sift' means to commute siftable+  -- patches to the end of the sequence and then drop them.+  case sift ps of+    Sealed sifted ->+      case tryToShrink sifted of+        Nothing -> Sealed sifted+        Just shrunk -> siftForPending shrunk+  where+    sift xs =+      case partitionFL (not . primIsSiftable) xs of+        (not_siftable :> deps :> _) -> Sealed (not_siftable +>+ deps)
src/Darcs/Repository/Prefs.hs view
@@ -15,422 +15,784 @@ --  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, --  Boston, MA 02110-1301, USA. --{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Repository.Prefs ( addToPreflist, getPreflist, setPreflist,-                   getGlobal, environmentHelpHome,-                   defaultrepo, setDefaultrepo,-                   getPrefval, setPrefval, changePrefval,-                   defPrefval,-                   writeDefaultPrefs,-                   boringRegexps, boringFileFilter, darcsdirFilter,-                   FileType(..), filetypeFunction,-                   getCaches,-                   binariesFileHelp, boringFileHelp,-                   globalCacheDir,-                   globalPrefsDirDoc,-                 ) where---import Prelude hiding ( catch )--import System.IO.Error ( isDoesNotExistError )-import Control.Exception ( catch )-import Control.Monad ( unless, when )-import Text.Regex ( Regex, mkRegex, matchRegex, )-import Data.Char ( toUpper )-import Data.Maybe ( isJust, fromMaybe, mapMaybe )-import Data.List ( nub, isPrefixOf, union, sortBy )-import System.Directory ( getAppUserDataDirectory, doesDirectoryExist, createDirectory, doesFileExist )-import Darcs.Lock( readBinFile, writeBinFile )-import System.FilePath.Posix ( (</>) )-import System.Environment ( getEnvironment )--import Darcs.Flags ( DarcsFlag( NoCache, NoSetDefault, DryRun, RemoteRepo ) )-import Darcs.RepoPath ( AbsolutePath, ioAbsolute, toFilePath, getCurrentDirectory )-import Darcs.Utils ( catchall, stripCr )-import Darcs.External ( gzFetchFilePS, Cachable( Cachable ) )-import qualified Data.ByteString.Char8 as BC ( unpack )-import qualified Data.ByteString       as B  ( empty )-import Darcs.Global ( darcsdir )-import Darcs.Repository.Cache ( Cache(..), CacheType(..), CacheLoc(..),-                                WritableOrNot(..), compareByLocality )-import Darcs.URL ( isFile )---writeDefaultPrefs :: IO ()-writeDefaultPrefs =   do setPreflist "boring" defaultBoring-                         setPreflist "binaries" defaultBinaries-                         setPreflist "motd" []--{-# NOINLINE defaultBoring #-}-defaultBoring :: [String]-defaultBoring = help ++-                [ "",-                  "### compiler and interpreter intermediate files",-                  "# haskell (ghc) interfaces",-                  "\\.hi$", "\\.hi-boot$", "\\.o-boot$",-                  "# object files",-                  "\\.o$","\\.o\\.cmd$",-                  "# profiling haskell",-                  "\\.p_hi$", "\\.p_o$",-                  "# haskell program coverage resp. profiling info",-                  "\\.tix$", "\\.prof$",-                  "# fortran module files",-                  "\\.mod$",-                  "# linux kernel",-                  "\\.ko\\.cmd$","\\.mod\\.c$",-                  "(^|/)\\.tmp_versions($|/)",-                  "# *.ko files aren't boring by default because they might",-                  "# be Korean translations rather than kernel modules",-                  "# \\.ko$",-                  "# python, emacs, java byte code",-                  "\\.py[co]$", "\\.elc$","\\.class$",-                  "# objects and libraries; lo and la are libtool things",-                  "\\.(obj|a|exe|so|lo|la)$",-                  "# compiled zsh configuration files",-                  "\\.zwc$",-                  "# Common LISP output files for CLISP and CMUCL",-                  "\\.(fas|fasl|sparcf|x86f)$",-                  "",-                  "### build and packaging systems",-                  "# cabal intermediates",-                  "\\.installed-pkg-config",-                  "\\.setup-config",-                  "# standard cabal build dir, might not be boring for everybody",-                  "# ^dist(/|$)",-                  "# autotools",-                  "(^|/)autom4te\\.cache($|/)", "(^|/)config\\.(log|status)$",-                  "# microsoft web expression, visual studio metadata directories",-                  "\\_vti_cnf$",-                  "\\_vti_pvt$",-                  "# gentoo tools",-                  "\\.revdep-rebuild.*",-                  "# generated dependencies",-                  "^\\.depend$",-                  "",-                  "### version control systems",-                  "# cvs",-                  "(^|/)CVS($|/)","\\.cvsignore$",-                  "# cvs, emacs locks",-                  "^\\.#",-                  "# rcs",-                  "(^|/)RCS($|/)", ",v$",-                  "# subversion",-                  "(^|/)\\.svn($|/)",-                  "# mercurial",-                  "(^|/)\\.hg($|/)",-                  "# git",-                  "(^|/)\\.git($|/)",-                  "# bzr",-                  "\\.bzr$",-                  "# sccs",-                  "(^|/)SCCS($|/)",-                  "# darcs",-                  "(^|/)"++darcsdir++"($|/)", "(^|/)\\.darcsrepo($|/)",-                  "^\\.darcs-temp-mail$",-                  "-darcs-backup[[:digit:]]+$",-                  "# gnu arch",-                  "(^|/)(\\+|,)",-                  "(^|/)vssver\\.scc$",-                  "\\.swp$","(^|/)MT($|/)",-                  "(^|/)\\{arch\\}($|/)","(^|/).arch-ids($|/)",-                  "# bitkeeper",-                  "(^|/)BitKeeper($|/)","(^|/)ChangeSet($|/)",-                  "",-                  "### miscellaneous",-                  "# backup files",-                  "~$","\\.bak$","\\.BAK$",-                  "# patch originals and rejects",-                  "\\.orig$", "\\.rej$",-                  "# X server",-                  "\\..serverauth.*",-                  "# image spam",-                  "\\#", "(^|/)Thumbs\\.db$",-                  "# vi, emacs tags",-                  "(^|/)(tags|TAGS)$",-                  "#(^|/)\\.[^/]",-                  "# core dumps",-                  "(^|/|\\.)core$",-                  "# partial broken files (KIO copy operations)",-                  "\\.part$",-                  "# waf files, see http://code.google.com/p/waf/",-                  "(^|/)\\.waf-[[:digit:].]+-[[:digit:]]+($|/)",-                  "(^|/)\\.lock-wscript$",-                  "# mac os finder",-                  "(^|/)\\.DS_Store$" ]- where-  help = map ("# "++) boringFileHelp--boringFileHelp :: [String]-boringFileHelp =- [ "This file contains a list of extended regular expressions, one per"- , "line. A file path matching any of these expressions will be filtered"- , "out during `darcs add', or when the `--look-for-adds' flag is passed"- , "to `darcs whatsnew' and `record'.  The entries in " ++ globalPrefsDirDoc ++ "boring (if"- , "it exists) supplement those in this file."- , ""- , "Blank lines, and lines beginning with an octothorpe (#) are ignored."- , "See regex(7) for a description of extended regular expressions."- ]--darcsdirFilter :: [FilePath] -> [FilePath]-darcsdirFilter = filter (not.isDarcsdir)-isDarcsdir :: FilePath -> Bool-isDarcsdir ('.':'/':f) = isDarcsdir f-isDarcsdir "." = True-isDarcsdir "" = True-isDarcsdir ".." = True-isDarcsdir "../" = True-isDarcsdir "_darcs" = True-isDarcsdir fp = "_darcs/" `isPrefixOf` fp---- | The path of the global preference directory; @~/.darcs@ on Unix,--- and @%APPDATA%/darcs@ on Windows.-globalPrefsDir :: IO (Maybe FilePath)-globalPrefsDir = do-  env <- getEnvironment-  case lookup "DARCS_TESTING_PREFS_DIR" env of-    Just d -> return (Just d)-    Nothing -> fmap Just (getAppUserDataDirectory "darcs")-               `catchall` (return Nothing)---- | The relative path of the global preference directory; @~/.darcs@ on Unix,--- and @%APPDATA%/darcs@ on Windows. This is used for online documentation.-globalPrefsDirDoc :: String-globalPrefsDirDoc =-#ifndef WIN32-  "~/.darcs/"-#else-  "%APPDATA%\\darcs\\"-#endif--environmentHelpHome :: ([String], [String])-environmentHelpHome = (["HOME", "APPDATA"], [- "Per-user preferences are set in $HOME/.darcs (on Unix) or",- "%APPDATA%/darcs (on Windows).  This is also the default location of",- "the cache."])--getGlobal :: String -> IO [String]-getGlobal f = do-  dir <- globalPrefsDir-  case dir of-    (Just d) -> getPreffile $ d </> f-    Nothing -> return []--globalCacheDir :: IO (Maybe FilePath)-globalCacheDir = slash_cache `fmap` globalPrefsDir-  where slash_cache = fmap (</> "cache")--boringRegexps :: IO [Regex]-boringRegexps = do-    borefile <- defPrefval "boringfile" (darcsdir ++ "/prefs/boring")-    bores <- getPrefLines borefile `catchall` return []-    gbs <- getGlobal "boring"-    return $ map mkRegex $ bores ++ gbs--boringFileFilter :: IO ([FilePath] -> [FilePath])-boringFileFilter = fmap actualBoringFileFilter boringRegexps--noncomments :: [String] -> [String]-noncomments ss = filter is_ok ss-                 where is_ok "" = False-                       is_ok ('#':_) = False-                       is_ok _ = True--getPrefLines :: FilePath -> IO [String]-getPrefLines f = (notconflicts . noncomments . map stripCr . lines)-              `fmap` readBinFile f-    where notconflicts = filter nc-          startswith [] _ = True-          startswith (x:xs) (y:ys) | x == y = startswith xs ys-          startswith _ _ = False-          nc l | startswith "v v v v v v v" l = False-          nc l | startswith "*************" l = False-          nc l | startswith "^ ^ ^ ^ ^ ^ ^" l = False-          nc _ = True---- | From a list of paths, filter out any that are within @_darcs@ or--- match a boring regexp.-actualBoringFileFilter :: [Regex] -> [FilePath] -> [FilePath]-actualBoringFileFilter regexps files = filter (not . boring . normalize) files-    where boring file = isDarcsdir file ||-                        any (\regexp -> isJust $ matchRegex regexp file) regexps--normalize :: FilePath -> FilePath-normalize ('.':'/':f) = normalize f-normalize f = normalize_helper $ reverse f-              where-              normalize_helper ('/':rf) = normalize_helper rf-              normalize_helper rf = reverse rf--data FileType = BinaryFile | TextFile-                deriving (Eq)--{-# NOINLINE defaultBinaries #-}--- | The lines that will be inserted into @_darcs/prefs/binaries@ when--- @darcs init@ is run.  Hence, a list of comments, blank lines and--- regular expressions (ERE dialect).------ Note that while this matches .gz and .GZ, it will not match .gZ,--- i.e. it is not truly case insensitive.-defaultBinaries :: [String]-defaultBinaries = help ++-                   ["\\.(" ++ e ++ "|" ++ map toUpper e ++ ")$" | e <- extensions ]-    where extensions = ["a","bmp","bz2","doc","elc","exe","gif","gz","iso",-                        "jar","jpe?g","mng","mpe?g","p[nbgp]m","pdf","png",-                        "pyc","so","tar","tgz","tiff?","z","zip"]-          help = map ("# "++) binariesFileHelp--binariesFileHelp :: [String]-binariesFileHelp =-  ["This file contains a list of extended regular expressions, one per",-   "line.  A file path matching any of these expressions is assumed to",-   "contain binary data (not text).  The entries in " ++ globalPrefsDirDoc ++ "binaries (if",-   "it exists) supplement those in this file.",-   "",-   "Blank lines, and lines beginning with an octothorpe (#) are ignored.",-   "See regex(7) for a description of extended regular expressions."]--filetypeFunction :: IO (FilePath -> FileType)-filetypeFunction = do-    binsfile <- defPrefval "binariesfile" (darcsdir ++ "/prefs/binaries")-    bins <- getPrefLines binsfile `catch`-             (\e-> if isDoesNotExistError e then return [] else ioError e)-    gbs <- getGlobal "binaries"-    let regexes = map mkRegex (bins ++ gbs)-    let isbin f = any (\r -> isJust $ matchRegex r f) regexes-        ftf f = if isbin $ normalize f then BinaryFile else TextFile-        in-        return ftf---- this avoids a circular dependency with Repository-prefsDirectory :: IO (Maybe String)-prefsDirectory =-    do darcs <- doesDirectoryExist darcsdir-       return $ if darcs-          then Just $ darcsdir ++ "/prefs/"-          else Nothing--withPrefsDirectory :: (String -> IO ()) -> IO ()-withPrefsDirectory j = prefsDirectory >>= maybe (return ()) j--addToPreflist :: String -> String -> IO ()-addToPreflist p s = withPrefsDirectory $ \prefs -> do-  hasprefs <- doesDirectoryExist prefs-  unless hasprefs $ createDirectory prefs-  pl <- getPreflist p-  writeBinFile (prefs ++ p) $ unlines $ union [s] pl--getPreflist :: String -> IO [String]-getPreflist p =  prefsDirectory >>= maybe (return []) (\prefs -> getPreffile $ prefs ++ p)--getPreffile :: FilePath -> IO [String]-getPreffile f = do-  hasprefs <- doesFileExist f-  if hasprefs-    then getPrefLines f-    else return []--setPreflist :: String -> [String] -> IO ()-setPreflist p ls = withPrefsDirectory $ \prefs -> do-  haspref <- doesDirectoryExist prefs-  when haspref $ writeBinFile (prefs ++ p) (unlines ls)--defPrefval :: String -> String -> IO String-defPrefval p d = fromMaybe d `fmap` getPrefval p--getPrefval :: String -> IO (Maybe String)-getPrefval p =-    do pl <- getPreflist "prefs"-       return $-        case map snd $ filter ((==p).fst) $ map (break (==' ')) pl of-           [val] ->-                case words val of-                    [] -> Nothing-                    _ -> Just $ tail val-           _ -> Nothing--setPrefval :: String -> String -> IO ()-setPrefval p v =  do pl <- getPreflist "prefs"-                     setPreflist "prefs" $-                       filter ((/=p) . fst . break (==' ')) pl ++ [p++" "++v]--changePrefval :: String -> String -> String -> IO ()-changePrefval p f t =-    do pl <- getPreflist "prefs"-       ov <- getPrefval p-       let newval = case ov of-                        Nothing -> t-                        Just old -> if old == f then t else old-       setPreflist "prefs" $-                    filter ((/=p) . fst . break(==' ')) pl ++ [p++" "++newval]--defaultrepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]-defaultrepo opts _ [] =-  do let fixR r | isFile r = toFilePath `fmap` ioAbsolute r-                | otherwise = return r-     case [r | RemoteRepo r <- opts] of-       [] -> do defrepo <- getPreflist "defaultrepo"-                case defrepo of-                  [r] -> (:[]) `fmap` fixR r-                  _ -> return []-       rs -> mapM fixR rs-defaultrepo _ _ r = return r--setDefaultrepo :: String -> [DarcsFlag] -> IO ()-setDefaultrepo r opts =  do olddef <- getPreflist "defaultrepo"-                            let doit = null noSetDefault && greenLight-                                greenLight = wetRun-                                           && not rIsTmp-                                           && (olddef /= [r] || olddef == [])-                            if doit-                               then setPreflist "defaultrepo" [r]-                               else when (True `notElem` noSetDefault && greenLight) $ putStr . unlines $-                                      -- the nuance here is that we should only notify when the-                                      -- reason we're not setting default is the --no-set-default-                                      -- flag, not the various automatic show stoppers-                                      [ "HINT: if you want to change the default remote repository to"-                                      , "      " ++ r ++ ","-                                      , "      quit now and issue the same command with the --set-default flag."-                                      ]-                            addToPreflist "repos" r-                         `catchall` return () -- we don't care if this fails!- where-  wetRun = DryRun `notElem` opts-  rIsTmp = r `elem` [x | RemoteRepo x <- opts]-  noSetDefault = [x | NoSetDefault x <- opts]--getCaches :: [DarcsFlag] -> String -> IO Cache-getCaches opts repodir =-    do here <- parsehs `fmap` getPreffile (darcsdir ++ "/prefs/sources")-       there <- (parsehs . lines . BC.unpack) `fmap`-                (gzFetchFilePS (repodir </> darcsdir </> "prefs/sources") Cachable-                 `catchall` return B.empty)-       globalcachedir <- globalCacheDir-       let globalcache = case (nocache,globalcachedir) of-                           (True,_) -> []-                           (_,Just d) -> [Cache Directory Writable d]-                           _ -> []-       globalsources <- parsehs `fmap` getGlobal "sources"-       thisdir <- getCurrentDirectory-       let thisrepo = [Cache Repo Writable $ toFilePath thisdir]-       let tempCache = nub $ thisrepo ++ globalcache ++ globalsources ++-                  here ++ [Cache Repo NotWritable repodir] ++ filterExternalSources there-       return $ Ca $ sortBy compareByLocality tempCache-      where-            parsehs = mapMaybe readln . noncomments-            readln l | "repo:"     `isPrefixOf` l = Just (Cache Repo NotWritable (drop 5 l))-                     | nocache = Nothing-                     | "cache:"    `isPrefixOf` l = Just (Cache Directory Writable    (drop 6 l))-                     | "readonly:" `isPrefixOf` l = Just (Cache Directory NotWritable (drop 9 l))-                     | otherwise = Nothing-            nocache = NoCache `elem` opts-            filterExternalSources there = if isFile repodir-                                          then-                                            there-                                          else-                                            filter (not . isFile . cacheSource) there+module Darcs.Repository.Prefs+    ( Pref(..)+    , addToPreflist+    , deleteSources+    , getPreflist+    , setPreflist+    , getGlobal++    , environmentHelpHome+    , getDefaultRepo+    , addRepoSource++    -- these are for the setpref command i.e. contents of _darcs/prefs/prefs+    , getPrefval+    , setPrefval+    , changePrefval+    , defPrefval++    , writeDefaultPrefs+    , isBoring+    , FileType(..)+    , filetypeFunction+    , getCaches+    , globalCacheDir+    , globalPrefsDirDoc+    , globalPrefsDir+    , getMotd+    , showMotd+    , prefsUrl+    , prefsDirPath --re-export+    , prefsFilePath+    , getPrefLines -- exported for darcsden, don't remove+    -- * documentation of prefs files+    , prefsFilesHelp+    ) where++import Darcs.Prelude++import Control.Exception ( catch )+import Control.Monad ( unless, when, liftM )+import Data.Char ( toLower, toUpper )+import Data.List ( isPrefixOf, union, lookup )+import Data.Maybe+    ( catMaybes+    , fromMaybe+    , isJust+    , listToMaybe+    , mapMaybe+    , maybeToList+    )+import qualified Control.Exception as C+import qualified Data.ByteString       as B  ( empty, null, hPut, ByteString )+import qualified Data.ByteString.Char8 as BC ( unpack )+import Safe ( tailErr )+import System.Directory+    ( createDirectory+    , doesDirectoryExist+    , doesFileExist+    , getAppUserDataDirectory+    , getHomeDirectory+    )+import System.Environment ( getEnvironment )+import System.FilePath.Posix ( normalise, dropTrailingPathSeparator, (</>) )+import System.IO.Error ( isDoesNotExistError, catchIOError )+import System.IO ( stdout, stderr )+import System.Info ( os )+import System.Posix.Files ( fileOwner, getFileStatus, ownerModes, setFileMode )++import Darcs.Util.Cache+    ( Cache+    , CacheLoc(..)+    , CacheType(..)+    , WritableOrNot(..)+    , mkCache+    , parseCacheLoc+    )+import Darcs.Util.File ( Cachable(..), fetchFilePS, gzFetchFilePS )+import Darcs.Repository.Flags+    ( UseCache (..)+    , DryRun (..)+    , SetDefault (..)+    , InheritDefault (..)+    , WithPrefsTemplates(..)+    )+import Darcs.Repository.Paths ( prefsDirPath )+import Darcs.Util.Lock( readTextFile, writeTextFile )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.Global ( darcsdir, debugMessage )+import Darcs.Util.Path+    ( AbsoluteOrRemotePath+    , getCurrentDirectory+    , toFilePath+    , toPath+    )+import Darcs.Util.Printer( hPutDocLn, text )+import Darcs.Util.Regex ( Regex, mkRegex, matchRegex )+import Darcs.Util.URL ( isValidLocalPath )+import Darcs.Util.File ( removeFileMayNotExist )++windows,osx :: Bool+windows = "mingw" `isPrefixOf` os -- GHC under Windows is compiled with mingw+osx     = os == "darwin"++writeDefaultPrefs :: WithPrefsTemplates -> IO ()+writeDefaultPrefs withPrefsTemplates = do+    setPreflist Boring $ defaultBoring withPrefsTemplates+    setPreflist Binaries $ defaultBinaries withPrefsTemplates+    setPreflist Motd []++defaultBoring :: WithPrefsTemplates -> [String]+defaultBoring withPrefsTemplates =+  map ("# " ++) boringFileInternalHelp +++    case withPrefsTemplates of+      NoPrefsTemplates -> []+      WithPrefsTemplates -> defaultBoringTemplate++defaultBoringTemplate :: [String]+defaultBoringTemplate =+    [ ""+    , "### compiler and interpreter intermediate files"+    , "# haskell (ghc) interfaces"+    , "\\.hi$", "\\.hi-boot$", "\\.o-boot$"+    , "# object files"+    , "\\.o$","\\.o\\.cmd$"+    , "# profiling haskell"+    , "\\.p_hi$", "\\.p_o$"+    , "# haskell program coverage resp. profiling info"+    , "\\.tix$", "\\.prof$"+    , "# fortran module files"+    , "\\.mod$"+    , "# linux kernel"+    , "\\.ko\\.cmd$","\\.mod\\.c$"+    , "(^|/)\\.tmp_versions/"+    , "# *.ko files aren't boring by default because they might"+    , "# be Korean translations rather than kernel modules"+    , "# \\.ko$"+    , "# python, emacs, java byte code"+    , "\\.py[co]$", "\\.elc$","\\.class$"+    , "# objects and libraries; lo and la are libtool things"+    , "\\.(obj|a|exe|so|lo|la)$"+    , "# compiled zsh configuration files"+    , "\\.zwc$"+    , "# Common LISP output files for CLISP and CMUCL"+    , "\\.(fas|fasl|sparcf|x86f)$"+    , ""+    , "### build and packaging systems"+    , "# cabal intermediates"+    , "\\.installed-pkg-config"+    , "\\.setup-config"+    , "# standard cabal build dir, might not be boring for everybody"+    , "# ^dist(/|$)"+    , "# autotools"+    , "(^|/)autom4te\\.cache/", "(^|/)config\\.(log|status)$"+    , "# microsoft web expression, visual studio metadata directories"+    , "\\_vti_cnf$"+    , "\\_vti_pvt$"+    , "# gentoo tools"+    , "\\.revdep-rebuild.*"+    , "# generated dependencies"+    , "^\\.depend$"+    , ""+    , "### version control systems"+    , "# cvs"+    , "(^|/)CVS/","\\.cvsignore$"+    , "# cvs, emacs locks"+    , "^\\.#"+    , "# rcs"+    , "(^|/)RCS/", ",v$"+    , "# subversion"+    , "(^|/)\\.svn/"+    , "# mercurial"+    , "(^|/)\\.hg/"+    , "# git"+    , "(^|/)\\.git/"+    , "# bzr"+    , "\\.bzr$"+    , "# sccs"+    , "(^|/)SCCS/"+    , "# darcs"+    , "(^|/)"++darcsdir++"/", "(^|/)\\.darcsrepo/"+    , "# gnu arch"+    , "(^|/)(\\+|,)"+    , "(^|/)vssver\\.scc$"+    , "\\.swp$","(^|/)MT/"+    , "(^|/)\\{arch\\}/","(^|/).arch-ids/"+    , "# bitkeeper"+    , "(^|/)BitKeeper/","(^|/)ChangeSet/"+    , ""+    , "### miscellaneous"+    , "# backup files"+    , "~$","\\.bak$","\\.BAK$"+    , "# patch originals and rejects"+    , "\\.orig$", "\\.rej$"+    , "# X server"+    , "\\..serverauth.*"+    , "# image spam"+    , "\\#", "(^|/)Thumbs\\.db$"+    , "# vi, emacs tags"+    , "(^|/)(tags|TAGS)$"+    , "#(^|/)\\.[^/]"+    , "# core dumps"+    , "(^|/|\\.)core$"+    , "# partial broken files (KIO copy operations)"+    , "\\.part$"+    , "# waf files, see http://code.google.com/p/waf/"+    , "(^|/)\\.waf-[[:digit:].]+-[[:digit:]]+/"+    , "(^|/)\\.lock-wscript$"+    , "# mac os finder"+    , "(^|/)\\.DS_Store$"+    , "# emacs saved sessions (desktops)"+    , "(^|.*/)\\.emacs\\.desktop(\\.lock)?$"+    , " # stack"+    , "(^|/)\\.stack-work/"+    ]++boringFileInternalHelp :: [String]+boringFileInternalHelp =+    [ "This file contains a list of extended regular expressions, one per"+    , "line. A file path matching any of these expressions will be filtered"+    , "out during `darcs add`, or when the `--look-for-adds` flag is passed"+    , "to `darcs whatsnew` and `record`. The entries in "+        ++ globalPrefsDirDoc ++ "boring (if"+    , "it exists) supplement those in this file."+    , ""+    , "Blank lines, and lines beginning with an octothorpe (#) are ignored."+    , "See regex(7) for a description of extended regular expressions."+    ]++-- | The path of the global preference directory; @~/.darcs@ on Unix,+-- and @%APPDATA%/darcs@ on Windows.+globalPrefsDir :: IO (Maybe FilePath)+globalPrefsDir = do+    env <- getEnvironment+    case lookup "DARCS_TESTING_PREFS_DIR" env of+        Just d -> return (Just d)+        Nothing -> Just `fmap` getAppUserDataDirectory "darcs"+                   `catchall` return Nothing++-- | The relative path of the global preference directory; @~/.darcs@ on Unix,+-- and @%APPDATA%/darcs@ on Windows. This is used for online documentation.+globalPrefsDirDoc :: String+globalPrefsDirDoc | windows   = "%APPDATA%\\darcs\\"+                  | otherwise = "~/.darcs/"++environmentHelpHome :: ([String], [String])+environmentHelpHome =+    ( ["HOME", "APPDATA"]+    , [ "Per-user preferences are set in $HOME/.darcs (on Unix) or"+      , "%APPDATA%/darcs (on Windows).  This is also the default location of"+      , "the cache."+      ]+    )++getGlobal :: Pref -> IO [String]+getGlobal f = do+    dir <- globalPrefsDir+    case dir of+        (Just d) -> getPreffile $ d </> formatPref f+        Nothing -> return []++-- |osxCacheDir assumes @~/Library/Caches/@ exists.+osxCacheDir :: IO (Maybe FilePath)+osxCacheDir = do+    home <- getHomeDirectory+    return $ Just $ home </> "Library" </> "Caches"+    `catchall` return Nothing++-- |xdgCacheDir returns the $XDG_CACHE_HOME environment variable,+-- or @~/.cache@ if undefined. See the FreeDesktop specification:+-- http://standards.freedesktop.org/basedir-spec/basedir-spec-latest.html+xdgCacheDir :: IO (Maybe FilePath)+xdgCacheDir = do+    env <- getEnvironment+    d <- case lookup "XDG_CACHE_HOME" env of+           Just d  -> return d+           Nothing -> getAppUserDataDirectory "cache"+    exists <- doesDirectoryExist d++    -- If directory does not exist, create it with permissions 0700+    -- as specified by the FreeDesktop standard.+    unless exists $ do createDirectory d+                       setFileMode d ownerModes+    return $ Just d+    `catchall` return Nothing++globalCacheDir :: IO (Maybe FilePath)+globalCacheDir | windows   = ((</> "cache2") `fmap`) `fmap` globalPrefsDir+               | osx       = ((</> "darcs") `fmap`) `fmap` osxCacheDir+               | otherwise = ((</> "darcs") `fmap`) `fmap` xdgCacheDir++-- |tryMakeBoringRegexp attempts to create a Regex from a given String. The+-- evaluation is forced, to ensure any malformed exceptions are thrown here,+-- and not later.+tryMakeBoringRegexp :: String -> IO (Maybe Regex)+tryMakeBoringRegexp input = regex `C.catch` handleBadRegex+  where+    regex = C.evaluate (Just $! mkRegex input)++    handleBadRegex :: C.SomeException -> IO (Maybe Regex)+    handleBadRegex _ = hPutDocLn stderr warning >> return Nothing++    warning = text $ "Warning: Ignored invalid boring regex: " ++ input++-- |boringRegexps returns a list of the boring regexps, from the local and+-- global prefs/boring files. Any invalid regexps are filtered, preventing an+-- exception in (potentially) pure code, when the regexps are used.+boringRegexps :: IO [Regex]+boringRegexps = do+    borefile <- maybeToList <$> getPrefval "boringfile"+    localBores <-+      concat <$> safeGetPrefLines `mapM` (borefile ++ [prefsFile Boring])+    globalBores <- getGlobal Boring+    liftM catMaybes $ mapM tryMakeBoringRegexp $ localBores ++ globalBores+  where+    safeGetPrefLines fileName = getPrefLines fileName `catchall` return []++isBoring :: IO (FilePath -> Bool)+isBoring = do+  regexps <- boringRegexps+  return $ \file -> any (\r -> isJust $ matchRegex r file) regexps++noncomments :: [String] -> [String]+noncomments = filter nonComment+  where+    nonComment "" = False+    nonComment ('#' : _) = False+    nonComment _ = True++getPrefLines :: FilePath -> IO [String]+getPrefLines f = removeCRsCommentsAndConflicts `fmap` readTextFile f+  where+    removeCRsCommentsAndConflicts =+        filter notconflict . noncomments . map stripCr+    startswith [] _ = True+    startswith (x : xs) (y : ys) = x == y && startswith xs ys+    startswith _ _ = False+    notconflict l+        | startswith "v v v v v v v" l = False+        | startswith "*************" l = False+        | startswith "^ ^ ^ ^ ^ ^ ^" l = False+        | otherwise = True+    stripCr ""     = ""+    stripCr "\r"   = ""+    stripCr (c : cs) = c : stripCr cs++doNormalise :: FilePath -> FilePath+doNormalise = dropTrailingPathSeparator . normalise++data FileType = BinaryFile+              | TextFile+              deriving (Eq)++-- | The lines that will be inserted into @_darcs/prefs/binaries@ when+-- @darcs init@ is run.  Hence, a list of comments, blank lines and+-- regular expressions (ERE dialect).+--+-- Note that while this matches .gz and .GZ, it will not match .gZ,+-- i.e. it is not truly case insensitive.+defaultBinaries :: WithPrefsTemplates -> [String]+defaultBinaries withPrefsTemplates =+  map ("# "++) binariesFileInternalHelp +++    case withPrefsTemplates of+      NoPrefsTemplates -> []+      WithPrefsTemplates -> defaultBinariesTemplate++defaultBinariesTemplate :: [String]+defaultBinariesTemplate =+    [ "\\." ++ regexToMatchOrigOrUpper e ++ "$" | e <- extensions ]+  where+    regexToMatchOrigOrUpper e = "(" ++ e ++ "|" ++ map toUpper e ++ ")"+    extensions =+        [ "a"+        , "bmp"+        , "bz2"+        , "doc"+        , "elc"+        , "exe"+        , "gif"+        , "gz"+        , "iso"+        , "jar"+        , "jpe?g"+        , "mng"+        , "mpe?g"+        , "p[nbgp]m"+        , "pdf"+        , "png"+        , "pyc"+        , "so"+        , "tar"+        , "tgz"+        , "tiff?"+        , "z"+        , "zip"+        ]++binariesFileInternalHelp :: [String]+binariesFileInternalHelp =+    [ "This file contains a list of extended regular expressions, one per"+    , "line.  A file path matching any of these expressions is assumed to"+    , "contain binary data (not text). The entries in "+        ++ globalPrefsDirDoc ++ "binaries (if"+    , "it exists) supplement those in this file."+    , ""+    , "Blank lines, and lines beginning with an octothorpe (#) are ignored."+    , "See regex(7) for a description of extended regular expressions."+    ]++filetypeFunction :: IO (FilePath -> FileType)+filetypeFunction = do+    binsfile <- maybeToList <$> getPrefval "binariesfile"+    bins <-+      concat <$> safeGetPrefLines `mapM` (binsfile ++ [prefsFile Binaries])+    gbs <- getGlobal Binaries+    let binaryRegexes = map mkRegex (bins ++ gbs)+        isBinary f = any (\r -> isJust $ matchRegex r f) binaryRegexes+        ftf f = if isBinary $ doNormalise f then BinaryFile else TextFile+    return ftf+  where+    safeGetPrefLines fileName =+        getPrefLines fileName+        `catch`+        (\e -> if isDoesNotExistError e then return [] else ioError e)++findPrefsDirectory :: IO (Maybe String)+findPrefsDirectory = do+    inDarcsRepo <- doesDirectoryExist darcsdir+    return $ if inDarcsRepo+                 then Just prefsDirPath+                 else Nothing++withPrefsDirectory :: (String -> IO ()) -> IO ()+withPrefsDirectory job = findPrefsDirectory >>= maybe (return ()) job++data Pref+  = Author+  | Binaries+  | Boring+  | Defaultrepo+  | Defaults+  | Email+  | Motd+  | Post+  | Prefs+  | Repos+  | Sources+  deriving (Eq, Ord, Read, Show)++formatPref :: Pref -> String+formatPref = map toLower . show++addToPreflist :: Pref -> String -> IO ()+addToPreflist pref value =+  withPrefsDirectory $ \prefs_dir -> do+    hasprefs <- doesDirectoryExist prefs_dir+    unless hasprefs $ createDirectory prefs_dir+    pl <- getPreflist pref+    writeTextFile (prefs_dir </> formatPref pref) . unlines $ union [value] pl++getPreflist :: Pref -> IO [String]+getPreflist pref =+  findPrefsDirectory >>=+  maybe (return []) (\prefs_dir -> getPreffile $ prefs_dir </> formatPref pref)++getPreffile :: FilePath -> IO [String]+getPreffile f = do+    hasprefs <- doesFileExist f+    if hasprefs then getPrefLines f else return []++setPreflist :: Pref -> [String] -> IO ()+setPreflist p ls = withPrefsDirectory $ \prefs_dir -> do+    haspref <- doesDirectoryExist prefs_dir+    when haspref $+        writeTextFile (prefs_dir </> formatPref p) (unlines ls)++defPrefval :: String -> String -> IO String+defPrefval p d = fromMaybe d `fmap` getPrefval p++getPrefval :: String -> IO (Maybe String)+getPrefval p = do+    pl <- getPreflist Prefs+    return $ case map snd $ filter ((== p) . fst) $ map (break (== ' ')) pl of+                 [val] -> case words val of+                    [] -> Nothing+                    _ -> Just $ tailErr val+                 _ -> Nothing++setPrefval :: String -> String -> IO ()+setPrefval p v = do+    pl <- getPreflist Prefs+    setPreflist Prefs $ updatePrefVal pl p v++updatePrefVal :: [String] -> String -> String -> [String]+updatePrefVal prefList p newVal =+    filter ((/= p) . fst . break (== ' ')) prefList ++ [p ++ " " ++ newVal]++changePrefval :: String -> String -> String -> IO ()+changePrefval p f t = do+    pl <- getPreflist Prefs+    ov <- getPrefval p+    let newval = maybe t (\old -> if old == f then t else old) ov+    setPreflist Prefs $ updatePrefVal pl p newval++getDefaultRepo :: IO (Maybe String)+getDefaultRepo = listToMaybe <$> getPreflist Defaultrepo++-- | addRepoSource adds a new entry to _darcs/prefs/repos and sets it as default+--   in _darcs/prefs/defaultrepo, unless --no-set-default or --dry-run is passed,+--   or it is the same repository as the current one.+addRepoSource :: String+              -> DryRun+              -> SetDefault+              -> InheritDefault+              -> Bool+              -> IO ()+addRepoSource r isDryRun setDefault inheritDefault isInteractive = (do+    olddef <- getDefaultRepo+    newdef <- newDefaultRepo+    let shouldDoIt = null noSetDefault && greenLight+        greenLight = shouldAct && olddef /= Just newdef+    -- the nuance here is that we should only notify when the reason we're not+    -- setting default is the --no-set-default flag, not the various automatic+    -- show stoppers+    if shouldDoIt+       then setPreflist Defaultrepo [newdef]+       else when (True `notElem` noSetDefault && greenLight && inheritDefault == NoInheritDefault) $+                putStr . unlines $ setDefaultMsg+    addToPreflist Repos newdef) `catchall` return ()+  where+    shouldAct = isDryRun == NoDryRun+    noSetDefault = case setDefault of+                       NoSetDefault x -> [x]+                       _ -> []+    setDefaultMsg =+        [ "By the way, to change the default remote repository to"+        , "      " ++ r ++ ","+        , "you can " +++          (if isInteractive then "quit now and " else "") +++          "issue the same command with the --set-default flag."+        ]+    newDefaultRepo :: IO String+    newDefaultRepo = case inheritDefault of+      YesInheritDefault -> getRemoteDefaultRepo+      NoInheritDefault -> return r+    -- TODO It would be nice if --inherit-default could be made to work with+    -- arbitrary remote repos; for security reasons we currently allow only+    -- repos on the same host which must also be owned by ourselves. This is+    -- because the defaultrepo file is read and written as a text file, and+    -- therefore encoded in the user's locale encoding. See+    -- http://bugs.darcs.net/issue2627 for a more detailed discussion.+    getRemoteDefaultRepo+      | isValidLocalPath r = do+          sameOwner r "." >>= \case+            True -> do+              defs <-+                getPreffile (prefsUrl r Defaultrepo)+                `catchIOError`+                const (return [r])+              case defs of+                defrepo:_ -> do+                  debugMessage "using defaultrepo of remote"+                  return defrepo+                [] -> return r+            False -> return r+      | otherwise = return r+    -- In case r is a symbolic link we do want the target directory's+    -- status, not that of the symlink.+    sameOwner p q =+      (==) <$> (fileOwner <$> getFileStatus p) <*> (fileOwner <$> getFileStatus q)++-- | delete references to other repositories.+--   Used when cloning to a ssh destination.+--   Assume the current working dir is the repository.+deleteSources :: IO ()+deleteSources = do+  removeFileMayNotExist (prefsFile Sources)+  removeFileMayNotExist (prefsFile Repos)++getCaches :: UseCache -> Maybe AbsoluteOrRemotePath -> IO Cache+getCaches useCache from = do+    here <- parsehs `fmap` getPreflist Sources+    globalcachedir <- globalCacheDir+    let globalcache = if nocache+                          then []+                          else case globalcachedir of+                              Nothing -> []+                              Just d -> [Cache Directory Writable d]+    globalsources <- parsehs `fmap` getGlobal Sources+    thisdir <- getCurrentDirectory+    let thisrepo = [Cache Repo Writable $ toFilePath thisdir]+    from_cache <-+      case from of+        Nothing -> return []+        Just repoloc -> do+          there <- (parsehs . lines . BC.unpack)+                 `fmap`+                 (gzFetchFilePS (prefsUrl (toPath repoloc) Sources) Cachable+                  `catchall` return B.empty)+          let thatrepo = [Cache Repo NotWritable (toPath repoloc)]+              externalSources =+                  if isValidLocalPath (toPath repoloc)+                      then there+                      else filter (not . isValidLocalPath . cacheSource) there+          return (thatrepo ++ externalSources)+    return $ mkCache (thisrepo ++ here ++ globalcache ++ globalsources ++ from_cache)+  where+    parsehs = filter by . mapMaybe parseCacheLoc . noncomments+    by (Cache Directory _ _) = not nocache+    by (Cache Repo Writable _) = False -- ignore thisrepo: entries+    by _ = True+    nocache = useCache == NoUseCache++-- | Fetch and return the message of the day for a given repository.+getMotd :: String -> IO B.ByteString+getMotd repo = fetchFilePS motdPath (MaxAge 600) `catchall` return B.empty+  where+    motdPath = prefsUrl repo Motd++-- | Display the message of the day for a given repository,+showMotd :: String -> IO ()+showMotd repo = do+    motd <- getMotd repo+    unless (B.null motd) $ do+        B.hPut stdout motd+        putStrLn $ replicate 22 '*'++prefsUrl :: String -> Pref -> String+prefsUrl repourl pref = repourl </> prefsDirPath </> formatPref pref++prefsFile :: Pref -> FilePath+prefsFile pref = prefsDirPath </> formatPref pref++prefsFilePath :: FilePath+prefsFilePath = prefsFile Prefs++prefsFilesHelp :: [(String,String)]+prefsFilesHelp  =+    [ ("motd", unlines+      [ "The `_darcs/prefs/motd` file may contain a 'message of the day' which"+      , "will be displayed to users who clone or pull from the repository without"+      , "the `--quiet` option."])+    , ("email", unlines+      [ "The `_darcs/prefs/email` file is used to provide the e-mail address for"+      , "your repository that others will use when they `darcs send` a patch back"+      , "to you. The contents of the file should simply be an e-mail address."])+    , ("post", unlines+      [ "If `_darcs/prefs/post` exists in the target repository, `darcs send ` will"+      , "upload to the URL contained in that file, which may either be a `mailto:`"+      , "URL, or an `http://` URL. In the latter case, the patch is posted to that URL."])+    , ("author", unlines+      [ "The `_darcs/prefs/author` file contains the email address (or name) to"+      , "be used as the author when patches are recorded in this repository,"+      , "e.g. `David Roundy <droundy@abridgegame.org>`. This file overrides the"+      , "contents of the environment variables `$DARCS_EMAIL` and `$EMAIL`."])+    , ("defaults", unlines+      [ "Default options for darcs commands. Each line of this file has the"+      , "following form:"+      , ""+      , "    COMMAND FLAG VALUE"+      , ""+      , "where `COMMAND` is either the name of the command to which the default"+      , "applies, or `ALL` to indicate that the default applies to all commands"+      , "accepting that flag. The `FLAG` term is the name of the long argument"+      , "option with or without the `--`, i.e. `verbose` or `--verbose`."+      , "Finally, the `VALUE` option can be omitted if the flag does not involve"+      , "a value. If the value has spaces in it, use single quotes, not double"+      , "quotes, to surround it. Each line only takes one flag. To set multiple"+      , "defaults for the same command (or for `ALL` commands), use multiple lines."+      , ""+      , "Options listed in the defaults file are just that: defaults. You can"+      , "override any default on the command line."+      , ""+      , "Note that the use of `ALL` easily can have unpredicted consequences,"+      , "especially if commands in newer versions of darcs accepts flags that"+      , "they did not in previous versions. Only use safe flags with `ALL`."+      , ""+      , "For example, if your system clock is bizarre, you could instruct darcs to"+      , "always ignore the file modification times by adding the following line:"+      , ""+      , "    ALL ignore-times"+      , ""+      , "There are some options which are meant specifically for use in"+      , "`_darcs/prefs/defaults`. One of them is `--disable`. As the name"+      , "suggests, this option will disable every command that got it as"+      , "argument. So, if you are afraid that you could damage your repositories"+      , "by inadvertent use of a command like amend, add the following line:"+      , ""+      , "    amend disable"+      , ""+      , "A global defaults file can be created with the name"+      , "`.darcs/defaults` in your home directory. In case of conflicts,"+      , "the defaults for a specific repository take precedence."+      ])+    , ("boring", unlines+      [ "The `_darcs/prefs/boring` file may contain a list of regular expressions"+      , "describing files, such as object files, that you do not expect to add to"+      , "your project. A newly created repository has a boring file that includes"+      , "many common source control, backup, temporary, and compiled files."+      , ""+      , "You may want to have the boring file under version control. To do this"+      , "you can use darcs setpref to set the value 'boringfile' to the name of"+      , "your desired boring file (e.g. `darcs setpref boringfile .boring`, where"+      , "`.boring` is the repository path of a file that has been darcs added to"+      , "your repository). The boringfile preference overrides"+      , "`_darcs/prefs/boring`, so be sure to copy that file to the boringfile."+      , ""+      , "You can also set up a 'boring' regexps file in your home directory, named"+      , "`~/.darcs/boring`, which will be used with all of your darcs repositories."+      , ""+      , "Any file not already managed by darcs and whose repository path"+      , "matches any of the boring regular expressions is"+      , "considered boring. The boring file is used to filter the files provided"+      , "to darcs add, to allow you to use a simple `darcs add newdir newdir/*`"+      , "without accidentally adding a bunch of object files. It is also used"+      , "when the `--look-for-adds` flag is given to whatsnew or record. Note"+      , "that once a file has been added to darcs, it is not considered boring,"+      , "even if it matches the boring file filter."])+    , ("binaries", unlines+      [ "The `_darcs/prefs/binaries` file may contain a list of regular"+      , "expressions describing files that should be treated as binary files rather"+      , "than text files. Darcs automatically treats files containing characters"+      , "`^Z` or `NULL` within the first 4096 bytes as being binary files."+      , "You probably will want to have the binaries file under version control."+      , "To do this you can use `darcs setpref` to set the value 'binariesfile'"+      , "to the name of your desired binaries file"+      , "(e.g. `darcs setpref binariesfile ./.binaries`, where `.binaries` is a"+      , "file that has been darcs added to your repository). As with the boring"+      , "file, you can also set up a `~/.darcs/binaries` file if you like."])+    , ("defaultrepo", unlines+      [ "Contains the URL of the default remote repository used by commands `pull`,"+      , "`push`, `send` and `optimize relink`. Darcs edits this file automatically"+      , "or when the flag `--set-default` is used."])+    , ("sources", unlines+      [ "Besides the defaultrepo, darcs also keeps track of any other locations"+      , "used in commands for exchanging patches (e.g. push, pull, send)."+      , "These are subsequently used as alternatives from which to download"+      , "patches. The file contains lines such as:"+      , ""+      , "    cache:/home/droundy/.cache/darcs"+      , "    readonly:/home/otheruser/.cache/darcs"+      , "    repo:http://darcs.net"+      , ""+      , "The prefix `cache:` indicates that darcs can use this as a read-write"+      , "cache for patches, `read-only:` indicates a cache that is only"+      , "readable, and `repo:` denotes a (possibly remote) repository. The order"+      , "of the entries is immaterial: darcs will always try local paths before"+      , "remote ones, and only local ones will be used as potentially writable."+      , ""+      , "A global cache is enabled by default in your home directory under"+      , "`.cache/darcs` (older versions of darcs used `.darcs/cache` for this),"+      , "or `$XDG_CACHE_HOME/darcs` if the environment variable is set, see"+      , "https://specifications.freedesktop.org/basedir-spec/basedir-spec-latest.html."+      , "The cache allows darcs to avoid re-downloading patches (for example, when"+      , "doing a second darcs clone of the same repository), and also allows darcs"+      , "to use hard links to reduce disk usage."+      , ""+      , "Note that the cache directory should reside on the same filesystem as"+      , "your repositories, so you may need to vary this. You can also use"+      , "multiple cache directories on different filesystems, if you have several"+      , "filesystems on which you use darcs."+      , ""+      , "While darcs automatically adds entries to `_darcs/prefs/sources`, it does"+      , "not currently remove them. If one or more of the entries aren't accessible"+      , "(e.g. because they resided on a removable media), then darcs will bugger"+      , "you with a hint, suggesting you remove those entries. This is done because"+      , "certain systems have extremely long timeouts associated with some remotely"+      , "accessible media (e.g. NFS over automounter on Linux), which can slow down"+      , "darcs operations considerably. On the other hand, when you clone a repo"+      , "with --lazy from a no longer accessible location, then the hint may give"+      , "you an idea where the patches could be found, so you can try to restore"+      , "access to them."+      ])+    , ("tmpdir", unlines+      [ "By default temporary directories are created in `/tmp`, or if that doesn't"+      , "exist, in `_darcs` (within the current repo).  This can be overridden by"+      , "specifying some other directory in the file `_darcs/prefs/tmpdir` or the"+      , "environment variable `$DARCS_TMPDIR` or `$TMPDIR`."])+    , ("prefs", unlines+      [ "Contains the preferences set by the command `darcs setprefs`."+      , "Do not edit manually."])+    ]
+ src/Darcs/Repository/Pristine.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+module Darcs.Repository.Pristine+    ( applyToTentativePristine+    , readHashedPristineRoot+    , pokePristineHash+    , peekPristineHash+    , createPristineDirectoryTree+    , readPristine+    , writePristine+    , convertSizePrefixedPristine+    ) where++import Darcs.Prelude++import Control.Exception ( catch, IOException, throwIO )++import System.Directory ( withCurrentDirectory )+import System.FilePath.Posix ( (</>) )+import System.IO ( hPutStrLn, stderr )+import System.IO.Error ( catchIOError )++import Darcs.Patch ( PatchInfoAnd, RepoPatch, description )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Invertible ( Invertible )+import Darcs.Patch.Show ( ShowPatch )+import Darcs.Patch.Witnesses.Ordered ( FL )++import Darcs.Repository.Flags ( WithWorkingDir(..) )+import Darcs.Repository.Format ( RepoProperty(HashedInventory), formatHas )+import Darcs.Repository.Inventory+import Darcs.Repository.InternalTypes+    ( Repository+    , AccessType(..)+    , SAccessType(..)+    , repoAccessType+    , repoCache+    , repoFormat+    , repoLocation+    , withRepoDir+    )+import Darcs.Repository.Old ( oldRepoFailMsg )+import Darcs.Repository.Paths+    ( hashedInventoryPath+    , tentativePristinePath+    )++import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Cache ( Cache )+import Darcs.Util.Lock ( writeDocBinFile )+import Darcs.Util.Printer ( ($$), renderString, text )+import Darcs.Util.Tree ( Tree )+import Darcs.Util.Tree.Hashed+    ( darcsAddMissingHashes+    , darcsTreeHash+    , hashedTreeIO+    , readDarcsHashed+    , readDarcsHashedNosize+    , writeDarcsHashed+    )+import Darcs.Util.Tree.Plain ( writePlainTree )+import Darcs.Util.ValidHash ( fromHash, getSize )+++-- | Apply a patch to the 'Tree' identified by the given root 'PristineHash',+-- then return the root hash of the result. The 'ApplyDir' argument says+-- whether to add or remove the changes. The 'Cache' argument specifies the+-- possible locations for hashed files.+applyToHashedPristine :: (Apply p, ApplyState p ~ Tree, ShowPatch p)+                      => Cache+                      -> PristineHash+                      -> p wX wY+                      -> IO PristineHash+applyToHashedPristine cache root patch = tryApply `catchIOError` annotateError+  where+    tryApply :: IO PristineHash+    tryApply = do+        -- Read a non-size-prefixed pristine, failing if we encounter one.+        tree <- readDarcsHashedNosize cache root+        (_, updatedTree) <- hashedTreeIO (apply patch) tree cache+        return $ fromHash $ darcsTreeHash updatedTree++    annotateError e =+      throwIO $+      userError $+      renderString $+      "Cannot apply patch to pristine:" $$ (description patch) $$+      "You may want to run 'darcs repair' on the repository containing this patch." $$+      "Reason: " <> text (show e)++convertSizePrefixedPristine :: Cache -> PristineHash -> IO PristineHash+convertSizePrefixedPristine cache ph = do+  case getSize ph of+    Nothing -> return ph+    Just _ -> do+      hPutStrLn stderr "Converting pristine..."+      -- Read the old size-prefixed pristine tree+      old <- readDarcsHashed cache ph+      -- Write out the pristine tree as a non-size-prefixed pristine+      -- and return the new root hash.+      writeDarcsHashed old cache++-- | Apply an 'FL' of 'Invertible' patches tentative pristine tree, and update+-- the tentative pristine hash. The patches need to be 'Invertible' so that we+-- can use it when removing patches from the repository, too.+applyToTentativePristine :: (ApplyState p ~ Tree, RepoPatch p)+                         => Repository 'RW p wU wR+                         -> Invertible (FL (PatchInfoAnd p)) wR wY+                         -> IO ()+applyToTentativePristine r p = do+    tentativePristine <- gzReadFilePS tentativePristinePath+    -- Extract the pristine hash from the tentativePristine file, using+    -- peekPristineHash (this is valid since we normally just extract the hash+    -- from the first line of an inventory file; we can pass in a one-line file+    -- that just contains said hash).+    let tentativePristineHash = peekPristineHash tentativePristine+    newPristineHash <- applyToHashedPristine (repoCache r) tentativePristineHash p+    writeDocBinFile tentativePristinePath $+        pokePristineHash newPristineHash tentativePristine++readHashedPristineRoot :: Repository rt p wU wR -> IO PristineHash+readHashedPristineRoot r =+  withRepoDir r $+    case repoAccessType r of+      SRO -> getHash hashedInventoryPath+      SRW -> getHash tentativePristinePath -- note the asymmetry!+  where+    getHash path =+      peekPristineHash <$>+        gzReadFilePS path `catch` (\(_ :: IOException) -> fail oldRepoFailMsg)++-- | Write the pristine tree into a plain directory at the given path.+createPristineDirectoryTree ::+     Repository rt p wU wR -> FilePath -> WithWorkingDir -> IO ()+createPristineDirectoryTree r _ NoWorkingDir = do+    tree <- readPristine r+    -- evaluate the tree to force copying of pristine files+    _ <- darcsAddMissingHashes tree+    return ()+createPristineDirectoryTree r dir WithWorkingDir = do+    tree <- readPristine r+    writePlainTree tree dir++-- | Obtains a Tree corresponding to the "recorded" state of the repository:+-- this is the same as the pristine cache, which is the same as the result of+-- applying all the repository's patches to an empty directory.+readPristine :: Repository rt p wU wR -> IO (Tree IO)+readPristine repo+  | formatHas HashedInventory (repoFormat repo) =+    case repoAccessType repo of+      SRO -> do+        inv <- gzReadFilePS $ repoLocation repo </> hashedInventoryPath+        let root = peekPristineHash inv+        readDarcsHashed (repoCache repo) root+      SRW -> do+        hash <-+          peekPristineHash <$>+            gzReadFilePS (repoLocation repo </> tentativePristinePath)+        readDarcsHashedNosize (repoCache repo) hash+  | otherwise = fail oldRepoFailMsg++-- | Replace the existing pristine with a new one (loaded up in a Tree object).+-- Warning: If @rt ~ 'RO@ this overwrites the recorded state, use only when+-- creating a new repo!+writePristine :: Repository rt p wU wR -> Tree IO -> IO PristineHash+writePristine repo tree =+  withCurrentDirectory (repoLocation repo) $ do+    tree' <- darcsAddMissingHashes tree+    root <- writeDarcsHashed tree' (repoCache repo)+    -- now update the current pristine hash+    case repoAccessType repo of+      SRO -> putHash root hashedInventoryPath+      SRW -> putHash root tentativePristinePath -- note the asymmetry!+  where+    putHash root path = do+      content <- gzReadFilePS path+      writeDocBinFile path $ pokePristineHash root content+      return root
+ src/Darcs/Repository/Rebase.hs view
@@ -0,0 +1,231 @@+--  Copyright (C) 2009-2012 Ganesh Sittampalam+--+--  BSD3+{-# LANGUAGE OverloadedStrings #-}+module Darcs.Repository.Rebase+    ( -- * Create/read/write rebase patch+      readTentativeRebase+    , writeTentativeRebase+    , withTentativeRebase+    , readRebase+    , finalizeTentativeRebase+    , revertTentativeRebase+    , withManualRebaseUpdate+      -- * Handle rebase format and status+    , checkHasRebase+    , displayRebaseStatus+    , updateRebaseFormat+      -- * Handle old-style rebase+    , extractOldStyleRebase+    , checkOldStyleRebaseStatus+    ) where++import Darcs.Prelude++import Control.Monad ( unless, void, when )+import System.Directory ( copyFile, renameFile )+import System.Exit ( exitFailure )+import System.FilePath.Posix ( (</>) )++import qualified Darcs.Patch.Rebase.Legacy.Wrapped as W+import Darcs.Patch.PatchInfoAnd+    ( PatchInfoAnd+    , PatchInfoAndG+    , fmapPIAP+    , hopefully+    )+import Darcs.Patch.Rebase.Suspended+    ( Suspended(Items)+    , countToEdit+    , readSuspended+    , showSuspended+    , simplifyPushes+    , removeFixupsFromSuspended+    )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )+import Darcs.Patch.RepoPatch ( RepoPatch, PrimOf )+import Darcs.Patch.Show ( ShowPatchFor(ForStorage) )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..)+    , FL(..)+    , RL(..)+    , foldlwFL+    , mapRL_RL+    , (+<<+)+    )+import Darcs.Patch.Witnesses.Sealed ( Dup(..) )++import Darcs.Repository.Format+    ( RepoProperty ( RebaseInProgress_2_16, RebaseInProgress )+    , formatHas+    , addToFormat+    , removeFromFormat+    )+import Darcs.Repository.InternalTypes+    ( Repository+    , AccessType(..)+    , modifyRepoFormat+    , repoFormat+    , repoLocation+    )+import Darcs.Repository.Paths+    ( rebasePath+    , tentativeRebasePath+    )++import Darcs.Util.Diff ( DiffAlgorithm(MyersDiff) )+import Darcs.Util.English ( englishNum, Noun(..) )+import Darcs.Util.Exception ( catchDoesNotExistError )+import Darcs.Util.Lock ( writeDocBinFile, readBinFile )+import Darcs.Util.Parser ( parse )+import Darcs.Util.Printer ( text, hsep, vcat )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.URL ( isValidLocalPath )++withManualRebaseUpdate+   :: RepoPatch p+   => Repository rt p wU wR+   -> (Repository rt p wU wR -> IO (Repository rt p wU wR', FL (RebaseFixup (PrimOf p)) wR' wR, x))+   -> IO (Repository rt p wU wR', x)+withManualRebaseUpdate r subFunc = do+    susp <- readTentativeRebase r+    (r', fixups, x) <- subFunc r+    when (countToEdit susp > 0) $+      -- HACK overwrite the changes that were made by subFunc+      -- which may and indeed does call add/remove patch+      writeTentativeRebase r' (simplifyPushes MyersDiff fixups susp)+    return (r', x)++-- | Fail if there is an old-style rebase present.+-- To be called initially for every command except rebase upgrade.+checkOldStyleRebaseStatus :: Repository rt p wU wR -> IO ()+checkOldStyleRebaseStatus repo = do+  let rf = repoFormat repo+  when (formatHas RebaseInProgress rf) $ do+      ePutDocLn upgradeMsg+      exitFailure+  where+    upgradeMsg = vcat+      [ "An old-style rebase is in progress in this repository. You can upgrade it"+      , "to the new format using the 'darcs rebase upgrade' command. The repository"+      , "format is unaffected by this, but you won't be able to use a darcs version"+      , "older than 2.16 on this repository until the current rebase is finished."+      ]++-- | Fail unless we already have some suspended patches.+-- Not essential, since all rebase commands should be happy to work+-- with an empty rebase state.+checkHasRebase :: Repository rt p wU wR -> IO ()+checkHasRebase repo =+  unless (formatHas RebaseInProgress_2_16 $ repoFormat repo) $+    fail "No rebase in progress. Try 'darcs rebase suspend' first."++-- | Report the rebase status if there is (still) a rebase in progress+-- after the command has finished running.+-- To be called via 'finally' for every 'RepoJob'.+displayRebaseStatus :: RepoPatch p => Repository rt p wU wR -> IO ()+displayRebaseStatus repo = do+  -- The repoLocation may be a remote URL (e.g. darcs log). We neither can nor+  -- want to display anything in that case.+  when (isValidLocalPath $ repoLocation repo) $ do+    -- Why do we use 'readRebase' and not 'readTentativeRebase' here?+    -- There are three cases:+    -- * We had no transaction in the first place.+    -- * We had a successful transaction: then it will be finalized before we+    --   are called (because finalization is part of the RepoJob itself) and+    --   we want to report the new finalized state.+    -- * We had a transaction that was cancelled or failed: then we want to+    --   report the old (unmodified) rebase state.+    -- Thus, in all cases 'readRebase' is the correct choice. However, if there+    -- is no rebase in progress, then 'rebasePath' may not exist, so we must+    -- handle that.+    suspended <- readRebase repo `catchDoesNotExistError` return (Items NilFL)+    case countToEdit suspended of+      0 -> return ()+      count ->+        ePutDocLn $ hsep+          [ "Rebase in progress:"+          , text (show count)+          , "suspended"+          , text (englishNum count (Noun "patch") "")+          ]++-- | Rebase format update for all commands that modify the repo,+-- except rebase upgrade. This is called by 'finalizeRepositoryChanges'.+updateRebaseFormat :: RepoPatch p => Repository 'RW p wU wR -> IO ()+updateRebaseFormat repo = do+  let rf = repoFormat repo+      hadRebase = formatHas RebaseInProgress_2_16 rf+  suspended <-+    readTentativeRebase repo `catchDoesNotExistError` return (Items NilFL)+  case countToEdit suspended of+    0 ->+      when hadRebase $ do+        void $ modifyRepoFormat (removeFromFormat RebaseInProgress_2_16) repo+        putStrLn "Rebase finished!"+    _ ->+      unless hadRebase $+        void $ modifyRepoFormat (addToFormat RebaseInProgress_2_16) repo++withTentativeRebase+  :: RepoPatch p+  => Repository rt p wU wR+  -> Repository rt p wU wR'+  -> (Suspended p wR -> Suspended p wR')+  -> IO ()+withTentativeRebase r r' f =+  readTentativeRebase r >>= writeTentativeRebase r' . f++readTentativeRebase :: RepoPatch p+                    => Repository rt p wU wR -> IO (Suspended p wR)+readTentativeRebase = readRebaseFile tentativeRebasePath++writeTentativeRebase :: RepoPatch p+                     => Repository rt p wU wR -> Suspended p wR -> IO ()+writeTentativeRebase = writeRebaseFile tentativeRebasePath++readRebase :: RepoPatch p => Repository rt p wU wR -> IO (Suspended p wR)+readRebase = readRebaseFile rebasePath++createTentativeRebase :: RepoPatch p => Repository rt p wU wR -> IO ()+createTentativeRebase r = writeRebaseFile tentativeRebasePath r (Items NilFL)++revertTentativeRebase :: RepoPatch p => Repository rt p wU wR -> IO ()+revertTentativeRebase repo =+  copyFile rebasePath tentativeRebasePath+    `catchDoesNotExistError` createTentativeRebase repo++finalizeTentativeRebase :: IO ()+finalizeTentativeRebase = renameFile tentativeRebasePath rebasePath++-- unsafe witnesses, not exported+readRebaseFile :: RepoPatch p+               => FilePath -> Repository rt p wU wR -> IO (Suspended p wX)+readRebaseFile path r = do+  parsed <- parse readSuspended <$> readBinFile (repoLocation r </> path)+  case parsed of+    Left e -> fail $ unlines ["parse error in file " ++ path, e]+    Right (result, _) -> return result++-- unsafe witnesses, not exported+writeRebaseFile :: RepoPatch p+                => FilePath -> Repository rt p wU wR+                -> Suspended p wR -> IO ()+writeRebaseFile path r sp =+  writeDocBinFile (repoLocation r </> path) (showSuspended ForStorage sp)++type PiaW p = PatchInfoAndG (W.WrappedNamed p)++extractOldStyleRebase :: forall p wA wB. RepoPatch p+                      => RL (PiaW p) wA wB+                      -> Maybe ((RL (PatchInfoAnd p) :> Dup (Suspended p)) wA wB)+extractOldStyleRebase ps = go (ps :> NilFL) where+  go :: (RL (PiaW p) :> FL (PatchInfoAnd p)) wA wB+     -> Maybe ((RL (PatchInfoAnd p) :> Dup (Suspended p)) wA wB)+  go (NilRL :> _) = Nothing+  go (xs :<: x :> ys)+    | W.RebaseP _ r <- hopefully x = do+      let xs' = mapRL_RL (fmapPIAP W.fromRebasing) xs+          rffs = foldlwFL (removeFixupsFromSuspended . hopefully) ys+      return ((xs' +<<+ ys) :> Dup (rffs r))+    | otherwise = go (xs :> fmapPIAP W.fromRebasing x :>: ys)
src/Darcs/Repository/Repair.hs view
@@ -1,124 +1,117 @@-{-# LANGUAGE CPP, PatternGuards #-}- module Darcs.Repository.Repair ( replayRepository, checkIndex,                                  replayRepositoryInTemp,                                  RepositoryConsistency(..) )        where -import Prelude hiding ( catch )+import Darcs.Prelude  import Control.Monad ( when, unless ) import Control.Monad.Trans ( liftIO )-import Control.Applicative( (<$>) )-import Control.Exception ( catch, finally, IOException )-import Data.Maybe ( catMaybes )+import Control.Exception ( catch, IOException ) import Data.List ( sort, (\\) )-import System.Directory ( createDirectoryIfMissing, getCurrentDirectory,-                          setCurrentDirectory )-import Darcs.Lock( rmRecursive )-import Darcs.RepoPath( AbsolutePath, ioAbsolute, toFilePath )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, winfo, WPatchInfo, unWPatchInfo, compareWPatchInfo )+import System.Directory+    ( createDirectoryIfMissing+    , getCurrentDirectory+    , setCurrentDirectory+    , withCurrentDirectory+    ) -import Darcs.Witnesses.Eq ( EqCheck(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), lengthFL, reverseFL,-                                 mapRL, nullFL, (:||:)(..) )-import Darcs.Witnesses.Sealed ( Sealed2(..), Sealed(..), unFreeLeft )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , lengthFL+    , mapFL+    , nullFL+    , reverseFL+    , reverseRL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft, unseal ) import Darcs.Patch.Apply( ApplyState ) import Darcs.Patch.Repair ( Repair(applyAndTryToFix) )-import Darcs.Patch.PatchInfoAnd( hopefully )-import Darcs.Patch.Info ( humanFriendly )-import Darcs.Patch.Set ( PatchSet(..), newset2FL, newset2RL )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif+import Darcs.Patch.Info ( displayPatchInfo, makePatchname )+import Darcs.Patch.Set ( Origin, PatchSet(..), Tagged(..), patchSet2FL ) import Darcs.Patch ( RepoPatch, PrimOf, isInconsistent )-import Darcs.Patch.Named ( patchcontents ) -import Darcs.Repository.Format ( identifyRepoFormat,-                                 RepoProperty ( HashedInventory ), formatHas )-import Darcs.Repository.Cache ( HashedDir( HashedPristineDir ) )-import Darcs.Repository.HashedIO ( cleanHashdir )-import Darcs.Repository.HashedRepo ( readHashedPristineRoot )-import Darcs.Repository.InternalTypes ( extractCache )+import Darcs.Repository.Diff( treeDiff )+import Darcs.Repository.Flags ( Verbosity(..), DiffAlgorithm )+import Darcs.Repository.Hashed ( readPatches, writeAndReadPatch )+import Darcs.Repository.InternalTypes ( Repository, repoCache, repoLocation )+import Darcs.Repository.Paths ( pristineDirPath )+import Darcs.Repository.Pending ( readPending ) import Darcs.Repository.Prefs ( filetypeFunction )-import Darcs.Repository ( Repository, readRepo, makePatchLazy-                        , readRecorded, readIndex, readRecordedAndPending )--import Progress ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )-import Darcs.Utils ( catchall )-import Darcs.Global ( darcsdir )-import Darcs.Lock( withTempDir )-import Printer ( Doc, putDocLn, text )-import Darcs.Arguments ( DarcsFlag( Verbose, Quiet ) )--import Darcs.Diff( treeDiff )-import Storage.Hashed.Monad( TreeIO )-import Storage.Hashed.Darcs( hashedTreeIO )-import Storage.Hashed.Tree( Tree, emptyTree )-import Storage.Hashed.AnchoredPath( anchorPath )-import Storage.Hashed.Hash( Hash(NoHash), encodeBase16 )-import Storage.Hashed.Tree( list, restrict, expand, itemHash, zipTrees )-import Storage.Hashed.Darcs( darcsUpdateHashes )-import Storage.Hashed.Index( updateIndex )-import Storage.Hashed( readPlainTree )--import qualified Data.ByteString.Char8 as BS--#include "impossible.h"-#include "gadts.h"--replaceInFL :: FL (PatchInfoAnd a) C(x y)-            -> [Sealed2 (WPatchInfo :||: PatchInfoAnd a)]-            -> FL (PatchInfoAnd a) C(x y)-replaceInFL orig [] = orig-replaceInFL NilFL _ = impossible-replaceInFL (o:>:orig) ch@(Sealed2 (o':||:c):ch_rest)-    | IsEq <- winfo o `compareWPatchInfo` o' = c:>:replaceInFL orig ch_rest-    | otherwise = o:>:replaceInFL orig ch+import Darcs.Repository.State+    ( readPristine+    , readIndex+    , readPristineAndPending+    ) -applyAndFix :: forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree)-            => Repository p C(r u t) -> FL (PatchInfoAnd p) C(Origin r)-            -> TreeIO (FL (PatchInfoAnd p) C(Origin r), Bool)-applyAndFix _ NilFL = return (NilFL, True)-applyAndFix r psin =-    do liftIO $ beginTedious k-       liftIO $ tediousSize k $ lengthFL psin-       (repaired, ok) <- aaf psin-       liftIO $ endTedious k-       orig <- liftIO $ newset2FL `fmap` readRepo r-       return (replaceInFL orig repaired, ok)-    where k = "Replaying patch"-          aaf :: FL (PatchInfoAnd p) C(w z) -> TreeIO ([Sealed2 (WPatchInfo :||: PatchInfoAnd p)], Bool)-          aaf NilFL = return ([], True)-          aaf (p:>:ps) = do-            mp' <- applyAndTryToFix p-            case isInconsistent . patchcontents . hopefully $ p of-              Just err -> liftIO $ putDocLn err-              Nothing -> return ()-            let !winfp = winfo p -- assure that 'p' can be garbage collected.-            liftIO $ finishedOneIO k $ show $ humanFriendly $ unWPatchInfo winfp-            (ps', restok) <- aaf ps-            case mp' of-              Nothing -> return (ps', restok)-              Just (e,pp) -> liftIO $ do putStrLn e-                                         p' <- makePatchLazy r pp-                                         return (Sealed2 (winfp :||: p'):ps', False)+import Darcs.Util.Cache ( Cache, mkDirCache )+import Darcs.Util.Progress+    ( beginTedious+    , endTedious+    , finishedOneIO+    , tediousSize+    )+import Darcs.Util.Lock( withDelayedDir )+import Darcs.Util.Path( anchorPath, toFilePath )+import Darcs.Util.Printer ( putDocLn, text, renderString, ($$) )+import Darcs.Util.Hash( showHash )+import Darcs.Util.Tree( Tree, emptyTree, list, restrict, expand, itemHash, zipTrees )+import Darcs.Util.Tree.Monad( TreeIO )+import Darcs.Util.Tree.Hashed( darcsUpdateHashes, hashedTreeIO )+import Darcs.Util.Tree.Plain( readPlainTree )+import Darcs.Util.Index( treeFromIndex ) -data RepositoryConsistency p C(x) =-    RepositoryConsistent-  | BrokenPristine (Tree IO)-  | BrokenPatches (Tree IO) (PatchSet p C(Origin x))+applyAndFixPatchSet+  :: forall rt p wU wR. (RepoPatch p, ApplyState p ~ Tree)+  => Repository rt p wU wR+  -> PatchSet p Origin wR+  -> TreeIO (PatchSet p Origin wR, Bool)+applyAndFixPatchSet r s = do+    liftIO $ beginTedious k+    liftIO $ tediousSize k $ lengthFL $ patchSet2FL s+    result <- case s of+      PatchSet ts ps -> do+        (ts', ts_ok) <- applyAndFixTagged (reverseRL ts)+        (ps', ps_ok) <- applyAndFixPatches (reverseRL ps)+        return (PatchSet (reverseFL ts') (reverseFL ps'), ts_ok && ps_ok)+    liftIO $ endTedious k+    return result+  where+    k = "Replaying patch"+    applyAndFixTagged :: FL (Tagged p) wX wY -> TreeIO (FL (Tagged p) wX wY, Bool)+    applyAndFixTagged NilFL = return (NilFL, True)+    applyAndFixTagged (Tagged ps t _ :>: ts) = do+      (ps', ps_ok) <- applyAndFixPatches (reverseRL ps)+      (ts', ts_ok) <- applyAndFixTagged ts+      return (Tagged (reverseFL ps') t Nothing :>: ts', ps_ok && ts_ok)+    applyAndFixPatches+      :: FL (PatchInfoAnd p) wX wY -> TreeIO (FL (PatchInfoAnd p) wX wY, Bool)+    applyAndFixPatches NilFL = return (NilFL, True)+    applyAndFixPatches (p :>: ps) = do+      mp' <- applyAndTryToFix p+      case isInconsistent . hopefully $ p of+        Just err -> liftIO $ putDocLn err+        Nothing -> return ()+      liftIO $ finishedOneIO k $ show $ makePatchname $ info p+      (ps', ps_ok) <- applyAndFixPatches ps+      case mp' of+        Nothing -> return (p :>: ps', ps_ok)+        Just (e, p') ->+          liftIO $ do+            putStrLn $ renderString $ (displayPatchInfo $ info p) $$ text e+            -- FIXME While this is okay semantically, it means we can't+            -- run darcs check in a read-only repo+            p'' <-+              withCurrentDirectory (repoLocation r) $+              writeAndReadPatch (repoCache r) p'+            return (p'' :>: ps', False) -checkUniqueness :: (RepoPatch p, ApplyState p ~ Tree)-                => (Doc -> IO ()) -> (Doc -> IO ()) -> Repository p C(r u t) -> IO ()-checkUniqueness putVerbose putInfo repository =-    do putVerbose $ text "Checking that patch names are unique..."-       r <- readRepo repository-       case hasDuplicate $ mapRL info $ newset2RL r of-         Nothing -> return ()-         Just pinf -> do putInfo $ text "Error! Duplicate patch name:"-                         putInfo $ humanFriendly pinf-                         fail "Duplicate patches found."+data RepositoryConsistency p wR = RepositoryConsistency+  { fixedPristine :: Maybe (Tree IO, Sealed (FL (PrimOf p) wR))+  , fixedPatches :: Maybe (PatchSet p Origin wR)+  , fixedPending :: Maybe (Sealed (FL (PrimOf p) wR))+  }  hasDuplicate :: Ord a => [a] -> Maybe a hasDuplicate li = hd $ sort li@@ -126,73 +119,101 @@           hd [] = Nothing           hd (x1:x2:xs) | x1 == x2 = Just x1                         | otherwise = hd (x2:xs)-replayRepository' ::-    forall p C(r u t) . (RepoPatch p, ApplyState p ~ Tree)-               => AbsolutePath -> Repository p C(r u t) -> [DarcsFlag] -> IO (RepositoryConsistency p C(r))-replayRepository' whereToReplay' repo opts = do-  let whereToReplay = toFilePath whereToReplay'-      putVerbose s = when (Verbose `elem` opts) $ putDocLn s-      putInfo s = when (not $ Quiet `elem` opts) $ putDocLn s-  checkUniqueness putVerbose putInfo repo-  createDirectoryIfMissing False whereToReplay-  putVerbose $ text "Reading recorded state..."-  pris <- readRecorded repo `catch` \(_ :: IOException) -> return emptyTree-  putVerbose $ text "Applying patches..."-  patches <- readRepo repo-  debugMessage "Fixing any broken patches..."-  let psin = newset2FL patches-      repair = applyAndFix repo psin -  ((ps, patches_ok), newpris) <- hashedTreeIO repair emptyTree whereToReplay-  debugMessage "Done fixing broken patches..."-  let newpatches = PatchSet (reverseFL ps) NilRL+replayRepository'+  :: forall rt p wR wU. (RepoPatch p, ApplyState p ~ Tree)+  => DiffAlgorithm+  -> Cache+  -> Repository rt p wU wR+  -> Verbosity+  -> IO (RepositoryConsistency p wR)+replayRepository' dflag cache repo verbosity = do+  let putVerbose s = when (verbosity == Verbose) $ putDocLn s+      putInfo s = unless (verbosity == Quiet) $ putDocLn s -  debugMessage "Checking pristine against slurpy"+  putVerbose $ text "Checking that patch names are unique..."+  patches <- readPatches repo+  case hasDuplicate $ mapFL info $ patchSet2FL patches of+    Nothing -> return ()+    Just pinf -> do+      putInfo $ text "Error! Duplicate patch name:"+      putInfo $ displayPatchInfo pinf+      -- FIXME repair duplicates by re-generating their salt+      fail "Duplicate patches found."++  -- we have to read pristine before fixing patches as that updates pristine+  pris <-+    (readPristine repo >>= expand >>= darcsUpdateHashes)+    `catch`+    \(_ :: IOException) -> return emptyTree++  putVerbose $ text "Checking content of recorded patches..."+  ((newpatches, patches_ok), newpris) <-+    hashedTreeIO (applyAndFixPatchSet repo patches) emptyTree cache++  putVerbose $ text "Checking pristine..."   ftf <- filetypeFunction-  is_same <- do Sealed diff <- unFreeLeft `fmap` treeDiff ftf pris newpris :: IO (Sealed (FL (PrimOf p) C(r)))-                return $ nullFL diff-              `catchall` return False-  -- TODO is the latter condition needed? Does a broken patch imply pristine-  -- difference? Why, or why not?-  return (if is_same && patches_ok-     then RepositoryConsistent-     else if patches_ok-            then BrokenPristine newpris-            else BrokenPatches newpris newpatches)+  pristine_diff <- unFreeLeft `fmap` treeDiff dflag ftf pris newpris+  let pristine_ok = unseal nullFL pristine_diff -cleanupRepositoryReplay :: Repository p C(r u t) -> IO ()-cleanupRepositoryReplay r = do-  let c = extractCache r-  rf <- identifyRepoFormat "."-  unless (formatHas HashedInventory rf) $-         rmRecursive $ darcsdir ++ "/pristine.hashed"-  when (formatHas HashedInventory rf) $ do-       current <- readHashedPristineRoot r-       cleanHashdir c HashedPristineDir $ catMaybes [current]+  putVerbose $ text "Checking pending patch..."+  Sealed pend <- readPending repo+  maybe_newpend <- fst <$> hashedTreeIO (applyAndTryToFix pend) newpris cache+  (newpend, pending_ok) <- convertFixed pend maybe_newpend -replayRepositoryInTemp :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> [DarcsFlag]-                          -> IO (RepositoryConsistency p C(r))-replayRepositoryInTemp r opt = do+  return $ RepositoryConsistency+    { fixedPristine = if pristine_ok then Nothing else Just (newpris, pristine_diff)+    , fixedPatches = if patches_ok then Nothing else Just newpatches+    , fixedPending = if pending_ok then Nothing else Just (Sealed newpend)+    }++  where+    convertFixed :: a -> Maybe (String, a) -> IO (a, Bool)+    convertFixed x Nothing = return (x, True)+    convertFixed _ (Just (e, x)) = do+      unless (verbosity == Quiet) $ putStrLn e+      return (x, False)++replayRepositoryInTemp+  :: (RepoPatch p, ApplyState p ~ Tree)+  => DiffAlgorithm+  -> Repository rt p wU wR+  -> Verbosity+  -> IO (RepositoryConsistency p wR)+replayRepositoryInTemp dflag r verb = do   repodir <- getCurrentDirectory-  withTempDir "darcs-check" $ \tmpDir -> do+  {- The reason we use withDelayedDir here, instead of withTempDir, is that+  replayRepository' may return a new pristine that is read from the +  temporary location and reading a Tree is done using lazy ByteStrings (for+  file contents). Then we check if there is a difference to our stored+  pristine, but when there are differences the check may terminate early+  and not all of the new pristine was read/evaluated. This may then cause+  does-not-exist-failures later on when the tree is evaluated further.+  -}+  withDelayedDir "darcs-check" $ \tmpDir -> do     setCurrentDirectory repodir-    replayRepository' tmpDir r opt+    replayRepository' dflag (mkDirCache (toFilePath tmpDir)) r verb -replayRepository :: (RepoPatch p, ApplyState p ~ Tree)-                 => Repository p C(r u t) -> [DarcsFlag]-                 -> (RepositoryConsistency p C(r) -> IO a) -> IO a-replayRepository r opt f = do-  run `finally` cleanupRepositoryReplay r-    where run = do-            createDirectoryIfMissing False "_darcs/pristine.hashed"-            hashedPristine <- ioAbsolute "_darcs/pristine.hashed"-            st <- replayRepository' hashedPristine r opt-            f st+replayRepository+  :: (RepoPatch p, ApplyState p ~ Tree)+  => DiffAlgorithm+  -> Repository rt p wU wR+  -> Verbosity+  -> (RepositoryConsistency p wR -> IO a)+  -> IO a+replayRepository dflag r verb job = do+  createDirectoryIfMissing False pristineDirPath+  st <- replayRepository' dflag (repoCache r) r verb+  job st -checkIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> Bool -> IO Bool+checkIndex+  :: (RepoPatch p, ApplyState p ~ Tree)+  => Repository rt p wU wR+  -> Bool+  -> IO Bool checkIndex repo quiet = do-  index <- updateIndex =<< readIndex repo-  pristine <- expand =<< readRecordedAndPending repo+  index <- treeFromIndex =<< readIndex repo+  pristine <- expand =<< readPristineAndPending repo   working <- expand =<< restrict pristine <$> readPlainTree "."   working_hashed <- darcsUpdateHashes working   let index_paths = [ p | (p, _) <- list index ]@@ -200,15 +221,16 @@       index_extra = index_paths \\ working_paths       working_extra = working_paths \\ index_paths       gethashes p (Just i1) (Just i2) = (p, itemHash i1, itemHash i2)-      gethashes p (Just i1) Nothing   = (p, itemHash i1, NoHash)-      gethashes p   Nothing (Just i2) = (p,      NoHash, itemHash i2)+      gethashes p (Just i1) Nothing   = (p, itemHash i1, Nothing)+      gethashes p   Nothing (Just i2) = (p,     Nothing, itemHash i2)       gethashes p   Nothing Nothing   = error $ "Bad case at " ++ show p-      mismatches = [ miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2 ]+      mismatches =+        [miss | miss@(_, h1, h2) <- zipTrees gethashes index working_hashed, h1 /= h2] -      format paths = unlines $ (map $ (("  " ++) . anchorPath "")) paths+      format paths = unlines $ map (("  " ++) . anchorPath "") paths       mismatches_disp = unlines [ anchorPath "" p ++-                                    "\n    index: " ++ BS.unpack (encodeBase16 h1) ++-                                    "\n  working: " ++ BS.unpack (encodeBase16 h2)+                                    "\n    index: " ++ showHash h1 +++                                    "\n  working: " ++ showHash h2                                   | (p, h1, h2) <- mismatches ]   unless (quiet || null index_extra) $          putStrLn $ "Extra items in index!\n" ++ format index_extra
+ src/Darcs/Repository/Resolution.hs view
@@ -0,0 +1,264 @@+--  Copyright (C) 2003,2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.+module Darcs.Repository.Resolution+    ( standardResolution+    , rebaseResolution+    , externalResolution+    , patchsetConflictResolutions+    , StandardResolution(..)+    , announceConflicts+    , haveConflicts+    , warnUnmangled+    , showUnmangled+    , showUnravelled+    ) where++import Darcs.Prelude++import System.FilePath.Posix ( (</>) )+import System.Exit ( ExitCode( ExitSuccess ) )+import System.Directory ( setCurrentDirectory, getCurrentDirectory )+import Data.List ( intersperse, zip4 )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( catMaybes, isNothing )+import Control.Monad ( unless, when )++import Darcs.Repository.Diff( treeDiff )+import Darcs.Patch+    ( Named+    , PrimOf+    , RepoPatch+    , applyToTree+    , effect+    , effectOnPaths+    , invert+    , listConflictedFiles+    , patchcontents+    , resolveConflicts+    )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Conflict ( Conflict, ConflictDetails(..), Mangled, Unravelled )+import Darcs.Patch.Inspect ( listTouchedFiles )+import Darcs.Patch.Merge ( mergeList )+import Darcs.Patch.Prim ( PrimPatch )+import Darcs.Util.Path+    ( AnchoredPath+    , anchorPath+    , displayPath+    , filterPaths+    , toFilePath+    )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), concatRLFL, mapRL_RL, nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unseal, unFreeLeft )++import Darcs.Util.CommandLine ( parseCmd )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )+import Darcs.Util.Prompt ( askEnter )+import Darcs.Patch.Set ( PatchSet(..), Origin, patchSet2RL )+import Darcs.Repository.Prefs ( filetypeFunction )+import Darcs.Util.Exec ( exec, Redirect(..) )+import Darcs.Util.Lock ( withTempDir )+import Darcs.Util.File ( copyTree )+import Darcs.Repository.Flags+    ( AllowConflicts (..)+    , ResolveConflicts (..)+    , WantGuiPause (..)+    , DiffAlgorithm (..)+    )++import qualified Darcs.Util.Tree as Tree+import Darcs.Util.Tree.Plain ( writePlainTree, readPlainTree )++import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Printer ( Doc, renderString, ($$), text, redText, vcat )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Patch ( displayPatch )++data StandardResolution prim wX =+  StandardResolution {+    mangled :: Mangled prim wX,+    unmangled :: [Unravelled prim wX],+    conflictedPaths :: [AnchoredPath]+  }++haveConflicts :: StandardResolution prim wX -> Bool+haveConflicts res = not $ null (unmangled res) && unseal nullFL (mangled res)++standardResolution :: (RepoPatch p)+                   => RL (PatchInfoAnd p) wO wX+                   -> RL (PatchInfoAnd p) wX wY+                   -> StandardResolution (PrimOf p) wY+standardResolution context interesting =+  mangleConflicts $ resolveConflicts context interesting++-- | Like 'standardResolution' but it doesn't use the @instance (Named p)@+-- because the traling list of patches may contain "fake" conflictors.+rebaseResolution+  :: (Conflict p, PrimPatch (PrimOf p))+  => RL (PatchInfoAnd p) wO wX+  -> RL (Named p) wX wY+  -> StandardResolution (PrimOf p) wY+rebaseResolution context interesting =+    mangleConflicts $ resolveConflicts context_patches interesting_patches+  where+    context_patches = concatRLFL (mapRL_RL (patchcontents . hopefully) context)+    interesting_patches = concatRLFL (mapRL_RL patchcontents interesting)++mangleConflicts+  :: (PrimPatch prim) => [ConflictDetails prim wX] -> StandardResolution prim wX+mangleConflicts conflicts =+  case mergeList $ catMaybes $ map conflictMangled conflicts of+    Right mangled -> StandardResolution {..}+    Left (Sealed ps, Sealed qs) ->+      error $ renderString+        $ redText "resolutions conflict:"+        $$ displayPatch ps+        $$ redText "conflicts with"+        $$ displayPatch qs+  where+    unmangled = map conflictParts $ filter (isNothing . conflictMangled) conflicts+    conflictedPaths =+      nubSort $+      concatMap (unseal listTouchedFiles) (concatMap conflictParts conflicts)++warnUnmangled+  :: PrimPatch prim => Maybe [AnchoredPath] -> StandardResolution prim wX -> IO ()+warnUnmangled mpaths StandardResolution {..}+  | null unmangled = return ()+  | otherwise = ePutDocLn $ showUnmangled mpaths unmangled++showUnmangled+  :: PrimPatch prim => Maybe [AnchoredPath] -> [Unravelled prim wX] -> Doc+showUnmangled mpaths = vcat . map showUnmangledConflict . filter (affected mpaths)+  where+    showUnmangledConflict unravelled =+      redText "Cannot mark these conflicting patches:" $$+      showUnravelled (redText "versus") unravelled+    affected Nothing _ = True+    affected (Just paths) unravelled =+      any (`elem` paths) $ concatMap (unseal listTouchedFiles) unravelled++showUnravelled :: PrimPatch prim => Doc -> Unravelled prim wX -> Doc+showUnravelled sep =+  vcat . intersperse sep . map (unseal displayPatch)++announceConflicts :: PrimPatch prim+                  => String+                  -> AllowConflicts+                  -> StandardResolution prim wX+                  -> IO Bool+announceConflicts cmd allowConflicts conflicts = do+  let result = haveConflicts conflicts+  when result $ do+    let cfs = nubSort (conflictedPaths conflicts)+    ePutDocLn $ redText "We have conflicts!"+    unless (null cfs) $+      ePutDocLn $ vcat $ text "Affected paths:" : map (text . displayPath) cfs+    case allowConflicts of+      NoAllowConflicts ->+        fail $+        "Refusing to "++cmd++" patches leading to conflicts.\n"+++        "If you would rather apply the patch and mark the conflicts,\n"+++        "use the --mark-conflicts or --allow-conflicts options to "++cmd++"\n"+++        "These can set as defaults by adding\n"+++        " "++cmd++" mark-conflicts\n"+++        "to "++darcsdir++"/prefs/defaults in the target repo. "+      YesAllowConflicts MarkConflicts ->+        warnUnmangled Nothing conflicts+      _ -> return ()+  return result++externalResolution :: forall p wX wY wZ wA. (RepoPatch p, ApplyState p ~ Tree.Tree)+                   => DiffAlgorithm+                   -> Tree.Tree IO        -- ^ working tree+                   -> String              -- ^ external merge tool command+                   -> WantGuiPause        -- ^ tell whether we want GUI pause+                   -> FL (PrimOf p) wX wY -- ^ our effect+                   -> FL (PrimOf p) wX wZ -- ^ their effect+                   -> FL p wY wA          -- ^ them merged+                   -> IO (Sealed (FL (PrimOf p) wA))+externalResolution diffa s1 c wantGuiPause p1 p2 pmerged = do+ sa <- applyToTree (invert p1) s1+ sm <- applyToTree pmerged s1+ s2 <- applyToTree p2 sa+ let nms = listConflictedFiles pmerged+     n1s = effectOnPaths (invert (effect pmerged)) nms+     nas = effectOnPaths (invert p1) n1s+     n2s = effectOnPaths p2 nas+     ns = zip4 (tofp nas) (tofp n1s) (tofp n2s) (tofp nms)+     tofp = map (anchorPath "")+     write_files tree fs = writePlainTree (Tree.filter (filterPaths fs) tree) "."+  in do+   former_dir <- getCurrentDirectory+   withTempDir "version1" $ \absd1 -> do+     let d1 = toFilePath absd1+     write_files s1 n1s+     setCurrentDirectory former_dir+     withTempDir "ancestor" $ \absda -> do+       let da = toFilePath absda+       write_files sa nas+       setCurrentDirectory former_dir+       withTempDir "merged" $ \absdm -> do+         let dm = toFilePath absdm+         write_files sm nms+         setCurrentDirectory former_dir+         withTempDir "cleanmerged" $ \absdc -> do+           let dc = toFilePath absdc+           copyTree dm "."+           setCurrentDirectory former_dir+           withTempDir "version2" $ \absd2 -> do+             let d2 = toFilePath absd2+             write_files s2 n2s+             mapM_ (externallyResolveFile c wantGuiPause da d1 d2 dm) ns+             sc <- readPlainTree dc+             sfixed <- readPlainTree dm+             ftf <- filetypeFunction+             unFreeLeft `fmap` treeDiff diffa ftf sc sfixed++externallyResolveFile :: String -- ^ external merge tool command+                      -> WantGuiPause -- ^ tell whether we want GUI pause+                      -> String -- ^ path to merge base+                      -> String -- ^ path to side 1 of the merge+                      -> String -- ^ path to side 2 of the merge+                      -> String -- ^ path where resolved content should go+                      -> (FilePath, FilePath, FilePath, FilePath)+                      -> IO ()+externallyResolveFile c wantGuiPause da d1 d2 dm (fa, f1, f2, fm) = do+    putStrLn $ "Merging file "++fm++" by hand."+    ec <- run c [('1', d1</>f1), ('2', d2</>f2), ('a', da</>fa), ('o', dm</>fm), ('%', "%")]+    when (ec /= ExitSuccess) $+         fail $ "External merge command exited with " ++ show ec+    when (wantGuiPause == YesWantGuiPause) $+        askEnter "Hit return to move on, ^C to abort the whole operation..."++run :: String -> [(Char,String)] -> IO ExitCode+run c replacements =+    case parseCmd replacements c of+    Left err     -> fail $ show err+    Right (c2,_) -> rr c2+    where rr (command:args) = do putStrLn $ "Running command '" +++                                            unwords (command:args) ++ "'"+                                 exec command args (Null,AsIs,AsIs)+          rr [] = return ExitSuccess++patchsetConflictResolutions :: RepoPatch p+                            => PatchSet p Origin wX+                            -> StandardResolution (PrimOf p) wX+patchsetConflictResolutions (PatchSet ts xs) =+  -- optimization: all patches before the latest known clean tag+  -- are known to be resolved+  standardResolution (patchSet2RL (PatchSet ts NilRL)) xs
src/Darcs/Repository/State.hs view
@@ -1,7 +1,6 @@-{-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE CPP #-}- -- Copyright (C) 2009 Petr Rockai+--           (C) 2012 José Neder -- -- Permission is hereby granted, free of charge, to any person -- obtaining a copy of this software and associated documentation@@ -24,272 +23,700 @@ -- SOFTWARE.  module Darcs.Repository.State-    ( restrictSubpaths, restrictBoring, TreeFilter(..)-    -- * Diffs.-    , unrecordedChanges, readPending-    -- * Trees.-    , readRecorded, readUnrecorded, readRecordedAndPending, readWorking-    -- * Index.-    , readIndex, invalidateIndex, UseIndex(..), ScanKnown(..) ) where+    ( restrictSubpaths, restrictBoring, TreeFilter(..), restrictDarcsdir+    -- * Diffs+    , unrecordedChanges+    -- * Trees+    , readPristine, readUnrecorded, readPristineAndPending, readWorking+    , readPendingAndWorking, readUnrecordedFiltered+    -- * Index+    , readIndex, updateIndex+    -- * Utilities+    , filterOutConflicts+    -- * Pending-related functions that depend on repo state+    , unsafeAddToPending, addToPending+    ) where -import Prelude hiding ( filter, catch )-import Control.Monad( when )-import Control.Applicative( (<$>) )+import Darcs.Prelude++import Control.Monad ( when, foldM, forM, void )+import Control.Monad.State ( StateT, runStateT, get, put, liftIO ) import Control.Exception ( catch, IOException )-import Data.Maybe( isJust )-import Data.List( union )-import Text.Regex( matchRegex )+import Data.Ord ( comparing )+import Data.List ( sortBy, union, delete ) -import System.Directory( removeFile, doesFileExist, doesDirectoryExist, renameFile )-import System.FilePath ( (</>) )-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BSC+import System.Directory( doesFileExist, renameFile )+import System.FilePath ( (<.>) ) -import Darcs.Patch ( RepoPatch, PrimOf, sortCoalesceFL, fromPrim, effect )-import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnFilePaths )-import Darcs.Witnesses.Ordered ( FL(..), (+>+), mapFL_FL )-import Darcs.Witnesses.Eq ( EqCheck(IsEq, NotEq) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal )-import Darcs.Diff ( treeDiff )-import Darcs.Flags ( UseIndex(..), ScanKnown(..) )-import Darcs.Global ( darcsdir )-import Darcs.Utils ( filterPaths )+import qualified Data.ByteString as B ( ByteString, concat )+import qualified Data.ByteString.Char8 as BC ( pack, unpack )+import qualified Data.ByteString.Lazy as BL ( toChunks ) -import Darcs.Repository.InternalTypes ( Repository(..) )+import Darcs.Patch ( RepoPatch, PrimOf, canonizeFL+                   , PrimPatch, maybeApplyToTree+                   , tokreplace, forceTokReplace, move )+import Darcs.Patch.Named ( anonymous )+import Darcs.Patch.Apply ( ApplyState, applyToTree, effectOnPaths )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+), consGapFL+                                     , (:>)(..), reverseRL, reverseFL+                                     , mapFL, concatFL, joinGapsFL, nullFL )+import Darcs.Patch.Witnesses.Eq ( EqCheck(IsEq, NotEq) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed), seal, unFreeLeft, mapSeal+                                    , freeGap, emptyGap, joinGap, FreeLeft, Gap(..) )+import Darcs.Patch.Commute ( commuteFL )+import Darcs.Patch.Permutations ( partitionConflictingFL, genCommuteWhatWeCanRL )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )+import Darcs.Patch.FileHunk ( FileHunk(..), IsHunk(..) )+import Darcs.Patch.TokenReplace ( breakToTokens, defaultToks )++import Darcs.Repository.Flags+    ( DiffAlgorithm(..)+    , LookForMoves(..)+    , LookForReplaces(..)+    , LookForAdds(..)+    , UseIndex(..)+    , DiffOpts(..)+    )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , Repository+    , repoFormat+    , repoLocation+    ) import Darcs.Repository.Format(formatHas, RepoProperty(NoWorkingDir))-import qualified Darcs.Repository.LowLevel as LowLevel-import Darcs.Repository.Prefs ( filetypeFunction, boringRegexps )+import qualified Darcs.Repository.Pending as Pending+import Darcs.Repository.Prefs ( filetypeFunction, isBoring )+import Darcs.Repository.Pristine ( readPristine )+import Darcs.Repository.Diff ( treeDiff )+import Darcs.Repository.Paths+    ( indexPath+    , indexInvalidPath+    ) -import Darcs.Patch.FileName ( fn2fp )-import Darcs.RepoPath ( SubPath, sp2fn )+import Darcs.Util.File ( removeFileMayNotExist )+import Darcs.Util.Global ( debugMessage )+import Darcs.Util.Path+    ( AnchoredPath+    , realPath+    , filterPaths+    , inDarcsdir+    , parents+    , movedirfilename+    )+import Darcs.Util.Tree( Tree, restrict, FilterTree, expand, emptyTree, overlay, find+                      , ItemType(..), itemType, readBlob, modifyTree, findFile, TreeItem(..)+                      , makeBlobBS, expandPath )+import qualified Darcs.Util.Tree.Plain as PlainTree ( readPlainTree )+import Darcs.Util.Index+    ( Index+    , indexFormatValid+    , openIndex+    , treeFromIndex+    , updateIndexFrom+    )+import qualified Darcs.Util.Tree as Tree+import Darcs.Util.Index ( listFileIDs, getFileID ) -import Storage.Hashed.AnchoredPath( AnchoredPath(..), anchorPath, floatPath, Name(..) )-import Storage.Hashed.Tree( Tree, restrict, FilterTree, expand, filter, emptyTree, overlay, find )-import Storage.Hashed.Plain( readPlainTree )-import Storage.Hashed.Darcs( darcsTreeHash, readDarcsHashed, decodeDarcsHash, decodeDarcsSize )-import Storage.Hashed.Hash( Hash( NoHash ) )-import qualified Storage.Hashed.Index as I-import qualified Storage.Hashed.Tree as Tree+#define TEST_INDEX 0 -#include "gadts.h"+#if TEST_INDEX+import Control.Monad ( unless )+import Darcs.Util.Path ( displayPath )+import Darcs.Util.Tree ( list )+#else+import System.IO ( hPutStrLn, stderr )+import System.IO.Error ( catchIOError )+#endif  newtype TreeFilter m = TreeFilter { applyTreeFilter :: forall tr . FilterTree tr m => tr m -> tr m } --- TODO: We wrap the pending patch inside RepoPatch here, to avoid the--- requirement to propagate an (ApplyState (PrimOf p) ~ ApplyState p)--- constraint everywhere. When we have GHC 7.2 as a minimum requirement, we can--- lift this constraint into RepoPatch superclass context and remove this hack.-readPendingLL :: (RepoPatch p, ApplyState p ~ Tree)-              => Repository p C(r u t) -> IO (Sealed ((FL p) C(t)))-readPendingLL repo = mapSeal (mapFL_FL fromPrim) `fmap` LowLevel.readPending repo---- | From a repository and a list of SubPath's, construct a filter that can be+-- | From a repository and a list of AnchoredPath's, construct a filter that can be -- used on a Tree (recorded or unrecorded state) of this repository. This -- constructed filter will take pending into account, so the subpaths will be -- translated correctly relative to pending move patches.-restrictSubpaths :: forall p m C(r u t). (RepoPatch p, ApplyState p ~ Tree)-                 => Repository p C(r u t) -> [SubPath]+restrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree)+                 => Repository rt p wU wR -> [AnchoredPath]                  -> IO (TreeFilter m)-restrictSubpaths repo subpaths = do-  Sealed pending <- readPendingLL repo-  let paths = map (fn2fp . sp2fn) subpaths-      paths' = paths `union` (effectOnFilePaths pending paths)-      anchored = map floatPath paths'+restrictSubpaths repo paths = do+  Sealed pending <- Pending.readPending repo+  restrictSubpathsAfter pending repo paths++-- | Like 'restrictSubpaths' but with the pending patch passed as a parameter.+-- The 'Repository' parameter is not used, we need it only to avoid+-- abiguous typing of @p@.+restrictSubpathsAfter :: (RepoPatch p, ApplyState p ~ Tree)+                      => FL (PrimOf p) wR wP+                      -> Repository rt p wU wR+                      -> [AnchoredPath]+                      -> IO (TreeFilter m)+restrictSubpathsAfter pending _repo paths = do+  let paths' = paths `union` effectOnPaths pending paths       restrictPaths :: FilterTree tree m => tree m -> tree m-      restrictPaths = filter (filterPaths anchored)+      restrictPaths = Tree.filter (filterPaths paths')   return (TreeFilter restrictPaths) --- |Is the given path in (or equal to) the _darcs metadata directory?-inDarcsDir :: AnchoredPath -> Bool-inDarcsDir (AnchoredPath (Name x:_)) | x == BSC.pack darcsdir = True-inDarcsDir _ = False+-- note we assume pending starts at the recorded state+maybeRestrictSubpaths :: (RepoPatch p, ApplyState p ~ Tree)+                      => FL (PrimOf p) wR wP+                      -> Repository rt p wU wR+                      -> Maybe [AnchoredPath]+                      -> IO (TreeFilter m)+maybeRestrictSubpaths pending repo =+  maybe (return $ TreeFilter id) (restrictSubpathsAfter pending repo) --- | Construct a Tree filter that removes any boring files the Tree might have--- contained. Additionally, you should (in most cases) pass an (expanded) Tree--- that corresponds to the recorded content of the repository. This is--- important in the cases when the repository contains files that would be--- boring otherwise. (If you pass emptyTree instead, such files will simply be--- discarded by the filter, which is usually not what you want.)+-- | Construct a 'TreeFilter' that removes any boring files that are not also+-- contained in the argument 'Tree'. ----- This function is most useful when you have a plain Tree corresponding to the--- full working copy of the repository, including untracked--- files. Cf. whatsnew, record --look-for-adds.  NB. Assumes that our CWD is--- the repository root.-restrictBoring :: forall m . Tree m -> IO (TreeFilter m)+-- The standard use case is for the argument to be the recorded state, possibly+-- with further patches applied, so as not to discard any files already known+-- to darcs. The result is usually applied to the full working state.+restrictBoring :: Tree m -> IO (TreeFilter m) restrictBoring guide = do-  boring <- boringRegexps-  let boring' p | inDarcsDir p = False-      boring' p = not $ any (\rx -> isJust $ matchRegex rx p') boring-          where p' = anchorPath "" p+  boring <- isBoring+  let exclude p t = inDarcsdir p || boring (appendSlash t (realPath p))+      appendSlash TreeType fp = fp ++ "/"+      appendSlash BlobType fp = fp       restrictTree :: FilterTree t m => t m -> t m-      restrictTree = filter $ \p _ -> case find guide p of-                                        Nothing -> boring' p-                                        _ -> True+      restrictTree =+        Tree.filter $ \p i ->+          case find guide p of+            Nothing -> not (exclude p (itemType i))+            _ -> True   return (TreeFilter restrictTree)  -- | Construct a Tree filter that removes any darcs metadata files the -- Tree might have contained.-restrictDarcsdir :: forall m . TreeFilter m-restrictDarcsdir = TreeFilter $ filter $ \p _ -> not (inDarcsDir p)+restrictDarcsdir :: TreeFilter m+restrictDarcsdir = TreeFilter $ Tree.filter $ \p _ -> not (inDarcsdir p) --- | For a repository and an optional list of paths (when Nothing, take--- everything) compute a (forward) list of prims (i.e. a patch) going from the--- recorded state of the repository (pristine) to the unrecorded state of the--- repository (the working copy + pending). When a list of paths is given, at--- least the files that live under any of these paths in either recorded or--- unrecorded will be included in the resulting patch. NB. More patches may be--- included in this list, eg. the full contents of the pending patch. This is--- usually not a problem, since selectChanges will properly filter the results--- anyway.------ This also depends on the options given: with LookForAdds, we will include--- any non-boring files (i.e. also those that do not exist in the "recorded"--- state) in the working in the "unrecorded" state, and therefore they will--- show up in the patches as addfiles.------ The IgnoreTimes option disables index usage completely -- for each file, we--- read both the unrecorded and the recorded copy and run a diff on them. This--- is very inefficient, although in extremely rare cases, the index could go--- out of sync (file is modified, index is updated and file is modified again--- within a single second).-unrecordedChanges :: forall p C(r u t) . (RepoPatch p, ApplyState p ~ Tree)-                  => (UseIndex, ScanKnown) -> Repository p C(r u t)-                  -> Maybe [SubPath] -> IO (FL (PrimOf p) C(t u))-unrecordedChanges _ r@(Repo _ _ rf _) _-  | (formatHas NoWorkingDir rf) = do-    IsEq <- return $ workDirLessRepoWitness r-    return NilFL-unrecordedChanges (useidx, scan) repo mbpaths = do-  (all_current, Sealed (pending :: FL p C(t x))) <- readPending repo+{- |+For a repository and an optional list of paths (when 'Nothing', take+everything) compute a (forward) list of prims (i.e. a patch) going from the+recorded state of the repository (pristine) to the unrecorded state of the+repository (the working tree + pending). When a list of paths is given, at+least the files that live under any of these paths in either recorded or+unrecorded will be included in the resulting patch. NB. More patches may be+included in this list, eg. the full contents of the pending patch. This is+usually not a problem, since selectChanges will properly filter the results+anyway. -  relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths-  let getIndex = I.updateIndex =<< (applyTreeFilter relevant <$> readIndex repo)-      current = applyTreeFilter relevant all_current+This also depends on the options given: -  index <- getIndex-  working <- applyTreeFilter restrictDarcsdir <$> case scan of-    ScanKnown -> case useidx of-      UseIndex -> getIndex-      IgnoreIndex -> do-        guide <- expand current-        applyTreeFilter relevant <$> restrict guide <$> readPlainTree "."-    ScanAll -> do-      nonboring <- restrictBoring index-      plain <- applyTreeFilter relevant <$> applyTreeFilter nonboring <$> readPlainTree "."-      return $ case useidx of-        UseIndex -> plain `overlay` index-        IgnoreIndex -> plain-    ScanBoring -> do-      plain <- applyTreeFilter relevant <$> readPlainTree "."-      return $ case useidx of-        UseIndex -> plain `overlay` index-        IgnoreIndex -> plain+--look-for-moves: Detect pending file moves using the index. The resulting+  patches are added to pending and taken into consideration, when filtering+  the tree according to the given path list. +--look-for-adds: Include files in the working state that do not exist in the+  recorded + pending state.++--include-boring: Include even boring files.++--look-for-replaces: Detect pending replace patches. Like detected moves,+  these are added to the pending patch. Note that, like detected moves,+  these are mere proposals for the user to consider or reject.++--ignore-times: Disables index usage completely -- for each file, we read+  both the unrecorded and the recorded copy and run a diff on them. This is+  very inefficient, although in extremely rare cases, the index could go out+  of sync (file is modified, index is updated and file is modified again+  within a single second).++  Note that use of the index is also disabled when we detect moves or+  replaces, since this implies that the index is out of date.+-}+unrecordedChanges :: (RepoPatch p, ApplyState p ~ Tree)+                  => DiffOpts+                  -> Repository rt p wU wR+                  -> Maybe [AnchoredPath] -> IO (FL (PrimOf p) wR wU)+unrecordedChanges dopts@DiffOpts{..} r paths = do+  (pending :> working) <- readPendingAndWorking dopts r paths+  return $ canonizeFL diffAlg (pending +>+ working)++-- Implementation note: it is important to do things in the right order: we+-- first have to read the pending patch, then detect moves, then detect adds,+-- then detect replaces.+readPendingAndWorking :: (RepoPatch p, ApplyState p ~ Tree)+                      => DiffOpts+                      -> Repository rt p wU wR+                      -> Maybe [AnchoredPath]+                      -> IO ((FL (PrimOf p) :> FL (PrimOf p)) wR wU)+readPendingAndWorking _ r _ | formatHas NoWorkingDir (repoFormat r) = do+  IsEq <- return $ workDirLessRepoWitness r+  return (NilFL :> NilFL)+readPendingAndWorking DiffOpts{..} repo mbpaths = do+  debugMessage "readPendingAndWorking: start"+  (pending_tree, working_tree, (pending :> moves)) <-+    readPendingAndMovesAndUnrecorded repo withIndex lookForAdds lookForMoves mbpaths+  debugMessage "readPendingAndWorking: after readPendingAndMovesAndUnrecorded"+  (pending_tree_with_replaces, Sealed replaces) <-+    getReplaces lookForReplaces diffAlg repo pending_tree working_tree+  debugMessage "readPendingAndWorking: after getReplaces"   ft <- filetypeFunction-  Sealed (diff :: FL (PrimOf p) C(x y)) <- (unFreeLeft `fmap` treeDiff ft current working) :: IO (Sealed (FL (PrimOf p) C(x)))-  IsEq <- return (unsafeCoerceP IsEq) :: IO (EqCheck C(y u))-  return $ sortCoalesceFL (effect pending +>+ diff)+  wrapped_diff <- treeDiff diffAlg ft pending_tree_with_replaces working_tree+  case unFreeLeft wrapped_diff of+    Sealed diff -> do+      debugMessage "readPendingAndWorking: done"+      return $ unsafeCoercePEnd $ pending :> (moves +>+ replaces +>+ diff) --- | Witnesses the fact that in the absence of a working directory, we--- pretend that the working dir updates magically to the tentative state.-workDirLessRepoWitness :: Repository p C(r u t)-                          -> (EqCheck C(u t))-workDirLessRepoWitness (Repo _ _ rf _) | formatHas NoWorkingDir rf =-  unsafeCoerceP IsEq-                                       | otherwise = NotEq+readPendingAndMovesAndUnrecorded+  :: (RepoPatch p, ApplyState p ~ Tree)+  => Repository rt p wU wR+  -> UseIndex+  -> LookForAdds+  -> LookForMoves+  -> Maybe [AnchoredPath]+  -> IO ( Tree IO             -- pristine with (pending + moves)+        , Tree IO             -- working+        , (FL (PrimOf p) :> FL (PrimOf p)) wR wM -- pending :> moves+        )+readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths = do+  debugMessage "readPendingAndMovesAndUnrecorded: start"+  (pending_tree, Sealed pending) <- readPending repo+  moves <- getMoves lfm repo mbpaths+  -- we want to include any user specified paths before and after pending+  -- and detected moves+  relevant <- maybeRestrictSubpaths (pending +>+ moves) repo mbpaths+  pending_tree_with_moves <-+    applyTreeFilter relevant <$> applyToTree moves pending_tree+  debugMessage "readPendingAndMovesAndUnrecorded: before readIndexOrPlainTree"+  -- the moves are detected i.e. they are already applied in the working tree;+  -- also note that we have to use the amended pending tree to restrict the+  -- working tree in case we don't use the index (here and below)+  index <- readIndexOrPlainTree repo useidx relevant pending_tree_with_moves+  debugMessage "readPendingAndMovesAndUnrecorded: before filteredWorking"+  -- TODO this conditional looks wrong; so if we do have detected moves,+  -- then we cannot use the index to read the working state? Why not?+  let useidx' = if nullFL moves then useidx else IgnoreIndex+  working_tree <-+    filteredWorking repo useidx' scan relevant index pending_tree_with_moves+  debugMessage "readPendingAndMovesAndUnrecorded: done"+  return+    (pending_tree_with_moves, working_tree, unsafeCoercePEnd (pending :> moves)) --- | Obtains a Tree corresponding to the "recorded" state of the repository:--- this is the same as the pristine cache, which is the same as the result of--- applying all the repository's patches to an empty directory.------ Handles the plain and hashed pristine cases. Currently does not handle the--- no-pristine case, as that requires replaying patches. Cf. 'readDarcsHashed'--- and 'readPlainTree' in hashed-storage that are used to do the actual 'Tree'--- construction.-readRecorded :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO (Tree IO)-readRecorded _repo = do-  let h_inventory = darcsdir </> "hashed_inventory"-  hashed <- doesFileExist h_inventory-  if hashed-     then do inv <- BS.readFile h_inventory-             let linesInv = BSC.split '\n' inv-             case linesInv of-               [] -> return emptyTree-               (pris_line:_) -> do-                          let hash = decodeDarcsHash $ BS.drop 9 pris_line-                              size = decodeDarcsSize $ BS.drop 9 pris_line-                          when (hash == NoHash) $ fail $ "Bad pristine root: " ++ show pris_line-                          readDarcsHashed (darcsdir </> "pristine.hashed") (size, hash)-     else do have_pristine <- doesDirectoryExist $ darcsdir </> "pristine"-             have_current <- doesDirectoryExist $ darcsdir </> "current"-             case (have_pristine, have_current) of-               (True, _) -> readPlainTree $ darcsdir </> "pristine"-               (False, True) -> readPlainTree $ darcsdir </> "current"-               (_, _) -> fail "No pristine tree is available!"+-- | @filteredWorking useidx scan relevant from_index pending_tree@ reads the+-- working tree and filters it according to options and @relevant@ file paths.+-- The @pending_tree@ is understood to have @relevant@ already applied and is+-- used (only) if @useidx == 'IgnoreIndex'@ and @scan /= 'EvenLookForBoring'@ to act as+-- a guide for filtering the working tree.+filteredWorking :: Repository rt p wU wR+                -> UseIndex+                -> LookForAdds+                -> TreeFilter IO+                -> Tree IO+                -> Tree IO+                -> IO (Tree IO)+filteredWorking repo useidx scan relevant from_index pending_tree =+  applyTreeFilter restrictDarcsdir <$> applyTreeFilter relevant <$>+    case useidx of+      UseIndex ->+        case scan of+          NoLookForAdds -> return from_index+          YesLookForAdds -> do+            nonboring <- restrictBoring from_index+            plain <- applyTreeFilter nonboring <$> readPlainTree repo+            return $ plain `overlay` from_index+          EvenLookForBoring -> do+            plain <- readPlainTree repo+            return $ plain `overlay` from_index+      IgnoreIndex -> do+        working <- readPlainTree repo+        case scan of+          NoLookForAdds -> do+            guide <- expand pending_tree+            return $ restrict guide working+          YesLookForAdds -> do+            guide <- expand pending_tree+            nonboring <- restrictBoring guide+            return $ applyTreeFilter nonboring working+          EvenLookForBoring -> return working +-- | Witnesses the fact that in the absence of a working tree, the+-- unrecorded state cannot differ from the record state.+workDirLessRepoWitness :: Repository rt p wU wR -> EqCheck wU wR+workDirLessRepoWitness r+ | formatHas NoWorkingDir (repoFormat r) = unsafeCoerceP IsEq+ | otherwise                             = NotEq+ -- | Obtains a Tree corresponding to the "unrecorded" state of the repository:--- the working tree plus the "pending" patch. The optional list of paths allows--- to restrict the query to a subtree.+-- the modified files of the working tree plus the "pending" patch.+-- The optional list of paths allows to restrict the query to a subtree. -- -- Limiting the query may be more efficient, since hashes on the uninteresting -- parts of the index do not need to go through an up-to-date check (which -- involves a relatively expensive lstat(2) per file. readUnrecorded :: (RepoPatch p, ApplyState p ~ Tree)-               => Repository p C(r u t) -> Maybe [SubPath] -> IO (Tree IO)-readUnrecorded repo mbpaths = do-  relevant <- maybe (return $ TreeFilter id) (restrictSubpaths repo) mbpaths-  readIndex repo >>= I.updateIndex . applyTreeFilter relevant---- | Obtains a Tree corresponding to the working copy of the--- repository. NB. Almost always, using readUnrecorded is the right--- choice. This function is only useful in not-completely-constructed--- repositories.-readWorking :: IO (Tree IO)-readWorking = expand =<< (nodarcs `fmap` readPlainTree ".")-  where nodarcs = Tree.filter (\(AnchoredPath (Name x:_)) _ -> x /= BSC.pack "_darcs")+               => Repository rt p wU wR+               -> UseIndex+               -> Maybe [AnchoredPath]+               -> IO (Tree IO)+readUnrecorded repo useidx mbpaths = do+#if TEST_INDEX+  t1 <- expand =<< readUnrecordedFiltered repo useidx NoLookForAdds NoLookForMoves mbpaths+  (pending_tree, Sealed pending) <- readPending repo+  relevant <- maybeRestrictSubpaths pending repo mbpaths+  t2 <- readIndexOrPlainTree repo useidx relevant pending_tree+  assertEqualTrees "indirect" t1 "direct" t2+  return t1+#else+  expand =<< readUnrecordedFiltered repo useidx NoLookForAdds NoLookForMoves mbpaths+#endif -readRecordedAndPending :: (RepoPatch p, ApplyState p ~ Tree)-                       => Repository p C(r u t) -> IO (Tree IO)-readRecordedAndPending repo = fst `fmap` readPending repo+#if TEST_INDEX+assertEqualTrees :: String -> Tree m -> String -> Tree m -> IO ()+assertEqualTrees n1 t1 n2 t2 =+  unless (t1 `eqTree` t2) $+    fail $ "Trees are not equal!\n" ++ showTree n1 t1 ++ showTree n2 t2 -readPending :: (RepoPatch p, ApplyState p ~ Tree)-            => Repository p C(r u t) -> IO (Tree IO, Sealed (FL p C(t)))-readPending repo =-  do Sealed pending <- readPendingLL repo-     pristine <- readRecorded repo-     catch ((\t -> (t, seal pending)) `fmap` applyToTree pending pristine) $ \ (err :: IOException) -> do-       putStrLn $ "Yikes, pending has conflicts! " ++ show err-       putStrLn $ "Stashing the buggy pending as _darcs/patches/pending_buggy"-       renameFile "_darcs/patches/pending"-                  "_darcs/patches/pending_buggy"-       return (pristine, seal NilFL)+eqTree :: Tree m -> Tree m -> Bool+eqTree t1 t2 = map fst (list t1) == map fst (list t2) --- | Mark the existing index as invalid. This has to be called whenever the--- listing of pristine changes and will cause darcs to update the index next--- time it tries to read it. (NB. This is about files added and removed from--- pristine: changes to file content in either pristine or working are handled--- transparently by the index reading code.)-invalidateIndex :: t -> IO ()-invalidateIndex _ = do-  BS.writeFile "_darcs/index_invalid" BS.empty+showTree :: String -> Tree m -> String+showTree name tree = unlines (name : map (("  "++) . displayPath . fst) (list tree))+#endif -readIndex :: (RepoPatch p, ApplyState p ~ Tree) => Repository p C(r u t) -> IO I.Index-readIndex repo = do-  invalid <- doesFileExist "_darcs/index_invalid"-  exist <- doesFileExist "_darcs/index"-  format_valid <- if exist-                     then I.indexFormatValid "_darcs/index"-                     else return True-  when (exist && not format_valid) $-#if mingw32_HOST_OS-       renameFile "_darcs/index" "_darcs/index.old"+readIndexOrPlainTree :: (ApplyState p ~ Tree, RepoPatch p)+                     => Repository rt p wU wR+                     -> UseIndex+                     -> TreeFilter IO+                     -> Tree IO+                     -> IO (Tree IO)+#if TEST_INDEX+readIndexOrPlainTree repo useidx treeFilter pending_tree = do+  indexTree <-+    treeFromIndex =<< applyTreeFilter treeFilter <$> readIndex repo+  plainTree <- do+    guide <- expand pending_tree+    expand =<< applyTreeFilter treeFilter . restrict guide <$> readPlainTree repo+  assertEqualTrees "index tree" indexTree "plain tree" plainTree+  return $+    case useidx of+      UseIndex -> indexTree+      IgnoreIndex -> plainTree #else-       removeFile "_darcs/index"+readIndexOrPlainTree repo UseIndex treeFilter pending_tree =+  (treeFromIndex =<< applyTreeFilter treeFilter <$> readIndex repo)+    `catchIOError` \e -> do+      hPutStrLn stderr ("Warning, cannot access the index:\n" ++ show e)+      readIndexOrPlainTree repo IgnoreIndex treeFilter pending_tree+readIndexOrPlainTree repo IgnoreIndex treeFilter pending_tree = do+  guide <- expand pending_tree+  expand =<< applyTreeFilter treeFilter . restrict guide <$> readPlainTree repo #endif-  if (not exist || invalid || not format_valid)-     then do pris <- readRecordedAndPending repo-             idx <- I.updateIndexFrom "_darcs/index" darcsTreeHash pris-             when invalid $ removeFile "_darcs/index_invalid"-             return idx-     else I.readIndex "_darcs/index" darcsTreeHash++-- | A variant of 'readUnrecorded' that takes the UseIndex and LookForAdds+-- options into account, similar to 'readPendingAndWorking'. We are only+-- interested in the resulting tree, not the patch, so the 'DiffAlgorithm' option+-- is irrelevant.+readUnrecordedFiltered :: (RepoPatch p, ApplyState p ~ Tree)+                       => Repository rt p wU wR+                       -> UseIndex+                       -> LookForAdds+                       -> LookForMoves+                       -> Maybe [AnchoredPath] -> IO (Tree IO)+readUnrecordedFiltered repo useidx scan lfm mbpaths = do+  (_, working_tree, _) <-+    readPendingAndMovesAndUnrecorded repo useidx scan lfm mbpaths+  return working_tree++-- | Obtains the relevant (according to the given filter) part of the working tree.+readWorking :: TreeFilter IO -> IO (Tree IO)+readWorking relevant =+  expand =<<+  (applyTreeFilter relevant . applyTreeFilter restrictDarcsdir <$>+   PlainTree.readPlainTree ".")++-- | Obtains the recorded 'Tree' with the pending patch applied.+readPristineAndPending :: (RepoPatch p, ApplyState p ~ Tree)+                       => Repository rt p wU wR -> IO (Tree IO)+readPristineAndPending repo = fst `fmap` readPending repo++-- | Obtains the recorded 'Tree' with the pending patch applied, plus+--   the pending patch itself. The pending patch should start at the+--   recorded state (we even verify that it applies, and degrade to+--   renaming pending and starting afresh if it doesn't).+readPending :: (RepoPatch p, ApplyState p ~ Tree)+            => Repository rt p wU wR+            -> IO (Tree IO, Sealed (FL (PrimOf p) wR))+readPending repo = do+  pristine <- readPristine repo+  Sealed pending <- Pending.readPending repo+  catch ((\t -> (t, seal pending)) <$> applyToTree pending pristine) $ \(e::IOException) -> do+    fail $+      "Cannot apply pending patch, please run `darcs repair`\n"+      ++ show e++-- | Open the index or re-create it in case it is invalid or non-existing.+readIndex :: (RepoPatch p, ApplyState p ~ Tree)+          => Repository rt p wU wR -> IO Index+readIndex repo = do+  okay <- checkIndex+  if not okay+    then internalUpdateIndex repo+    else openIndex indexPath++-- | Update the index so that it matches pristine+pending. If the index does+-- not exist or is invalid, create a new one. Returns the updated index.+internalUpdateIndex :: (RepoPatch p, ApplyState p ~ Tree)+            => Repository rt p wU wR -> IO Index+internalUpdateIndex repo = do+  pris <-+    readPristineAndPending repo+    `catch` \(_::IOException) -> readPristine repo+  idx <- updateIndexFrom indexPath pris+  removeFileMayNotExist indexInvalidPath+  return idx++-- | Update the index so that it matches pristine+pending. If the index does+-- not exist or is invalid, create a new one.+--+-- This has to be called whenever the listing of pristine+pending changes. Note+-- that this only concerns files added and removed or renamed: changes to file+-- content in either pristine or working are handled transparently by the index+-- reading code.+updateIndex :: (RepoPatch p, ApplyState p ~ Tree)+            => Repository rt p wU wR -> IO ()+updateIndex repo = do+  -- call checkIndex to throw away the index if it is invalid;+  -- this can happen if we are called with --ignore-times+  -- TODO make this impossible i.e. honor UseIndex here+  void checkIndex+  void $ internalUpdateIndex repo++-- | Check if we have a valid index. This means that the index file exists, is+-- readable, and can be mmapped. For compatibility with older darcs versions we+-- also check that indexInvalidPath does not exist. We do not yet remove+-- indexInvalidPath in case updating the index fails.+checkIndex :: IO Bool+checkIndex = do+  invalid <- doesFileExist $ indexInvalidPath+  formatValid <- indexFormatValid indexPath+  exist <- doesFileExist indexPath+  -- this fails with a permission (access denied) error on windows+  -- if we use removeFileMayNotExist instead of renameFile+  when (exist && not formatValid) $ renameFile indexPath (indexPath <.> "old")+  return (not invalid && formatValid)++-- |Remove any patches (+dependencies) from a sequence that+-- conflict with the recorded or unrecorded changes in a repo+filterOutConflicts+  :: (RepoPatch p, ApplyState p ~ Tree)+  => Repository rt p wU wR     -- ^Repository itself, used for grabbing+                                  --  unrecorded changes+  -> UseIndex                     -- ^Whether to use the index when reading+                                  --  the working state+  -> FL (PatchInfoAnd p) wX wR -- ^Recorded patches from repository, starting from+                                  --  same context as the patches to filter+  -> FL (PatchInfoAnd p) wX wZ -- ^Patches to filter+  -> IO (Bool, Sealed (FL (PatchInfoAnd p) wX))+                                  -- ^True iff any patches were removed,+                                  --  possibly filtered patches+filterOutConflicts repository useidx us them+     = do -- Note: use of anonymous is benign here since we only try to merge cleanly+          unrec <- fmap n2pia . anonymous+                     =<< unrecordedChanges+                          (DiffOpts useidx NoLookForAdds NoLookForReplaces+                          NoLookForMoves MyersDiff) repository Nothing+          them' :> rest <-+            return $ partitionConflictingFL them (us +>+ unrec :>: NilFL)+          return (check rest, Sealed them')+  where check :: FL p wA wB -> Bool+        check NilFL = False+        check _ = True++-- | Automatically detect file moves using the index.+-- TODO: This function lies about the witnesses.+getMoves :: forall rt p wU wR wB prim.+            (RepoPatch p, ApplyState p ~ Tree, prim ~ PrimOf p)+         => LookForMoves+         -> Repository rt p wU wR+         -> Maybe [AnchoredPath]+         -> IO (FL prim wB wB)+getMoves NoLookForMoves _ _ = return NilFL+getMoves YesLookForMoves repository files =+    mkMovesFL <$> getMovedFiles repository files+  where+    mkMovesFL [] = NilFL+    mkMovesFL ((a,b,_):xs) = move a b :>: mkMovesFL xs++    getMovedFiles :: Repository rt p wU wR+                  -> Maybe [AnchoredPath]+                  -> IO [(AnchoredPath, AnchoredPath, ItemType)]+    getMovedFiles repo fs = do+        old <- sortBy (comparing snd) <$> (listFileIDs =<< readIndex repo)+        nonboring <- restrictBoring emptyTree+        let addIDs = foldM (\xs (p, it)-> do mfid <- getFileID p+                                             return $ case mfid of+                                               Nothing -> xs+                                               Just fid -> ((p, it), fid):xs) []+        new <- sortBy (comparing snd) <$>+                 (addIDs . map (\(a,b) -> (a, itemType b)) . Tree.list  =<<+                   expand =<< applyTreeFilter nonboring <$> readPlainTree repository)+        let match (x:xs) (y:ys)+              | snd x > snd y = match (x:xs) ys+              | snd x < snd y = match xs (y:ys)+              | snd (fst x) /= snd (fst y) = match xs ys+              | otherwise = (fst (fst x), fst (fst y), snd (fst x)):match xs ys+            match _ _ = []+            movedfiles = match old new+            fmovedfiles =+              case fs of+                Nothing -> movedfiles+                Just paths ->+                  filter (\(f1, f2, _) -> any (`elem` selfiles) [f1, f2]) movedfiles+                  where selfiles = paths+        return (resolve fmovedfiles)++    resolve :: [(AnchoredPath, AnchoredPath, ItemType)]+            -> [(AnchoredPath, AnchoredPath, ItemType)]+    resolve xs = fixPaths $ sortMoves $ deleteCycles xs+      where+        -- Input relation is left-and-right-unique. Makes cycle detection easier.+        deleteCycles [] = []+        deleteCycles whole@( x@(start,_,_):rest)+            = if hasCycle start whole start+                  then deleteCycles (deleteFrom start whole [])+                  else x:deleteCycles rest+           where hasCycle current ((a',b',_):rest') first+                     | a' == current = b' == first || hasCycle b' whole first+                     | otherwise     = hasCycle current rest' first +                 hasCycle _ [] _     = False+                 deleteFrom a (y@(a',b',_):ys) seen+                   | a == a'   = deleteFrom b' (seen++ys) []+                   | otherwise = deleteFrom a ys (y:seen)+                 deleteFrom _ [] seen = seen++        sortMoves []                           = []+        sortMoves whole@(current@(_,dest,_):_) =+              smallest:sortMoves (delete smallest whole)+              where+               smallest = follow dest whole current+               follow prevDest (y@(s,d,_):ys) currentSmallest+                 -- destination is source of another move+                 | prevDest == s             = follow d whole y+                 -- parent of destination is also destination of a move+                 | d `elem` parents prevDest = follow d whole y+                 | otherwise     = follow prevDest ys currentSmallest+               follow _ [] currentSmallest = currentSmallest++        -- rewrite [d/ -> e/, .., d/f -> e/h] to [d/ -> e/, .., e/f -> e/h]+        -- and throw out moves that don't move anything (can they be in there?)+        fixPaths [] = []+        fixPaths (y@(f1,f2,t):ys)+                        | f1 == f2         = fixPaths ys -- no effect, throw out+                        | TreeType <- t    = y:fixPaths (map replacepp ys)+                        | otherwise        = y:fixPaths ys+         -- TODO why adapt only if1 here and not if2?+         --      is this a bug?+         where replacepp (if1,if2,it) = (movedirfilename f1 f2 if1, if2, it)++-- | Search for possible replaces between the recordedAndPending state+-- and the unrecorded (or working) state. Return a Sealed FL list of+-- replace patches to be applied to the recordedAndPending state.+getReplaces :: forall rt p wU wR+             . (RepoPatch p, ApplyState p ~ Tree)+            => LookForReplaces+            -> DiffAlgorithm+            -> Repository rt p wU wR+            -> Tree IO -- ^ pending tree (including possibly detected moves)+            -> Tree IO -- ^ working tree+            -> IO (Tree IO, -- new pending tree+                   Sealed (FL (PrimOf p) wU))+getReplaces NoLookForReplaces _ _ pending _ = return (pending, Sealed NilFL)+getReplaces YesLookForReplaces diffalg _repo pending working = do+    ftf <- filetypeFunction+    Sealed changes <- unFreeLeft <$> treeDiff diffalg ftf pending working+    let allModifiedTokens = concat $ mapFL modifiedTokens changes+        replaces = rmInvalidReplaces allModifiedTokens+    (patches, new_pending) <-+      flip runStateT pending $+        forM replaces $ \(path, a, b) ->+          doReplace defaultToks path (BC.unpack a) (BC.unpack b)+    return (new_pending, mapSeal concatFL $ unFreeLeft $ joinGapsFL patches)+  where+    modifiedTokens :: PrimOf p wX wY -> [(AnchoredPath, B.ByteString, B.ByteString)]+    modifiedTokens p = case isHunk p of+      Just (FileHunk f _ old new) ->+        map (\(a,b) -> (f, a, b)) (concatMap checkModified $+          filter (\(a,b) -> length a == length b) -- only keep lines with same number of tokens+            $ zip (map breakToTokens old) (map breakToTokens new))+      Nothing -> []++    -- from a pair of token lists, create a pair of modified token lists+    checkModified = filter (\(a,b) -> a/=b) . uncurry zip++    rmInvalidReplaces [] = []+    rmInvalidReplaces ((f,old,new):rs)+      | any (\(f',a,b) -> f' == f && old == a && b /= new) rs =+          -- inconsistency detected+          rmInvalidReplaces $ filter (\(f'',a',_) -> f'' /= f || a' /= old) rs+    rmInvalidReplaces (r:rs) = r:rmInvalidReplaces (filter (/=r) rs)++    doReplace toks path old new = do+        pend <- get+        mpend' <- liftIO $ maybeApplyToTree replacePatch pend+        case mpend' of+          Nothing -> getForceReplace path toks old new+          Just pend' -> do+            put pend'+            return $ consGapFL replacePatch (emptyGap NilFL)+      where+        replacePatch = tokreplace path toks old new++    getForceReplace :: (PrimPatch prim, ApplyState prim ~ Tree)+                    => AnchoredPath -> String -> String -> String+                    -> StateT (Tree IO) IO (FreeLeft (FL prim))+    getForceReplace path toks old new = do+        -- the tree here is the "current" pending state+        tree <- get+        -- It would be nice if we could fuse the two traversals here, that is,+        -- expandPath and findFile. OTOH it is debatable whether adding a new+        -- effectful version of findFile to Darcs.Util.Tree is justified.+        expandedTree <- liftIO $ expandPath tree path+        content <- case findFile expandedTree path of+          Just blob -> liftIO $ readBlob blob+          Nothing -> error $ "getForceReplace: not in tree: " ++ show path+        let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old)+                            (B.concat $ BL.toChunks content)+            tree' = modifyTree expandedTree path . Just . File $ makeBlobBS newcontent+        ftf <- liftIO $ filetypeFunction+        normaliseNewTokPatch <- liftIO $ treeDiff diffalg ftf expandedTree tree'+        -- make sure we can apply them to the pending state+        patches <- return $ joinGap (+>+) normaliseNewTokPatch $ freeGap $+            tokreplace path toks old new :>: NilFL+        mtree'' <- case unFreeLeft patches of+            Sealed ps -> liftIO $ maybeApplyToTree ps tree+        case mtree'' of+            Nothing -> error "getForceReplace: unable to apply detected force replaces"+            Just tree'' -> do+                put tree''+                return patches++-- | Add an 'FL' of patches started from the pending state to the pending patch.+unsafeAddToPending :: (RepoPatch p, ApplyState p ~ Tree)+                   => Repository 'RW p wU wR+                   -> FreeLeft (FL (PrimOf p)) -> IO ()+unsafeAddToPending repo newP = do+    (_, Sealed toPend) <- readPending repo+    case unFreeLeft newP of+        (Sealed p) -> do+            Pending.writeTentativePending repo (toPend +>+ p)++-- | Add an 'FL' of patches starting from the working state to the pending patch,+-- including as much extra context as is necessary (context meaning+-- dependencies), by commuting the patches to be added past as much of the+-- changes between pending and working as is possible, and including anything+-- that doesn't commute, and the patch itself in the new pending patch.+addToPending :: (RepoPatch p, ApplyState p ~ Tree)+             => Repository 'RW p wU wR+             -> DiffOpts+             -> FL (PrimOf p) wU wY -> IO ()+addToPending repo dopts p = do+   (toPend :> toUnrec) <-+      readPendingAndWorking dopts repo Nothing+   case genCommuteWhatWeCanRL commuteFL (reverseFL toUnrec :> p) of+       (toP' :> p'  :> _excessUnrec) -> do+           Pending.writeTentativePending repo (toPend +>+ reverseRL toP' +>+ p')++readPlainTree :: Repository rt p wU wR -> IO (Tree IO)+readPlainTree repo  = PlainTree.readPlainTree (repoLocation repo)
+ src/Darcs/Repository/Transaction.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE OverloadedStrings #-}+module Darcs.Repository.Transaction+    ( revertRepositoryChanges+    , finalizeRepositoryChanges+    , upgradeOldStyleRebase+    ) where++import Darcs.Prelude++import Control.Monad ( unless, void, when )+import System.Directory ( doesFileExist, removeFile )+import System.IO ( IOMode(..), hClose, hPutStrLn, openBinaryFile, stderr )+import System.IO.Error ( catchIOError )++import Darcs.Patch ( ApplyState, PatchInfoAnd, RepoPatch )+import qualified Darcs.Patch.Rebase.Legacy.Wrapped as W+import Darcs.Patch.Rebase.Suspended ( Suspended(..), showSuspended )+import Darcs.Patch.Set ( Origin, PatchSet(..), Tagged(..) )+import Darcs.Patch.Show ( ShowPatchFor(..) )+import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (:>)(..) )+import Darcs.Patch.Witnesses.Sealed ( Dup(..), Sealed(..) )++import Darcs.Repository.Flags ( DryRun(..) )+import Darcs.Repository.Format+    ( RepoProperty(HashedInventory, RebaseInProgress, RebaseInProgress_2_16)+    , addToFormat+    , formatHas+    , removeFromFormat+    )+import Darcs.Repository.Hashed+    ( finalizeTentativeChanges+    , readPatches+    , readTentativePatches+    , revertTentativeChanges+    , writeTentativeInventory+    )+import Darcs.Repository.InternalTypes+    ( AccessType(..)+    , Repository+    , modifyRepoFormat+    , repoCache+    , repoFormat+    , repoLocation+    , unsafeCoerceR+    , unsafeEndTransaction+    , unsafeStartTransaction+    , withRepoDir+    )+import Darcs.Repository.Inventory ( readOneInventory )+import qualified Darcs.Repository.Old as Old ( oldRepoFailMsg )+import Darcs.Repository.PatchIndex+    ( createOrUpdatePatchIndexDisk+    , doesPatchIndexExist+    )+import Darcs.Repository.Paths+    ( indexInvalidPath+    , indexPath+    , tentativeHashedInventoryPath+    )+import Darcs.Repository.Pending ( finalizePending, revertPending )+import Darcs.Repository.Rebase+    ( extractOldStyleRebase+    , finalizeTentativeRebase+    , readTentativeRebase+    , revertTentativeRebase+    , updateRebaseFormat+    , writeTentativeRebase+    )+import Darcs.Repository.State ( updateIndex )+import Darcs.Repository.Unrevert+    ( finalizeTentativeUnrevert+    , revertTentativeUnrevert+    )++import Darcs.Util.Printer ( text, ($$) )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Tree ( Tree )+++-- TODO: rename this and document the transaction protocol (revert/finalize)+-- clearly.+-- |Slightly confusingly named: as well as throwing away any tentative+-- changes, revertRepositoryChanges also re-initialises the tentative state.+-- It's therefore used before makign any changes to the repo.+revertRepositoryChanges :: RepoPatch p+                        => Repository 'RO p wU wR+                        -> IO (Repository 'RW p wU wR)+revertRepositoryChanges r+  | formatHas HashedInventory (repoFormat r) =+      withRepoDir r $ do+        checkIndexIsWritable+          `catchIOError` \e -> fail (unlines ["Cannot write index", show e])+        revertTentativeUnrevert+        revertPending r+        revertTentativeChanges r+        let r' = unsafeCoerceR r+        revertTentativeRebase r'+        return $ unsafeStartTransaction r'+  | otherwise = fail Old.oldRepoFailMsg++-- | Atomically copy the tentative state to the recorded state,+-- thereby committing the tentative changes that were made so far.+-- This includes inventories, pending, rebase, and the index.+finalizeRepositoryChanges :: (RepoPatch p, ApplyState p ~ Tree)+                          => Repository 'RW p wU wR+                          -> DryRun+                          -> IO (Repository 'RO p wU wR)+finalizeRepositoryChanges r dryrun+    | formatHas HashedInventory (repoFormat r) =+        withRepoDir r $ do+          let r' = unsafeEndTransaction $ unsafeCoerceR r+          when (dryrun == NoDryRun) $ do+            debugMessage "Finalizing changes..."+            withSignalsBlocked $ do+                updateRebaseFormat r+                finalizeTentativeRebase+                finalizeTentativeChanges r+                finalizePending r+                finalizeTentativeUnrevert+            debugMessage "Done finalizing changes..."+            ps <- readPatches r'+            pi_exists <- doesPatchIndexExist (repoLocation r')+            when pi_exists $+              createOrUpdatePatchIndexDisk r' ps+              `catchIOError` \e ->+                hPutStrLn stderr $ "Cannot create or update patch index: "++ show e+            updateIndex r'+          return r'+    | otherwise = fail Old.oldRepoFailMsg++-- | Upgrade a possible old-style rebase in progress to the new style.+upgradeOldStyleRebase :: forall p wU wR.+                         (RepoPatch p, ApplyState p ~ Tree)+                      => Repository 'RW p wU wR -> IO ()+upgradeOldStyleRebase repo = do+  PatchSet (ts :: RL (Tagged p) Origin wX) _ <- readTentativePatches repo+  Sealed wps <-+    readOneInventory @(W.WrappedNamed p) (repoCache repo) tentativeHashedInventoryPath+  case extractOldStyleRebase wps of+    Nothing ->+      ePutDocLn $ text "No old-style rebase state found, no upgrade needed."+    Just ((ps :: RL (PatchInfoAnd p) wX wZ) :> Dup r) -> do+      -- low-level call, must not try to update an existing rebase patch,+      -- nor update anything else beside the inventory+      writeTentativeInventory repo (PatchSet ts ps)+      Items old_r <- readTentativeRebase repo+      case old_r of+        NilFL -> do+          writeTentativeRebase (unsafeCoerceR repo) r+          repo' <-+            modifyRepoFormat+              (addToFormat RebaseInProgress_2_16 . removeFromFormat RebaseInProgress)+              repo+          void $ finalizeRepositoryChanges repo' NoDryRun+        _ -> do+          ePutDocLn+            $  "A new-style rebase is already in progress, not overwriting it."+            $$ "This should not have happened! This is the old-style rebase I found"+            $$ "and removed from the repository:"+            $$ showSuspended ForDisplay r++checkIndexIsWritable :: IO ()+checkIndexIsWritable = do+    checkWritable indexInvalidPath+    checkWritable indexPath+  where+    checkWritable path = do+      exists <- doesFileExist path+      touchFile path+      unless exists $ removeFile path+    touchFile path = openBinaryFile path AppendMode >>= hClose
+ src/Darcs/Repository/Traverse.hs view
@@ -0,0 +1,225 @@+module Darcs.Repository.Traverse+    ( cleanRepository+    , cleanPristineDir+    , listInventories+    , listInventoriesRepoDir+    , listPatchesLocalBucketed+    , specialPatches+    ) where++import Darcs.Prelude++import Data.Maybe ( fromJust )+import qualified Data.ByteString.Char8 as BC ( unpack, pack )+import qualified Data.Set as Set++import System.Directory ( listDirectory, withCurrentDirectory )+import System.FilePath.Posix( (</>) )++import Darcs.Repository.Inventory+    ( Inventory(..)+    , PristineHash+    , emptyInventory+    , encodeValidHash+    , inventoryPatchNames+    , parseInventory+    , peekPristineHash+    , skipPristineHash+    )+import Darcs.Repository.InternalTypes+    ( Repository+    , AccessType(..)+    , repoCache+    , withRepoDir+    )+import Darcs.Repository.Paths+    ( tentativeHashedInventory+    , tentativePristinePath+    , inventoriesDir+    , inventoriesDirPath+    , patchesDirPath+    , pristineDirPath+    )+import Darcs.Repository.Prefs ( globalCacheDir )++import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Cache+    ( Cache+    , HashedDir(HashedPristineDir)+    , bucketFolder+    , cleanCachesWithHint+    )+import Darcs.Util.Exception ( ifDoesNotExistError )+import Darcs.Util.Global ( darcsdir, debugMessage )+import Darcs.Util.Lock ( removeFileMayNotExist )+import Darcs.Util.Tree.Hashed ( followPristineHashes )+++cleanRepository :: Repository 'RW p wU wR -> IO ()+cleanRepository r = cleanPristine r >> cleanInventories r >> cleanPatches r++-- | The way patchfiles, inventories, and pristine trees are stored.+-- 'PlainLayout' means all files are in the same directory. 'BucketedLayout'+-- means we create a second level of subdirectories, such that all files whose+-- hash starts with the same two letters are in the same directory.+-- Currently, only the global cache uses 'BucketedLayout' while repositories+-- use the 'PlainLayout'.+data DirLayout = PlainLayout | BucketedLayout++-- | Remove unreferenced entries in the pristine cache.+cleanPristine :: Repository 'RW p wU wR -> IO ()+cleanPristine r = withRepoDir r $ do+    debugMessage "Cleaning out the pristine cache..."+    i <- gzReadFilePS tentativePristinePath+    cleanPristineDir (repoCache r) [peekPristineHash i]++cleanPristineDir :: Cache -> [PristineHash] -> IO ()+cleanPristineDir cache roots = do+    reachable <- set . map encodeValidHash <$> followPristineHashes cache roots+    files <- set <$> listDirectory pristineDirPath+    let to_remove = unset $ files `Set.difference` reachable+    withCurrentDirectory pristineDirPath $+      mapM_ removeFileMayNotExist to_remove+    -- and also clean out any global caches+    debugMessage "Cleaning out any global caches..."+    cleanCachesWithHint cache HashedPristineDir to_remove+  where+    set = Set.fromList . map BC.pack+    unset = map BC.unpack . Set.toList++-- | Set difference between two lists of hashes.+diffHashLists :: [String] -> [String] -> [String]+diffHashLists xs ys = from_set $ (to_set xs) `Set.difference` (to_set ys)+  where+    to_set = Set.fromList . map BC.pack+    from_set = map BC.unpack . Set.toList++-- | Remove unreferenced files in the inventories directory.+cleanInventories :: Repository 'RW p wU wR -> IO ()+cleanInventories _ = do+    debugMessage "Cleaning out inventories..."+    hs <- listInventoriesLocal+    fs <- ifDoesNotExistError [] $ listDirectory inventoriesDirPath+    mapM_ (removeFileMayNotExist . (inventoriesDirPath </>))+        (diffHashLists fs hs)++-- FIXME this is ugly, these files should be directly under _darcs+-- since they are not hashed. And 'unrevert' isn't even a real patch but+-- a patch bundle.++-- | List of special patch files that may exist in the directory+-- _darcs/patches/. We must not clean those.+specialPatches :: [FilePath]+specialPatches = ["unrevert", "pending", "pending.tentative"]++-- | Remove unreferenced files in the patches directory.+cleanPatches :: Repository 'RW p wU wR -> IO ()+cleanPatches _ = do+    debugMessage "Cleaning out patches..."+    hs <- (specialPatches ++) <$> listPatchesLocal PlainLayout darcsdir darcsdir+    fs <- ifDoesNotExistError [] (listDirectory patchesDirPath)+    mapM_ (removeFileMayNotExist . (patchesDirPath </>)) (diffHashLists fs hs)++-- | Return a list of the inventories hashes.+-- The first argument can be readInventory or readInventoryLocal.+-- The second argument specifies whether the files are expected+-- to be stored in plain or in bucketed format.+-- The third argument is the directory of the parent inventory files.+-- The fourth argument is the directory of the head inventory file.+listInventoriesWith+  :: (FilePath -> IO Inventory)+  -> DirLayout+  -> String -> String -> IO [String]+listInventoriesWith readInv dirformat baseDir startDir = do+    mbStartingWithInv <- getStartingWithHash startDir tentativeHashedInventory+    followStartingWiths mbStartingWithInv+  where+    getStartingWithHash dir file = inventoryParent <$> readInv (dir </> file)++    invDir = baseDir </> inventoriesDir+    nextDir dir = case dirformat of+        BucketedLayout -> invDir </> bucketFolder dir+        PlainLayout -> invDir++    followStartingWiths Nothing = return []+    followStartingWiths (Just hash) = do+        let startingWith = encodeValidHash hash+        mbNextInv <- getStartingWithHash (nextDir startingWith) startingWith+        (startingWith :) <$> followStartingWiths mbNextInv++-- | Return a list of the inventories hashes.+-- This function attempts to retrieve missing inventory files from the cache.+listInventories :: IO [String]+listInventories =+    listInventoriesWith readInventory PlainLayout darcsdir darcsdir++-- | Return inventories hashes by following the head inventory.+-- This function does not attempt to retrieve missing inventory files.+listInventoriesLocal :: IO [String]+listInventoriesLocal =+    listInventoriesWith readInventoryLocal PlainLayout darcsdir darcsdir++-- | Return a list of the inventories hashes.+-- The argument @repoDir@ is the directory of the repository from which+-- we are going to read the head inventory file.+-- The rest of hashed files are read from the global cache.+listInventoriesRepoDir :: String -> IO [String]+listInventoriesRepoDir repoDir = do+    gCacheDir' <- globalCacheDir+    let gCacheInvDir = fromJust gCacheDir'+    listInventoriesWith+        readInventoryLocal+        BucketedLayout+        gCacheInvDir+        (repoDir </> darcsdir)++-- | Return a list of the patch filenames, extracted from inventory+-- files, by starting with the head inventory and then following the+-- chain of parent inventories.+--+-- This function does not attempt to download missing inventory files.+--+-- * The first argument specifies whether the files are expected+--   to be stored in plain or in bucketed format.+-- * The second argument is the directory of the parent inventory.+-- * The third argument is the directory of the head inventory.+listPatchesLocal :: DirLayout -> String -> String -> IO [String]+listPatchesLocal dirformat baseDir startDir = do+  inventory <- readInventory (startDir </> tentativeHashedInventory)+  followStartingWiths+    (inventoryParent inventory)+    (inventoryPatchNames inventory)+  where+    invDir = baseDir </> inventoriesDir+    nextDir dir =+      case dirformat of+        BucketedLayout -> invDir </> bucketFolder dir+        PlainLayout -> invDir+    followStartingWiths Nothing patches = return patches+    followStartingWiths (Just hash) patches = do+      let startingWith = encodeValidHash hash+      inv <- readInventoryLocal (nextDir startingWith </> startingWith)+      (patches ++) <$>+        followStartingWiths (inventoryParent inv) (inventoryPatchNames inv)++-- |listPatchesLocalBucketed is similar to listPatchesLocal, but+-- it read the inventory directory under @darcsDir@ in bucketed format.+listPatchesLocalBucketed :: String -> String -> IO [String]+listPatchesLocalBucketed = listPatchesLocal BucketedLayout++-- | Read the given inventory file if it exist, otherwise return an empty+-- inventory. Used when we expect that some inventory files may be missing.+-- Still fails with an error message if file cannot be parsed.+readInventoryLocal :: FilePath -> IO Inventory+readInventoryLocal path =+  ifDoesNotExistError emptyInventory $ readInventory path++-- | Read an inventory from a file. Fails with an error message if+-- file is not there or cannot be parsed.+readInventory :: FilePath -> IO Inventory+readInventory path = do+  -- FIXME we should check the hash (if this is a hashed file)+  inv <- skipPristineHash <$> gzReadFilePS path+  case parseInventory inv of+    Right r -> return r+    Left e -> fail $ unlines [unwords ["parse error in file", path], e]
+ src/Darcs/Repository/Unrevert.hs view
@@ -0,0 +1,112 @@+module Darcs.Repository.Unrevert+    ( finalizeTentativeUnrevert+    , revertTentativeUnrevert+    , writeUnrevert+    , readUnrevert+    , removeFromUnrevertContext+    ) where++import Darcs.Prelude++import Darcs.Patch ( PrimOf, RepoPatch, commuteRL )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Bundle ( interpretBundle, makeBundle, parseBundle )+import Darcs.Patch.Depends ( patchSetMerge, removeFromPatchSet )+import Darcs.Patch.Info ( patchinfo )+import Darcs.Patch.Named ( infopatch )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )+import Darcs.Patch.Set ( Origin, PatchSet, SealedPatchSet )+import Darcs.Patch.Witnesses.Ordered+    ( (:/\:)(..)+    , (:>)(..)+    , FL(..)+    , lengthFL+    , reverseFL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Repository.Paths ( tentativeUnrevertPath, unrevertPath )+import Darcs.Util.Exception ( catchDoesNotExistError, ifDoesNotExistError )+import Darcs.Util.Global ( debugMessage )+import Darcs.Util.IsoDate ( getIsoDateTime )+import Darcs.Util.Lock ( readBinFile, removeFileMayNotExist, writeDocBinFile )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.Tree ( Tree )++import System.Directory ( copyFile, renameFile )+import System.Exit ( exitSuccess )++finalizeTentativeUnrevert :: IO ()+finalizeTentativeUnrevert =+  renameFile tentativeUnrevertPath unrevertPath `catchDoesNotExistError`+    removeFileMayNotExist unrevertPath++revertTentativeUnrevert :: IO ()+revertTentativeUnrevert =+  copyFile unrevertPath tentativeUnrevertPath `catchDoesNotExistError`+    removeFileMayNotExist tentativeUnrevertPath++writeUnrevert :: (RepoPatch p, ApplyState p ~ Tree)+              => PatchSet p Origin wR+              -> FL (PrimOf p) wR wX+              -> IO ()+writeUnrevert _ NilFL = removeFileMayNotExist tentativeUnrevertPath+writeUnrevert recorded ps = do+  date <- getIsoDateTime+  info <- patchinfo date "unrevert" "anon" []+  let np = infopatch info ps+  bundle <- makeBundle Nothing recorded (np :>: NilFL)+  writeDocBinFile tentativeUnrevertPath bundle++readUnrevert :: RepoPatch p+             => PatchSet p Origin wR+             -> IO (SealedPatchSet p Origin)+readUnrevert us = do+  pf <- readBinFile tentativeUnrevertPath+        `catchDoesNotExistError` fail "There's nothing to unrevert!"+  case parseBundle pf of+      Right (Sealed bundle) -> do+        case interpretBundle us bundle of+          Left msg -> fail msg+          Right ps -> return (Sealed ps)+      Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err++removeFromUnrevertContext :: forall p wR wX. (RepoPatch p, ApplyState p ~ Tree)+                          => PatchSet p Origin wR+                          -> FL (PatchInfoAnd p) wX wR+                          -> IO ()+removeFromUnrevertContext _ NilFL = return () -- nothing to do+removeFromUnrevertContext ref ps =+  ifDoesNotExistError () $ do+    debugMessage "Reading the unrevert bundle..."+    Sealed bundle <- unrevert_patch_bundle+    debugMessage "Adjusting the context of the unrevert changes..."+    debugMessage $+      "Removing " ++ show (lengthFL ps) ++ " patches in removeFromUnrevertContext"+    Sealed bundle_ps <- bundle_to_patchset bundle+    case patchSetMerge ref bundle_ps of+      (unrevert :>: NilFL) :/\: _ -> do+        case commuteRL (reverseFL ps :> unrevert) of+          Nothing -> unrevert_impossible+          Just (unrevert' :> _) ->+            case removeFromPatchSet ps ref of+              Nothing -> unrevert_impossible+              Just common -> do+                debugMessage "Have now found the new context..."+                bundle' <- makeBundle Nothing common (hopefully unrevert' :>: NilFL)+                writeDocBinFile tentativeUnrevertPath bundle'+      _ -> return () -- TODO I guess this should be an error call+    debugMessage "Done adjusting the context of the unrevert changes"+  where+    unrevert_impossible = do+      confirmed <-+        promptYorn "This operation will make unrevert impossible!\nProceed?"+      if confirmed+        then removeFileMayNotExist tentativeUnrevertPath+        else putStrLn "Cancelled." >> exitSuccess+    unrevert_patch_bundle = do+      pf <- readBinFile tentativeUnrevertPath+      case parseBundle pf of+        Right foo -> return foo+        Left err -> fail $ "Couldn't parse unrevert patch:\n" ++ err+    bundle_to_patchset bundle =+      either fail (return . Sealed) $ interpretBundle ref bundle
+ src/Darcs/Repository/Working.hs view
@@ -0,0 +1,81 @@+module Darcs.Repository.Working+    ( applyToWorking+    , setAllScriptsExecutable+    , setScriptsExecutablePatches+    )  where++import Control.Monad ( when, unless, filterM )+import System.Directory ( doesFileExist, withCurrentDirectory )+import System.IO.Error ( catchIOError )++import qualified Data.ByteString as B ( readFile+                                      , isPrefixOf+                                      )+import qualified Data.ByteString.Char8 as BC (pack)++import Darcs.Prelude++import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Workaround ( setExecutable )+import Darcs.Util.Tree ( Tree )+import Darcs.Util.Path ( anchorPath )+import qualified Darcs.Util.Tree as Tree++import Darcs.Patch ( RepoPatch, PrimOf, apply, listTouchedFiles )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..) )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Progress ( progressFL )++import Darcs.Repository.Format ( RepoProperty( NoWorkingDir ), formatHas )+import Darcs.Repository.Flags  ( Verbosity(..) )+import Darcs.Repository.InternalTypes+    ( Repository+    , repoFormat+    , repoLocation+    , unsafeCoerceU )+import Darcs.Repository.ApplyPatches ( runTolerantly, runSilently )+import Darcs.Repository.State ( readWorking, TreeFilter(..)  )++applyToWorking :: (ApplyState p ~ Tree, RepoPatch p)+               => Repository rt p wU wR+               -> Verbosity+               -> FL (PrimOf p) wU wY+               -> IO (Repository rt p wY wR)+applyToWorking repo verb ps =+  do+    unless (formatHas NoWorkingDir (repoFormat repo)) $ do+      debugMessage "Applying changes to working tree"+      withCurrentDirectory (repoLocation repo) $+        let ps' = progressFL "Applying patches to working" ps in+        if verb == Quiet+          then runSilently $ apply ps'+          else runTolerantly $ apply ps'+    return $ unsafeCoerceU repo+  `catchIOError` (\e -> fail $ "Error applying changes to working tree:\n" ++ show e)++-- | Set the given paths executable if they are scripts.+--   A script is any file that starts with the bytes '#!'.+--   This is used for --set-scripts-executable.+setScriptsExecutable_ :: [FilePath] -> IO ()+setScriptsExecutable_ paths = do+    debugMessage "Making scripts executable"+    mapM_ setExecutableIfScript paths++setAllScriptsExecutable :: IO ()+setAllScriptsExecutable = do+    tree <- readWorking (TreeFilter id)+    setScriptsExecutable_ [anchorPath "." p | (p, Tree.File _) <- Tree.list tree]++setScriptsExecutablePatches :: PatchInspect p => p wX wY -> IO ()+setScriptsExecutablePatches pw = do+    paths <- filterM doesFileExist $ map (anchorPath ".") $ listTouchedFiles pw+    setScriptsExecutable_ paths++setExecutableIfScript :: FilePath -> IO ()+setExecutableIfScript f = do+    contents <- B.readFile f+    when (BC.pack "#!" `B.isPrefixOf` contents) $ do+        debugMessage ("Making executable: " ++ f)+        setExecutable f True
− src/Darcs/Resolution.hs 
@@ -1,164 +0,0 @@---  Copyright (C) 2003,2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Resolution ( standardResolution,-                          externalResolution,-                          patchsetConflictResolutions,-                        ) where--import System.FilePath.Posix ( (</>) )-import System.Exit ( ExitCode( ExitSuccess ) )-import System.Directory ( setCurrentDirectory, getCurrentDirectory )-import Data.List ( zip4 )-import Control.Monad ( when )--import Darcs.Diff( treeDiff )-import Darcs.Patch ( PrimOf, PrimPatch, RepoPatch, joinPatches, resolveConflicts,-                     effectOnFilePaths, patchcontents,-                     invert, listConflictedFiles, commute, applyToTree, fromPrim )-import Darcs.Patch.Apply( ApplyState )-import Darcs.RepoPath ( toFilePath )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (+>+),-                             mapFL_FL, reverseRL )--import CommandLine ( parseCmd )-import Darcs.Patch.PatchInfoAnd ( hopefully )-import Darcs.Utils ( askEnter, filterFilePaths )-import Darcs.Patch.Set ( PatchSet(..) )-#ifdef GADT_WITNESSES-import Darcs.Patch.Set ( Origin )-#endif-import Darcs.Witnesses.Sealed ( Sealed(..), unFreeLeft )-import Darcs.Repository.Prefs ( filetypeFunction )-import Exec ( exec, Redirect(..) )-import Darcs.Lock ( withTempDir )-import Darcs.External ( cloneTree )-import Darcs.Flags ( DarcsFlag, wantGuiPause )--import qualified Storage.Hashed.Tree as Tree-import Storage.Hashed ( writePlainTree, readPlainTree )----import Darcs.ColorPrinter ( traceDoc )---import Printer ( greenText, ($$), Doc )---import Darcs.Patch ( showPatch )--standardResolution :: RepoPatch p => FL p C(x y) -> Sealed (FL (PrimOf p) C(y))-standardResolution p = mergeList $ map head $ resolveConflicts p--mergeList :: forall prim C(x) . PrimPatch prim => [Sealed (FL prim C(x))] -> Sealed (FL prim C(x))-mergeList patches = doml NilFL patches-    where doml :: FL prim C(x y) -> [Sealed (FL prim C(x))] -> Sealed (FL prim C(x))-          doml mp (Sealed p:ps) =-              case commute (invert p :> mp) of-              Just (mp' :> _) -> doml (p +>+ mp') ps-              Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.-          doml mp [] = Sealed mp--externalResolution :: forall p C(x y z a). (RepoPatch p, ApplyState p ~ Tree.Tree)-                   => Tree.Tree IO-                   -> String  -- ^ external merge tool command-                   -> [DarcsFlag] -- ^ command line arguments-                   -> FL (PrimOf p) C(x y)-                   -> FL (PrimOf p) C(x z)-                   -> FL p C(y a)-                   -> IO (Sealed (FL (PrimOf p) C(a)))-externalResolution s1 c opts p1_prim p2_prim pmerged = do- -- TODO: remove the following two once we can rely on GHC 7.2 / superclass equality- let p1 :: FL p C(x y) = mapFL_FL fromPrim p1_prim-     p2 :: FL p C(x z) = mapFL_FL fromPrim p2_prim- sa <- applyToTree (invert p1) s1- sm <- applyToTree pmerged s1- s2 <- applyToTree p2 sa- let effectOnFPs ps fps = effectOnFilePaths ps fps-     nms = listConflictedFiles pmerged-     nas = effectOnFPs (invert pmerged) nms-     n1s = effectOnFPs p1 nas-     n2s = effectOnFPs p2 nas-     ns = zip4 nas n1s n2s nms-     write_files tree fs = writePlainTree (Tree.filter (filterFilePaths fs) tree) "."-  in do-   former_dir <- getCurrentDirectory-   withTempDir "version1" $ \absd1 -> do-     let d1 = toFilePath absd1-     write_files s1 n1s-     setCurrentDirectory former_dir-     withTempDir "ancestor" $ \absda -> do-       let da = toFilePath absda-       write_files sa nas-       setCurrentDirectory former_dir-       withTempDir "merged" $ \absdm -> do-         let dm = toFilePath absdm-         write_files sm nms-         setCurrentDirectory former_dir-         withTempDir "cleanmerged" $ \absdc -> do-           let dc = toFilePath absdc-           cloneTree dm "."-           setCurrentDirectory former_dir-           withTempDir "version2" $ \absd2 -> do-             let d2 = toFilePath absd2-             write_files s2 n2s-             mapM_ (externallyResolveFile c opts da d1 d2 dm) ns-             sc <- readPlainTree dc-             sfixed <- readPlainTree dm-             ftf <- filetypeFunction-             unFreeLeft `fmap` treeDiff ftf sc sfixed--externallyResolveFile :: String -- ^ external merge tool command-                      -> [DarcsFlag] -- ^ command line arguments-                      -> String -- ^ path to merge base-                      -> String -- ^ path to side 1 of the merge-                      -> String -- ^ path to side 2 of the merge-                      -> String -- ^ path where resolved content should go-                      -> (FilePath, FilePath, FilePath, FilePath)-                      -> IO ()-externallyResolveFile c opts da d1 d2 dm (fa, f1, f2, fm) = do-    putStrLn $ "Merging file "++fm++" by hand."-    ec <- run c [('1', d1</>f1), ('2', d2</>f2), ('a', da</>fa), ('o', dm</>fm), ('%', "%")]-    when (ec /= ExitSuccess) $-         putStrLn $ "External merge command exited with " ++ show ec-    when (wantGuiPause opts) $-        askEnter "Hit return to move on, ^C to abort the whole operation..."--run :: String -> [(Char,String)] -> IO ExitCode-run c replacements =-    case parseCmd replacements c of-    Left err     -> fail $ show err-    Right (c2,_) -> rr c2-    where rr (command:args) = do putStrLn $ "Running command '" ++-                                            unwords (command:args) ++ "'"-                                 exec command args (Null,Null,Null)-          rr [] = return ExitSuccess--patchsetConflictResolutions :: RepoPatch p => PatchSet p C(Origin x) -> Sealed (FL (PrimOf p) C(x))-patchsetConflictResolutions (PatchSet NilRL _) = Sealed NilFL-patchsetConflictResolutions (PatchSet xs _)-    = --traceDoc (greenText "looking at resolutions" $$-      --         (sh $ resolveConflicts $ joinPatches $-      --              mapFL_FL (patchcontents . hopefully) $ reverseRL xs )) $-      mergeList $ map head $ resolveConflicts $ joinPatches $-      mapFL_FL (patchcontents . hopefully) $ reverseRL xs-    --where sh :: [[Sealed (FL Prim)]] -> Doc-    --      sh [] = greenText "no more conflicts"-    --      sh (x:ps) = greenText "one conflict" $$ sh1 x $$ sh ps-    --      sh1 :: [Sealed (FL Prim)] -> Doc-    --      sh1 [] = greenText "end of unravellings"-    --      sh1 (Sealed x:ps) = greenText "one unravelling:" $$ showPatch x $$-    --                          sh1 ps
− src/Darcs/RunCommand.hs 
@@ -1,192 +0,0 @@--- Copyright (C) 2002,2003,2005 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-module Darcs.RunCommand ( runTheCommand ) where--import Control.Monad ( unless, when )-import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),-                              OptDescr( Option ),-                              getOpt )-import System.Exit ( ExitCode ( ExitSuccess ), exitWith )--import Darcs.Arguments ( DarcsFlag(..),-                         help,-                         fixUrlFlag,-                         optionFromDarcsOption,-                         listOptions, nubOptions )-import Darcs.ArgumentDefaults ( getDefaultFlags )-import Darcs.Commands ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub ),-                        CommandControl,-                        DarcsCommand,-                        commandName,-                        commandCommand,-                        commandPrereq,-                        commandExtraArgHelp,-                        commandExtraArgs,-                        commandArgdefaults,-                        commandGetArgPossibilities,-                        commandOptions, commandAlloptions,-                        disambiguateCommands,-                        getCommandHelp, getCommandMiniHelp,-                        getSubcommands,-                        extractCommands,-                        superName,-                        subusage, chompNewline )-import Darcs.Commands.GZCRCs ( doCRCWarnings )-import Darcs.Global ( atexit )-import Darcs.External ( viewDoc )-import Darcs.Global ( setDebugMode, setTimingsMode )-import Darcs.Match ( checkMatchSyntax )-import Progress ( setProgressMode )-import Darcs.RepoPath ( getCurrentDirectory )-import Darcs.Test ( runPosthook, runPrehook )-import Darcs.Utils ( formatPath )-import Data.List ( intercalate )-import Printer ( text )-import URL ( setDebugHTTP, disableHTTPPipelining )--runTheCommand :: [CommandControl] -> String -> [String] -> IO ()-runTheCommand commandControlList cmd args =-  either fail rtc $ disambiguateCommands commandControlList cmd args- where-  rtc (CommandOnly c, as)       = runCommand Nothing c  as-  rtc (SuperCommandOnly c,  as) = runRawSupercommand c as-  rtc (SuperCommandSub c s, as) = runCommand (Just c) s as---- This is the actual heavy lifter code, which is responsible for parsing the--- arguments and then running the command itself.--runCommand :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO ()--runCommand _ _ args -- Check for "dangerous" typoes...-    | "-all" `elem` args = -- -all indicates --all --look-for-adds!-        fail "Are you sure you didn't mean --all rather than -all?"-runCommand msuper cmd args = do-   cwd <- getCurrentDirectory-   let options = opts1 ++ opts2-       (opts1, opts2) = commandOptions cwd cmd-   case getOpt Permute-             (optionFromDarcsOption cwd listOptions++options) args of-    (opts,extra,[])-      | Help `elem` opts -> viewDoc $ text $ getCommandHelp msuper cmd-      | ListOptions `elem` opts  -> do-           setProgressMode False--- Warning:  A do-notation statement discarded a result of type Either String ().-           _ <- commandPrereq cmd opts-           file_args <- commandGetArgPossibilities cmd-           putStrLn $ unlines $ getOptionsOptions (opts1++opts2) : file_args-      | otherwise -> considerRunning msuper cmd (addVerboseIfDebug opts) extra-    (_,_,ermsgs) -> fail $ chompNewline(unlines ermsgs)-    where addVerboseIfDebug opts | DebugVerbose `elem` opts = Debug:Verbose:opts-                                 | otherwise = opts--considerRunning :: Maybe DarcsCommand -> DarcsCommand-                 -> [DarcsFlag] -> [String] -> IO ()-considerRunning msuper cmd opts old_extra = do- cwd <- getCurrentDirectory- location <- commandPrereq cmd opts- case location of-   Left complaint -> fail $ "Unable to " ++-                     formatPath ("darcs " ++ superName msuper ++ commandName cmd) ++-                     " here.\n\n" ++ complaint-   Right () -> do-    specops <- nubopts `fmap` addCommandDefaults cmd opts-    extra <- (commandArgdefaults cmd) specops cwd old_extra-    when (Disable `elem` specops) $-      fail $ "Command "++commandName cmd++" disabled with --disable option!"-    case extraArgumentsError extra cmd msuper of-        Nothing     -> runWithHooks specops extra-        Just msg    -> fail msg-       where nubopts = nubOptions (uncurry (++) $ commandAlloptions cmd)-             runWithHooks os ex = do-               here <- getCurrentDirectory-               checkMatchSyntax os-               -- set any global variables-               when (Timings `elem` os) setTimingsMode-               when (Debug `elem` os) setDebugMode-               when (DebugHTTP `elem` os) setDebugHTTP-               when (Quiet `elem` os) $ setProgressMode False-               when (NoHTTPPipelining `elem` os) $ disableHTTPPipelining-               unless (Quiet `elem` os) $ atexit $ doCRCWarnings (Verbose `elem` os)-               -- actually run the command and its hooks-               preHookExitCode <- runPrehook os here-               if preHookExitCode /= ExitSuccess-                  then exitWith preHookExitCode-                  else do let fixFlag = FixFilePath here cwd-                          fixedOs <- mapM (fixUrlFlag [fixFlag]) os-                          (commandCommand cmd) (fixFlag : fixedOs) ex-                          postHookExitCode <- runPosthook os here-                          exitWith postHookExitCode---- Checks if the number of extra arguments matches the number of extra--- arguments supported by the command as specified in `commandExtraArgs`.--- Extra arguments are arguments that follow the command but aren't--- considered a flag. In `darcs push xyz`, xyz would be an extra argument.-extraArgumentsError :: [String]             -- extra commands provided by user-                    -> DarcsCommand-                    -> Maybe DarcsCommand-                    -> Maybe String-extraArgumentsError extra cmd msuper-    | extraArgsCmd < 0 = Nothing-    | extraArgsInput > extraArgsCmd = Just badArg-    | extraArgsInput < extraArgsCmd = Just missingArg-    | otherwise = Nothing-        where-            extraArgsInput = length extra-            extraArgsCmd = commandExtraArgs cmd-            badArg     = "Bad argument: `" ++ unwords extra ++-                         "'\n" ++ getCommandMiniHelp msuper cmd-            missingArg = "Missing argument:  " ++ nthArg (length extra + 1) ++-                         "\n" ++ getCommandMiniHelp msuper cmd-            nthArg n       = nthOf n (commandExtraArgHelp cmd)-            nthOf 1 (h:_)  = h-            nthOf n (_:hs) = nthOf (n-1) hs-            nthOf _ []     = "UNDOCUMENTED"--addCommandDefaults :: DarcsCommand -> [DarcsFlag] -> IO [DarcsFlag]-addCommandDefaults cmd already = do-  let (opts1, opts2) = commandAlloptions cmd-  defaults <- getDefaultFlags (commandName cmd) (opts1 ++ opts2) already-  return $ already ++ defaults--getOptionsOptions :: [OptDescr DarcsFlag] -> String-getOptionsOptions = intercalate "\n" . concatMap goo- where-  goo (Option _ os _ _) = map ("--"++) os--runRawSupercommand :: DarcsCommand -> [String] -> IO ()-runRawSupercommand super [] =-    fail $ "Command '"++ commandName super ++"' requires subcommand!\n\n"-             ++ subusage super-runRawSupercommand super args = do-  cwd <- getCurrentDirectory-  case getOpt RequireOrder-             (optionFromDarcsOption cwd help++-              optionFromDarcsOption cwd listOptions) args of-    (opts,_,[])-      | Help `elem` opts ->-            viewDoc $ text $ getCommandHelp Nothing super-      | ListOptions `elem` opts -> do-            putStrLn "--help"-            mapM_ (putStrLn . commandName) (extractCommands $ getSubcommands super)-      | otherwise ->-            if Disable `elem` opts-            then fail $ "Command " ++ (commandName super) ++-                      " disabled with --disable option!"-            else fail $ "Invalid subcommand!\n\n" ++ subusage super-    (_,_,ermsgs) -> fail $ chompNewline(unlines ermsgs)
− src/Darcs/SelectChanges.hs 
@@ -1,904 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, ForeignFunctionInterface #-}--#include "gadts.h"--module Darcs.SelectChanges (selectChanges, WhichChanges(..), viewChanges, withSelectedPatchFromRepo,-                            filterOutConflicts, runSelection, selectionContextPrim,-                            selectionContext-                     ) where-import Data.List ( intersperse )-import Data.Maybe ( isJust, isNothing )-import Data.Char ( toUpper )-import Control.Monad ( when, (>=>) )-import Control.Monad.Identity ( Identity(..) )-import Control.Monad.Trans ( liftIO )-import Control.Monad.Reader ( ReaderT, Reader, asks, runReader, runReaderT )-import Control.Monad.State ( StateT, modify, gets, runStateT, execStateT )-import System.Exit ( exitWith, ExitCode(ExitSuccess) )--import English ( Noun(..), englishNum  )-import Darcs.Arguments ( showFriendly )-import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, n2pia )-import Darcs.Repository ( Repository, readRepo, unrecordedChanges )-import Darcs.Patch ( RepoPatch, Patchy, PrimPatch, summary,-                     invert, listTouchedFiles,-                     commuteFLorComplain, fromPrims, anonymous )-import Darcs.Patch.Set ( newset2RL )-import Darcs.Patch.Apply( ApplyState )-import qualified Darcs.Patch ( thing, things )-import Darcs.Patch.Split ( Splitter(..) )-import Darcs.Witnesses.Ordered ( FL(..), RL(..), (:>)(..), (:||:)(..),-                       (+>+), lengthFL, mapFL_FL,-                       spanFL, spanFL_M, reverseFL, (+<+), mapFL, filterFL )-import Darcs.Witnesses.WZipper( FZipper(..), left, right-                              , rightmost, nullFZ-                              , toEnd, toStart)-import Darcs.Patch.Choices ( PatchChoices, patchChoices,-                             patchChoicesTpsSub,-                             forceFirst, forceLast, makeUncertain, tag,-                      getChoices, refineChoices,-                      separateFirstFromMiddleLast,-                      patchSlot',-                      selectAllMiddles,-                      forceMatchingLast,-                      forceMatchingFirst, makeEverythingLater,-                      makeEverythingSooner,-                      TaggedPatch, tpPatch, Slot(..),-                      substitute-                    )-import Darcs.Patch.Permutations ( partitionConflictingFL, selfCommuter, commuterIdRL )-import qualified Darcs.Patch.TouchesFiles as TouchesFiles-import Darcs.PrintPatch ( printFriendly, printPatch, printPatchPager )-import Darcs.Match ( haveNonrangeMatch, matchAPatch, matchAPatchread )-import Darcs.Flags ( DarcsFlag( Summary, DontGrabDeps, Verbose, DontPromptForDependencies-                              , SkipConflicts )-                   , isInteractive, UseIndex(..), ScanKnown(..) )-import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal, seal2, unseal2, Sealed(..), Sealed2(..) )-import Darcs.Utils ( askUser, promptChar, PromptConfig(..) )-import Darcs.Lock ( editText )-import Printer ( prefix, putDocLn )-import Storage.Hashed.Tree( Tree )---- | When asking about patches, we either ask about them in--- oldest-first or newest first (with respect to the current ordering--- of the repository), and we either want an initial segment or a--- final segment of the poset of patches.------ @First@: ask for an initial--- segment, first patches first (default for all pull-like commands)------ @FirstReversed@: ask for an initial segment, last patches first--- (used to ask about dependencies in record, and for pull-like--- commands with the @--reverse@ flag).------ @LastReversed@: ask for a final segment, last patches first. (default--- for unpull-like commands, except for selecting *primitive* patches in--- rollback)------ @Last@: ask for a final segment, first patches first. (used for selecting--- primitive patches in rollback, and for unpull-like commands with the--- @--reverse@ flag-data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show)---- | A @WhichChanges@ is backwards if the order in which patches are presented--- is the opposite of the order of dependencies for that operation.-backward :: WhichChanges -> Bool-backward w = w == Last || w == FirstReversed---- | The type of the function we use to filter patches when @--match@ is--- given.-type MatchCriterion p = WhichChanges -> [DarcsFlag] -> Sealed2 p -> Bool---- | A @PatchSelectionContext@ contains all the static settings for selecting--- patches. See "PatchSelectionM"-data PatchSelectionContext p = PSC { opts :: [DarcsFlag]-                                   , splitter :: Maybe (Splitter p)-                                   , files :: Maybe [FilePath]-                                   , matchCriterion :: MatchCriterion p-                                   , jobname :: String-                                   , pristine :: Maybe (Tree IO)}---- | A 'PatchSelectionContext' for selecting 'Prim' patches.-selectionContextPrim ::  PrimPatch prim => String -> [DarcsFlag] -> Maybe (Splitter prim)-                 -> Maybe [FilePath] -> Maybe (Tree IO) -> PatchSelectionContext prim-selectionContextPrim jn o spl fs p =- PSC { opts = o-     , splitter = spl-     , files = fs-     , matchCriterion = triv-     , jobname = jn-     , pristine = p }---- | A 'PatchSelectionContext' for selecting full patches ('PatchInfoAnd' patches)-selectionContext :: (RepoPatch p) => String -> [DarcsFlag] -> Maybe (Splitter (PatchInfoAnd p))-                 -> Maybe [FilePath] -> PatchSelectionContext (PatchInfoAnd p)-selectionContext jn o spl fs =- PSC { opts = o-     , splitter = spl-     , files = fs-     , matchCriterion = iswanted-     , jobname = jn-     , pristine = Nothing }---- | The dynamic parameters for interactive selection of patches.-data InteractiveSelectionContext p C(x y) = ISC { total :: Int-                                                  -- ^ total number of patches-                                                , current :: Int-                                                  -- ^ number of already-seen patches-                                                , tps :: FZipper (TaggedPatch p) C(x y)-                                                  -- ^ the patches we offer-                                                , choices :: PatchChoices p C(x y)-                                                  -- ^ the user's choices-                                                }--type PatchSelectionM p a = ReaderT (PatchSelectionContext p) a--type InteractiveSelectionM p C(x y) a =-    StateT (InteractiveSelectionContext p C(x y))-           (PatchSelectionM p IO) a--type PatchSelection p C(x y) =-        PatchSelectionM p IO ((FL p :> FL p) C(x y))---- Common match criteria---- | For commands without @--match@, 'triv' matches all patches-triv :: MatchCriterion p-triv = \ _ _ _ -> True---- | 'iswanted' selects patches according to the @--match@ flag in--- opts'-iswanted :: Patchy p => MatchCriterion (PatchInfoAnd p)-iswanted whch opts' =-    unseal2 (iw whch)-        where-          iw First = matchAPatch opts' . hopefully-          iw Last = matchAPatch opts' . hopefully-          iw LastReversed = matchAPatch opts' . hopefully . invert-          iw FirstReversed = matchAPatch opts' . hopefully . invert--liftR :: Monad m => Reader r a -> ReaderT r m a-liftR = asks . runReader---- | runs a 'PatchSelection' action in the given 'PatchSelectionContext'.-runSelection :: (Patchy p) => PatchSelection p C(x y) -> PatchSelectionContext p-             -> IO ((FL p :> FL p) C(x y))-runSelection = runReaderT---- | Select patches from a @FL@.-selectChanges :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) =>-                WhichChanges -> FL p C(x y)-                             -> PatchSelection p C(x y)-selectChanges First = sc1 First-selectChanges Last = sc1 Last-selectChanges FirstReversed = return . invert-                              >=> sc1 FirstReversed-                              >=> return . invertC--selectChanges LastReversed = return . invert-                             >=> sc1 LastReversed-                             >=> return . invertC--sc1 :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) =>-                WhichChanges -> FL p C(x y)-                             -> PatchSelection p C(x y)-sc1 whch =-    ((liftR . patchesToConsider whch)-     >=> realSelectChanges whch-     >=> return . selectedPatches whch-     >=> (liftR . canonizeAfterSplitter))---- | inverses the choices that have been made-invertC :: (Patchy p) => (FL p :> FL p) C(x y) -> (FL p :> FL p) C(y x)-invertC (a :> b) = (invert b) :> (invert a)---- | Shows the patch that is actually being selected the way the user--- should see it.-repr :: (Patchy p) => WhichChanges -> Sealed2 p -> Sealed2 p-repr First (Sealed2 p) = Sealed2 p-repr LastReversed (Sealed2 p) = Sealed2 (invert p)-repr Last (Sealed2 p) = Sealed2 p-repr FirstReversed (Sealed2 p) = Sealed2 (invert p)---- | The equivalent of 'selectChanges' for the @darcs changes@ command-viewChanges :: (Patchy p, ApplyState p ~ Tree) => [DarcsFlag] -> [Sealed2 p] -> IO ()-viewChanges opts' ps = textView opts' Nothing 0 [] ps---- | The type of the answers to a "shall I [wiggle] that [foo]?" question--- They are found in a [[KeyPress]] bunch, each list representing a set of--- answers which belong together-data KeyPress = KeyPress { kp     :: Char-                           , kpHelp :: String }---- | Generates the help for a set of basic and advanced 'KeyPress' groups.-helpFor :: String -> [[KeyPress]] -> [[KeyPress]] -> String-helpFor jn basicKeypresses advancedKeyPresses =-  unlines $ [ "How to use "++jn++":" ]-            ++ (concat $ intersperse [""] $ map (map help) keypresses)-            ++ [ ""-               , "?: show this help"-               , ""-               , "<Space>: accept the current default (which is capitalized)"-               ]-  where help i = kp i:(": "++kpHelp i)-        keypresses = basicKeypresses ++ advancedKeyPresses---- | The keys used by a list of 'keyPress' groups.-keysFor :: [[KeyPress]] -> [Char]-keysFor = concatMap (map kp)---- | The function for selecting a patch to amend record. Read at your own risks.-withSelectedPatchFromRepo ::-       forall p C(r u t). (RepoPatch p, ApplyState p ~ Tree)-    => String   -- name of calling command (always "amend" as of now)-    -> Repository p C(r u t)-    -> [DarcsFlag]-    -> (FORALL(a) (FL (PatchInfoAnd p) :> PatchInfoAnd p) C(a r) -> IO ())-    -> IO ()-withSelectedPatchFromRepo jn repository o job = do-    patchSet <- readRepo repository-    sp <- wspfr jn (matchAPatchread o) (newset2RL patchSet) NilFL-    case sp of-        Just (FlippedSeal (skipped :> selected')) -> job (skipped :> selected')-        Nothing ->-            putStrLn $ "Cancelling " ++ jn ++ " since no patch was selected."---- | This ensures that the selected patch commutes freely with the skipped--- patches, including pending and also that the skipped sequences has an--- ending context that matches the recorded state, z, of the repository.-wspfr :: (RepoPatch p, ApplyState p ~ Tree)-      => String-      -> (FORALL(a b) (PatchInfoAnd p) C(a b) -> Bool)-      -> RL (PatchInfoAnd p) C(x y)-      -> FL (PatchInfoAnd p) C(y u)-      -> IO (Maybe (FlippedSeal (FL (PatchInfoAnd p) :> (PatchInfoAnd p)) C(u)))-wspfr _ _ NilRL _ = return Nothing-wspfr jn matches remaining@(p:<:pps) skipped-    | not $ matches p = wspfr jn matches pps (p:>:skipped)-    | otherwise =-    case commuteFLorComplain (p :> skipped) of-    Left _  -> do putStrLn "\nSkipping depended-upon patch:"-                  printFriendly Nothing [] p-                  wspfr jn matches pps (p:>:skipped)-    Right (skipped' :> p') -> do-        printFriendly Nothing [] p-        yorn <- promptChar $-                    PromptConfig { pPrompt = prompt'-                                 , pBasicCharacters = keysFor basicOptions-                                 , pAdvancedCharacters = keysFor advancedOptions-                                 , pDefault = Just 'n'-                                 , pHelp = "?h" }-        case yorn of-            'y' -> return $ Just $ flipSeal $ skipped' :> p'-            'n' -> nextPatch-            'j' -> nextPatch-            'k' -> case skipped of-                     NilFL -> repeatThis-                     (prev :>: skipped') -> wspfr jn matches (prev :<: remaining) skipped'-            'v' -> printPatch p >> repeatThis-            'p' -> printPatchPager p >> repeatThis-            'x' -> do putDocLn $ prefix "    " $ summary p-                      repeatThis-            'q' -> do putStrLn $ jnCapital ++ " cancelled."-                      exitWith $ ExitSuccess-            _   -> do putStrLn $ helpFor jn basicOptions advancedOptions-                      repeatThis-  where jnCapital = (toUpper $ head jn) : tail jn-        repeatThis = wspfr jn matches (p:<:pps) skipped-        prompt' = "Shall I " ++ jn ++ " this patch?"-        nextPatch = wspfr jn matches pps (p:>:skipped)-        basicOptions =-                    [[ KeyPress 'y' (jn ++ " this patch")-                     , KeyPress 'n' ("don't " ++ jn ++ " it")-                     , KeyPress 'j' "skip to next patch"-                     , KeyPress 'k' "back up to previous patch"-                    ]]-        advancedOptions =-                    [[ KeyPress 'v' "view this patch in full"-                     , KeyPress 'p' "view this patch in full with pager"-                     , KeyPress 'x' "view a summary of this patch"-                     , KeyPress 'q' ("cancel " ++ jn)-                    ]]---- After selecting with a splitter, the results may not be canonical-canonizeAfterSplitter :: (FL p :> FL p) C(x y) -> Reader (PatchSelectionContext p) ((FL p :> FL p) C(x y))-canonizeAfterSplitter (x :> y) =-    do mspl <- asks splitter-       let canonizeIfNeeded = maybe id canonizeSplit mspl-       return $ canonizeIfNeeded x :> canonizeIfNeeded y--realSelectChanges :: forall p C(x y). (Patchy p, ApplyState p ~ Tree)-                                => WhichChanges-                                -> PatchChoices p C(x y)-                                -> PatchSelectionM p IO (PatchChoices p C(x y))-realSelectChanges whch autoChoices =-    do-      o <- asks opts-      if not $ isInteractive o-       then return $ promote autoChoices-       else refineChoices (textSelect whch) autoChoices-    where forward = not $ backward whch-          promote = if forward-                    then makeEverythingSooner-                    else makeEverythingLater---- | When using @--match@, remove unmatched patches not depended upon by matched--- patches.-deselectUnwanted :: forall p C(x y) . Patchy p => WhichChanges ->-                     PatchChoices p C(x y) ->-                     Reader (PatchSelectionContext p) (PatchChoices p C(x y))-deselectUnwanted whichch pc =-    do-      o <- asks opts-      c <- asks matchCriterion-      let iswanted_ = c whichch o . seal2 . tpPatch-          select = if forward-                   then forceMatchingFirst iswanted_-                   else forceMatchingLast iswanted_-          deselect = if forward-                     then forceMatchingLast (not . iswanted_)-                     else forceMatchingFirst (not . iswanted_)-      return $-        if haveNonrangeMatch o-            then if DontGrabDeps `elem` o-                 then deselect pc-                 else demote $ select pc-            else pc-    where-      forward = not $ backward whichch-      demote = if forward-               then makeEverythingLater-               else makeEverythingSooner---- | Selects the patches matching the match criterion, and puts them first or last--- according to whch, while respecting any dependencies.-patchesToConsider :: (Patchy p, ApplyState p ~ Tree)-                     => WhichChanges-                     -> FL p C(x y)-                     -> Reader (PatchSelectionContext p) (PatchChoices p C(x y))-patchesToConsider whch ps =-    do-      fs <- asks files-      o <- asks opts-      let deselectNotTouching =-              case whch of-                First -> TouchesFiles.deselectNotTouching-                Last -> TouchesFiles.selectNotTouching-                FirstReversed -> TouchesFiles.selectNotTouching-                LastReversed -> TouchesFiles.deselectNotTouching-          everything = patchChoices ps-      if isNothing fs && not (haveNonrangeMatch o)-         then return everything-         else do notUnwanted <- deselectUnwanted whch everything-                 return $ deselectNotTouching fs notUnwanted---- | Returns the results of a patch selection user interaction-selectedPatches :: Patchy p => WhichChanges -> PatchChoices p C(y z)-                      -> (FL p :> FL p) C(y z)-selectedPatches Last pc =-  case getChoices pc of-   fc :> mc :> lc -> mapFL_FL tpPatch (fc +>+ mc) :> mapFL_FL tpPatch lc--selectedPatches First pc =-  case separateFirstFromMiddleLast pc of-  xs :> ys -> mapFL_FL tpPatch xs :> mapFL_FL tpPatch ys--selectedPatches LastReversed pc =-  case separateFirstFromMiddleLast pc of-  xs :> ys -> mapFL_FL tpPatch (xs) :> (mapFL_FL tpPatch (ys))--selectedPatches FirstReversed pc =-  case getChoices pc of-  fc :> mc :> lc -> (mapFL_FL tpPatch (fc +>+ mc)) :> (mapFL_FL tpPatch lc)---- | Runs a function on the underlying @PatchChoices@ object-liftChoices :: forall p a C(x y) . Patchy p =>-               StateT (PatchChoices p C(x y)) Identity a-                   -> InteractiveSelectionM p C(x y) a-liftChoices act = do-  ch <- gets choices-  let (result, _) = runIdentity $ runStateT act ch-  modify $ \isc -> isc {choices = ch} -- Should this be ch or the result of runState?-  return result---- | @justDone n@ notes that @n@ patches have just been processed-justDone :: Patchy p => Int -> InteractiveSelectionM p C(x y) ()-justDone n = modify $ \isc -> isc{ current = current isc + n}---- | The actual interactive selection process.-textSelect :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) => WhichChanges ->-             FL (TaggedPatch p) C(x y) -> PatchChoices p C(x y)-             -> PatchSelectionM p IO (PatchChoices p C(x y))-textSelect whch tps' pcs = do-    userSelection <- execStateT (skipMundane whch >>-                                 showCur whch >>-                                 textSelectIfAny) $-                     ISC { total = lengthFL tps'-                         , current = 0-                         , tps = FZipper NilRL tps'-                         , choices = pcs }-    return $ choices userSelection-    where textSelectIfAny = do-            z <- gets tps-            if rightmost z-              then return ()-              else textSelect' whch--textSelect' :: (Patchy p, ApplyState p ~ Tree) => WhichChanges ->-              InteractiveSelectionM p C(x y) ()-textSelect' whch = do-  z <- gets tps-  when (not $ rightmost z) $-       do-         textSelectOne whch-         textSelect' whch--optionsBasic :: [Char] -> [Char] -> [KeyPress]-optionsBasic jn aThing =-    [ KeyPress 'y' (jn++" this "++aThing)-    , KeyPress 'n' ("don't "++jn++" it")-    , KeyPress 'w' ("wait and decide later, defaulting to no") ]--optionsFile :: [Char] -> [KeyPress]-optionsFile jn =-    [ KeyPress 's' ("don't "++jn++" the rest of the changes to this file")-    , KeyPress 'f' (jn++" the rest of the changes to this file") ]--optionsView :: String -> String -> [KeyPress]-optionsView aThing someThings =-    [ KeyPress 'v' ("view this "++aThing++" in full")-    , KeyPress 'p' ("view this "++aThing++" in full with pager")-    , KeyPress 'l' ("list all selected "++someThings) ]--optionsSummary :: String -> [KeyPress]-optionsSummary aThing =-    [ KeyPress 'x' ("view a summary of this "++aThing) ]--optionsQuit :: String -> String -> [KeyPress]-optionsQuit jn someThings =-    [ KeyPress 'd' (jn++" selected "++someThings++", skipping all the remaining "++someThings)-    , KeyPress 'a' (jn++" all the remaining "++someThings)-    , KeyPress 'q' ("cancel "++jn) ]--optionsNav :: String -> [KeyPress]-optionsNav aThing =-  [ KeyPress 'j' ("skip to next "++ aThing)-  ,  KeyPress 'k' ("back up to previous "++ aThing)-  , KeyPress 'g' ("start over from the first "++aThing)]--optionsSplit :: Maybe (Splitter a) -> String -> [KeyPress]-optionsSplit split aThing-    | Just _ <- split-             = [ KeyPress 'e' ("interactively edit this "++ aThing) ]-    | otherwise = []--options :: forall p C(x y) . (Patchy p) => Bool ->-           InteractiveSelectionM p C(x y) ([[KeyPress]],[[KeyPress]])-options single = do-  split <- asks splitter-  jn <- asks jobname-  aThing <- thing-  someThings <- things-  o <- asks opts-  return $-             ([optionsBasic jn aThing]-             ,[optionsSplit split aThing]-             ++ (if single then-                     [optionsFile jn ] else [])-             ++ [optionsView aThing someThings ++-                 if Summary `elem` o then []-                 else optionsSummary aThing]-             ++ [optionsQuit jn someThings]-             ++ [optionsNav aThing]-             )---- | Returns a @Sealed2@ version of the patch we are asking the user--- about.-currentPatch :: forall p C(x y) . Patchy p =>-               InteractiveSelectionM p C(x y)-                    (Maybe (Sealed2 (TaggedPatch p)))-currentPatch = do-  (FZipper _ tps_todo) :: FZipper (TaggedPatch p) C(x y) <- gets tps-  case tps_todo of-    NilFL -> return Nothing-    (tp:>:_) -> return $ Just (Sealed2 tp)---- | Returns the patches we have yet to ask the user about.-todo :: forall p C(x y) . Patchy p-        => InteractiveSelectionM p C(x y)-              (FlippedSeal (FL (TaggedPatch p)) C(y))-todo = do-    (FZipper _ tps_todo) <- gets tps-    return (FlippedSeal tps_todo)---- | Modify the underlying @PatchChoices@ by some function-modChoices :: forall p C(x y) . Patchy p =>-              (PatchChoices p C(x y) -> PatchChoices p C(x y))-              -> InteractiveSelectionM p C(x y) ()-modChoices f = modify $ \isc -> isc{choices = f $ choices isc}---- | returns @Just f@ if the 'currentPatch' only modifies @f@,--- @Nothing@ otherwise.-currentFile :: forall p C(x y) . Patchy p-               => InteractiveSelectionM p C(x y) (Maybe FilePath)-currentFile = do-  c <- currentPatch-  return $ case c of-             Nothing -> Nothing-             Just (Sealed2 tp) ->-                 case listTouchedFiles tp of-                   [f] -> Just f-                   _ -> Nothing---- | @decide True@ selects the current patch, and @decide False@ deselects--- it.-decide :: forall p C(x y t u) . Patchy p => WhichChanges -> Bool-         -> TaggedPatch p C(t u)-         -> InteractiveSelectionM p C(x y) ()-decide whch takeOrDrop tp =-    if backward whch == takeOrDrop -- we go backward xor we are dropping-    then modChoices $ forceLast (tag tp)-    else modChoices $ forceFirst (tag tp)---- | like 'decide', but for all patches touching @file@-decideWholeFile :: forall p C(x y). Patchy p => WhichChanges ->-                  FilePath -> Bool -> InteractiveSelectionM p C(x y) ()-decideWholeFile whch file takeOrDrop =-    do-      FlippedSeal tps_todo <- todo-      let patches_to_skip =-              filterFL (\tp' -> listTouchedFiles tp' == [file]) tps_todo-      mapM_ (unseal2 $ decide whch takeOrDrop) patches_to_skip---- | Undecide the current patch.-postponeNext :: forall p C(x y) . Patchy p => InteractiveSelectionM p C(x y) ()-postponeNext =-    do-      Just (Sealed2 tp) <- currentPatch-      modChoices $ makeUncertain (tag tp)---- | Focus the next patch.-skipOne :: forall p C(x y) . Patchy p => InteractiveSelectionM p C(x y) ()-skipOne = modify so-    where so x = x{tps = right (tps x), current = current x +1}---- | Focus the previous patch.-backOne :: forall p C(x y) . Patchy p => InteractiveSelectionM p C(x y) ()-backOne = modify so-    where so isc = isc{tps = left (tps isc), current = max (current isc-1) 0}---- | Split the current patch (presumably a hunk), and add the replace it--- with its parts.-splitCurrent :: forall p C(x y) . Patchy p => Splitter p-                -> InteractiveSelectionM p C(x y) ()-splitCurrent s = do-    FZipper tps_done (tp:>:tps_todo) <- gets tps-    case (applySplitter s (tpPatch tp)) of-      Nothing -> return ()-      Just (text, parse) ->-          do-            newText <- liftIO $ editText "darcs-patch-edit" text-            case parse newText of-               Nothing -> return ()-               Just ps -> do-                 tps_new <- liftIO . return . snd-                             $ patchChoicesTpsSub (Just (tag tp)) ps-                 modify $ \isc -> isc { total = ( total isc-                                                  + lengthFL tps_new - 1 )-                                      , tps = (FZipper tps_done-                                               (tps_new +>+ tps_todo))-                                      , choices = (substitute-                                                   (seal2 (tp :||: tps_new))-                                                   (choices isc))-                                      }---- | Returns a list of the currently selected patches, in--- their original context, i.e., not commuted past unselected--- patches.-selected :: forall p C(x y). Patchy p => WhichChanges ->-           InteractiveSelectionM p C(x y) [Sealed2 p]-selected whichch = do-  c <- gets choices-  (first_chs :> _ :> last_chs) <- return $ getChoices c-  return $ if backward whichch-           then-               mapFL (repr whichch . Sealed2 . tpPatch) $ last_chs-           else-               mapFL (repr whichch . Sealed2 . tpPatch) $ first_chs---- | Prints the list of the selected patches. See 'selected'.-printSelected :: Patchy p => WhichChanges ->-                InteractiveSelectionM p C(x y) ()-printSelected whichch = do-  someThings <- things-  o <- asks opts-  s <- selected whichch-  liftIO $ do-    putStrLn $ "---- Already selected "++someThings++" ----"-    mapM_ (putDocLn . unseal2 (showFriendly o)) s-    putStrLn $ "---- end of already selected "++someThings++" ----"--printSummary :: forall p C(x y) . Patchy p => p C(x y) -> IO ()-printSummary =-  putDocLn . prefix "    " . summary---- | Skips all remaining patches.-skipAll :: forall p C(x y) . Patchy p =>-          InteractiveSelectionM p C(x y) ()-skipAll = do-  modify $ \isc -> isc {tps = toEnd $ tps isc}--backAll :: forall p C(x y) . Patchy p =>-          InteractiveSelectionM p C(x y) ()-backAll = do-  modify $ \isc -> isc {tps = toStart $ tps isc-                       ,current = 0}--isSingleFile :: Patchy p => p C(x y) -> Bool-isSingleFile p = length (listTouchedFiles p) == 1--askConfirmation :: forall p C(x y) . Patchy p =>-                   InteractiveSelectionM p C(x y) ()-askConfirmation = do-    jn <- asks jobname-    liftIO $ if jn `elem` ["unpull", "unrecord", "obliterate"]-             then do-               yorn <- askUser $ "Really " ++ jn ++ " all undecided patches? "-               case yorn of-                 ('y':_) -> return ()-                 _ -> exitWith $ ExitSuccess-             else return ()---- | The singular form of the noun for items of type @p@.-thing :: Patchy p => InteractiveSelectionM p C(x y) String-thing = gets choices >>= return . Darcs.Patch.thing . helper-        where-          helper :: PatchChoices p C(a b) -> p C(a b)-          helper = undefined---- | The plural form of the noun for items of type @p@.-things :: Patchy p => InteractiveSelectionM p C(x y) String-things = gets choices >>= return . Darcs.Patch.things . helper-        where-          helper :: PatchChoices p C(a b) -> p C(a b)-          helper = undefined---- | The question to ask about one patch.-prompt :: Patchy p => InteractiveSelectionM p C(x y) String-prompt = do-  jn <- asks jobname-  aThing <- thing-  n <- gets current-  n_max <- gets total-  return $ "Shall I "++jn++" this "++aThing++"? "-             ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") "---- | Asks the user about one patch, returns their answer.-promptUser :: forall p C(x y) . Patchy p => Bool -> Char-              -> InteractiveSelectionM p C(x y) Char-promptUser single def = do-  thePrompt <- prompt-  (basicOptions,advancedOptions) <- options single-  liftIO $ promptChar $ PromptConfig { pPrompt = thePrompt-                                     , pBasicCharacters = keysFor basicOptions-                                     , pAdvancedCharacters = keysFor advancedOptions-                                     , pDefault = Just def-                                     , pHelp = "?h"-                                     }---- | Ask the user what to do with the next patch.-textSelectOne :: forall p C(x y). (Patchy p, ApplyState p ~ Tree) => WhichChanges-            -> InteractiveSelectionM p C(x y) ()-textSelectOne whichch = do- c <- currentPatch- case c of-   Nothing -> return ()-   Just (Sealed2 tp) ->-       do-         jn <- asks jobname-         spl <- asks splitter-         let singleFile = isSingleFile (tpPatch tp)-             reprCur = repr whichch (Sealed2 (tpPatch tp))-         (basicOptions,advancedOptions) <- options singleFile-         theSlot <- liftChoices $ patchSlot' tp-         let-             the_default = getDefault (whichch == Last || whichch == FirstReversed) theSlot-             jnCapital = (toUpper $ head jn) : tail jn-         yorn <- promptUser singleFile the_default-         let nextPatch = skipMundane whichch >> showCur whichch-         case yorn of-               'y' -> decide whichch True tp >> skipOne >> nextPatch-               'n' -> decide whichch False tp >> skipOne >> nextPatch-               'w' -> postponeNext >> skipOne >> nextPatch-               'e' | (Just s) <- spl -> splitCurrent s >> showCur whichch-               's' -> currentFile >>= maybe-                       (return ())-                       (\f -> decideWholeFile whichch f False) >> nextPatch-               'f' -> currentFile >>= maybe-                       (return ())-                       (\f -> decideWholeFile whichch f True) >> nextPatch-               'v' -> liftIO $ unseal2 printPatch reprCur-               'p' -> liftIO $ unseal2 printPatchPager reprCur-               'l' -> printSelected whichch >> showCur whichch-               'x' -> liftIO $ unseal2 printSummary reprCur-               'd' -> skipAll-               'g' -> backAll >> showCur whichch-               'a' ->-                   do-                     askConfirmation-                     modChoices $ selectAllMiddles (whichch == Last || whichch == FirstReversed)-                     skipAll-               'q' -> liftIO $-                      do putStrLn $ jnCapital++" cancelled."-                         exitWith $ ExitSuccess-               'j' -> skipOne >> showCur whichch-               'k' -> backOne >> showCur whichch-               _   -> do-                 liftIO . putStrLn $ helpFor jn basicOptions advancedOptions---- | Shows the current patch as it should be seen by the user.-showCur :: forall p C(x y) . (Patchy p, ApplyState p ~ Tree) => WhichChanges-           -> InteractiveSelectionM p C(x y) ()-showCur whichch = do-  o <- asks opts-  p <- asks pristine-  c <- currentPatch-  case c of-      Nothing -> return ()-      Just (Sealed2 tp) -> do-             let reprCur = repr whichch (Sealed2 (tpPatch tp))-             liftIO . (unseal2 (printFriendly p o)) $ reprCur---- | The interactive part of @darcs changes@-textView :: forall p . (Patchy p, ApplyState p ~ Tree) => [DarcsFlag] -> Maybe Int -> Int-            -> [Sealed2 p] -> [Sealed2 p]-            -> IO ()-textView _ _ _ _ [] = return ()-textView o n_max n-            ps_done ps_todo@(p:ps_todo') = do-      unseal2 (printFriendly Nothing o) p-      repeatThis -- prompt the user-    where-        prev_patch :: IO ()-        prev_patch = case ps_done of-                       [] -> repeatThis-                       (p':ps_done') ->-                         textView o-                            n_max (n-1) ps_done' (p':ps_todo)-        next_patch :: IO ()-        next_patch = case ps_todo' of-                         [] -> -- May as well work out the length now we have all-                                  -- the patches in memory-                               textView o n_max-                                   n ps_done []-                         _ -> textView o n_max-                                  (n+1) (p:ps_done) ps_todo'-        first_patch = textView o n_max 0 [] (ps_done++ps_todo)-        options_yn =-          [ KeyPress 'y' "view this patch and go to the next"-          , KeyPress 'n' "skip to the next patch" ]-        optionsView' =-          [ KeyPress 'v' "view this patch in full"-          , KeyPress 'p' "view this patch in full with pager" ]-        optionsSummary' =-          [ KeyPress 'x' "view a summary of this patch" ]-        optionsNav' =-          [ KeyPress 'q' "quit view changes"-          , KeyPress 'k' "back up to previous patch"-          , KeyPress 'j' "skip to next patch"-          , KeyPress 'g' "start over from the first patch"-          , KeyPress 'c' "count total patch number" ]-        basicOptions = [ options_yn ]-        advancedOptions =-                     [ optionsView' ++-                       if Summary `elem` o then [] else optionsSummary' ]-                  ++ [ optionsNav' ]-        prompt' = "Shall I view this patch? "-               ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")"-        repeatThis :: IO ()-        repeatThis = do-          yorn <- promptChar (PromptConfig prompt' (keysFor basicOptions) (keysFor advancedOptions) (Just 'n') "?h")-          case yorn of-            'y' -> unseal2 printPatch p >> next_patch-            'n' -> next_patch-            'v' -> unseal2 printPatch p >> repeatThis-            'p' -> unseal2 printPatchPager p >> repeatThis-            'x' -> do putDocLn $ prefix "    " $ unseal2 summary p-                      repeatThis-            'q' -> exitWith ExitSuccess-            'k' -> prev_patch-            'j' -> next_patch-            'g' -> first_patch-            'c' -> textView o-                       count_n_max n ps_done ps_todo-            _   -> do putStrLn $ helpFor "view changes" basicOptions advancedOptions-                      repeatThis-        count_n_max | isJust n_max = n_max-                    | otherwise    = Just $ length ps_done + length ps_todo---- | Skips patches we should not ask the user about-skipMundane :: Patchy p => WhichChanges ->-              InteractiveSelectionM p C(x y) ()-skipMundane whichch = do-  (FZipper tps_done tps_todo) <- gets tps-  o <- asks opts-  crit <- asks matchCriterion-  jn <- asks jobname-  (skipped :> unskipped) <- liftChoices $ spanFL_M-                                 (patchSlot' >=> return . decided)-                                 tps_todo-  let numSkipped = lengthFL skipped-  when (numSkipped > 0) . liftIO $ show_skipped o jn numSkipped skipped-  let boringThenInteresting =-          if DontPromptForDependencies `elem` o-          then spanFL (not.(crit whichch o) . seal2 . tpPatch) $-                                 unskipped-          else NilFL :> unskipped-  case boringThenInteresting of-    boring :> interesting ->-        do-          justDone $ lengthFL boring + numSkipped-          modify $ \isc -> isc {tps = (FZipper (reverseFL boring +<+ reverseFL skipped +<+ tps_done) interesting)}-    where-      show_skipped o jn n ps = do putStrLn $ _nevermind_ jn ++ _these_ n ++ "."-                                  when (Verbose `elem` o) $-                                       showskippedpatch ps-      _nevermind_ jn = "Will not ask whether to " ++ jn ++ " "-      _these_ n  = show n ++ " already decided " ++ _elem_ n ""-      _elem_ n = englishNum n (Noun "patch")-      showskippedpatch :: Patchy p => FL (TaggedPatch p) C(y t) -> IO ()-      showskippedpatch =-                    sequence_ . mapFL (printSummary . tpPatch)--decided :: Slot -> Bool-decided InMiddle = False-decided _ = True---- | The action bound to space, depending on the current status of the--- patch.-getDefault :: Bool -> Slot -> Char-getDefault _ InMiddle = 'w'-getDefault True InFirst  = 'n'-getDefault True InLast   = 'y'-getDefault False InFirst = 'y'-getDefault False InLast  = 'n'---- |Optionally remove any patches (+dependencies) from a sequence that--- conflict with the recorded or unrecorded changes in a repo-filterOutConflicts :: (RepoPatch p, ApplyState p ~ Tree)-                   => [DarcsFlag]                                    -- ^Command-line options. Only 'SkipConflicts' is-                                                                     -- significant; filtering will happen iff it is present-                   -> RL (PatchInfoAnd p) C(x t)                     -- ^Recorded patches from repository, starting from-                                                                     -- same context as the patches to filter-                   -> Repository p C(r u t)                          -- ^Repository itself, used for grabbing unrecorded changes-                   -> FL (PatchInfoAnd p) C(x z)                     -- ^Patches to filter-                   -> IO (Bool, Sealed (FL (PatchInfoAnd p) C(x)))   -- ^(True iff any patches were removed, possibly filtered patches)-filterOutConflicts o us repository them-  | SkipConflicts `elem` o-     = do let commuter = commuterIdRL selfCommuter-          unrec <- fmap n2pia . (anonymous . fromPrims)-                     =<< unrecordedChanges (UseIndex, ScanKnown) repository Nothing-          them' :> rest <- return $ partitionConflictingFL commuter them (unrec :<: us)-          return (check rest, Sealed them')-  | otherwise-     = return (False, Sealed them)-  where check :: FL p C(a b) -> Bool-        check NilFL = False-        check _ = True
− src/Darcs/SignalHandler.hs 
@@ -1,151 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, DeriveDataTypeable #-}--module Darcs.SignalHandler ( withSignalsHandled, withSignalsBlocked,-                             catchInterrupt, catchNonSignal,-                             tryNonSignal, stdoutIsAPipe ) where--import Prelude hiding ( catch )--import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName )-import System.Exit ( exitWith, ExitCode ( ExitFailure ) )-import Control.Concurrent ( ThreadId, myThreadId )-import Control.Exception.Extensible-            ( catch, throw, throwTo,-              Exception(..), SomeException(..), IOException )-#if (MIN_VERSION_base(4,4,0))-import Control.Exception.Extensible ( mask )-#else-import Control.Exception.Extensible ( block, unblock )-#endif-import System.Posix.Files ( getFdStatus, isNamedPipe )-import System.Posix.IO ( stdOutput )-import Data.Typeable ( Typeable, cast )-import Data.List ( isPrefixOf )-import System.IO ( hPutStrLn, stderr )-import Control.Monad ( when )--import Workaround ( installHandler, raiseSignal, Handler(..), Signal,-                    sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE )-#ifdef WIN32-import CtrlC ( withCtrlCHandler )-#endif--#if !(MIN_VERSION_base(4,4,0))-mask f = block (f unblock)-#endif--stdoutIsAPipe :: IO Bool-stdoutIsAPipe- = catch-        (do stat <- getFdStatus stdOutput-            return (isNamedPipe stat))-        (\(_ :: IOException) -> return False)--withSignalsHandled :: IO a -> IO a-newtype SignalException = SignalException Signal deriving (Show, Typeable)--instance Exception SignalException where-   toException e = SomeException e-   fromException (SomeException e) = cast e--withSignalsHandled job = do-    thid <- myThreadId-    mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE]-    catchUserErrors (job' thid `catchSignal` defaults)-                    die_with_string-    where defaults s | s == sigINT = ew s "Interrupted!"-                     | s == sigHUP = ew s "HUP"-                     | s == sigABRT = ew s "ABRT"-                     | s == sigTERM = ew s "TERM"-                     | s == sigPIPE = exitWith $ ExitFailure $ 1-                     | otherwise = ew s "Unhandled signal!"-          ew sig s = do hPutStrLn stderr $ ("withSignalsHandled: " ++ s)-                        resethandler sig-                        raiseSignal sig -- ensure that our caller knows how we died-                        exitWith $ ExitFailure $ 1-          die_with_string e | "STDOUT" `isPrefixOf` e =-                do is_pipe <- stdoutIsAPipe-                   when (not is_pipe) $-                        hPutStrLn stderr $ "\ndarcs failed:  "++drop 6 e-                   exitWith $ ExitFailure $ 2-          die_with_string e = do hPutStrLn stderr $ "\ndarcs failed:  "++e-                                 exitWith $ ExitFailure $ 2-#ifdef WIN32-          job' thid =-             withCtrlCHandler (throwTo thid $ SignalException sigINT) job-#else-          job' _ = job-#endif--resethandler :: Signal -> IO ()--- Warning:  A do-notation statement discarded a result of type Handler.-resethandler s = do _ <- installHandler s Default Nothing-                    return ()--ih :: ThreadId -> Signal -> IO ()-ih thid s =--- Warning:  A do-notation statement discarded a result of type Handler.-  do _ <- installHandler s (Catch $ throwTo thid $ SignalException s) Nothing-     return ()--catchSignal :: IO a -> (Signal -> IO a) -> IO a-catchSignal job handler =-    job `catch` (\(SignalException sig) -> handler sig)---- catchNonSignal is a drop-in replacement for Control.Exception.catch, which allows--- us to catch anything but a signal.  Useful for situations where we want--- don't want to inhibit ctrl-C.--catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a-catchNonSignal comp handler = catch comp handler'-    where handler' se =-           case fromException se :: Maybe SignalException of-             Nothing -> handler se-             Just _ -> throw se--catchInterrupt :: IO a -> IO a -> IO a-catchInterrupt job handler =-    job `catchSignal` h-        where h s | s == sigINT = handler-                  | otherwise   = throw (SignalException s)--tryNonSignal :: IO a -> IO (Either SomeException a)-tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e)--catchUserErrors :: IO a -> (String -> IO a) -> IO a-catchUserErrors comp handler = catch comp handler'-  where handler' ioe-         | isUserError ioe                       = handler (ioeGetErrorString ioe)-         | ioeGetFileName ioe == Just "<stdout>" = handler ("STDOUT" ++ ioeGetErrorString ioe)-         | otherwise                             = throw ioe--withSignalsBlocked :: IO a -> IO a-withSignalsBlocked job = mask (\unmask -> job >>= \r ->-                           unmask (return r) `catchSignal` couldnt_do r)-    where couldnt_do r s | s == sigINT = oops "interrupt" r-                         | s ==  sigHUP = oops "HUP" r-                         | s ==  sigABRT = oops "ABRT" r-                         | s ==  sigALRM = oops "ALRM" r-                         | s ==  sigTERM = oops "TERM" r-                         | s ==  sigPIPE = return r-                         | otherwise = oops "unknown signal" r-          oops s r = do hPutStrLn stderr $ "Couldn't handle " ++ s ++-                          " since darcs was in a sensitive job."-                        return r
− src/Darcs/Ssh.hs 
@@ -1,231 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---- |--- Module      : Darcs.Ssh--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Darcs.Ssh-    (-      copySSH-    , SSHCmd(..)-    , getSSH-    , environmentHelpSsh-    , environmentHelpScp-    , environmentHelpSshPort-    , remoteDarcs-  ) where---import Prelude hiding ( lookup, catch )--import qualified Ratified ( hGetContents )--import System.Environment ( getEnv )-import System.Exit ( ExitCode(..) )--import Control.Monad ( when )--import qualified Data.ByteString as B (ByteString, hGet, writeFile )--import Data.Map ( Map, empty, insert, lookup )-import Data.IORef ( IORef, newIORef, readIORef, modifyIORef )--import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush )-import System.IO.Unsafe ( unsafePerformIO )-import System.Process ( runInteractiveProcess )--import Darcs.SignalHandler ( catchNonSignal )-import Darcs.Flags( RemoteDarcs(..) )-import Darcs.Global ( defaultSsh, SshSettings)-import Darcs.URL (SshFilePath(..), urlOf)-import Darcs.Utils ( breakCommand, prettyException, catchall )-import Exec ( exec, Redirect(..), )-import Progress ( withoutProgress, debugMessage, debugFail )--import qualified Darcs.Global as Settings---sshConnections :: IORef (Map String (Maybe Connection))-sshConnections = unsafePerformIO $ newIORef empty-{-# NOINLINE sshConnections #-}---data Connection = C-    { inp :: !Handle-    , out :: !Handle-    , err :: !Handle-    , deb :: String -> IO ()-    }----- | @withSSHConnection rdarcs repoid  withconnection withoutconnection@--- performs an action on a remote host. If we are already connected to @repoid @,--- then it does @withconnection@, else @withoutconnection@.-withSSHConnection :: String                 -- ^ rdarcs-                  -> SshFilePath            -- ^ Destination repo id-                  -> (Connection -> IO a)   -- ^ withconnection-                  -> IO a                   -- ^ withoutconnection-                  -> IO a-withSSHConnection rdarcs repoid withconnection withoutconnection =-    withoutProgress $-    do cs <- readIORef sshConnections-       case lookup (sshUhost repoid) (cs :: Map String (Maybe Connection)) of-         Just Nothing -> withoutconnection-         Just (Just c) -> withconnection c-         Nothing ->-           do mc <- do (ssh,sshargs_) <- getSSH SSH-                       let sshargs = sshargs_ ++ [sshUhost repoid, rdarcs,-                                                  "transfer-mode","--repodir",sshRepo repoid]-                       debugMessage $ unwords (ssh : sshargs)-                       (i,o,e,_) <- runInteractiveProcess ssh sshargs Nothing Nothing-                       hSetBinaryMode i True-                       hSetBinaryMode o True-                       l <- hGetLine o-                       if l == "Hello user, I am darcs transfer mode"-                           then return ()-                           else debugFail "Couldn't start darcs transfer-mode on server"-                       let c = C { inp = i, out = o, err = e,-                                   deb = \s -> debugMessage ("with ssh (transfer-mode) " ++ sshUhost repoid ++ " " ++ s) }-                       modifyIORef sshConnections (insert (sshUhost repoid) (Just c))-                       return $ Just c-                    `catchNonSignal`-                            \e -> do debugMessage $ "Failed to start ssh connection:\n    "++-                                                    prettyException e-                                     severSSHConnection repoid-                                     debugMessage $ unlines $-                                         [ "NOTE: the server may be running a version of darcs prior to 2.0.0."-                                         , ""-                                         , "Installing darcs 2 on the server will speed up ssh-based commands."-                                         ]-                                     return Nothing-              maybe withoutconnection withconnection mc--severSSHConnection :: SshFilePath-                   -> IO ()-severSSHConnection x = do-    debugMessage $ "Severing ssh failed connection to " ++ (sshUhost x)-    modifyIORef sshConnections (insert (urlOf x) Nothing)---grabSSH :: SshFilePath -> Connection -> IO B.ByteString-grabSSH dest c = do-  debugMessage $ "grabSSH dest=" ++ urlOf dest-  let failwith e = do severSSHConnection dest-                        -- hGetContents is ok here because we're-                        -- only grabbing stderr, and we're also-                        -- about to throw the contents.-                      eee <- Ratified.hGetContents (err c)-                      debugFail $ e ++ " grabbing ssh file "++-                        urlOf dest++"/"++ file ++"\n"++eee-      file = sshFile dest-  deb c $ "get "++ file-  hPutStrLn (inp c) $ "get " ++ file-  hFlush (inp c)-  l2 <- hGetLine (out c)-  if l2 == "got "++file-    then do showlen <- hGetLine (out c)-            case reads showlen of-              [(len,"")] -> B.hGet (out c) len-              _ -> failwith "Couldn't get length"-    else if l2 == "error "++file-         then do e <- hGetLine (out c)-                 case reads e of-                   (msg,_):_ -> debugFail $ "Error reading file remotely:\n"++msg-                   [] -> failwith "An error occurred"-         else failwith "Error"--remoteDarcs :: RemoteDarcs-            -> String-remoteDarcs DefaultRemoteDarcs = "darcs"-remoteDarcs (RemoteDarcs x) = x---copySSH :: RemoteDarcs-        -> SshFilePath-        -> FilePath-        -> IO ()-copySSH remote dest to | rdarcs <- remoteDarcs remote = do-    debugMessage $ "copySSH file: " ++ urlOf dest-    withSSHConnection rdarcs dest (\c -> grabSSH dest c >>= B.writeFile to) $ do-        let u = escape_dollar $ urlOf dest-        (scp, args) <- getSSH SCP-        r <- exec scp (args ++ [u, to]) (AsIs,AsIs,AsIs)-        when (r /= ExitSuccess) $-            debugFail $ "(scp) failed to fetch: " ++ u-  where-    -- '$' in filenames is troublesome for scp, for some reason.-    escape_dollar :: String -> String-    escape_dollar = concatMap tr-      where-        tr '$' = "\\$"-        tr c = [c]----- ------------------------------------------------------------------------ older ssh helper functions--- -----------------------------------------------------------------------data SSHCmd = SSH-            | SCP-            | SFTP---fromSshCmd :: SshSettings-           -> SSHCmd-           -> String-fromSshCmd s SSH  = Settings.ssh s-fromSshCmd s SCP  = Settings.scp s-fromSshCmd s SFTP = Settings.sftp s----- | Return the command and arguments needed to run an ssh command---   First try the appropriate darcs environment variable and SSH_PORT---   defaulting to "ssh" and no specified port.-getSSH :: SSHCmd-       -> IO (String, [String])-getSSH cmd = do-    port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return []-    let (ssh, ssh_args) = breakCommand command-    return (ssh, ssh_args ++ port)-  where-    command = fromSshCmd defaultSsh cmd-    portFlag SSH  x = ["-p", x]-    portFlag SCP  x = ["-P", x]-    portFlag SFTP x = ["-oPort=" ++ x]---environmentHelpSsh :: ([String], [String])-environmentHelpSsh = (["DARCS_SSH"], [-    "Repositories of the form [user@]host:[dir] are taken to be remote",-    "repositories, which Darcs accesses with the external program ssh(1).",-    "",-    "The environment variable $DARCS_SSH can be used to specify an",-    "alternative SSH client.  Arguments may be included, separated by",-    "whitespace.  The value is not interpreted by a shell, so shell",-    "constructs cannot be used; in particular, it is not possible for the",-    "program name to contain whitespace by using quoting or escaping."])---environmentHelpScp :: ([String], [String])-environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [-    "When reading from a remote repository, Darcs will attempt to run",-    "`darcs transfer-mode' on the remote host.  This will fail if the",-    "remote host only has Darcs 1 installed, doesn't have Darcs installed",-    "at all, or only allows SFTP.",-    "",-    "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",-    "The commands invoked can be customized with the environment variables",-    "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",-    "If the remote end allows only sftp, try setting DARCS_SCP=sftp."])---environmentHelpSshPort :: ([String], [String])-environmentHelpSshPort = (["SSH_PORT"], [-    "If this environment variable is set, it will be used as the port",-    "number for all SSH calls made by Darcs (when accessing remote",-    "repositories over SSH).  This is useful if your SSH server does not",-    "run on the default port, and your SSH client does not support",-    "ssh_config(5).  OpenSSH users will probably prefer to put something",-    "like `Host *.example.net Port 443' into their ~/.ssh/config file."])
− src/Darcs/Test.hs 
@@ -1,95 +0,0 @@---  Copyright (C) 2002-2005 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Test ( getTest,-                    runPosthook, runPrehook )-where-import Darcs.RepoPath ( AbsolutePath )-import Darcs.Utils ( withCurrentDirectory )-import System.Exit ( ExitCode(..) )-import System.Cmd ( system )-import Control.Monad ( when )--import Darcs.Arguments ( DarcsFlag( Quiet,-                                    AskPosthook, AskPrehook ),-                        getPosthookCmd, getPrehookCmd )-import Darcs.Repository.Prefs ( getPrefval )-import Darcs.Utils ( askUser )-import System.IO ( hPutStrLn, stderr )--getTest :: [DarcsFlag] -> IO (IO ExitCode)-getTest opts =- let putInfo s = when (not $ Quiet `elem` opts) $ putStr s- in do- testline <- getPrefval "test"- return $-   case testline of-   Nothing -> return ExitSuccess-   Just testcode -> do-     putInfo "Running test...\n"-     ec <- system testcode-     if ec == ExitSuccess-       then putInfo "Test ran successfully.\n"-       else putInfo "Test failed!\n"-     return ec--runPosthook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode-runPosthook opts repodir =  do ph <- getPosthook opts-                               withCurrentDirectory repodir $ runHook opts "Posthook" ph--getPosthook :: [DarcsFlag] -> IO (Maybe String)-getPosthook opts = case getPosthookCmd opts of-                    Nothing -> return Nothing-                    Just command ->-                       if AskPosthook `elem` opts-                       then do putStr ("\nThe following command is set to execute.\n"++-                                                "Execute the following command now (yes or no)?\n"++-                                                command++"\n")-                               yorn <- askUser ""-                               case yorn of ('y':_) -> return $ Just command-                                            _ -> do putStrLn "Posthook cancelled..."-                                                    return Nothing-                       else return $ Just command--runPrehook :: [DarcsFlag] -> AbsolutePath -> IO ExitCode-runPrehook opts repodir =  do ph <- getPrehook opts-                              withCurrentDirectory repodir $ runHook opts "Prehook" ph--getPrehook :: [DarcsFlag] -> IO (Maybe String)-getPrehook opts = case getPrehookCmd opts of-                   Nothing -> return Nothing-                   Just command ->-                       if AskPrehook `elem` opts-                       then do putStr ("\nThe following command is set to execute.\n"++-                                                "Execute the following command now (yes or no)?\n"++-                                                command++"\n")-                               yorn <- askUser ""-                               case yorn of ('y':_) -> return $ Just command-                                            _ -> do putStrLn "Prehook cancelled..."-                                                    return Nothing-                       else return $ Just command--runHook :: [DarcsFlag] -> String -> Maybe String -> IO ExitCode-runHook _ _ Nothing = return ExitSuccess-runHook opts cname (Just command) =-    do ec <- system command-       when (Quiet `notElem` opts) $-         if ec == ExitSuccess-         then putStrLn $ cname++" ran successfully."-         else hPutStrLn stderr $ cname++" failed!"-       return ec-
− src/Darcs/Test/Email.hs 
@@ -1,93 +0,0 @@---  Copyright (C) 2002-2005,2007 David Roundy---  Copyright (C) 2009 Reinier Lamers------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.---- | This module contains unit tests of the code in 'Darcs.Email'------ These tests check whether the emails generated by darcs meet a few criteria.--- We check for line length and non-ASCII characters. We apparently do not have--- to check for CR-LF newlines because that's handled by sendmail.-module Darcs.Test.Email ( testSuite ) where-import Data.Char ( isPrint )-import qualified Data.ByteString as B ( length, unpack, null, head,-                                        cons, empty, foldr, ByteString )-import qualified Data.ByteString.Char8 as BC ( unpack )-import Test.Framework ( Test, testGroup )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Printer ( text, renderPS )-import Darcs.Email ( makeEmail, readEmail, formatHeader )--testSuite :: Test-testSuite = testGroup "Darcs.Email"-  [ emailParsing-  , emailHeaderNoLongLines-  , emailHeaderAsciiChars-  , emailHeaderLinesStart-  , emailHeaderNoEmptyLines-  ]---- | Checks that darcs can read the emails it generates-emailParsing :: Test-emailParsing = testProperty "Checking that email can be parsed" $ \s ->-    unlines ("":s++["", ""]) ==-              BC.unpack (readEmail (renderPS-                    $ makeEmail "reponame" [] (Just (text "contents\n"))-                                 Nothing-                                 (text $ unlines s) (Just "filename")))---- | Check that formatHeader never creates lines longer than 78 characters--- (excluding the carriage return and line feed)-emailHeaderNoLongLines :: Test-emailHeaderNoLongLines =-    testProperty "Checking email header line length" $ \field value ->-      let cleanField = cleanFieldString field-      in not $ any (>78) $ map B.length $ bsLines $ formatHeader cleanField value---- Check that an email header does not contain non-ASCII characters--- formatHeader doesn't escape field names, there is no such thing as non-ascii--- field names afaik-emailHeaderAsciiChars :: Test-emailHeaderAsciiChars =-    testProperty "Checking email for illegal characters" $ \field value ->-      let cleanField = cleanFieldString field-      in not (any (>127) (B.unpack (formatHeader cleanField value)))---- Check that header the second and later lines of a header start with a space-emailHeaderLinesStart :: Test-emailHeaderLinesStart =-    testProperty "Checking for spaces at start of folded email header lines" $ \field value ->-      let headerLines = bsLines (formatHeader cleanField value)-          cleanField  = cleanFieldString field-      in all (\l -> B.null l || B.head l == 32) (tail headerLines)---- Checks that there are no lines in email headers with only whitespace-emailHeaderNoEmptyLines :: Test-emailHeaderNoEmptyLines =-    testProperty "Checking that there are no empty lines in email headers" $ \field value ->-      let headerLines = bsLines (formatHeader cleanField value)-          cleanField  = cleanFieldString field-          in all (not . B.null) headerLines --(not . B.null . B.filter (not . (`elem` [10, 32, 9]))) headerLines--bsLines :: B.ByteString -> [B.ByteString]-bsLines = finalizeFold . B.foldr splitAtLines (B.empty, [])-  where splitAtLines 10 (thisLine, prevLines) = (B.empty, thisLine:prevLines)-        splitAtLines c  (thisLine, prevLines) = (B.cons c thisLine, prevLines)-        finalizeFold (lastLine, otherLines) = lastLine : otherLines--cleanFieldString :: String -> String-cleanFieldString = filter (\c -> isPrint c && c < '\x80' && c /= ':')-
− src/Darcs/Test/Misc.hs 
@@ -1,107 +0,0 @@---  Copyright (C) 2002-2005,2007 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--module Darcs.Test.Misc ( testSuite ) where--import ByteStringUtils ( unpackPSFromUTF8, fromHex2PS, fromPS2Hex )-import qualified Data.ByteString.Char8 as BC ( unpack, pack )-import qualified Data.ByteString as B ( concat, empty )-import Lcs ( shiftBoundaries )-import Data.Array.Base-import Control.Monad.ST-import Test.HUnit ( assertBool, assertEqual, assertFailure )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.Framework.Providers.HUnit ( testCase )-import Test.Framework ( Test, testGroup )--#include "gadts.h"--testSuite :: Test-testSuite = testGroup ""- [ byteStringUtilsTestSuite- , lcsTestSuite- ]----- ------------------------------------------------------------------------- * ByteStringUtils--- Here are a few quick tests of the shiftBoundaries function.--- ------------------------------------------------------------------------byteStringUtilsTestSuite :: Test-byteStringUtilsTestSuite = testGroup "ByteStringUtils"-  [ testCase "UTF-8 packing and unpacking preserves 'hello world'"-           (assertBool "" (unpackPSFromUTF8 (BC.pack "hello world") == "hello world"))-  , testCase "Checking that hex packing and unpacking preserves 'hello world'"-           (assertEqual "" (BC.unpack (fromHex2PS $ fromPS2Hex $ BC.pack "hello world"))-                           "hello world")-  , testProperty "Checking that B.concat works" propConcatPS-  , testProperty "Checking that hex conversion works" propHexConversion-  ]--propHexConversion :: String -> Bool-propHexConversion s =-    fromHex2PS (fromPS2Hex $ BC.pack s) == BC.pack s--propConcatPS :: [String] -> Bool-propConcatPS ss = concat ss == BC.unpack (B.concat $ map BC.pack ss)---- ------------------------------------------------------------------------- * LCS--- Here are a few quick tests of the shiftBoundaries function.--- ------------------------------------------------------------------------lcsTestSuite :: Test-lcsTestSuite = testGroup "LCS"- [ testCase "lcs code" (mapM_ assertFailure showLcsTests)- ]--showLcsTests :: [String]-showLcsTests = concatMap checkKnownShifts knownShifts-checkKnownShifts :: ([Int],[Int],String,String,[Int],[Int])-                   -> [String]-checkKnownShifts (ca, cb, sa, sb, ca', cb') = runST (-    do ca_arr <- newListArray (0, length ca) $ toBool (0:ca)-       cb_arr <- newListArray (0, length cb) $ toBool (0:cb)-       let p_a = listArray (0, length sa) $ B.empty:(toPS sa)-           p_b = listArray (0, length sb) $ B.empty:(toPS sb)-       shiftBoundaries ca_arr cb_arr p_a 1 1-       shiftBoundaries cb_arr ca_arr p_b 1 1-       ca_res <- fmap (fromBool . tail) $ getElems ca_arr-       cb_res <- fmap (fromBool . tail) $ getElems cb_arr-       return $ if ca_res  == ca' && cb_res == cb' then []-                else ["shiftBoundaries failed on "++sa++" and "++sb++" with "-                      ++(show (ca,cb))++" expected "++(show (ca', cb'))-                      ++" got "++(show (ca_res, cb_res))++"\n"])- where toPS = map (\c -> if c == ' ' then B.empty else BC.pack [c])-       toBool = map (>0)-       fromBool = map (\b -> if b then 1 else 0)--knownShifts :: [([Int],[Int],String,String,[Int],[Int])]-knownShifts =-  [([0,0,0],[0,1,0,1,0],"aaa","aaaaa",-    [0,0,0],[0,0,0,1,1]),-   ([0,1,0],[0,1,1,0],"cd ","c a ",-    [0,1,0],[0,1,1,0]),-   ([1,0,0,0,0,0,0,0,0],[1,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","dg{} ih{} if{}",-    [1,0,0,0,0,0,0,0,0],[1,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end-   ([0,0,0,0,0,0,0,0,0],[0,0,0,0,0,0,1,1,1,1,1,0,0,0], "fg{} if{}","fg{} ih{} if{}",-    [0,0,0,0,0,0,0,0,0],[0,0,0,0,0,1,1,1,1,1,0,0,0,0]), -- prefer empty line at end-   ([],[1,1],"","aa",[],[1,1]),-   ([1,1],[],"aa","",[1,1],[])]
− src/Darcs/Test/Patch.hs 
@@ -1,370 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-#if __GLASGOW_HASKELL__ >= 700-{-# LANGUAGE ImpredicativeTypes #-}-#endif-#if __GLASGOW_HASKELL__ >= 708-{-# LANGUAGE AllowAmbiguousTypes #-}-#endif---  Copyright (C) 2002-2005,2007 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--module Darcs.Test.Patch ( testSuite ) where--import Data.Maybe( isNothing )-import Test.Framework ( Test, testGroup )-import Test.Framework.Providers.HUnit ( testCase )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.QuickCheck.Arbitrary( Arbitrary )-import Test.QuickCheck( Testable )-import Test.HUnit ( assertBool )--import Darcs.Test.Util.TestResult ( TestResult, isOk, fromMaybe )-import Darcs.Test.Patch.Utils ( testConditional )--import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq ( unsafeCompare )-import Darcs.Witnesses.Show-import Darcs.Patch.Prim( PrimPatch, join, FromPrim, PrimOf, PrimPatchBase )-import Darcs.Patch.Prim.Class( PrimCanonize )-import qualified Darcs.Patch.Prim.V1 as V1 ( Prim )-import qualified Darcs.Patch.Prim.V3 as V3 ( Prim )-import qualified Darcs.Patch.V1 as V1-import Darcs.Patch.V2.Real ( isConsistent, isForward, RealPatch )-import Darcs.Patch.RepoPatch( RepoPatch )-import Darcs.Patch.Patchy ( Commute(..), Patchy )-import Darcs.Patch.Merge( Merge )-import Darcs.Patch.Apply( ApplyState )--import Darcs.Test.Patch.Arbitrary.Generic-import qualified Darcs.Test.Patch.Arbitrary.PrimV1 as P1-import qualified Darcs.Test.Patch.Arbitrary.PrimV3 as P3-import Darcs.Test.Patch.Arbitrary.Real-import Darcs.Test.Patch.Arbitrary.PatchV1 ()-import Darcs.Test.Patch.Arbitrary.PrimV1 ()-import Darcs.Test.Patch.RepoModel-import Darcs.Test.Patch.V3Model( V3Model )-import Darcs.Test.Patch.V1Model( V1Model )-import Darcs.Test.Patch.WithState( WithState, wsPatch, WithStartState )--import qualified Darcs.Test.Patch.Info--import qualified Darcs.Test.Patch.Examples.Set1 as Ex-import qualified Darcs.Test.Patch.Examples.Set2Unwitnessed as ExU--import Darcs.Test.Patch.Properties.Check( Check(..), checkAPatch )-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.GenericUnwitnessed as PropU--import qualified Darcs.Test.Patch.WSub as WSub--#include "gadts.h"--type instance ModelOf (FL prim) = ModelOf prim--#if __GLASGOW_HASKELL__ >= 700-type TestGenerator thing gen = (FORALL(t ctx) ((FORALL(xx yy) thing xx yy -> t) -> (gen ctx -> t)))-type TestCondition thing = (FORALL (yy zz) thing C(yy zz) -> Bool)-type TestCheck thing t = (FORALL (yy zz) thing C(yy zz) -> t)---- arbitraryThing :: (FORALL(xx yy) thing C(xx yy) -> t) -> (thing C(a b) -> t)-arbitraryThing :: x -> TestGenerator thing (thing x)-arbitraryThing _ f p = f p-#endif---- | Run a test function on a set of data, using HUnit. The test function should---   return @Nothing@ upon success and a @Just x@ upon failure.-testCases :: Show a => String               -- ^ The test name-             -> (a -> TestResult)  -- ^ The test function-             -> [a]                -- ^ The test data-             -> Test-testCases name test datas = testCase name (assertBool assertName res)-    where assertName = "Boolean assertion for \"" ++ name ++ "\""-          res        = and $ map (isOk . test) datas--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-  ]--unit_V2P1 :: [Test]-unit_V2P1 =-  [ testCases "join commute" (PropU.joinCommute WSub.join) ExU.primPermutables-  , testCases "prim recommute" (PropU.recommute WSub.commute) ExU.commutables-  , testCases "prim patch and inverse commute" (PropU.patchAndInverseCommute WSub.commute) ExU.commutables-  , testCases "prim inverses commute" (PropU.commuteInverses WSub.commute) ExU.commutables-  , testCases "FL prim recommute" (PropU.recommute WSub.commute) ExU.commutablesFL-  , testCases "FL prim patch and inverse commute" (PropU.patchAndInverseCommute WSub.commute) ExU.commutablesFL-  , testCases "FL prim inverses commute" (PropU.commuteInverses WSub.commute) $ ExU.commutablesFL-  , testCases "fails" (PropU.commuteFails WSub.commute) ([] :: [(V1.Prim WSub.:> V1.Prim) C(x y)])-  , testCases "read and show work on Prim" PropU.show_read ExU.primPatches-  , testCases "read and show work on RealPatch" PropU.show_read ExU.realPatches-  , testCases "example flattenings work" PropU.consistentTreeFlattenings ExU.realPatchLoopExamples-  , testCases "real merge input consistent" (PropU.mergeArgumentsConsistent isConsistent) ExU.realMergeables-  , testCases "real merge input is forward" (PropU.mergeArgumentsConsistent isForward) ExU.realMergeables-  , testCases "real merge output is forward" (PropU.mergeConsistent isForward) ExU.realMergeables-  , testCases "real merge output consistent" (PropU.mergeConsistent isConsistent) ExU.realMergeables-  , testCases "real merge either way" PropU.mergeEitherWay ExU.realMergeables-  , testCases "real merge and commute" PropU.mergeCommute ExU.realMergeables--  , testCases "real recommute" (PropU.recommute WSub.commute) ExU.realCommutables-  , testCases "real inverses commute" (PropU.commuteInverses WSub.commute) ExU.realCommutables-  , testCases "real permutivity" (PropU.permutivity WSub.commute) ExU.realNonduplicateTriples-  , testCases "real partial permutivity" (PropU.partialPermutivity WSub.commute) ExU.realNonduplicateTriples-  ]--instance PrimPatch prim => Check (RealPatch prim) where-  checkPatch p = return $ isNothing $ isConsistent p--instance Check V3.Prim where-  checkPatch _ = return True -- XXX--commuteReals :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y) -> Maybe ((RealPatch prim :> RealPatch prim) C(x y))-commuteReals = commute--qc_prim :: forall prim C(x y a) model.-           (PrimPatch prim, ArbitraryPrim prim, Show2 prim-           , model ~ ModelOf prim, RepoModel model-           , RepoState model ~ ApplyState (PrimOf prim)-           , Show1 (ModelOf prim)-           , Check prim, PrimPatchBase prim, PrimOf prim ~ prim-           , FromPrim prim-           , Show1 (prim C(a))-           , Show1 ((prim :> prim) C(a))-           , Show1 (WithState model prim C(a))-           , Arbitrary (Sealed ((prim :> prim) C(a)))-           , Arbitrary (Sealed ((prim :> prim :> prim) C(a)))-           , Arbitrary (Sealed (prim C(a)))-           , Arbitrary (Sealed (FL prim C(a)))-           , Arbitrary (Sealed ((FL prim :> FL prim) C(a)))-           , Arbitrary (Sealed (WithState model prim C(a)))-           , Arbitrary (Sealed (WithState model (FL prim) C(a)))-           , Arbitrary (Sealed2 (WithState model (prim :> prim)))-           , Arbitrary (Sealed ((WithState model (prim :> prim)) C(a)))-           , Arbitrary (Sealed ((WithState model (FL prim :> FL prim)) C(a)))-           ) => prim C(x y) -> [Test]-qc_prim _ =-  -- The following fails because of setpref patches...-  -- testProperty "prim inverse doesn't commute" (inverseDoesntCommute :: Prim -> Maybe Doc)-  [ testProperty "prim join effect preserving... "-    (unseal2 $ Prop.joinEffectPreserving join :: Sealed2 (WithState model (prim :> prim)) -> TestResult)-  ]-#if __GLASGOW_HASKELL__ >= 700-    ++ concat-  [ pair_properties            (undefined :: prim C(x y))    "arbitrary"    arbitraryThing'-  , pair_properties            (undefined :: FL prim C(x y)) "arbitrary FL" arbitraryThing'-  , coalesce_properties        (undefined :: prim C(x y))    "arbitrary"    arbitraryThing'-  , nonreal_commute_properties (undefined :: prim C(x y))    "arbitrary"    arbitraryThing'-  , nonreal_commute_properties (undefined :: FL prim C(x y)) "arbitrary FL" arbitraryThing'-  , patch_properties           (undefined :: prim C(x a))    "arbitrary"    arbitraryThing'-  , patch_properties           (undefined :: FL prim C(x a)) "arbitrary FL" arbitraryThing'-  , patch_repo_properties      (undefined :: prim C(x a))    "arbitrary"    arbitraryThing'-  , patch_repo_properties      (undefined :: FL prim C(x a)) "arbitrary FL" arbitraryThing'-  , pair_repo_properties       (undefined :: prim C(x a))    "arbitrary"    arbitraryThing'-  , pair_repo_properties       (undefined :: FL prim C(x a)) "arbitrary FL" arbitraryThing'-  ]-      where arbitraryThing' = arbitraryThing (undefined :: a) -- bind the witness for generator-#endif--qc_V2P1 :: [Test]-qc_V2P1 =-  [ testProperty "tree flattenings are consistent... "-    Prop.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)-  , testConditional "partial permutivity"-    (unseal $ P1.commuteTripleFromTree notDuplicatestriple)-    (unseal $ P1.commuteTripleFromTree $ Prop.partialPermutivity commuteReals)-  , testConditional "nontrivial permutivity"-    (unseal $ P1.commuteTripleFromTree (\t -> nontrivialTriple t && notDuplicatestriple t))-    (unseal $ P1.commuteTripleFromTree $ (Prop.permutivity commuteReals))-  ]--qc_V2 :: forall prim C(xx yy a). (PrimPatch prim, Show1 (ModelOf prim), RepoModel (ModelOf prim),-                                  Check (RealPatch prim), ArbitraryPrim prim, Show2 prim,-                                  RepoState (ModelOf prim) ~ ApplyState prim)-      => prim C(xx yy) -> [Test]-qc_V2 _ =-  [ testProperty "readPatch and showPatch work on RealPatch... "-    (unseal $ patchFromTree $ (Prop.show_read :: RealPatch prim C(x y) -> TestResult))-  , testProperty "readPatch and showPatch work on FL RealPatch... "-    (unseal2 $ (Prop.show_read :: FL (RealPatch prim) C(x y) -> TestResult))-  , testProperty "we can do merges using QuickCheck"-    (isNothing . (Prop.propIsMergeable ::-                     Sealed (WithStartState (ModelOf prim) (Tree prim))-                     -> Maybe (Tree (RealPatch prim) C(x))))-  ]-#if __GLASGOW_HASKELL__ >= 700-  ++ concat-  [ merge_properties   (undefined :: RealPatch prim C(x y)) "tree" mergePairFromTree-  , merge_properties   (undefined :: RealPatch prim C(x y)) "twfp" mergePairFromTWFP-  , pair_properties    (undefined :: RealPatch prim C(x y)) "tree" commutePairFromTree-  , pair_properties    (undefined :: RealPatch prim C(x y)) "twfp" commutePairFromTWFP-  , patch_properties   (undefined :: RealPatch prim C(x y)) "tree" patchFromTree-  -- , patch_repo_properties (undefined :: RealPatch prim C(x y)) "tree" arbitraryThing'-  ]-    where arbitraryThing' = arbitraryThing (undefined :: a)-#endif--#if __GLASGOW_HASKELL__ >= 700-properties :: forall thing gen. (Show1 gen, Arbitrary (Sealed gen)) =>-              TestGenerator thing gen-           -- -> forall xx yy. thing xx yy-           -> String -> String-           -> forall t. Testable t => [(String, TestCondition thing, TestCheck thing t)]-           -> [Test]-properties gen prefix genname tests =-  [ cond name condition check | (name, condition, check) <- tests ]-  where cond :: forall testable. Testable testable-             => String -> TestCondition thing -> TestCheck thing testable -> Test-        cond t c p =-          testConditional (prefix ++ " (" ++ genname ++ "): " ++ t) (unseal $ gen c) (unseal $ gen p)--type PropList what gen = String -> TestGenerator what gen -> [Test]--pair_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy 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            )-  ]--coalesce_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p, PrimPatch p)-                    => p x y -> PropList (p :> p :> p) gen-coalesce_properties _ genname gen =-  properties gen "commute" genname-  [ ("join commutes with commute", const True, Prop.joinCommute join) ]---- The following properties do not hold for "Real" patches (conflictors and--- duplicates, specifically) .-nonreal_commute_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p)-                           => 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_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p)-                 => p x y -> PropList p gen-patch_properties _ genname gen =-  properties gen "patch" genname-  [ ("inverse . inverse is id"  , const True       , Prop.invertSymmetry)-  ]--patch_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy p,-                                            RepoModel (ModelOf (PrimOf p)),-                                            RepoState (ModelOf (PrimOf p)) ~ ApplyState p)-                      => 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)-  ]--pair_repo_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen), Patchy 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 )-  ]--merge_properties :: forall p gen x y. (Show1 gen, Arbitrary (Sealed gen)-                                      , Patchy p, Merge 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        )-  ]-#endif--qc_V1P1 :: [Test]-qc_V1P1 =-  [-    testProperty "show and read work right" (unseal Prop.propReadShow)-  ]-  ++ Prop.checkSubcommutes Prop.subcommutesInverse "patch and inverse both commute"-  ++ Prop.checkSubcommutes Prop.subcommutesNontrivialInverse "nontrivial commutes are correct"-  ++ Prop.checkSubcommutes Prop.subcommutesFailure "inverses fail"-  ++-  [ testProperty "commuting by patch and its inverse is ok" Prop.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-  -- 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 "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--  ] -- the following properties are disabled, because they routinely lead to-    -- exponential cases, making the tests run for ever and ever; nevertheless,-    -- we would expect them to hold- {- ++ merge_properties (undefined :: V1.Patch Prim C(x y)) "tree" mergePairFromTree-    ++ merge_properties (undefined :: V1.Patch Prim C(x y)) "twfp" mergePairFromTWFP-    ++ commute_properties (undefined :: V1.Patch Prim C(x y)) "tree" commutePairFromTree-    ++ commute_properties (undefined :: V1.Patch Prim C(x y)) "twfp" commutePairFromTWFP -}---- | This is the big list of tests that will be run using testrunner.-testSuite :: [Test]-testSuite = [ testGroup "Darcs.Patch.Prim.V1" $ qc_prim (undefined :: V1.Prim C(x y))-            , testGroup "Darcs.Patch.V1 (using Prim.V1)" $ unit_V1P1 ++ qc_V1P1-            , testGroup "Darcs.Patch.V2 (using Prim.V1)" $ unit_V2P1 ++ qc_V2 (undefined :: V1.Prim C(x y)) ++ qc_V2P1-            , testGroup "Darcs.Patch.Prim.V3" $ qc_prim (undefined :: V3.Prim C(x y))-            , testGroup "Darcs.Patch.V2 (using Prim.V3)" $ qc_V2 (undefined :: V3.Prim C(x y))-            , Darcs.Test.Patch.Info.testSuite-            ]
− src/Darcs/Test/Patch/Arbitrary/Generic.hs 
@@ -1,231 +0,0 @@-{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}-{-# LANGUAGE CPP, UndecidableInstances, ScopedTypeVariables, MultiParamTypeClasses,-             FlexibleInstances, ViewPatterns #-}--#include "gadts.h"-module Darcs.Test.Patch.Arbitrary.Generic-       ( Tree(..), TreeWithFlattenPos(..), G2(..), ArbitraryPrim, NullPatch(..), RepoModel(..)-       , flattenOne, flattenTree, mapTree, sizeTree-       , commutePairFromTree, mergePairFromTree-       , commuteTripleFromTree, mergePairFromCommutePair-       , commutePairFromTWFP, mergePairFromTWFP, getPairs, getTriples-       , patchFromTree-       , canonizeTree-       , quickCheck-       ) where--import Control.Monad ( liftM )-import Test.QuickCheck-import Darcs.Test.Patch.WithState-import Darcs.Test.Patch.RepoModel-import Darcs.Test.Util.QuickCheck ( bSized )-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Unsafe-import Darcs.Witnesses.Ordered-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Patchy ( Invert(..), Commute(..) )-import Darcs.Patch.Prim ( PrimOf, PrimPatch, PrimPatchBase, FromPrim(..), PrimConstruct( anIdentity ) )-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.V2 ( RealPatch ) -- XXX this is more or less a hack---import Darcs.ColorPrinter ( errorDoc )---import Darcs.ColorPrinter ( traceDoc )-import Darcs.Witnesses.Show---import Printer ( greenText, ($$) )---- | Generate a patch to a certain state.-class ArbitraryStateIn s p where-  arbitraryStateIn :: s C(x) -> Gen (p C(x))--data Tree p C(x) where-   NilTree :: Tree p C(x)-   SeqTree :: p C(x y) -> Tree p C(y) -> Tree p C(x)-   ParTree :: Tree p C(x) -> Tree p C(x) -> Tree p C(x)--mapTree :: (FORALL(y z) p C(y z) -> q C(y z)) -> Tree p C(x) -> Tree q C(x)-mapTree _ NilTree = NilTree-mapTree f (SeqTree p t) = SeqTree (f p) (mapTree f t)-mapTree f (ParTree t1 t2) = ParTree (mapTree f t1) (mapTree f t2)--instance Show2 p => Show (Tree p C(x)) where-   showsPrec _ NilTree = showString "NilTree"-   showsPrec d (SeqTree a t) = showParen (d > appPrec) $ showString "SeqTree " .-                               showsPrec2 (appPrec + 1) a . showString " " .-                               showsPrec (appPrec + 1) t-   showsPrec d (ParTree t1 t2) = showParen (d > appPrec) $ showString "ParTree " .-                                 showsPrec (appPrec + 1) t1 . showString " " .-                                 showsPrec (appPrec + 1) t2--instance Show2 p => Show1 (Tree p) where-    showDict1 = ShowDictClass--instance Show2 p => Show1 (TreeWithFlattenPos p) where-    showDict1 = ShowDictClass--sizeTree :: Tree p C(x) -> Int-sizeTree NilTree = 0-sizeTree (SeqTree _ t) = 1 + sizeTree t-sizeTree (ParTree t1 t2) = 1 + sizeTree t1 + sizeTree t2---- newtype G1 l p C(x) = G1 { _unG1 :: l (p C(x)) }-newtype G2 l p C(x y) = G2 { unG2 :: l (p C(x y)) }--flattenTree :: (Merge p) => Tree p C(z) -> Sealed (G2 [] (FL p) C(z))-flattenTree NilTree = seal $ G2 $ return NilFL-flattenTree (SeqTree p t) = mapSeal (G2 . map (p :>:) . unG2) $ flattenTree t-flattenTree (ParTree (flattenTree -> Sealed gpss1) (flattenTree -> Sealed gpss2))-                            = seal $ G2 $-                              do ps1 <- unG2 gpss1-                                 ps2 <- unG2 gpss2-                                 ps2' :/\: ps1' <- return $ merge (ps1 :\/: ps2)-                                 -- We can't prove that the existential type in the result-                                 -- of merge will be the same for each pair of-                                 -- ps1 and ps2.-                                 map unsafeCoerceP [ps1 +>+ ps2', ps2 +>+ ps1']--instance ArbitraryState s p => ArbitraryStateIn s (Tree p) where-  -- Don't generate trees deeper than 6 with default QuickCheck size (0..99).-  -- Note if we don't put a non-zero lower bound the first generated trees will always have depth 0.-  arbitraryStateIn rm = bSized 3 0.035 9 $ \depth -> arbitraryTree rm depth---- | Generate a tree of patches, bounded by the depth @maxDepth@.-arbitraryTree :: ArbitraryState s p => s C(x) -> Int -> Gen (Tree p C(x))-arbitraryTree rm depth-    | depth == 0 = return NilTree-                      -- Note a probability of N for NilTree would imply ~(100*N)% of empty trees.-                      -- For the purpose of this module empty trees are useless, but even when-                      -- NilTree case is omitted there is still a small percentage of empty trees-                      -- due to the generation of null-patches (empty-hunks) and the use of canonizeTree.-    | otherwise  = frequency [(1, do Sealed (WithEndState p rm') <- arbitraryState rm-                                     t <- arbitraryTree rm' (depth - 1)-                                     return (SeqTree p t))-                             ,(3, do t1 <- arbitraryTree rm (depth - 1)-                                     t2 <- arbitraryTree rm (depth - 1)-                                     return (ParTree t1 t2))]---class NullPatch p where-  nullPatch :: p C(x y) -> EqCheck C(x y)--class (ArbitraryState (ModelOf prim) prim, NullPatch prim, PrimPatch prim, RepoModel (ModelOf prim)) => ArbitraryPrim prim---- canonize a tree, removing any dead branches-canonizeTree :: NullPatch p => Tree p C(x) -> Tree p C(x)-canonizeTree NilTree = NilTree-canonizeTree (ParTree t1 t2)-    | NilTree <- canonizeTree t1 = canonizeTree t2-    | NilTree <- canonizeTree t2 = canonizeTree t1-    | otherwise = ParTree (canonizeTree t1) (canonizeTree t2)-canonizeTree (SeqTree p t) | IsEq <- nullPatch p = canonizeTree t-                           | otherwise = SeqTree p (canonizeTree t)---instance (RepoModel model, ArbitraryPrim prim, model ~ ModelOf prim,-          ArbitraryState model prim) => Arbitrary (Sealed (WithStartState model (Tree prim))) where-  arbitrary = do repo <- aSmallRepo-                 Sealed (WithStartState rm tree) <--                     liftM (seal . WithStartState repo) (arbitraryStateIn repo)-                 return $ Sealed $ WithStartState rm (canonizeTree tree)--flattenOne :: (FromPrim p, Merge p) => Tree (PrimOf p) C(x) -> Sealed (FL p C(x))-flattenOne NilTree = seal NilFL-flattenOne (SeqTree p (flattenOne -> Sealed ps)) = seal (fromPrim p :>: ps)-flattenOne (ParTree (flattenOne -> Sealed ps1) (flattenOne -> Sealed ps2)) =-    --traceDoc (greenText "flattening two parallel series: ps1" $$ showPatch ps1 $$-    --          greenText "ps2" $$ showPatch ps2) $-    case merge (ps1 :\/: ps2) of-      ps2' :/\: _ -> seal (ps1 +>+ ps2')--data TreeWithFlattenPos p C(x) = TWFP Int (Tree p C(x))--commutePairFromTWFP :: (FromPrim p, Merge p, PrimPatchBase p)-                    => (FORALL (y z) (p :> p) C(y z) -> t)-                    -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) C(x) -> t)-commutePairFromTWFP handlePair (WithStartState _ (TWFP n t))-    = unseal2 handlePair $-      let xs = unseal getPairs (flattenOne t)-      in if length xs > n && n >= 0 then xs!!n else seal2 (fromPrim anIdentity :> fromPrim anIdentity)--commutePairFromTree :: (FromPrim p, Merge p, PrimPatchBase p)-                    => (FORALL (y z) (p :> p) C(y z) -> t)-                    -> (WithStartState model (Tree (PrimOf p)) C(x) -> t)-commutePairFromTree handlePair (WithStartState _ t)-   = unseal2 handlePair $-     case flattenOne t of-       Sealed ps ->-         let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $-                 getPairs ps-         in if null xs then seal2 (fromPrim anIdentity :> fromPrim anIdentity) else last xs--commuteTripleFromTree :: (FromPrim p, Merge p, PrimPatchBase p)-                      => (FORALL (y z) (p :> p :> p) C(y z) -> t)-                      -> (WithStartState model (Tree (PrimOf p)) C(x) -> t)-commuteTripleFromTree handle (WithStartState _ t)-   = unseal2 handle $-     case flattenOne t of-       Sealed ps ->-         let xs = --traceDoc (greenText "I'm flattening one to get:" $$ showPatch ps) $-                  getTriples ps-         in if null xs-            then seal2 (fromPrim anIdentity :> fromPrim anIdentity :> fromPrim anIdentity)-            else last xs--mergePairFromCommutePair :: (Commute p, Invert p)-                         => (FORALL (y z) (p :\/: p) C(y z) -> t)-                         -> (FORALL (y z) (p :>   p) C(y z) -> t)-mergePairFromCommutePair handlePair (a :> b)- = case commute (a :> b) of-     Just (b' :> _) -> handlePair (a :\/: b')-     Nothing -> handlePair (b :\/: b)---- impredicativity problems mean we can't use (.) in the definitions below--mergePairFromTWFP :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)-                  => (FORALL (y z) (p :\/: p) C(y z) -> t)-                  -> (WithStartState model (TreeWithFlattenPos (PrimOf p)) C(x) -> t)-mergePairFromTWFP x = commutePairFromTWFP (mergePairFromCommutePair x)--mergePairFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)-                  => (FORALL (y z) (p :\/: p) C(y z) -> t)-                  -> (WithStartState model (Tree (PrimOf p)) C(x) -> t)-mergePairFromTree x = commutePairFromTree (mergePairFromCommutePair x)--patchFromCommutePair :: (Commute p, Invert p)-                     => (FORALL (y z) p C(y z) -> t)-                     -> (FORALL (y z) (p :> p) C(y z) -> t)-patchFromCommutePair handle (_ :> b) = handle b--patchFromTree :: (FromPrim p, Merge p, Invert p, PrimPatchBase p)-              => (FORALL (y z) p C(y z) -> t)-              -> (WithStartState model (Tree (PrimOf p)) C(x) -> t)-patchFromTree x = commutePairFromTree (patchFromCommutePair x)---instance Show2 p => Show (TreeWithFlattenPos p C(x)) where-   showsPrec d (TWFP n t) = showParen (d > appPrec) $ showString "TWFP " .-                            showsPrec (appPrec + 1) n . showString " " .-                            showsPrec1 (appPrec + 1) t--getPairs :: FL p C(x y) -> [Sealed2 (p :> p)]-getPairs NilFL = []-getPairs (_:>:NilFL) = []-getPairs (a:>:b:>:c) = seal2 (a:>b) : getPairs (b:>:c)--getTriples :: FL p C(x y) -> [Sealed2 (p :> p :> p)]-getTriples NilFL = []-getTriples (_:>:NilFL) = []-getTriples (_:>:_:>:NilFL) = []-getTriples (a:>:b:>:c:>:d) = seal2 (a:>b:>c) : getTriples (b:>:c:>:d)--instance (ArbitraryPrim prim, RepoModel (ModelOf prim), model ~ ModelOf prim,-          ArbitraryState model prim)-         => Arbitrary (Sealed (WithStartState model (TreeWithFlattenPos prim))) where-   arbitrary = do Sealed (WithStartState rm t) <- arbitrary-                  let num = unseal (length . getPairs) (flattenOneRP t)-                  if num == 0 then return $ Sealed $ WithStartState rm $ TWFP 0 NilTree-                    else do n <- choose (0, num - 1)-                            return $ Sealed $ WithStartState rm $ TWFP n t-                    where -- just used to get the length. In principle this should be independent of the patch type.-                          flattenOneRP :: Tree prim C(x) -> Sealed (FL (RealPatch prim) C(x))-                          flattenOneRP = flattenOne-
− src/Darcs/Test/Patch/Arbitrary/PatchV1.hs 
@@ -1,288 +0,0 @@--- Copyright (C) 2002-2003,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances #-}--#include "gadts.h"--module Darcs.Test.Patch.Arbitrary.PatchV1 () where--import Prelude hiding ( pi )-import System.IO.Unsafe ( unsafePerformIO )-import Test.QuickCheck-import Control.Applicative-import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM )--import Darcs.Patch.Info ( PatchInfo, patchinfo )-import qualified Data.ByteString as B ( ByteString )-import qualified Data.ByteString.Char8 as BC ( pack )--import Darcs.Patch ( addfile, adddir, move,-                     hunk, tokreplace, binary,-                     changepref, invert, merge )-import Darcs.Patch.V1 ()-import qualified Darcs.Patch.V1.Core as V1 ( Patch(..) )-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.Prim.V1.Core ( Prim(..) )-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) )-import Darcs.Witnesses.Unsafe---- This definitely feels a bit weird to be importing Properties here, and--- 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 )--#include "impossible.h"--type Patch = V1.Patch Prim--class ArbitraryP p where-    arbitraryP :: Gen (Sealed (p C(x)))--{--TODO: there is a lot of overlap in testing between between this module-and Darcs.Test.Patch.QuickCheck--This module tests Prim and V1 patches, and Darcs.Test.Patch.QuickCheck-tests Prim and V2 patches--This module's generator covers a wider set of patch types, but is less-likely to generate conflicts than Darcs.Test.Patch.QuickCheck.--Until this is cleaned up, we take some care that the Arbitrary instances-do not overlap and are only used for tests from the respective-modules.--(There are also tests in other modules that probably depend on the-Arbitrary instances in this module.)--}--instance Arbitrary (Sealed (Prim C(x))) where-    arbitrary = arbitraryP--instance Arbitrary (Sealed (FL Patch C(x))) where-    arbitrary = arbitraryP---- instance Arbitrary (Sealed2 (Prim :> Prim)) where-    -- arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch)) where-    arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch :\/: FL Patch)) where-    arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch :> FL Patch)) where-    arbitrary = unseal Sealed2 <$> arbitraryP--instance Arbitrary (Sealed2 (FL Patch :> FL Patch :> FL Patch)) where-    arbitrary = unseal Sealed2 <$> arbitraryP---instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :> p2) where-    arbitraryP = do Sealed p1 <- arbitraryP-                    Sealed p2 <- arbitraryP-                    return (Sealed (p1 :> p2))--instance (ArbitraryP p1, ArbitraryP p2) => ArbitraryP (p1 :\/: p2) where-    arbitraryP = do Sealed p1 <- arbitraryP-                    Sealed p2 <- arbitraryP-                    return (Sealed (unsafeCoercePEnd p1 :\/: p2))--instance ArbitraryP (FL Patch) where-    arbitraryP = sized arbpatch--instance ArbitraryP Prim where-    arbitraryP = onepatchgen--hunkgen :: Gen (Sealed (Prim C(x)))-hunkgen = do-  i <- frequency [(1,choose (0,5)),(1,choose (0,35)),-                  (2,return 0),(3,return 1),(2,return 2),(1,return 3)]-  j <- frequency [(1,choose (0,5)),(1,choose (0,35)),-                  (2,return 0),(3,return 1),(2,return 2),(1,return 3)]-  if i == 0 && j == 0 then hunkgen-    else Sealed <$>-            liftM4 hunk filepathgen linenumgen-                (replicateM i filelinegen)-                (replicateM j filelinegen)--tokreplacegen :: Gen (Sealed (Prim C(x)))-tokreplacegen = do-  f <- filepathgen-  o <- tokengen-  n <- tokengen-  if o == n-     then return $ Sealed $ tokreplace f "A-Za-z" "old" "new"-     else return $ Sealed $ tokreplace f "A-Za-z_" o n--twofilegen :: (FORALL(y) FilePath -> FilePath -> Prim C(x y)) -> Gen (Sealed (Prim C(x)))-twofilegen p = do-  n1 <- filepathgen-  n2 <- filepathgen-  if n1 /= n2 && checkAPatch (p n1 n2)-     then return $ Sealed $ p n1 n2-     else twofilegen p--chprefgen :: Gen (Sealed (Prim C(x)))-chprefgen = do-  f <- oneof [return "color", return "movie"]-  o <- tokengen-  n <- tokengen-  if o == n then return $ Sealed $ changepref f "old" "new"-            else return $ Sealed $ changepref f o n--simplepatchgen :: Gen (Sealed (Prim C(x)))-simplepatchgen = frequency [(1,liftM (Sealed . addfile) filepathgen),-                            (1,liftM (Sealed . adddir) filepathgen),-                            (1,liftM3 (\x y z -> Sealed (binary x y z)) filepathgen arbitrary arbitrary),-                            (1,twofilegen move),-                            (1,tokreplacegen),-                            (1,chprefgen),-                            (7,hunkgen)-                           ]--onepatchgen :: Gen (Sealed (Prim C(x)))-onepatchgen = oneof [simplepatchgen, mapSeal (invert . unsafeCoerceP) `fmap` simplepatchgen]--norecursgen :: Int -> Gen (Sealed (FL Patch C(x)))-norecursgen 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen-norecursgen n = oneof [mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen,flatcompgen n]--arbpatch :: Int -> Gen (Sealed (FL Patch C(x)))-arbpatch 0 = mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen-arbpatch n = frequency [(3,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen),-                        (2,flatcompgen n),-                        (0,rawMergeGen n),-                        (0,mergegen n),-                        (1,mapSeal (\p -> V1.PP p :>: NilFL) `fmap` onepatchgen)-                       ]---- | Generate an arbitrary list of at least one element-unempty :: Arbitrary a => Gen [a]-unempty = do-  a <- arbitrary-  as <- arbitrary-  return (a:as)--rawMergeGen :: Int -> Gen (Sealed (FL Patch C(x)))-rawMergeGen n =   do Sealed p1 <- arbpatch len-                     Sealed p2 <- arbpatch len-                     if checkAPatch (invert p1:>:p2:>:NilFL) &&-                        checkAPatch (invert p2:>:p1:>:NilFL)-                        then case merge (p2 :\/: p1) of-                             _ :/\: p2' -> return (Sealed (unsafeCoercePStart p2'))-                        else rawMergeGen n-    where len = if n < 15 then n`div`3 else 3--mergegen :: Int -> Gen (Sealed (FL Patch C(x)))-mergegen n = do-  Sealed p1 <- norecursgen len-  Sealed p2 <- norecursgen len-  if checkAPatch (invert p1:>:p2:>:NilFL) &&-         checkAPatch (invert p2:>:p1:>:NilFL)-     then case merge (p2:\/:p1) of-          _ :/\: p2' ->-              if checkAPatch (p1+>+p2')-              then return $ Sealed $ p1+>+p2'-              else impossible-     else mergegen n-  where len = if n < 15 then n`div`3 else 3--arbpi :: Gen PatchInfo-arbpi = do n <- unempty-           a <- unempty-           l <- unempty-           d <- unempty-           return $ unsafePerformIO $ patchinfo n d a l--instance Arbitrary PatchInfo where-    arbitrary = arbpi--instance Arbitrary B.ByteString where-    arbitrary = liftM BC.pack arbitrary--flatlistgen :: Int -> Gen (Sealed (FL Patch C(x)))-flatlistgen 0 = return $ Sealed NilFL-flatlistgen n = do Sealed x <- onepatchgen-                   Sealed xs <- flatlistgen (n-1)-                   return (Sealed (V1.PP x :>: xs))--flatcompgen :: Int -> Gen (Sealed (FL Patch C(x)))-flatcompgen n = do-  Sealed ps <- flatlistgen n-  let myp = regularizePatches $ ps-  if checkAPatch myp-     then return $ Sealed myp-     else flatcompgen n---- resize to size 25, that means we'll get line numbers no greater--- than 1025 using QuickCheck 2.1-linenumgen :: Gen Int-linenumgen = frequency [(1,return 1), (1,return 2), (1,return 3),-                    (3,liftM (\n->1+abs n) (resize 25 arbitrary)) ]--tokengen :: Gen String-tokengen = oneof [return "hello", return "world", return "this",-                  return "is", return "a", return "silly",-                  return "token", return "test"]--toklinegen :: Gen String-toklinegen = liftM unwords $ replicateM 3 tokengen--filelinegen :: Gen B.ByteString-filelinegen = liftM BC.pack $-              frequency [(1,map fromSafeChar `fmap` arbitrary),(5,toklinegen),-                         (1,return ""), (1,return "{"), (1,return "}") ]--filepathgen :: Gen String-filepathgen = liftM fixpath badfpgen--fixpath :: String -> String-fixpath "" = "test"-fixpath p = fpth p--fpth :: String -> String-fpth ('/':'/':cs) = fpth ('/':cs)-fpth (c:cs) = c : fpth cs-fpth [] = []--newtype SafeChar = SS Char-instance Arbitrary SafeChar where-    arbitrary = oneof $ map (return . SS) (['a'..'z']++['A'..'Z']++['1'..'9']++"0")--fromSafeChar :: SafeChar -> Char-fromSafeChar (SS s) = s--badfpgen :: Gen String-badfpgen =  frequency [(1,return "test"), (1,return "hello"), (1,return "world"),-                       (1,map fromSafeChar `fmap` arbitrary),-                       (1,liftM2 (\a b-> a++"/"++b) filepathgen filepathgen) ]--regularizePatches :: FL Patch C(x y) -> FL Patch C(x y)-regularizePatches patches = rpint (unsafeCoerceP NilFL) patches-    where -- this reverses the list, which seems odd and causes-          -- the witness unsafety-          rpint :: FL Patch C(x y) -> FL Patch C(a b) -> FL Patch C(x y)-          rpint ok_ps NilFL = ok_ps-          rpint ok_ps (p:>:ps) =-            if checkAPatch (unsafeCoerceP p:>:ok_ps)-            then rpint (unsafeCoerceP p:>:ok_ps) ps-            else rpint ok_ps ps-
− src/Darcs/Test/Patch/Arbitrary/PrimV1.hs 
@@ -1,394 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Test.Patch.Arbitrary.PrimV1 where--import qualified Darcs.Test.Patch.Arbitrary.Generic as T-     ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP-     , mergePairFromTree, mergePairFromTWFP-     , patchFromTree )-import Darcs.Test.Patch.Arbitrary.Generic-import Darcs.Test.Patch.RepoModel--import Control.Monad ( liftM )-import Test.QuickCheck-import Darcs.Test.Patch.WithState-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Unsafe-import Darcs.Witnesses.Ordered--- import Darcs.Witnesses.Show-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.Prim.V1.Core ( FilePatchType( Hunk, TokReplace ), Prim( FP ), isIdentity )-import Darcs.Patch.RepoPatch ( RepoPatch )-import Darcs.Patch.FileHunk( IsHunk( isHunk ), FileHunk(..) )--import Darcs.Test.Patch.V1Model-import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )--import Darcs.Commands.Replace ( defaultToks )-import Darcs.Patch.Prim--import Control.Applicative ( (<$>) )-import qualified Data.ByteString.Char8 as BC-import Data.Maybe ( isJust )--#include "gadts.h"-#include "impossible.h"--patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) p C(y z) -> t) -> WithStartState V1Model (Tree Prim) C(x) -> t-patchFromTree = T.patchFromTree--mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :\/: p) C(y z) -> t) -> WithStartState V1Model (Tree Prim) C(x) -> t-mergePairFromTree = T.mergePairFromTree--mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :\/: p) C(y z) -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) C(x) -> t-mergePairFromTWFP = T.mergePairFromTWFP--commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p) C(y z) -> t) -> WithStartState V1Model (TreeWithFlattenPos Prim) C(x) -> t-commutePairFromTWFP = T.commutePairFromTWFP--commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p) C(y z) -> t) -> WithStartState V1Model (Tree Prim) C(x) -> t-commutePairFromTree = T.commutePairFromTree--commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p :> p) C(y z) -> t) -> WithStartState V1Model (Tree Prim) C(x) -> t-commuteTripleFromTree = T.commuteTripleFromTree--nonEmptyHunk :: (IsHunk p) => p C(x y) -> Bool-nonEmptyHunk p-  | Just (FileHunk _ _ [] []) <- isHunk p = False-  | otherwise                             = True--nonEmptyHunksPair :: (IsHunk p) => (p :> p) C(x y) -> Bool-nonEmptyHunksPair (p1 :> p2) = nonEmptyHunk p1 && nonEmptyHunk p2--nonEmptyHunksTriple :: (IsHunk p) => (p :> p :> p) C(x y) -> Bool-nonEmptyHunksTriple (p1 :> p2 :> p3) = nonEmptyHunk p1 && nonEmptyHunk p2 && nonEmptyHunk p3--nonEmptyHunksFLPair :: (IsHunk p) => (FL p :> FL p) C(x y) -> Bool-nonEmptyHunksFLPair (ps :> qs) = allFL nonEmptyHunk ps && allFL nonEmptyHunk qs--type instance ModelOf Prim = V1Model-instance ArbitraryPrim Prim--instance NullPatch Prim where-  nullPatch (FP _ fp) = nullPatch fp-  nullPatch p | IsEq <- isIdentity p = IsEq-  nullPatch _ = NotEq--instance NullPatch FilePatchType where-  nullPatch (Hunk _ [] []) = unsafeCoerceP IsEq -- is this safe?-  nullPatch _ = NotEq--instance Arbitrary (Sealed2 (FL (WithState V1Model Prim))) where-  arbitrary = do repo <- ourSmallRepo-                 liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo---- instance Show1 (TreeWithFlattenPos Prim) where---   showDict1 = ShowDictClass---- WithState and propFail are handy for debugging arbitrary code-propFail :: Int -> Tree Prim C(x) -> Bool-propFail n xs = sizeTree xs < n--------------------------------------------------------------------------- * QuickCheck generators--------------------------------------------------------------------------- ** FilePatchType generators--aHunk :: FORALL(x y) Content -> Gen (FilePatchType C(x y))-aHunk content- = sized $ \n ->-     do pos <- choose (1, contentLen+1)-        let prefixLen = pos-1-            restLen   = contentLen-prefixLen-        oldLen <- frequency-                      [ (75, choose (0, min restLen n))-                        -- produces small hunks common in real editing-                      , (25, choose (0, min 10 restLen))-                      ]-        -- newLen choice aims to cover all possibilities, that is,-        -- remove less/the same/more than added and empty the file.-        newLen <- frequency-                      [ ( 54-                        , choose (1,min 1 n)-                        )-                      , ( if oldLen /= 0 then 42 else 0-                        , choose (1,min 1 oldLen)-                        )-                      , ( if oldLen /= 0 then 2 else 0-                        , return oldLen-                        )-                      , ( if oldLen /= 0 then 2 else 0-                        , return 0-                        )-                      ]-        new <- vectorOf newLen aLine-        let old = take oldLen $ drop prefixLen $ content-        return $ Hunk pos old new-  where-      contentLen = length content--aTokReplace :: FORALL(x y) Content -> Gen (FilePatchType C(x y))-aTokReplace []-  = do w <- vectorOf 1 alpha-       w' <- vectorOf 1 alpha-       return $ TokReplace defaultToks w w'-aTokReplace content-  = do let fileWords = concatMap BC.words content-       wB <- elements fileWords-       w' <- alphaBS `notIn` fileWords-       return $ TokReplace defaultToks (BC.unpack wB) (BC.unpack w')-  where-      alphaBS = do x <- alpha; return $ BC.pack [x]--------------------------------------------------------------------------- ** Prim generators--aHunkP :: FORALL(x y) (AnchoredPath,File) -> Gen (Prim C(x y))-aHunkP (path,file)-  = do Hunk pos old new <- aHunk content-       return $ hunk (ap2fp path) pos old new-  where-      content = fileContent file--aTokReplaceP :: FORALL (x y) (AnchoredPath,File) -> Gen (Prim C(x y))-aTokReplaceP (path,file)-  = do TokReplace tokchars old new <- aTokReplace content-       return $ tokreplace (ap2fp path) tokchars old new-  where-      content = fileContent file--anAddFileP :: FORALL (x y) (AnchoredPath,Dir) -> Gen (Prim C(x y))-anAddFileP (path,dir)-  = do newFilename <- aFilename `notIn` existing-       let newPath = path `appendPath` newFilename-       return $ addfile (ap2fp newPath)-  where-      existing = map fst $ filterFiles $ dirContent dir--aRmFileP :: FORALL (x y) AnchoredPath   -- ^ Path of an empty file-                          -> Prim C(x y)-aRmFileP path = rmfile (ap2fp path)--anAddDirP :: FORALL (x y) (AnchoredPath,Dir) -> Gen (Prim C(x y))-anAddDirP (path,dir)-  = do newDirname <- aDirname `notIn` existing-       let newPath = path `appendPath` newDirname-       return $ adddir (ap2fp newPath)-  where-      existing = map fst $ filterDirs $ dirContent dir--aRmDirP :: FORALL (x y) AnchoredPath    -- ^ Path of an empty directory-                        -> Prim C(x y)-aRmDirP path = rmdir (ap2fp path)--aMoveP :: FORALL (x y) Gen Name -> AnchoredPath -> (AnchoredPath,Dir) -> Gen (Prim C(x y))-aMoveP nameGen oldPath (dirPath,dir)-  = do newName <- nameGen `notIn` existing-       let newPath = dirPath `appendPath` newName-       return $ move (ap2fp oldPath) (ap2fp newPath)-  where-      existing = map fst $ dirContent dir---- | Generates any type of 'Prim' patch, except binary and setpref patches.-aPrim :: FORALL(x y) V1Model C(x) -> Gen (WithEndState V1Model (Prim C(x)) C(y))-aPrim repo-  = do mbFile <- maybeOf repoFiles-       mbEmptyFile <- maybeOf $ filter (isEmpty . snd) repoFiles-       dir  <- elements (rootDir:repoDirs)-       mbOldDir <- maybeOf repoDirs-       mbEmptyDir <- maybeOf $ filter (isEmpty . snd) repoDirs-       patch <- frequency-                  [ ( if isJust mbFile then 12 else 0-                    , aHunkP $ fromJust mbFile-                    )-                  , ( if isJust mbFile then 6 else 0-                    , aTokReplaceP $ fromJust mbFile-                    )-                  , ( 2-                    , anAddFileP dir-                    )-                  , ( if isJust mbEmptyFile then 12 else 0-                    , return $ aRmFileP $ fst $ fromJust mbEmptyFile-                    )-                  , ( 2-                    , anAddDirP dir-                    )-                  , ( if isJust mbEmptyDir then 10 else 0-                    , return $ aRmDirP $ fst $ fromJust mbEmptyDir-                    )-                  , ( if isJust mbFile then 3 else 0-                    , aMoveP aFilename (fst $ fromJust mbFile) dir-                    )-                  , let oldPath = fst $ fromJust mbOldDir in-                    ( if isJust mbOldDir-                         && not (oldPath `isPrefix` fst dir)-                        then 4 else 0-                    , aMoveP aDirname oldPath dir-                    )-                  ]-       let repo' = unFail $ repoApply repo patch-       return $ WithEndState patch repo'-  where-      repoItems = list repo-      repoFiles = filterFiles repoItems-      repoDirs  = filterDirs repoItems-      rootDir   = (anchoredRoot,root repo)--{- [COVERAGE OF aPrim]--  PLEASE,-  if you change something that may affect the coverage of aPrim then-      a) recalculate it, or if that is not possible;-      b) indicate the need to do it.--  Patch type-  -----------  42% hunk-  22% tokreplace-  14% move-   6% rmdir-   6% addfile-   6% adddir-   4% rmfile--}--------------------------------------------------------------------------- *** Pairs of primitive patches---- Try to generate commutable pairs of hunks-hunkPairP :: FORALL(x y) (AnchoredPath,File) -> Gen ((Prim :> Prim) C(x y))-hunkPairP (path,file)-  = do h1@(Hunk l1 old1 new1) <- aHunk content-       (delta, content') <- selectChunk h1 content-       Hunk l2' old2 new2 <- aHunk content'-       let l2 = l2'+delta-       return (hunk fpPath l1 old1 new1 :> hunk fpPath l2 old2 new2)-  where-      content = fileContent file-      fpPath = ap2fp path-      selectChunk (Hunk l old new) content_-        = elements [prefix, suffix]-        where-            start = l - 1-            prefix = (0, take start content_)-            suffix = (start + length new, drop (start + length old) content_)-      selectChunk _ _ = impossible--aPrimPair :: FORALL(x y) V1Model C(x) -> Gen (WithEndState V1Model ((Prim :> Prim) C(x)) C(y))-aPrimPair repo-  = do mbFile <- maybeOf repoFiles-       frequency-          [ ( if isJust mbFile then 1 else 0-            , do p1 :> p2 <- hunkPairP $ fromJust mbFile-                 let repo'  = unFail $ repoApply repo p1-                     repo'' = unFail $ repoApply repo' p2-                 return $ WithEndState (p1 :> p2) repo''-            )-          , ( 1-            , do Sealed wesP <- arbitraryState repo-                 return $ unsafeCoerceP1 wesP-            )-          ]-  where-      repoItems = list repo-      repoFiles = filterFiles repoItems--{- [COVERAGE OF aPrimPair]--  PLEASE,-  if you change something that may affect the coverage of aPrimPair then-      a) recalculate it, or if that is not possible;-      b) indicate the need to do it.--  Rate of ommutable pairs-  ------------------------  67% commutable--  Commutable coverage (for 1000 tests)-  --------------------  21% hunks-B-  20% hunks-A-  14% file:>dir-  12% file:>move-   8% trivial-FP-   8% hunk:>tok-   4% hunks-D-   3% tok:>tok-   2% hunks-C-   1% move:>move-   1% dir:>move-   1% dir:>dir-   0% emptyhunk:>file--}--------------------------------------------------------------------------- Arbitrary instances--ourSmallRepo :: Gen (V1Model C(x))-ourSmallRepo = aSmallRepo--instance ArbitraryState V1Model Prim where-  arbitraryState s = seal <$> aPrim s---instance Arbitrary (Sealed2 Prim) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed2 (Prim :> Prim)) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp _ <- aPrimPair repo-                 return $ seal2 pp--instance Arbitrary (Sealed ((Prim :> Prim) C(a))) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp _ <- aPrimPair repo-                 return $ seal pp--instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim) C(a))) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim :> FL Prim) C(a))) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V1Model Prim)) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V1Model Prim C(a))) where-  arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed (WithState V1Model (FL Prim) C(a))) where-  arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V1Model (Prim :> Prim))) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal2 $ WithState repo pp repo'--instance Arbitrary (Sealed (WithState V1Model (Prim :> Prim) a)) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal $ WithState repo pp repo'---instance Arbitrary (Sealed2 (WithState V1Model (FL Prim))) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V1Model (FL Prim :> FL Prim))) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V1Model (FL Prim :> FL Prim) a)) where-  arbitrary = makeWSGen ourSmallRepo
− src/Darcs/Test/Patch/Arbitrary/PrimV3.hs 
@@ -1,259 +0,0 @@--- TODO: Remove these warning disabling flags...-{-# OPTIONS_GHC -w #-}-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}-module Darcs.Test.Patch.Arbitrary.PrimV3 where--import qualified Darcs.Test.Patch.Arbitrary.Generic as T-     ( commuteTripleFromTree, commutePairFromTree, commutePairFromTWFP-     , mergePairFromTree, mergePairFromTWFP-     , patchFromTree )-import Darcs.Test.Patch.Arbitrary.Generic-import Darcs.Test.Patch.RepoModel--import Control.Monad ( liftM )-import Test.QuickCheck-import Darcs.Test.Patch.WithState-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Unsafe-import Darcs.Witnesses.Ordered--- import Darcs.Witnesses.Show-import Darcs.Patch.Prim.V3 ()-import Darcs.Patch.Prim.V3.Core ( Prim(..), Location, Hunk(..), UUID(..) )-import Darcs.Patch.RepoPatch ( RepoPatch )--import Darcs.Test.Patch.V3Model-import Darcs.Test.Util.QuickCheck ( alpha, notIn, maybeOf )--import Darcs.Commands.Replace ( defaultToks )-import Darcs.Patch.Prim--import Control.Applicative ( (<$>) )-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString as BS-import Data.Maybe ( isJust )-import qualified Data.Map as M-import Storage.Hashed.Hash( Hash(..) )--#include "gadts.h"-#include "impossible.h"--patchFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) p C(y z) -> t) -> WithStartState V3Model (Tree Prim) C(x) -> t-patchFromTree = T.patchFromTree--mergePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :\/: p) C(y z) -> t) -> WithStartState V3Model (Tree Prim) C(x) -> t-mergePairFromTree = T.mergePairFromTree--mergePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :\/: p) C(y z) -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) C(x) -> t-mergePairFromTWFP = T.mergePairFromTWFP--commutePairFromTWFP :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p) C(y z) -> t) -> WithStartState V3Model (TreeWithFlattenPos Prim) C(x) -> t-commutePairFromTWFP = T.commutePairFromTWFP--commutePairFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p) C(y z) -> t) -> WithStartState V3Model (Tree Prim) C(x) -> t-commutePairFromTree = T.commutePairFromTree--commuteTripleFromTree :: (RepoPatch p, PrimOf p ~ Prim) => (FORALL(y z) (p :> p :> p) C(y z) -> t) -> WithStartState V3Model (Tree Prim) C(x) -> t-commuteTripleFromTree = T.commuteTripleFromTree--type instance ModelOf Prim = V3Model-instance ArbitraryPrim Prim--hunkIdentity (Hunk _ old new) | old == new = unsafeCoerceP IsEq-hunkIdentity _ = NotEq--instance NullPatch Prim where-  nullPatch (BinaryHunk _ x) = hunkIdentity x-  nullPatch (TextHunk _ x) = hunkIdentity x-  nullPatch _ = NotEq--instance Arbitrary (Sealed2 (FL (WithState V3Model Prim))) where-  arbitrary = do repo <- ourSmallRepo-                 liftM (unseal (seal2 . wesPatch)) $ arbitraryState repo---- instance Show1 (TreeWithFlattenPos Prim) where---   showDict1 = ShowDictClass---- WithState and propFail are handy for debugging arbitrary code-propFail :: Int -> Tree Prim C(x) -> Bool-propFail n xs = sizeTree xs < n--------------------------------------------------------------------------- * QuickCheck generators--aHunk :: FORALL(x y) BS.ByteString -> Gen (Hunk C(x y))-aHunk content- = sized $ \n ->-     do pos <- choose (0, BS.length content)-        let prefixLen = pos-            restLen   = BS.length content - prefixLen-        oldLen <- frequency-                      [ (75, choose (0, min restLen n))-                      , (25, choose (0, min 10 restLen))-                      ]-        let nonempty x = if oldLen /= 0 then x else 0-        newLen <- frequency-                      [ ( 54, choose (1,min 1 n) )-                      , ( nonempty 42, choose (1,min 1 oldLen) )-                      , ( nonempty 2, return oldLen )-                      , ( nonempty 2, return 0 )-                      ]-        new <- BS.concat <$> vectorOf newLen aLine-        let old = BS.take oldLen $ BS.drop prefixLen $ content-        return $ Hunk pos old new--aTextHunk :: FORALL (x y) (UUID, Object Fail) -> Gen (Prim C(x y))-aTextHunk (uuid, (Blob text _)) =-  do hunk <- aHunk (unFail text)-     return $ TextHunk uuid hunk--aManifest :: FORALL (x y) UUID -> Location -> Object Fail -> Gen (Prim C(x y))-aManifest uuid loc (Directory dir) =-  do newFilename <- aFilename `notIn` (M.keys dir)-     return $ Manifest uuid loc--aDemanifest :: FORALL (x y) UUID -> Location -> Gen (Prim C(x y))-aDemanifest uuid loc = return $ Demanifest uuid loc---- | Generates any type of 'Prim' patch, except binary and setpref patches.-aPrim :: FORALL(x y) V3Model C(x) -> Gen (WithEndState V3Model (Prim C(x)) C(y))-aPrim repo-  = do mbFile <- maybeOf repoFiles-       mbDir <- maybeOf repoDirs-       mbExisting <- maybeOf $ repoObjects repo-       mbManifested <- maybeOf manifested-       fresh <- anUUID-       filename <- aFilename-       dir  <- elements (rootDir:repoDirs)-       mbOtherDir <- maybeOf repoDirs-       let whenfile x = if isJust mbFile then x else 0-           whendir x = if isJust mbDir then x else 0-           whenexisting x = if isJust mbExisting then x else 0-           whenmanifested x = if isJust mbManifested then x else 0-       patch <- frequency-                  [ ( whenfile 12, aTextHunk $ fromJust mbFile )-                  , ( 2, aTextHunk (fresh, Blob (return "") NoHash) ) -- create an empty thing-                  , ( whenexisting (whendir 2), -- manifest an existing object-                      aManifest (fst $ fromJust mbExisting)-                                (fst $ fromJust mbDir, filename)-                                (snd $ fromJust mbDir))-                  , ( whenmanifested 2, uncurry aDemanifest $ fromJust mbManifested )-                    -- TODO: demanifest-                  ]-       let repo' = unFail $ repoApply repo patch-       return $ WithEndState patch repo'-  where-      manifested = [ (id, (dirid, name)) | (dirid, Directory dir) <- repoDirs-                                         , (name, id) <- M.toList dir ]-      repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ]-      repoDirs  = [ (id, Directory x) | (id, Directory x) <- repoObjects repo ]-      rootDir   = (UUID "ROOT", root repo)--------------------------------------------------------------------------- *** Pairs of primitive patches---- Try to generate commutable pairs of hunks-hunkPair :: FORALL(x y) (UUID, Object Fail) -> Gen ((Prim :> Prim) C(x y))-hunkPair (uuid, (Blob file _)) =-  do h1@(Hunk l1 old1 new1) <- aHunk (unFail file)-     (delta, content') <- selectChunk h1 (unFail file)-     Hunk l2' old2 new2 <- aHunk content'-     let l2 = l2'+delta-     return (TextHunk uuid (Hunk l1 old1 new1) :> TextHunk uuid (Hunk l2 old2 new2))-  where-     selectChunk (Hunk l old new) content = elements [prefix, suffix]-       where start = l - 1-             prefix = (0, BS.take start content)-             suffix = (start + BS.length new, BS.drop (start + BS.length old) content)-     selectChunk _ _ = impossible--aPrimPair :: FORALL(x y) V3Model C(x) -> Gen (WithEndState V3Model ((Prim :> Prim) C(x)) C(y))-aPrimPair repo-  = do mbFile <- maybeOf repoFiles-       frequency-          [ ( if isJust mbFile then 1 else 0-            , do p1 :> p2 <- hunkPair $ fromJust mbFile-                 let repo'  = unFail $ repoApply repo  p1-                     repo'' = unFail $ repoApply repo' p2-                 return $ WithEndState (p1 :> p2) repo''-            )-          , ( 1-            , do Sealed wesP <- arbitraryState repo-                 return $ unsafeCoerceP1 wesP-            )-          ]-  where-      repoFiles = [ (id, Blob x y) | (id, Blob x y) <- repoObjects repo ]--------------------------------------------------------------------------- Arbitrary instances--ourSmallRepo :: Gen (V3Model C(x))-ourSmallRepo = aSmallRepo--instance ArbitraryState V3Model Prim where-  arbitraryState s = seal <$> aPrim s---instance Arbitrary (Sealed2 Prim) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed (Prim x)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (Prim :> Prim)) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp _ <- aPrimPair repo-                 return $ seal2 pp--instance Arbitrary (Sealed ((Prim :> Prim) C(a))) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp _ <- aPrimPair repo-                 return $ seal pp--instance Arbitrary (Sealed2 (Prim :> Prim :> Prim)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((Prim :> Prim :> Prim) a)) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim) C(a))) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (FL Prim :> FL Prim)) where-  arbitrary = makeS2Gen ourSmallRepo--instance Arbitrary (Sealed ((FL Prim :> FL Prim) C(a))) where-  arbitrary = makeSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V3Model Prim)) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V3Model Prim C(a))) where-  arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed (WithState V3Model (FL Prim) C(a))) where-  arbitrary = makeWSGen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V3Model (Prim :> Prim))) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal2 $ WithState repo pp repo'--instance Arbitrary (Sealed (WithState V3Model (Prim :> Prim) a)) where-  arbitrary = do repo <- ourSmallRepo-                 WithEndState pp repo' <- aPrimPair repo-                 return $ seal $ WithState repo pp repo'---instance Arbitrary (Sealed2 (WithState V3Model (FL Prim))) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed2 (WithState V3Model (FL Prim :> FL Prim))) where-  arbitrary = makeWS2Gen ourSmallRepo--instance Arbitrary (Sealed (WithState V3Model (FL Prim :> FL Prim) a)) where-  arbitrary = makeWSGen ourSmallRepo
− src/Darcs/Test/Patch/Arbitrary/Real.hs 
@@ -1,67 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-{-# LANGUAGE UndecidableInstances #-}-module Darcs.Test.Patch.Arbitrary.Real where-import Darcs.Test.Patch.Arbitrary.Generic-import Darcs.Test.Patch.Arbitrary.PrimV1 ()-import Darcs.Test.Patch.RepoModel--import Darcs.Witnesses.Ordered-import Darcs.Patch.Merge ( Merge(..) )-import Darcs.Patch.Patchy ( Patchy, Commute(..) )-import Darcs.Patch.Prim ( PrimPatch, anIdentity )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.V2.Real ( isDuplicate )--import Test.QuickCheck-import Darcs.Test.Patch.WithState-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Patch.Prim ( FromPrim(..) )--#include "gadts.h"--nontrivialReals :: PrimPatch prim => (RealPatch prim :> RealPatch prim) C(x y) -> Bool-nontrivialReals = nontrivialCommute--nontrivialCommute :: Patchy p => (p :> p) C(x y) -> Bool-nontrivialCommute (x :> y) = case commute (x :> y) of-                              Just (y' :> x') -> not (y' `unsafeCompare` y) ||-                                                 not (x' `unsafeCompare` x)-                              Nothing -> False--nontrivialMergeReals :: PrimPatch prim => (RealPatch prim :\/: RealPatch prim) C(x y) -> Bool-nontrivialMergeReals = nontrivialMerge--nontrivialMerge :: (Patchy p, Merge p) => (p :\/: p) C(x y) -> Bool-nontrivialMerge (x :\/: y) = case merge (x :\/: y) of-                              y' :/\: x' -> not (y' `unsafeCompare` y) ||-                                            not (x' `unsafeCompare` x)--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)))-                   return $ unseal seal2 (flattenOne tree)--instance (RepoModel (ModelOf prim), ArbitraryPrim prim)-         => Arbitrary (Sealed2 (RealPatch prim)) where-    arbitrary = do Sealed (WithStartState _ tree) <- arbitrary :: Gen (Sealed (WithStartState (ModelOf prim) (Tree prim)))-                   case mapFL seal2 `unseal` flattenOne tree of-                     [] -> return $ seal2 $ fromPrim anIdentity-                     ps -> elements ps--notDuplicatestriple :: (RealPatch prim :> RealPatch prim :> RealPatch prim) C(x y) -> Bool-notDuplicatestriple (a :> b :> c) = not (isDuplicate a || isDuplicate b || isDuplicate c)--nontrivialTriple :: PrimPatch prim => (RealPatch prim :> RealPatch prim :> RealPatch prim) C(x y) -> Bool-nontrivialTriple (a :> b :> c) =-    case commute (a :> b) of-    Nothing -> False-    Just (b' :> a') ->-      case commute (a' :> c) of-      Nothing -> False-      Just (c'' :> a'') ->-        case commute (b :> c) of-        Nothing -> False-        Just (c' :> b'') -> (not (a `unsafeCompare` a') || not (b `unsafeCompare` b')) &&-                            (not (c' `unsafeCompare` c) || not (b'' `unsafeCompare` b)) &&-                            (not (c'' `unsafeCompare` c) || not (a'' `unsafeCompare` a'))
− src/Darcs/Test/Patch/Check.hs 
@@ -1,347 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--module Darcs.Test.Patch.Check ( PatchCheck(), doCheck, fileExists, dirExists,-                                removeFile, removeDir, createFile, createDir,-                                insertLine, deleteLine, isValid, doVerboseCheck,-                                fileEmpty,-                                checkMove, modifyFile, FileContents(..)-                              ) where--import System.IO.Unsafe ( unsafePerformIO )-import qualified Data.ByteString as B (ByteString)-import Data.List ( isPrefixOf, inits )-import Control.Monad.State ( State, evalState, runState )-import Control.Monad.State.Class ( get, put, modify )--- use Map, not IntMap, because Map has mapKeys and IntMap hasn't-import Data.Map ( Map )-import qualified Data.Map as M ( mapKeys, delete, insert, empty, lookup, null )-import System.FilePath ( joinPath, splitDirectories )--#include "impossible.h"---- | File contents are represented by a map from line numbers to line contents.---   If for a certain line number, the line contents are Nothing, that means---   that we are sure that that line exists, but we don't know its contents.---   We must also store the greatest line number that is known to exist in a---   file, to be able to exclude the possibility of it being empty without---   knowing its contents.-data FileContents = FC { fcLines   :: Map Int B.ByteString-                       , fcMaxline :: Int-                       } deriving (Eq, Show)-data Prop = FileEx String | DirEx String | NotEx String-          | FileLines String FileContents-            deriving (Eq)--- | A @KnownState@ is a simulated repository state. The repository is either--- inconsistent, or it has two lists of properties: one list with properties--- that hold for this repo, and one with properties that do not hold for this--- repo. These two lists may not have any common elements: if they had, the--- repository would be inconsistent.-data KnownState = P [Prop] [Prop]-                | Inconsistent-                  deriving (Show)-instance  Show Prop  where-    show (FileEx f) = "FileEx "++f-    show (DirEx d)  = "DirEx "++d-    show (NotEx f) = "NotEx"++f-    show (FileLines f l)  = "FileLines "++f++": "++show l---- TODO the way that the standard way to use PatchCheck is--- by returning PatchCheck Bool but then often ignoring the--- result and instead checking again for state consistency--- is weird. It should be possible to replace it by a more normal--- error handling mechanism.---- | PatchCheck is a state monad with a simulated repository state-type PatchCheck = State KnownState---- | The @FileContents@ structure for an empty file-emptyFilecontents :: FileContents-emptyFilecontents = FC M.empty 0---- | Returns a given value if the repository state is inconsistent, and performs---   a given action otherwise.-handleInconsistent :: a            -- ^ The value to return if the state is inconsistent-                   -> PatchCheck a -- ^ The action to perform otherwise-                   -> PatchCheck a-handleInconsistent v a =  do state <- get-                             case state of-                               Inconsistent -> return v-                               _            -> a--doCheck :: PatchCheck a -> a-doCheck p = evalState p (P [] [])---- | Run a check, and print the final repository state-doVerboseCheck :: PatchCheck a -> a-doVerboseCheck p =-    case runState p (P [] []) of-    (b, pc) -> unsafePerformIO $ do print pc-                                    return b---- | Returns true if the current repository state is not inconsistent-isValid :: PatchCheck Bool-isValid = handleInconsistent False (return True)--has :: Prop -> [Prop] -> Bool-has _ [] = False-has k (k':ks) = k == k' || has k ks--modifyFile :: String-            -> (Maybe FileContents -> Maybe FileContents)-            -> PatchCheck Bool-modifyFile f change = do-    _ <- fileExists f-    c <- fileContents f-    case change c of-      Nothing -> assertNot $ FileEx f -- shorthand for "FAIL"-      Just c' -> do setContents f c'-                    isValid--insertLine :: String -> Int -> B.ByteString -> PatchCheck Bool-insertLine f n l = do-    c <- fileContents f-    case c of-      Nothing -> assertNot $ FileEx f -- in this case, the repo is inconsistent-      Just c' -> do-        let lines'   = M.mapKeys (\k -> if k >= n then k+1 else k) (fcLines c')-            lines''  = M.insert n l lines'-            maxline' = max n (fcMaxline c')-        setContents f (FC lines'' maxline')-        return True---- deletes a line from a hunk patch (third argument) in the given file (first--- argument) at the given line number (second argument)-deleteLine :: String -> Int -> B.ByteString -> PatchCheck Bool-deleteLine f n l = do-    c <- fileContents f-    case c of-      Nothing -> assertNot $ FileEx f-      Just c' ->-        let flines  = fcLines c'-            flines' = M.mapKeys (\k -> if k > n then k-1 else k)-                                (M.delete n flines)-            maxlinenum' | n <= fcMaxline c'  = fcMaxline c' - 1-                        | otherwise           = n - 1-            c'' = FC flines' maxlinenum'-            do_delete = do-              setContents f c''-              isValid-        in case M.lookup n flines of-          Nothing -> do_delete-          Just l' -> if l == l'-                       then do_delete-                       else assertNot $ FileEx f--setContents :: String -> FileContents -> PatchCheck ()-setContents f c = handleInconsistent () $ do-    P ks nots <- get-    let ks' = FileLines f c : filter (not . is_file_lines_for f) ks-    put (P ks' nots)-  where is_file_lines_for file prop = case prop of-                                        FileLines f' _ -> file == f'-                                        _              -> False---- | Get (as much as we know about) the contents of a file in the current state.---   Returns Nothing if the state is inconsistent.-fileContents :: String -> PatchCheck (Maybe FileContents)-fileContents f = handleInconsistent Nothing $ do-      P ks _ <- get-      return (fic ks)-    where fic (FileLines f' c:_) | f == f' = Just c-          fic (_:ks) = fic ks-          fic [] = Just emptyFilecontents---- | Checks if a file is empty-fileEmpty :: String          -- ^ Name of the file to check-           -> PatchCheck Bool-fileEmpty f = do-  c <- fileContents f-  let empty = case c of-               Just c' -> fcMaxline c' == 0 && M.null (fcLines c')-               Nothing -> True-  _ <- if empty-     then do setContents f emptyFilecontents-             isValid-     -- Crude way to make it inconsistent and return false:-     else assertNot $ FileEx f-  return empty--movedirfilename :: String -> String -> String -> String-movedirfilename d d' f-  | (d ++ "/") `isPrefixOf` f = d' ++ drop (length d) f-  | f == d = d'-  | otherwise = f---- | Replaces a filename by another in all paths. Returns True if the repository---   is consistent, False if it is not.-doSwap :: String -> String -> PatchCheck Bool-doSwap f f' = handleInconsistent False $ do-    modify map_sw-    return True-  where sw (FileEx a) | f  `is_soe` a = FileEx $ movedirfilename f f' a-                      | f' `is_soe` a = FileEx $ movedirfilename f' f a-        sw (DirEx a) | f  `is_soe` a = DirEx $ movedirfilename f f' a-                     | f' `is_soe` a = DirEx $ movedirfilename f' f a-        sw (FileLines a c) | f  `is_soe` a = FileLines (movedirfilename f f' a) c-                           | f' `is_soe` a = FileLines (movedirfilename f' f a) c-        sw (NotEx a) | f `is_soe` a = NotEx $ movedirfilename f f' a-                     | f' `is_soe` a = NotEx $ movedirfilename f' f a-        sw p = p-        is_soe d1 d2 = -- is_superdir_or_equal-            d1 == d2 || (d1 ++ "/") `isPrefixOf` d2-        map_sw (P ks nots) = P (map sw ks) (map sw nots)-        map_sw _ = impossible---- | Assert a property about the repository. If the property is already present--- in the repo state, nothing changes, and the function returns True. If it is--- not present yet, it is added to the repo state, and the function is True. If--- the property is already in the list of properties that do not hold for the--- repo, the state becomes inconsistent, and the function returns false.-assert :: Prop -> PatchCheck Bool-assert p = handleInconsistent False $ do-    P ks nots <- get-    if has p nots-      then do-        put Inconsistent-        return False-      else if has p ks-             then return True-             else do-               put (P (p:ks) nots)-               return True---- | Like @assert@, but negatively: state that some property must not hold for---   the current repo.-assertNot :: Prop -> PatchCheck Bool-assertNot p = handleInconsistent False $ do-    P ks nots <- get-    if has p ks-      then do-        put Inconsistent-        return False-      else if has p nots-             then return True-             else do-               put (P ks (p:nots))-               return True---- | Remove a property from the list of properties that do not hold for this--- repo (if it's there), and add it to the list of properties that hold.--- Returns False if the repo is inconsistent, True otherwise.-changeToTrue :: Prop -> PatchCheck Bool-changeToTrue p = handleInconsistent False $ do-    modify filter_nots-    return True-      where filter_nots (P ks nots) = P (p:ks) (filter (p /=) nots)-            filter_nots _ = impossible---- | Remove a property from the list of properties that hold for this repo (if--- it's in there), and add it to the list of properties that do not hold.--- Returns False if the repo is inconsistent, True otherwise.-changeToFalse :: Prop -> PatchCheck Bool-changeToFalse p = handleInconsistent False $ do-    modify filter_ks-    return True-    where filter_ks (P ks nots) = P (filter (p /=) ks) (p:nots)-          filter_ks _ = impossible--assertFileExists :: String -> PatchCheck Bool-assertFileExists f =   do _ <- assertNot $ NotEx f-                          _ <- assertNot $ DirEx f-                          assert $ FileEx f-assertDirExists :: String -> PatchCheck Bool-assertDirExists d =   do _ <- assertNot $ NotEx d-                         _ <- assertNot $ FileEx d-                         assert $ DirEx d-assertExists :: String -> PatchCheck Bool-assertExists f = assertNot $ NotEx f--assertNoSuch :: String -> PatchCheck Bool-assertNoSuch f =   do _ <- assertNot $ FileEx f-                      _ <- assertNot $ DirEx f-                      assert $ NotEx f--createFile :: String -> PatchCheck Bool-createFile fn = do-  _ <- superdirsExist fn-  _ <- assertNoSuch fn-  _ <- changeToTrue (FileEx fn)-  changeToFalse (NotEx fn)--createDir :: String -> PatchCheck Bool-createDir fn = do-  _ <- substuffDontExist fn-  _ <- superdirsExist fn-  _ <- assertNoSuch fn-  _ <- changeToTrue (DirEx fn)-  changeToFalse (NotEx fn)--removeFile :: String -> PatchCheck Bool-removeFile fn = do-  _ <- superdirsExist fn-  _ <- assertFileExists fn-  _ <- fileEmpty fn-  _ <- changeToFalse (FileEx fn)-  changeToTrue (NotEx fn)--removeDir :: String -> PatchCheck Bool-removeDir fn = do-  _ <- substuffDontExist fn-  _ <- superdirsExist fn-  _ <- assertDirExists fn-  _ <- changeToFalse (DirEx fn)-  changeToTrue (NotEx fn)--checkMove :: String -> String -> PatchCheck Bool-checkMove f f' = do-  _ <- superdirsExist f-  _ <- superdirsExist f'-  _ <- assertExists f-  _ <- assertNoSuch f'-  doSwap f f'--substuffDontExist :: String -> PatchCheck Bool-substuffDontExist d = handleInconsistent False $ do-    P ks _ <- get-    if all noss ks-      then return True-      else do-        put Inconsistent-        return False-  where noss (FileEx f) = not (is_within_dir f)-        noss (DirEx f) = not (is_within_dir f)-        noss _ = True-        is_within_dir f = (d ++ "/") `isPrefixOf` f---- the init and tail calls dump the final init (which is just the path itself--- again), the first init (which is empty), and the initial "." from--- splitDirectories-superdirsExist :: String -> PatchCheck Bool-superdirsExist fn = and `fmap` mapM assertDirExists superdirs-  where superdirs =  map (("./"++) . joinPath)-                         (init (tail (inits (tail (splitDirectories fn)))))--fileExists :: String -> PatchCheck Bool-fileExists fn = do-  _ <- superdirsExist fn-  assertFileExists fn--dirExists :: String -> PatchCheck Bool-dirExists fn = do-  _ <- superdirsExist fn-  assertDirExists fn
− src/Darcs/Test/Patch/Examples/Set1.hs 
@@ -1,419 +0,0 @@---  Copyright (C) 2002-2005,2007 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-deprecations #-}-{-# LANGUAGE CPP #-}--module Darcs.Test.Patch.Examples.Set1-       ( knownCommutes, knownCantCommutes, knownMerges-       , knownMergeEquivs, knownCanons, mergePairs2-       , validPatches, commutePairs, mergePairs-       , primitiveTestPatches, testPatches, testPatchesNamed-       , primitiveCommutePairs ) where--import System.IO.Unsafe ( unsafePerformIO )-import qualified Data.ByteString.Char8 as BC ( pack )-import qualified Data.ByteString as B ( empty )-import Darcs.Patch-     ( commute, invert, merge-     , Named, namepatch-     , readPatch, fromPrim-     , adddir, addfile, hunk, binary, rmdir, rmfile, tokreplace )-import Darcs.Patch.Prim ( PrimOf, FromPrim )-import Darcs.Patch.Prim.V1 ( Prim )-import qualified Darcs.Patch.V1 as V1 ( Patch )-import Darcs.Test.Patch.Properties.Check( checkAPatch )-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed ( unsafeUnseal )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePEnd )--#include "gadts.h"-#include "impossible.h"--type Patch = V1.Patch Prim---- The unit tester function is really just a glorified map for functions that--- return lists, in which the lists get concatenated (where map would end up--- with a list of lists).--quickmerge :: (FL Patch :\/: FL Patch) C(x y) -> FL Patch C(y z)-quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of-                        _ :/\: p1' -> unsafeCoercePEnd p1'---- ------------------------------------------------------------------------- * Show/Read tests--- -------------------------------------------------------------------------- | This test involves calling 'show' to print a string describing a patch,---   and then using readPatch to read it back in, and making sure the patch we---   read in is the same as the original.  Useful for making sure that I don't---   have any stupid IO bugs.---- ------------------------------------------------------------------------- * Canonization tests--- ------------------------------------------------------------------------knownCanons :: [(FL Patch C(x y),FL Patch C(x y))]-knownCanons =-    [(quickhunk 1 "abcde" "ab" :>: NilFL, quickhunk 3 "cde"   "" :>: NilFL),-     (quickhunk 1 "abcde" "bd" :>: NilFL,-      quickhunk 1 "a" "" :>:-      quickhunk 2 "c" "" :>:-      quickhunk 3 "e" "" :>: NilFL),-     (quickhunk 4 "a" "b" :>:-      quickhunk 1 "c" "d" :>: NilFL,-      quickhunk 1 "c" "d" :>:-      quickhunk 4 "a" "b" :>: NilFL),-     (quickhunk 1 "a" "" :>:-      quickhunk 1 "" "b" :>: NilFL,-      quickhunk 1 "a" "b" :>: NilFL),-     (quickhunk 1 "ab" "c" :>:-      quickhunk 1 "cd" "e" :>: NilFL,-      quickhunk 1 "abd" "e" :>: NilFL),-     (quickhunk 1 "abcde" "cde" :>: NilFL, quickhunk 1 "ab" "" :>: NilFL),-     (quickhunk 1 "abcde" "acde" :>: NilFL, quickhunk 2 "b" "" :>: NilFL)]--quickhunk :: (FromPrim p, PrimOf p ~ Prim) => Int -> String -> String -> p C(x y)-quickhunk l o n = fromPrim $ hunk "test" l (map (\c -> BC.pack [c]) o)-                                             (map (\c -> BC.pack [c]) n)---- ------------------------------------------------------------------------- * Merge/unmgerge tests--- -------------------------------------------------------------------------- | It should always be true that if two patches can be unmerged, then merging---   the resulting patches should give them back again.-mergePairs :: [(FL Patch :\/: FL Patch) C(x y)]-mergePairs =-  take 400 [(p1:\/:p2)|-            i <- [0..(length testPatches)-1],-            p1<-[testPatches!!i],-            p2<-drop i testPatches,-            checkAPatch (invert p2 :>: p1 :>: NilFL)]---- ------------------------------------------------------------------------- * Commute/recommute tests--- -------------------------------------------------------------------------- | Here we test to see if commuting patch A and patch B and then commuting--- the result gives us patch A and patch B again.  The set of patches (A,B)--- is chosen from the set of all pairs of test patches by selecting those which--- commute with one another.-commutePairs :: [(FL Patch :> FL Patch) C(x y)]-commutePairs =-  take 200 [(p1:>p2)|-            p1<-testPatches,-            p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatches,-            commute (p1:>p2) /= Nothing]--primitiveCommutePairs :: [(FL Patch :> FL Patch) C(x y)]-primitiveCommutePairs =-  [(p2:>p1)|-   p1<-primitiveTestPatches,-   p2<-primitiveTestPatches,-   commute (p2:>p1) /= Nothing,-   checkAPatch (p2:>:p1:>:NilFL)]---- ------------------------------------------------------------------------- * Commute tests--- -------------------------------------------------------------------------- | Here we provide a set of known interesting commutes.-knownCommutes :: [((FL Patch:<FL Patch) C(x y),(FL Patch:<FL Patch) C(x y))]-knownCommutes = [-                  (testhunk 1 [] ["A"]:<-                   testhunk 2 [] ["B"],-                   testhunk 3 [] ["B"]:<-                   testhunk 1 [] ["A"]),-                  (fromPrim (tokreplace "test" "A-Za-z_" "old" "new"):<-                   testhunk 2-                   ["hello world all that is old is good old_"]-                   ["I don't like old things"],-                   testhunk 2-                   ["hello world all that is new is good old_"]-                   ["I don't like new things"]:<-                   fromPrim (tokreplace "test" "A-Za-z_" "old" "new")),-                  (testhunk 1 ["A"] ["B"]:<-                   testhunk 2 ["C"] ["D"],-                   testhunk 2 ["C"] ["D"]:<-                   testhunk 1 ["A"] ["B"]),-                  (fromPrim (rmfile "NwNSO"):<-                   (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))),-                   (quickmerge (fromPrim (addfile "hello"):\/:fromPrim (addfile "hello"))):<-                   fromPrim (rmfile "NwNSO")),--                  (quickmerge (testhunk 3 ["o"] ["n"]:\/:-                               testhunk 3 ["o"] ["v"]):<-                   testhunk 1 [] ["a"],-                   testhunk 1 [] ["a"]:<-                   quickmerge (testhunk 2 ["o"] ["n"]:\/:-                               testhunk 2 ["o"] ["v"])),--                  (testhunk 1 ["A"] []:<-                   testhunk 3 ["B"] [],-                   testhunk 2 ["B"] []:<-                   testhunk 1 ["A"] []),--                  (testhunk 1 ["A"] ["B"]:<-                   testhunk 2 ["B"] ["C"],-                   testhunk 2 ["B"] ["C"]:<-                   testhunk 1 ["A"] ["B"]),--                  (testhunk 1 ["A"] ["B"]:<-                   testhunk 3 ["B"] ["C"],-                   testhunk 3 ["B"] ["C"]:<-                   testhunk 1 ["A"] ["B"]),--                  (testhunk 1 ["A"] ["B","C"]:<-                   testhunk 2 ["B"] ["C","D"],-                   testhunk 3 ["B"] ["C","D"]:<-                   testhunk 1 ["A"] ["B","C"])]-  where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)--knownCantCommutes :: [(FL Patch:< FL Patch) C(x y)]-knownCantCommutes = [-                      (testhunk 2 ["o"] ["n"]:<-                       testhunk 1 [] ["A"]),-                      (testhunk 1 [] ["A"]:<-                       testhunk 1 ["o"] ["n"]),-                      (quickmerge (testhunk 2 ["o"] ["n"]:\/:-                                   testhunk 2 ["o"] ["v"]):<-                       testhunk 1 [] ["a"]),-                      (fromPrim (hunk "test" 1 ([BC.pack "a"]) ([BC.pack "b"])):<-                       fromPrim (addfile "test"))]-  where testhunk l o n = fromPrim $ hunk "test" l (map BC.pack o) (map BC.pack n)---- ------------------------------------------------------------------------- * Merge tests--- -------------------------------------------------------------------------- | Here we provide a set of known interesting merges.-knownMerges :: [((FL Patch:\/:FL Patch) C(x y),FL Patch C(y z))]-knownMerges = [-                (testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"]:\/:-                 testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"],-                 testhunk 3 [BC.pack "c"] [BC.pack "d",BC.pack "e"]),-                (testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]:\/:-                 testhunk 2 [BC.pack "c"] [BC.pack "d",BC.pack "e"],-                 testhunk 1 [BC.pack "x"] [BC.pack "a",BC.pack "b"]),-                (testhunk 3 [BC.pack "A"] []:\/:-                 testhunk 1 [BC.pack "B"] [],-                 testhunk 2 [BC.pack "A"] []),-                (fromPrim (rmdir "./test/world"):\/:-                 fromPrim (hunk "./world" 3 [BC.pack "A"] []),-                 fromPrim (rmdir "./test/world")),--                ((quickhunk 1 "a" "bc" :>:-                  quickhunk 6 "d" "ef" :>: NilFL):\/:-                 (quickhunk 3 "a" "bc" :>:-                  quickhunk 8 "d" "ef" :>: NilFL),-                 (quickhunk 1 "a" "bc" :>:-                  quickhunk 7 "d" "ef" :>: NilFL)),--                (testhunk 1 [BC.pack "A"] [BC.pack "B"]:\/:-                 testhunk 2 [BC.pack "B"] [BC.pack "C"],-                 testhunk 1 [BC.pack "A"] [BC.pack "B"]),--                (testhunk 2 [BC.pack "A"] [BC.pack "B",BC.pack "C"]:\/:-                 testhunk 1 [BC.pack "B"] [BC.pack "C",BC.pack "D"],-                 testhunk 3 [BC.pack "A"] [BC.pack "B",BC.pack "C"])]-  where testhunk l o n = fromPrim $ hunk "test" l o n--knownMergeEquivs :: [((FL Patch :\/: FL Patch) C(x y), FL Patch C(y z))]-knownMergeEquivs = [--                     -- The following tests are going to be failed by the-                     -- Conflictor code as a cleanup.--                     --(addfile "test":\/:-                     -- adddir "test",-                     -- joinPatches (adddir "test" :>:-                     --              addfile "test-conflict" :>: NilFL)),-                     --(move "silly" "test":\/:-                     -- adddir "test",-                     -- joinPatches (adddir "test" :>:-                     --              move "silly" "test-conflict" :>: NilFL)),-                     --(addfile "test":\/:-                     -- move "old" "test",-                     -- joinPatches (addfile "test" :>:-                     --              move "old" "test-conflict" :>: NilFL)),-                     --(move "a" "test":\/:-                     -- move "old" "test",-                     -- joinPatches (move "a" "test" :>:-                     --              move "old" "test-conflict" :>: NilFL)),-                     (fromPrim (hunk "test" 1 [] [BC.pack "A"]) :\/:-                       fromPrim (hunk "test" 1 [] [BC.pack "B"]),-                       fromPrim (hunk "test" 1 [] [BC.pack "A", BC.pack "B"])),-                     (fromPrim (hunk "test" 1 [] [BC.pack "a"]):\/:-                      fromPrim (hunk "test" 1 [BC.pack "b"] []),-                      unsafeCoerceP NilFL),-                      --hunk "test" 1 [] [BC.pack "v v v v v v v",-                      --                  BC.pack "*************",-                      --                  BC.pack "a",-                      --                  BC.pack "b",-                      --                  BC.pack "^ ^ ^ ^ ^ ^ ^"]),-                     (quickhunk 4 "a"  "" :\/:-                      quickhunk 3 "a"  "",-                      quickhunk 3 "aa" ""),-                     ((quickhunk 1 "a" "bc" :>:-                       quickhunk 6 "d" "ef" :>: NilFL) :\/:-                       (quickhunk 3 "a" "bc" :>:-                        quickhunk 8 "d" "ef" :>: NilFL),-                      quickhunk 3 "a" "bc" :>:-                      quickhunk 8 "d" "ef" :>:-                      quickhunk 1 "a" "bc" :>:-                      quickhunk 7 "d" "ef" :>: NilFL),-                     (quickmerge (quickhunk 2 "" "bd":\/:quickhunk 2 "" "a") :\/:-                              quickmerge (quickhunk 2 "" "c":\/:quickhunk 2 "" "a"),-                              quickhunk 2 "" "abdc")-                     ]----- | It also is useful to verify that it doesn't matter which order we specify---   the patches when we merge.-mergePairs2 :: [(FL Patch C(x y), FL Patch C(x z))]-mergePairs2 = [(p1, p2) |-               p1<-primitiveTestPatches,-               p2<-primitiveTestPatches,-               checkAPatch (invert p1:>:p2:>:NilFL)-              ]---- ------------------------------------------------------------------------- Patch test data--- This is where we define the set of patches which we run our tests on.  This--- should be kept up to date with as many interesting permutations of patch--- types as possible.--- ------------------------------------------------------------------------testPatches :: [FL Patch C(x y)]-testPatchesNamed :: [Named Patch C(x y)]-testPatchesAddfile :: [FL Patch C(x y)]-testPatchesRmfile :: [FL Patch C(x y)]-testPatchesHunk :: [FL Patch C(x y)]-primitiveTestPatches :: [FL Patch C(x y)]-testPatchesBinary :: [FL Patch C(x y)]-testPatchesCompositeNocom :: [FL Patch C(x y)]-testPatchesComposite :: [FL Patch C(x y)]-testPatchesTwoCompositeHunks :: [FL Patch C(x y)]-testPatchesCompositeHunks :: [FL Patch C(x y)]-testPatchesCompositeFourHunks :: [FL Patch C(x y)]-testPatchesMerged :: [FL Patch C(x y)]-validPatches :: [FL Patch C(x y)]--testPatchesNamed = [unsafePerformIO $-                      namepatch "date is" "patch name" "David Roundy" []-                                (fromPrim $ addfile "test"),-                      unsafePerformIO $-                      namepatch "Sat Oct 19 08:31:13 EDT 2002"-                                "This is another patch" "David Roundy"-                                ["This log file has","two lines in it"]-                                (fromPrim $ rmfile "test")]-testPatchesAddfile = map fromPrim-                       [addfile "test",adddir "test",addfile "test/test"]-testPatchesRmfile = map invert testPatchesAddfile-testPatchesHunk  =-    [fromPrim (hunk file line old new) |-     file <- ["test"],-     line <- [1,2],-     old <- map (map BC.pack) partials,-     new <- map (map BC.pack) partials,-     old /= new-    ]-    where partials  = [["A"],["B"],[],["B","B2"]]--primitiveTestPatches = testPatchesAddfile ++-                         testPatchesRmfile ++-                         testPatchesHunk ++-                         [unsafeUnseal.fromJust.readPatch $-                          BC.pack "move ./test/test ./hello",-                          unsafeUnseal.fromJust.readPatch $-                          BC.pack "move ./test ./hello"] ++-                         testPatchesBinary--testPatchesBinary =-    [fromPrim $ binary "./hello"-     (BC.pack $ "agadshhdhdsa75745457574asdgg" ++-      "a326424677373735753246463gadshhdhdsaasdgg" ++-      "a326424677373735753246463gadshhdhdsaasdgg" ++-      "a326424677373735753246463gadshhdhdsaasdgg")-     (BC.pack $ "adafjttkykrehhtrththrthrthre" ++-      "a326424677373735753246463gadshhdhdsaasdgg" ++-      "a326424677373735753246463gadshhdhdsaasdgg" ++-      "a326424677373735753246463gadshhdhdsaagg"),-     fromPrim $ binary "./hello"-     B.empty-     (BC.pack "adafjttkykrere")]--testPatchesCompositeNocom =-    take 50 [p1+>+p2|-             p1<-primitiveTestPatches,-             p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) primitiveTestPatches,-             commute (p1:>p2) == Nothing]--testPatchesComposite =-    take 100 [p1+>+p2|-              p1<-primitiveTestPatches,-              p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) primitiveTestPatches,-              commute (p1:>p2) /= Nothing,-              commute (p1:>p2) /= Just (unsafeCoerceP p2:>unsafeCoerceP p1)]--testPatchesTwoCompositeHunks =-    take 100 [p1+>+p2|-              p1<-testPatchesHunk,-              p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk]--testPatchesCompositeHunks =-    take 100 [p1+>+p2+>+p3|-              p1<-testPatchesHunk,-              p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk,-              p3<-filter (\p->checkAPatch (p1:>:p2:>:p:>:NilFL)) testPatchesHunk]--testPatchesCompositeFourHunks =-    take 100 [p1+>+p2+>+p3+>+p4|-              p1<-testPatchesHunk,-              p2<-filter (\p->checkAPatch (p1:>:p:>:NilFL)) testPatchesHunk,-              p3<-filter (\p->checkAPatch (p1:>:p2:>:p:>:NilFL)) testPatchesHunk,-              p4<-filter (\p->checkAPatch (p1:>:p2:>:p3:>:p:>:NilFL)) testPatchesHunk]--testPatchesMerged =-  take 200-    [p2+>+quickmerge (p1:\/:p2) |-     p1<-take 10 (drop 15 testPatchesCompositeHunks)++primitiveTestPatches-         ++take 10 (drop 15 testPatchesTwoCompositeHunks)-         ++ take 2 (drop 4 testPatchesCompositeFourHunks),-     p2<-take 10 testPatchesCompositeHunks++primitiveTestPatches-         ++take 10 testPatchesTwoCompositeHunks-         ++take 2 testPatchesCompositeFourHunks,-     checkAPatch (invert p1 :>: p2 :>: NilFL),-     commute (p2:>p1) /= Just (p1:>p2)-    ]--testPatches =  primitiveTestPatches ++-                testPatchesComposite ++-                testPatchesCompositeNocom ++-                testPatchesMerged---- ------------------------------------------------------------------------- * Check patch test--- ------------------------------------------------------------------------validPatches = [(quickhunk 4 "a" "b" :>:-                 quickhunk 1 "c" "d" :>: NilFL),-                (quickhunk 1 "a" "bc" :>:-                 quickhunk 1 "b" "d" :>: NilFL),-                (quickhunk 1 "a" "b" :>:-                 quickhunk 1 "b" "d" :>: NilFL)]++testPatches
− src/Darcs/Test/Patch/Examples/Set2Unwitnessed.hs 
@@ -1,492 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}-{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Test.Patch.Examples.Set2Unwitnessed-       ( primPermutables, primPatches-       , commutables, commutablesFL-       , realCommutables , realMergeables, realTriples-       , realNonduplicateTriples, realPatches, realPatchLoopExamples-       ) where--import Data.Maybe ( catMaybes )-import qualified Data.ByteString.Char8 as BC ( pack )-import Darcs.Witnesses.Sealed-import Darcs.Patch ( invert, hunk )-import Darcs.Patch.Patchy ( Invert(..) )-import Darcs.Patch.Prim ( PrimPatch )-import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.V2.Real ( prim2real )--- import Darcs.Test.Patch.Test () -- for instance Eq Patch--- import Darcs.Test.Patch.Examples.Set2Unwitnessed-import Darcs.Witnesses.Unsafe ( unsafeCoerceP )-import qualified Darcs.Test.Patch.Arbitrary.Real as W ( notDuplicatestriple )---import Printer ( greenText )---import Darcs.ColorPrinter ( traceDoc )---import Darcs.ColorPrinter ( errorDoc )-import Darcs.ColorPrinter () -- for instance Show Doc-import Darcs.Test.Patch.WSub--import qualified Darcs.Witnesses.Ordered as W ( (:>), (:\/:) )-import qualified Data.ByteString as B ( ByteString )-import Darcs.Test.Patch.V1Model ( V1Model, Content-                                , makeRepo, makeName, makeFile)-import Darcs.Test.Patch.WithState ( WithStartState(..) )-import Darcs.Patch.Prim.V1.Core ( Prim(FP), FilePatchType(Hunk) )-import Darcs.Patch.FileName ( FileName, fp2fn )-import Darcs.Patch.Prim ( PrimPatchBase(..), FromPrim )-import Darcs.Patch.Merge ( Merge )-import Darcs.Test.Patch.Arbitrary.Generic-    ( Tree(..)-    , TreeWithFlattenPos(..)-    , commutePairFromTree, commuteTripleFromTree-    , mergePairFromCommutePair, commutePairFromTWFP-    , canonizeTree-    )---- import Debug.Trace--- #include "impossible.h"--makeSimpleRepo :: String -> Content -> V1Model C(x)-makeSimpleRepo filename content = makeRepo [(makeName filename, makeFile content)]---w_tripleExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:> p W.:> p)]-w_tripleExamples = [commuteTripleFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [])-                   (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "g"]))-                     (SeqTree (FP (fp2fn "./file") (Hunk 2 [] [BC.pack "j"]))-                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "s"])) NilTree)))-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "e"])) NilTree))-                  ,commuteTripleFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [BC.pack "j"])-                   (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "s"]))-                     (ParTree-                      (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "j"] [])) NilTree)-                      (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "j"] [])) NilTree)))-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree))-                  ]---w_mergeExamples :: (FromPrim p, Merge p, Invert p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:\/: p)]-w_mergeExamples = map (unseal2 (mergePairFromCommutePair seal2)) w_commuteExamples--w_commuteExamples :: (FromPrim p, Merge p, PrimPatchBase p, PrimOf p ~ Prim) => [Sealed2 (p W.:> p)]-w_commuteExamples = [-                   commutePairFromTWFP seal2 $-                   WithStartState (makeSimpleRepo "file" [])-                   (TWFP 3-                    (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) NilTree)-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "b"]))-                       (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"]))-                         (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"]))-                           (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "f"] [])) NilTree)))))),-                   commutePairFromTWFP seal2 $-                   WithStartState-                   (makeSimpleRepo "file" [BC.pack "f",BC.pack "s",BC.pack "d"])-                   (TWFP 3-                    (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "d"] [])) NilTree)-                     (ParTree-                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] [])) NilTree)-                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] []))-                        (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "s",BC.pack "d"] []))-                          (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree)))))),-{-                   commutePairFromTWFP seal2 $-                   WithStartState-                   (makeSimpleRepo "file" [BC.pack "f",BC.pack "u",-                                            BC.pack "s",BC.pack "d"])-                   (TWFP 5-                    (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 5 [] [BC.pack "x"]))-                      (SeqTree (FP (fp2fn "./file") (Hunk 4 [BC.pack "d"] [])) NilTree))-                     (ParTree-                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f",BC.pack "u"] [])) NilTree)-                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f"] []))-                       (SeqTree (FP(fp2fn "./file") (Hunk 1 [BC.pack "u",BC.pack "s",BC.pack "d"] []))-                        (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "a"]))-                         (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "a"] [])) NilTree))))))),-}-                   commutePairFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [BC.pack "n",BC.pack "t",BC.pack "h"])-                   (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "n",BC.pack "t",BC.pack "h"] []))-                     NilTree)-                    (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "h"] []))-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "n"] []))-                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t"] [])) NilTree)))),-                  commutePairFromTree seal2 $-                  WithStartState (makeSimpleRepo "file" [])-                  (ParTree-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "n"])) NilTree)-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "i"]))-                                (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "i"])) NilTree))),-                  commutePairFromTree seal2 $-                  WithStartState (makeSimpleRepo "file" [])-                  (ParTree-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "c"]))-                     (ParTree-                       (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "c"] [BC.pack "r"])) NilTree)-                       (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"]))-                        (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "d"])) NilTree))))-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree)),-                  commutePairFromTWFP seal2 $-                  WithStartState (makeSimpleRepo "file" [])-                  (TWFP 1-                  (ParTree-                   (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "t"])) NilTree)-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "t"])) NilTree))-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree))),-                   commutePairFromTWFP seal2 $-                   WithStartState (makeSimpleRepo "file" [BC.pack "f",BC.pack " r",-                                                            BC.pack "c",BC.pack "v"])-                   (TWFP 4-                    (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "c",BC.pack "v"] []))-                        (ParTree-                         (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "r"] []))-                          (SeqTree (FP (fp2fn "fi le") (Hunk 1 [BC.pack "f"] [])) NilTree))-                         (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "f",BC.pack "r"] []))-                          (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "y"])) NilTree))))-                     (SeqTree (FP (fp2fn "./file") (Hunk 4 [BC.pack "v"] [])) NilTree))),-                   commutePairFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [])-                   (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "z"])) NilTree)-                    (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "f"])) NilTree)-                     (ParTree-                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "r"])) NilTree)-                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "d"])) NilTree))))-                 , commutePairFromTree seal2 $-                   WithStartState (makeSimpleRepo "file" [BC.pack "t",BC.pack "r",BC.pack "h"])-                   (ParTree-                    (ParTree-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t",BC.pack "r",BC.pack "h"] []))-                              NilTree)-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "o"])) NilTree))-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "t"] []))-                     (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "h"] [])) NilTree)))-                 , commutePairFromTWFP seal2 $-                   WithStartState (makeSimpleRepo "file" []) $-                   TWFP 2-                   (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"])) NilTree)-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "y"]))-                     (SeqTree (FP (fp2fn "./file") (Hunk 2 [] [BC.pack "m"]))-                      (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree))))-                 , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [])-                 (ParTree-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "p"]))-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "p"] []))-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "c"])) NilTree)))-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "z"])) NilTree))-                 , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [])-                 (ParTree-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j" ]))-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree))-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree))-                 , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [])-                 (ParTree-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "v"])) NilTree)-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j" ]))-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 [BC.pack "j"] [])) NilTree)))-                 , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [BC.pack "x",BC.pack "c"])-                 (ParTree-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "h"]))-                   (ParTree-                    (SeqTree (FP (fp2fn "./file") (Hunk 3 [BC.pack "c"] [])) NilTree)-                    (SeqTree (FP (fp2fn "./file") (Hunk 2 [BC.pack "x"] []))-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "j"])) NilTree))))-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] [BC.pack "l"])) NilTree))-                 , commutePairFromTree seal2 $-                 WithStartState (makeSimpleRepo "file" [])-                 (ParTree-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "s"))) NilTree)-                  (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "k")))-                   (SeqTree (FP (fp2fn "./file") (Hunk 1 (packStringLetters "k") []))-                    (SeqTree (FP (fp2fn "./file") (Hunk 1 [] (packStringLetters "m")))-                     (SeqTree (FP (fp2fn "./file") (Hunk 1 (packStringLetters "m") [])) NilTree)))))-                 ]--packStringLetters :: String -> [B.ByteString]-packStringLetters = map (BC.pack . (:[]))--w_realPatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))]-w_realPatchLoopExamples =-    [Sealed (WithStartState (makeSimpleRepo fx_name [])-     $ canonizeTree-     (ParTree-      (SeqTree (FP fx (Hunk 1 [] (packStringLetters "pkotufogbvdabnmbzajvolwviqebieonxvcvuvigkfgybmqhzuaaurjspd")))-       (ParTree-        (SeqTree (FP fx (Hunk 47 (packStringLetters "qhzu") (packStringLetters "zafybdcokyjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmh")))-         (ParTree-          (ParTree-           NilTree-           (ParTree-            (ParTree-             (ParTree-              (SeqTree (FP fx (Hunk 15 (packStringLetters "mbzajvolwviqebieonxvcvuvigkfgyb") (packStringLetters "vujnxnhvybvpouyciaabszfmgssezlwwjgnethvrpnfrkubphzvdgymjjoacppqps")))-               (ParTree-                NilTree-                (ParTree-                 (SeqTree (FP fx (Hunk 40 (packStringLetters "ssezlwwjgnethvrpnfrkubphzvdgymjjoacppqpsmzafybdcokyjskcgnvhkbz") (packStringLetters "wnesidpccwoiqiichxaaejdsyrhrusqljlcoro")))-                  (ParTree-                   (ParTree-                    (SeqTree (FP fx (Hunk 12 (packStringLetters "abnvujnxnhvybvpouyciaabszfmgwnesidpccwoiqii") (packStringLetters "czfdhqkipdstfjycqaxwnbxrihrufdeyneqiiiafwzlmg"))) NilTree)-                    NilTree)-                   NilTree))-                 (SeqTree (FP fx (Hunk 25 [] (packStringLetters "dihgmsotezucqdgxczvcivijootyvhlwymbiueufnvpwpeukmskqllalfe"))) NilTree))))-              (SeqTree (FP fx (Hunk 56 (packStringLetters "yjskcgnvhkbzpysaafnjjhcstgrczplxsfwagmhaaurjsp") (packStringLetters "xldhrutyhcyaqeezwujiguawfyawjjqlirxshjddvq"))) NilTree))-             (SeqTree (FP fx (Hunk 20 [] (packStringLetters "ooygwiyogqrqnytixqtmvdxx")))-              (SeqTree (FP fx (Hunk 26 (packStringLetters "yogqrqnytixqtmvdxxvolwviqebieonxvcvuvigkfgybmzafybdcokyjskcgnvhkbz") (packStringLetters "akhsmlbkdxnvfoikmiatfbpzdrsyykkpoxvvddeaspzxe")))-               (SeqTree (FP fx (Hunk 39 [] (packStringLetters "ji")))-                (ParTree-                 NilTree-                 (ParTree-                  NilTree-                  (ParTree-                   (ParTree-                    NilTree-                    (SeqTree (FP fx (Hunk 26 (packStringLetters "akhsmlbkdxnvfjioikmiatfbpzdrsyykkpoxvvddeaspzxepysaafnjjhcstgrczplxs") (packStringLetters "onjbhddskcj")))-                     (SeqTree (FP fx (Hunk 39 [] (packStringLetters "fyscunxxxjjtyqpfxeznhtwvlphmp"))) NilTree)))-                   (ParTree-                    NilTree-                    (SeqTree (FP fx (Hunk 44 [] (packStringLetters "xcchzwmzoezxkmkhcmesplnjpqriypshgiqklgdnbmmkldnydiy")))-                     (ParTree-                      NilTree-                      (SeqTree (FP fx (Hunk 64 (packStringLetters "plnjpqriypshgiqklgdnbmmkldnydiymiatfbpzdrsyykkpoxvvddeaspzxepysaafn") (packStringLetters "anjlzfdqbjqbcplvqvkhwjtkigp"))) NilTree)))))))))))-            (ParTree-             NilTree-             NilTree)))-          NilTree))-        NilTree))-      (ParTree-       NilTree-       (SeqTree (FP fx (Hunk 1 [] (packStringLetters "ti")))-        (SeqTree (FP fx (Hunk 1 (packStringLetters "t") (packStringLetters "ybcop")))-         (SeqTree (FP fx (Hunk 2 [] (packStringLetters "dvlhgwqlpaeweerqrhnjtfolczbqbzoccnvdsyqiefqitrqneralf")))-          (SeqTree (FP fx (Hunk 15 [] (packStringLetters "yairbjphwtnaerccdlfewujvjvmjakbc")))-           (SeqTree (FP fx (Hunk 51 [] (packStringLetters "xayvfuwaiiogginufnhsrmktpmlbvxiakjwllddkiyofyfw")))-            (ParTree-             NilTree-             NilTree)))))))))]-  where-      fx_name :: String-      fx_name = "F"--      fx :: FileName-      fx = fp2fn "./F"---mergeExamples :: [Sealed2 (RealPatch Prim :\/: RealPatch Prim)]-mergeExamples = map (mapSeal2 fromW) w_mergeExamples--realPatchLoopExamples :: [Sealed (WithStartState V1Model (Tree Prim))]-realPatchLoopExamples = w_realPatchLoopExamples--commuteExamples :: [Sealed2 (RealPatch Prim :> RealPatch Prim)]-commuteExamples = map (mapSeal2 fromW) w_commuteExamples--tripleExamples :: [Sealed2 (RealPatch Prim :> RealPatch Prim :> RealPatch Prim)]-tripleExamples = map (mapSeal2 fromW) w_tripleExamples--notDuplicatestriple :: (RealPatch Prim :> RealPatch Prim :> RealPatch Prim) C(x y) -> Bool-notDuplicatestriple = W.notDuplicatestriple . toW--quickhunk :: PrimPatch prim => Int -> String -> String -> prim C(x y)-quickhunk l o n = hunk "test" l (map (\c -> BC.pack [c]) o)-                                (map (\c -> BC.pack [c]) n)--primPermutables :: [(Prim :> Prim :> Prim) C(x y)]-primPermutables =-    [quickhunk 0 "e" "bo" :> quickhunk 3 "" "x" :> quickhunk 2 "f" "qljo"]--mergeables :: [(Prim :\/: Prim) C(x y)]-mergeables = [quickhunk 1 "a" "b" :\/: quickhunk 1 "a" "c",-              quickhunk 1 "a" "b" :\/: quickhunk 3 "z" "c",-              quickhunk 0 "" "a" :\/: quickhunk 1 "" "b",-              quickhunk 0 "a" "" :\/: quickhunk 1 "" "b",-              quickhunk 0 "a" "" :\/: quickhunk 1 "b" "",-              quickhunk 0 "" "a" :\/: quickhunk 1 "b" ""-             ]--mergeablesFL :: [(FL Prim :\/: FL Prim) C(x y)]-mergeablesFL = map (\ (x:\/:y) -> (x :>: NilFL) :\/: (y :>: NilFL)) mergeables ++-           [] --    [(quickhunk 1 "a" "b" :>: quickhunk 3 "z" "c" :>: NilFL)-              --  :\/: (quickhunk 1 "a" "z" :>: NilFL),-              --  (quickhunk 1 "a" "b" :>: quickhunk 1 "b" "c" :>: NilFL)-              --  :\/: (quickhunk 1 "a" "z" :>: NilFL)]--mergeable2commutable :: Invert p => (p :\/: p) C(x y) -> (p :> p) C(x y)-mergeable2commutable (x :\/: y) = unsafeCoerceP (invert x) :> y--commutablesFL :: [(FL Prim :> FL Prim) C(x y)]-commutablesFL = map mergeable2commutable mergeablesFL-commutables :: [(Prim :> Prim) C(x y)]-commutables = map mergeable2commutable mergeables--primPatches :: [Prim C(x y)]-primPatches = concatMap mergeable2patches mergeables-    where mergeable2patches (x:\/:y) = [x,y]--realPatches :: [RealPatch Prim C(x y)]-realPatches = concatMap commutable2patches realCommutables-    where commutable2patches (x:>y) = [x,y]--realTriples :: [(RealPatch Prim :> RealPatch Prim :> RealPatch Prim) C(x y)]-realTriples = [ob' :> oa2 :> a2'',-                oa' :> oa2 :> a2'']-               ++ map unsafeUnseal2 tripleExamples-               ++ map unsafeUnseal2 (concatMap getTriples realFLs)-    where oa = prim2real $ quickhunk 1 "o" "aa"-          oa2 = oa-          a2 = prim2real $ quickhunk 2 "a34" "2xx"-          ob = prim2real $ quickhunk 1 "o" "bb"-          ob' :/\: oa' = merge (oa :\/: ob)-          a2' :/\: _ = merge (ob' :\/: a2)-          a2'' :/\: _ = merge (oa2 :\/: a2')--realNonduplicateTriples :: [(RealPatch Prim :> RealPatch Prim :> RealPatch Prim) C(x y)]-realNonduplicateTriples = filter (notDuplicatestriple) realTriples--realFLs :: [FL (RealPatch Prim) C(x y)]-realFLs = [oa :>: invert oa :>: oa :>: invert oa :>: ps +>+ oa :>: invert oa :>: NilFL]-    where oa = prim2real $ quickhunk 1 "o" "a"-          ps :/\: _ = merge (oa :>: invert oa :>: NilFL :\/: oa :>: invert oa :>: NilFL)--realCommutables :: [(RealPatch Prim :> RealPatch Prim) C(x y)]-realCommutables = map unsafeUnseal2 commuteExamples++-                   map mergeable2commutable realMergeables++-                   [invert oa :> ob'] ++ map unsafeUnseal2 (concatMap getPairs realFLs)-    where oa = prim2real $ quickhunk 1 "o" "a"-          ob = prim2real $ quickhunk 1 "o" "b"-          _ :/\: ob' = mergeFL (ob :\/: oa :>: invert oa :>: NilFL)--realMergeables :: [(RealPatch Prim :\/: RealPatch Prim) C(x y)]-realMergeables = map (\ (x :\/: y) -> prim2real x :\/: prim2real y) mergeables-                        ++ realIglooMergeables-                        ++ realQuickcheckMergeables-                        ++ map unsafeUnseal2 mergeExamples-                        ++ catMaybes (map pair2m (concatMap getPairs realFLs))-                        ++ [(oa :\/: od),-                            (oa :\/: a2'),-                            (ob' :\/: od''),-                            (oe :\/: od),-                            (of' :\/: oe'),-                            (ob' :\/: oe'),-                            (oa :\/: oe'),-                            (ob' :\/: oc'),-                            (b2' :\/: oc'''),-                            (ob' :\/: a2),-                            (b2' :\/: og'''),-                            (oc''' :\/: og'''),-                            (oc'' :\/: og''),-                            (ob'' :\/: og''),-                            (ob'' :\/: oc''),-                            (oc' :\/: od'')]-    where oa = prim2real $ quickhunk 1 "o" "aa"-          a2 = prim2real $ quickhunk 2 "a34" "2xx"-          og = prim2real $ quickhunk 3 "4" "g"-          ob = prim2real $ quickhunk 1 "o" "bb"-          b2 = prim2real $ quickhunk 2 "b" "2"-          oc = prim2real $ quickhunk 1 "o" "cc"-          od = prim2real $ quickhunk 7 "x" "d"-          oe = prim2real $ quickhunk 7 "x" "e"-          pf = prim2real $ quickhunk 7 "x" "f"-          od'' = prim2real $ quickhunk 8 "x" "d"-          ob' :>: b2' :>: NilFL :/\: _ = mergeFL (oa :\/: ob :>: b2 :>: NilFL)-          a2' :/\: _ = merge (ob' :\/: a2)-          ob'' :/\: _ = merge (a2 :\/: ob')-          og' :/\: _ = merge (oa :\/: og)-          og'' :/\: _ = merge (a2 :\/: og')-          og''' :/\: _ = merge (ob' :\/: og')-          oc' :/\: _ = merge (oa :\/: oc)-          oc'' :/\: _ = merge (a2 :\/: oc)-          oc''' :/\: _ = merge (ob' :\/: oc')-          oe' :/\: _ = merge (od :\/: oe)-          of' :/\: _ = merge (od :\/: pf)-          pair2m :: Sealed2 (RealPatch Prim :> RealPatch Prim)-                 -> Maybe ((RealPatch Prim :\/: RealPatch Prim) C(x y))-          pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)-                                          return $ unsafeCoerceP (xx :\/: y')--realIglooMergeables :: [(RealPatch Prim :\/: RealPatch Prim) C(x y)]-realIglooMergeables = [(a :\/: b),-                    (b :\/: c),-                    (a :\/: c),-                    (x :\/: a),-                    (y :\/: b),-                    (z :\/: c),-                    (x' :\/: y'),-                    (z' :\/: y'),-                    (x' :\/: z'),-                    (a :\/: a)]-    where a = prim2real $ quickhunk 1 "1" "A"-          b = prim2real $ quickhunk 2 "2" "B"-          c = prim2real $ quickhunk 3 "3" "C"-          x = prim2real $ quickhunk 1 "1BC" "xbc"-          y = prim2real $ quickhunk 1 "A2C" "ayc"-          z = prim2real $ quickhunk 1 "AB3" "abz"-          x' :/\: _ = merge (a :\/: x)-          y' :/\: _ = merge (b :\/: y)-          z' :/\: _ = merge (c :\/: z)--realQuickcheckMergeables :: [(RealPatch Prim :\/: RealPatch Prim) C(x y)]-realQuickcheckMergeables = [-- invert k1 :\/: n1-                             --, invert k2 :\/: n2-                               hb :\/: k-                             , b' :\/: b'-                             , n' :\/: n'-                             , b :\/: d-                             , k' :\/: k'-                             , k3 :\/: k3-                             ] ++ catMaybes (map pair2m pairs)-    where hb = prim2real $ quickhunk 0 "" "hb"-          k = prim2real $ quickhunk 0 "" "k"-          n = prim2real $ quickhunk 0 "" "n"-          b = prim2real $ quickhunk 1 "b" ""-          d = prim2real $ quickhunk 2 "" "d"-          d':/\:_ = merge (b :\/: d)-          --k1 :>: n1 :>: NilFL :/\: _ = mergeFL (hb :\/: k :>: n :>: NilFL)-          --k2 :>: n2 :>: NilFL :/\: _ =-          --    merge (hb :>: b :>: NilFL :\/: k :>: n :>: NilFL)-          k' :>: n' :>: NilFL :/\: _ :>: b' :>: _ = merge (hb :>: b :>: d' :>: NilFL :\/: k :>: n :>: NilFL)-          pairs = getPairs (hb :>: b :>: d' :>: k' :>: n' :>: NilFL)-          pair2m :: Sealed2 (RealPatch Prim :> RealPatch Prim)-                 -> Maybe ((RealPatch Prim :\/: RealPatch Prim) C(x y))-          pair2m (Sealed2 (xx :> y)) = do y' :> _ <- commute (xx :> y)-                                          return $ unsafeCoerceP (xx :\/: y')--          i = prim2real $ quickhunk 0 "" "i"-          x = prim2real $ quickhunk 0 "" "x"-          xi = prim2real $ quickhunk 0 "xi" ""-          d3 :/\: _ = merge (xi :\/: d)-          _ :/\: k3 = mergeFL (k :\/: i :>: x :>: xi :>: d3 :>: NilFL)-
− src/Darcs/Test/Patch/Info.hs 
@@ -1,163 +0,0 @@--- Copyright (C) 2009 Reinier Lamers------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- | This module contains tests for the code in Darcs.Patch.Info. Most of them---   are about the UTF-8-encoding of patch metadata.-module Darcs.Test.Patch.Info ( testSuite ) where--import Prelude hiding ( pi )-import Data.ByteString ( ByteString )-import qualified Data.ByteString as B ( split, pack )-import qualified Data.ByteString.Char8 as BC ( unpack )-import Data.List ( sort )-import Data.Maybe ( isNothing )-import Data.Text as T ( find, any )-import Data.Text.Encoding ( decodeUtf8With )-import Data.Text.Encoding.Error ( lenientDecode )-import System.IO.Unsafe ( unsafePerformIO )-import Test.QuickCheck ( Arbitrary(arbitrary), oneof, listOf, choose, shrink-                       , Gen )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.Framework (Test, testGroup)-import Data.List ( isPrefixOf )--import Darcs.Patch.Info ( PatchInfo(..), patchinfo,-                          piLog, piAuthor, piName )-import ByteStringUtils ( decodeLocale, packStringToUTF8, unpackPSFromUTF8 )--testSuite :: Test-testSuite = testGroup "Darcs.Patch.Info"-  [ metadataDecodingTest-  , metadataEncodingTest-  , packUnpackTest-  ]---- | A newtype wrapping String so we can make our own random generator for it.-newtype UnicodeString = UnicodeString { asString :: String }-        deriving (Show, Eq, Ord)---- | A newtype wrapping PatchInfo that has a random generator that generates---   both UTF-8-encoded and non-encoded PatchInfo's.-newtype UTF8OrNotPatchInfo = UTF8OrNotPatchInfo PatchInfo deriving (Eq, Ord)---- | A newtype wrapping PatchInfo, which has a random generator that generates---   only UTF-8-encoded PatchInfo's.-newtype UTF8PatchInfo = UTF8PatchInfo PatchInfo deriving (Eq, Ord)--instance Arbitrary UnicodeString where-    -- 0x10ffff is the highest Unicode code point ; 0xd800 - 0xdfff are-    -- surrogates. '\xfffd' is excluded because it is used as a marker-    -- for UTF-8 test failure.-    arbitrary = UnicodeString `fmap` listOf (oneof [choose ('\0', '\xd799')-                                                   ,choose ('\xe000', '\xfffc')-                                                   ,choose ('\xfffe', '\x10ffff')])--instance Show UTF8PatchInfo where-     showsPrec _ = withUTF8PatchInfo rawPatchInfoShow-instance Show UTF8OrNotPatchInfo where-     showsPrec _ = withUTF8OrNotPatchInfo rawPatchInfoShow---- | Shows a PatchInfo, outputting every byte and clearly marking what is what-rawPatchInfoShow :: PatchInfo -> String -> String-rawPatchInfoShow pi = ("PatchInfo: \n"++)-                    . ("date: "++) . shows (_piDate pi) . ('\n':)-                    . ("author: "++) . shows (_piAuthor pi) . ('\n':)-                    . ("name: "++) . shows (_piName pi) . ('\n':)-                    . ("log: "++) . shows (_piLog pi) . ('\n':)--instance Arbitrary UTF8PatchInfo where-    arbitrary = UTF8PatchInfo `fmap` arbitraryUTF8Patch-    shrink upi = flip withUTF8PatchInfo upi $ \pi -> do-        sn <- shrink (piName pi)-        sa <- shrink (piAuthor pi)-        sl <- shrink (filter (not . isPrefixOf "Ignore-this:") (piLog pi))-        return (UTF8PatchInfo-                   (unsafePerformIO $ patchinfo sn-                                          (BC.unpack (_piDate pi)) sa sl))--instance Arbitrary UTF8OrNotPatchInfo where-    arbitrary = UTF8OrNotPatchInfo `fmap` oneof ([arbitraryUTF8Patch,-                                                  arbitraryUnencodedPatch])---- | Generate arbitrary patch metadata that uses the metadata creation function---   'patchinfo' from Darcs.Patch.Info.-arbitraryUTF8Patch :: Gen PatchInfo-arbitraryUTF8Patch =-    do n <- asString `fmap` arbitrary-       d <- arbitrary-       a <- asString `fmap` arbitrary-       l <- (lines . asString) `fmap` arbitrary-       return $ unsafePerformIO $ patchinfo n d a l---- | Generate arbitrary patch metadata that has totally arbitrary byte strings---   as its name, date, author and log.-arbitraryUnencodedPatch :: Gen PatchInfo-arbitraryUnencodedPatch = do-    n <- arbitraryByteString-    d <- arbitraryByteString-    a <- arbitraryByteString-    -- split 10 is the ByteString equivalent of 'lines'-    l <- B.split 10 `fmap` arbitraryByteString-    i <- arbitrary-    return (PatchInfo d n a l i)--arbitraryByteString :: Gen ByteString-arbitraryByteString = (B.pack . map fromIntegral)-                          `fmap` listOf (choose (0, 255) :: Gen Int)---- | Test that anything produced by the 'patchinfo' function is valid UTF-8-metadataEncodingTest :: Test-metadataEncodingTest = testProperty "Testing patch metadata encoding" $-    withUTF8PatchInfo $-       \patchInfo -> encodingOK (_piAuthor patchInfo)-                     && encodingOK (_piName patchInfo)-                     && all encodingOK (_piLog patchInfo)-  where encodingOK = isNothing . T.find (=='\xfffd') . decodeUtf8With lenientDecode---- | Test that metadata in patches are decoded as UTF-8 or locale depending on--- whether they're valid UTF-8.-metadataDecodingTest :: Test-metadataDecodingTest = testProperty "Testing patch metadata decoding" $-    withUTF8OrNotPatchInfo $-        \patchInfo -> utf8OrLocale (_piAuthor patchInfo) == piAuthor patchInfo-                      && utf8OrLocale (_piName patchInfo) == piName patchInfo-                      && map utf8OrLocale (_piLog patchInfo) `superset` piLog patchInfo-  where utf8OrLocale bs = if isValidUTF8 bs-                            then unpackPSFromUTF8 bs-                            else decodeLocale bs--isValidUTF8 :: ByteString -> Bool-isValidUTF8 = not . T.any (=='\xfffd') . decodeUtf8With lenientDecode--packUnpackTest :: Test-packUnpackTest = testProperty "Testing UTF-8 packing and unpacking" $-    \uString -> asString uString == (unpackPSFromUTF8 . packStringToUTF8) (asString uString)--superset :: (Eq a, Ord a) => [a] -> [a] -> Bool-superset a b = sorted_superset (sort a) (sort b)-  where sorted_superset (x:xs) (y:ys) | x == y = sorted_superset xs ys-                                      | x <  y = sorted_superset xs (y:ys)-                                      | otherwise = False-        sorted_superset []     (_:_)           = False-        sorted_superset _      []              = True--withUTF8PatchInfo :: (PatchInfo -> a) -> UTF8PatchInfo -> a-withUTF8PatchInfo f mpi = case mpi of-                            UTF8PatchInfo pinf -> f pinf-withUTF8OrNotPatchInfo :: (PatchInfo -> a) -> UTF8OrNotPatchInfo -> a-withUTF8OrNotPatchInfo f mpi = case mpi of-                                 UTF8OrNotPatchInfo pinf -> f pinf
− src/Darcs/Test/Patch/Properties/Check.hs 
@@ -1,111 +0,0 @@-module Darcs.Test.Patch.Properties.Check ( Check(..), checkAPatch ) where--import Test.QuickCheck-import Control.Applicative-import Control.Monad ( liftM, liftM2, liftM3, liftM4, replicateM )--import Darcs.Patch.Info ( PatchInfo, patchinfo )-import Darcs.Test.Patch.Check ( PatchCheck,-                                checkMove, removeDir, createDir,-                                isValid, insertLine, fileEmpty, fileExists,-                                deleteLine, modifyFile, createFile, removeFile,-                                doCheck, doVerboseCheck, FileContents(..)-                              )-import Darcs.Patch.RegChars ( regChars )-import ByteStringUtils ( linesPS )-import qualified Data.ByteString as B ( ByteString, null, concat )-import qualified Data.ByteString.Char8 as BC ( break, pack )-import Darcs.Patch.FileName ( fn2fp )-import qualified Data.Map as M ( mapMaybe )--import Darcs.Patch ( addfile, adddir, move,-                     hunk, tokreplace, binary,-                     changepref, invert, merge,-                     effect )-import Darcs.Patch.Invert ( Invert )-import Darcs.Patch.V1 ()-import qualified Darcs.Patch.V1.Core as V1 ( Patch(..) )-import Darcs.Patch.V1.Core ( isMerger )-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.Prim.V1.Core ( Prim(..), DirPatchType(..), FilePatchType(..) )-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed ( Sealed(Sealed), unseal, mapSeal, Sealed2(..) )-import Darcs.Witnesses.Unsafe--#include "gadts.h"-#include "impossible.h"--type Patch = V1.Patch Prim--class Check p where-   checkPatch :: p C(x y) -> PatchCheck Bool--instance Check p => Check (FL p) where-   checkPatch NilFL = isValid-   checkPatch (p :>: ps) = checkPatch p >> checkPatch ps--checkAPatch :: (Invert p, Check p) => p C(x y) -> Bool-checkAPatch p = doCheck $ do _ <- checkPatch p-                             checkPatch $ invert p--instance Check (V1.Patch Prim) where-   checkPatch p | isMerger p = do-     checkPatch $ effect p-   checkPatch (V1.Merger _ _ _ _) = impossible-   checkPatch (V1.Regrem _ _ _ _) = impossible-   checkPatch (V1.PP p) = checkPatch p--instance Check Prim where--   checkPatch (FP f RmFile) = removeFile $ fn2fp f-   checkPatch (FP f AddFile) =  createFile $ fn2fp f-   checkPatch (FP f (Hunk line old new)) = do-       _ <- fileExists $ fn2fp f-       mapM_ (deleteLine (fn2fp f) line) old-       mapM_ (insertLine (fn2fp f) line) (reverse new)-       isValid-   checkPatch (FP f (TokReplace t old new)) =-       modifyFile (fn2fp f) (tryTokPossibly t old new)-   -- note that the above isn't really a sure check, as it leaves PSomethings-   -- and PNothings which may have contained new...-   checkPatch (FP f (Binary o n)) = do-       _ <- fileExists $ fn2fp f-       mapM_ (deleteLine (fn2fp f) 1) (linesPS o)-       _ <- fileEmpty $ fn2fp f-       mapM_ (insertLine (fn2fp f) 1) (reverse $ linesPS n)-       isValid--   checkPatch (DP d AddDir) = createDir $ fn2fp d-   checkPatch (DP d RmDir) = removeDir $ fn2fp d--   checkPatch (Move f f') = checkMove (fn2fp f) (fn2fp f')-   checkPatch (ChangePref _ _ _) = return True--tryTokPossibly :: String -> String -> String-                -> (Maybe FileContents) -> (Maybe FileContents)-tryTokPossibly t o n = liftM $ \contents ->-        let lines' = M.mapMaybe (liftM B.concat-                                  . tryTokInternal t (BC.pack o) (BC.pack n))-                                (fcLines contents)-        in contents { fcLines = lines' }--tryTokInternal :: String -> B.ByteString -> B.ByteString-                 -> B.ByteString -> Maybe [B.ByteString]-tryTokInternal _ _ _ s | B.null s = Just []-tryTokInternal t o n s =-    case BC.break (regChars t) s of-    (before,s') ->-        case BC.break (not . regChars t) s' of-        (tok,after) ->-            case tryTokInternal t o n after of-            Nothing -> Nothing-            Just rest ->-                if tok == o-                then Just $ before : n : rest-                else if tok == n-                     then Nothing-                     else Just $ before : tok : rest--verboseCheckAPatch :: (Invert p, Check p) => p C(x y) -> Bool-verboseCheckAPatch p = doVerboseCheck $ do checkPatch p-
− src/Darcs/Test/Patch/Properties/Generic.hs 
@@ -1,369 +0,0 @@---  Copyright (C) 2007 David Roundy------  This program is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2, or (at your option)---  any later version.------  This program is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with this program; see the file COPYING.  If not, write to---  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,---  Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-deprecations -fno-warn-orphans #-}--#include "gadts.h"--module Darcs.Test.Patch.Properties.Generic-    ( invertSymmetry, inverseComposition, invertRollback,-      recommute, commuteInverses, effectPreserving,-      permutivity, partialPermutivity,-      patchAndInverseCommute, mergeEitherWay,-      show_read,-      mergeCommute, mergeConsistent, mergeArgumentsConsistent,-      joinEffectPreserving, joinCommute, propIsMergeable-    ) where--import Darcs.Test.Util.TestResult ( TestResult, succeeded, failed, rejected,-                                    (<&&>), fromMaybe )-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 Control.Monad ( msum )-import Darcs.Witnesses.Show ( Show2(..), show2 )-import Darcs.Patch.Patchy ( Patchy, showPatch, commute, invert )-import Darcs.Patch.Prim.Class ( PrimPatch, PrimOf, FromPrim )-import Darcs.Patch ()-import Darcs.Patch.Apply ( ApplyState )-import Darcs.Patch.Commute ( commuteFLorComplain )-import Darcs.Patch.Merge ( Merge(merge) )-import Darcs.Patch.Read ( readPatch )-import Darcs.Patch.Invert ( invertFL )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..), isIsEq )-import Darcs.Witnesses.Ordered ( FL(..), (:>)(..), (:\/:)(..), (:/\:)(..), lengthFL, eqFL, reverseRL )-import Darcs.Witnesses.Sealed ( Sealed(Sealed), seal2, Sealed2 )-import Printer ( Doc, renderPS, redText, greenText, ($$), text )---import Darcs.ColorPrinter ( traceDoc )--propIsMergeable :: forall model p C(x) . (FromPrim p, Merge p, RepoModel model)-                  => Sealed (WithStartState model (Tree (PrimOf p)))-                  -> Maybe (Tree p C(x))-propIsMergeable (Sealed (WithStartState _ t))-   = case flattenOne t of-        Sealed ps -> let _ = seal2 ps :: Sealed2 (FL p)-                     in case lengthFL ps of-                       _ -> Nothing---- | invert symmetry   inv(inv(p)) = p-invertSymmetry :: Patchy p => p C(a b) -> TestResult-invertSymmetry p = case invert (invert p) =\/= p of-                        IsEq  -> succeeded-                        NotEq -> failed $ redText "p /= inv(inv(p))"--inverseComposition :: Patchy p => (p :> p) C(x y) -> TestResult-inverseComposition (a :> b) =-    case eqFL (reverseRL (invertFL (a:>:b:>:NilFL))) (invert b:>:invert a:>:NilFL) of-      IsEq -> succeeded-      NotEq -> failed $ redText "inv(a :>: b :>: NilFL) /= inv(b) :>: inv(a) :>: NilFL"---- | invert rollback   if b = A(a) then a = A'(b)-invertRollback :: (ApplyState p ~ RepoState model, Patchy p, RepoModel model)-                => WithState model p C(a b) -> TestResult-invertRollback (WithState a x b)-  = case maybeFail $ repoApply b (invert x) of-         Nothing -> failed $ redText "x' not applicable to b."-         Just a1 -> if a1 `eqModel` a-                       then succeeded-                       else failed $ redText "a1: " $$ text (showModel a1)-                                  $$ redText " ---- is not equals to a:" $$ text (showModel a)-                                  $$ redText "where a was" $$ text (showModel b)-                                  $$ redText "with (invert x) on top:" $$ showPatch (invert x)---- | recommute   AB ↔ B′A′ if and only if B′A′ ↔ AB-recommute :: Patchy p => (FORALL(x y) ((p :> p) C(x y) -> Maybe ((p :> p) C(x y))))-          -> (p :> p) C(a b) -> TestResult-recommute c (x :> y) =-    case c (x :> y) of-    Nothing -> rejected-    Just (y' :> x') ->-       case c (y' :> x') of-         Nothing -> failed (redText "failed" $$ showPatch y' $$ redText ":>" $$ showPatch x')-         Just (x'' :> y'') ->-             case y'' =/\= y of-             NotEq -> failed (redText "y'' =/\\= y failed, where x" $$ showPatch x $$-                              redText ":> y" $$ showPatch y $$-                              redText "y'" $$ showPatch y' $$-                              redText ":> x'" $$ showPatch x' $$-                              redText "x''" $$ showPatch x'' $$-                              redText ":> y''" $$ showPatch y'')-             IsEq -> case x'' =/\= x of-                     NotEq -> failed (redText "x'' /= x" $$ showPatch x'' $$ redText ":>" $$ showPatch y'')-                     IsEq -> succeeded---- | commuteInverses   AB ↔ B′A′ if and only if B⁻¹A⁻¹ ↔ A′⁻¹B′⁻¹-commuteInverses :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-                 -> (p :> p) C(a b) -> TestResult-commuteInverses c (x :> y) =-    case c (x :> y) of-    Nothing -> rejected-    Just (y' :> x') ->-        case c (invert y :> invert x) of-        Nothing -> failed $ redText "second commute failed" $$-                            redText "x" $$ showPatch x $$ redText "y" $$ showPatch y $$-                            redText "y'" $$ showPatch y' $$ redText "x'" $$ showPatch x'-        Just (ix' :> iy') ->-            case invert ix' =/\= x' of-            NotEq -> failed $ redText "invert ix' /= x'" $$-                              redText "x" $$ showPatch x $$-                              redText "y" $$ showPatch y $$-                              redText "y'" $$ showPatch y' $$-                              redText "x'" $$ showPatch x' $$-                              redText "ix'" $$ showPatch ix' $$-                              redText "iy'" $$ showPatch iy' $$-                              redText "invert ix'" $$ showPatch (invert ix') $$-                              redText "invert iy'" $$ showPatch (invert iy')-            IsEq -> case y' =\/= invert iy' of-                    NotEq -> failed $ redText "y' /= invert iy'" $$ showPatch iy' $$ showPatch y'-                    IsEq -> succeeded---- | effect preserving  AB <--> B'A' then effect(AB) = effect(B'A')-effectPreserving :: (Patchy p, RepoModel model, ApplyState p ~ RepoState model) =>-                        (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-                     -> WithState model (p :> p) C(a b) -> TestResult-effectPreserving c (WithState r (x :> y) r')-  = case c (x :> y) of-    Nothing         -> rejected-    Just (y' :> x') ->-      case maybeFail $ repoApply r y' of-      Nothing  -> failed $ redText "y' is not applicable to r."-      Just r_y' ->-        case maybeFail $ repoApply r_y' x' of-        Nothing     -> failed $ redText "x' is not applicable to r_y'."-        Just r_y'x' -> if r_y'x' `eqModel` r'-                          then succeeded-                          else failed $ redText "r_y'x' is not equal to r'."---- | patchAndInverseCommute   If AB ↔ B′A′ then A⁻¹B′ ↔ BA′⁻¹-patchAndInverseCommute :: Patchy p =>-                             (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-                          -> (p :> p) C(a b) -> TestResult-patchAndInverseCommute c (x :> y) =-  case c (x :> y) of-  Nothing -> rejected-  Just (y' :> x') ->-     case c (invert x :> y') of-       Nothing -> failed (redText ""-                          $$ redText "-------- original commute (x :> y):"-                          $$ showPatch x $$ redText ":>" $$ showPatch y-                          $$ redText "-------- result (y' :> x'):"-                          $$ showPatch y' $$ redText ":>" $$ showPatch x'-                          $$ redText "-------- bad commute (invert x :> y'):"-                          $$ showPatch (invert x) $$ redText ":>" $$ showPatch y')-       Just (y'' :> ix') ->-           case y'' =\/= y of-           NotEq -> failed (redText "y'' /= y" $$-                            redText "x" $$ showPatch x $$-                            redText "y" $$ showPatch y $$-                            redText "x'" $$ showPatch x' $$-                            redText "y'" $$ showPatch y' $$-                            redText "y''" $$ showPatch y'' $$-                            redText ":> x'" $$ showPatch x')-           IsEq -> case x' =\/= invert ix' of-                   NotEq -> failed (redText "x' /= invert ix'" $$-                                    redText "y''" $$ showPatch y'' $$-                                    redText ":> x'" $$ showPatch x' $$-                                    redText "invert x" $$ showPatch (invert x) $$-                                    redText ":> y" $$ showPatch y $$-                                    redText "y'" $$ showPatch y' $$-                                    redText "ix'" $$ showPatch ix')-                   IsEq -> succeeded--permutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-            -> (p :> p :> p) C(a b) -> TestResult-permutivity c (x:>y:>z) =-  case c (x :> y) of-  Nothing -> rejected-  Just (y1 :> x1) ->-    case c (y :> z) of-    Nothing -> rejected-    Just (z2 :> y2) ->-      case c (x :> z2) of-      Nothing -> rejected-      Just (z3 :> x3) ->-        case c (x1 :> z) of-          Nothing -> failed $ redText "permutivity1"-          Just (z4 :> x4) ->-            --traceDoc (greenText "third commuted" $$-            --          greenText "about to commute" $$-            --          greenText "y1" $$ showPatch y1 $$-            --          greenText "z4" $$ showPatch z4) $-            case c (y1 :> z4) of-            Nothing -> failed $ redText "permutivity2"-            Just (z3_ :> y4)-                | IsEq <- z3_ =\/= z3 ->-                     --traceDoc (greenText "passed z3") $ error "foobar test" $-                     case c (y4 :> x4) of-                     Nothing -> failed $ redText "permutivity5: input was" $$-                                         redText "x" $$ showPatch x $$-                                         redText "y" $$ showPatch y $$-                                         redText "z" $$ showPatch z $$-                                         redText "z3" $$ showPatch z3 $$-                                         redText "failed commute of" $$-                                         redText "y4" $$ showPatch y4 $$-                                         redText "x4" $$ showPatch x4 $$-                                         redText "whereas commute of x and y give" $$-                                         redText "y1" $$ showPatch y1 $$-                                         redText "x1" $$ showPatch x1-                     Just (x3_ :> y2_)-                          | NotEq <- x3_ =\/= x3 -> failed $ redText "permutivity6"-                          | NotEq <- y2_ =/\= y2 -> failed $ redText "permutivity7"-                          | otherwise -> succeeded-                | otherwise ->-                    failed $ redText "permutivity failed" $$-                             redText "z3" $$ showPatch z3 $$-                             redText "z3_" $$ showPatch z3_--partialPermutivity :: Patchy p => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-                    -> (p :> p :> p) C(a b) -> TestResult-partialPermutivity c (xx:>yy:>zz) = pp (xx:>yy:>zz) <&&> pp (invert zz:>invert yy:>invert xx)-    where pp (x:>y:>z) =-            case c (y :> z) of-            Nothing -> rejected-            Just (z1 :> y1) ->-              case c (x :> z1) of-              Nothing -> rejected-              Just (_ :> x1) ->-                case c (x :> y) of-                  Just _ -> rejected -- this is covered by full permutivity test above-                  Nothing ->-                      case c (x1 :> y1) of-                      Nothing -> succeeded-                      Just _ -> failed $ greenText "partialPermutivity error" $$-                                         greenText "x" $$ showPatch x $$-                                         greenText "y" $$ showPatch y $$-                                         greenText "z" $$ showPatch z--mergeArgumentsConsistent :: Patchy p =>-                              (FORALL(x y) p C(x y) -> Maybe Doc)-                           -> (p :\/: p) C(a b) -> TestResult-mergeArgumentsConsistent isConsistent (x :\/: y) =-  fromMaybe $-    msum [(\z -> redText "mergeArgumentsConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x,-          (\z -> redText "mergeArgumentsConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y]--mergeConsistent :: (Patchy p, Merge p) =>-                           (FORALL(x y) p C(x y) -> Maybe Doc)-                        -> (p :\/: p) C(a b) -> TestResult-mergeConsistent isConsistent (x :\/: y) =-    case merge (x :\/: y) of-    y' :/\: x' ->-      fromMaybe $-        msum [(\z -> redText "mergeConsistent x" $$ showPatch x $$ z) `fmap` isConsistent x,-              (\z -> redText "mergeConsistent y" $$ showPatch y $$ z) `fmap` isConsistent y,-              (\z -> redText "mergeConsistent x'" $$ showPatch x' $$ z $$-                     redText "where x' comes from x" $$ showPatch x $$-                     redText "and y" $$ showPatch y) `fmap` isConsistent x',-              (\z -> redText "mergeConsistent y'" $$ showPatch y' $$ z) `fmap` isConsistent y']--mergeEitherWay :: (Patchy p, Merge p) => (p :\/: p) C(x y) -> TestResult-mergeEitherWay (x :\/: y) =-    case merge (x :\/: y) of-    y' :/\: x' -> case merge (y :\/: x) of-                  x'' :/\: y'' | IsEq <- x'' =\/= x',-                                 IsEq <- y'' =\/= y' -> succeeded-                               | otherwise -> failed $ redText "mergeEitherWay bug"--mergeCommute :: (Patchy p, Merge p) => (p :\/: p) C(x y) -> TestResult-mergeCommute (x :\/: y) =-    case merge (x :\/: y) of-    y' :/\: x' ->-        case commute (x :> y') of-        Nothing -> failed $ redText "mergeCommute 1" $$-                            redText "x" $$ showPatch x $$-                            redText "y" $$ showPatch y $$-                            redText "x'" $$ showPatch x' $$-                            redText "y'" $$ showPatch y'-        Just (y_ :> x'_)-            | IsEq <- y_ =\/= y,-              IsEq <- x'_ =\/= x' ->-                      case commute (y :> x') of-                      Nothing -> failed $ redText "mergeCommute 2 failed" $$-                                          redText "x" $$ showPatch x $$-                                          redText "y" $$ showPatch y $$-                                          redText "x'" $$ showPatch x' $$-                                          redText "y'" $$ showPatch y'-                      Just (x_ :> y'_)-                           | IsEq <- x_ =\/= x,-                             IsEq <- y'_ =\/= y' -> succeeded-                           | otherwise -> failed $ redText "mergeCommute 3" $$-                                                   redText "x" $$ showPatch x $$-                                                   redText "y" $$ showPatch y $$-                                                   redText "x'" $$ showPatch x' $$-                                                   redText "y'" $$ showPatch y' $$-                                                   redText "x_" $$ showPatch x_ $$-                                                   redText "y'_" $$ showPatch y'_-            | otherwise -> failed $ redText "mergeCommute 4" $$-                                    redText "x" $$ showPatch x $$-                                    redText "y" $$ showPatch y $$-                                    redText "x'" $$ showPatch x' $$-                                    redText "y'" $$ showPatch y' $$-                                    redText "x'_" $$ showPatch x'_ $$-                                    redText "y_" $$ showPatch y_----- | join effect preserving-joinEffectPreserving :: (PrimPatch prim, RepoModel model, ApplyState prim ~ RepoState model )-                     => (FORALL(x y) (prim :> prim) C(x y) -> Maybe (FL prim C(x y)))-                      -> WithState model (prim :> prim) C(a b) -> TestResult-joinEffectPreserving j (WithState r (a :> b) r') =-  case j (a :> b) of-       Nothing -> rejected-       Just x  -> case maybeFail $ repoApply r x of-                       Nothing  -> failed $ redText "x is not applicable to r."-                       Just r_x -> if r_x `eqModel` r'-                                      then succeeded-                                      else failed $ redText "r_x /= r'"--joinCommute :: (PrimPatch prim) => (FORALL(x y) (prim :> prim) C(x y) -> Maybe (FL prim C(x y)))-             -> (prim :> prim :> prim) C(a b) -> TestResult-joinCommute j (a :> b :> c) =-    case j (b :> c) of-    Nothing -> rejected-    Just x  ->-       case commuteFLorComplain (a :> b :>: c :>: NilFL) of-        Right (b' :>: c' :>: NilFL :> a') ->-           case commute (a:>:NilFL :> x) of-             Just (x' :> a'':>:NilFL) ->-                 case a'' =/\= a' of-                 NotEq -> failed $ greenText "joinCommute 3"-                 IsEq -> case j (b' :> c') of-                         Nothing -> failed $ greenText "joinCommute 4"-                         Just x'' -> case x' =\/= x'' of-                                     NotEq -> failed $ greenText "joinCommute 5"-                                     IsEq -> succeeded-             _ -> failed $ greenText "joinCommute 1"-        _ -> rejected--show_read :: (Show2 p, Patchy p) => p C(a b) -> TestResult-show_read p = let ps = renderPS (showPatch p)-              in case readPatch ps of-                 Nothing -> failed (redText "unable to read " $$ showPatch p)-                 Just (Sealed p'  ) | IsEq <- p' =\/= p -> succeeded-                                    | otherwise -> failed $ redText "trouble reading patch p" $$-                                                            showPatch p $$-                                                            redText "reads as p'" $$-                                                            showPatch p' $$-                                                            redText "aka" $$-                                                            greenText (show2 p) $$-                                                            redText "and" $$-                                                            greenText (show2 p')---- vim: fileencoding=utf-8 :
− src/Darcs/Test/Patch/Properties/GenericUnwitnessed.hs 
@@ -1,90 +0,0 @@-module Darcs.Test.Patch.Properties.GenericUnwitnessed where--import qualified Darcs.Test.Patch.Properties.Generic as W-     ( permutivity, partialPermutivity-     , mergeConsistent, mergeArgumentsConsistent, mergeEitherWay-     , mergeCommute, patchAndInverseCommute, joinCommute, commuteInverses-     , recommute-     , show_read )-import Darcs.Test.Patch.Arbitrary.Generic ( Tree )-import Darcs.Test.Patch.RepoModel( RepoModel, RepoState )-import Darcs.Test.Patch.WithState( WithStartState )--import qualified Darcs.Test.Patch.Properties.Real as W ( propConsistentTreeFlattenings )-import Darcs.Test.Patch.WSub-import Darcs.Test.Util.TestResult--import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.Patchy ( showPatch )-import Darcs.Witnesses.Show-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Sealed( Sealed )-import Darcs.Patch.Merge ( Merge )-import Darcs.Patch ( Patchy )-import Printer ( Doc, redText, ($$) )-import qualified Storage.Hashed.Tree as HST ( Tree )--#include "gadts.h"--permutivity :: (Patchy wp, WSub wp p) => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-            -> (p :> p :> p) C(a b) -> TestResult-permutivity f = W.permutivity (fmap toW . f . fromW) . toW--partialPermutivity :: (Patchy wp, WSub wp p) => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-                    -> (p :> p :> p) C(a b) -> TestResult-partialPermutivity f = W.partialPermutivity (fmap toW . f . fromW) . toW--mergeEitherWay :: (Patchy wp, Merge wp, WSub wp p) => (p :\/: p) C(x y) -> TestResult-mergeEitherWay = W.mergeEitherWay . toW--commuteInverses :: (Patchy wp, WSub wp p) => (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-                 -> (p :> p) C(a b) -> TestResult-commuteInverses f = W.commuteInverses (fmap toW . f . fromW) . toW--recommute :: (Patchy wp, WSub wp p) => (FORALL(x y) ((p :> p) C(x y) -> Maybe ((p :> p) C(x y))))-          -> (p :> p) C(a b) -> TestResult-recommute f = W.recommute (fmap toW . f . fromW) . toW--mergeCommute :: (Patchy wp, Merge wp, WSub wp p) => (p :\/: p) C(x y) -> TestResult-mergeCommute = W.mergeCommute . toW--mergeConsistent :: (Patchy wp, Merge wp, WSub wp p) =>-                           (FORALL(x y) p C(x y) -> Maybe Doc)-                        -> (p :\/: p) C(a b) -> TestResult-mergeConsistent f = W.mergeConsistent (f . fromW) . toW--mergeArgumentsConsistent :: (Patchy wp, WSub wp p) =>-                              (FORALL(x y) p C(x y) -> Maybe Doc)-                           -> (p :\/: p) C(a b) -> TestResult-mergeArgumentsConsistent f = W.mergeArgumentsConsistent (f . fromW) . toW--show_read :: (Patchy p, Show2 p) => p C(x y) -> TestResult-show_read = W.show_read--patchAndInverseCommute :: (Patchy wp, WSub wp p) =>-                             (FORALL(x y) (p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-                          -> (p :> p) C(a b) -> TestResult-patchAndInverseCommute f = W.patchAndInverseCommute (fmap toW . f . fromW) . toW---joinCommute :: (FORALL(x y) (Prim :> Prim) C(x y) -> Maybe (FL Prim C(x y)))-             -> (Prim :> Prim :> Prim) C(a b) -> TestResult-joinCommute f = W.joinCommute (fmap toW . f . fromW) . toW--consistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model)-                          => Sealed (WithStartState model (Tree Prim)) -> TestResult-consistentTreeFlattenings = (\x -> if W.propConsistentTreeFlattenings x-                                      then succeeded-                                      else failed $ redText "oops")--commuteFails :: (MyEq p, Patchy p)-             => ((p :> p) C(x y) -> Maybe ((p :> p) C(x y)))-             -> (p :> p) C(x y)-             -> TestResult-commuteFails c (x :> y) = case c (x :> y) of-                            Nothing -> succeeded-                            Just (y' :> x') ->-                              failed $ redText "x" $$ showPatch x $$-                                       redText ":> y" $$ showPatch y $$-                                       redText "y'" $$ showPatch y' $$-                                       redText ":> x'" $$ showPatch x'
− src/Darcs/Test/Patch/Properties/Real.hs 
@@ -1,35 +0,0 @@-module Darcs.Test.Patch.Properties.Real-       ( propConsistentTreeFlattenings ) where--import Darcs.Test.Patch.Arbitrary.Generic ( Tree, flattenTree, G2(..), mapTree )-import Darcs.Test.Patch.WithState-import Darcs.Test.Patch.RepoModel ( RepoModel, repoApply, showModel, eqModel, RepoState-                                  , Fail, maybeFail )-import qualified Storage.Hashed.Tree as HST ( Tree )--import Darcs.Witnesses.Sealed( Sealed(..) )-import Darcs.Patch.V2.Real( prim2real )-import Darcs.Patch.Prim.V1 ( Prim )--#include "gadts.h"-#include "impossible.h"--assertEqualFst :: (RepoModel a, Show b, Show c) => (Fail (a x), b) -> (Fail (a x), c) -> Bool-assertEqualFst (x,bx) (y,by)-    | Just x' <- maybeFail x, Just y' <- maybeFail y, x' `eqModel` y' = True-    | Nothing <- maybeFail x, Nothing <- maybeFail y = True-    | otherwise = error ("Not really equal:\n" ++ showx ++ "\nand\n" ++ showy-                         ++ "\ncoming from\n" ++ show bx ++ "\nand\n" ++ show by)-      where showx | Just x' <- maybeFail x = showModel x'-                  | otherwise = "Nothing"-            showy | Just y' <- maybeFail y = showModel y'-                  | otherwise = "Nothing"--propConsistentTreeFlattenings :: (RepoState model ~ HST.Tree, RepoModel model)-                              => Sealed (WithStartState model (Tree Prim)) -> Bool-propConsistentTreeFlattenings (Sealed (WithStartState start t))-  = fromJust $-    do Sealed (G2 flat) <- return $ flattenTree $ mapTree prim2real t-       rms <- return $ map (start `repoApply`) flat-       return $ and $ zipWith assertEqualFst (zip rms flat) (tail $ zip rms flat)-
− src/Darcs/Test/Patch/Properties/V1Set1.hs 
@@ -1,155 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Darcs.Test.Patch.Properties.V1Set1-       ( checkMerge, checkMergeEquiv, checkMergeSwap, checkCanon-       , checkCommute, checkCantCommute-       , tShowRead-       , tMergeEitherWayValid, tTestCheck ) where--import Darcs.Patch-     ( Patchy, commute, invert, merge, effect-     , readPatch, showPatch-     , fromPrim, canonize, sortCoalesceFL )-import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.Merge ( Merge )-import qualified Darcs.Patch.V1 as V1 ( Patch )-import Darcs.Test.Patch.Properties.Check ( checkAPatch, Check )-import Printer ( renderPS )-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Show-import Darcs.Witnesses.Sealed ( Sealed(Sealed) )-import Darcs.Witnesses.Unsafe( unsafeCoercePEnd )-import Darcs.Test.Util.TestResult-import Printer ( text )--#include "gadts.h"--type Patch = V1.Patch Prim---quickmerge :: (Patchy p, Merge p) => (p :\/: p ) C(x y) -> p C(y z)-quickmerge (p1:\/:p2) = case merge (p1:\/:p2) of-                        _ :/\: p1' -> unsafeCoercePEnd p1'--instance Show2 p => Show ((p :/\: p) C(x y)) where-   show (x :/\: y) = show2 x ++ " :/\\: " ++ show2 y-instance Show2 p => Show ((p :< p) C(x y)) where-   show (x :< y) = show2 x ++ " :< " ++ show2 y-instance MyEq p => Eq ((p :/\: p) C(x y)) where-   (x :/\: y) == (x' :/\: y') = isIsEq (x =\/= x') && isIsEq (y =\/= y')---- ------------------------------------------------------------------------------- A number of "comparison" properties: these carry out some operation on--- inputs (first value in the pair) and compare the results with a known--- expected value (the second value in the pair).-----checkMerge :: ((FL Patch:\/: FL Patch) C(x y), FL Patch C(y z)) -> TestResult-checkMerge (p1:\/:p2,p1') =-   case merge (p1:\/:p2) of-   _ :/\: p1a ->-       if isIsEq (p1a `eqFL` p1')-       then succeeded-       else failed $ text $ "Merge gave wrong value!\n"++show p1++show p2-            ++"I expected\n"++show p1'-            ++"but found instead\n"++show p1a--checkMergeEquiv :: ((FL Patch:\/:FL Patch) C(x y),FL Patch C(y z)) -> TestResult-checkMergeEquiv (p1:\/: p2, pe) =-    case quickmerge (p1:\/:p2) of-    p1' -> if checkAPatch (invert p1 :>: p2 :>: p1' :>: invert pe :>: NilFL)-           then succeeded-           else failed $ text $ "Oh no, merger isn't equivalent...\n"++show p1++"\n"++show p2-                 ++"in other words\n" ++ show (p1 :\/: p2)-                 ++"merges as\n" ++ show (merge $ p1 :\/: p2)-                 ++"merges to\n" ++ show (quickmerge $ p1 :\/: p2)-                 ++"which is equivalent to\n" ++ show (effect p1')-                 ++ "should all work out to\n"-                 ++ show pe--checkMergeSwap :: (FL Patch C(x y), FL Patch C(x z)) -> TestResult-checkMergeSwap (p1, p2) =-    case merge (p2:\/:p1) of-    _ :/\: p2' ->-        case merge (p1:\/:p2) of-        _ :/\: p1' ->-            case commute (p1:>p2') of-            Just (_:>p1'b) ->-                if not $ p1'b `eqFLUnsafe` p1'-                then failed $ text $ "Merge swapping problem with...\np1 "++-                      show p1++"merged with\np2 "++-                      show p2++"p1' is\np1' "++-                      show p1'++"p1'b is\np1'b  "++-                      show p1'b-                else succeeded-            Nothing -> failed $ text $ "Merge commuting problem with...\np1 "++-                        show p1++"merged with\np2 "++-                        show p2++"gives\np2' "++-                        show p2'++"which doesn't commute with p1.\n"--checkCanon :: FORALL(x y) (FL Patch C(x y), FL Patch C(x y)) -> TestResult-checkCanon (p1,p2) =-    if isIsEq $ eqFL p1_ p2-    then succeeded-    else failed $ text $ "Canonization failed:\n"++show p1++"canonized is\n"-          ++show (p1_ :: FL Patch C(x y))-          ++"which is not\n"++show p2-    where p1_ = mapFL_FL fromPrim $ concatFL $ mapFL_FL canonize $ sortCoalesceFL $ effect p1--checkCommute :: ((FL Patch:< FL Patch) C(x y), (FL Patch:< FL Patch) C(x y)) -> TestResult-checkCommute (p1:<p2,p2':<p1') =-   case commute (p2:>p1) of-   Just (p1a:>p2a) ->-       if (p2a:< p1a) == (p2':< p1')-       then succeeded-       else failed $ text $ "Commute gave wrong value!\n"++show p1++"\n"++show p2-             ++"should be\n"++show p2'++"\n"++show p1'-             ++"but is\n"++show p2a++"\n"++show p1a-   Nothing -> failed $ text $ "Commute failed!\n"++show p1++"\n"++show p2-   <&&>-   case commute (p1':>p2') of-   Just (p2a:>p1a) ->-       if (p1a:< p2a) == (p1:< p2)-       then succeeded-       else failed $ text $ "Commute gave wrong value!\n"++show p2a++"\n"++show p1a-             ++"should have been\n"++show p2'++"\n"++show p1'-   Nothing -> failed $ text $ "Commute failed!\n"++show p2'++"\n"++show p1'--checkCantCommute :: (FL Patch:< FL Patch) C(x y) -> TestResult-checkCantCommute (p1:<p2) =-    case commute (p2:>p1) of-    Nothing -> succeeded-    _ -> failed $ text $ show p1 ++ "\n\n" ++ show p2 ++-          "\nArgh, these guys shouldn't commute!\n"---- ------------------------------------------------------------------------------- A few "test" properties, doing things with input patches and giving a OK/not--- OK type of answer.--tShowRead :: (Show2 p, Patchy p) => (FORALL(x y w z) p C(x y) -> p C(w z) -> Bool) -> FORALL(x y) p C(x y) -> TestResult-tShowRead eq p =-    case readPatch $ renderPS $ showPatch p of-    Just (Sealed p') -> if p' `eq` p then succeeded-                        else failed $ text $ "Failed to read shown:  "++(show2 p)++"\n"-    Nothing -> failed $ text $ "Failed to read at all:  "++(show2 p)++"\n"--tMergeEitherWayValid :: FORALL(x y p) (Check p, Show2 p, Merge p, Patchy p) => (p :\/: p) C(x y) -> TestResult-tMergeEitherWayValid (p1 :\/: p2) =-  case p2 :>: quickmerge (p1:\/: p2) :>: NilFL of-  combo2 ->-    case p1 :>: quickmerge (p2:\/: p1) :>: NilFL of-    combo1 ->-      if not $ checkAPatch combo1-      then failed $ text $ "oh my combo1 invalid:\n"++show2 p1++"and...\n"++show2 p2++show combo1-      else-        if checkAPatch (invert combo1 :>: combo2 :>: NilFL)-        then succeeded-        else failed $ text $ "merge both ways invalid:\n"++show2 p1++"and...\n"++show2 p2++-              show combo1++-              show combo2--tTestCheck :: FORALL(x y) FL Patch C(x y) -> TestResult-tTestCheck p = if checkAPatch p-                 then succeeded-                 else failed $ text $ "Failed the check:  "++show p++"\n"
− src/Darcs/Test/Patch/Properties/V1Set2.hs 
@@ -1,315 +0,0 @@--- Copyright (C) 2002-2003,2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Test.Patch.Properties.V1Set2-    ( propCommuteInverse, propPatchAndInverseIsIdentity-    , propSimpleSmartMergeGoodEnough, propCommuteEquivalency-    , propMergeValid, propInverseValid, propOtherInverseValid-    , propCommuteEitherOrder-    , propCommuteEitherWay, propCommuteTwice-    , propMergeIsCommutableAndCorrect, propMergeIsSwapable--    , checkSubcommutes-    , subcommutesInverse, subcommutesNontrivialInverse, subcommutesFailure--    , propReadShow-    -- TODO: these are exported temporarily to mark them as used-    -- Figure out whether to enable or remove the tests.-    , propUnravelThreeMerge, propUnravelSeqMerge-    , propUnravelOrderIndependent, propResolveConflictsValid-    ) where--import Prelude hiding ( pi )-import Test.QuickCheck-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.Framework ( Test )-import Data.Maybe ( isJust )--import Darcs.Test.Patch.Properties.Check ( Check, checkAPatch )--import Darcs.Patch ( invert, commute, merge,-                     readPatch, resolveConflicts,-                     fromPrim, showPatch )-import Darcs.Patch.Commute ( Commute )-import Darcs.Patch.Invert ( Invert )-import qualified Darcs.Patch.V1 as V1 ( Patch )-import Darcs.Patch.V1.Commute ( unravel, merger )-import Darcs.Patch.Prim.V1 ()-import Darcs.Patch.Prim.V1.Core ( Prim(..) )-import Darcs.Patch.Prim.V1.Commute ( WrappedCommuteFunction(..), Perhaps(..),-                                     subcommutes )-import Printer ( renderPS )-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed ( Sealed(Sealed), unsafeUnseal, unseal, mapSeal, Sealed2(..) )-import Darcs.Witnesses.Unsafe--#include "impossible.h"--type Patch = V1.Patch Prim----- | Groups a set of tests by giving them the same prefix in their description.---   When this is called as @checkSubcommutes subcoms expl@, the prefix for a---   test becomes @"Checking " ++ expl ++ " for subcommute "@.-checkSubcommutes :: Testable a => [(String, a)] -> String-                                                 -> [Test]-checkSubcommutes subcoms expl = map check_subcommute subcoms-  where check_subcommute (name, test) =-            let testName = expl ++ " for subcommute " ++ name-            in testProperty testName test--propInverseValid :: Sealed2 (FL Patch) -> Bool-propInverseValid (Sealed2 p1) = checkAPatch (invert p1:>:p1:>:NilFL)-propOtherInverseValid :: Sealed2 (FL Patch) -> Bool-propOtherInverseValid (Sealed2 p1) = checkAPatch (p1:>:invert p1:>:NilFL)--propCommuteTwice :: Sealed2 (FL Patch :> FL Patch) -> Property-propCommuteTwice (Sealed2 (p1:>p2)) =-    (doesCommute p1 p2) ==> (Just (p1:>p2) == (commute (p1:>p2) >>= commute))-doesCommute :: (MyEq p, Invert p, Commute p, Check p) => p C(x y) -> p C(y z) -> Bool-doesCommute p1 p2 =-    commute (p1:>p2) /= Nothing && checkAPatch (p1:>:p2:>:NilFL)-propCommuteEquivalency :: Sealed2 (FL Patch :> FL Patch) -> Property-propCommuteEquivalency (Sealed2 (p1:>p2)) =-    (doesCommute p1 p2) ==>-    case commute (p1:>p2) of-    Just (p2':>p1') -> checkAPatch (p1:>:p2:>:invert p1':>:invert p2':>:NilFL)-    _ -> impossible--propCommuteEitherWay :: Sealed2 (FL Patch :> FL Patch) -> Property-propCommuteEitherWay (Sealed2 (p1:>p2)) =-    doesCommute p1 p2 ==> doesCommute (invert p2) (invert p1)--propCommuteEitherOrder :: Sealed2 (FL Patch :> FL Patch :> FL Patch) -> Property-propCommuteEitherOrder (Sealed2 (p1:>p2:>p3)) =-    checkAPatch (p1:>:p2:>:p3:>:NilFL) &&-    doesCommute p1 (p2+>+p3) &&-    doesCommute p2 p3 ==>-    case commute (p1:>p2) of-    Nothing -> False-    Just (p2':>p1') ->-        case commute (p1':>p3) of-        Nothing -> False-        Just (p3':>_) ->-            case commute (p2':>p3') of-            Nothing -> False-            Just (p3'' :> _) ->-                case commute (p2:>p3) of-                Nothing -> False-                Just (p3'a:>_) ->-                    case commute (p1:>p3'a) of-                    Just (p3''a:>_) -> isIsEq (p3''a =\/= p3'')-                    Nothing -> False--propPatchAndInverseIsIdentity :: Sealed2 (FL Patch :> FL Patch) -> Property-propPatchAndInverseIsIdentity (Sealed2 (p1:>p2)) =-    checkAPatch (p1:>:p2:>:NilFL) && (commute (p1:>p2) /= Nothing) ==>-    case commute (p1:>p2) of-    Just (p2':>_) -> case commute (invert p1:>p2') of-                    Nothing -> True -- This is a subtle distinction.-                    Just (p2'':>_) -> isIsEq (p2'' =\/= p2)-    Nothing -> impossible--propMergeIsCommutableAndCorrect :: Sealed2 (FL Patch :\/: FL Patch) -> Property-propMergeIsCommutableAndCorrect (Sealed2 (p1:\/:p2)) =-    checkAPatch (invert p1:>:p2:>:NilFL) ==>-    case merge (p2:\/:p1) of-    p1' :/\: p2' ->-        case commute (p1:>p2') of-        Nothing -> False-        Just (p2'':>p1'') -> isIsEq (p2'' =\/= p2) && isIsEq (p1' =/\= p1'')-propMergeIsSwapable :: Sealed2 (FL Patch :\/: FL Patch) -> Property-propMergeIsSwapable (Sealed2 (p1:\/:p2)) =-    checkAPatch (invert p1:>:p2:>:NilFL) ==>-    case merge (p2:\/:p1) of-    p1' :/\: p2' ->-           case merge (p1:\/:p2) of-           p2''' :/\: p1''' -> isIsEq (p1' =\/= p1''') && isIsEq (p2' =\/= p2''')--propMergeValid :: Sealed2 (FL Patch :\/: FL Patch) -> Property-propMergeValid (Sealed2 (p1:\/:p2)) =-    checkAPatch (invert p1:>:p2:>:NilFL) ==>-    case merge (p2:\/:p1) of-    _ :/\: p2' ->-        checkAPatch (invert p1:>:p2:>:invert p2:>:p1:>:p2':>:NilFL)--propSimpleSmartMergeGoodEnough :: Sealed2 (FL Patch :\/: FL Patch) -> Property-propSimpleSmartMergeGoodEnough (Sealed2 (p1:\/:p2)) =-    checkAPatch (invert p1:>:p2:>:NilFL) ==>-    case simpleSmartMerge (p1 :\/: p2) of-      Nothing -> True-      Just (Sealed p1'a)-       -> isJust ((do-                    p1o :> _ <- commute (p2 :> p1'a)-                    IsEq <- return $ p1o =\/= p1-                    Sealed p2'a <- simpleSmartMerge (p2 :\/: p1)-                    p2b :> p1'b <- commute (p1 :> p2'a)-                    IsEq <- return $ p2 =\/= p2b-                    IsEq <- return $ p1'a =\/= p1'b-                    return ()) :: Maybe ())--simpleSmartMerge :: (Commute p, Invert p) => (p :\/: p) C(x y) -> Maybe (Sealed (p C(y)))-simpleSmartMerge (p1 :\/: p2) =-  case commute (invert p2 :> p1) of-  Just (p1':>_) -> Just (Sealed p1')-  Nothing -> Nothing---- | The conflict resolution code (glump) begins by "unravelling" the merger--- into a set of sequences of patches.  Each sequence of patches corresponds--- to one non-conflicted patch that got merged together with the others.  The--- result of the unravelling of a series of merges must obviously be--- independent of the order in which those merges are performed.  This--- unravelling code (which uses the unwind code mentioned above) uses probably--- the second most complicated algorithm.  Fortunately, if we can successfully--- unravel the merger, almost any function of the unravelled merger satisfies--- the two constraints mentioned above that the conflict resolution code must--- satisfy.-propUnravelThreeMerge :: Patch C(x y) -> Patch C(x z) -> Patch C(x w) -> Property-propUnravelThreeMerge p1 p2 p3 =-    checkAPatch (invert p1:>:p2:>:invert p2:>:p3:>:NilFL) ==>-    (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p2 p3)) (unsafeUnseal (merger "0.0" p2 p1))) ==-    (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal (merger "0.0" p1 p3)) (unsafeUnseal (merger "0.0" p1 p2)))--propUnravelSeqMerge :: Patch C(x y) -> Patch C(x z) -> Patch C(z w) -> Property-propUnravelSeqMerge p1 p2 p3 =-    checkAPatch (invert p1:>:p2:>:p3:>:NilFL) ==>-    (unravel $ unsafeUnseal $ merger "0.0" p3 $ unsafeUnseal $ merger "0.0" p2 p1) ==-    (unravel $ unsafeUnseal $ merger "0.0" (unsafeUnseal $ merger "0.0" p2 p1) p3)--propUnravelOrderIndependent :: Patch C(x y) -> Patch C(x z) -> Property-propUnravelOrderIndependent p1 p2 =-    checkAPatch (invert p1:>:p2:>:NilFL) ==>-    (unravel $ unsafeCoercePStart $ unsafeUnseal $ merger "0.0" p2 p1) == (unravel $ unsafeUnseal $ merger "0.0" p1 p2)--propResolveConflictsValid :: Patch C(x y) -> Patch C(x z) -> Property-propResolveConflictsValid p1 p2 =- case merge (p1:\/:p2) of- _ :/\: p1' ->-   let p = p2:>:p1':>:NilFL in-    checkAPatch (invert p1:>:p2:>:NilFL) ==>-    and $ map (\l -> (\ml -> checkAPatch (p+>+ml)) `unseal` mergeList l)-            $ resolveConflicts p--mergeList :: [Sealed (FL Prim C(x))] -> Sealed (FL Patch C(x))-mergeList patches = mapFL_FL fromPrim `mapSeal` doml NilFL patches-    where doml :: FL Prim C(x y) -> [Sealed (FL Prim C(x))] -> Sealed (FL Prim C(x))-          doml mp (Sealed p:ps) =-              case commute (invert p :> mp) of-              Just (mp' :> _) -> doml (p +>+ mp') ps-              Nothing -> doml mp ps -- This shouldn't happen for "good" resolutions.-          doml mp [] = Sealed mp--propReadShow :: FL Patch C(x y) -> Bool-propReadShow p = case readPatch $ renderPS $ showPatch p of-                   Just (Sealed p') -> isIsEq (p' =\/= p)-                   Nothing -> False---- |In order for merges to work right with commuted patches, inverting a patch--- past a patch and its inverse had golly well better give you the same patch--- back again.-propCommuteInverse :: Sealed2 (FL Patch :> FL Patch) -> Property-propCommuteInverse (Sealed2 (p1 :> p2)) =-    doesCommute p1 p2 ==> case commute (p1 :> p2) of-                           Nothing -> impossible-                           Just (_ :> p1') ->-                               case commute (p1' :> invert p2) of-                               Nothing -> False-                               Just (_ :> p1'') -> isIsEq (p1'' =/\= p1)--type CommuteProperty = Sealed2 (Prim :> Prim) -> Property--subcommutesInverse :: [(String, CommuteProperty)]-subcommutesInverse = zip names (map prop_subcommute cs)-    where (names, cs) = unzip subcommutes-          prop_subcommute c (Sealed2 (p1:>p2)) =-              does c p1 p2 ==>-              case runWrappedCommuteFunction c (p2:< p1) of-              Succeeded (p1':<p2') ->-                  case runWrappedCommuteFunction c (invert p2:< p1') of-                  Succeeded (p1'':<ip2x') -> isIsEq (p1'' =/\= p1) &&-                      case runWrappedCommuteFunction c (invert p1:< invert p2) of-                      Succeeded (ip2':< ip1') ->-                          case runWrappedCommuteFunction c (p2':< invert p1) of-                          Succeeded (ip1o':< p2o) -> isJust ((do-                                 IsEq <- return $ invert ip1' =/\= p1'-                                 IsEq <- return $ invert ip2' =/\= p2'-                                 IsEq <- return $ ip1o' =/\= ip1'-                                 IsEq <- return $ p2o =\/= p2-                                 IsEq <- return $ p1'' =/\= p1-                                 IsEq <- return $ ip2x' =\/= ip2'-                                 return ()) :: Maybe ())-                          _ -> False-                      _ -> False-                  _ -> False-              _ -> False--subcommutesNontrivialInverse :: [(String, CommuteProperty)]-subcommutesNontrivialInverse = zip names (map prop_subcommute cs)-    where (names, cs) = unzip subcommutes-          prop_subcommute c (Sealed2 (p1 :> p2)) =-              nontrivial c p1 p2 ==>-              case runWrappedCommuteFunction c (p2:< p1) of-              Succeeded (p1':<p2') ->-                  case runWrappedCommuteFunction c (invert p2:< p1') of-                  Succeeded (p1'':<ip2x') -> isIsEq (p1'' =/\= p1) &&-                      case runWrappedCommuteFunction c (invert p1:< invert p2) of-                      Succeeded (ip2':< ip1') ->-                          case runWrappedCommuteFunction c (p2':< invert p1) of-                          Succeeded (ip1o':< p2o) -> isJust ((do-                              IsEq <- return $ invert ip1' =/\= p1'-                              IsEq <- return $ invert ip2' =/\= p2'-                              IsEq <- return $ ip1o' =/\= ip1'-                              IsEq <- return $ p2o =\/= p2-                              IsEq <- return $ p1'' =/\= p1-                              IsEq <- return $ ip2x' =\/= ip2'-                              return ()) :: Maybe ())-                          _ -> False-                      _ -> False-                  _ -> False-              _ -> False--subcommutesFailure :: [(String, CommuteProperty)]-subcommutesFailure = zip names (map prop cs)-    where (names, cs) = unzip subcommutes-          prop c (Sealed2 (p1 :> p2)) =-              doesFail c p1 p2 ==>-                case runWrappedCommuteFunction c (invert p1 :< invert p2) of-                 Failed -> True-                 _ -> False--doesFail :: WrappedCommuteFunction -> Prim C(x y) -> Prim C(y z) -> Bool-doesFail c p1 p2 =-    fails (runWrappedCommuteFunction c (p2:<p1)) && checkAPatch (p1 :>: p2 :>: NilFL)-        where fails Failed = True-              fails _ = False--does :: WrappedCommuteFunction -> Prim C(x y) -> Prim C(y z) -> Bool-does c p1 p2 =-    succeeds (runWrappedCommuteFunction c (p2:<p1)) && checkAPatch (p1 :>: p2 :>: NilFL)-        where succeeds (Succeeded _) = True-              succeeds _ = False--nontrivial :: WrappedCommuteFunction -> Prim C(x y) -> Prim C(y z) -> Bool-nontrivial c p1 p2 =-    succeeds (runWrappedCommuteFunction c (p2:<p1)) && checkAPatch (p1 :>: p2 :>: NilFL)-        where succeeds (Succeeded (p1' :< p2')) = not (p1' `unsafeCompare` p1 && p2' `unsafeCompare` p2)-              succeeds _ = False
− src/Darcs/Test/Patch/RepoModel.hs 
@@ -1,23 +0,0 @@-module Darcs.Test.Patch.RepoModel where-import Darcs.Patch.Apply ( Apply, ApplyState )-import Test.QuickCheck ( Gen )--type Fail = Either String--unFail :: Either [Char] t -> t-unFail (Right x) = x-unFail (Left err) = error $ "unFail failed: " ++ err--maybeFail :: Either t a -> Maybe a-maybeFail (Right x) = Just x-maybeFail _ = Nothing--class RepoModel model where-  type RepoState model :: (* -> *) -> *-  showModel :: model x -> String-  eqModel :: model x -> model x -> Bool-  aSmallRepo :: Gen (model x)-  repoApply :: (Apply p, ApplyState p ~ RepoState model) => model x -> p x y -> Fail (model y)--type family ModelOf (patch :: * -> * -> *) :: * -> *-
− src/Darcs/Test/Patch/Utils.hs 
@@ -1,24 +0,0 @@-module Darcs.Test.Patch.Utils-    ( testConditional, testStringList )-    where--import Test.Framework ( Test, TestName )-import Test.Framework.Providers.HUnit ( testCase )-import Test.Framework.Providers.QuickCheck2 ( testProperty )-import Test.HUnit ( assertFailure )-import Test.QuickCheck ( Arbitrary, Testable, (==>) )---- | Turns a condition and a test function into a conditional quickcheck---   property that can be run by test-framework.-testConditional-  :: (Arbitrary a, Show a, Testable prop) => TestName     -- ^ Test name-                                          -> (a -> Bool)  -- ^ Condition-                                          -> (a -> prop)  -- ^ Test function-                                          -> Test-testConditional name cond t = testProperty name t'-    where t' x = cond x ==> t x---- | Utility function to run old tests that return a list of error messages,---   with the empty list meaning success.-testStringList :: String -> [String] -> Test-testStringList name test = testCase name $ mapM_ assertFailure test
− src/Darcs/Test/Patch/V1Model.hs 
@@ -1,289 +0,0 @@-{-# LANGUAGE CPP #-}--#include "gadts.h"---- | Repository model-module Darcs.Test.Patch.V1Model-  ( module Storage.Hashed.AnchoredPath-  , V1Model, repoTree-  , RepoItem, File, Dir, Content-  , makeRepo, emptyRepo-  , makeFile, emptyFile-  , emptyDir-  , nullRepo-  , isFile, isDir-  , fileContent, dirContent-  , isEmpty-  , root-  , filterFiles, filterDirs-  , find-  , list-  , ap2fp-  , aFilename, aDirname-  , aLine, aContent-  , aFile, aDir-  , aRepo-  ) where---import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized )-import Darcs.Test.Patch.RepoModel--import Darcs.Patch.Apply( applyToTree )-import Darcs.Witnesses.Sealed ( Sealed, seal )-import Darcs.Witnesses.Show--import Storage.Hashed.AnchoredPath-import Storage.Hashed.Tree( Tree, TreeItem )-import Storage.Hashed.Darcs ( darcsUpdateHashes )-import qualified Storage.Hashed.Tree as T--import Control.Applicative ( (<$>) )-import Control.Arrow ( second )-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC-import Data.List ( intercalate )-import qualified Data.Map as M-import Test.QuickCheck-  ( Arbitrary(..)-  , Gen, choose, vectorOf, frequency )--#include "impossible.h"---------------------------------------------------------------------------- * Model definition---- | A repository is an abstraction build in top of a 'Tree'.--- NB: Repository preferences are not supported yet.-newtype V1Model C(x) = V1Model {-                           repoTree :: Tree Fail-                         }---- | Repository items may be text files or directories.--- NB: Binary files are not supported yet.-newtype RepoItem = RepoItem {-                      treeItem :: TreeItem Fail-                   }--type File = RepoItem-type Dir  = RepoItem--type Content = [B.ByteString]--------------------------------------------- Instances--instance Show (V1Model C(x)) where-  show repo = "V1Model{ "-            ++ intercalate " " (map showEntry $ list repo)-            ++ " }"-    where-        showPath = show . flatten-        showContent content = "[" ++ intercalate " " (map show content) ++ "]"-        showEntry (path,item)-          | isDir item  = showPath path-          | isFile item = showPath path ++ showContent (fileContent item)-        showEntry _ = impossible--instance Show1 V1Model where-  showDict1 = ShowDictClass--------------------------------------------- Utils--bs2lbs :: B.ByteString -> BL.ByteString-bs2lbs bs = BL.fromChunks [bs]--lbs2bs :: BL.ByteString -> B.ByteString-lbs2bs = B.concat . BL.toChunks--content2lbs :: Content -> BL.ByteString-content2lbs = BLC.unlines . map bs2lbs--lbs2content :: BL.ByteString -> Content-lbs2content = map lbs2bs . BLC.lines--------------------------------------------------------------------------- ** Path conversion--ap2fp :: AnchoredPath -> FilePath-ap2fp = anchorPath ""--------------------------------------------------------------------------- * Constructors--makeRepo :: [(Name, RepoItem)] -> V1Model C(x)-makeRepo = V1Model . T.makeTree . map (second treeItem)--emptyRepo :: V1Model C(x)-emptyRepo = V1Model T.emptyTree--makeFile :: Content -> File-makeFile = RepoItem . T.File . T.makeBlob . content2lbs--emptyFile :: File-emptyFile = RepoItem $ T.File T.emptyBlob--emptyDir :: Dir-emptyDir = RepoItem $ T.SubTree T.emptyTree--------------------------------------------------------------------------- * Queries--nullRepo :: V1Model C(x) -> Bool-nullRepo = M.null . T.items . repoTree--isFile :: RepoItem -> Bool-isFile (RepoItem (T.File _)) = True-isFile _other                = False--isDir :: RepoItem -> Bool-isDir (RepoItem (T.SubTree _)) = True-isDir _other                   = False--fileContent :: File -> Content-fileContent (RepoItem (T.File blob))-  = lbs2content $ unFail $ T.readBlob blob-fileContent _other-  = error "fileContent: Not a file."--dirContent :: Dir -> [(Name, RepoItem)]-dirContent (RepoItem (T.SubTree subtree))-  = map (second RepoItem) $ M.toList $ T.items subtree-dirContent _other-  = error "dirContent: Not a directory."---- | @isEmpty file@ <=> file content is empty---   @isEmpty dir@  <=> dir has no child-isEmpty :: RepoItem -> Bool-isEmpty item-  | isFile item = null $ fileContent item-  | isDir item  = null $ dirContent item-  | otherwise   = undefined---- | The root directory of a repository.-root :: V1Model C(x) -> Dir-root = RepoItem . T.SubTree . repoTree--find :: V1Model C(x) -> AnchoredPath -> Maybe RepoItem-find (V1Model tree) path = RepoItem <$> T.find tree path---- | List repository items.--- NB: It does not include the root directory.-list :: V1Model C(x) -> [(AnchoredPath, RepoItem)]-list (V1Model tree) = map (second RepoItem) $ T.list tree--------------------------------------------------------------------------- ** Filtering--filterFiles :: [(n, RepoItem)] -> [(n, File)]-filterFiles = filter (isFile . snd)--filterDirs :: [(n, RepoItem)] -> [(n, Dir)]-filterDirs = filter (isDir . snd)--------------------------------------------------------------------------- * Comparing repositories--diffRepos :: V1Model C(x) -> V1Model C(y) -> (V1Model C(u), V1Model C(v))-diffRepos repo1 repo2 =-  let (diff1,diff2) = unFail $ T.diffTrees hashedTree1 hashedTree2-    in (V1Model diff1, V1Model diff2)-  where-      hashedTree1, hashedTree2 :: Tree Fail-      hashedTree1 = unFail $ darcsUpdateHashes $ repoTree repo1-      hashedTree2 = unFail $ darcsUpdateHashes $ repoTree repo2---------------------------------------------------------------------------- * Patch application--------------------------------------------------------------------------- * QuickCheck generators---- Testing code assumes that aFilename and aDirname generators--- will always be able to generate a unique name given a list of--- existing names. This should be OK as long as the number of possible--- file/dirnames is much bigger than the number of files/dirs per repository.---- 'Arbitrary' 'V1Model' instance is based on the 'aSmallRepo' generator.----- | Files are distinguish by ending their names with ".txt".-aFilename :: Gen Name-aFilename = do len <- choose (1,maxLength)-               name <- vectorOf len alpha-               return $ makeName (name ++ ".txt")-  where-      maxLength = 3--aDirname :: Gen Name-aDirname = do len <- choose (1,maxLength)-              name <- vectorOf len alpha-              return $ makeName name-  where-      maxLength = 3--aWord :: Gen B.ByteString-aWord = do c <- alpha-           return $ BC.pack[c]--aLine :: Gen B.ByteString-aLine = do wordsNo <- choose (1,2)-           ws <- vectorOf wordsNo aWord-           return $ BC.unwords ws--aContent :: Gen Content-aContent = bSized 0 0.5 80 $ \k ->-             do n <- choose (0,k)-                vectorOf n aLine--aFile :: Gen File-aFile = makeFile <$> aContent---- | See 'aRepo', the same applies for 'aDir'.-aDir :: Int                -- ^ Maximum number of files-        -> Int             -- ^ Maximum number of directories-        -> Gen Dir-aDir filesL dirL = root <$> aRepo filesL dirL---- | @aRepo filesNo dirsNo@ produces repositories with *at most*--- @filesNo@ files and @dirsNo@ directories.--- The structure of the repository is aleatory.-aRepo :: Int                -- ^ Maximum number of files-        -> Int              -- ^ Maximum number of directories-        -> Gen (V1Model C(x))-aRepo maxFiles maxDirs-  = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0-       filesNo <- choose (minFiles,maxFiles)-       let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0-       dirsNo <- choose (minDirs,maxDirs)-            -- NB: Thanks to laziness we don't need to care about division by zero-            -- since if dirsNo == 0 then neither filesPerDirL nor subdirsPerDirL will-            -- be evaluated.-       let filesPerDirL   = (maxFiles-filesNo) `div` dirsNo-           subdirsPerDirL = (maxDirs-dirsNo) `div` dirsNo-       files <- vectorOf filesNo aFile-       filenames <- uniques filesNo aFilename-       dirs <- vectorOf dirsNo (aDir filesPerDirL subdirsPerDirL)-       dirnames <- uniques dirsNo aDirname-       return $ makeRepo (filenames `zip` files ++ dirnames `zip` dirs)---- | Generate small repositories.--- Small repositories help generating (potentially) conflicting patches.-instance RepoModel V1Model where-  type RepoState V1Model = Tree-  showModel m = show m-  aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)]-                  dirsNo <- frequency [(3, return 1), (1, return 0)]-                  aRepo filesNo dirsNo-  repoApply (V1Model tree) patch = V1Model <$> applyToTree patch tree-  eqModel repo1 repo2 = let (diff1,diff2) = diffRepos repo1 repo2-                         in nullRepo diff1 && nullRepo diff2---instance Arbitrary (Sealed V1Model) where-  arbitrary = seal <$> aSmallRepo
− src/Darcs/Test/Patch/V3Model.hs 
@@ -1,216 +0,0 @@-{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-binds -fno-warn-unused-imports -fno-warn-orphans #-}-{-# LANGUAGE CPP, OverloadedStrings, MultiParamTypeClasses, StandaloneDeriving #-}--#include "gadts.h"---- | Repository model-module Darcs.Test.Patch.V3Model-  ( module Storage.Hashed.AnchoredPath-  , V3Model-  , Object(..)-  , repoApply-  , emptyFile-  , emptyDir-  , nullRepo-  , isEmpty-  , root, repoObjects-  , aFilename, aDirname-  , aLine, aContent-  , aFile, aDir-  , aRepo-  , anUUID-  ) where---import Darcs.Test.Util.QuickCheck ( alpha, uniques, bSized )-import Darcs.Test.Patch.RepoModel--import Darcs.Patch.Apply( Apply(..), applyToState )-import Darcs.Patch.ApplyMonad( ApplyMonad(..) )-import Darcs.Patch.Prim.V3.Core( UUID(..), Hunk(..), Prim(..), Object(..) )-import Darcs.Patch.Prim.V3.Apply( ObjectMap(..) )-import Darcs.Witnesses.Sealed ( Sealed, seal )-import Darcs.Witnesses.Show--import Storage.Hashed.AnchoredPath-import Storage.Hashed.Tree( Tree, TreeItem )-import Storage.Hashed.Darcs ( darcsUpdateHashes )-import Storage.Hashed.Hash( Hash(..) )-import qualified Storage.Hashed.Tree as T--import Control.Applicative ( (<$>) )-import Control.Arrow ( second )-import qualified Data.ByteString as BS-import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as BL-import qualified Data.ByteString.Lazy.Char8 as BLC-import Data.List ( intercalate, sort )-import qualified Data.Map as M-import Test.QuickCheck-  ( Arbitrary(..)-  , Gen, choose, vectorOf, frequency, oneof )--#include "impossible.h"---------------------------------------------------------------------------- * Model definition--newtype V3Model C(x) = V3Model { repoMap :: ObjectMap Fail }--------------------------------------------- Instances--instance Show (Object Fail) where-  show (Directory l) = show l-  show (Blob c _) = show c--deriving instance Eq (Object Fail)--instance Show (V3Model x) where-  show = showModel--instance Show1 V3Model where-  showDict1 = ShowDictClass--------------------------------------------------------------------------- * Constructors--objectMap :: (Monad m) => M.Map UUID (Object m) -> ObjectMap m-objectMap map = ObjectMap { getObject = get, putObject = put, listObjects = list }-  where list = return $ M.keys map-        put k o = return $ objectMap (M.insert k o map)-        get k = return $ M.lookup k map--emptyRepo :: V3Model C(x)-emptyRepo = V3Model (objectMap M.empty)--emptyFile :: (Monad m) => Object m-emptyFile = Blob (return BS.empty) NoHash--emptyDir :: Object m-emptyDir = Directory M.empty--------------------------------------------------------------------------- * Queries--nullRepo :: V3Model C(x) -> Bool-nullRepo = null . repoObjects---- | @isEmpty file@ <=> file content is empty---   @isEmpty dir@  <=> dir has no child-isEmpty :: Object Fail -> Bool-isEmpty (Directory d) = M.null d-isEmpty (Blob f _) = BS.null $ unFail f---- | The root directory of a repository.-root :: V3Model C(x) -> Object Fail-root (V3Model repo) = fromJust $ unFail $ getObject repo (UUID "ROOT")--repoObjects :: V3Model C(x) -> [(UUID, Object Fail)]-repoObjects (V3Model repo) = [ (id, obj id) |-                               id <- unFail $ listObjects repo, not $ isEmpty $ obj id ]-  where obj id = fromJust $ unFail $ getObject repo id--------------------------------------------------------------------------- * Comparing repositories--------------------------------------------------------------------------- * QuickCheck generators---- Testing code assumes that aFilename and aDirname generators --- will always be able to generate a unique name given a list of--- existing names. This should be OK as long as the number of possible--- file/dirnames is much bigger than the number of files/dirs per repository.---- 'Arbitrary' 'V3Model' instance is based on the 'aSmallRepo' generator.----- | Files are distinguish by ending their names with ".txt".-aFilename :: Gen BS.ByteString-aFilename = do len <- choose (1,maxLength)-               name <- vectorOf len alpha-               return $ BC.pack $ name ++ ".txt"-  where-      maxLength = 3--aDirname :: Gen BS.ByteString-aDirname = do len <- choose (1,maxLength)-              BC.pack <$> vectorOf len alpha-  where-      maxLength = 3--aWord :: Gen BS.ByteString-aWord = do c <- alpha-           return $ BC.pack[c]--aLine :: Gen BS.ByteString-aLine = do wordsNo <- choose (1,2)-           ws <- vectorOf wordsNo aWord-           return $ BC.unwords ws--aContent :: Gen BS.ByteString-aContent = bSized 0 0.5 80 $ \k ->-             do n <- choose (0,k)-                BC.intercalate "\n" <$> vectorOf n aLine--aFile :: (Monad m) => Gen (Object m)-aFile = aContent >>= \c -> return $ Blob (return c) NoHash--aDir :: (Monad m) => [UUID] -> [UUID] -> Gen [(UUID, Object m)]-aDir [] _ = return []-aDir (dirid:dirids) fileids =-  do dirsplit <- choose (1, length dirids)-     filesplit <- choose (1, length fileids)-     let ids = take filesplit fileids-         rem = drop filesplit fileids-     files <- vectorOf filesplit aFile-     names <- vectorOf filesplit aFilename-     dirnames <- vectorOf dirsplit aDirname-     dirs <- subdirs (take dirsplit dirids)-                     (drop dirsplit dirids)-                     (drop filesplit fileids)-     return $ (dirid, Directory $ M.fromList $ names `zip` ids ++ dirnames `zip` dirids)-            : (fileids `zip` files) ++ dirs-  where subdirs [] _ _ = return []-        subdirs tomake dirs files = do-          dirsplit <- choose (1, length dirs)-          filesplit <- choose (1, length files)-          dir <- aDir (head tomake : take dirsplit dirs) (take filesplit files)-          rem <- subdirs (tail tomake) (drop dirsplit dirs) (drop filesplit files)-          return $ dir ++ rem---anUUID :: Gen UUID-anUUID = UUID . BC.pack <$> vectorOf 32 (oneof $ map return "0123456789")---- | @aRepo filesNo dirsNo@ produces repositories with *at most* --- @filesNo@ files and @dirsNo@ directories. --- The structure of the repository is aleatory.-aRepo :: Int                -- ^ Maximum number of files-        -> Int              -- ^ Maximum number of directories-        -> Gen (V3Model C(x))-aRepo maxFiles maxDirs-  = do let minFiles = if maxDirs == 0 && maxFiles > 0 then 1 else 0-       filesNo <- choose (minFiles,maxFiles)-       let minDirs = if filesNo == 0 && maxDirs > 0 then 1 else 0-       dirsNo <- choose (minDirs,maxDirs)-       dirids <- (UUID "ROOT":) <$> uniques dirsNo anUUID-       fileids <- uniques filesNo anUUID-       objectmap <- aDir dirids fileids-       return $ V3Model $ objectMap $ M.fromList objectmap---- | Generate small repositories.--- Small repositories help generating (potentially) conflicting patches.-instance RepoModel V3Model where-  type RepoState V3Model = ObjectMap-  aSmallRepo = do filesNo <- frequency [(3, return 1), (1, return 2)]-                  dirsNo <- frequency [(3, return 1), (1, return 0)]-                  aRepo filesNo dirsNo-  repoApply (V3Model state) patch = V3Model <$> applyToState patch state-  showModel model = "V3Model{\n" ++ unlines (map entry $ repoObjects model) ++ "}"-    where entry (id, obj) = show id ++ " -> " ++ show obj-  eqModel r1 r2 = repoObjects r1 == repoObjects r2--instance Arbitrary (Sealed V3Model) where-  arbitrary = seal <$> aSmallRepo
− src/Darcs/Test/Patch/WSub.hs 
@@ -1,138 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies, UndecidableInstances #-}-module Darcs.Test.Patch.WSub where--{--The Examples.Set2Unwitnessed module builds a lot of test cases by pattern matching-on the results of merge/commute in where clauses. This would-be very painful to switch to using witnesses properly, because-we'd have to make them use case in series.--So instead we give up on witnesses for this module, but instead-of preprocessor hacks which make incompatible code with the rest-of darcs, we build a fresh set of witnesses constructors (FL etc)-which aren't actually GADTs or existentials. So the pattern matching-works as before, but we need to translate back and forth a lot.--We call the normal darcs constructors the 'W' variants.--}--import qualified Darcs.Test.Patch.Arbitrary.Generic as W-     ( getPairs, getTriples )--import qualified Darcs.Patch as W ( commute )-import qualified Darcs.Patch.Merge as W ( merge, mergeFL )-import qualified Darcs.Patch.Prim as W ( join )--import qualified Darcs.Witnesses.Ordered as W-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Eq-import Darcs.Witnesses.Show-import Darcs.Witnesses.Unsafe ( unsafeCoerceP, unsafeCoercePStart, unsafeCoercePEnd )--import Darcs.Patch.Merge ( Merge )-import Darcs.Patch.Prim.V1 ( Prim )-import Darcs.Patch.V2 ( RealPatch )-import Darcs.Patch.Patchy ( Commute, Invert(..) )--#include "gadts.h"--infixr 5 :>:-infixr 5 +>+-infixr 1 :>-infix 1 :/\:-infix 1 :\/:--data FL p C(x y) where-   NilFL :: FL p C(x y)-   (:>:) :: p C(x y) -> FL p C(x y) -> FL p C(x y)--(+>+) :: FL p C(x y) -> FL p C(x y) -> FL p C(x y)-NilFL +>+ ps = ps-(p :>: ps) +>+ qs = p :>: (ps +>+ qs)--data (p :> q) C(x y) where-   (:>) :: p C(x y) -> q C(x y) -> (p :> q) C(x y)--data (p :\/: q) C(x y) where-   (:\/:) :: p C(x y) -> q C(x y) -> (p :\/: q) C(x y)--data (p :/\: q) C(x y) where-   (:/\:) :: p C(x y) -> q C(x y) -> (p :/\: q) C(x y)--class WSub wp p | p -> wp, wp -> p where-   fromW :: wp C(x y) -> p C(x y)-   toW :: p C(x y) -> wp C(x y)--instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:\/: wp2) (p1 :\/: p2) where-   fromW (x W.:\/: y) = unsafeCoerceP (fromW x) :\/: unsafeCoerceP (fromW y)-   toW (x :\/: y) = unsafeCoerceP (toW x) W.:\/: unsafeCoerceP (toW y)--instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:/\: wp2) (p1 :/\: p2) where-   fromW (x W.:/\: y) = unsafeCoerceP (fromW x) :/\: unsafeCoerceP (fromW y)-   toW (x :/\: y) = unsafeCoerceP (toW x) W.:/\: unsafeCoerceP (toW y)--instance (WSub wp1 p1, WSub wp2 p2) => WSub (wp1 W.:> wp2) (p1 :> p2) where-   fromW (x W.:> y) = unsafeCoercePEnd (fromW x) :> unsafeCoercePStart (fromW y)-   toW (x :> y) = unsafeCoercePEnd (toW x) W.:> unsafeCoercePStart (toW y)--instance WSub wp p => WSub (W.FL wp) (FL p) where-   fromW W.NilFL = unsafeCoerceP NilFL-   fromW (x W.:>: xs) = unsafeCoercePEnd (fromW x) :>: unsafeCoercePStart (fromW xs)--   toW NilFL = unsafeCoerceP W.NilFL-   toW (x :>: xs) = unsafeCoercePEnd (toW x) W.:>: unsafeCoercePStart (toW xs)--instance WSub prim prim => WSub (RealPatch prim) (RealPatch prim) where-   fromW = id-   toW = id--instance WSub Prim Prim where-   fromW = id-   toW = id--instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :> q) C(x y)) where-   show = show . toW--instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :> q) where-   showDict2 = ShowDictClass--instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show ((p :\/: q) C(x y)) where-   show = show . toW--instance (WSub wp p, WSub wq q, Show2 wp, Show2 wq) => Show2 (p :\/: q) where-   showDict2 = ShowDictClass--instance (WSub wp p, Show2 wp) => Show (FL p C(x y)) where-   show = show . toW--instance (WSub wp p, Show2 wp) => Show2 (FL p) where-   showDict2 = ShowDictClass--instance (WSub wp p, Commute wp, MyEq wp) => MyEq (FL p) where-   unsafeCompare x y = unsafeCompare (toW x) (toW y)--instance (WSub wp p, Commute wp, Invert wp) => Invert (FL p) where-   invert = fromW . invert . toW--instance (WSub wp p, Commute wp) => Commute (FL p) where-   commute (xs W.:> ys) = do ys' W.:> xs' <- W.commute (toW xs W.:> toW ys)-                             return (fromW ys' W.:> fromW xs')--mergeFL :: (WSub wp p, Merge wp) => (p :\/: FL p) C(x y) -> (FL p :/\: p) C(x y)-mergeFL = fromW . W.mergeFL . toW--merge :: (WSub wp p, Merge wp) => (p :\/: p) C(x y) -> (p :/\: p) C(x y)-merge = fromW . W.merge . toW--commute :: (WSub wp p, Commute wp) => (p :> p) C(x y) -> Maybe ((p :> p) C(x y))-commute = fmap fromW . W.commute . toW--getPairs :: FL (RealPatch Prim) C(x y) -> [Sealed2 (RealPatch Prim :> RealPatch Prim)]-getPairs = map (mapSeal2 fromW) . W.getPairs . toW--getTriples :: FL (RealPatch Prim) C(x y) -> [Sealed2 (RealPatch Prim :> RealPatch Prim :> RealPatch Prim)]-getTriples = map (mapSeal2 fromW) . W.getTriples . toW--join :: (Prim :> Prim) C(x y) -> Maybe (FL Prim C(x y))-join = fmap fromW . W.join . toW-
− src/Darcs/Test/Patch/WithState.hs 
@@ -1,132 +0,0 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, ScopedTypeVariables, UndecidableInstances #-}--#include "gadts.h"--module Darcs.Test.Patch.WithState-  where---import Darcs.Witnesses.Ordered-import Darcs.Witnesses.Sealed-import Darcs.Witnesses.Show-import Test.QuickCheck ( Gen, sized, choose )----------------------------------------------------------------------------- * WithState--data WithState s p C(x y) = WithState {-                              wsStartState :: s C(x)-                            , wsPatch      :: p C(x y)-                            , wsEndState   :: s C(y)-                            }-    deriving Eq--instance (Show1 s, Show2 p) => Show (WithState s p C(x y)) where-  showsPrec d (WithState s p s')-    = showParen (d > appPrec) $ showString "WithState "-                              . showsPrec1 (appPrec+1) s-                              . showString " "-                              . showsPrec2 (appPrec+1) p-                              . showString " "-                              . showsPrec1 (appPrec+1) s'--instance (Show1 s, Show2 p) => Show2 (WithState s p) where-  showDict2 = ShowDictClass--data WithStartState s p C(x) = WithStartState {-                                 wssStartState :: s C(x)-                               , wssPatch      :: p C(x)-                               }-    deriving Eq--instance (Show1 s, Show1 p) => Show (WithStartState s p C(x)) where-   showsPrec d (WithStartState s p) = showParen (d > appPrec) $ showString "WithStartState " .-                                      showsPrec1 (appPrec + 1) s . showString " " .-                                      showsPrec1 (appPrec + 1) p--instance (Show1 s, Show1 p) => Show1 (WithStartState s p) where-   showDict1 = ShowDictClass---- | A combination of a patch and its final state. The state, in this module, is---   typically represented by a 'RepoModel' value. The @px@ type is typically a---   patch type applied to its pre-state, e.g. @Prim x@.-data WithEndState s px C(y) = WithEndState {-                                wesPatch    :: px C(y)-                              , wesEndState :: s C(y)-                              }-    deriving Eq--instance (Show1 s, Show1 p) => Show (WithEndState s p C(x)) where-   showsPrec d (WithEndState p s) = showParen (d > appPrec) $ showString "WithEndState " .-                                    showsPrec1 (appPrec + 1) p . showString " " .-                                    showsPrec1 (appPrec + 1) s---instance (Show1 s, Show1 p) => Show1 (WithEndState s p) where-   showDict1 = ShowDictClass---------------------------------------------------------------------------- * ArbitraryState generators---- | A type class to generate arbitrary values, threading a state through the---   arbitrary calls. So this can be used to generate a patch that comes after---   another patch. The post-state of the generated patch is hidden by the---   'Sealed'.-class ArbitraryState s p where-  arbitraryState :: s C(x) -> Gen (Sealed (WithEndState s (p C(x))))-  -- does a coarbitrary make sense?---instance ArbitraryState s p => ArbitraryState s (WithState s p) where-  arbitraryState s = do Sealed (WithEndState x s') <- arbitraryState s-                        return $ seal $ WithEndState (WithState s x s') s'---instance ArbitraryState s p => ArbitraryState s (p :> p) where-  arbitraryState s = do Sealed (WithEndState p1 s') <- arbitraryState s-                        Sealed (WithEndState p2 s'') <- arbitraryState s'-                        return $ seal $ WithEndState (p1 :> p2) s'' --instance ArbitraryState s p => ArbitraryState s (p :> p :> p) where-  arbitraryState s0 = do Sealed (WithEndState p1 s1) <- arbitraryState s0-                         Sealed (WithEndState p2 s2) <- arbitraryState s1-                         Sealed (WithEndState p3 s3) <- arbitraryState s2-                         return $ seal $ WithEndState (p1 :> p2 :> p3) s3--arbitraryFL :: ArbitraryState s p => FORALL(x) Int -> s C(x) -> Gen (Sealed (WithEndState s (FL p C(x))))-arbitraryFL 0 s = return $ seal $ WithEndState NilFL s-arbitraryFL n s = do Sealed (WithEndState x s') <- arbitraryState s-                     Sealed (WithEndState xs s'') <- arbitraryFL (n-1) s'-                     return $ seal $ WithEndState (x :>: xs) s''--instance ArbitraryState s p => ArbitraryState s (FL p) where-  arbitraryState s = sized $ \n -> do k <- choose (0, min 2 (n `div` 5))-                                      arbitraryFL k s---makeS2Gen :: ArbitraryState s p => Gen (s C(x)) -> Gen (Sealed2 p)-makeS2Gen stGen = do s <- stGen-                     Sealed (WithEndState p _) <- arbitraryState s-                     return $ seal2 p--makeSGen :: ArbitraryState s p => Gen (s C(x)) -> Gen (Sealed (p C(x)))-makeSGen stGen = do s <- stGen-                    Sealed (WithEndState p _) <- arbitraryState s-                    return $ seal p--makeWS2Gen :: ArbitraryState s p => Gen (s C(x)) -> Gen (Sealed2 (WithState s p))-makeWS2Gen stGen = do s <- stGen-                      Sealed (WithEndState wsP _) <- arbitraryState s-                      return $ seal2 wsP--makeWSGen :: ArbitraryState s p => Gen (s C(x)) -> Gen (Sealed (WithState s p C(x)))-makeWSGen stGen = do s <- stGen-                     Sealed (WithEndState wsP _) <- arbitraryState s-                     return $ seal wsP--instance (Show2 p, Show1 s) => Show1 ((WithState s p) C(a)) where-  showDict1 = ShowDictClass-
+ src/Darcs/Test/TestOnly.hs view
@@ -0,0 +1,7 @@+{-# LANGUAGE MultiParamTypeClasses #-}+module Darcs.Test.TestOnly ( TestOnly ) where++-- |This nullary type class flags code that should only be used for+-- the tests. No instance of it should be defined in either the+-- darcs library or the main darcs executable.+class TestOnly
− src/Darcs/Test/Util/QuickCheck.hs 
@@ -1,58 +0,0 @@--module Darcs.Test.Util.QuickCheck-  ( upper-  , lower-  , alpha-  , notIn-  , uniques-  , maybeOf-  , bSized-  )-  where---import Control.Applicative-import Test.QuickCheck.Gen------ | An uppercase alphabetic character.-upper :: Gen Char-upper = choose ('A','Z')---- | A lowercase alphabetic character.-lower :: Gen Char-lower = choose ('a','z')---- | An alphabetic character.-alpha :: Gen Char-alpha = oneof [upper, lower]---- | @gen `notIn` xs@ generate a @x@ that is not in @xs@.-notIn :: Eq a => Gen a -> [a] -> Gen a-gen `notIn` xs = gen `suchThat` (`notElem` xs)---- | @uniques k gen@ generates a list of @k@ unique values.-uniques :: Eq a => Int -> Gen a -> Gen [a]-uniques k gen = go k []-  where-    go 0 xs = return xs-    go n xs = do x <- gen `notIn` xs-                 go (n-1) (x:xs)---- | Try to arbitrarily pick some element of the list.-maybeOf :: [a] -> Gen (Maybe a)-maybeOf [] = return Nothing-maybeOf xs = Just <$> elements xs----- | A bounded sized combinator.-bSized :: Int       -- ^ Lower bound-        -> Double   -- ^ Increment-        -> Int      -- ^ Upper bound-        -> (Int -> Gen a) -> Gen a-bSized low inc upp mkGen = sized $ mkGen . resize'-  where-    resize' :: Int -> Int-    resize' n = let x = fromIntegral n-                 in min upp (floor(inc*x) + low)
− src/Darcs/Test/Util/TestResult.hs 
@@ -1,63 +0,0 @@--module Darcs.Test.Util.TestResult-  ( TestResult-  , succeeded-  , failed-  , rejected-  , (<&&>)-  , fromMaybe-  , isOk-  , isFailed-  )-  where---import Printer ( Doc, renderString )--import qualified Test.QuickCheck.Property as Q----data TestResult = TestSucceeded-                | TestFailed Doc-                | TestRejected      -- ^ Rejects test case---succeeded :: TestResult-succeeded = TestSucceeded--failed :: Doc             -- ^ Error message-          -> TestResult-failed = TestFailed--rejected :: TestResult-rejected = TestRejected---- | @t <&&> s@ fails <=> t or s fails---   @t <&&> s@ succeeds <=> none fails and some succeeds---   @t <&&> s@ is rejected <=> both are rejected-(<&&>) :: TestResult -> TestResult -> TestResult-t@(TestFailed _) <&&> _s               = t-_t               <&&> s@(TestFailed _) = s-TestRejected     <&&> s                = s-t                <&&> TestRejected     = t-TestSucceeded    <&&> TestSucceeded    = TestSucceeded---- | 'Nothing' is considered success whilst 'Just' is considered failure.-fromMaybe :: Maybe Doc -> TestResult-fromMaybe Nothing       = succeeded-fromMaybe (Just errMsg) = failed errMsg--isFailed :: TestResult -> Bool-isFailed (TestFailed _) = True-isFailed _other         = False---- | A test is considered OK if it does not fail.-isOk :: TestResult -> Bool-isOk = not . isFailed--  -- 'Testable' instance is defined by converting 'TestResult' to 'QuickCheck.Property.Result'-instance Q.Testable TestResult where-  property TestSucceeded         = Q.property Q.succeeded-  property (TestFailed errorMsg) = Q.property (Q.failed{Q.reason = renderString errorMsg})-  property TestRejected          = Q.property Q.rejected
− src/Darcs/TheCommands.hs 
@@ -1,104 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}-module Darcs.TheCommands ( commandControlList ) where--import Prelude ()-import Darcs.Commands.Add ( add )-import Darcs.Commands.AmendRecord ( amendrecord, amendunrecord )-import Darcs.Commands.Annotate ( annotate )-import Darcs.Commands.Apply ( apply )-import Darcs.Commands.Changes ( changes, log )-import Darcs.Commands.Check ( check, repair )-import Darcs.Commands.Convert ( convert )-import Darcs.Commands.Diff ( diffCommand )-import Darcs.Commands.Dist ( dist )-import Darcs.Commands.Get ( get, clone )-import Darcs.Commands.GZCRCs ( gzcrcs )-import Darcs.Commands.Init ( initialize )-import Darcs.Commands.Show ( showCommand, list, query )-import Darcs.Commands.MarkConflicts ( markconflicts )-import Darcs.Commands.Move ( move, mv )-import Darcs.Commands.Optimize ( optimize )-import Darcs.Commands.Pull ( pull, fetch )-import Darcs.Commands.Push ( push )-import Darcs.Commands.Put ( put )-import Darcs.Commands.Record ( record, commit )-import Darcs.Commands.Remove ( remove, rm, unadd )-import Darcs.Commands.Replace ( replace )-import Darcs.Commands.Revert ( revert )-import Darcs.Commands.Rollback ( rollback )-import Darcs.Commands.Send ( send )-import Darcs.Commands.SetPref ( setpref )-import Darcs.Commands.Tag ( tag )-import Darcs.Commands.Test ( test )-import Darcs.Commands.TrackDown ( trackdown )-import Darcs.Commands.TransferMode ( transferMode )-import Darcs.Commands.Unrecord ( unrecord, unpull, obliterate )-import Darcs.Commands.Unrevert ( unrevert )-import Darcs.Commands.WhatsNew ( whatsnew, status )-import Darcs.Commands ( CommandControl(CommandData,HiddenCommand,GroupName) )---- | The commands that darcs knows about (e.g. whatsnew, record),---   organized into thematic groups.  Note that hidden commands---   are also listed here.-commandControlList :: [CommandControl]-commandControlList = [GroupName "Changing and querying the working copy:",-                CommandData add,-                CommandData remove, HiddenCommand unadd, HiddenCommand rm,-                CommandData move, HiddenCommand mv,-                CommandData replace,-                CommandData revert,-                CommandData unrevert,-                CommandData whatsnew, HiddenCommand status,-                GroupName "Copying changes between the working copy and the repository:",-                CommandData record, HiddenCommand commit,-                CommandData unrecord,-                CommandData amendrecord,-                HiddenCommand amendunrecord,-                CommandData markconflicts,-                GroupName "Direct modification of the repository:",-                CommandData tag,-                CommandData setpref,-                GroupName "Querying the repository:",-                CommandData diffCommand,-                CommandData changes, HiddenCommand log,-                CommandData annotate,-                CommandData dist,-                CommandData test,-                CommandData trackdown,-                CommandData showCommand, HiddenCommand list, HiddenCommand query,-                HiddenCommand transferMode,-                GroupName "Copying patches between repositories with working copy update:",-                CommandData pull,-                CommandData fetch,-                CommandData obliterate, HiddenCommand unpull,-                CommandData rollback,-                CommandData push,-                CommandData send,-                CommandData apply,-                CommandData get, HiddenCommand clone,-                CommandData put,-                GroupName "Administrating repositories:",-                CommandData initialize,-                CommandData optimize,-                CommandData check,-                CommandData repair,-                CommandData convert-                ,HiddenCommand gzcrcs-               ]
+ src/Darcs/UI/ApplyPatches.hs view
@@ -0,0 +1,149 @@+module Darcs.UI.ApplyPatches+    ( PatchApplier(..)+    , PatchProxy(..)+    , StandardPatchApplier(..)+    , applyPatchesStart+    , applyPatchesFinish+    ) where++import Darcs.Prelude++import Control.Monad ( when, void )++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.UI.Commands+    ( putVerbose+    , putFinished+    , setEnvDarcsPatches+    )+import Darcs.UI.Commands.Util ( printDryRunMessageAndExit )+import Darcs.UI.Flags+    ( DarcsFlag, verbosity, reorder, allowConflicts+    , wantGuiPause, diffingOpts, setScriptsExecutable, isInteractive+    , xmlOutput, dryRun+    )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Options ( (?) )+import Darcs.UI.Commands.Util ( testTentativeAndMaybeExit )+import Darcs.Repository+    ( Repository+    , AccessType(..)+    , tentativelyMergePatches+    , finalizeRepositoryChanges+    , applyToWorking+    , setScriptsExecutablePatches+    )+import Darcs.Repository.Pristine ( readPristine )+import Darcs.Repository.Job ( RepoJob(RepoJob) )+import Darcs.Patch ( RepoPatch, description )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.FromPrim ( PrimOf )+import Darcs.Patch.Set ( PatchSet, Origin )+import Darcs.Patch.Witnesses.Ordered+    ( FL, Fork(..), mapFL, nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )++import Darcs.Util.English ( presentParticiple )+import Darcs.Util.Printer ( vcat, text )+import Darcs.Util.Tree( Tree )++data PatchProxy (p :: * -> * -> *) = PatchProxy++-- |This class is a hack to abstract over pull/apply and rebase pull/apply.+class PatchApplier pa where++    repoJob+        :: pa+        -> (forall p wR wU+               . (RepoPatch p, ApplyState p ~ Tree)+              => (PatchProxy p -> Repository 'RW p wU wR -> IO ()))+        -> RepoJob 'RW ()++    applyPatches+        :: forall p wR wU wZ+         . (RepoPatch p, ApplyState p ~ Tree)+        => pa+        -> PatchProxy p+        -> String+        -> [DarcsFlag]+        -> Repository 'RW p wU wR+        -> Fork (PatchSet p)+                (FL (PatchInfoAnd p))+                (FL (PatchInfoAnd p)) Origin wR wZ+        -> IO ()++data StandardPatchApplier = StandardPatchApplier++instance PatchApplier StandardPatchApplier where+    repoJob StandardPatchApplier f = RepoJob (f PatchProxy)+    applyPatches StandardPatchApplier PatchProxy = standardApplyPatches++standardApplyPatches :: (RepoPatch p, ApplyState p ~ Tree)+                     => String+                     -> [DarcsFlag]+                     -> Repository 'RW p wU wR+                     -> Fork (PatchSet p)+                             (FL (PatchInfoAnd p))+                             (FL (PatchInfoAnd p)) Origin wR wZ+                     -> IO ()+standardApplyPatches cmdName opts repository patches@(Fork _ _ to_be_applied) = do+    !no_patches <- return (nullFL to_be_applied)+    applyPatchesStart cmdName opts to_be_applied+    Sealed pw <- mergeAndTest cmdName opts repository patches+    applyPatchesFinish cmdName opts repository pw (not no_patches)++mergeAndTest :: (RepoPatch p, ApplyState p ~ Tree)+             => String+             -> [DarcsFlag]+             -> Repository 'RW p wU wR+             -> Fork (PatchSet p)+                     (FL (PatchInfoAnd p))+                     (FL (PatchInfoAnd p)) Origin wR wZ+             -> IO (Sealed (FL (PrimOf p) wU))+mergeAndTest cmdName opts repository patches = do+    pw <- tentativelyMergePatches repository cmdName+                         (allowConflicts opts)+                         (wantGuiPause opts)+                         (reorder ? opts) (diffingOpts opts)+                         patches+    tree <- readPristine repository+    testTentativeAndMaybeExit tree opts+        "those patches do not pass the tests." (cmdName ++ " them") Nothing+    return pw++applyPatchesStart :: (RepoPatch p, ApplyState p ~ Tree)+                  => String -> [DarcsFlag] -> FL (PatchInfoAnd p) wX wY -> IO ()+applyPatchesStart cmdName opts to_be_applied = do+    printDryRunMessageAndExit cmdName+        (verbosity ? opts)+        (O.withSummary ? opts)+        (dryRun ? opts)+        (xmlOutput ? opts)+        (isInteractive True opts)+        to_be_applied+    if nullFL to_be_applied then+        putStrLn $ "You don't want to " ++ cmdName ++ " any patches, and that's fine with me!"+    else do+        putVerbose opts $ text $ "Will " ++ cmdName ++ " the following patches:"+        putVerbose opts . vcat $ mapFL description to_be_applied+        setEnvDarcsPatches to_be_applied++applyPatchesFinish :: (RepoPatch p, ApplyState p ~ Tree)+                   => String+                   -> [DarcsFlag]+                   -> Repository 'RW p wU wR+                   -> FL (PrimOf p) wU wY+                   -> Bool+                   -> IO ()+applyPatchesFinish cmdName opts _repository pw any_applied = do+    withSignalsBlocked $ do+        _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+        void $ applyToWorking _repository (verbosity ? opts) pw+        when (setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $+            setScriptsExecutablePatches pw+    case (any_applied, reorder ? opts == O.Reorder) of+        (True,True)  -> putFinished opts $ "reordering"+        (False,True) -> putFinished opts $ presentParticiple cmdName ++ " and reordering"+        _            -> putFinished opts $ presentParticiple cmdName+
+ src/Darcs/UI/Commands.hs view
@@ -0,0 +1,362 @@+--  Copyright (C) 2002,2003,2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands+    ( CommandControl ( CommandData, HiddenCommand, GroupName )+    , DarcsCommand(..)+    , commandAlias+    , commandStub+    , withStdOpts+    , commandOptDescr+    , commandAlloptions+    , commandDefaults+    , commandCheckOptions+    , disambiguateCommands+    , CommandArgs(..)+    , getSubcommands+    , extractCommands+    , extractAllCommands+    , normalCommand+    , hiddenCommand+    , commandGroup+    , superName+    , nodefaults+    , putInfo+    , putVerbose+    , putWarning+    , putVerboseWarning+    , putFinished+    , abortRun+    , setEnvDarcsPatches+    , setEnvDarcsFiles+    , defaultRepo+    , amInHashedRepository+    , amInRepository+    , amNotInRepository+    , findRepository+    ) where++import Control.Monad ( when, unless )+import Data.List ( sort, isPrefixOf )+import Data.Maybe ( maybeToList )+import System.Console.GetOpt ( OptDescr )+import System.IO ( stderr )+import System.IO.Error ( catchIOError )+import System.Environment ( setEnv )++import Darcs.Prelude++import Darcs.Patch ( listTouchedFiles )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Info ( toXml )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )+import Darcs.Patch.Witnesses.Ordered ( FL, mapFL )++import qualified Darcs.Repository as R ( amInHashedRepository, amInRepository+                                       , amNotInRepository, findRepository )+import Darcs.Repository.Flags ( WorkRepo(..) )+import Darcs.Repository.Prefs ( getDefaultRepo )++import Darcs.UI.Options+    ( DarcsOptDescr+    , DarcsOption+    , OptMsg+    , defaultFlags+    , ocheck+    , odesc+    , optDescr+    , parseFlags+    , (?)+    , (^)+    )+import Darcs.UI.Options.All+    ( StdCmdAction, stdCmdActions, debugging, UseCache, useCache, HooksConfig, hooks+    , Verbosity(..), DryRun(..), dryRun, newRepo, verbosity, UseIndex, useIndex, yes+    )++import Darcs.UI.Flags ( DarcsFlag, workRepo, quiet, verbose )+import Darcs.UI.External ( viewDoc )+import Darcs.UI.PrintPatch ( showWithSummary )++import Darcs.Util.ByteString ( decodeLocale, packStringToUTF8 )+import Darcs.Util.Path ( AbsolutePath, anchorPath )+import Darcs.Util.Printer+    ( Doc, text, (<+>), ($$), ($+$), hsep, vcat+    , putDocLnWith, hPutDocLn, renderString+    )+import Darcs.Util.Printer.Color ( fancyPrinters, ePutDocLn )+import Darcs.Util.Progress+    ( debugMessage, beginTedious, endTedious, tediousSize, finishedOneIO )++extractCommands :: [CommandControl] -> [DarcsCommand]+extractCommands ccl = [ cmd | CommandData cmd <- ccl ]++extractHiddenCommands :: [CommandControl] -> [DarcsCommand]+extractHiddenCommands ccl = [ cmd | HiddenCommand cmd <- ccl ]++extractAllCommands :: [CommandControl] -> [DarcsCommand]+extractAllCommands ccl = concatMap flatten (extractCommands ccl ++ extractHiddenCommands ccl)+    where flatten c@(DarcsCommand {}) = [c]+          flatten c@(SuperCommand { commandSubCommands = scs }) = c : extractAllCommands scs++normalCommand :: DarcsCommand -> CommandControl+normalCommand c = CommandData c++hiddenCommand :: DarcsCommand -> CommandControl+hiddenCommand c = HiddenCommand c++commandGroup :: String -> CommandControl+commandGroup = GroupName++data CommandControl+  = CommandData DarcsCommand+  | HiddenCommand DarcsCommand+  | GroupName String++-- |A 'DarcsCommand' represents a command like add, record etc.+data DarcsCommand =+      DarcsCommand+          { commandProgramName -- programs that use libdarcs can change the name here+          , commandName :: String+          , commandHelp :: Doc+          , commandDescription :: String+          , commandExtraArgs :: Int+          , commandExtraArgHelp :: [String]+          , commandCommand :: -- First 'AbsolutePath' is the repository path,+                              -- second one is the path where darcs was executed.+                              (AbsolutePath, AbsolutePath)+                           -> [DarcsFlag] -> [String] -> IO ()+          , commandPrereq :: [DarcsFlag] -> IO (Either String ())+          , commandCompleteArgs :: (AbsolutePath, AbsolutePath)+                                -> [DarcsFlag] -> [String] -> IO [String]+          , commandArgdefaults :: [DarcsFlag] -> AbsolutePath -> [String]+                               -> IO [String]+          , commandOptions :: CommandOptions+          }+    | SuperCommand+          { commandProgramName+          , commandName :: String+          , commandHelp :: Doc+          , commandDescription :: String+          , commandPrereq :: [DarcsFlag] -> IO (Either String ())+          , commandSubCommands :: [CommandControl]+          }++data CommandOptions = CommandOptions+  { coBasicOptions :: [DarcsOptDescr DarcsFlag]+  , coAdvancedOptions :: [DarcsOptDescr DarcsFlag]+  , coDefaults :: [DarcsFlag]+  , coCheckOptions :: [DarcsFlag] -> [OptMsg]+  }++-- | Construct 'CommandOptions' from the command specific basic and advanced+-- 'DarcsOption's+withStdOpts+  :: DarcsOption (Maybe StdCmdAction -> Verbosity -> b) c+  -> DarcsOption+      (UseCache -> UseIndex -> HooksConfig -> Bool -> Bool -> [DarcsFlag]) b+  -> CommandOptions+withStdOpts bopts aopts =+  CommandOptions+    { coBasicOptions = odesc bopts'+    , coAdvancedOptions = odesc aopts'+    , coDefaults = defaultFlags opts+    , coCheckOptions = ocheck opts+    }+  where+    aopts' = verbosity ^ aopts ^ useCache ^ useIndex ^ hooks ^ debugging+    bopts' = bopts ^ stdCmdActions+    opts = bopts' ^ aopts'++-- | For the given 'DarcsCommand' check the given 'DarcsFlag's for+-- consistency+commandCheckOptions :: DarcsCommand -> [DarcsFlag] -> [OptMsg]+commandCheckOptions DarcsCommand {commandOptions=co} = coCheckOptions co+commandCheckOptions SuperCommand {} = ocheck stdCmdActions++-- | Built-in default values for all 'DarcsFlag's supported by the given+-- command+commandDefaults :: DarcsCommand -> [DarcsFlag]+commandDefaults DarcsCommand {commandOptions=co} = coDefaults co+commandDefaults SuperCommand {} = defaultFlags stdCmdActions++-- | Option descriptions split into basic and advanced options+commandAlloptions :: DarcsCommand+                  -> ([DarcsOptDescr DarcsFlag], [DarcsOptDescr DarcsFlag])+commandAlloptions DarcsCommand {commandOptions = co} =+  (coBasicOptions co, coAdvancedOptions co)+commandAlloptions SuperCommand {} = (odesc stdCmdActions, [])++-- | Option descriptions as required by 'System.Console.Getopt.getOpt',+-- i.e. resolved with the given 'AbsolutePath'.+commandOptDescr :: AbsolutePath -> DarcsCommand -> [OptDescr DarcsFlag]+commandOptDescr cwd = map (optDescr cwd) . uncurry (++) . commandAlloptions++nodefaults :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]+nodefaults _ _ = return++getSubcommands :: DarcsCommand -> [CommandControl]+getSubcommands c@(SuperCommand {}) = commandGroup "Subcommands:" : commandSubCommands c+getSubcommands _ = []++commandAlias :: String -> Maybe (DarcsCommand) -> DarcsCommand -> DarcsCommand+commandAlias alias msuper command =+  command+    { commandName = alias+    , commandDescription = "Alias for `" ++ prog ++ " " ++ cmdName ++ "'."+    , commandHelp =+        hsep+          [ "The"+          , "`" <> text prog <+> text alias <> "`"+          , "command is an alias for"+          , "`" <> text prog <+> text cmdName <> "`"+          ]+        $+$ "See description of `" <> text prog <+> text cmdName <> "` for details."+    }+  where+    prog = commandProgramName command+    cmdName = unwords . map commandName . maybe id (:) msuper $ [command]++commandStub :: String -> Doc -> String -> DarcsCommand -> DarcsCommand+commandStub n h d command@DarcsCommand {} =+  command+    { commandName = n+    , commandHelp = h+    , commandDescription = d+    , commandCommand = \_ _ _ -> viewDoc h+    }+commandStub _ _ _ SuperCommand {} =+  error "commandStub called with SuperCommand argument"++superName :: Maybe (DarcsCommand) -> String+superName Nothing  = ""+superName (Just x) = commandName x ++ " "++data CommandArgs+  = CommandOnly DarcsCommand+  | SuperCommandOnly DarcsCommand+  | SuperCommandSub DarcsCommand DarcsCommand++-- Parses a darcs command line with potentially abbreviated commands+disambiguateCommands :: [CommandControl] -> String -> [String]+                     -> Either String (CommandArgs, [String])+disambiguateCommands allcs cmd args = do+    c <- extract cmd allcs+    case (getSubcommands c, args) of+        ([], _) -> return (CommandOnly c, args)+        (_, []) -> return (SuperCommandOnly c, args)+        (subcs, a : as) -> case extract a subcs of+                               Left _ -> return (SuperCommandOnly c, args)+                               Right sc -> return (SuperCommandSub c sc, as)++extract :: String -> [CommandControl] -> Either String DarcsCommand+extract cmd cs = case potentials of+    []  -> Left $ "No such command '" ++ cmd ++ "'\n"+    [c] -> Right c+    cs' -> Left $ unlines [ "Ambiguous command..."+                          , ""+                          , "The command '" ++ cmd ++ "' could mean one of:"+                          , unwords . sort . map commandName $ cs'+                          ]+  where+    potentials = [c | c <- extractCommands cs, cmd `isPrefixOf` commandName c]+                 ++ [h | h <- extractHiddenCommands cs, cmd == commandName h]++putVerbose :: [DarcsFlag] -> Doc -> IO ()+putVerbose flags = when (verbose flags) . putDocLnWith fancyPrinters++putInfo :: [DarcsFlag] -> Doc -> IO ()+putInfo flags = unless (quiet flags) . putDocLnWith fancyPrinters++putFinished :: [DarcsFlag] -> String -> IO ()+putFinished flags what =+  unless (yes (dryRun ? flags)) $+    putInfo flags $ "Finished" <+> text what <> "."++putWarning :: [DarcsFlag] -> Doc -> IO ()+putWarning flags = unless (quiet flags) . ePutDocLn++putVerboseWarning :: [DarcsFlag] -> Doc -> IO ()+putVerboseWarning flags = when (verbose flags) . hPutDocLn stderr++abortRun :: [DarcsFlag] -> Doc -> IO ()+abortRun flags msg = if parseFlags dryRun flags == YesDryRun+                        then putInfo flags $ "NOTE:" <+> msg+                        else fail $ renderString msg++-- | Set the DARCS_PATCHES and DARCS_PATCHES_XML environment variables with+-- info about the given patches, for use in post-hooks.+setEnvDarcsPatches :: RepoPatch p => FL (PatchInfoAnd p) wX wY -> IO ()+setEnvDarcsPatches ps = do+    let k = "Defining set of chosen patches"+    let filepaths = map (anchorPath ".") (listTouchedFiles ps)+    debugMessage $ unlines ("setEnvDarcsPatches:" : filepaths)+    beginTedious k+    tediousSize k 3+    finishedOneIO k "DARCS_PATCHES"+    setEnvCautiously "DARCS_PATCHES" (renderString $ showWithSummary ps)+    finishedOneIO k "DARCS_PATCHES_XML"+    setEnvCautiously "DARCS_PATCHES_XML" . renderString $+        text "<patches>" $$+        vcat (mapFL (toXml . info) ps) $$+        text "</patches>"+    finishedOneIO k "DARCS_FILES"+    setEnvCautiously "DARCS_FILES" $ unlines filepaths+    endTedious k++-- | Set the DARCS_FILES environment variable to the files touched by the+-- given patch, one per line, for use in post-hooks.+setEnvDarcsFiles :: (PatchInspect p) => p wX wY -> IO ()+setEnvDarcsFiles ps = do+    let filepaths = map (anchorPath ".") (listTouchedFiles ps)+    setEnvCautiously "DARCS_FILES" $ unlines filepaths++-- | Set some environment variable to the given value, unless said value is+-- longer than 100K characters, in which case do nothing.+setEnvCautiously :: String -> String -> IO ()+setEnvCautiously e v+    | toobig (100 * 1024) v =+        hPutDocLn stderr $ text $+          "Warning: not setting env var " ++ e ++ " (would exceed 100K)"+    | otherwise =+        setEnv e v `catchIOError` (\_ -> setEnv e (decodeLocale (packStringToUTF8 v)))+  where+    -- note: not using (length v) because we want to be more lazy than that+    toobig :: Int -> [a] -> Bool+    toobig 0 _ = True+    toobig _ [] = False+    toobig n (_ : xs) = toobig (n - 1) xs++-- | To use for commandArgdefaults field.+defaultRepo :: [DarcsFlag] -> AbsolutePath -> [String] -> IO [String]+defaultRepo _ _ [] = maybeToList <$> getDefaultRepo+defaultRepo _ _ args = return args++amInHashedRepository :: [DarcsFlag] -> IO (Either String ())+amInHashedRepository fs = R.amInHashedRepository (workRepo fs)++amInRepository :: [DarcsFlag] -> IO (Either String ())+amInRepository fs = R.amInRepository (workRepo fs)++amNotInRepository :: [DarcsFlag] -> IO (Either String ())+amNotInRepository fs =+  R.amNotInRepository (maybe WorkRepoCurrentDir WorkRepoDir (newRepo ? fs))++findRepository :: [DarcsFlag] -> IO (Either String ())+findRepository fs = R.findRepository (workRepo fs)
+ src/Darcs/UI/Commands/Add.hs view
@@ -0,0 +1,337 @@+--  Copyright (C) 2002-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++-- |+-- Module      : Darcs.UI.Commands.Add+-- Copyright   : 2002-2004 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.UI.Commands.Add ( add ) where++import Darcs.Prelude++import Control.Exception ( catch, IOException )+import Control.Monad ( when, unless, void )+import Data.List ( (\\), nub )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( fromMaybe, isNothing, maybeToList )+import Darcs.Util.Printer ( Doc, text, vcat )+import Darcs.Util.Tree+    ( Tree+    , expand+    , explodePaths+    , findTree+    , treeHas+    , treeHasAnycase+    , treeHasDir+    )+import qualified Darcs.Util.Tree as Tree+import Darcs.Util.Path+    ( AbsolutePath+    , AnchoredPath+    , displayPath+    , filterPaths+    , parent+    , parents+    , realPath+    )+import System.Posix.Files ( isRegularFile, isDirectory, isSymbolicLink )+import System.Directory ( getPermissions, readable )++import qualified System.FilePath.Windows as WindowsFilePath++import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts, putInfo, putWarning, putVerboseWarning+    , nodefaults, amInHashedRepository)+import Darcs.UI.Commands.Util ( doesDirectoryReallyExist )+import Darcs.UI.Completion ( unknownFileArgs )+import Darcs.UI.Flags+    ( DarcsFlag, diffingOpts+    , allowCaseDifferingFilenames, allowWindowsReservedFilenames, useCache, dryRun, umask+    , pathsFromArgs )+import Darcs.UI.Options ( parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O++import Darcs.Patch ( PrimPatch, applyToTree, addfile, adddir, listTouchedFiles )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Repository.State+    ( TreeFilter(..)+    , readPristineAndPending+    , readWorking+    )+import Darcs.Repository+    ( withRepoLock+    , RepoJob(..)+    , addToPending+    , finalizeRepositoryChanges+    )+import Darcs.Repository.Prefs ( isBoring )+import Darcs.Util.File ( getFileStatus )+import Darcs.Patch.Witnesses.Ordered ( FL(..), concatGapsFL, nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )++addDescription :: String+addDescription = "Add new files to version control."+++addHelp :: Doc+addHelp = text $+    "Generally the working tree contains both files that should be version\n" +++    "controlled (such as source code) and files that Darcs should ignore\n" +++    "(such as executables compiled from the source code).  The `darcs add`\n" +++    "command is used to tell Darcs which files to version control.\n" +++    "\n" +++    "When an existing project is first imported into a Darcs repository, it\n" +++    "is common to run `darcs add -r *` or `darcs record -l` to add all\n" +++    "initial source files into darcs.\n"+++    "\n" +++    "Adding symbolic links (symlinks) is not supported.\n\n"+++addHelp' :: Doc+addHelp' = text $+    "Darcs will ignore all files and folders that look \"boring\".  The\n" +++    "`--boring` option overrides this behaviour.\n" +++    "\n" +++    "Darcs will not add a file if another file in the same folder has the\n" +++    "same name, except for case.  The `--case-ok` option overrides this\n" +++    "behaviour.  Windows and OS X usually use filesystems that do not allow\n" +++    "files a folder to have the same name except for case (for example,\n" +++    "`ReadMe` and `README`).  If `--case-ok` is used, the repository might be\n" +++    "unusable on those systems!\n\n"++add :: DarcsCommand+add = DarcsCommand+    { commandProgramName          = "darcs"+    , commandName                 = "add"+    , commandHelp                 = addHelp <> addHelp'+    , commandDescription          = addDescription+    , commandExtraArgs            = -1+    , commandExtraArgHelp         = [ "<FILE or DIRECTORY> ..." ]+    , commandCommand              = addCmd+    , commandPrereq               = amInHashedRepository+    , commandCompleteArgs         = unknownFileArgs+    , commandArgdefaults          = nodefaults+    , commandOptions              = addOpts+    }+  where+    addBasicOpts+      = O.includeBoring+      ^ O.allowProblematicFilenames+      ^ O.recursive+      ^ O.repoDir+      ^ O.dryRun+    addAdvancedOpts = O.umask+    addOpts = withStdOpts addBasicOpts addAdvancedOpts+++addCmd :: (AbsolutePath, AbsolutePath)+       -> [DarcsFlag]+       -> [String]+       -> IO ()+addCmd fps opts args+  | null args = putStrLn $ "Nothing specified, nothing added. " +++      "Maybe you wanted to say `darcs add --recursive .'?"+  | otherwise = do+      paths <- pathsFromArgs fps args+      case paths of+        [] -> fail "No valid repository paths were given"+        _ -> addFiles opts paths++addFiles :: [DarcsFlag] -> [AnchoredPath] -> IO ()+addFiles opts paths =+  withRepoLock (useCache ? opts) (umask ? opts) $+  RepoJob $ \repository -> do+    -- TODO do not expand here, and use findM/findIO or such later+    -- (needs adding to hashed-storage first though)+    cur <- expand =<< readPristineAndPending repository+    let parent_paths = notInTreeParents cur paths+    -- (1) note, readWorking already filters out darcsdir paths+    -- (2) note, filterPaths matches if path is parent /or/ child +    working <- readWorking (TreeFilter (Tree.filter (filterPaths paths)))+    -- we first get the boring paths, too, so we can report dropping them+    let all_paths = nubSort $ parent_paths +++                      (if parseFlags O.recursive opts+                        then explodePaths working+                        else id) paths+        all_orig_paths = map displayPath all_paths+    boring <- isBoring+    let nboring s = if O.includeBoring ? opts then id else filter (not . boring . s)+    mapM_ (putWarning opts . text . ((msgSkipping msgs ++ " boring file ")++)) $+        all_orig_paths \\ nboring id all_orig_paths+    Sealed ps <- fmap unFreeLeft $ addp msgs opts cur $ nboring realPath all_paths+    when (nullFL ps && not (null paths)) $+        fail "No files were added"+    addToPending repository (diffingOpts opts) ps+    void $ finalizeRepositoryChanges repository (O.dryRun ? opts)+    unless gotDryRun $ do+      putInfo opts $ vcat $+        map text $ ["Finished adding:"] ++ map displayPath (listTouchedFiles ps)+  where+    gotDryRun = dryRun ? opts == O.YesDryRun+    msgs | gotDryRun = dryRunMessages+         | otherwise = normalMessages++    notInTreeParents :: Tree IO -> [AnchoredPath] -> [AnchoredPath]+    notInTreeParents cur = filter (isNothing . findTree cur) . concatMap parents++addp :: forall prim . (PrimPatch prim, ApplyState prim ~ Tree)+     => AddMessages+     -> [DarcsFlag]+     -> Tree IO+     -> [AnchoredPath]+     -> IO (FreeLeft (FL prim))+addp msgs opts cur0 files = do+    (ps, dups) <-+        foldr+             (\f rest cur accPS accDups -> do+                    addResult <- addp' cur f+                    case addResult of+                        -- If a single file fails to add, stop further processing.+                        (_, Nothing, Nothing) -> return ([], [])+                        (cur', mp, mdup) -> rest cur' (maybeToList mp ++ accPS) (maybeToList mdup ++ accDups))+            (\_ ps dups -> return (reverse ps, dups))+            files+            cur0 [] []+    let uniq_dups = nub dups+        caseMsg =+            if gotAllowCaseOnly then ":"+                else ";\nnote that to ensure portability we don't allow\n" +++                     "files that differ only in case. Use --case-ok to override this:"+    unless (null dups) $ do+       dupMsg <-+         case uniq_dups of+         [f] -> do+           isDir <- doesDirectoryReallyExist (realPath f)+           if isDir+             then return $+               "The following directory " +++               msgIs msgs ++ " already in the repository"+             else return $+               "The following file " +++               msgIs msgs ++ " already in the repository"+         fs   -> do+           areDirs <- mapM (doesDirectoryReallyExist . realPath) fs+           if and areDirs+             then return $+               "The following directories " +++               msgAre msgs ++ " already in the repository"+             else+               (if or areDirs+                  then return $+                    "The following files and directories " +++                    msgAre msgs ++ " already in the repository"+                  else return $+                    "The following files " +++                    msgAre msgs ++ " already in the repository")+       putWarning opts . text $ "WARNING: Some files were not added because they are already in the repository."+       putVerboseWarning opts . text $ dupMsg ++ caseMsg+       mapM_ (putVerboseWarning opts . text . displayPath) uniq_dups+    return $ concatGapsFL ps+  where+    addp' :: Tree IO+          -> AnchoredPath+          -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)+    addp' cur f = do+      already_has <- (if gotAllowCaseOnly then treeHas else treeHasAnycase) cur f+      mstatus <- getFileStatus (realPath f)+      case (already_has, is_badfilename, mstatus) of+        (True, _, _) -> return (cur, Nothing, Just f)+        (_, True, _) -> do+            putWarning opts . text $+              "The filename " ++ displayPath f ++ " is invalid on Windows.\n" +++              "Use --reserved-ok to allow it."+            return add_failure+        (_, _, Just s)+            | isDirectory s    -> trypatch $ freeGap (adddir f :>: NilFL)+            | isRegularFile s  -> trypatch $ freeGap (addfile f :>: NilFL)+            | isSymbolicLink s -> do+                putWarning opts . text $+                    "Sorry, file " ++ displayPath f +++                    " is a symbolic link, which is unsupported by darcs."+                return add_failure+        _ -> do+            putWarning opts . text $ "File "++ displayPath f ++" does not exist!"+            return add_failure+        where+          is_badfilename = not (gotAllowWindowsReserved || WindowsFilePath.isValid (realPath f))+          add_failure = (cur, Nothing, Nothing)+          trypatch :: FreeLeft (FL prim)+                   -> IO (Tree IO, Maybe (FreeLeft (FL prim)), Maybe AnchoredPath)+          trypatch p = do+              perms <- getPermissions (realPath f)+              if not $ readable perms+                then do+                    putWarning opts . text $+                        msgSkipping msgs ++ " '" ++ displayPath f ++ "': permission denied "+                    return (cur, Nothing, Nothing)+                else trypatch' p+          trypatch' p = do+              Sealed p' <- return $ unFreeLeft p+              ok <- treeHasDir cur parentdir+              if ok+                then do+                    tree <- applyToTree p' cur+                    putInfo opts . text $+                        msgAdding msgs ++ " '" ++ displayPath f ++ "'"+                    return (tree, Just p, Nothing)+                else do+                    putWarning opts . text $+                        msgSkipping msgs ++ " '" ++ displayPath f +++                            "' ... couldn't add parent directory '" +++                            displayPath parentdir ++ "' to repository"+                    return (cur, Nothing, Nothing)+              `catch` \(e :: IOException) -> do+                  putWarning opts . text $+                      msgSkipping msgs ++ " '" ++ displayPath f ++ "' ... " ++ show e+                  return (cur, Nothing, Nothing)+          parentdir = fromMaybe (error "cannot take parent of root path") $ parent f+              +    gotAllowCaseOnly = allowCaseDifferingFilenames ? opts+    gotAllowWindowsReserved = allowWindowsReservedFilenames ? opts+++data AddMessages = AddMessages+    {+      msgSkipping  :: String+    , msgAdding    :: String+    , msgIs        :: String+    , msgAre       :: String+    }+++normalMessages :: AddMessages+normalMessages = AddMessages+    {+      msgSkipping  = "Skipping"+    , msgAdding    = "Adding"+    , msgIs        = "is"+    , msgAre       = "are"+    }+++dryRunMessages :: AddMessages+dryRunMessages = AddMessages+    {+      msgSkipping  = "Would skip"+    , msgAdding    = "Would add"+    , msgIs        = "would be"+    , msgAre       = "would be"+    }
+ src/Darcs/UI/Commands/Amend.hs view
@@ -0,0 +1,379 @@+--  Copyright (C) 2004,2007 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++-- |+-- Copyright   : 2004, 2007 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.Amend+    (+      amend+    , amendrecord+    ) where++import Darcs.Prelude++import Control.Monad ( unless )+import Data.Maybe ( isNothing, isJust )++import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts+    , commandAlias+    , nodefaults+    , setEnvDarcsFiles+    , setEnvDarcsPatches+    , amInHashedRepository+    )+import Darcs.UI.Commands.Util+    ( announceFiles+    , historyEditHelp+    , testTentativeAndMaybeExit+    )+import Darcs.UI.Completion ( modifiedFileArgs, knownFileArgs )+import Darcs.UI.Flags ( diffingOpts, pathSetFromArgs )+import Darcs.UI.Options ( Config, (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.PatchHeader+    ( AskAboutDeps(..)+    , HijackOptions(..)+    , patchHeaderConfig+    , runHijackT+    , updatePatchHeader+    )++import Darcs.Repository.Flags ( UpdatePending(..) )+import Darcs.Patch ( RepoPatch, description, PrimOf+                   , effect, invert, invertFL, canonizeFL+                   )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Depends ( contextPatches, patchSetUnion, findCommonWithThem )+import Darcs.Patch.Info ( isTag )+import Darcs.Patch.Named ( fmapFL_Named )+import Darcs.Patch.PatchInfoAnd ( hopefully )+import Darcs.Patch.Set ( Origin, PatchSet )+import Darcs.Patch.Split ( primSplitter )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, patchDesc )+import Darcs.Patch.Rebase.Fixup ( RebaseFixup(..) )+import Darcs.Patch.Rebase.Name ( RebaseName(..) )+import Darcs.Util.Path ( AnchoredPath )+import Darcs.Repository+    ( Repository+    , AccessType(..)+    , withRepoLock+    , RepoJob(..)+    , identifyRepositoryFor+    , ReadingOrWriting(Reading)+    , tentativelyRemovePatches+    , tentativelyAddPatch+    , withManualRebaseUpdate+    , finalizeRepositoryChanges+    , readPendingAndWorking+    , readPristine+    , readPatches+    , tentativelyRemoveFromPW+    )+import Darcs.Repository.Pending ( readTentativePending, writeTentativePending )+import Darcs.Repository.Prefs ( getDefaultRepo )+import Darcs.UI.SelectChanges+    ( WhichChanges(..)+    , selectionConfigPrim+    , runInvertibleSelection+    , withSelectedPatchFromList+    )+import qualified Darcs.UI.SelectChanges as S+    ( PatchSelectionOptions(..)+    )+import Darcs.Util.Exception ( clarifyErrors )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), RL, (:>)(..), (+>+)+    , nullFL, reverseRL, reverseFL, mapFL_FL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )++import Darcs.Util.English ( anyOfClause, itemizeVertical )+import Darcs.Util.Printer ( Doc, formatWords, putDocLn, text, (<+>), ($$), ($+$) )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.Tree( Tree )+++amendDescription :: String+amendDescription = "Improve a patch before it leaves your repository."+++amendHelp :: Doc+amendHelp =+  formatWords+  [ "Amend updates a \"draft\" patch with additions or improvements,"+  , "resulting in a single \"finished\" patch."+  ]+  $+$ formatWords+  [ "By default `amend` proposes you to record additional changes."+  , "If instead you want to remove changes, use the flag `--unrecord`."+  ]+  $+$ formatWords+  [ "When recording a draft patch, it is a good idea to start the name with"+  , "`DRAFT:`. When done, remove it with `darcs amend --edit-long-comment`."+  , "Alternatively, to change the patch name without starting an editor, "+  , "use the `--name`/`-m` flag:"+  ]+  $+$ text+    "    darcs amend --match 'name \"DRAFT: foo\"' --name 'foo2'"+  $+$ formatWords+  [ "Like `darcs record`, if you call amend with files as arguments,"+  , "you will only be asked about changes to those files.  So to amend a"+  , "patch to foo.c with improvements in bar.c, you would run:"+  ]+  $+$ text+    "    darcs amend --match 'touch foo.c' bar.c"+  $+$ historyEditHelp++amend :: DarcsCommand+amend = DarcsCommand+    {+      commandProgramName          = "darcs"+    , commandName                 = "amend"+    , commandHelp                 = amendHelp+    , commandDescription          = amendDescription+    , commandExtraArgs            = -1+    , commandExtraArgHelp         = ["[FILE or DIRECTORY]..."]+    , commandCommand              = amendCmd+    , commandPrereq               = amInHashedRepository+    , commandCompleteArgs         = fileArgs+    , commandArgdefaults          = nodefaults+    , commandOptions              = allOpts+    }+  where+    fileArgs fps flags args =+      if (O.amendUnrecord ? flags)+        then knownFileArgs fps flags args+        else modifiedFileArgs fps flags args+    basicOpts+      = O.amendUnrecord+      ^ O.notInRemote+      ^ O.matchOneNontag+      ^ O.testChanges+      ^ O.interactive --True+      ^ O.author+      ^ O.selectAuthor+      ^ O.patchname+      ^ O.askDeps+      ^ O.askLongComment+      ^ O.keepDate+      ^ O.lookforadds+      ^ O.lookforreplaces+      ^ O.lookformoves+      ^ O.repoDir+      ^ O.diffAlgorithm+    advancedOpts+      = O.umask+      ^ O.setScriptsExecutable+    allOpts = withStdOpts basicOpts advancedOpts+    amendCmd fps flags args = pathSetFromArgs fps args >>= doAmend flags++amendrecord :: DarcsCommand+amendrecord = commandAlias "amend-record" Nothing amend++doAmend :: Config -> Maybe [AnchoredPath] -> IO ()+doAmend cfg files =+  withRepoLock (O.useCache ? cfg) (O.umask ? cfg) $+      RepoJob $ \(repository :: Repository 'RW p wU wR) -> do+    patchSet <- readPatches repository+    _ :> candidates <- filterNotInRemote cfg repository patchSet+    withSelectedPatchFromList "amend" candidates (patchSelOpts cfg) $+     \(kept :> oldp) -> do+      announceFiles (O.verbosity ? cfg) files "Amending changes in"+      pending :> working <-+        readPendingAndWorking (diffingOpts cfg) repository files+      -- auxiliary function needed because the witness types differ for the+      -- isTag case+      let go :: FL (PrimOf p) wR wU1 -> IO ()+          go NilFL | not (hasEditMetadata cfg) = putInfo cfg "No changes!"+          go ch = do+            let selection_config =+                   selectionConfigPrim First "record"+                       (patchSelOpts cfg)+                       (Just (primSplitter (O.diffAlgorithm ? cfg)))+                       files+            (chosenPatches :> _) <- runInvertibleSelection ch selection_config+            addChangesToPatch cfg repository kept oldp chosenPatches pending working+      if not (isTag (info oldp))+        -- amending a normal patch+        then+          if O.amendUnrecord ? cfg+            then do+              let selection_config =+                    selectionConfigPrim Last "unrecord" (patchSelOpts cfg)+                      (Just (primSplitter (O.diffAlgorithm ? cfg)))+                      files+              (_ :> chosenPrims) <-+                runInvertibleSelection (effect oldp) selection_config+              let invPrims = reverseRL (invertFL chosenPrims)+              addChangesToPatch cfg repository kept oldp invPrims pending working+            else+              go (canonizeFL (O.diffAlgorithm ? cfg) (pending +>+ working))+        -- amending a tag+        else+          if hasEditMetadata cfg && isNothing files+            -- the user is not trying to add new changes to the tag so there is+            -- no reason to warn.+            then go NilFL+            -- the user is trying to add new changes to a tag.+            else do+              if hasEditMetadata cfg+                -- the user already knows that it is possible to edit tag metadata,+                -- note that s/he is providing editing options!+                then ePutDocLn "You cannot add new changes to a tag."+                -- the user may not be aware that s/he can edit tag metadata.+                else+                  ePutDocLn+                    "You cannot add new changes to a tag, but you are allowed to edit tag's metadata (see darcs help amend)."+              go NilFL+++addChangesToPatch+  :: (RepoPatch p, ApplyState p ~ Tree)+  => Config+  -> Repository 'RW p wU wR+  -> RL (PatchInfoAnd p) wC wX  -- ^ candidates for --ask-deps+  -> PatchInfoAnd p wX wR       -- ^ original patch+  -> FL (PrimOf p) wR wY        -- ^ changes to add+  -> FL (PrimOf p) wR wP        -- ^ pending+  -> FL (PrimOf p) wP wU        -- ^ working+  -> IO ()+addChangesToPatch cfg _repository context oldp chs pending working =+  if nullFL chs && not (hasEditMetadata cfg)+    then putInfo cfg "You don't want to record anything!"+    else do+      -- remember the old pending for the amend --unrecord case, see below+      Sealed old_pending <- readTentativePending _repository+      -- If a rebase is in progress, we want to manually update the rebase+      -- state, using the amendments directly as rebase fixups. This is+      -- necessary because otherwise we will first remove the original patch+      -- then add the amended patch,+      -- and this can lead to more conflicts than using the amendment as a fixup+      -- directly. For example, if a rename operation is amended in, the rename+      -- can be propagated to any edits to the file in the rebase state, whereas+      -- a delete then add would just cause a conflict.+      -- +      -- We can also signal that any explicit dependencies of the old patch+      -- should be rewritten for the new patch using a 'NameFixup'.+      (_repository, (mlogf, newp)) <-+        withManualRebaseUpdate _repository $ \_repository -> do+          -- Note we pass NoUpdatePending here and below when re-adding the+          -- amended patch, and instead fix pending explicitly further below.+          _repository <-+            tentativelyRemovePatches+              _repository+              NoUpdatePending+              (oldp :>: NilFL)+          (mlogf, newp) <-+            runHijackT AlwaysRequestHijackPermission $+            updatePatchHeader+              "amend"+              (if O.askDeps ? cfg+                 then AskAboutDeps context+                 else NoAskAboutDeps)+              (patchSelOpts cfg)+              (patchHeaderConfig cfg)+              (fmapFL_Named effect (hopefully oldp))+              chs+          let fixups =+                mapFL_FL PrimFixup (invert chs) +>++                NameFixup (Rename (info newp) (info oldp)) :>:+                NilFL+          setEnvDarcsFiles newp+          _repository <-+            tentativelyAddPatch _repository NoUpdatePending newp+          return (_repository, fixups, (mlogf, newp))+      let failmsg = maybe "" (\lf -> "\nLogfile left in " ++ lf ++ ".") mlogf+      tp <- readPristine _repository+      testTentativeAndMaybeExit tp cfg+        ("you have a bad patch: '" ++ patchDesc newp ++ "'")+        "amend it"+        (Just failmsg)+      if O.amendUnrecord ? cfg then+        writeTentativePending _repository $ invert chs +>+ old_pending+      else+        tentativelyRemoveFromPW _repository chs pending working+      _repository <-+        finalizeRepositoryChanges _repository (O.dryRun ? cfg)+          `clarifyErrors` failmsg+      case O.verbosity ? cfg of+        O.NormalVerbosity -> putDocLn "Finished amending patch."+        O.Verbose -> putDocLn $ "Finished amending patch:" $$ description newp+        _ -> return ()+      setEnvDarcsPatches (newp :>: NilFL)++filterNotInRemote :: RepoPatch p+                  => Config+                  -> Repository 'RW p wU wR+                  -> PatchSet p Origin wR+                  -> IO ((PatchSet p :> RL (PatchInfoAnd p)) Origin wR)+filterNotInRemote cfg repository patchSet = do+    nirs <- mapM getNotInRemotePath (O.notInRemote ? cfg)+    if null nirs+      then+        -- We call contextPatches here because+        -- (a) selecting patches beyond the latest clean tag is impossible anyway+        -- (b) makes it easier to reconstruct a PatchSet w/o the selected patch+        -- (c) avoids listing the complete list of patches in the repo when user+        --     rejects the last selectable patch+        return (contextPatches patchSet)+      else do+        putInfo cfg $+          "Determining patches not in" <+> anyOfClause nirs $$ itemizeVertical 2 nirs+        Sealed thems <- patchSetUnion `fmap` mapM readNir nirs+        in_remote :> only_ours <- return $ findCommonWithThem patchSet thems+        return (in_remote :> reverseFL only_ours)+  where+    readNir loc = do+      repo <- identifyRepositoryFor Reading repository (O.useCache ? cfg) loc+      rps <- readPatches repo+      return (Sealed rps)+    getNotInRemotePath (O.NotInRemotePath p) = return p+    getNotInRemotePath O.NotInDefaultRepo = do+        defaultRepo <- getDefaultRepo+        let err = fail $ "No default push/pull repo configured, please pass a "+                         ++ "repo name to --" ++ O.notInRemoteFlagName+        maybe err return defaultRepo++hasEditMetadata :: Config -> Bool+hasEditMetadata cfg = isJust (O.author ? cfg)+                    || O.selectAuthor ? cfg+                    || isJust (O.patchname ? cfg)+                    || O.askLongComment ? cfg == Just O.YesEditLongComment+                    || O.askLongComment ? cfg == Just O.PromptLongComment+                    || O.askDeps ? cfg++patchSelOpts :: Config -> S.PatchSelectionOptions+patchSelOpts cfg = S.PatchSelectionOptions+    { S.verbosity = O.verbosity ? cfg+    , S.matchFlags = O.matchOneNontag ? cfg+    , S.interactive = isInteractive cfg+    , S.selectDeps = O.PromptDeps -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default+    }++isInteractive :: Config -> Bool+isInteractive cfg = maybe True id (O.interactive ? cfg)++putInfo :: Config -> Doc -> IO ()+putInfo cfg what = unless (O.verbosity ? cfg == O.Quiet) $ putDocLn what
+ src/Darcs/UI/Commands/Annotate.hs view
@@ -0,0 +1,144 @@+--  Copyright (C) 2003 David Roundy, 2010-2011 Petr Rockai+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.+{-# LANGUAGE OverloadedStrings #-}++module Darcs.UI.Commands.Annotate ( annotate ) where++import Darcs.Prelude++import Control.Monad ( when )++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.UI.External ( viewDocWith )+import Darcs.UI.Flags ( DarcsFlag, useCache, patchIndexYes, pathsFromArgs )+import Darcs.UI.Options ( parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O++import Darcs.Repository.State ( readPristine )+import Darcs.Repository+    ( withRepository+    , withRepoLockCanFail+    , RepoJob(..)+    , readPatches+    )+import Darcs.Repository.PatchIndex ( attemptCreatePatchIndex )+import Darcs.Patch.Set ( patchSet2RL )+import qualified Data.ByteString.Char8 as BC ( pack, concat, intercalate )+import Data.ByteString.Lazy ( toChunks )+import Darcs.Patch.ApplyMonad( withFileNames )+import Darcs.Patch.Match ( patchSetMatch, rollbackToPatchSetMatch  )+import Darcs.Repository.Match ( getOnePatchset )+import Darcs.Repository.PatchIndex ( getRelevantSubsequence, canUsePatchIndex )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )+import qualified Darcs.Patch.Annotate as A++import Darcs.Util.Tree( TreeItem(..) )+import qualified Darcs.Util.Tree as T ( readBlob, list, expand )+import Darcs.Util.Tree.Monad( findM, virtualTreeIO )+import Darcs.Util.Path( AbsolutePath, AnchoredPath, displayPath, catPaths )+import Darcs.Util.Printer ( Doc, simplePrinters, renderString, text )+import Darcs.Util.Exception ( die )++annotateDescription :: String+annotateDescription = "Annotate lines of a file with the last patch that modified it."++annotateHelp :: Doc+annotateHelp = text $ unlines+ [ "When `darcs annotate` is called on a file, it will find the patch that"+ , "last modified each line in that file. This also works on directories."+ , ""+ , "The `--machine-readable` option can be used to generate output for"+ , "machine postprocessing."+ ]++annotate :: DarcsCommand+annotate = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "annotate"+    , commandHelp = annotateHelp+    , commandDescription = annotateDescription+    , commandExtraArgs = 1+    , commandExtraArgHelp = ["[FILE or DIRECTORY]"]+    , commandCommand = annotateCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = knownFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = annotateOpts+    }+  where+    annotateBasicOpts = O.machineReadable ^ O.matchUpToOne ^ O.repoDir+    annotateAdvancedOpts = O.patchIndexYes+    annotateOpts = annotateBasicOpts `withStdOpts` annotateAdvancedOpts++annotateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+annotateCmd fps opts args = do+  paths <- pathsFromArgs fps args+  case paths of+    [path] -> do+      when (patchIndexYes ? opts == O.YesPatchIndex)+        $ withRepoLockCanFail (useCache ? opts)+        $ RepoJob (\repo -> readPatches repo >>= attemptCreatePatchIndex repo)+      annotateCmd' opts path+    _ -> die "Error: annotate requires a single filepath argument"++annotateCmd' :: [DarcsFlag] -> AnchoredPath -> IO ()+annotateCmd' opts fixed_path = withRepository (useCache ? opts) $ RepoJob $ \repository -> do+  let matchFlags = parseFlags O.matchUpToOne opts+  r <- readPatches repository+  recorded <- readPristine repository+  (patches, initial, path) <-+    case patchSetMatch matchFlags of+      Just psm -> do+        Sealed x <- getOnePatchset repository psm+        case withFileNames Nothing [fixed_path] (rollbackToPatchSetMatch psm r) of+          (_, [path'], _) -> do+            initial <- snd `fmap` virtualTreeIO (rollbackToPatchSetMatch psm r) recorded+            return (seal $ patchSet2RL x, initial, path')+          _ -> error "impossible"+      Nothing ->+        return (seal $ patchSet2RL r, recorded, fixed_path)++  found <- findM initial path+  -- TODO need to decide about the --machine flag+  let (fmt, view) = if parseFlags O.machineReadable opts+                      then (A.machineFormat, putStrLn . renderString)+                      else (A.format, viewDocWith simplePrinters)+  usePatchIndex <- (O.yes (O.patchIndexYes ? opts) &&) <$> canUsePatchIndex repository+  case found of+    Nothing -> die $ "Error: path not found in repository: " ++ displayPath fixed_path+    Just (SubTree s) -> do+      -- TODO the semantics and implementation of annotating of directories need to be revised+      s' <- T.expand s+      let subs = map (catPaths path . fst) $ T.list s'+          showPath (n, File _) = BC.pack $ displayPath $ path `catPaths` n+          showPath (n, _) = BC.concat [BC.pack $ displayPath $ path `catPaths` n, "/"]+      (Sealed ans_patches) <- do+         if not usePatchIndex+            then return patches+            else getRelevantSubsequence patches repository r subs+      view . text $+        fmt (BC.intercalate "\n" $ map showPath $ T.list s') $+        A.annotateDirectory ans_patches path subs+    Just (File b) -> do (Sealed ans_patches) <- do+                           if not usePatchIndex+                              then return patches+                              else getRelevantSubsequence patches repository r [path]+                        con <- BC.concat `fmap` toChunks `fmap` T.readBlob b+                        view $ text . fmt con $+                          A.annotateFile ans_patches path con+    Just (Stub _ _) -> error "impossible case"
+ src/Darcs/UI/Commands/Apply.hs view
@@ -0,0 +1,304 @@+--  Copyright (C) 2003-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Apply+    ( apply, applyCmd+    , getPatchBundle -- used by darcsden+    ) where++import Darcs.Prelude++import System.Exit ( exitSuccess )+import Control.Monad ( unless, when )+import Data.Maybe ( catMaybes )++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefullyM, info )+import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts+    , putInfo+    , amInHashedRepository+    )+import Darcs.UI.Completion ( fileArgs )+import Darcs.UI.Flags+    ( DarcsFlag+    , changesReverse, verbosity, useCache+    , reorder, umask+    , fixUrl+    )+import Darcs.UI.Options ( (^), parseFlags, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path ( toFilePath, AbsolutePath )+import Darcs.Repository+    ( Repository+    , AccessType(..)+    , SealedPatchSet+    , withRepoLock+    , readPatches+    , filterOutConflicts+    )+import Darcs.Patch.Set ( PatchSet, Origin )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Info ( PatchInfo, displayPatchInfo )+import Darcs.Patch.Witnesses.Ordered+    ( Fork(..), (:>)(..)+    , mapFL, nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Util.ByteString ( linesPS, unlinesPS, gzReadStdin )+import qualified Data.ByteString as B (ByteString, null, init)+import qualified Data.ByteString.Char8 as BC (last)++import Darcs.Util.HTTP ( Cachable(Uncachable) )+import Darcs.Util.File ( gzFetchFilePS )+import Darcs.UI.External+    ( verifyPS+    )+import Darcs.UI.Email ( readEmail )+import Darcs.Patch.Depends ( findCommon )+import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..), PatchProxy )+import Darcs.UI.SelectChanges+    ( WhichChanges(..)+    , runSelection+    , selectionConfig+    )+import qualified Darcs.UI.SelectChanges as S+import Darcs.Patch.Bundle ( interpretBundle, parseBundle )+import Darcs.Util.Printer+    ( Doc, vcat, text+    , renderString+    , ($$)+    , vsep+    , formatWords+    )+import Darcs.Util.Tree( Tree )++applyDescription :: String+applyDescription = "Apply a patch bundle created by `darcs send'."++applyHelp :: Doc+applyHelp = vsep $ map formatWords+  [ [ "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` on the remote end of an SSH connection."+    ]+  , [ "If no file is supplied, the bundle is read from standard input."+    ]+  , [ "If given an email instead of a patch bundle, Darcs will look for the"+    , "bundle as a MIME attachment to that email.  Currently this will fail"+    , "if the MIME boundary is rewritten, such as in Courier and Mail.app."+    ]+  , [ "If gpg(1) is installed, you can use `--verify pubring.gpg` to reject"+    , "bundles that aren't signed by a key in `pubring.gpg`."+    ]+  , [ "If `--test` is supplied and a test is defined (see `darcs setpref`), the"+    , "bundle will be rejected if the test fails after applying it."+    ]+  , [ "Unlike most Darcs commands, `darcs apply` defaults to `--all`.  Use the"+    , "`--interactive` option to pick which patches to apply from a bundle."+    ]+  , [ "A patch bundle may introduce unresolved conflicts with existing"+    , "patches or with the working tree.  By default, Darcs will refuse to"+    , "apply conflicting patches (`--no-allow-conflicts`)."+    ]+  , [ "The `--mark-conflicts` option instructs Darcs to allow conflicts and"+    , "try to add conflict markup in your working tree. Note that this may"+    , "(partly) fail, because some conflicts cannot be marked, such as e.g."+    , "conflicts between two adds of the same file. In this case Darcs will"+    , "warn you and display the conflicting changes instead. When Darcs"+    , "detects conflicts with unrecorded changes, it will give you an extra"+    , "warning and prompts you to confirm that you want to continue. This is"+    , "because your original unrecorded changes cannot be automatically"+    , "restored by Darcs."+    ]+  , [ "Note that conflict markup is something Darcs adds to your working tree"+    , "files. Nevertheless, you can always re-construct it using"+    , "`darcs mark-conflicts`."+    ]+  , [ "The `--external-merge` option lets you resolve conflicts"+    , "using an external merge tool.  In the option, `%a` is replaced with"+    , "the common ancestor (merge base), `%1` with the first version, `%2`"+    , "with the second version, and `%o` with the path where your resolved"+    , "content should go.  For example, to use the xxdiff visual merge tool"+    , "you'd specify: `--external-merge='xxdiff -m -O -M %o %1 %a %2'`"+    ]+  , [ "The `--allow-conflicts` option allows conflicts but does not add"+    , "conflict markup. This is useful when you want to treat a repository as"+    , "just a bunch of patches, such as using `darcs pull --union` to download"+    , "all of your co-workers' patches before going offline. Again, conflict"+    , "markup can be added at any time later on using `darcs mark-conflicts`."+    ]+  , [ "For more information on conflicts in Darcs and how to resolve them,"+    , "see the help on `darcs mark-conflicts`."+    ]+  ]++stdindefault :: a -> [String] -> IO [String]+stdindefault _ [] = return ["-"]+stdindefault _ x = return x++apply :: DarcsCommand+apply = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "apply"+    , commandHelp = applyHelp+    , commandDescription = applyDescription+    , commandExtraArgs = 1+    , commandExtraArgHelp = ["<PATCHFILE>"]+    , commandCommand = applyCmd StandardPatchApplier+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = fileArgs+    , commandArgdefaults = const stdindefault+    , commandOptions = applyOpts+    }+  where+    applyBasicOpts+      = O.verify+      ^ O.reorder+      ^ O.interactive+      ^ O.dryRunXml+      ^ O.matchSeveral+      ^ O.conflictsNo+      ^ O.testChanges+      ^ O.repoDir+      ^ O.diffAlgorithm+    applyAdvancedOpts+      = O.setScriptsExecutable+      ^ O.umask+      ^ O.changesReverse+      ^ O.pauseForGui+    applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts++applyCmd :: PatchApplier pa+         => pa+         -> (AbsolutePath, AbsolutePath)+         -> [DarcsFlag]+         -> [String]+         -> IO ()+applyCmd patchApplier (_,orig) opts args =+  withRepoLock (useCache ? opts) (umask ? opts) $+  repoJob patchApplier $ \patchProxy repository -> do+    bundle <- readBundle args+    applyCmdCommon patchApplier patchProxy opts bundle repository+  where+    readBundle ["-"] = do+      -- For users who try out 'darcs apply' without any arguments.+      -- FIXME apparently some magic behind the scenes causes an empty argument+      -- list to be converted to a single "-". This is quite obscure and should+      -- be removed.+      putInfo opts $ text "reading patch bundle from stdin..."+      gzReadStdin+    readBundle [""] = fail "Empty filename argument given to apply!"+    readBundle [unfixed_filename] = do+      patchesfile <- fixUrl orig unfixed_filename+      gzFetchFilePS (toFilePath patchesfile) Uncachable+    readBundle _ = error "impossible case"++applyCmdCommon+    :: forall pa p wR wU+     . (PatchApplier pa, RepoPatch p, ApplyState p ~ Tree)+    => pa+    -> PatchProxy p+    -> [DarcsFlag]+    -> B.ByteString+    -> Repository 'RW p wU wR+    -> IO ()+applyCmdCommon patchApplier patchProxy opts bundle repository = do+  us <- readPatches repository+  Sealed them <- either fail return =<< getPatchBundle opts us bundle+  Fork common us' them' <- return $ findCommon us them++  -- all patches in them' need to be available; check that+  let check :: PatchInfoAnd p wX wY -> Maybe PatchInfo+      check p = case hopefullyM p of+        Nothing -> Just (info p)+        Just _ -> Nothing+      bad = catMaybes (mapFL check them')+  unless (null bad) $+    fail $+    renderString $+      (vcat $ map displayPatchInfo bad) $$ text "" $$+      text "Cannot apply this bundle. We are missing the above patches."++  (hadConflicts, Sealed their_ps)+    <- if O.conflictsNo ? opts == Nothing -- skip conflicts+        then filterOutConflicts repository (O.useIndex ? opts) us' them'+        else return (False, Sealed them')+  when hadConflicts $ putStrLn "Skipping some patches which would cause conflicts."+  when (nullFL their_ps) $+       do if hadConflicts+           then putStrLn ("All new patches of the bundle cause conflicts.  " +++                          "Nothing to do.") >> exitSuccess+           else putStrLn ("All these patches have already been applied.  " +++                          "Nothing to do.") >> when (reorder ? opts /= O.Reorder) exitSuccess+          +  let direction = if changesReverse ? opts then FirstReversed else First+      selection_config = selectionConfig direction "apply" (patchSelOpts opts) Nothing Nothing+  (to_be_applied :> _) <- runSelection their_ps selection_config+  applyPatches patchApplier patchProxy "apply" opts repository (Fork common us' to_be_applied)++getPatchBundle :: RepoPatch p+               => [DarcsFlag]+               -> PatchSet p Origin wR+               -> B.ByteString+               -> IO (Either String (SealedPatchSet p Origin))+getPatchBundle opts us fps = do+    let opt_verify = parseFlags O.verify opts+    mps <- verifyPS opt_verify $ readEmail fps+    mops <- verifyPS opt_verify fps+    case (mps, mops) of+      (Nothing, Nothing) ->+          return $ Left "Patch bundle not properly signed, or gpg failed."+      (Just bundle, Nothing) -> return $ parseAndInterpretBundle us bundle+      (Nothing, Just bundle) -> return $ parseAndInterpretBundle us bundle+      -- We use careful_scan_bundle only below because in either of the two+      -- above case we know the patch was signed, so it really shouldn't+      -- need stripping of CRs.+      (Just ps1, Just ps2) -> case careful_scan_bundle ps1 of+                              Left _ -> return $ careful_scan_bundle ps2+                              Right x -> return $ Right x+          where careful_scan_bundle bundle =+                    case parseAndInterpretBundle us bundle of+                    Left e -> case parseAndInterpretBundle us $ stripCrPS bundle of+                              Right x -> Right x+                              _ -> Left e+                    x -> x+                stripCrPS :: B.ByteString -> B.ByteString+                stripCrPS bundle = unlinesPS $ map stripline $ linesPS bundle+                stripline p | B.null p = p+                            | BC.last p == '\r' = B.init p+                            | otherwise = p++parseAndInterpretBundle :: RepoPatch p+                        => PatchSet p Origin wR+                        -> B.ByteString+                        -> Either String (SealedPatchSet p Origin)+parseAndInterpretBundle us content = do+    Sealed bundle <- parseBundle content+    Sealed <$> interpretBundle us bundle++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = parseFlags O.matchSeveral flags+    , S.interactive = maybeIsInteractive flags+    , S.selectDeps = O.PromptDeps -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default+    }++maybeIsInteractive :: [DarcsFlag] -> Bool+maybeIsInteractive = maybe False id . parseFlags O.interactive
+ src/Darcs/UI/Commands/Clone.hs view
@@ -0,0 +1,369 @@+--  Copyright (C) 2002-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Clone+    ( get+    , put+    , clone+    , makeRepoName+    , cloneToSSH+    , otherHelpInheritDefault+    ) where++import Darcs.Prelude++import System.Directory ( doesDirectoryExist, doesFileExist+                        , setCurrentDirectory )+import System.Exit ( ExitCode(..) )+import System.FilePath.Posix ( joinPath, splitDirectories )+import Control.Monad ( when, unless )++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts+                      , nodefaults+                      , commandStub+                      , commandAlias+                      , putInfo+                      , putFinished+                      )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags+    ( DarcsFlag+    , cloneKind+    , fixUrl+    , patchIndexNo+    , quiet+    , setDefault+    , setScriptsExecutable+    , umask+    , useCache+    , usePacks+    , verbosity+    , withNewRepo+    , withWorkingDir+    )+import Darcs.UI.Options ( (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands.Util+    ( commonHelpWithPrefsTemplates+    , getUniqueRepositoryName+    )+import Darcs.Patch.Match ( MatchFlag(..) )+import Darcs.Repository ( cloneRepository )+import Darcs.Repository.Format ( identifyRepoFormat+                               , RepoProperty ( HashedInventory+                                              , RebaseInProgress+                                              )+                               , formatHas+                               )+import Darcs.Util.Lock ( withTempDir )+import Darcs.Util.Ssh ( getSSH, SSHCmd(SCP,SSH) )+import Darcs.Repository.Flags+    ( CloneKind(CompleteClone), SetDefault(NoSetDefault), ForgetParent(..) )+import Darcs.Repository.Prefs ( showMotd )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Printer ( Doc, formatWords, formatText, text, vsep, ($$), ($+$) )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Workaround ( getCurrentDirectory )+import Darcs.Util.URL ( SshFilePath(..), isSshUrl, splitSshUrl, sshCanonRepo )+import Darcs.Util.Exec ( exec, Redirect(..), )++cloneDescription :: String+cloneDescription = "Make a copy of an existing repository."++cloneHelp :: Doc+cloneHelp = vsep $+  map formatWords+  [ [ "Clone creates a copy of a repository.  The optional second"+    , "argument specifies a destination directory for the new copy;"+    , "if omitted, it is inferred from the source location."+    ]+  , [ "By default Darcs will copy every patch from the original repository."+    , "If you expect the original repository to remain accessible, you can"+    , "use `--lazy` to avoid copying patches until they are needed ('copy on"+    , "demand').  This is particularly useful when copying a remote"+    , "repository with a long history that you don't care about."+    ]+  , [ "When cloning locally, Darcs automatically uses hard linking where"+    , "possible.  As well as saving time and space, this enables to move or"+    , "delete the original repository without affecting the copy."+    , "Hard linking requires that the copy be on the same filesystem as the"+    , "original repository, and that the filesystem support hard linking."+    , "This includes NTFS, HFS+ and all general-purpose Unix filesystems"+    , "(such as ext, UFS and ZFS). FAT does not support hard links."+    ]+  , [ "When cloning from a remote location, Darcs will look for and attempt"+    , "to use packs created by `darcs optimize http` in the remote repository."+    , "Packs are single big files that can be downloaded faster than many"+    , "little files."+    ]+  , [ "Darcs clone will not copy unrecorded changes to the source repository's"+    , "working tree."+    ]+  , [ "You can copy a repository to a ssh url, in which case the new repository"+    , "will always be complete."+    ]+  ]+  +++  [ cloneHelpTag+  , cloneHelpSSE+  , cloneHelpInheritDefault+  , commonHelpWithPrefsTemplates+  ]++clone :: DarcsCommand+clone = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "clone"+    , commandHelp = cloneHelp+    , commandDescription = cloneDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["<REPOSITORY>", "[<DIRECTORY>]"]+    , commandCommand = cloneCmd+    , commandPrereq = \_ -> return $ Right ()+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = cloneOpts+    }+  where+    cloneBasicOpts+      = O.newRepo+      ^ O.cloneKind+      ^ O.matchOneContext+      ^ O.setDefault+      ^ O.inheritDefault+      ^ O.setScriptsExecutable+      ^ O.withWorkingDir+    cloneAdvancedOpts+      = O.usePacks+      ^ O.patchIndexNo+      ^ O.umask+      ^ O.remoteDarcs+      ^ O.withPrefsTemplates+    cloneOpts = cloneBasicOpts `withStdOpts` cloneAdvancedOpts++get :: DarcsCommand+get = commandAlias "get" Nothing clone++putDescription :: String+putDescription = "Deprecated command, replaced by clone."++putHelp :: Doc+putHelp = formatText 80+ [ "This command is deprecated."+ , "To clone the current repository to a ssh destination, " +++   "use the syntax `darcs clone . user@server:path` ."+ ]++put :: DarcsCommand+put = commandStub "put" putHelp putDescription clone++cloneCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+cloneCmd fps opts [inrepodir, outname] = cloneCmd fps (withNewRepo outname opts) [inrepodir]+cloneCmd (_,o) opts [inrepodir] = do+  debugMessage "Starting work on clone..."+  repodir <- fixUrl o inrepodir+  unless (quiet opts) $ showMotd repodir+  rfsource <- identifyRepoFormat repodir+  debugMessage $ "Found the format of "++repodir++"..."++  -- This merely forbids clone from an old-style rebase in progress, which is+  -- exactly what we want. Transferring patches from repos with new-style+  -- rebase in progress is unproblematic and fully supported.+  when (formatHas RebaseInProgress rfsource) $+      fail "Cannot clone a repository with an old-style rebase in progress"++  unless (formatHas HashedInventory rfsource) $ putInfo opts $+       text "***********************************************************************"+    $$ text "  _______   Sorry for the wait! The repository you are cloning is"+    $$ text " |       |  using the DEPRECATED 'old-fashioned' format. I'm doing a"+    $$ text " | O   O |  hashed copy instead, but this may take a while."+    $$ text " |  ___  |"+    $$ text " | /   \\ |  We recommend that the maintainer upgrade the remote copy"+    $$ text " |_______|  as well. See http://wiki.darcs.net/OF for more information."+    $$ text ""+    $$ text "***********************************************************************"++  case cloneToSSH opts of+    Just repo -> do+      withTempDir "clone" $ \_ -> do+         prepareRemoteDir repo+         putInfo opts $ text "Creating local clone..."+         currentDir <- getCurrentDirectory+         mysimplename <- makeRepoName True [] repodir -- give correct name to local clone+         cloneRepository repodir mysimplename (verbosity ? opts) (useCache ? opts)+                         CompleteClone (umask ? opts) (O.remoteDarcs ? opts)+                         (setScriptsExecutable ? opts)+                         (NoSetDefault True)+                         O.NoInheritDefault -- never inherit defaultrepo when cloning to ssh+                         (map convertUpToToOne (O.matchOneContext ? opts))+                         rfsource+                         (withWorkingDir ? opts)+                         (patchIndexNo ? opts)+                         (usePacks ? opts)+                         YesForgetParent+                         (O.withPrefsTemplates ? opts)+         setCurrentDirectory currentDir+         (scp, args) <- getSSH SCP+         putInfo opts $ text $ "Transferring clone using " ++ scp ++ "..."+         -- This has the precondition that the last part of 'repo' does not+         -- exist on the remote host, but all its parent directories do,+         -- which is ensured by 'prepareRemoteDir'.+         -- Note that adding the trailing slash to the source is essential+         -- in order to allow DARCS_SCP=rsync to work the same way as scp.+         r <- exec scp (args ++ ["-r", mysimplename ++ "/", repo]) (AsIs,AsIs,AsIs)+         when (r /= ExitSuccess) $ fail $ "Problem during " ++ scp ++ " transfer."+         putInfo opts $ text "Cloning and transferring successful."+    Nothing -> do+      mysimplename <- makeRepoName True opts repodir+      cloneRepository repodir mysimplename (verbosity ? opts) (useCache ? opts)+                  (cloneKind ? opts) (umask ? opts) (O.remoteDarcs ? opts)+                  (setScriptsExecutable ? opts)+                  (setDefault True opts)+                  (O.inheritDefault ? opts)+                  (map convertUpToToOne (O.matchOneContext ? opts))+                  rfsource+                  (withWorkingDir ? opts)+                  (patchIndexNo ? opts)+                  (usePacks ? opts)+                  NoForgetParent+                  (O.withPrefsTemplates ? opts)+      putFinished opts "cloning"++cloneCmd _ _ _ = fail "You must provide 'clone' with either one or two arguments."++cloneToSSH :: [DarcsFlag] -> Maybe String+cloneToSSH fs = case O.newRepo ? fs of+  Nothing -> Nothing+  Just r -> if isSshUrl r then Just (sshCanonRepo $ splitSshUrl r) else Nothing++mkRemoteDirectory :: Bool -> String -> FilePath -> IO ()+mkRemoteDirectory recursive sshUhost path = do+  (ssh, ssh_args) <- getSSH SSH+  let ssh_cmd = "mkdir " ++ (if recursive then "-p " else "") ++  "'" ++ path ++ "'"+  r <- exec ssh (ssh_args ++ [sshUhost, ssh_cmd]) (AsIs,AsIs,AsIs)+  when (r /= ExitSuccess) $+    fail $ "Cannot create remote directory '"  ++ path ++ "'."++rmRemoteDirectory :: String -> FilePath -> IO ()+rmRemoteDirectory sshUhost path = do+  (ssh, ssh_args) <- getSSH SSH+  let ssh_cmd = "rmdir '" ++ path ++ "'"+  r <- exec ssh (ssh_args ++ [sshUhost, ssh_cmd]) (AsIs,AsIs,AsIs)+  when (r /= ExitSuccess) $+    fail $ "Cannot remove remote directory '"  ++ path ++ "'."++-- | Make sure that the remote directory does not exist, but all its+-- parent directories do.+prepareRemoteDir :: String -> IO ()+prepareRemoteDir rpath = do+  let sshfp = splitSshUrl rpath+  let sshRepoParent = if length sshPathParts > 1 then joinPath (init sshPathParts) else []+        where+          sshPathParts = splitDirectories (sshRepo sshfp)++  unless (null sshRepoParent) $ mkRemoteDirectory True (sshUhost sshfp) sshRepoParent+  mkRemoteDirectory False (sshUhost sshfp) (sshRepo sshfp)+  rmRemoteDirectory (sshUhost sshfp) (sshRepo sshfp)++makeRepoName :: Bool -> [DarcsFlag] -> FilePath -> IO String+makeRepoName talkative fs d =+  case O.newRepo ? fs of+    Just n -> do+      exists <- doesDirectoryExist n+      file_exists <- doesFileExist n+      if exists || file_exists+        then fail $ "Directory or file named '" ++ n ++ "' already exists."+        else return n+    Nothing ->+      case mkName d of+        "" -> getUniqueRepositoryName talkative "anonymous_repo"+        base@('/':_) -> getUniqueRepositoryName talkative base -- Absolute+        base -- Relative+         -> do+          cwd <- getCurrentDirectory+          getUniqueRepositoryName talkative (cwd ++ "/" ++ base)+      where mkName = dropWhile (== '.') . reverse .+              takeWhile (not . (`elem` "/:")) . dropWhile (== '/') . reverse++cloneHelpTag :: Doc+cloneHelpTag = formatWords+  [ ""+  , "It is often desirable to make a copy of a repository that excludes"+  , "some patches.  For example, if releases are tagged then `darcs clone"+  , "--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 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"+  , "find out exactly what version they were running is to have them" +  , "include a context file in the bug report."+  , ""+  , "You can also make a copy of an untagged state using the `--to-patch` or"+  , "`--to-match` options, which exclude patches *after* the first matching"+  , "patch.  Because these options treat the set of patches as an ordered"+  , "sequence, you may get different results after reordering with `darcs"+  , "optimize reorder`."+  ]++cloneHelpSSE :: Doc+cloneHelpSSE = formatWords+  [ "The `--set-scripts-executable` option causes scripts to be made"+  , "executable in the working tree. A script is any file that starts"+  , "with a shebang (\"#!\")."+  ]++cloneHelpInheritDefault :: Doc+cloneHelpInheritDefault = commonHelpInheritDefault $+$ formatWords+  [ "For the clone command it means the following:"+  , "If the source repository already has a defaultrepo set (either because"+  , "you cloned it or because you explicitly used the --set-default option),"+  , "and both source and target are locally valid paths on the same host,"+  , "then the target repo will get the same defaultrepo as the source repo."+  , "Otherwise the target repo gets the source repo itself as defaultrepo,"+  , "i.e. we fall back to the defalt behavior (--no-inherit-default)."+  ]++otherHelpInheritDefault :: Doc+otherHelpInheritDefault = commonHelpInheritDefault $+$ formatWords+  [ "For the commands push, pull, and send it means the following:"+  , "Changes the meaning of the --set-default option so that it sets the"+  , "(local) defaultrepo to the defaultrepo of the remote repo, instead of"+  , "the remote repo itself. This happens only if the remote repo does have"+  , "a defaultrepo set and both local and remote repositories are locally"+  , "valid paths on the same host, otherwise fall back to the default behavior"+  , "(--no-inherit-default)."+  ]++commonHelpInheritDefault :: Doc+commonHelpInheritDefault = formatWords+  [ "The --inherit-default option is meant to support a work flow where"+  , "you have different branches of the same upstream repository and want"+  , "all your branches to have the same upstream repo as the defaultrepo."+  , "It is most useful when enabled globally by adding 'ALL --inherit-default'"+  , "to your ~/darcs/defaults file."+  ]++-- | The 'clone' command takes --to-patch and --to-match as arguments,+-- but internally wants to handle them as if they were --patch and --match.+-- This function does the conversion.+convertUpToToOne :: MatchFlag -> MatchFlag+convertUpToToOne (UpToPattern p) = OnePattern p+convertUpToToOne (UpToPatch p) = OnePatch p+convertUpToToOne (UpToHash p) = OneHash p+convertUpToToOne f = f
+ src/Darcs/UI/Commands/Convert.hs view
@@ -0,0 +1,45 @@+--  Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Convert ( convert ) where++import Darcs.Prelude++import Darcs.UI.Commands (DarcsCommand(..), amInRepository, normalCommand)+import Darcs.UI.Commands.Convert.Darcs2 (convertDarcs2)+import Darcs.UI.Commands.Convert.Import (convertImport)+import Darcs.UI.Commands.Convert.Export (convertExport)+import Darcs.Util.Printer ( text, ($+$) )++convertDescription :: String+convertDescription = "Convert repositories between various formats."++convert :: DarcsCommand+convert = SuperCommand+    { commandProgramName = "darcs"+    , commandName = "convert"+    , commandHelp =+        text convertDescription $+$+        text "See description of the subcommands for details."+    , commandDescription = convertDescription+    , commandPrereq = amInRepository+    , commandSubCommands =+        [ normalCommand convertDarcs2+        , normalCommand convertExport+        , normalCommand convertImport+        ]+    }
+ src/Darcs/UI/Commands/Convert/Darcs2.hs view
@@ -0,0 +1,290 @@+--  Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Convert.Darcs2 ( convertDarcs2 ) where++import Control.Monad ( when, unless, void )+import qualified Data.ByteString as B+import Data.Char ( toLower )+import Data.Maybe ( catMaybes )+import Data.List ( lookup )+import Safe ( headErr )+import System.FilePath.Posix ( (</>) )+import System.Directory ( doesDirectoryExist, doesFileExist )++import Darcs.Prelude++import Darcs.Patch ( RepoPatch, effect, displayPatch )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Info ( isTag, piRename, piTag )+import Darcs.Patch.Named ( Named(..), getdeps, patch2patchinfo, patchcontents )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia )+import Darcs.Patch.Permutations ( (=/~\=) )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Patch.Set ( inOrderTags, patchSet2FL, patchSet2RL )+import qualified Darcs.Patch.V1 as V1 ( RepoPatchV1 )+import Darcs.Patch.V1.Commute ( publicUnravel )+import qualified Darcs.Patch.V1.Core as V1 ( RepoPatchV1(PP), isMerger )+import qualified Darcs.Patch.V1.Prim as V1 ( Prim(..) )+import qualified Darcs.Patch.V2.Prim as V2 ( Prim(..) )+import qualified Darcs.Patch.V2.RepoPatch as V2 ( RepoPatchV2(Normal) )+import Darcs.Patch.V2.RepoPatch ( mergeUnravelled )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , concatFL+    , foldFL_M+    , mapFL_FL+    , mapRL+    , reverseFL+    )+import Darcs.Patch.Witnesses.Sealed ( FlippedSeal(..), mapSeal )++import Darcs.Repository+    ( RepoJob(..)+    , Repository+    , AccessType(..)+    , applyToWorking+    , createRepositoryV2+    , finalizeRepositoryChanges+    , readPatches+    , revertRepositoryChanges+    , withRepositoryLocation+    , withUMaskFlag+    )+import qualified Darcs.Repository as R ( setAllScriptsExecutable )+import Darcs.Repository.Format+    ( RepoProperty(Darcs2)+    , formatHas+    , identifyRepoFormat+    )+import Darcs.Repository.Hashed ( UpdatePristine(..), tentativelyAddPatch_ )+import Darcs.Repository.Prefs ( showMotd, prefsFilePath )++import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, putFinished, withStdOpts )+import Darcs.UI.Commands.Convert.Util ( updatePending )+import Darcs.UI.Commands.Util ( commonHelpWithPrefsTemplates )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags+    ( verbosity, useCache, umask, withWorkingDir, patchIndexNo+    , DarcsFlag, withNewRepo+    , quiet+    )+import Darcs.UI.Options ( parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O++import Darcs.Util.File ( fetchFilePS, Cachable(Uncachable) )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.Lock ( withNewDirectory )+import Darcs.Util.Path( ioAbsoluteOrRemote, toPath, AbsolutePath )+import Darcs.Util.Printer ( Doc, text, ($$), ($+$) )+import Darcs.Util.Printer.Color ( traceDoc )+import Darcs.Util.Prompt ( askUser )+import Darcs.Util.Tree( Tree )+import Darcs.Util.Workaround ( getCurrentDirectory )++type RepoPatchV1 = V1.RepoPatchV1 V1.Prim+type RepoPatchV2 = V2.RepoPatchV2 V2.Prim++convertDarcs2Help :: Doc+convertDarcs2Help = text (unlines+ [ "This command converts a repository that uses the old patch semantics"+ , "`darcs-1` to a new repository with current `darcs-2` semantics."+ , ""+ , convertDarcs2Help'+ ])+ $+$ commonHelpWithPrefsTemplates++-- | This part of the help is split out because it is used twice: in+-- the help string, and in the prompt for confirmation.+convertDarcs2Help' :: String+convertDarcs2Help' = unlines+ [ "WARNING: the repository produced by this command is not understood by"+ , "Darcs 1.x, and patches cannot be exchanged between repositories in"+ , "darcs-1 and darcs-2 formats. Also, you should not exchange patches"+ , "between repositories created by different invocations of this command."+ , "This means:"+ , "- Before doing this conversion, you should merge into this repo any patches"+ , "  existing elsewhere that you might want to merge in future, so that they"+ , "  will remain mergeable. (You can always remove them again after converting)."+ , "- After converting, you should tell everyone with a fork of this repo"+ , "  to discard it and make a new fork of the converted repo."+ ]++convertDarcs2 :: DarcsCommand+convertDarcs2 = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "darcs-2"+    , commandHelp = convertDarcs2Help+    , commandDescription = "Convert darcs-1 repository to the darcs-2 patch format"+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["<SOURCE>", "[<DESTINATION>]"]+    , commandCommand = toDarcs2+    , commandPrereq = \_ -> return $ Right ()+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = opts+    }+  where+    basicOpts = O.newRepo ^ O.setScriptsExecutable ^ O.withWorkingDir+    advancedOpts = O.remoteDarcs ^ O.patchIndexNo ^ O.umask ^ O.patchFormat+    opts = basicOpts `withStdOpts` advancedOpts++toDarcs2 :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+toDarcs2 _ opts' args = do+  (inrepodir, opts) <-+    case args of+      [arg1, arg2] -> return (arg1, withNewRepo arg2 opts')+      [arg1] -> return (arg1, opts')+      _ -> fail "You must provide either one or two arguments."+  typed_repodir <- ioAbsoluteOrRemote inrepodir+  let repodir = toPath typed_repodir++  format <- identifyRepoFormat repodir+  when (formatHas Darcs2 format) $ fail "Repository is already in darcs 2 format."++  putStrLn convertDarcs2Help'+  answer <- askUser ("Do you still want to proceed ? If so, please type \"yes\": ")+  when (map toLower answer /= "yes") $ fail "Ok, doing nothing."++  unless (quiet opts) $ showMotd repodir++  mysimplename <- makeRepoName opts repodir+  withUMaskFlag (umask ? opts) $ withNewDirectory mysimplename $ do+    _repo <-+      createRepositoryV2 (withWorkingDir ? opts) (patchIndexNo ? opts)+        (O.useCache ? opts) (O.withPrefsTemplates ? opts)+    _repo <- revertRepositoryChanges _repo++    withRepositoryLocation (useCache ? opts) repodir $ V1Job $ \other -> do+      theirstuff <- readPatches other+      let patches = mapFL_FL (convertNamed . hopefully) $ patchSet2FL theirstuff+          outOfOrderTags = catMaybes $ mapRL oot $ patchSet2RL theirstuff+              where oot t = if isTag (info t) && info t `notElem` inOrderTags theirstuff+                            then Just (info t, getdeps $ hopefully t)+                            else Nothing+          fixDep p = case lookup p outOfOrderTags of+                     Just d -> p : concatMap fixDep d+                     Nothing -> [p]+          primV1toV2 = V2.Prim . V1.unPrim+          convertOne :: RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY+          convertOne x | V1.isMerger x =+            let ex = mapFL_FL primV1toV2 (effect x) in+            case mergeUnravelled $ map (mapSeal (mapFL_FL primV1toV2)) $ publicUnravel x of+             Just (FlippedSeal y) ->+                 case reverseFL (effect y) =/~\= reverseFL ex of+                 IsEq -> y :>: NilFL+                 NotEq ->+                     traceDoc (text "lossy conversion:" $$+                               displayPatch x) $+                     mapFL_FL V2.Normal ex+             Nothing -> traceDoc (text+                                  "lossy conversion of complicated conflict:" $$+                                  displayPatch x) $+                        mapFL_FL V2.Normal ex+          convertOne (V1.PP x) = V2.Normal (primV1toV2 x) :>: NilFL+          convertOne _ = error "impossible case"+          convertFL :: FL RepoPatchV1 wX wY -> FL RepoPatchV2 wX wY+          convertFL = concatFL . mapFL_FL convertOne+          convertNamed :: Named RepoPatchV1 wX wY+                       -> PatchInfoAnd RepoPatchV2 wX wY+          convertNamed n = n2pia $+                           NamedP+                            (convertInfo $ patch2patchinfo n)+                            (map convertInfo $ concatMap fixDep $ getdeps n)+                            (convertFL $ patchcontents n)+          convertInfo n | n `elem` inOrderTags theirstuff = n+                        | otherwise = maybe n (\t -> piRename n ("old tag: "++t)) $ piTag n++      _ <- applyAll opts _repo $ progressFL "Converting patch" patches+      void $ finalizeRepositoryChanges _repo (O.dryRun ? opts)+      when (parseFlags O.setScriptsExecutable opts == O.YesSetScriptsExecutable)+        R.setAllScriptsExecutable++      -- Copy over the prefs file+      (fetchFilePS (repodir </> prefsFilePath) Uncachable >>= B.writeFile prefsFilePath)+       `catchall` return ()++      putFinished opts "converting"+  where+    applyOne :: (RepoPatch p, ApplyState p ~ Tree)+             => [DarcsFlag]+             -> W2 (Repository 'RW p) wX+             -> PatchInfoAnd p wX wY+             -> IO (W2 (Repository 'RW p) wY)+    applyOne opts (W2 _repo) x = do+      _repo <-+        tentativelyAddPatch_ (updatePristine opts) _repo (updatePending opts) x+      _repo <- applyToWorking _repo (verbosity ? opts) (effect x)+      return (W2 _repo)++    applyAll :: (RepoPatch p, ApplyState p ~ Tree)+             => [DarcsFlag]+             -> Repository 'RW p wX wX+             -> FL (PatchInfoAnd p) wX wY+             -> IO (Repository 'RW p wY wY)+    applyAll opts r xss = unW2 <$> foldFL_M (applyOne opts) (W2 r) xss++    updatePristine :: [DarcsFlag] -> UpdatePristine+    updatePristine opts =+      case withWorkingDir ? opts of+        O.WithWorkingDir -> UpdatePristine+        -- this should not be necessary but currently is, because+        -- some commands (e.g. send) cannot cope with a missing pristine+        -- even if the repo is marked as having no working tree+        O.NoWorkingDir -> {- DontUpdatePristineNorRevert -}UpdatePristine++-- | Need this to make 'foldFL_M' work with a function that changes+-- the last two (identical) witnesses at the same time.+newtype W2 r wX = W2 {unW2 :: r wX wX}++makeRepoName :: [DarcsFlag] -> FilePath -> IO String+makeRepoName opts d =+  case O.newRepo ? opts of+    Just n -> do+      exists <- doesDirectoryExist n+      file_exists <- doesFileExist n+      if exists || file_exists+        then fail $ "Directory or file named '" ++ n ++ "' already exists."+        else return n+    Nothing ->+      case dropWhile (== '.') $+           reverse $+           takeWhile (\c -> c /= '/' && c /= ':') $+           dropWhile (== '/') $ reverse d of+        "" -> modifyRepoName "anonymous_repo"+        base -> modifyRepoName base++modifyRepoName :: String -> IO String+modifyRepoName name =+    if headErr name == '/'+    then mrn name (-1)+    else do cwd <- getCurrentDirectory+            mrn (cwd ++ "/" ++ name) (-1)+ where+  mrn :: String -> Int -> IO String+  mrn n i = do+    exists <- doesDirectoryExist thename+    file_exists <- doesFileExist thename+    if not exists && not file_exists+       then do when (i /= -1) $+                    putStrLn $ "Directory '"++ n +++                               "' already exists, creating repository as '"+++                               thename ++"'"+               return thename+       else mrn n $ i+1+    where thename = if i == -1 then n else n++"_"++show i
+ src/Darcs/UI/Commands/Convert/Export.hs view
@@ -0,0 +1,375 @@+--  Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}++module Darcs.UI.Commands.Convert.Export+  ( convertExport+  -- exported for testing+  , cleanPatchAuthor+  , cleanPatchAuthorTestCases+  ) where++import Darcs.Prelude hiding ( readFile, lex )++import Control.Exception (finally)+import Control.Monad (forM_, unless, void, when)+import Control.Monad.State.Strict (gets)+import Control.Monad.Trans (liftIO)++import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import qualified Data.ByteString.Lazy.UTF8 as BLU+import Data.Char (isSpace)+import Data.IORef (modifyIORef, newIORef, readIORef)+import Data.Maybe (fromJust)+import System.Time (toClockTime)++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )+import Darcs.Patch ( RepoPatch, apply, effect, listTouchedFiles )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Effect ( Effect )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , nullFL+    )+import Darcs.Patch.Witnesses.Sealed+    ( FlippedSeal(..)+    , flipSeal+    , unsealFlipped+    )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )++import Darcs.Patch.Info+    ( PatchInfo+    , isTag+    , piAuthor+    , piDate+    , piLog+    , piName+    )+import Darcs.Patch.Set ( patchSet2FL, inOrderTags )++import Darcs.Repository+    ( RepoJob(..)+    , Repository+    , readPatches+    , repoCache+    , withRepository+    )+import Darcs.Repository.Pristine ( readHashedPristineRoot )+import Darcs.Repository.Traverse ( cleanPristineDir )++import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInRepository+    , nodefaults+    , withStdOpts+    )+import Darcs.UI.Commands.Convert.Util+    ( Marks+    , addMark+    , emptyMarks+    , getMark+    , lastMark+    , readMarks+    , writeMarks+    , patchHash+    )+import Darcs.UI.Completion (noArgs)+import Darcs.UI.Flags ( DarcsFlag , useCache )+import Darcs.UI.Options ( parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O++import Darcs.Util.DateTime ( formatDateTime, fromClockTime )+import Darcs.Util.Path+    ( AbsolutePath+    , AnchoredPath(..)+    , anchorPath+    , appendPath+    , toFilePath+    )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Tree+    ( Tree+    , emptyTree+    , findTree+    , listImmediate+    )+import Darcs.Util.Tree.Hashed ( hashedTreeIO )++import Darcs.Util.Tree.Monad ( TreeIO )+import qualified Darcs.Util.Tree.Monad as T+    ( directoryExists+    , fileExists+    , readFile+    , tree+    )+++convertExportHelp :: Doc+convertExportHelp = text $ unlines+ [ "This command enables you to export darcs repositories into git."+ , ""+ , "For a one-time export you can use the recipe:"+ , ""+ , "    $ cd repo"+ , "    $ git init ../mirror"+ , "    $ darcs convert export | (cd ../mirror && git fast-import)"+ , ""+ , "For incremental export using marksfiles:"+ , ""+ , "    $ cd repo"+ , "    $ git init ../mirror"+ , "    $ touch ../mirror/git.marks"+ , "    $ darcs convert export --read-marks darcs.marks --write-marks darcs.marks"+ , "       | (cd ../mirror && git fast-import --import-marks=git.marks --export-marks=git.marks)"+ , ""+ , "In the case of incremental export, be careful to never amend, delete or"+ , "reorder patches in the source darcs repository."+ , ""+ , "Also, be aware that exporting a darcs repo to git will not be exactly"+ , "faithful in terms of history if the darcs repository contains conflicts."+ , ""+ , "Limitations:"+ , ""+ , "  * Empty directories are not supported by the fast-export protocol."+ , "  * Unicode filenames are currently not correctly handled."+ , "    See http://bugs.darcs.net/issue2359 ."+ ]++convertExport :: DarcsCommand+convertExport = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "export"+    , commandHelp = convertExportHelp+    , commandDescription = "Export a darcs repository to a git-fast-import stream"+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = fastExport+    , commandPrereq = amInRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = convertExportOpts+    }+  where+    convertExportBasicOpts = O.repoDir ^ O.marks+    convertExportAdvancedOpts = O.remoteDarcs+    convertExportOpts = convertExportBasicOpts `withStdOpts` convertExportAdvancedOpts++fastExport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+fastExport _ opts _ = do+  marks <- case parseFlags O.readMarks opts of+    Nothing -> return emptyMarks+    Just f  -> readMarks (toFilePath f)+  newMarks <-+    withRepository (useCache ? opts) $ RepoJob $ \repo -> fastExport' repo marks+  case parseFlags O.writeMarks opts of+    Nothing -> return ()+    Just f  -> writeMarks (toFilePath f) newMarks++fastExport' :: (RepoPatch p, ApplyState p ~ Tree)+            => Repository rt p wU wR -> Marks -> IO Marks+fastExport' repo marks = do+  putStrLn "progress (reading repository)"+  patchset <- readPatches repo+  marksref <- newIORef marks+  let patches = patchSet2FL patchset+      tags = inOrderTags patchset+      mark :: (PatchInfoAnd p) x y -> Int -> TreeIO ()+      mark p n = liftIO $ do putStrLn $ "mark :" ++ show n+                             modifyIORef marksref $ \m -> addMark m n (patchHash p)+      -- apply a single patch to build the working tree of the last exported version+      checkOne :: (RepoPatch p, ApplyState p ~ Tree)+               => Int -> (PatchInfoAnd p) x y -> TreeIO ()+      checkOne n p = do apply p+                        unless (inOrderTag tags p ||+                                (getMark marks n == Just (patchHash p))) $+                          fail $ "FATAL: Marks do not correspond: expected " +++                                 show (getMark marks n) ++ ", got " ++ BC.unpack (patchHash p)+      -- build the working tree of the last version exported by convert --export+      check :: (RepoPatch p, ApplyState p ~ Tree)+            => Int -> FL (PatchInfoAnd p) x y -> TreeIO (Int,  FlippedSeal( FL (PatchInfoAnd p)) y) +      check _ NilFL = return (1, flipSeal NilFL)+      check n allps@(p:>:ps)+        | n <= lastMark marks = checkOne n p >> check (next tags n p) ps+        | n > lastMark marks = return (n, flipSeal allps)+        | lastMark marks == 0 = return (1, flipSeal allps)+        | otherwise = undefined+  ((n, patches'), tree') <- hashedTreeIO (check 1 patches) emptyTree (repoCache repo)+  let patches'' = unsealFlipped unsafeCoerceP patches'+  void $ hashedTreeIO (dumpPatches tags mark n patches'') tree' (repoCache repo)+  readIORef marksref+ `finally` do+  putStrLn "progress (cleaning up)"+  current <- readHashedPristineRoot repo+  cleanPristineDir (repoCache repo) [current]+  putStrLn "progress done"++dumpPatches ::  (RepoPatch p, ApplyState p ~ Tree)+            =>  [PatchInfo]+            -> (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ())+            -> Int -> FL (PatchInfoAnd p) x y -> TreeIO ()+dumpPatches _ _ _ NilFL = liftIO $ putStrLn "progress (patches converted)"+dumpPatches tags mark n (p:>:ps) = do+  apply p+  if inOrderTag tags p && n > 0+     then dumpTag p n+     else do dumpPatch mark p n+             dumpFiles $ listTouchedFiles p+  dumpPatches tags mark (next tags n p) ps++dumpTag :: (PatchInfoAnd p) x y  -> Int -> TreeIO () +dumpTag p n =+  dumpBits [ BLU.fromString $ "progress TAG " ++ cleanTagName p+           , BLU.fromString $ "tag " ++ cleanTagName p -- FIXME is this valid?+           , BLU.fromString $ "from :" ++ show (n - 1)+           , BLU.fromString $ unwords ["tagger", patchAuthor p, patchDate p]+           -- -3 == (-4 for "TAG " and +1 for newline)+           , BLU.fromString $ "data "+                 ++ show (BL.length (patchMessage p) - 3)+           , BL.drop 4 $ patchMessage p ]+   where+     -- FIXME forbidden characters and subsequences in tags:+     -- https://www.kernel.org/pub/software/scm/git/docs/git-check-ref-format.html+     cleanTagName = map cleanup . drop 4 . piName . info+         where cleanup x | x `elem` bad = '_'+                         | otherwise = x+               bad :: String+               bad = " ~^:"++dumpFiles :: [AnchoredPath] -> TreeIO ()+dumpFiles files = forM_ files $ \file -> do+  let quotedPath = quotePath $ anchorPath "" file+  isfile <- T.fileExists file+  isdir <- T.directoryExists file+  when isfile $ do bits <- T.readFile file+                   dumpBits [ BLU.fromString $ "M 100644 inline " ++ quotedPath+                            , BLU.fromString $ "data " ++ show (BL.length bits)+                            , bits ]+  when isdir $ do -- Always delete directory before dumping its contents. This fixes+                  -- a corner case when a same patch moves dir1 to dir2, and creates+                  -- another directory dir1.+                  -- As we always dump its contents anyway this is not more costly.+                  liftIO $ putStrLn $ "D " ++ quotedPath+                  tt <- gets T.tree -- ick+                  let subs = [ file `appendPath` n | (n, _) <-+                                  listImmediate $ fromJust $ findTree tt file ]+                  dumpFiles subs+  when (not isfile && not isdir) $ liftIO $ putStrLn $ "D " ++ quotedPath+  where+    -- |quotePath escapes and quotes paths containing newlines, double-quotes+    -- or backslashes.+    quotePath :: FilePath -> String+    quotePath path = case foldr escapeChars ("", False) path of+        (_, False) -> path+        (path', True) -> quote path'++    quote str = "\"" ++ str ++ "\""++    escapeChars c (processed, haveEscaped) = case escapeChar c of+        (escaped, didEscape) ->+            (escaped ++ processed, didEscape || haveEscaped)++    escapeChar c = case c of+        '\n' -> ("\\n", True)+        '\r' -> ("\\r", True)+        '"'  -> ("\\\"", True)+        '\\' -> ("\\\\", True)+        _    -> ([c], False)+++dumpPatch ::  (forall p0 x0 y0 . (PatchInfoAnd p0) x0 y0 -> Int -> TreeIO ())+          -> (PatchInfoAnd p) x y -> Int+          -> TreeIO ()+dumpPatch mark p n =+  do dumpBits [ BLU.fromString $ "progress " ++ show n ++ ": " ++ piName (info p)+              , "commit refs/heads/master" ]+     mark p n+     dumpBits [ BLU.fromString $ "committer " ++ patchAuthor p ++ " " ++ patchDate p+              , BLU.fromString $ "data " ++ show (BL.length $ patchMessage p)+              , patchMessage p ]+     when (n > 1) $ dumpBits [ BLU.fromString $ "from :" ++ show (n - 1) ]++dumpBits :: [BL.ByteString] -> TreeIO ()+dumpBits = liftIO . BLC.putStrLn . BL.intercalate "\n"++-- patchAuthor attempts to fixup malformed author strings+-- into format: "Name <Email>"+-- e.g.+-- <john@home>      -> john <john@home>+-- john@home        -> john <john@home>+-- john <john@home> -> john <john@home>+-- john <john@home  -> john <john@home>+-- <john>           -> john <unknown>+patchAuthor :: (PatchInfoAnd p) x y -> String+patchAuthor = cleanPatchAuthor . piAuthor . info++cleanPatchAuthor :: String -> String+cleanPatchAuthor authorString+ | null author = unknownEmail "unknown"+ | otherwise = case span (/='<') author of+               -- No name, but have email (nothing spanned)+               ("", _:email) -> case span (/='@') email of+                   -- Not a real email address (no @).+                   (n, "") -> case span (/='>') n of+                       (name, _) -> unknownEmail name+                   -- A "real" email address.+                   (user, _:rest) -> case span (/= '>') rest of+                       (dom, _) -> mkAuthor user $ emailPad (user ++ "@" ++ dom)+               -- No email (everything spanned)+               (_, "") -> case span (/='@') author of+                   (n, "") -> unknownEmail n+                   (name, _) -> mkAuthor name $ emailPad author+               -- Name and email+               (n, _:rest) -> case span (/='>') rest of+                   (email, _) -> n ++ emailPad email+ where+   author = dropWhile isSpace authorString+   unknownEmail = flip mkAuthor "<unknown>"+   emailPad email = "<" ++ email ++ ">"+   mkAuthor name email = name ++ " " ++ email++cleanPatchAuthorTestCases :: [(String, String)]+cleanPatchAuthorTestCases =+  [ ("<john@home>", "john <john@home>")+  , ("john@home", "john <john@home>")+  , ("john <john@home>", "john <john@home>")+  , ("john <john@home", "john <john@home>")+  , ("<john>", "john <unknown>")+  , ("", "unknown <unknown>")+  , (" ", "unknown <unknown>")+  ]++patchDate :: (PatchInfoAnd p) x y -> String+patchDate = formatDateTime "%s +0000" . fromClockTime . toClockTime .+  piDate . info++patchMessage :: (PatchInfoAnd p) x y -> BLU.ByteString+patchMessage p = BL.concat [ BLU.fromString (piName $ info p)+                           , case unlines . piLog $ info p of+                                 "" -> BL.empty+                                 plog -> BLU.fromString ("\n\n" ++ plog)+                           ]++inOrderTag :: (Effect p) => [PatchInfo] -> PatchInfoAnd p wX wZ -> Bool+inOrderTag tags p = isTag (info p) && info p `elem` tags && nullFL (effect p)++next :: (Effect p) => [PatchInfo] -> Int ->  PatchInfoAnd p x y -> Int+next tags n p = if inOrderTag tags p then n else n + 1+
+ src/Darcs/UI/Commands/Convert/Import.hs view
@@ -0,0 +1,622 @@+--  Copyright (C) 2002-2014 David Roundy, Petr Rockai, Owen Stephens+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}++module Darcs.UI.Commands.Convert.Import ( convertImport ) where++import Darcs.Prelude hiding ( readFile, lex )++import Control.Applicative ((<|>),many)+import Control.Arrow ((&&&), second)+import Control.Monad (unless, void, when)+import Control.Monad.State.Strict (gets, modify)+import Control.Monad.Trans (liftIO)++import qualified Data.Attoparsec.ByteString.Char8 as A+import Data.Attoparsec.ByteString.Char8 ((<?>))+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy.Char8 as BLC+import Data.IORef (modifyIORef, newIORef)+import Data.Maybe (fromMaybe)+import Data.Word (Word8)++import Safe (headErr, tailErr)++import System.Directory (doesFileExist)+import System.FilePath.Posix ((</>))+import System.IO (stdin)++import Darcs.Patch.Depends ( getUncovered )+import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch ( PrimOf, RepoPatch, move )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Named ( Named(..), infopatch )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , RL(..)+    , (+<<+)+    , reverseRL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), unFreeLeft )++import Darcs.Patch.Info ( PatchInfo, patchinfo )+import Darcs.Patch.Prim ( canonizeFL )++import Darcs.Repository+    ( EmptyRepository(..)+    , AccessType(RW)+    , Repository+    , cleanRepository+    , createPristineDirectoryTree+    , createRepository+    , finalizeRepositoryChanges+    , readPatches+    , repoCache+    , revertRepositoryChanges+    , withUMaskFlag+    )+import Darcs.Repository.Diff (treeDiff)+import Darcs.Repository.Hashed (addToTentativeInventory)+import Darcs.Repository.Paths (tentativePristinePath)+import Darcs.Repository.Prefs (FileType(..))+import Darcs.Repository.State (readPristine)++import Darcs.UI.Commands+    ( DarcsCommand(..)+    , nodefaults+    , withStdOpts+    )+import Darcs.UI.Commands.Convert.Util+    ( Marks+    , addMark+    , emptyMarks+    , getMark+    , patchHash+    )+import Darcs.UI.Commands.Util ( commonHelpWithPrefsTemplates )+import Darcs.UI.Completion (noArgs)+import Darcs.UI.Flags+    ( DarcsFlag+    , patchFormat+    , patchIndexNo+    , umask+    , useCache+    , withWorkingDir+    )+import Darcs.UI.Options ( (?), (^) )+import qualified Darcs.UI.Options.All as O++import Darcs.Util.ByteString (decodeLocale, unpackPSFromUTF8)+import Darcs.Util.DateTime+    ( formatDateTime+    , parseDateTime+    , startOfTime+    )+import Darcs.Util.Global (darcsdir)+import Darcs.Util.Hash (encodeBase16, sha256)+import Darcs.Util.Lock (withNewDirectory)+import Darcs.Util.Path+    ( AbsolutePath+    , AnchoredPath(..)+    , appendPath+    , unsafeFloatPath+    , makeName+    , parent+    , darcsdirName+    )+import Darcs.Util.Printer ( Doc, text, ($+$) )+import qualified Darcs.Util.Tree as T+import Darcs.Util.Tree+    ( Tree+    , TreeItem(..)+    , findTree+    , listImmediate+    , readBlob+    , treeHasDir+    , treeHasFile+    , treeHash+    )+import Darcs.Util.Tree.Hashed (darcsAddMissingHashes, hashedTreeIO)+import qualified Darcs.Util.Tree.Monad as TM+import Darcs.Util.Tree.Monad hiding (createDirectory, exists, rename)+++convertImportHelp :: Doc+convertImportHelp = text (unlines+ [ "This command imports git repositories into new darcs repositories."+ , "Further options are accepted (see `darcs help init`)."+ , ""+ , "To convert a git repo to a new darcs one you may run:"+ , ""+ , "    $ (cd gitrepo && git fast-export --all -M) | darcs convert import darcsmirror"+ , ""+ , "WARNING: git repositories with branches will produce weird results,"+ , "         use at your own risks."+ , ""+ , "Incremental import with marksfiles is currently not supported."+ ])+ $+$ commonHelpWithPrefsTemplates++convertImport :: DarcsCommand+convertImport = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "import"+    , commandHelp = convertImportHelp+    , commandDescription = "Import from a git-fast-export stream into darcs"+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[<DIRECTORY>]"]+    , commandCommand = fastImport+    , commandPrereq = \_ -> return $ Right ()+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = opts+    }+  where+    basicOpts+      = O.newRepo+      ^ O.setScriptsExecutable+      ^ O.patchFormat+      ^ O.withWorkingDir+    advancedOpts+      = O.diffAlgorithm+      ^ O.patchIndexNo+      ^ O.umask+      ^ O.withPrefsTemplates+    opts = basicOpts `withStdOpts` advancedOpts++type Marked = Maybe Int+type Branch = B.ByteString+type AuthorInfo = B.ByteString+type Message = B.ByteString+type Content = B.ByteString+type Tag = B.ByteString++data RefId = MarkId Int | HashId B.ByteString | Inline+           deriving Show++-- Newish (> 1.7.6.1) Git either quotes filenames or has two+-- non-special-char-containing paths. Older git doesn't do any quoting, so+-- we'll have to manually try and find the correct paths, when we use the+-- paths.+data CopyRenameNames = Quoted B.ByteString B.ByteString+                     | Unquoted B.ByteString deriving Show++data Object = Blob (Maybe Int) Content+            | Reset Branch (Maybe RefId)+            | Commit Branch Marked AuthorInfo Message+            | Tag Tag Int AuthorInfo Message+            | Modify (Either Int Content) B.ByteString -- (mark or content), filename+            | Gitlink B.ByteString+            | Copy CopyRenameNames+            | Rename CopyRenameNames+            | Delete B.ByteString -- filename+            | From Int+            | Merge Int+            | Progress B.ByteString+            | End+            deriving Show++type Ancestors = (Marked, [Int])+data State p where+  Toplevel :: Marked -> Branch -> State p+  InCommit :: Marked -> Ancestors -> Branch -> Tree IO -> RL (PrimOf p) cX cY -> PatchInfo -> State p+  Done :: State p++instance Show (State p) where+  show Toplevel {} = "Toplevel"+  show InCommit {} = "InCommit"+  show Done =  "Done"++fastImport :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+fastImport _ opts [outrepo] =+  withUMaskFlag (umask ? opts) $ withNewDirectory outrepo $ do+    EmptyRepository _repo <- createRepository+      (patchFormat ? opts)+      (withWorkingDir ? opts)+      (patchIndexNo ? opts)+      (useCache ? opts)+      (O.withPrefsTemplates ? opts)+    -- TODO implement --dry-run, which would be read-only?+    _repo <- revertRepositoryChanges _repo+    marks <-+      fastImport' _repo (O.diffAlgorithm ? opts) emptyMarks+    cleanRepository _repo+    _repo <- finalizeRepositoryChanges _repo (O.dryRun ? opts)+    createPristineDirectoryTree _repo "." (withWorkingDir ? opts)+    return marks+fastImport _ _ _ = fail "I need exactly one output repository."++fastImport' :: forall p wU wR . (RepoPatch p, ApplyState p ~ Tree)+            => Repository 'RW p wU wR+            -> O.DiffAlgorithm+            -> Marks+            -> IO ()+fastImport' repo diffalg marks = do+    pristine <- readPristine repo+    marksref <- newIORef marks+    let initial = Toplevel Nothing $ BC.pack "refs/branches/master"++        go :: State p -> B.ByteString -> TreeIO ()+        go state rest = do (rest', item) <- parseObject rest+                           state' <- process state item+                           case state' of+                             Done -> return ()+                             _ -> go state' rest'++        -- sort marks into buckets, since there can be a *lot* of them+        markpath :: Int -> AnchoredPath+        markpath n = unsafeFloatPath (darcsdir </> "marks")+                        `appendPath` (either error id $ makeName $ show (n `div` 1000))+                        `appendPath` (either error id $ makeName $ show (n `mod` 1000))++        makeinfo author message tag = do+          let (name, log) = case unpackPSFromUTF8 message of+                                      "" -> ("Unnamed patch", [])+                                      msg -> (headErr &&& tailErr) . lines $ msg+              (author'', date'') = span (/='>') $ unpackPSFromUTF8 author+              date' = dropWhile (`notElem` ("0123456789" :: String)) date''+              author' = author'' ++ ">"+              date = formatDateTime "%Y%m%d%H%M%S" $ fromMaybe startOfTime (parseDateTime "%s %z" date')+          liftIO $ patchinfo date (if tag then "TAG " ++ name else name) author' log++        addtag author msg =+          do info_ <- makeinfo author msg True+             gotany <- liftIO $ doesFileExist tentativePristinePath+             deps <- if gotany then liftIO $ getUncovered `fmap` readPatches repo+                               else return []+             let patch :: Named p wA wA+                 patch = NamedP info_ deps NilFL+             liftIO $+                 addToTentativeInventory (repoCache repo) (n2pia patch)++        -- processing items++        -- ugly procedure that does too many things at once:+        -- * it modifies the tree in the state by adding missing hashes+        --   but only for blobs and excluding anything under _darcs+        -- * it also returns the resulting tree with _darcs filtered out+        updateHashes = do+          let nodarcs = \(AnchoredPath xs) _ -> headErr xs /= darcsdirName+              hashblobs (File blob@(T.Blob con Nothing)) =+                do hash <- sha256 `fmap` readBlob blob+                   return $ File (T.Blob con (Just hash))+              hashblobs x = return x+          tree' <- liftIO . T.partiallyUpdateTree hashblobs nodarcs =<< gets tree+          modify $ \s -> s { tree = tree' }+          return $ T.filter nodarcs tree'++        -- Since git doesn't track directores it implicitly deletes+        -- them when they become empty. We should therefore remove any+        -- directories that become empty (except the repo-root+        -- directory!)+        deleteEmptyParents fp =+          case parent fp of+            Nothing -> return ()+            Just directParent -> do+              parentTree <- flip findTree directParent <$> gets tree+              case (null . listImmediate) <$> parentTree of+                      Just True -> do TM.unlink directParent+                                      deleteEmptyParents directParent+                      -- Either missing (not possible) or non-empty.+                      _ -> return ()++        -- generate Hunk primitive patches from diffing+        diffCurrent :: State p -> TreeIO (State p)+        diffCurrent (InCommit mark ancestors branch start ps info_) = do+          current <- updateHashes+          Sealed diff <- unFreeLeft `fmap`+             liftIO (treeDiff diffalg (const TextFile) start current)+          let newps = ps +<<+ diff+          return $ InCommit mark ancestors branch current newps info_+        diffCurrent _ = error "This is never valid outside of a commit."++        process :: State p -> Object -> TreeIO (State p)+        process s (Progress p) = do+          liftIO $ putStrLn ("progress " ++ decodeLocale p)+          return s++        process (Toplevel _ _) End = do+          tree' <- (liftIO . darcsAddMissingHashes) =<< updateHashes+          modify $ \s -> s { tree = tree' } -- lets dump the right tree, without _darcs+          let root =+                case treeHash tree' of+                  Nothing -> error "tree has no hash!"+                  Just hash -> encodeBase16 hash+          liftIO $ do+            putStrLn "\\o/ It seems we survived. Enjoy your new repo."+            B.writeFile tentativePristinePath $ BC.concat [BC.pack "pristine:", root]+          return Done++        process (Toplevel n b) (Tag tag what author msg) = do+          if Just what == n+             then addtag author msg+             else liftIO $ putStrLn $+                    "WARNING: Ignoring out-of-order tag " ++ decodeLocale tag+          return (Toplevel n b)++        process (Toplevel n _) (Reset branch from) =+          do case from of+               (Just (MarkId k)) | Just k == n ->+                 addtag (BC.pack "Anonymous Tagger <> 0 +0000") branch+               _ -> liftIO $ putStrLn $ "WARNING: Ignoring out-of-order tag " +++                                        decodeLocale branch+             return $ Toplevel n branch++        process (Toplevel n b) (Blob (Just m) bits) = do+          TM.writeFile (markpath m) (BLC.fromChunks [bits])+          return $ Toplevel n b++        process x (Gitlink link) = do+          liftIO $ putStrLn $ "WARNING: Ignoring gitlink " ++ decodeLocale link+          return x++        process (Toplevel previous pbranch) (Commit branch mark author message) = do+          when (pbranch /= branch) $ do+            liftIO $ putStrLn ("Tagging branch: " ++ decodeLocale pbranch)+            addtag author pbranch+          info_ <- makeinfo author message False+          startstate <- updateHashes+          return $ InCommit mark (previous, []) branch startstate NilRL info_++        process s@InCommit {} (Modify (Left m) path) = do+          TM.copy (markpath m) (decodePath path)+          diffCurrent s++        process s@InCommit {} (Modify (Right bits) path) = do+          TM.writeFile (decodePath path) (BLC.fromChunks [bits])+          diffCurrent s++        process s@InCommit {} (Delete path) = do+          let floatedPath = decodePath path+          TM.unlink floatedPath+          deleteEmptyParents floatedPath+          diffCurrent s++        process (InCommit mark (prev, current) branch start ps info_) (From from) =+          return $ InCommit mark (prev, from:current) branch start ps info_++        process (InCommit mark (prev, current) branch start ps info_) (Merge from) =+          return $ InCommit mark (prev, from:current) branch start ps info_++        process s@InCommit {} (Copy names) = do+            (from, to) <- extractNames names+            TM.copy (decodePath from) (decodePath to)+            -- We can't tell Darcs that a file has been copied, so it'll+            -- show as an addfile.+            diffCurrent s++        process s@(InCommit mark ancestors branch start _ info_) (Rename names) = do+          (from, to) <- extractNames names+          let uFrom = decodePath from+              uTo = decodePath to+          case parent uTo of+            Nothing ->+              -- no parents i.e. target is root => nothing to do+              return ()+            Just parentDir -> do+              targetDirExists <- liftIO $ treeHasDir start uTo+              targetFileExists <- liftIO $ treeHasFile start uTo+              parentDirExists <-+                  liftIO $ treeHasDir start parentDir+              -- If the target exists, remove it; if it doesn't, add all+              -- its parent directories.+              if targetDirExists || targetFileExists+                  then TM.unlink uTo+                  else unless parentDirExists $ TM.createDirectory parentDir+          (InCommit _ _ _ _ newPs _) <- diffCurrent s+          TM.rename uFrom uTo+          let ps' = newPs :<: move uFrom uTo+          current <- updateHashes+          -- ensure empty dirs get deleted+          deleteEmptyParents uFrom+          -- run diffCurrent to add the dir deletions prims+          diffCurrent (InCommit mark ancestors branch current ps' info_)++        -- When we leave the commit, create a patch for the cumulated+        -- prims.+        process (InCommit mark ancestors branch _ ps info_) x = do+          case ancestors of+            (_, []) -> return () -- OK, previous commit is the ancestor+            (Just n, list)+              | n `elem` list -> return () -- OK, we base off one of the ancestors+              | otherwise -> liftIO $ putStrLn $+                               "WARNING: Linearising non-linear ancestry:" +++                               " currently at " ++ show n ++ ", ancestors " ++ show list+            (Nothing, list) ->+              liftIO $ putStrLn $ "WARNING: Linearising non-linear ancestry " ++ show list++          {- current <- updateHashes -} -- why not?+          (prims :: FL (PrimOf p) cX cY) <-+            return $ canonizeFL diffalg $ reverseRL ps+          let patch :: Named p cX cY+              patch = infopatch info_ prims+          liftIO $+              addToTentativeInventory (repoCache repo) (n2pia patch)+          case mark of+            Nothing -> return ()+            Just n -> case getMark marks n of+              Nothing -> liftIO $ modifyIORef marksref $ \m -> addMark m n (patchHash $ n2pia patch)+              Just n' -> fail $ "FATAL: Mark already exists: " ++ decodeLocale n'+          process (Toplevel mark branch) x++        process state obj = do+          liftIO $ print obj+          fail $ "Unexpected object in state " ++ show state++        extractNames :: CopyRenameNames+                     -> TreeIO (BC.ByteString, BC.ByteString)+        extractNames names = case names of+            Quoted f t -> return (f, t)+            Unquoted uqNames -> do+                let spaceIndices = BC.elemIndices ' ' uqNames+                    splitStr = second (BC.drop 1) . flip BC.splitAt uqNames+                -- Reverse the components, so we find the longest+                -- prefix existing name.+                case reverse $ map splitStr spaceIndices of+                    [component] -> return component+                    spaceComponents -> do+                        let dieMessage = unwords+                                [ "Couldn't determine move/rename"+                                , "source/destination filenames, with the"+                                , "data produced by this (old) version of"+                                , "git, since it uses unquoted, but"+                                , "special-character-containing paths."+                                ]+                            lPathExists (l,_) =+                                TM.fileExists $ decodePath l+                            finder [] = error dieMessage+                            finder (x : rest) = do+                                xExists <- lPathExists x+                                if xExists then return x else finder rest+                        finder spaceComponents++    void $ hashedTreeIO (go initial B.empty) pristine (repoCache repo)++parseObject :: BC.ByteString -> TreeIO ( BC.ByteString, Object )+parseObject = next' mbObject+  where mbObject = A.parse p_maybeObject++        p_maybeObject = Just `fmap` p_object+                        <|> (A.endOfInput >> return Nothing)++        lex p = p >>= \x -> A.skipSpace >> return x+        lexString s = A.string (BC.pack s) >> A.skipSpace+        line = lex $ A.takeWhile (/='\n')++        optional p = Just `fmap` p <|> return Nothing++        p_object = p_blob+                   <|> p_reset+                   <|> p_commit+                   <|> p_tag+                   <|> p_modify+                   <|> p_rename+                   <|> p_copy+                   <|> p_from+                   <|> p_merge+                   <|> p_delete+                   <|> (lexString "progress" >> Progress `fmap` line)++        p_author name = lexString name >> line++        p_reset = do lexString "reset"+                     branch <- line+                     refid <- optional $ lexString "from" >> p_refid+                     return $ Reset branch refid++        p_commit = do lexString "commit"+                      branch <- line+                      mark <- optional p_mark+                      _ <- optional $ p_author "author"+                      committer <- p_author "committer"+                      message <- p_data+                      return $ Commit branch mark committer message++        p_tag = do _ <- lexString "tag"+                   tag <- line+                   lexString "from"+                   mark <- p_marked+                   author <- p_author "tagger"+                   message <- p_data+                   return $ Tag tag mark author message++        p_blob = do lexString "blob"+                    mark <- optional p_mark+                    Blob mark `fmap` p_data+                  <?> "p_blob"++        p_mark = do lexString "mark"+                    p_marked+                  <?> "p_mark"++        p_refid = MarkId `fmap` p_marked+                  <|> (lexString "inline" >> return Inline)+                  <|> HashId `fmap` p_hash++        p_data = do lexString "data"+                    len <- A.decimal+                    _ <- A.char '\n'+                    lex $ A.take len+                  <?> "p_data"++        p_marked = lex $ A.char ':' >> A.decimal+        p_hash = lex $ A.takeWhile1 (A.inClass "0123456789abcdefABCDEF")+        p_from = lexString "from" >> From `fmap` p_marked+        p_merge = lexString "merge" >> Merge `fmap` p_marked+        p_delete = lexString "D" >> Delete `fmap` p_maybeQuotedName+        p_rename = do lexString "R"+                      names <- p_maybeQuotedCopyRenameNames+                      return $ Rename names+        p_copy = do lexString "C"+                    names <- p_maybeQuotedCopyRenameNames+                    return $ Copy names+        p_modify = do lexString "M"+                      mode <- lex $ A.takeWhile (A.inClass "01234567890")+                      mark <- p_refid+                      path <- p_maybeQuotedName+                      case mark of+                        HashId hash | mode == BC.pack "160000" -> return $ Gitlink hash+                                    | otherwise -> fail ":(("+                        MarkId n -> return $ Modify (Left n) path+                        Inline -> do bits <- p_data+                                     return $ Modify (Right bits) path+        p_maybeQuotedCopyRenameNames =+            p_lexTwoQuotedNames <|> Unquoted `fmap` line+        p_lexTwoQuotedNames = do+            n1 <- lex p_quotedName+            n2 <- lex p_quotedName+            return $ Quoted n1 n2+        p_maybeQuotedName = lex (p_quotedName <|> line)+        p_quotedName = do+          _ <- A.char '"'+          bytes <- many (p_escaped <|> p_unescaped)+          _ <- A.char '"'+          return $ B.concat bytes+        p_unescaped = A.takeWhile1 (\c->c/='"' && c/='\\')+        p_escaped = do+          _ <- A.char '\\'+          p_escaped_octal <|> p_escaped_char+        p_escaped_octal = do+          let octals :: [Char]+              octals = "01234567"+          s <- A.takeWhile1 (`elem` octals)+          let x :: Word8+              x = read ("0o" ++ BC.unpack s)+          return $ B.singleton $ fromIntegral x+        p_escaped_char =+          fmap BC.singleton $+          '\r' <$ A.char 'r' <|> '\n' <$ A.char 'n' <|> A.char '"' <|> A.char '\\'++        next' :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)+        next' parser rest =+          do chunk <- if B.null rest then liftIO $ B.hGet stdin (64 * 1024)+                                     else return rest+             next_chunk parser chunk++        next_chunk :: (B.ByteString -> A.Result (Maybe Object)) -> B.ByteString -> TreeIO (B.ByteString, Object)+        next_chunk parser chunk =+          case parser chunk of+             A.Done rest result -> return (rest, maybe End id result) -- not sure about the maybe+             A.Partial cont -> next' cont B.empty+             A.Fail _ ctx err -> do+               liftIO $ putStrLn $ "=== chunk ===\n" ++ decodeLocale chunk ++ "\n=== end chunk ===="+               fail $ "Error parsing stream. " ++ err ++ "\nContext: " ++ show ctx++decodePath :: BC.ByteString -> AnchoredPath+decodePath = unsafeFloatPath . decodeLocale
+ src/Darcs/UI/Commands/Convert/Util.hs view
@@ -0,0 +1,70 @@+module Darcs.UI.Commands.Convert.Util+    ( Marks+    , emptyMarks+    , addMark+    , getMark+    , lastMark+    , readMarks+    , writeMarks+    -- misc+    , patchHash+    , updatePending+    ) where++import Darcs.Prelude++import Darcs.Util.Exception ( catchall )++import qualified Data.ByteString.Char8 as BC+import qualified Data.IntMap as M++import System.Directory ( removeFile )++import Darcs.Patch.Info ( makePatchname )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info )++import Darcs.Repository.Flags ( UpdatePending(..) )+import Darcs.UI.Options ( (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Flags ( DarcsFlag )++-- marks support++type Marks = M.IntMap BC.ByteString++emptyMarks :: Marks+emptyMarks = M.empty++lastMark :: Marks -> Int+lastMark m = if M.null m then 0 else fst $ M.findMax m++getMark :: Marks -> Int -> Maybe BC.ByteString+getMark marks key = M.lookup key marks++addMark :: Marks -> Int -> BC.ByteString -> Marks+addMark marks key value = M.insert key value marks++readMarks :: FilePath -> IO Marks+readMarks p = do lines' <- BC.split '\n' `fmap` BC.readFile p+                 return $ foldl merge M.empty lines'+               `catchall` return emptyMarks+  where merge set line = case BC.split ':' line of+          [i, hash] -> M.insert (read $ BC.unpack i) (BC.dropWhile (== ' ') hash) set+          _ -> set -- ignore, although it is maybe not such a great idea...++writeMarks :: FilePath -> Marks -> IO ()+writeMarks fp m = do removeFile fp `catchall` return () -- unlink+                     BC.writeFile fp marks+  where marks = BC.concat $ map format $ M.assocs m+        format (k, s) = BC.concat [BC.pack $ show k, BC.pack ": ", s, BC.pack "\n"]++-- misc shared functions++patchHash :: PatchInfoAnd p cX cY -> BC.ByteString+patchHash p = BC.pack $ show $ makePatchname (info p)++updatePending :: [DarcsFlag] -> UpdatePending+updatePending opts =+  case O.withWorkingDir ? opts of+    O.WithWorkingDir -> YesUpdatePending+    O.NoWorkingDir -> NoUpdatePending
+ src/Darcs/UI/Commands/Diff.hs view
@@ -0,0 +1,274 @@+--  Copyright (C) 2003-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Diff ( diffCommand ) where++import Darcs.Prelude hiding ( all )++import Control.Monad ( unless, when )+import Data.Maybe ( fromMaybe )+import Data.Maybe ( isJust )+import System.Directory ( createDirectory, findExecutable, withCurrentDirectory )+import System.FilePath.Posix ( takeFileName, (</>) )+import System.IO ( hFlush, stdout )++import Darcs.Patch ( listTouchedFiles )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Depends ( findCommonWithThem )+import Darcs.Patch.Info ( displayPatchInfo )+import Darcs.Patch.Match ( matchFirstPatchset, matchSecondPatchset, secondMatch )+import Darcs.Patch.Named ( anonymous )+import Darcs.Patch.PatchInfoAnd ( info, n2pia )+import Darcs.Patch.Set ( patchSetSnoc )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), mapFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )+import Darcs.Repository ( RepoJob(..), readPatches, withRepository )+import Darcs.Repository.State+    ( applyTreeFilter+    , readPristine+    , restrictSubpaths+    , unrecordedChanges+    )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , nodefaults+    , withStdOpts+    )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.UI.External ( diffProgram )+import Darcs.UI.Flags ( DarcsFlag, diffingOpts, pathSetFromArgs, useCache, wantGuiPause )+import Darcs.UI.Options ( parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Cache ( mkDirCache )+import Darcs.Util.CommandLine ( parseCmd )+import Darcs.Util.Exec ( execInteractive )+import Darcs.Util.Global ( debugMessage )+import Darcs.Util.Lock ( withTempDir )+import Darcs.Util.Path ( AbsolutePath, AnchoredPath, isPrefix, toFilePath )+import Darcs.Util.Printer ( Doc, putDocLn, text, vcat )+import Darcs.Util.Prompt ( askEnter )+import Darcs.Util.Tree.Hashed ( hashedTreeIO, writeDarcsHashed )+import Darcs.Util.Tree.Plain ( writePlainTree )+import Darcs.Util.Workaround ( getCurrentDirectory )++diffDescription :: String+diffDescription = "Create a diff between two versions of the repository."++diffHelp :: Doc+diffHelp = text $+ "The `darcs diff` command compares two versions of the working tree of\n" +++ "the current repository.  Without options, the pristine (recorded) and\n" +++ "unrecorded working trees are compared.  This is lower-level than\n" +++ "the `darcs whatsnew` command, since it outputs a line-by-line diff,\n" +++ "and it is also slower.  As with `darcs whatsnew`, if you specify\n" +++ "files or directories, changes to other files are not listed.\n" +++ "The command always uses an external diff utility.\n" +++ "\n" +++ "With the `--patch` option, the comparison will be made between working\n" +++ "trees with and without that patch.  Patches *after* the selected patch\n" +++ "are not present in either of the compared working trees.  The\n" +++ "`--from-patch` and `--to-patch` options allow the set of patches in the\n" +++ "`old' and `new' working trees to be specified separately.\n" +++ "\n" +++ "The associated tag and match options are also understood, e.g. `darcs\n" +++ "diff --from-tag 1.0 --to-tag 1.1`.  All these options assume an\n" +++ "ordering of the patch set, so results may be affected by operations\n" +++ "such as `darcs optimize reorder`.\n" +++ "\n" +++ "diff(1) is always called with the arguments `-rN` and by default also\n" +++ "with `-u` to show the differences in unified format. This can be turned\n" +++ "off by passing `--no-unified`. An additional argument can be passed\n" +++ "using `--diff-opts`, such as `--diff-opts=-ud` or `--diff-opts=-wU9`.\n" +++ "\n" +++ "The `--diff-command` option can be used to specify an alternative\n" +++ "utility. Arguments may be included, separated by whitespace.  The value\n" +++ "is not interpreted by a shell, so shell constructs cannot be used.  The\n" +++ "arguments %1 and %2 MUST be included, these are substituted for the two\n" +++ "working trees being compared. For instance:\n" +++ "\n" +++ "    darcs diff -p . --diff-command \"meld %1 %2\"\n" +++ "\n" +++ "If this option is used, `--diff-opts` is ignored.\n"++diffCommand :: DarcsCommand+diffCommand = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "diff"+    , commandHelp = diffHelp+    , commandDescription = diffDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+    , commandCommand = diffCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = knownFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = withStdOpts diffBasicOpts diffAdvancedOpts+    }+  where+    diffBasicOpts+      = O.matchOneOrRange+      ^ O.extDiff+      ^ O.lookforadds+      ^ O.lookformoves+      ^ O.repoDir+      ^ O.storeInMemory+    diffAdvancedOpts = O.pauseForGui++diffCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+diffCmd fps opts args+  | not (null (O.matchLast ? opts)) &&+      not (null (O.matchFrom ? opts)) =+        fail $ "using --patch and --last at the same time with the 'diff'" +++          " command doesn't make sense. Use --from-patch to create a diff" +++          " from this patch to the present, or use just '--patch' to view" +++          " this specific patch."+  | otherwise = doDiff opts =<< pathSetFromArgs fps args++doDiff :: [DarcsFlag] -> Maybe [AnchoredPath] ->  IO ()+doDiff opts mpaths = withRepository (useCache ? opts) $ RepoJob $ \repository -> do+  patchset <- readPatches repository+  debugMessage "After readPatches"+  -- We pass @mpaths@ here which means we get only the changes that affect the+  -- given paths (if any).+  unrecorded <- unrecordedChanges (diffingOpts opts) repository mpaths+  debugMessage "After getting the unrecorded changes"+  -- Use of 'anonymous' is unproblematic here as we don't store any patches.+  -- But we must take care not to show its fake patch info to the user.+  unrecorded' <- n2pia `fmap` anonymous unrecorded++  let matchFlags = parseFlags O.matchOneOrRange opts++  -- If no secondMatch (--to-xxx) is specified, include unrecorded changes+  Sealed all <- return $+    if secondMatch matchFlags+      then seal patchset+      else seal $ patchSetSnoc patchset unrecorded'+  -- Note how this differs from how firstMatch defaults for log command+  Sealed ctx <- return $+    fromMaybe (seal patchset) $ matchFirstPatchset matchFlags patchset+  Sealed match <- return $+    fromMaybe (seal all) $ matchSecondPatchset matchFlags patchset++  _ :> todiff <- return $ findCommonWithThem match ctx+  _ :> tounapply <- return $ findCommonWithThem all match++  Sealed logmatch <- return $+    if secondMatch matchFlags+      then seal match+      else seal patchset+  -- Same as @todiff@ but without trailing @unrecorded'@ changes+  _ :> tolog <- return $ findCommonWithThem logmatch ctx++  let touched = listTouchedFiles todiff+      files = case mpaths of+               Nothing -> touched+               Just paths ->+                  concatMap (\path -> filter (isPrefix path) touched) paths+  relevant <- restrictSubpaths repository files++  formerdir <- getCurrentDirectory+  let thename = takeFileName formerdir+  withTempDir "darcs-diff" $ \tmpdir -> do+      getCurrentDirectory >>= debugMessage . ("doDiff: I am now in "++)+      let tdir = toFilePath tmpdir+      let odir = tdir </> ("old-"++thename)+      createDirectory odir+      let ndir = tdir </> ("new-"++thename)+      createDirectory ndir++      -- Prepare the (plain) trees we want to compare. Since we need to access+      -- our repository, we have to restore the working directory.+      withCurrentDirectory formerdir $ do+        -- Make sure we have at least one writable cache entry+        -- to serve as our storage for hashed 'Tree' items+        -- during the 'apply' and 'unapply' operations below.+        let cache = mkDirCache tdir+        pristine <- readPristine repository+        -- fill our temporary cache+        _ <- writeDarcsHashed pristine cache++        -- @base@ will be like our working tree, /except/ that it contains only+        -- the unrecorded changes that affect the given file paths, see comment+        -- above when we called 'unrecordedChanges'.+        base <- if secondMatch matchFlags+                 then return pristine+                 else snd <$> hashedTreeIO (apply unrecorded') pristine cache++        newtree <- snd <$> hashedTreeIO (unapply tounapply) base cache+        -- @todiff@ may have our @unrecorded'@ changes as its last element. If+        -- we used our full working tree as @base@, then we would now unapply+        -- filtered changes from an unfiltered 'Tree', so the result would be+        -- the pristine Tree with the filtered-out unrecorded changes /still+        -- applied/. Unapplying the (unfiltered) recorded changes that touch+        -- paths that we filtered out would then fail (issue2639).+        -- We cannot use 'readUnrecorded' and pass it @mpaths@ because that+        -- would filter the whole Tree, so again unapplying recorded changes+        -- that touch irrelevant paths would fail.+        -- A valid alternative solution would be to not pre-filter unrecorded+        -- changes at all, since we filter the resulting Trees anyway (see+        -- below). But that may be less efficient if there are many unrecorded+        -- changes but we are interested in just a small subset of the affected+        -- paths.+        oldtree <- snd <$> hashedTreeIO (unapply todiff) newtree cache++        writePlainTree (applyTreeFilter relevant oldtree) (toFilePath odir)+        writePlainTree (applyTreeFilter relevant newtree) (toFilePath ndir)+        -- Display patch info for (only) the recorded patches that we diff+        putDocLn $ vcat $ map displayPatchInfo $ reverse $ mapFL info tolog+        hFlush stdout++      -- Call the external diff program. Note we are now back in our+      -- temporary directory.+      cmd <- diffProgram+      let old = takeFileName $ toFilePath odir+          new = takeFileName $ toFilePath ndir+      case getDiffCmdAndArgs cmd opts old new of+        Left err -> fail err+        Right (d_cmd, d_args) -> do+          cmdExists <- findExecutable d_cmd+          unless (isJust cmdExists) $+            fail $ d_cmd ++ " is not an executable in --diff-command"+          let pausingForGui = (wantGuiPause opts == O.YesWantGuiPause)+              cmdline = unwords (d_cmd : d_args)+          when pausingForGui $ putStrLn $ "Running command '" ++ cmdline ++ "'"+          _ <- execInteractive cmdline Nothing+          when pausingForGui $ askEnter "Hit return to move on..."++-- | Returns the command we should use for diff as a tuple (command, arguments).+-- This will either be whatever the user specified via --diff-command  or the+-- default 'diffProgram'.  Note that this potentially involves parsing the+-- user's diff-command, hence the possibility for failure.+getDiffCmdAndArgs :: String -> [DarcsFlag] -> String -> String+                  -> Either String (String, [String])+getDiffCmdAndArgs cmd opts f1 f2 = helper (O.extDiff ? opts) where+  helper extDiff =+    case O.diffCmd extDiff of+      Just c ->+        case parseCmd [ ('1', f1) , ('2', f2) ] c of+          Left err      -> Left $ show err+          Right ([],_)  -> error "parseCmd should never return empty list"+          Right (cmd':args,_)+            | length (filter (== f1) args) == 1+            , length (filter (== f2) args) == 1 -> Right (cmd',args)+            | otherwise -> Left $ "Invalid argument (%1 or %2) in --diff-command"+      Nothing -> -- if no command specified, use 'diff'+        Right (cmd, "-rN":getDiffOpts extDiff++[f1,f2])++getDiffOpts :: O.ExternalDiff -> [String]+getDiffOpts O.ExternalDiff {O.diffOptions=os,O.diffUnified=u} = addUnified os where+  addUnified = if u then ("-u":) else id
+ src/Darcs/UI/Commands/Dist.hs view
@@ -0,0 +1,200 @@+--  Copyright (C) 2003 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++-- |+-- Module      : Darcs.UI.Commands.Dist+-- Copyright   : 2003 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.UI.Commands.Dist+    (+      dist+    , doFastZip -- libdarcs export+    , doFastZip'+    ) where++import Darcs.Prelude++import Control.Monad ( forM, unless, when )+import System.Process ( system )+import System.Exit ( ExitCode(..), exitWith )+import System.FilePath.Posix ( takeFileName, (</>) )++import Darcs.Util.Workaround ( getCurrentDirectory )+import qualified Codec.Archive.Tar as Tar+import qualified Codec.Archive.Tar.Entry as Tar+import Codec.Compression.GZip ( compress )++import qualified Codec.Archive.Zip as Zip+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BLC+import Darcs.UI.Flags as F ( DarcsFlag, useCache )+import Darcs.UI.Options ( oid, parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O++import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository+    , putVerbose, putInfo+    )+import Darcs.UI.Completion ( noArgs )+import Darcs.Util.Lock ( withDelayedDir )+import Darcs.Patch.Match ( patchSetMatch )+import Darcs.Repository.Match ( getPristineUpToMatch )+import Darcs.Repository ( RepoJob(..), withRepository, withRepositoryLocation )+import Darcs.Repository.Prefs ( getPrefval )+import Darcs.Repository.Pristine ( readPristine )++import Darcs.Util.DateTime ( getCurrentTime, toSeconds )+import Darcs.Util.Path ( AbsolutePath, realPath, toFilePath )+import Darcs.Util.Printer ( Doc, text, vcat )+import qualified Darcs.Util.Tree as T+import Darcs.Util.Tree.Plain ( readPlainTree, writePlainTree )+++distDescription :: String+distDescription = "Create a distribution archive."++distHelp :: Doc+distHelp = text $ unlines+  [ "`darcs dist` creates a compressed archive in the repository's root"+  , "directory, containing the recorded state of the working tree"+  , "(unrecorded changes and the `_darcs` directory are excluded)."+  , "The command accepts matchers to create an archive of some past"+  , "repository state, for instance `--tag`."+  , ""+  , "By default, the archive (and the top-level directory within the"+  , "archive) has the same name as the repository, but this can be"+  , "overridden with the `--dist-name` option."+  , ""+  , "If a predist command is set (see `darcs setpref`), that command will"+  , "be run on the recorded state prior to archiving.  For example,"+  , "autotools projects would set it to `autoconf && automake`."+  , ""+  , "If `--zip` is used, matchers and the predist command are ignored."+  ]++dist :: DarcsCommand+dist = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "dist"+    , commandHelp = distHelp+    , commandDescription = distDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = distCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = distOpts+    }+  where+    distBasicOpts+      = O.distname+      ^ O.distzip+      ^ O.repoDir+      ^ O.matchUpToOne+      ^ O.setScriptsExecutable+      ^ O.storeInMemory+    distOpts = distBasicOpts `withStdOpts` oid++distCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+distCmd _ opts _ | O.distzip ? opts = doFastZip opts+distCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $ \repository -> do+  let matchFlags = parseFlags O.matchUpToOne opts+  formerdir <- getCurrentDirectory+  let distname = getDistName formerdir (O.distname ? opts)+  predist <- getPrefval "predist"+  let resultfile = formerdir </> distname ++ ".tar.gz"+  raw_tree <-+    case patchSetMatch matchFlags of+      Just psm -> getPristineUpToMatch repository psm+      Nothing -> readPristine repository+  tree <- case predist of+    Nothing -> T.expand raw_tree+    Just pd -> do+      withDelayedDir "dist" $ \d -> do+        writePlainTree raw_tree "."+        ec <- system pd+        unless (ec == ExitSuccess) $ do+          putStrLn "Dist aborted due to predist failure"+          exitWith ec+        T.expand =<< readPlainTree (toFilePath d)+  entries <- createEntries distname tree+  putVerbose opts $ vcat $ map (text . Tar.entryPath) entries+  BL.writeFile resultfile $ compress $ Tar.write entries+  putInfo opts $ text $ "Created dist as " ++ resultfile+  where+    createEntries top tree = do+      topentry <- Tar.directoryEntry <$> either fail return (Tar.toTarPath True top)+      rest <- forM (T.list tree) go+      return $ topentry : rest+      where+        go (_, T.Stub _ _) = error "impossible"+        go (path, T.SubTree _) = do+          tarpath <- either fail return $ Tar.toTarPath True (top </> realPath path)+          return $ Tar.directoryEntry tarpath+        go (path, T.File b) = do+          content <- T.readBlob b+          tarpath <- either fail return $ Tar.toTarPath False (top </> realPath path)+          let entry = Tar.fileEntry tarpath content+          return $+            if O.yes (O.setScriptsExecutable ? opts) &&+               executablePrefix `BL.isPrefixOf` content+              then entry {Tar.entryPermissions = Tar.executableFilePermissions}+              else entry+    executablePrefix = BLC.pack "#!"++getDistName :: FilePath -> Maybe String -> FilePath+getDistName _ (Just dn) = takeFileName dn+getDistName currentDirectory _ = takeFileName currentDirectory++doFastZip :: [DarcsFlag] -> IO ()+doFastZip opts = do+  currentdir <- getCurrentDirectory+  let distname = getDistName currentdir (O.distname ? opts)+  let resultfile = currentdir </> distname ++ ".zip"+  doFastZip' opts currentdir (BL.writeFile resultfile)+  putInfo opts $ text $ "Created " ++ resultfile++doFastZip' :: [DarcsFlag]              -- ^ Flags/options+           -> FilePath                 -- ^ The path to the repository+           -> (BL.ByteString -> IO a)  -- ^ An action to perform on the archive contents+           -> IO a+doFastZip' opts path act = withRepositoryLocation (useCache ? opts) path $ RepoJob $ \repo -> do+  when (O.setScriptsExecutable ? opts == O.YesSetScriptsExecutable) $+    putStrLn "WARNING: Zip archives cannot store executable flag."  +  let distname = getDistName path (O.distname ? opts)+  pristine <-+    T.expand =<<+    case patchSetMatch (O.matchUpToOne ? opts) of+      Just psm -> getPristineUpToMatch repo psm+      Nothing -> readPristine repo+  pathsAndContents <-+    forM (T.list pristine) $ \(p,i) -> do+      case i of+        T.Stub _ _ -> error "tree is not expanded"+        T.SubTree _ -> return (distname </> realPath p ++ "/", BL.empty)+        T.File b -> do+          content <- T.readBlob b+          return (distname </> realPath p, content)+  epochtime <- toSeconds `fmap` getCurrentTime+  let entries = [ Zip.toEntry filepath epochtime contents | (filepath,contents) <- pathsAndContents ]+  let archive = foldr Zip.addEntryToArchive Zip.emptyArchive entries+  act (Zip.fromArchive archive)
+ src/Darcs/UI/Commands/GZCRCs.hs view
@@ -0,0 +1,195 @@+--  Copyright (C) 2009 Ganesh Sittampalam+--+-- 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+-- SOFTWARE.++module Darcs.UI.Commands.GZCRCs+    ( gzcrcs+    , doCRCWarnings+    ) where++import Darcs.Prelude++import Control.Monad ( when, unless, forM_ )+import Control.Monad.Trans ( liftIO )+import Control.Monad.Writer ( runWriterT, tell )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.IORef ( newIORef, readIORef, writeIORef )+import Data.Monoid ( Any(..), Sum(..) )+import System.Directory ( doesFileExist, doesDirectoryExist )+import System.Exit ( ExitCode(..), exitWith )+import System.IO ( stderr )+import Darcs.Util.File ( getRecursiveContentsFullPath )+import Darcs.Util.ByteString ( isGZFile, gzDecompress )+import Darcs.Util.Global ( getCRCWarnings, resetCRCWarnings )+import Darcs.Repository ( Repository, withRepository, RepoJob(..), repoCache )+-- This command needs access beyond the normal repository APIs (to+-- get at the caches and inspect them directly)+-- Could move the relevant code into Darcs.Repository modules+-- but it doesn't really seem worth it.+import Darcs.Util.Cache+    ( allHashedDirs+    , cacheEntries+    , hashedFilePath+    , isThisRepo+    , writable+    )+import Darcs.Util.Lock ( gzWriteAtomicFilePSs )+import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository+    , putInfo, putVerbose+    )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Options ( (^), oid, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path ( AbsolutePath )+import Darcs.UI.Flags ( DarcsFlag, useCache )+import Darcs.Util.Printer ( Doc, ($$), formatText, hPutDocLn, pathlist, text )++gzcrcsHelp :: Doc+gzcrcsHelp = formatText 80+    [ "Versions of darcs >=1.0.4 and <2.2.0 had a bug that caused compressed "+      ++ "files with bad CRCs (but valid data) to be written out. CRCs were "+      ++ "not checked on reading, so this bug wasn't noticed."+    , "This command inspects your repository for this corruption and "+      ++ "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 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 "+      ++ "it encounters any non-CRC corruption in compressed files."+    , "You may wish to also run 'darcs check --complete' before repairing the "+      ++ "corruption. This is not done automatically because it might result "+      ++ "in needing to fetch extra patches if the repository is lazy."+    , "If there are any other problems with your repository, you can still "+      ++ "repair the CRCs, but you are advised to first make a backup copy in "+      ++ "case the CRC errors are actually caused by bad data and the old "+      ++ "CRCs might be useful in recovering that data."+    , "If you were warned about CRC errors during an operation involving "+      ++ "another repository, then it is possible that the other repository "+      ++ "contains the corrupt CRCs, so you should arrange for that "+      ++ "repository to also be checked/repaired."+    ]++-- |This is designed for use in an atexit handler, e.g. in Darcs.RunCommand+doCRCWarnings :: Bool -> IO ()+doCRCWarnings verbose = do+    files <- getCRCWarnings+    resetCRCWarnings+    unless (null files) $ do+        hPutDocLn stderr . formatText 80 $+            [ "Warning: CRC errors found. These are probably harmless but "+              ++ "should be repaired. See 'darcs gzcrcs --help' for more "+              ++ "information."+            ]+        when verbose $+            hPutDocLn stderr $+                text "The following corrupt files were found:" $$ pathlist files++gzcrcsDescription :: String+gzcrcsDescription = "Check or repair the CRCs of compressed files in the "+                    ++ "repository."++gzcrcs :: DarcsCommand+gzcrcs = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "gzcrcs"+    , commandHelp = gzcrcsHelp+    , commandDescription = gzcrcsDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = gzcrcsCmd+    , commandPrereq = amInRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = gzcrcsOpts+    }+  where+    gzcrcsBasicOpts = O.gzcrcsActions ^ O.justThisRepo ^ O.repoDir+    gzcrcsOpts = gzcrcsBasicOpts `withStdOpts` oid++gzcrcsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+gzcrcsCmd _ opts _ =+  case O.gzcrcsActions ? opts of+    Nothing -> fail "You must specify --check or --repair for gzcrcs"+    Just action -> withRepository (useCache ? opts) (RepoJob (gzcrcs' action opts))++gzcrcs' :: O.GzcrcsAction -> [DarcsFlag] -> Repository rt p wU wR -> IO ()+gzcrcs' action opts repo = do+    -- Somewhat ugly IORef use here because it's convenient, would be nicer to+    -- pre-filter the list of locs to check and then decide whether to print+    -- the message up front.+    warnRelatedRepos <- newIORef $ not isJustThisRepo+    let locs = cacheEntries $ repoCache repo+    (_, Any checkFailed) <- runWriterT $ forM_ locs $ \loc ->+        unless (isJustThisRepo && not (isThisRepo loc)) $ do+            let isWritable = writable loc+            forM_ allHashedDirs $ \hdir -> do+                let dir = hashedFilePath loc hdir ""+                exists <- liftIO $ doesDirectoryExist dir+                when exists $ do+                    liftIO $ do+                        warn <- readIORef warnRelatedRepos+                        when (warn && not (isThisRepo loc)) $ do+                            writeIORef warnRelatedRepos False+                            putInfo opts $ text $+                                "Also checking related repos and caches; use "+                                ++ "--just-this-repo to disable.\n"+                                ++ "Checking " ++ dir+                                ++ (if isWritable then "" else " (readonly)")+                    files <- liftIO $ getRecursiveContentsFullPath dir+                    (_, Sum count) <- runWriterT $ forM_ files $ \file -> do+                        isfile <- liftIO $ doesFileExist file+                        when isfile $ do+                            gz <- liftIO $ isGZFile file+                            case gz of+                                Nothing -> return ()+                                Just len -> do+                                    contents <- liftIO $ B.readFile file+                                    let contentsbl = BL.fromChunks [contents]+                                        (uncompressed, isCorrupt) =+                                            gzDecompress (Just len) contentsbl+                                    when isCorrupt $ do+                                        -- Count of files in current directory+                                        tell (Sum 1)+                                        liftIO . putVerbose opts $ text $+                                            "Corrupt: " ++ file+                                        when (isWritable && shouldRepair) $+                                            doRepair file uncompressed+                    when (count > (0 :: Int)) $ do+                        liftIO . putInfo opts $ text $+                            "Found " ++ show count ++ " corrupt file"+                            ++ (if count > 1 then "s" else "")+                            ++ (if shouldRepair+                                    then if isWritable+                                            then " (repaired)"+                                            else " (not repaired)"+                                    else "")+                        -- Something corrupt somewhere+                        tell (Any True)+    when (action == O.GzcrcsCheck && checkFailed) $+        exitWith (ExitFailure 1)+  where+    shouldRepair = action == O.GzcrcsRepair+    isJustThisRepo = O.justThisRepo ? opts+    doRepair name contents = liftIO $ gzWriteAtomicFilePSs name contents
+ src/Darcs/UI/Commands/Help.hs view
@@ -0,0 +1,445 @@+--  Copyright (C) 2002-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.Help+    ( helpCmd+    , commandControlList+    , printVersion+    , listAvailableCommands+    ) where++import Darcs.Prelude++import Control.Arrow ( (***) )+import Data.Char ( isAlphaNum, toLower, toUpper )+import System.Directory ( withCurrentDirectory )+import System.FilePath.Posix ( (</>) )+import Data.Either ( partitionEithers )+import Data.List ( groupBy, intercalate, lookup, nub )+import System.Exit ( exitSuccess )+import Version ( version )++import Darcs.Patch.Match ( helpOnMatchers )+import Darcs.Repository.Prefs ( environmentHelpHome, prefsDirPath, prefsFilesHelp )++import Darcs.UI.Commands+    ( CommandArgs(..)+    , CommandControl(..)+    , DarcsCommand(..)+    , commandAlloptions+    , commandName+    , disambiguateCommands+    , extractCommands+    , getSubcommands+    , nodefaults+    , normalCommand+    , withStdOpts+    )+import Darcs.UI.External ( viewDoc )+import Darcs.UI.Flags ( DarcsFlag, environmentHelpEmail, environmentHelpSendmail )+import Darcs.UI.Options ( oid )+import Darcs.UI.Options.Markdown ( optionsMarkdown )+import qualified Darcs.UI.TheCommands as TheCommands+import Darcs.UI.Usage ( getCommandHelp, getSuperCommandHelp, subusage, usage )++import Darcs.Util.English ( andClauses )+import Darcs.Util.Lock+    ( environmentHelpKeepTmpdir+    , environmentHelpLocks+    , environmentHelpTmpdir+    )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer+    ( Doc+    , empty+    , formatWords+    , quoted+    , renderString+    , text+    , vcat+    , vsep+    , ($$)+    , ($+$)+    , (<+>)+    )+import Darcs.Util.Printer.Color+    ( environmentHelpColor+    , environmentHelpEscape+    , environmentHelpEscapeWhite+    )+import Darcs.Util.Ssh+    ( environmentHelpScp+    , environmentHelpSsh+    , environmentHelpSshPort+    )+import Darcs.Util.Workaround ( getCurrentDirectory )+++helpDescription :: String+helpDescription = "Display help about darcs and darcs commands."++helpHelp :: Doc+helpHelp = formatWords+  [ "Without arguments, `darcs help` prints a categorized list of darcs"+  , "commands and a short description of each one.  With an extra argument,"+  , "`darcs help foo` prints detailed help about the darcs command foo."+  ]++-- | Starting from a list of 'CommandControl's, unwrap one level+-- to get a list of command names together with their subcommands.+unwrapTree :: [CommandControl] -> [(String, [CommandControl])]+unwrapTree cs = [ (commandName c, getSubcommands c) | CommandData c <- cs ]++-- | Given a list of (normal) arguments to the help command, produce a list+-- of possible completions for the next (normal) argument.+completeArgs :: [String] -> [String]+completeArgs [] = map fst (unwrapTree commandControlList) ++ extraArgs where+  extraArgs = [ "patterns", "preferences", "environment", "manpage", "markdown" ]+completeArgs (arg:args) = exploreTree arg args commandControlList where+  exploreTree cmd cmds cs =+    case lookup cmd (unwrapTree cs) of+      Nothing -> []+      Just cs' -> case cmds of+        [] -> map fst (unwrapTree cs')+        sub:cmds' -> exploreTree sub cmds' cs'++help :: DarcsCommand+help = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "help"+    , commandHelp = helpHelp+    , commandDescription = helpDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[<DARCS_COMMAND> [DARCS_SUBCOMMAND]]  "]+    , commandCommand = \ x y z -> helpCmd x y z >> exitSuccess+    , commandPrereq = \_ -> return $ Right ()+    , commandCompleteArgs = \_ _ -> return . completeArgs+    , commandArgdefaults = nodefaults+    , commandOptions = withStdOpts oid oid+    }++helpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+helpCmd _ _ ["manpage"] = viewDoc manpage+helpCmd _ _ ["markdown"] = viewDoc $ vcat $ map text markdownLines+helpCmd _ _ ["patterns"] = viewDoc $ vcat $ map text helpOnMatchers+helpCmd _ _ ["preferences"] =+    viewDoc $ header $+$ vcat (map render prefsFilesHelp)+  where+    header = "Preference Files" $$+             "================"+    render (f, h) =+      let item = prefsDirPath </> f in+        text item $$ text (replicate (length item) '-') $$ text h+helpCmd _ _ ("environment":vs_) =+    viewDoc $ vsep (header : map render known) $+$ footer+  where+    header | null known = empty+           | otherwise = "Environment Variables" $$+                         "====================="++    footer | null unknown = empty+           | otherwise = text ("Unknown environment variables: "+                               ++ intercalate ", " unknown)++    render (ks, ds) = text (andClauses ks ++ ":") $$+                      vcat [ text ("  " ++ d) | d <- ds ]++    (unknown, known) = case map (map toUpper) vs_ of+                           [] -> ([], environmentHelp)+                           vs -> (nub *** (nub . concat)) . partitionEithers $+                                     map doLookup vs++    -- v is not known if it doesn't appear in the list of aliases of any+    -- of the environment var help descriptions.+    doLookup v = case filter ((v `elem`) . fst) environmentHelp of+                     [] -> Left v+                     es -> Right es++helpCmd _ _ [] = viewDoc $ usage commandControlList++helpCmd _ _ (cmd:args) =+    case disambiguateCommands commandControlList cmd args of+         Left err -> fail err+         Right (cmds,as) ->+             let msg = case cmds of+                         CommandOnly c       -> getCommandHelp Nothing c+                         SuperCommandOnly c  ->+                          if null as then+                            getSuperCommandHelp c+                          else+                            "Invalid subcommand!" $+$ subusage c+                         SuperCommandSub c s -> getCommandHelp (Just c) s+             in viewDoc $ msg++listAvailableCommands :: IO ()+listAvailableCommands =+    do here <- getCurrentDirectory+       is_valid <- mapM+                   (\c -> withCurrentDirectory here $ commandPrereq c [])+                   (extractCommands commandControlList)+       putStr $ unlines $ map (commandName . fst) $+                filter (isRight.snd) $+                zip (extractCommands commandControlList) is_valid+       putStrLn "--help"+       putStrLn "--version"+       putStrLn "--exact-version"+    where isRight (Right _) = True+          isRight _ = False++printVersion :: IO ()+printVersion = putStrLn $ "darcs version " ++ version++-- avoiding a module import cycle between Help and TheCommands+commandControlList :: [CommandControl]+commandControlList =+  normalCommand help : TheCommands.commandControlList++-- FIXME: the "grouping" comments below should made subsections in the+-- manpage, as we already do for DarcsCommand groups. --twb, 2009++-- | Help on each environment variable in which Darcs is interested.+environmentHelp :: [([String], [String])]+environmentHelp = [+ -- General-purpose+ environmentHelpHome,+ environmentHelpEditor,+ environmentHelpPager,+ environmentHelpColor,+ environmentHelpEscapeWhite,+ environmentHelpEscape,+ environmentHelpTmpdir,+ environmentHelpKeepTmpdir,+ environmentHelpEmail,+ environmentHelpSendmail,+ environmentHelpLocks,+ -- Remote Repositories+ environmentHelpSsh,+ environmentHelpScp,+ environmentHelpSshPort,+ environmentHelpTimeout]++-- | This function is responsible for emitting a darcs "man-page", a+-- reference document used widely on Unix-like systems.  Manpages are+-- primarily used as a quick reference, or "memory jogger", so the+-- output should be terser than the user manual.+--+-- Before modifying the output, please be sure to read the man(7) and+-- man-pages(7) manpages, as these respectively describe the relevant+-- syntax and conventions.+manpage :: Doc+manpage = vcat [+ ".TH DARCS 1" <+> quoted version,+ ".SH NAME",+ "darcs \\- an advanced revision control system",+ ".SH SYNOPSIS",+ ".B darcs", ".I command", ".RI < arguments |[ options ]>...",+ "",+ "Where the", ".I commands", "and their respective", ".I arguments", "are",+ "",+ synopsis,+ ".SH DESCRIPTION",+ description,+ ".SH OPTIONS",+ "Different options are accepted by different Darcs commands.",+ "Each command's most important options are listed in the",+ ".B COMMANDS",+ "section.  For a full list of all options accepted by",+ "a particular command, run `darcs", ".I command", "\\-\\-help'.",+ ".SS " <> vcat (map text helpOnMatchers),+ ".SH COMMANDS",+ commands,+ ".SH ENVIRONMENT",+ environment,+ ".SH FILES",+ prefFiles,+ ".SH BUGS",+ "At http://bugs.darcs.net/ you can find a list of known",+ "bugs in Darcs.  Unknown bugs can be reported at that",+ "site (after creating an account) or by emailing the",+ "report to bugs@darcs.net.",+ -- ".SH EXAMPLE",+ -- FIXME:+ -- new project: init, rec -la;+ -- 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.",+ "It can be found at http://darcs.net/",+ ".SH LICENSE",+ "Darcs is free software; you can redistribute it and/or modify",+ "it under the terms of the GNU General Public License as published by",+ "the Free Software Foundation; either version 2, or (at your option)",+ "any later version." ]+    where+      -- | A synopsis line for each command.  Uses 'foldl' because it is+      -- necessary to avoid blank lines from Hidden_commands, as groff+      -- translates them into annoying vertical padding (unlike TeX).+      synopsis :: Doc+      synopsis = foldl iter mempty commandControlList+          where iter :: Doc -> CommandControl -> Doc+                iter acc (GroupName _) = acc+                iter acc (HiddenCommand _) = acc+                iter acc (CommandData (c@SuperCommand {})) =+                    acc $$ vcat (map+                            (render (commandName c ++ " "))+                            (extractCommands (commandSubCommands c)))+                iter acc (CommandData c) = acc $$ render "" c+                render :: String -> DarcsCommand -> Doc+                render prefix c =+                    ".B darcs " <> text prefix <> text (commandName c) $$+                    vcat (map (text.mangle_args) (commandExtraArgHelp c)) $$+                    -- In the output, we want each command to be on its own+                    -- line, but we don't want blank lines between them.+                    ".br"++      -- | As 'synopsis', but make each group a subsection (.SS), and+      -- include the help text for each command.+      commands :: Doc+      commands = vsep $ map iter commandControlList+          where iter :: CommandControl -> Doc+                iter (GroupName x) = ".SS" <+> quoted x+                iter (HiddenCommand _) = mempty+                iter (CommandData (c@SuperCommand {})) =+                  vcat+                  [ ".B darcs " <> text (commandName c)+                  , text (mangle_args "subcommand")+                  , ".RS 4"+                  , commandHelp c+                  , ".RE"+                  ]+                  $+$+                  vsep (map (render (commandName c ++ " "))+                    (extractCommands (commandSubCommands c)))+                iter (CommandData c) = render "" c+                render :: String -> DarcsCommand -> Doc+                render prefix c =+                  vcat+                  [ ".B darcs " <> text prefix <> text (commandName c)+                  , vcat (map (text.mangle_args) (commandExtraArgHelp c))+                  , ".RS 4"+                  , commandHelp c+                  , ".RE"+                  ]++      -- | Now I'm showing off: mangle the extra arguments of Darcs commands+      -- so as to use the ideal format for manpages, italic words and roman+      -- punctuation.+      mangle_args :: String -> String+      mangle_args s =+          ".RI " ++ unwords (map show (groupBy cmp $ map toLower $ gank s))+              where cmp x y = isAlphaNum x == isAlphaNum y+                    gank (' ':'o':'r':' ':xs) = '|' : gank xs+                    gank (x:xs) = x : gank xs+                    gank [] = []++      environment :: Doc+      environment = vcat $ concat+                    [(".SS" <+> quoted (andClauses ks)) : map text ds+                     | (ks, ds) <- environmentHelp]++      prefFiles :: Doc+      prefFiles = vcat $ map go prefsFilesHelp+        where go (f,h) = ".SS" <+> quoted(prefsDirPath </> f) $$ text h++      description = vcat+        [ "Unlike conventional revision control systems, Darcs is based on tracking"+        , "changes, rather than versions: it can and does automatically re-order"+        , "independent changes when needed. This means that in Darcs the state of"+        , "a repository should be regarded as a"+        , ".I set of patches"+        , "rather than a"+        , ".I sequence of versions."+        , ""+        , "Another distinguishing feature of darcs is that most commands are"+        , "interactive by default. For instance, `darcs record' (the equivalent of"+        , "what is usually called `commit') presents you with"+        , "each unrecorded change and asks you whether it should be included in"+        , "the patch to be recorded. Similarly, `darcs push' and `darcs pull'"+        , "present you with each patch, allowing you to select which patches to"+        , "push or pull."+        ]++markdownLines :: [String]+markdownLines =+ [ "# Commands", ""+ , unlines commands+ , "# Patterns"+ , "", unlines helpOnMatchers+ , "# Configuration"+ , "", unlines prefFiles+ , "# Environment variables"+ , "", unlines environment ]+   where+      prefFiles = concatMap go prefsFilesHelp+        where go (f,h) = ["## `" ++ prefsDirPath </> f ++ "`", "", h]++      environment :: [String]+      environment = intercalate [""]+                     [ renderEnv ks ds | (ks, ds) <- environmentHelp ]+        where+          renderEnv k d = ("## " ++ (intercalate ", " k)) : "" : d+      commands :: [String]+      commands = foldl iter [] commandControlList+      iter :: [String] -> CommandControl -> [String]+      iter acc (GroupName x) = acc ++ ["## " ++ x, ""]+      iter acc (HiddenCommand _) = acc+      iter acc (CommandData (c@SuperCommand {})) =+          acc ++ concatMap+                  (render (commandName c ++ " "))+                  (extractCommands (commandSubCommands c))+      iter acc (CommandData c) = acc ++ render "" c+      render :: String -> DarcsCommand -> [String]+      render prefix c =+          [ "### " ++ prefix ++ commandName c+          , "", "darcs " ++ prefix ++ commandName c ++ " [OPTION]... " +++          unwords (commandExtraArgHelp c)+          , "", commandDescription c+          , "", renderString (commandHelp c)+          , "Options:", optionsMarkdown bopts+          , if null aopts then ""+             else unlines ["Advanced Options:", optionsMarkdown aopts]+          ]+       where (bopts, aopts) = commandAlloptions c++environmentHelpEditor :: ([String], [String])+environmentHelpEditor = (["DARCS_EDITOR", "VISUAL", "EDITOR"],[+ "To edit a patch description of email comment, Darcs will invoke an",+ "external editor.  Your preferred editor can be set as any of the",+ "environment variables $DARCS_EDITOR, $VISUAL or $EDITOR.",+ "If none of these are set, nano is used.  If nano crashes or is not",+ "found in your PATH, vi, emacs, emacs -nw and (on Windows) edit are",+ "each tried in turn."])++environmentHelpPager :: ([String], [String])+environmentHelpPager = (["DARCS_PAGER", "PAGER"],[+ "Darcs will invoke a pager if the output of some command is longer",+ "than 20 lines. Darcs will use the pager specified by $DARCS_PAGER",+ "or $PAGER.  If neither are set, `less` will be used.  Set $DARCS_PAGER",+ "- or $PAGER if the former is not set - to the empty string in order not",+ "to use a pager."])++environmentHelpTimeout :: ([String], [String])+environmentHelpTimeout = (["DARCS_CONNECTION_TIMEOUT"],[+ "Set the maximum time in seconds that darcs allows and connection to",+ "take. If the variable is not specified the default are 30 seconds.",+ "This option only works with curl."])++-- | There are two environment variables that we do not document:+-- - DARCS_USE_ISPRINT: deprecated, use DARCS_DONT_ESCAPE_ISPRINT.+-- - DARCS_TESTING_PREFS_DIR: used by the test suite to tell darcs+--                            where to find its configuration files.
+ src/Darcs/UI/Commands/Init.hs view
@@ -0,0 +1,132 @@+--  Copyright (C) 2002-2003 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.Init ( initialize, initializeCmd ) where++import Darcs.Prelude++import Control.Monad ( when )++import Darcs.Repository ( createRepository, withUMaskFlag )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amNotInRepository+    , nodefaults+    , putFinished+    , withStdOpts+    , putWarning+    )+import Darcs.UI.Commands.Util ( commonHelpWithPrefsTemplates )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags ( DarcsFlag, withNewRepo )+import Darcs.UI.Options ( (?), (^) )+import Darcs.UI.Options.All ()+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer+    ( Doc+    , formatWords+    , quoted+    , renderString+    , text+    , vsep+    , ($$)+    , (<+>)+    )++initializeDescription :: String+initializeDescription = "Create an empty repository."++initializeHelp :: Doc+initializeHelp = vsep $ map formatWords+  [ [ "The `darcs initialize` command creates an empty repository in the"+    , "current directory. This repository lives in a new `_darcs` directory,"+    , "which stores version control metadata and settings."+    ]+  , [ "Existing files and subdirectories are not touched. You can"+    , "record them with `darcs record --look-for-adds`."+    ]+  , [ "Initialize is commonly abbreviated to `init`."+    ]+  , [ "Darcs currently supports three kinds of patch semantics. These are called"+    , "`darcs-1`, `darcs-2`, and `darcs-3`. They are mutually incompatible, that"+    , "is, you cannot exchange patches between repos with different semantics."+    ]+  , [ "By default, patches of the new repository are in the darcs-2 semantics."+    , "However it is possible to create a repository in darcs-1 semantics with"+    , "the flag `--darcs-1`, althought this is not recommended except for sharing"+    , "patches with a project that uses patches in the darcs-1 semantics."+    ]+  ] ++ [darcs3Warning, commonHelpWithPrefsTemplates]++darcs3Warning :: Doc+darcs3Warning = formatWords+  [ "The `darcs-3` semantics is EXPERIMENTAL and new in version 2.16. It is"+  , "included only as a technology preview and we do NOT recommend to use it"+  , "for any serious work. The on-disk format is not yet finalized and we"+  , "cannot and will not promise that later releases will work with darcs-3"+  , "repos created with any darcs version before 3.0."+  ]++initialize :: DarcsCommand+initialize = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "initialize"+    , commandHelp = initializeHelp+    , commandDescription = initializeDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[<DIRECTORY>]"]+    , commandPrereq = \_ -> return $ Right ()+    , commandCommand = initializeCmd+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = initOpts+    }+  where+    initBasicOpts = O.patchFormat ^ O.withWorkingDir ^ O.newRepo+    initAdvancedOpts = O.patchIndexNo ^ O.hashed ^ O.umask ^ O.withPrefsTemplates+    initOpts = initBasicOpts `withStdOpts` initAdvancedOpts++initializeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+initializeCmd _ opts [outname]+  | Nothing <- O.newRepo ? opts = doInit (withNewRepo outname opts)+initializeCmd _ opts [] = doInit opts+initializeCmd _ _ _ =+  fail "You must provide 'initialize' with either zero or one argument."++doInit :: [DarcsFlag] -> IO ()+doInit opts =+  withUMaskFlag (O.umask ? opts) $ do+    location <- amNotInRepository opts+    case location of+      Left msg -> fail $ renderString $+        "Unable to" <+> quoted ("darcs " ++ commandName initialize)+                    <+> "here:" $$ text msg+      Right () -> do+        when (O.patchFormat ? opts == O.PatchFormat3) $+          putWarning opts $+            "============================= WARNING =============================" $$+            darcs3Warning $$+            "==================================================================="+        _ <- createRepository+          (O.patchFormat ? opts)+          (O.withWorkingDir ? opts)+          (O.patchIndexNo ? opts)+          (O.useCache ? opts)+          (O.withPrefsTemplates ? opts)+        putFinished opts $ "initializing repository"
+ src/Darcs/UI/Commands/Log.hs view
@@ -0,0 +1,477 @@+--  Copyright (C) 2003-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Log+    ( changes+    , log+    , changelog+    , logInfoFL+    , simpleLogInfo -- for darcsden+    ) where++import Darcs.Prelude++import Data.List ( intersect, find )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( catMaybes, fromMaybe, isJust )+import Control.Arrow ( second )+import Control.Exception ( catch, IOException )+import Control.Monad ( when, unless )+import Control.Monad.State.Strict ( evalState, get, gets, modify )++import Darcs.UI.PrintPatch ( showFriendly )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAndG, fmapFLPIAP, hopefullyM, info )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, findRepository )+import Darcs.UI.Commands.Util ( matchRange )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.UI.External ( viewDocWith )+import Darcs.UI.Flags+    ( DarcsFlag+    , changesReverse, onlyToFiles, diffingOpts+    , useCache, maxCount, hasXmlOutput+    , verbosity, isInteractive, verbose+    , getRepourl, pathSetFromArgs )+import Darcs.UI.Options ( (^), parseFlags, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path+    ( SubPath+    , AbsolutePath+    , simpleSubPath+    , AnchoredPath+    , floatSubPath+    , displayPath+    )+import Darcs.Repository ( PatchInfoAnd,+                          withRepositoryLocation, RepoJob(..),+                          readPatches, unrecordedChanges,+                          withRepoLockCanFail )+import Darcs.Util.Lock ( withTempDir )+import Darcs.Patch.Set ( PatchSet, patchSet2RL, Origin )+import Darcs.Patch.Format ( PatchListFormat )+import Darcs.Patch.Info ( toXml, toXmlShort, showPatchInfo, displayPatchInfo, escapeXML, PatchInfo )+import Darcs.Patch.Ident ( PatchId )+import Darcs.Patch.Invertible ( mkInvertible )+import Darcs.Patch.Depends ( contextPatches )+import Darcs.Patch.Show ( ShowPatch, ShowPatchFor(..) )+import Darcs.Patch.TouchesFiles ( lookTouch )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch ( PrimPatchBase(..), invert, xmlSummary, description,+                     effectOnPaths, listTouchedFiles, showPatch )+import Darcs.Patch.Named ( HasDeps, getdeps )+import Darcs.Patch.Prim.Class ( PrimDetails )+import Darcs.Patch.Summary ( Summary )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+    ( FL(NilFL), RL(..), filterOutFLFL, filterRL,+    reverseFL, (:>)(..), mapFL, mapRL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..), unseal2, Sealed(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Match+    ( MatchFlag+    , Matchable+    , MatchableRP+    , matchAPatch+    , haveNonrangeMatch+    )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , (<+>)+    , formatWords+    , hsep+    , insertBeforeLastline+    , prefix+    , simplePrinters+    , text+    , vcat+    , vsep+    )+import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Util.Progress ( setProgressMode, debugMessage )+import Darcs.UI.SelectChanges ( viewChanges )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Repository.PatchIndex ( PatchFilter, maybeFilterPatches, attemptCreatePatchIndex )+import Darcs.Util.Tree( Tree )++logHelp :: Doc+logHelp = vsep $ map formatWords+  [ [ "The `darcs log` command lists patches of the current repository or,"+    , "with `--repo`, a remote repository.  Without options or arguments,"+    , "ALL patches will be listed."+    ]+  , [ "When given files or directories paths as arguments, only patches which"+    , "affect those paths are listed.  This includes patches that happened to"+    , "files before they were moved or renamed."+    ]+  , [ "When given `--from-tag` or `--from-patch`, only patches since that tag"+    , "or patch are listed.  Similarly, the `--to-tag` and `--to-patch`"+    , "options restrict the list to older patches."+    ]+  , [ "The `--last` and `--max-count` options both limit the number of patches"+    , "listed.  The former applies BEFORE other filters, whereas the latter"+    , "applies AFTER other filters.  For example `darcs log foo.c"+    , "--max-count 3` will print the last three patches that affect foo.c,"+    , "whereas `darcs log --last 3 foo.c` will, of the last three"+    , "patches, print only those that affect foo.c."+    ]+  , [ "Four output formats exist.  The default is `--human-readable`. The slightly"+    , "different `--machine-readable` format enables to see patch dependencies in"+    , "non-interactive mode. You can also select `--context`, which is an internal"+    , "format that can be re-read by Darcs (e.g. `darcs clone --context`)."+    ]+  , [ "Finally, there is `--xml-output`, which emits valid XML... unless a the"+    , "patch metadata (author, name or description) contains a non-ASCII"+    , "character and was recorded in a non-UTF8 locale."+    ]+  ]++log :: DarcsCommand+log = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "log"+    , commandHelp = logHelp+    , commandDescription = "List patches in the repository."+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+    , commandCompleteArgs = knownFileArgs+    , commandCommand = logCmd+    , commandPrereq = findRepository+    , commandArgdefaults = nodefaults+    , commandOptions = logOpts+    }+  where+    logBasicOpts+      = O.matchSeveralOrRange+      ^ O.maxCount+      ^ O.onlyToFiles+      ^ O.changesFormat+      ^ O.withSummary+      ^ O.changesReverse+      ^ O.possiblyRemoteRepo+      ^ O.repoDir+      ^ O.interactive+    logAdvancedOpts = O.remoteDarcs ^ O.patchIndexYes+    logOpts = logBasicOpts `withStdOpts` logAdvancedOpts++logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+logCmd fps opts args+  | O.changesFormat ? opts == Just O.GenContext = if not . null $ args+      then fail "log --context cannot accept other arguments"+      else logContext opts+  | hasRemoteRepo opts = do+      (fs, es) <- remoteSubPaths args []+      if null es then+        withTempDir "darcs.log"+          (\_ -> showLog opts $ maybeNotNull $ nubSort $ filterErrors $ map floatSubPath fs)+      else+        fail $ "For a remote repo I can only handle relative paths.\n"+            ++ "Invalid arguments: "++unwords es+  | null args = showLog opts Nothing+  | otherwise = do+      unless (isInteractive False opts)+        $ when (O.patchIndexNo ? opts == O.YesPatchIndex)+          $ withRepoLockCanFail (useCache ? opts)+            $ RepoJob (\repo -> readPatches repo >>= attemptCreatePatchIndex repo)+      paths <- pathSetFromArgs fps args+      showLog opts paths++maybeNotNull :: [a] -> Maybe [a]+maybeNotNull [] = Nothing+maybeNotNull xs = Just xs++filterErrors :: [Either e a] -> [a]+filterErrors = catMaybes . map (either (const Nothing) Just)++hasRemoteRepo :: [DarcsFlag] -> Bool+hasRemoteRepo = isJust . getRepourl++remoteSubPaths :: [String] -> [String] -> IO ([SubPath],[String])+remoteSubPaths [] es = return ([], es)+remoteSubPaths (arg:args) es = case simpleSubPath arg of+  Nothing -> remoteSubPaths args (arg:es)+  Just sp -> do+    (sps, es') <- remoteSubPaths args es+    return (sp:sps, es')++showLog :: [DarcsFlag] -> Maybe [AnchoredPath] -> IO ()+showLog opts files =+  let repodir = fromMaybe "." (getRepourl opts) in+  withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repository -> do+  unless (O.debug ? opts) $ setProgressMode False+  Sealed unrec <- case files of+    Nothing -> return $ Sealed NilFL+    Just _ ->+      Sealed `fmap` unrecordedChanges (diffingOpts opts) repository files `catch`+        \(_ :: IOException) ->+          return (Sealed NilFL) -- this is triggered when repository is remote+  debugMessage "About to read the repository..."+  patches <- readPatches repository+  debugMessage "Done reading the repository."+  let recFiles = effectOnPaths (invert unrec) <$> files+      filtered_changes p =+          maybe_reverse <$>+          getLogInfo+              (maxCount ? opts)+              (parseFlags O.matchSeveralOrRange opts)+              (onlyToFiles ? opts)+              recFiles+              (maybeFilterPatches repository patches)+              p+  if isInteractive False opts+    then do li <- filtered_changes patches+            viewChanges (logPatchSelOpts opts) (map fst (liPatches li))+    else do let header =+                  case recFiles of+                    Just fs | not (hasXmlOutput opts) ->+                      let pathlist = map (text . displayPath) fs+                      in hsep (text "Changes to" : pathlist) <> text ":" $$ text ""+                    _ -> mempty+            debugMessage "About to print the patches..."+            let printers = if hasXmlOutput opts then simplePrinters else fancyPrinters+            ps <- readPatches repository -- read repo again to prevent holding onto+                                       -- values forced by filtered_changes+            logOutput <- changelog opts (patchSet2RL ps) `fmap` filtered_changes patches+            viewDocWith printers (header $$ logOutput)+  where+    maybe_reverse li@(LogInfo xs b c) =+      if changesReverse ? opts then LogInfo (reverse xs) b c else li++data LogInfo p = LogInfo+  { liPatches :: [(Sealed2 p, [AnchoredPath])]+  , liRenames :: [(AnchoredPath, AnchoredPath)]+  , liErrorMsg :: Maybe Doc+  }++mkLogInfo :: [Sealed2 p] -> LogInfo p+mkLogInfo ps = LogInfo (map (,[]) ps) [] Nothing++logInfoFL :: FL p wX wY -> LogInfo p+logInfoFL = mkLogInfo . mapFL Sealed2++matchNonrange :: (Matchable p, PatchId p ~ PatchInfo)+              => [MatchFlag] -> RL p wA wB -> [Sealed2 p]+matchNonrange matchFlags+  | haveNonrangeMatch matchFlags = filterRL (matchAPatch matchFlags)+  | otherwise = mapRL Sealed2++simpleLogInfo :: ( MatchableRP p+                 , ApplyState p ~ Tree+                 )+              => AnchoredPath+              -> PatchFilter p+              -> PatchSet p Origin wY+              -> IO [Sealed2 (PatchInfoAnd p)]+simpleLogInfo path pf ps =+  map fst . liPatches <$> getLogInfo Nothing [] False (Just [path]) pf ps++getLogInfo :: forall p wY.+              ( MatchableRP p+              , ApplyState p ~ Tree+              )+           => Maybe Int -> [MatchFlag] -> Bool+           -> Maybe [AnchoredPath]+           -> PatchFilter p+           -> PatchSet p Origin wY+           -> IO (LogInfo (PatchInfoAnd p))+getLogInfo maxCountFlag matchFlags onlyToFilesFlag paths patchFilter ps =+  case matchRange matchFlags ps of+    Sealed2 range ->+      let ps' = matchNonrange matchFlags (reverseFL range) in+      case paths of+        Nothing -> return $ mkLogInfo $ maybe id take maxCountFlag ps'+        Just fs -> do+          filterOutUnrelatedChanges <$> do+            ps'' <- patchFilter fs ps'+            return $ filterPatchesByNames maxCountFlag fs ps''+  where+        -- What we do here is somewhat unclean: we modify the contents of+        -- our patches and throw out everything not related to our files.+        -- This is okay because we only use the result for display.+        filterOutUnrelatedChanges li+          | onlyToFilesFlag = li { liPatches = map onlyRelated (liPatches li) }+          | otherwise       = li++        onlyRelated (Sealed2 p, fs) =+          (Sealed2 $ fmapFLPIAP (filterOutFLFL (unrelated fs)) p, fs)++        unrelated fs p+          -- If the change does not affect the patches we are looking at,+          -- we ignore the difference between the two states.+          | null $ fs `intersect` listTouchedFiles p = unsafeCoerceP IsEq+          | otherwise                                = NotEq++-- | Take a list of filenames and patches and produce a list of patches that+-- actually touch the given files with a list of touched file names, a list of+-- original-to-current filepath mappings, indicating the original names of the+-- affected files and possibly an error. Additionaly, the function takes a+-- "depth limit" -- maxcount, that could be Nothing (return everything) or+-- "Just n" -- returns at most n patches touching the file (starting from the+-- beginning of the patch list).+filterPatchesByNames+    :: forall p.+       ( MatchableRP p+       , ApplyState p ~ Tree+       )+    => Maybe Int                      -- ^ maxcount+    -> [AnchoredPath]                 -- ^ paths+    -> [Sealed2 (PatchInfoAnd p)]  -- ^ patches+    -> LogInfo (PatchInfoAnd p)+filterPatchesByNames maxcount paths patches = removeNonRenames $+    evalState (filterPatchesByNamesM paths patches) (maxcount, initRenames) where+        removeNonRenames li = li { liRenames = removeIds (liRenames li) }+        removeIds = filter $ uncurry (/=)+        initRenames = map (\x -> (x, x)) paths+        returnFinal = (\renames -> LogInfo [] renames Nothing) <$> gets snd+        filterPatchesByNamesM [] _ = returnFinal+        filterPatchesByNamesM _ [] = returnFinal+        filterPatchesByNamesM fs (s2hp@(Sealed2 hp) : ps) = do+            (count, renames) <- get+            case count of+                Just c | c <= 0 -> returnFinal+                _ ->+                  case hopefullyM hp of+                    Nothing -> do+                        let err = text "Can't find patches prior to:"+                                  $$ displayPatchInfo (info hp)+                        return (LogInfo [] renames (Just err))+                    Just p ->+                        case lookTouch (Just renames) fs (invert (mkInvertible p)) of+                            (True, affected, [], renames') ->+                                return (LogInfo [(s2hp, affected)] renames' Nothing)+                            (True, affected, fs', renames') -> do+                                let sub1Mb c = subtract 1 <$> c+                                modify $ \(c, _) -> (sub1Mb c, renames')+                                rest <- filterPatchesByNamesM fs' ps+                                return $ rest {+                                    liPatches = (s2hp, affected) : liPatches rest+                                  }+                            (False, _, fs', renames') -> do+                                modify $ second (const renames')+                                filterPatchesByNamesM fs' ps++changelog :: forall p wStart wX+           . ( ShowPatch p, PatchListFormat p+             , Summary p, HasDeps p, PrimDetails (PrimOf p)+             )+          => [DarcsFlag] -> RL (PatchInfoAndG p) wStart wX+          -> LogInfo (PatchInfoAndG p)+          -> Doc+changelog opts patches li+    | O.changesFormat ? opts == Just O.CountPatches =+        text $ show $ length $ liPatches li+    | hasXmlOutput opts = xml_changelog+    | O.yes (O.withSummary ? opts) || verbose opts =+        vsep (map (number_patch change_with_summary) ps) $$ mbErr+    | otherwise = vsep (map (number_patch description') ps) $$ mbErr+    where ps_and_fs = liPatches li+          mbErr = fromMaybe mempty (liErrorMsg li)+          change_with_summary :: Sealed2 (PatchInfoAndG p) -> Doc+          change_with_summary (Sealed2 hp)+            | Just p <- hopefullyM hp =+              if O.changesFormat ? opts == Just O.MachineReadable+                then showPatch ForStorage p+                else showFriendly (verbosity ? opts) (O.withSummary ? opts) p+            | otherwise = description hp $$ indent (text "[this patch is unavailable]")++          xml_changelog = vcat+            [ text "<changelog>"+            , vcat xml_created_as+            , vcat xml_changes+            , text "</changelog>"+            ]++          xml_with_summary :: Sealed2 (PatchInfoAndG p) -> Doc+          xml_with_summary (Sealed2 hp) | Just p <- hopefullyM hp =+                    let+                      deps = getdeps p+                      xmlDependencies =+                        text "<explicit_dependencies>"+                        $$ vcat (map (indent . toXmlShort) deps)+                        $$ text "</explicit_dependencies>"+                      summary | deps == [] = indent $ xmlSummary p+                              | otherwise = indent $ xmlDependencies $$ xmlSummary p+                    in+                      insertBeforeLastline (toXml $ info hp) summary+          xml_with_summary (Sealed2 hp) = toXml (info hp)+          indent = prefix "    "+          xml_changes =+            case O.withSummary ? opts of+              O.YesSummary -> map xml_with_summary ps+              O.NoSummary -> map (toXml . unseal2 info) ps+          xml_created_as = map create (liRenames li) where+            create :: (AnchoredPath, AnchoredPath) -> Doc+            create rename@(_, as) = createdAsXml (first_change_of as) rename+            -- We need to reorder the patches when they haven't been reversed+            -- already, so that we find the *first* patch that modifies a given+            -- file, not the last (by default, the list is oldest->newest).+            reorderer = if not (changesReverse ? opts) then reverse else id+            oldest_first_ps_and_fs = reorderer ps_and_fs+            couldnt_find fn = error $ "Couldn't find first patch affecting " +++                                      (displayPath fn) ++ " in ps_and_fs"+            mb_first_change_of fn = find ((fn `elem`) . snd) oldest_first_ps_and_fs+            find_first_change_of fn = fromMaybe (couldnt_find fn)+              (mb_first_change_of fn)+            first_change_of :: AnchoredPath -> PatchInfo+            first_change_of = unseal2 info . fst . find_first_change_of++          number_patch f x = if O.changesFormat ? opts == Just O.NumberPatches+                             then case get_number x of+                                  Just n -> text (show n++":") <+> f x+                                  Nothing -> f x+                             else f x++          get_number :: Sealed2 (PatchInfoAndG p) -> Maybe Int+          get_number (Sealed2 y) = gn 1 patches+              where iy = info y+                    gn :: Int -> RL (PatchInfoAndG p) wStart wY -> Maybe Int+                    gn n (bs:<:b) | seq n (info b) == iy = Just n+                                  | otherwise = gn (n+1) bs+                    gn _ NilRL = Nothing+          ps = map fst ps_and_fs+          description' = unseal2 description++logContext :: [DarcsFlag] -> IO ()+logContext opts = do+  let repodir = fromMaybe "." $ getRepourl opts+  withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repository -> do+      (_ :> ps) <- contextPatches `fmap` readPatches repository+      let header = text "\nContext:\n"+      viewDocWith simplePrinters $ vsep+          (header : mapRL (showPatchInfo ForStorage . info) ps)++-- | changes is an alias for log+changes :: DarcsCommand+changes = commandAlias "changes" Nothing log++createdAsXml :: PatchInfo -> (AnchoredPath, AnchoredPath) -> Doc+createdAsXml pinfo (current, createdAs) =+    text "<created_as current_name='"+       <> escapeXML (displayPath current)+       <> text "' original_name='"+       <> escapeXML (displayPath createdAs)+       <> text "'>"+    $$    toXml pinfo+    $$    text "</created_as>"++logPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+logPatchSelOpts flags = S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = parseFlags O.matchSeveralOrRange flags+    , S.interactive = isInteractive False flags+    , S.selectDeps = O.PromptDeps -- option not supported, use default+    , S.withSummary = O.withSummary ? flags+    }
+ src/Darcs/UI/Commands/MarkConflicts.hs view
@@ -0,0 +1,294 @@+--  Copyright (C) 2002-2003,2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}++module Darcs.UI.Commands.MarkConflicts ( markconflicts ) where++import Darcs.Prelude++import System.Exit ( exitSuccess )+import Data.List.Ordered ( nubSort, isect )+import Control.Monad ( when, unless, void )++import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Path ( AbsolutePath, AnchoredPath, anchorPath )+import Darcs.Util.Printer+    ( Doc, formatWords, pathlist, text, debugDocLn+    , vcat, vsep, (<+>), ($$) )++import Darcs.UI.Commands+    ( DarcsCommand(..)+    , withStdOpts+    , nodefaults+    , amInHashedRepository+    , putInfo+    , putFinished+    )+import Darcs.UI.Commands.Util ( filterExistingPaths )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.UI.Flags+    ( DarcsFlag, diffingOpts, verbosity, dryRun, umask+    , useCache, pathSetFromArgs )+import Darcs.UI.Options ( (^), (?) )+import qualified Darcs.UI.Options.All as O++import Darcs.Repository+    ( withRepoLock+    , RepoJob(..)+    , addToPending+    , finalizeRepositoryChanges+    , applyToWorking+    , readPatches+    , unrecordedChanges )++import Darcs.Patch ( invert, listTouchedFiles, effectOnPaths )+import Darcs.Patch.Show+import Darcs.Patch.TouchesFiles ( chooseTouching )+import Darcs.Patch.Witnesses.Ordered ( mapFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Repository.Resolution+    ( StandardResolution(..)+    , patchsetConflictResolutions+    , warnUnmangled+    )+import Darcs.Patch.Named ( anonymous )+import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch.Set ( patchSetSnoc )++-- * The mark-conflicts command++markconflictsDescription :: String+markconflictsDescription =+ "Mark unresolved conflicts in working tree, for manual resolution."++markconflictsHelp :: Doc+markconflictsHelp = vsep $+  [ formatWords+    [ "Darcs requires human guidance to reconcile independent changes to the same"+    , "part of a file.  When a conflict first occurs, darcs will add the"+    , "initial state and all conflicting choices to the working tree, delimited"+    , " by the markers `v v v`, `=====`,  `* * *` and `^ ^ ^`, as follows:"+    ]+  , vcat $ map text+    [ "    v v v v v v v"+    , "    initial state"+    , "    ============="+    , "    first choice"+    , "    *************"+    , "    ...more choices..."+    , "    *************"+    , "    last choice"+    , "    ^ ^ ^ ^ ^ ^ ^"+    ]+  ] ++ map formatWords+  [ [ "If you happened to revert or manually delete this conflict markup without"+    , "actually resolving the conflict, `darcs mark-conflicts` can be used to"+    , "re-create it; and similarly if you have used `darcs apply` or `darcs pull`"+    , "with `--allow-conflicts`, where conflicts aren't marked initially."+    ]+  , [ "In Darcs, a conflict counts as resolved when all of the changes"+    , "involved in the conflict (which can be more than two) are depended on by"+    , "one or more later patches. If you record a resolution for a particular"+    , "conflict, `darcs mark-conflicts` will no longer mark it, indicating that"+    , "it is resolved. If you have unrecorded changes, these count as (potential)"+    , "conflict resolutions, too, just as if you had already recorded them."+    ]+  , [ "This principle extends to explicit \"semantic\" dependencies. For instance,"+    , "recording a tag will automatically mark all conflicts as resolved."+    ]+  , [ "In the above schematic example the \"initial state\" corresponds to the"+    , "recorded state of the file in your repository. That is to say, the"+    , "recorded effect of a conflict is to apply none of the conflicting changes."+    , "This is usually not a state you would regard as a successful resolution"+    , "of the conflict; but there are exceptional situations where this may be"+    , "exactly what you want. In order to tell Darcs that you want this conflict"+    , "to be regarded as resolved, use `darcs record --ask-deps` to record a"+    , "patch that explicitly depends on all patches involved in the conflict."+    ]+ ]++markconflicts :: DarcsCommand+markconflicts = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "mark-conflicts"+    , commandHelp = markconflictsHelp+    , commandDescription = markconflictsDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+    , commandCommand = markconflictsCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = knownFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = markconflictsOpts+    }+  where+    markconflictsBasicOpts+      = O.repoDir+      ^ O.diffAlgorithm+      ^ O.dryRunXml+    markconflictsAdvancedOpts = O.umask+    markconflictsOpts = markconflictsBasicOpts `withStdOpts` markconflictsAdvancedOpts++markconflictsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+markconflictsCmd fps opts args = do+  paths <- maybeToOnly <$> pathSetFromArgs fps args+  debugDocLn $ "::: paths =" <+>  (text . show) paths+  withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \_repository -> do++{-+    What we do here:+    * read the unrecorded changes (all of them)+    * extract functions representing path rename effects from unrecorded+    * convert argument paths to pre-pending+    * read conflict resolutions that touch pre-pending argument paths+    * affected paths = intersection of paths touched by resolutions+                       and pre-pending argument paths+    * apply the conflict resolutions for affected paths+-}++    classified_paths <-+      traverse+        (filterExistingPaths _repository (verbosity ? opts) (diffingOpts opts))+        paths++    unrecorded <-+      unrecordedChanges (diffingOpts opts) _repository (fromOnly Everything)+    anonpw <- n2pia `fmap` anonymous unrecorded++    let forward_renames = effectOnPaths unrecorded+        backward_renames = effectOnPaths (invert unrecorded)+        existing_paths = fmap snd classified_paths+        pre_pending_paths = fmap backward_renames existing_paths+    debugDocLn $ "::: pre_pending_paths =" <+> (text . show) pre_pending_paths++    r <- readPatches _repository+    -- by including anonpw in the patch set, we regard unrecorded changes+    -- as potential conflict resolutions "under construction"+    Sealed res <- case patchsetConflictResolutions $ patchSetSnoc r anonpw of+      conflicts -> do+        warnUnmangled (fromOnly pre_pending_paths) conflicts+        Sealed mangled_res <- return $ mangled conflicts+        let raw_res_paths = pathSet $ listTouchedFiles mangled_res+        debugDocLn $ "::: raw_res_paths =" <+>  (text . show) raw_res_paths+        return $ chooseTouching (fromOnly pre_pending_paths) mangled_res+    let res_paths = pathSet $ listTouchedFiles res+    debugDocLn $ "::: res_paths =" <+>  (text . show) res_paths++    let affected_paths = res_paths `isectPathSet` pre_pending_paths+    debugDocLn $ "::: affected_paths =" <+>  (text . show) affected_paths++    when (affected_paths == Only []) $ do+      putInfo opts "No conflicts to mark."+      exitSuccess++    let post_pending_affected_paths = forward_renames <$> affected_paths+    putInfo opts $ "Marking conflicts in:" <+> showPathSet post_pending_affected_paths <> "."++    debugDocLn $ "::: res = " $$ vsep (mapFL displayPatch res)+    when (O.yes (dryRun ? opts)) $ do+        putInfo opts $ "Conflicts will not be marked: this is a dry run."+        exitSuccess++    addToPending _repository (diffingOpts opts) res+    withSignalsBlocked $ do+      _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+      unless (O.yes (O.dryRun ? opts)) $+        void $ applyToWorking _repository (verbosity ? opts) res+    putFinished opts "marking conflicts"++-- * Generic 'PathSet' support++{- $SupportCode++What follows is generic support code for working with argument path lists+that are used to restrict operations to a subset of the working or pristine+tree. The rest of Darcs uses two types for this:++ * @'Maybe' ['SubPath']@++ * @'Maybe' ['FilePath']@++The problem with both is the contra-intuitive name 'Nothing', which here+stands for 'Everything'. To make the intended use clearer, we use the 'Only'+type instead (which is is isomorphic to 'Maybe') and the synonym 'PathSet'+defined below.++These abstractions should get their own module (or become integrated into+Darcs.Util.Path) if and when someone decides to reuse it elsewhere. The+functionality provided is intentionally minimal and light-weight.+-}++-- | 'Only' is isomorphic to 'Maybe' but with the opposite semantics.+--+-- About the name: I like the data constructor names, they are pretty+-- suggestive. The data type name is up for grabs; a possible alternative+-- is @AtMost@.+data Only a = Everything | Only a deriving (Eq, Ord, Show)++instance Functor Only where+  fmap _ Everything = Everything+  fmap f (Only x) = Only (f x)++instance Foldable Only where+  foldMap _ Everything = mempty+  foldMap f (Only x) = f x++instance Traversable Only where+  traverse _ Everything = pure Everything+  traverse f (Only x) = Only <$> f x++-- | This is mostly for conversion to legacy APIs+fromOnly :: Only a -> Maybe a+fromOnly Everything = Nothing+fromOnly (Only x) = Just x++maybeToOnly :: Maybe a -> Only a+maybeToOnly Nothing = Everything+maybeToOnly (Just x) = Only x++{- | A set of repository paths. 'Everything' means every path in the repo,+it usually originates from an empty list of path arguments. The list of+'AnchoredPath's is always kept in sorted order with no duplicates.++It uses lists because the number of elements is expected to be small.+-}+type PathSet a = Only [a]++-- | Intersection of two 'PathSet's+isectPathSet :: Ord a => PathSet a -> PathSet a -> PathSet a+isectPathSet Everything ys = ys+isectPathSet xs Everything = xs+isectPathSet (Only xs) (Only ys) = Only (isect xs ys)++{-+-- | Union of two 'PathSet's+union :: PathSet -> PathSet -> PathSet+union Everything ys = Everything+union xs Everything = Everything+union (Only xs) (Only ys) = Only (union xs ys)+-}++pathSet :: Ord a => [a] -> PathSet a+pathSet = Only . nubSort++-- | Convert a 'PathSet' to a 'Doc'. Uses the English module+-- to generate a nicely readable list of file names.+showPathSet :: PathSet AnchoredPath -> Doc+showPathSet Everything = text "all paths"+showPathSet (Only xs) = pathlist (map (anchorPath "") xs)
+ src/Darcs/UI/Commands/Move.hs view
@@ -0,0 +1,369 @@+--  Copyright (C) 2002-2003 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Move ( move, mv ) where++import Darcs.Prelude++import Control.Monad ( when, unless, forM_, forM, void )+import Data.Maybe ( fromMaybe )+import Darcs.Util.SignalHandler ( withSignalsBlocked )++import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts, nodefaults, commandAlias, amInHashedRepository+    , putInfo+    )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.UI.Flags+    ( DarcsFlag+    , allowCaseDifferingFilenames, allowWindowsReservedFilenames+    , useCache, umask, pathsFromArgs+    )+import Darcs.UI.Options ( (^), (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Diff ( treeDiff )+import Darcs.Repository.Flags ( DiffAlgorithm(..) )+import Darcs.Repository.Prefs ( filetypeFunction )+import System.Directory ( renameDirectory, renameFile )+import Darcs.Repository.State+    ( readPristine+    , readPristineAndPending+    , readUnrecordedFiltered+    )+import Darcs.Repository+    ( Repository+    , AccessType(..)+    , withRepoLock+    , RepoJob(..)+    , unsafeAddToPending+    , finalizeRepositoryChanges+    )+import Darcs.Patch.Witnesses.Ordered ( FL(..), (+>+) )+import Darcs.Patch.Witnesses.Sealed ( FreeLeft, emptyGap, freeGap, joinGap )+import Darcs.Util.Global ( debugMessage )+import qualified Darcs.Patch+import Darcs.Patch ( RepoPatch, PrimPatch )+import Darcs.Patch.Apply( ApplyState )+import Data.List.Ordered ( nubSort )+import qualified System.FilePath.Windows as WindowsFilePath++import Darcs.Util.Tree+    ( Tree+    , modifyTree+    , treeHas+    , treeHasAnycase+    , treeHasDir+    , treeHasFile+    )+import Darcs.Util.Path+    ( AbsolutePath+    , AnchoredPath+    , displayPath+    , isRoot+    , parent+    , realPath+    , replaceParent+    )+import Darcs.Util.Printer ( Doc, text, hsep )++moveDescription :: String+moveDescription = "Move or rename files."++moveHelp :: Doc+moveHelp = text $+ "Darcs cannot reliably distinguish between a file being deleted and a\n" +++ "new one added, and a file being moved.  Therefore Darcs always assumes\n" +++ "the former, and provides the `darcs mv` command to let Darcs know when\n" +++ "you want the latter.  This command will also move the file in the\n" +++ "working tree (unlike `darcs remove`), unless it has already been moved.\n" +++ "\n" +++ -- Note that this paragraph is very similar to one in ./Add.lhs.+ "Darcs will not rename a file if another file in the same folder has\n" +++ "the same name, except for case.  The `--case-ok` option overrides this\n" +++ "behaviour.  Windows and OS X usually use filesystems that do not allow\n" +++ "files a folder to have the same name except for case (for example,\n" +++ "`ReadMe` and `README`).  If `--case-ok` is used, the repository might be\n" +++ "unusable on those systems!\n"++move :: DarcsCommand+move = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "move"+    , commandHelp = moveHelp+    , commandDescription = moveDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["<SOURCE> ... <DESTINATION>"]+    , commandCommand = moveCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = knownFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = moveOpts+    }+  where+    moveBasicOpts = O.allowProblematicFilenames ^ O.repoDir+    moveAdvancedOpts = O.umask+    moveOpts = moveBasicOpts `withStdOpts` moveAdvancedOpts++moveCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+moveCmd fps opts args+  | length args < 2 =+      fail "The `darcs move' command requires at least two arguments."+  | otherwise = do+      paths <- pathsFromArgs fps args+      when (length paths < 2) $+        fail "Note enough valid path arguments remaining."+      case paths of+        [from, to] -> do+          -- NOTE: The extra case for two arguments is necessary because+          -- in this case we allow file -> file moves. Whereas with 3 or+          -- more arguments the last one (i.e. the target) must be a directory.+          when (from == to) $ fail "Cannot rename a file or directory onto itself."+          when (isRoot from) $ fail "Cannot move the root of the repository."+          moveFile opts from to+        _ -> do+          let froms = init paths+              to = last paths+          when (to `elem` froms) $+            fail "Cannot rename a file or directory onto itself."+          when (any isRoot froms) $+            fail "Cannot move the root of the repository."+          moveFilesToDir opts (nubSort froms) to++data FileKind = Dir | File+              deriving (Show, Eq)++data FileStatus =+  Nonexistant+  | Unadded FileKind+  | Shadow FileKind -- ^ known to darcs, but absent in working tree+  | Known FileKind+  deriving Show++fileStatus :: Tree IO -- ^ tree of the working directory+           -> Tree IO -- ^ tree of recorded and pending changes+           -> Tree IO -- ^ tree of recorded changes+           -> AnchoredPath+           -> IO FileStatus+fileStatus work cur recorded fp = do+  existsInCur <- treeHas cur fp+  existsInRec <- treeHas recorded fp+  existsInWork <- treeHas work fp+  case (existsInRec, existsInCur, existsInWork) of+    (_, True, True) -> do+      isDirCur <- treeHasDir cur fp+      isDirWork <- treeHasDir work fp+      -- TODO is this an impossible case? else improve the error message!+      unless (isDirCur == isDirWork) . fail $ "don't know what to do with " ++ displayPath fp+      return . Known $ if isDirCur then Dir else File++    (_, False, True) -> do+      isDir <- treeHasDir work fp+      if isDir+        then return $ Unadded Dir+        else return $ Unadded File+    (False, False, False) -> return Nonexistant+    (_, _, False) -> do+      isDir <- treeHasDir cur fp+      if isDir+        then return $ Shadow Dir+        else return $ Shadow File++-- | Takes two filenames (as 'Subpath'), and tries to move the first+-- into/onto the second. Needs to guess what that means: renaming or moving+-- into a directory, and whether it is a post-hoc move.+moveFile :: [DarcsFlag] -> AnchoredPath -> AnchoredPath -> IO ()+moveFile opts old new = withRepoAndState opts $ \(repo, work, cur, recorded) -> do+  new_fs <- fileStatus work cur recorded new+  old_fs <- fileStatus work cur recorded old+  let doSimpleMove = simpleMove repo opts cur work old new+  case (old_fs, new_fs) of+    (Nonexistant, _) -> fail $ displayPath old ++ " does not exist."+    (Unadded k, _) -> fail $ show k ++ " " ++ displayPath old ++ " is unadded."+    (Known _, Nonexistant) -> doSimpleMove+    (Known _, Shadow _) -> doSimpleMove+    (_, Nonexistant) -> fail $ displayPath old ++ " is not in the repository."+    (Known _, Known Dir) -> moveToDir repo opts cur work [old] new+    (Known _, Unadded Dir) -> fail $+        displayPath new ++ " is not known to darcs; please add it to the repository."+    (Known _, _) -> fail $ displayPath new ++ " already exists."+    (Shadow k, Unadded k') | k == k' -> doSimpleMove+    (Shadow File, Known Dir) -> moveToDir repo opts cur work [old] new+    (Shadow Dir, Known Dir) -> doSimpleMove+    (Shadow File, Known File) -> doSimpleMove+    (Shadow k, _) -> fail $+        "cannot move " ++ show k ++ " " ++ displayPath old ++ " into " ++ displayPath new+        ++ " : " ++ "did you already move it elsewhere?"++moveFilesToDir :: [DarcsFlag] -> [AnchoredPath] -> AnchoredPath -> IO ()+moveFilesToDir opts froms to =+  withRepoAndState opts $ \(repo, work, cur, _) -> do+    froms_exist <- and <$> forM froms (treeHas cur)+    if froms_exist then+      moveToDir repo opts cur work froms to+    else+      fail "Some of the paths you want to move aren't know to darcs. Use `darcs add` to add them first."++{-+data RepoAndState = RS+  { repo :: Repository 'RW p wU wR+  , working :: Tree IO+  , current :: Tree IO+  , recorded :: Tree IO+  }+-}++withRepoAndState :: [DarcsFlag]+                 -> (forall p wR wU .+                        (ApplyState p ~ Tree, RepoPatch p) =>+                            (Repository 'RW p wU wR, Tree IO, Tree IO, Tree IO)+                                -> IO ())+                 -> IO ()+withRepoAndState opts f =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repo -> do+        work <-+          readUnrecordedFiltered repo (O.useIndex ? opts)+            O.EvenLookForBoring O.NoLookForMoves Nothing+        cur <- readPristineAndPending repo+        recorded <- readPristine repo+        f (repo, work, cur, recorded)++simpleMove :: (RepoPatch p, ApplyState p ~ Tree)+           => Repository 'RW p wU wR+           -> [DarcsFlag] -> Tree IO -> Tree IO -> AnchoredPath -> AnchoredPath+           -> IO ()+simpleMove repository opts cur work old new = do+    doMoves repository opts cur work [(old, new)]+    putInfo opts $ hsep $ map text ["Finished moving:", displayPath old, "to:", displayPath new]++moveToDir :: (RepoPatch p, ApplyState p ~ Tree)+          => Repository 'RW p wU wR+          -> [DarcsFlag] -> Tree IO -> Tree IO -> [AnchoredPath] -> AnchoredPath+          -> IO ()+moveToDir repository opts cur work moved finaldir = do+    -- note: we already checked that @moved@ is not the root,+    -- so we know that replaceParentPath can't fail+    let replaceParentPath a1 a2 =+          fromMaybe (error "cannot replace parent of root path") $ replaceParent a1 a2+    let moves = zip moved $ map (replaceParentPath finaldir) moved+    doMoves repository opts cur work moves+    putInfo opts $ hsep $ map text $ ["Finished moving:"] ++ map displayPath moved ++ ["to:", displayPath finaldir]++doMoves :: (RepoPatch p, ApplyState p ~ Tree)+          => Repository 'RW p wU wR+          -> [DarcsFlag] -> Tree IO -> Tree IO+          -> [(AnchoredPath, AnchoredPath)] -> IO ()+doMoves repository opts cur work moves = do+  patches <- forM moves $ \(old, new) -> do+        prePatch <- generatePreMovePatches opts cur work (old,new)+        return (prePatch, old, new)+  withSignalsBlocked $ do+    forM_ patches $ \(prePatch, old, new) -> do+      let -- Add any pre patches before the move patch+          pendingDiff = joinGap (+>+)+            (fromMaybe (emptyGap NilFL) prePatch)+            (freeGap $ Darcs.Patch.move old new :>: NilFL)+      moveFileOrDir work old new+      unsafeAddToPending repository pendingDiff+    void $ finalizeRepositoryChanges repository (O.dryRun ? opts)++-- Take the recorded/ working trees and the old and intended new filenames;+-- check if the new path is safe on windows. We potentially need to create+-- extra patches that are required to keep the repository consistent, in order+-- to allow the move patch to be applied.+generatePreMovePatches :: PrimPatch prim => [DarcsFlag] -> Tree IO -> Tree IO+                       -> (AnchoredPath, AnchoredPath)+                       -> IO (Maybe (FreeLeft (FL prim)))+generatePreMovePatches opts cur work (old,new) = do+    -- Only allow Windows-invalid paths if we've been told to do so+    unless newIsOkWindowsPath $ fail newNotOkWindowsPathMsg+    -- Check if the first directory above the new path is in the repo (this+    -- is the new path if itself is a directory), handling the case where+    -- a user moves a file into a directory not known by darcs.+    let dirPath =+          fromMaybe (error "unexpected root path in generatePreMovePatches") $ parent new+    haveNewParent <- treeHasDir cur dirPath+    unless haveNewParent $+        fail $ "The target directory " ++ displayPath dirPath+                ++ " isn't known in the repository, did you forget to add it?"+    newInRecorded <- hasNew cur+    newInWorking <- hasNew work+    oldInWorking <- treeHas work old+    if oldInWorking -- We need to move the object+        then do+            -- We can't move if the target already exists in working+            when newInWorking $ fail $ alreadyExists "working directory"+            if newInRecorded+                then Just <$> deleteNewFromRepoPatches+                else return Nothing+        else do+          putInfo opts $ text "Detected post-hoc move."+          -- Post-hoc move - user has moved/deleted the file in working, so+          -- we can hopefully make a move patch to make the repository+          -- consistent.+          -- If we don't have the old or new in working, we're stuck+          unless newInWorking $+              fail $ "Cannot determine post-hoc move target, "+                     ++ "no file/dir named:\n" ++ displayPath new+          Just <$> if newInRecorded+                       then deleteNewFromRepoPatches+                       else return $ emptyGap NilFL+  where+    newIsOkWindowsPath =+        allowWindowsReservedFilenames ? opts || WindowsFilePath.isValid (realPath new)++    newNotOkWindowsPathMsg =+        "The filename " ++ displayPath new ++ " is not valid under Windows.\n"+        ++ "Use --reserved-ok to allow such filenames."++    -- If we're moving to a file/dir that was recorded, but has been deleted,+    -- we need to add patches to pending that remove the original.+    deleteNewFromRepoPatches = do+        putInfo opts $ text $+          "Existing recorded contents of " ++ displayPath new ++ " will be overwritten."+        ftf <- filetypeFunction+        let curNoNew = modifyTree cur new Nothing+        -- Return patches to remove new, so that the move patch+        -- can move onto new+        treeDiff MyersDiff ftf cur curNoNew++    -- Check if the passed tree has the new filepath. The old path is removed+    -- from the tree before checking if the new path is present.+    hasNew s = treeHas_case (modifyTree s old Nothing) new+    treeHas_case = if allowCaseDifferingFilenames ? opts then treeHas else treeHasAnycase++    alreadyExists inWhat =+        if allowCaseDifferingFilenames ? opts+            then "A file or dir named "++displayPath new++" already exists in "+                  ++ inWhat ++ "."+            else "A file or dir named "++displayPath new++" (or perhaps differing "+                 ++ "only in case)\nalready exists in "++ inWhat ++ ".\n"+                 ++ "Use --case-ok to allow files differing only in case."++moveFileOrDir :: Tree IO -> AnchoredPath -> AnchoredPath -> IO ()+moveFileOrDir work old new = do+  has_file <- treeHasFile work old+  has_dir <- treeHasDir work old+  when has_file $ do+    debugMessage $ unwords ["renameFile", displayPath old, displayPath new]+    renameFile (realPath old) (realPath new)+  when has_dir $ do+    debugMessage $ unwords ["renameDirectory", displayPath old, displayPath new]+    renameDirectory (realPath old) (realPath new)++mv :: DarcsCommand+mv = commandAlias "mv" Nothing move
+ src/Darcs/UI/Commands/Optimize.hs view
@@ -0,0 +1,568 @@+--  Copyright (C) 2003-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module Darcs.UI.Commands.Optimize ( optimize ) where++import Darcs.Prelude++import Control.Monad ( when, unless, forM_ )+import System.Directory+    ( listDirectory+    , doesDirectoryExist+    , renameFile+    , createDirectoryIfMissing+    , removeFile+    , removeDirectoryRecursive+    , withCurrentDirectory+    )+import Darcs.UI.Commands ( DarcsCommand(..), nodefaults+                         , amInHashedRepository, amInRepository, putInfo+                         , normalCommand, withStdOpts )+import Darcs.UI.Completion ( noArgs )+import Darcs.Repository.Prefs ( Pref(Defaultrepo), getPreflist, globalCacheDir )+import Darcs.Repository+    ( Repository+    , AccessType(RW)+    , repoLocation+    , withRepoLock+    , RepoJob(..)+    , readPatches+    , reorderInventory+    , cleanRepository+    )+import Darcs.Repository.Job ( withOldRepoLock )+import Darcs.Repository.Traverse ( specialPatches )+import Darcs.Repository.Paths+    ( formatPath+    , inventoriesDir+    , inventoriesDirPath+    , oldCheckpointDirPath+    , oldCurrentDirPath+    , oldInventoryPath+    , oldPristineDirPath+    , oldTentativeInventoryPath+    , patchesDir+    , patchesDirPath+    , pristineDir+    , pristineDirPath+    , tentativePristinePath+    )+import Darcs.Repository.Packs ( createPacks )+import Darcs.Patch.Witnesses.Ordered ( lengthRL )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Invertible ( mkInvertible )+import Darcs.Patch.Set+    ( patchSet2RL+    , patchSet2FL+    , progressPatchSet+    )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Printer ( Doc, formatWords, wrapText, ($+$) )+import Darcs.Util.Lock+    ( maybeRelink+    , gzWriteAtomicFilePS+    , writeAtomicFilePS+    , removeFileMayNotExist+    , writeBinFile+    )+import Darcs.Util.File ( doesDirectoryReallyExist )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.Progress+    ( beginTedious+    , endTedious+    , tediousSize+    , debugMessage+    )++import System.FilePath.Posix+    ( takeExtension+    , (</>)+    , joinPath+    )+import Text.Printf ( printf )+import Darcs.UI.Flags+    (  DarcsFlag, useCache, umask )+import Darcs.UI.Options ( DarcsOption, (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags+    ( PatchFormat(PatchFormat1)+    , UMask(..)+    , WithWorkingDir(WithWorkingDir)+    )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Util.Cache ( allHashedDirs, bucketFolder, cleanCaches, mkDirCache )+import Darcs.Repository.Format+    ( identifyRepoFormat+    , createRepoFormat+    , unsafeWriteRepoFormat+    , formatHas+    , RepoProperty ( HashedInventory )+    )+import Darcs.Repository.PatchIndex+import Darcs.Repository.Hashed+    ( writeTentativeInventory+    , finalizeTentativeChanges+    )+import Darcs.Repository.InternalTypes ( repoCache, unsafeCoerceR )+import Darcs.Repository.Pristine+    ( applyToTentativePristine+    )++import Darcs.Util.Tree+    ( Tree+    , TreeItem(..)+    , list+    , expand+    , emptyTree+    )+import Darcs.Util.Path ( AbsolutePath, realPath, toFilePath )+import Darcs.Util.Tree.Plain( readPlainTree )+import Darcs.Util.Tree.Hashed ( writeDarcsHashed )++optimizeDescription :: String+optimizeDescription = "Optimize the repository."++optimizeHelp :: Doc+optimizeHelp = formatWords+  [ "The `darcs optimize` command modifies internal data structures of"+  , "the current repository in an attempt to reduce its resource requirements."+  ]+  $+$ "For further details see the descriptions of the subcommands."++optimize :: DarcsCommand+optimize = SuperCommand {+      commandProgramName = "darcs"+    , commandName = "optimize"+    , commandHelp = optimizeHelp+    , commandDescription = optimizeDescription+    , commandPrereq = amInRepository+    , commandSubCommands = [  normalCommand optimizeClean,+                              normalCommand optimizeHttp,+                              normalCommand optimizeReorder,+                              normalCommand optimizeEnablePatchIndex,+                              normalCommand optimizeDisablePatchIndex,+                              normalCommand optimizeCompress,+                              normalCommand optimizeUncompress,+                              normalCommand optimizeRelink,+                              normalCommand optimizeUpgrade,+                              normalCommand optimizeGlobalCache+                           ]+    }++commonBasicOpts :: DarcsOption a (Maybe String -> a)+commonBasicOpts = O.repoDir++commonAdvancedOpts :: DarcsOption a (UMask -> a)+commonAdvancedOpts = O.umask++common :: DarcsCommand+common = DarcsCommand+    { commandProgramName = "darcs"+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandPrereq =  amInHashedRepository+    , commandArgdefaults = nodefaults+    , commandName = undefined+    , commandHelp = undefined+    , commandDescription = undefined+    , commandCommand =  undefined+    , commandCompleteArgs = noArgs+    , commandOptions = commonOpts+    }+  where+    commonOpts = commonBasicOpts `withStdOpts` commonAdvancedOpts+++optimizeClean :: DarcsCommand+optimizeClean = common+    { commandName = "clean"+    , commandDescription = "Garbage collect pristine, inventories and patches"+    , commandHelp = optimizeHelpClean+    , commandCommand = optimizeCleanCmd+    }++optimizeCleanCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeCleanCmd _ opts _ =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repository -> do+      cleanRepository repository+      putInfo opts "Done cleaning repository!"++optimizeUpgrade :: DarcsCommand+optimizeUpgrade = common+    { commandName = "upgrade"+    , commandHelp = wrapText 80+        "Convert old-fashioned repositories to the current default hashed format."+    , commandDescription = "Upgrade repository to latest compatible format"+    , commandPrereq = amInRepository+    , commandCommand = optimizeUpgradeCmd+    , commandOptions =+        withStdOpts commonBasicOpts commonAdvancedOpts+    }++optimizeHttp :: DarcsCommand+optimizeHttp = common+    { commandName = "http"+    , commandHelp = optimizeHelpHttp+    , commandDescription = "Optimize repository for getting over network"+    , commandCommand = optimizeHttpCmd+    }++optimizeHttpCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeHttpCmd _ opts _ =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repository -> do+      cleanRepository repository+      createPacks repository+      putInfo opts "Done creating packs!"++optimizeCompress :: DarcsCommand+optimizeCompress = common+    { commandName = "compress"+    , commandHelp = optimizeHelpCompression+    , commandDescription = "Compress hashed files"+    , commandCommand = optimizeCompressCmd+    }++optimizeUncompress :: DarcsCommand+optimizeUncompress = common+    { commandName = "uncompress"+    , commandHelp = optimizeHelpCompression+    , commandDescription = "Uncompress hashed files (for debugging)"+    , commandCommand = optimizeUncompressCmd+    }++optimizeCompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeCompressCmd _ opts _ =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repository -> do+      cleanRepository repository+      optimizeCompression O.GzipCompression opts+      putInfo opts "Done optimizing by compression!"++optimizeUncompressCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeUncompressCmd _ opts _ =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repository -> do+      cleanRepository repository+      optimizeCompression O.NoCompression opts+      putInfo opts "Done uncompressing hashed files."++optimizeCompression :: O.Compression -> [DarcsFlag] -> IO ()+optimizeCompression compression opts = do+    putInfo opts "Optimizing (un)compression of patches..."+    do_compress patchesDirPath+    putInfo opts "Optimizing (un)compression of inventories..."+    do_compress inventoriesDirPath+    putInfo opts "Optimizing (un)compression of pristine..."+    do_compress pristineDirPath+    where+      do_compress f = do+        isd <- doesDirectoryExist f+        if isd+          then withCurrentDirectory f $ do+                 fs <- filter (`notElem` specialPatches) <$> listDirectory "."+                 mapM_ do_compress fs+          else gzReadFilePS f >>=+               case compression of+                 O.GzipCompression -> gzWriteAtomicFilePS f+                 O.NoCompression -> writeAtomicFilePS f++optimizeEnablePatchIndex :: DarcsCommand+optimizeEnablePatchIndex = common+    { commandName = "enable-patch-index"+    , commandHelp = formatWords+        [ "Build the patch index, an internal data structure that accelerates"+        , "commands that need to know what patches touch a given file. Such as"+        , "annotate and log."+        ]+    , commandDescription = "Enable patch index"+    , commandCommand = optimizeEnablePatchIndexCmd+    }++optimizeDisablePatchIndex :: DarcsCommand+optimizeDisablePatchIndex = common+    { commandName = "disable-patch-index"+    , commandHelp = wrapText 80+        "Delete and stop maintaining the patch index from the repository."+    , commandDescription = "Disable patch index"+    , commandCommand = optimizeDisablePatchIndexCmd+    }++optimizeEnablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeEnablePatchIndexCmd _ opts _ =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repository -> do+      ps <- readPatches repository+      createOrUpdatePatchIndexDisk repository ps+      putInfo opts "Done enabling patch index!"++optimizeDisablePatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeDisablePatchIndexCmd _ opts _ =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repo -> do+      deletePatchIndex (repoLocation repo)+      putInfo opts "Done disabling patch index!"++optimizeReorder :: DarcsCommand+optimizeReorder = common+    { commandName = "reorder"+    , commandHelp = formatWords+        [ "This command moves recent patches (those not included in"+        , "the latest tag) to the \"front\", reducing the amount that a typical"+        , "remote command needs to download. It should also reduce the CPU time"+        , "needed for some operations. This is the behavior with --shallow"+        , "which is the default."+        ]+        $+$ formatWords+        [ "With the --deep option it tries to optimize all tags in the whole"+        , "repository. This breaks the history of patches into smaller"+        , "bunches, which can further improve efficiency, but requires all"+        , "patches to be present. It is therefore less suitable for lazy clones."+        ]+    , commandDescription = "Reorder the patches in the repository"+    , commandCommand = optimizeReorderCmd+    , commandOptions =+        withStdOpts basicOpts commonAdvancedOpts+    }+  where+    basicOpts = commonBasicOpts ^ O.optimizeDeep++optimizeReorderCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeReorderCmd _ opts _ =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repository -> do+      reorderInventory repository (O.optimizeDeep ? opts)+      putInfo opts "Done reordering!"++optimizeRelink :: DarcsCommand+optimizeRelink = common+    { commandName = "relink"+    , commandHelp = optimizeHelpRelink +    , commandDescription = "Replace copies of hashed files with hard links"+    , commandCommand = optimizeRelinkCmd+    , commandOptions = optimizeRelinkOpts+    }+  where+    optimizeRelinkBasicOpts = commonBasicOpts ^ O.siblings+    optimizeRelinkOpts = optimizeRelinkBasicOpts `withStdOpts` commonAdvancedOpts++optimizeRelinkCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeRelinkCmd _ opts _ =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repository -> do+      cleanRepository repository+      doRelink opts+      putInfo opts "Done relinking!"++optimizeHelpHttp :: Doc+optimizeHelpHttp = formatWords+  [ "Using this option creates 'repository packs' that can dramatically"+  , "speed up performance when a user does a `darcs clone` of the repository"+  , "over HTTP. To make use of packs, the clients must have a darcs of at"+  , "least version 2.10."+  ]++optimizeHelpClean :: Doc+optimizeHelpClean = formatWords+  [ "Darcs normally does not delete hashed files that are no longer"+  , "referenced by the current repository state. This command can be"+  , "use to get rid of these files to save some disk space."+  ]++optimizeHelpCompression :: Doc+optimizeHelpCompression =+  formatWords+  [ "Patches, inventories, and pristine files are compressed with zlib"+  , "(RFC 1951) to reduce storage (and download) size."+  , "Older darcs versions allowed to store them"+  , "uncompressed, and darcs is still able to"+  , "read those files if they are not compressed."+  ]+  $+$ formatWords+  [ "The `darcs optimize uncompress` and `darcs optimize compress`"+  , "commands can be used to ensure existing patches in the current"+  , "repository are respectively uncompressed or compressed."+  ]++optimizeHelpRelink :: Doc+optimizeHelpRelink = +  formatWords+  [ "The `darcs optimize relink` command hard-links patches that the"+  , "current repository has in common with its peers.  Peers are those"+  , "repositories listed in `_darcs/prefs/sources`, or defined with the"+  , "`--sibling` option (which can be used multiple times)."+  ]+  $+$ formatWords+  [ "Darcs uses hard-links automatically, so this command is rarely needed."+  , "It is most useful if you used `cp -r` instead of `darcs clone` to copy a"+  , "repository, or if you pulled the same patch from a remote repository"+  , "into multiple local repositories."+  ]++doRelink :: [DarcsFlag] -> IO ()+doRelink opts =+    do let some_siblings = O.siblings ? opts+       defrepolist <- getPreflist Defaultrepo+       let siblings = map toFilePath some_siblings ++ defrepolist+       if null siblings+          then putInfo opts "No siblings -- no relinking done."+          else do debugMessage "Relinking patches..."+                  patch_tree <- expand =<< readPlainTree patchesDirPath+                  let patches = [ realPath p | (p, File _) <- list patch_tree ]+                  maybeRelinkFiles siblings patches patchesDirPath+                  debugMessage "Done relinking."++maybeRelinkFiles :: [String] -> [String] -> String -> IO ()+maybeRelinkFiles src dst dir =+    mapM_ (maybeRelinkFile src . ((dir ++ "/") ++)) dst++maybeRelinkFile :: [String] -> String -> IO ()+maybeRelinkFile [] _ = return ()+maybeRelinkFile (h:t) f =+    do done <- maybeRelink (h ++ "/" ++ f) f+       unless done $+           maybeRelinkFile t f++-- Only 'optimize' commands that works on old-fashionned repositories+optimizeUpgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeUpgradeCmd _ opts _ = do+  rf <- identifyRepoFormat "."+  debugMessage "Found our format"+  if formatHas HashedInventory rf+     then putInfo opts "No action taken because this repository already is hashed."+     else do putInfo opts "Upgrading to hashed..."+             withOldRepoLock $ RepoJob $ actuallyUpgradeFormat opts++actuallyUpgradeFormat+  :: (RepoPatch p, ApplyState p ~ Tree)+  => [DarcsFlag] -> Repository 'RW p wU wR -> IO ()+actuallyUpgradeFormat _opts _repository = do+  -- convert patches/inventory+  patches <- readPatches _repository+  let k = "Hashing patch"+  beginTedious k+  tediousSize k (lengthRL $ patchSet2RL patches)+  let patches' = progressPatchSet k patches+  writeTentativeInventory _repository patches'+  endTedious k+  -- convert pristine by applying patches+  -- the faster alternative would be to copy pristine, but the apply method+  -- is more reliable+  -- TODO we should do both and then comapre them+  let patchesToApply = progressFL "Applying patch" $ patchSet2FL patches'+  createDirectoryIfMissing False pristineDirPath+  -- We ignore the returned root hash, we don't use it.+  _ <- writeDarcsHashed emptyTree (repoCache _repository)+  writeBinFile tentativePristinePath ""+  -- we must coerce here because we just emptied out pristine+  applyToTentativePristine (unsafeCoerceR _repository) (mkInvertible patchesToApply)+  -- now make it official+  finalizeTentativeChanges _repository+  unsafeWriteRepoFormat (createRepoFormat PatchFormat1 WithWorkingDir) formatPath+  -- clean out old-fashioned junk+  debugMessage "Cleaning out old-fashioned repository files..."+  removeFileMayNotExist oldInventoryPath+  removeFileMayNotExist oldTentativeInventoryPath+  removeDirectoryRecursive oldPristineDirPath+    `catchall` removeDirectoryRecursive oldCurrentDirPath+  rmGzsIn patchesDirPath+  rmGzsIn inventoriesDirPath+  hasCheckPoints <- doesDirectoryExist oldCheckpointDirPath+  when hasCheckPoints $ removeDirectoryRecursive oldCheckpointDirPath+ where+  rmGzsIn dir =+    withCurrentDirectory dir $ do+      gzs <- filter ((== ".gz") . takeExtension) `fmap` listDirectory "."+      mapM_ removeFile gzs++optimizeBucketed :: [DarcsFlag] -> IO ()+optimizeBucketed opts = do+  putInfo opts "Migrating global cache to bucketed format."+  gCacheDir <- globalCacheDir++  case gCacheDir of+    Nothing -> fail "New global cache doesn't exist."+    Just gCacheDir' -> do+      let gCachePristineDir = joinPath [gCacheDir', pristineDir]+          gCacheInventoriesDir = joinPath [gCacheDir', inventoriesDir]+          gCachePatchesDir = joinPath [gCacheDir', patchesDir]+      debugMessage "Making bucketed cache from new cache."+      toBucketed gCachePristineDir gCachePristineDir+      toBucketed gCacheInventoriesDir gCacheInventoriesDir+      toBucketed gCachePatchesDir gCachePatchesDir+      putInfo opts "Done making bucketed cache!"+  where+    toBucketed :: FilePath -> FilePath -> IO ()+    toBucketed src dest = do+      srcExist <- doesDirectoryExist src+      if srcExist+        then  do+                debugMessage $ "Making " ++ src ++ " bucketed in " ++ dest+                forM_ subDirSet $ \subDir ->+                  createDirectoryIfMissing True (dest </> subDir)+                fileNames <- listDirectory src+                forM_ fileNames $ \file -> do+                  exists <- doesDirectoryReallyExist (src </> file)+                  if not $ exists+                    then renameFile' src dest file+                    else return ()+        else do+          debugMessage $ show src ++ " didn't exist, doing nothing."+          return ()++    renameFile' :: FilePath -> FilePath -> FilePath -> IO ()+    renameFile' s d f = renameFile (s </> f) (joinPath [d, bucketFolder f, f])++    subDirSet :: [String]+    subDirSet = map toStrHex [0..255]++    toStrHex :: Int -> String+    toStrHex = printf "%02x"+++optimizeGlobalCache :: DarcsCommand+optimizeGlobalCache = common+    { commandName = "cache"+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandHelp = optimizeHelpGlobalCache+    , commandDescription = "Garbage collect global cache"+    , commandCommand = optimizeGlobalCacheCmd+    , commandPrereq = \_ -> return $ Right ()+    }++optimizeHelpGlobalCache :: Doc+optimizeHelpGlobalCache = formatWords+  [ "This command deletes obsolete files within the global cache."+  ]+  $+$ formatWords+  [ "It also automatically migrates the global cache to the (default)"+  , "bucketed format."+  ]++optimizeGlobalCacheCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+optimizeGlobalCacheCmd _ opts _ = do+  optimizeBucketed opts+  globalCacheDir >>= \case+    Just dir -> mapM_ (cleanCaches (mkDirCache dir)) allHashedDirs+    Nothing -> return ()+  putInfo opts "Done cleaning global cache!"
+ src/Darcs/UI/Commands/Pull.hs view
@@ -0,0 +1,368 @@+--  Copyright (C) 2002-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.Pull ( -- * Commands.+                                pull, fetch,+                                pullCmd, StandardPatchApplier,+                                -- * Utility functions.+                                fetchPatches+                              ) where++import Darcs.Prelude++import System.Exit ( exitSuccess )+import Control.Monad ( when, unless, (>=>) )+import Data.List ( nub )+import Data.Maybe ( fromMaybe )+import Safe ( headErr, tailErr )++import Darcs.UI.Commands+    ( DarcsCommand(..)+    , withStdOpts+    , putInfo+    , putVerbose+    , setEnvDarcsPatches+    , defaultRepo+    , amInHashedRepository+    )+import Darcs.UI.Commands.Clone ( otherHelpInheritDefault )+import Darcs.UI.Flags+    ( DarcsFlag+    , fixUrl, getOutput+    , changesReverse, verbosity,  dryRun, umask, useCache, selectDeps+    , reorder, setDefault+    , hasXmlOutput+    , isInteractive, quiet+    )+import Darcs.UI.Options ( parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository+    ( Repository+    , AccessType(..)+    , identifyRepositoryFor+    , ReadingOrWriting(..)+    , withRepoLock+    , RepoJob(..)+    , readPatches+    , modifyCache+    , mkCache+    , cacheEntries+    , CacheLoc(..)+    , WritableOrNot(..)+    , CacheType(..)+    , filterOutConflicts+    )++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefully, patchDesc )+import Darcs.Patch ( RepoPatch, description )+import qualified Darcs.Patch.Bundle as Bundle ( makeBundle )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Set ( PatchSet, Origin, emptyPatchSet, SealedPatchSet )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), seal )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..), FL(..), Fork(..)+    , mapFL, nullFL, mapFL_FL )+import Darcs.Patch.Permutations ( partitionFL )+import Darcs.Repository.Prefs+    ( Pref(Defaultrepo, Repos)+    , addRepoSource+    , addToPreflist+    , getPreflist+    , showMotd+    )+import Darcs.Patch.Depends+    ( findCommon+    , findCommonWithThem+    , patchSetIntersection+    , patchSetUnion+    )+import Darcs.UI.ApplyPatches ( PatchApplier(..), StandardPatchApplier(..) )+import Darcs.UI.Completion ( prefArgs )+import Darcs.UI.Commands.Util ( checkUnrelatedRepos, getUniqueDPatchName )+import Darcs.UI.SelectChanges+    ( WhichChanges(..)+    , runSelection+    , selectionConfig+    )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , ($+$)+    , (<+>)+    , formatWords+    , hsep+    , putDoc+    , quoted+    , text+    , vcat+    )+import Darcs.Util.Lock ( writeDocBinFile )+import Darcs.Util.Path ( useAbsoluteOrStd, stdOut, AbsolutePath )+import Darcs.Util.Workaround ( getCurrentDirectory )+import Darcs.Util.Tree( Tree )++pullDescription :: String+pullDescription =+ "Copy and apply patches from another repository to this one."++fetchDescription :: String+fetchDescription =+ "Fetch patches from another repository, but don't apply them."++pullHelp :: Doc+pullHelp =+  formatWords+  [ "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 accepts arguments, which are"+  , "URLs from which to pull, and when called without an argument, pull will"+  , "use the repository specified at `_darcs/prefs/defaultrepo`."+  ]+  $+$ formatWords+  [ "The default (`--union`) behavior is to pull any patches that are in any of"+  , "the specified repositories.  If you specify the `--intersection` flag, darcs"+  , "will only pull those patches which are present in all source repositories."+  , "If you specify the `--complement` flag, darcs will only pull elements in the"+  , "first repository that do not exist in any of the remaining repositories."+  ]+  $+$ formatWords+  [ "If `--reorder` is supplied, the set of patches that exist only in the current"+  , "repository is brought at the top of the current history. This will work even"+  , "if there are no new patches to pull."+  ]+  $+$ otherHelpInheritDefault+  $+$ formatWords+  [ "See `darcs help apply` for detailed description of many options."+  ]++fetchHelp :: Doc+fetchHelp =+  formatWords+  [ "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`."+  ]+  $+$ formatWords+  [ "Fetch's behaviour is essentially similar to pull's, so please consult"+  , "the help of `pull` to know more."+  ]++fetch :: DarcsCommand+fetch = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "fetch"+    , commandHelp = fetchHelp+    , commandDescription = fetchDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[REPOSITORY]..."]+    , commandCommand = fetchCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = prefArgs Repos+    , commandArgdefaults = defaultRepo+    , commandOptions = allOpts+    }+  where+    basicOpts+      = O.matchSeveral+      ^ O.interactive -- True+      ^ O.dryRun+      ^ O.withSummary+      ^ O.selectDeps+      ^ O.setDefault+      ^ O.inheritDefault+      ^ O.repoDir+      ^ O.output+      ^ O.allowUnrelatedRepos+      ^ O.diffAlgorithm+    advancedOpts+      = O.repoCombinator+      ^ O.remoteDarcs+    allOpts = basicOpts `withStdOpts` advancedOpts++pull :: DarcsCommand+pull = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "pull"+    , commandHelp = pullHelp+    , commandDescription = pullDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[REPOSITORY]..."]+    , commandCommand = pullCmd StandardPatchApplier+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = prefArgs Repos+    , commandArgdefaults = defaultRepo+    , commandOptions = allOpts+    }+  where+    basicOpts+      = O.matchSeveral+      ^ O.reorder+      ^ O.interactive+      ^ O.conflictsYes+      ^ O.testChanges+      ^ O.dryRunXml+      ^ O.withSummary+      ^ O.selectDeps+      ^ O.setDefault+      ^ O.inheritDefault+      ^ O.repoDir+      ^ O.allowUnrelatedRepos+      ^ O.diffAlgorithm+    advancedOpts+      = O.repoCombinator+      ^ O.setScriptsExecutable+      ^ O.umask+      ^ O.changesReverse+      ^ O.pauseForGui+      ^ O.remoteDarcs+    allOpts = basicOpts `withStdOpts` advancedOpts++pullCmd+  :: PatchApplier pa+  => pa -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+pullCmd patchApplier (_,o) opts repos =+  do+    pullingFrom <- mapM (fixUrl o) repos+    withRepoLock (useCache ? opts) (umask ? opts) $+     repoJob patchApplier $ \patchProxy initRepo -> do+      let repository = modifyCache (addReposToCache pullingFrom) initRepo+      Sealed fork <- fetchPatches o opts repos "pull" repository+      applyPatches patchApplier patchProxy "pull" opts repository fork+    where+      addReposToCache repos' cache =+        mkCache $ [ toReadOnlyCache r | r <- repos' ] ++ cacheEntries cache+      toReadOnlyCache = Cache Repo NotWritable+++fetchCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+fetchCmd (_,o) opts repos =+    withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $+        fetchPatches o opts repos "fetch" >=> makeBundle opts++fetchPatches :: (RepoPatch p, ApplyState p ~ Tree)+             => AbsolutePath -> [DarcsFlag] -> [String] -> String+             -> Repository 'RW p wU wR+             -> IO (Sealed (Fork (PatchSet p)+                                 (FL (PatchInfoAnd p))+                                 (FL (PatchInfoAnd p)) Origin wR))+fetchPatches o opts unfixedrepourls@(_:_) jobname repository = do+  here <- getCurrentDirectory+  repourls <- (nub . filter (/= here)) `fmap` mapM (fixUrl o) unfixedrepourls+  -- Test to make sure we aren't trying to pull from the current repo+  when (null repourls) $+        fail "Can't pull from current repository!"+  old_default <- getPreflist Defaultrepo+  when (old_default == repourls && not (hasXmlOutput opts)) $+      let pulling = case dryRun ? opts of+                      O.YesDryRun -> "Would pull"+                      O.NoDryRun -> "Pulling"+      in  putInfo opts $ text pulling <+> "from" <+> hsep (map quoted repourls) <> "..."+  (Sealed them, Sealed compl) <- readRepos repository opts repourls+  addRepoSource (headErr repourls) (dryRun ? opts)+      (setDefault False opts) (O.inheritDefault ? opts) (isInteractive True opts)+  mapM_ (addToPreflist Repos) repourls+  unless (quiet opts || hasXmlOutput opts) $ mapM_ showMotd repourls+  us <- readPatches repository+  checkUnrelatedRepos (parseFlags O.allowUnrelatedRepos opts) us them++  Fork common us' them' <- return $ findCommon us them+  _ :> compl' <- return $ findCommonWithThem compl us++  let avoided = mapFL info compl'+  ps :> _ <- return $ partitionFL (not . (`elem` avoided) . info) them'+  putVerbose opts $+    case us' of+      (x@(_ :>: _)) ->+        text "We have the following new (to them) patches:" $$+        vcat (mapFL description x)+      _ -> mempty+  unless (nullFL ps) $ putVerbose opts $+      text "They have the following patches to pull:" $$+      vcat (mapFL description ps)+  (hadConflicts, Sealed psFiltered)+    <- if O.conflictsYes ? opts == Nothing+        then filterOutConflicts repository (O.useIndex ? opts) us' ps+        else return (False, Sealed ps)+  when hadConflicts $ putInfo opts $ text "Skipping some patches which would cause conflicts."+  when (nullFL psFiltered) $ do putInfo opts $ text "No remote patches to pull in!"+                                setEnvDarcsPatches psFiltered+                                when (reorder ? opts /= O.Reorder) exitSuccess+  let direction = if changesReverse ? opts then FirstReversed else First+      selection_config = selectionConfig direction jobname (pullPatchSelOpts opts) Nothing Nothing+  (to_be_pulled :> _) <- runSelection psFiltered selection_config+  return (Sealed (Fork common us' to_be_pulled))++fetchPatches _ _ [] jobname _ = fail $+  "No default repository to " ++ jobname ++ " from, please specify one"++makeBundle :: forall p wR . (RepoPatch p, ApplyState p ~ Tree)+           => [DarcsFlag]+           -> (Sealed (Fork (PatchSet p)+                      (FL (PatchInfoAnd p))+                      (FL (PatchInfoAnd p)) Origin wR))+           -> IO ()+makeBundle opts (Sealed (Fork common _ to_be_fetched)) =+    do+      bundle <- Bundle.makeBundle Nothing common $+                 mapFL_FL hopefully to_be_fetched+      let fname = case to_be_fetched of+                    (x:>:_)-> getUniqueDPatchName $ patchDesc x+                    _ -> error "impossible case"+      o <- fromMaybe (return stdOut) (getOutput opts fname)+      useAbsoluteOrStd writeDocBinFile putDoc o bundle++{- Read in the specified pull-from repositories.  Perform+Intersection, Union, or Complement read.  In patch-theory terms+(stated in set algebra, where + is union and & is intersection+and \ is complement):++    Union =         ((R1 + R2 + ... + Rn) \ Rc)+    Intersection =  ((R1 & R2 & ... & Rn) \ Rc)+    Complement =    (R1 \ Rc) \ ((R2 + R3 + ... + Rn) \ Rc)++                        where Rc = local repo+                              R1 = 1st specified pull repo+                              R2, R3, Rn = other specified pull repo++Since Rc is not provided here yet, the result of readRepos is a+tuple: the first patchset(s) to be complemented against Rc and then+the second patchset(s) to be complemented against Rc.+-}++readRepos :: RepoPatch p+          => Repository rt p wU wR -> [DarcsFlag] -> [String]+          -> IO (SealedPatchSet p Origin,SealedPatchSet p Origin)+readRepos _ _ [] = error "impossible case"+readRepos to_repo opts us =+    do rs <- mapM (\u -> do r <- identifyRepositoryFor Reading to_repo (useCache ? opts) u+                            ps <- readPatches r+                            return $ seal ps) us+       return $ case parseFlags O.repoCombinator opts of+                  O.Intersection -> (patchSetIntersection rs, seal emptyPatchSet)+                  O.Complement -> (headErr rs, patchSetUnion $ tailErr rs)+                  O.Union -> (patchSetUnion rs, seal emptyPatchSet)++pullPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+pullPatchSelOpts flags = S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = parseFlags O.matchSeveral flags+    , S.interactive = isInteractive True flags+    , S.selectDeps = selectDeps ? flags+    , S.withSummary = O.withSummary ? flags+    }
+ src/Darcs/UI/Commands/Push.hs view
@@ -0,0 +1,320 @@+--  Copyright (C) 2002-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.Push ( push ) where++import Darcs.Prelude++import System.Exit ( exitWith, ExitCode( ExitSuccess, ExitFailure ), exitSuccess )+import Control.Monad ( when, unless )+import Data.Maybe ( isJust )+import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts+    , putVerbose+    , putInfo+    , putFinished+    , abortRun+    , setEnvDarcsPatches+    , defaultRepo+    , amInHashedRepository+    )+import Darcs.UI.Commands.Clone ( otherHelpInheritDefault )+import Darcs.UI.Commands.Util ( printDryRunMessageAndExit, checkUnrelatedRepos )+import Darcs.UI.Completion ( prefArgs )+import Darcs.UI.Flags+    ( DarcsFlag+    , isInteractive, verbosity+    , xmlOutput, selectDeps, applyAs+    , changesReverse, dryRun, useCache, setDefault, fixUrl )+import Darcs.UI.Options ( (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Flags ( DryRun (..) )+import qualified Darcs.Repository.Flags as R ( remoteDarcs )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully )+import Darcs.Repository+    ( RepoJob(..)+    , Repository+    , identifyRepositoryFor+    , ReadingOrWriting(..)+    , readPatches+    , withRepository+    )+import Darcs.Patch ( RepoPatch, description )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..), RL, FL, nullRL,+    nullFL, reverseFL, mapFL_FL, mapRL )+import Darcs.Repository.Prefs+    ( Pref(Defaultrepo, Repos)+    , addRepoSource+    , getPreflist+    )+import Darcs.UI.External ( signString, darcsProgram+                         , pipeDoc, pipeDocSSH )+import Darcs.Util.Exception ( die )+import Darcs.Util.URL ( isHttpUrl, isValidLocalPath+                      , isSshUrl, splitSshUrl, SshFilePath(..) )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.UI.SelectChanges+    ( WhichChanges(..)+    , selectionConfig+    , runSelection+    )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Patch.Depends ( findCommonWithThem, countUsThem )+import Darcs.Patch.Bundle ( makeBundle )+import Darcs.Patch.Show( ShowPatch )+import Darcs.Patch.Set ( PatchSet, Origin )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.Printer+    ( Doc+    , ($$)+    , ($+$)+    , (<+>)+    , empty+    , formatWords+    , quoted+    , text+    , vcat+    )+import Darcs.UI.Email ( makeEmail )+import Darcs.Util.English (englishNum, Noun(..))+import Darcs.Util.Workaround ( getCurrentDirectory )+import Darcs.Util.Tree( Tree )+++pushDescription :: String+pushDescription =+ "Copy and apply patches from this repository to another one."++pushHelp :: Doc+pushHelp =+  formatWords+    [ "Push is the opposite of pull.  Push allows you to copy patches from the"+    , "current repository into another repository."+    ]+  $+$ formatWords+    [ "The --reorder-patches option works in the same way as it does for pull"+    , "and apply: instead of placing the new patches (coming from your local"+    , "repository) on top of (i.e. after) the existing (remote) ones, it puts"+    , "the remote-only patches on top of the ones that you are pushing. This"+    , "can be useful, for instance, if you have recorded a tag locally and want"+    , "this tag to be clean in the remote repository after pushing."+    ]+  $+$ formatWords+    [ "If you give the `--apply-as` flag, darcs will use `sudo` to apply the"+    , "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,"+    , "inept or lazy users."+    ]+  $+$ formatWords+    [ "`darcs push` will compress the patch data before sending it to a remote"+    , "location via ssh. This works as long as the remote darcs is not older"+    , "than version 2.5. If you get errors that indicate a corrupt patch bundle,"+    , "you should try again with the `--no-compress` option."+    ]+  $+$+  otherHelpInheritDefault++push :: DarcsCommand+push = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "push"+    , commandHelp = pushHelp+    , commandDescription = pushDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[REPOSITORY]"]+    , commandCommand = pushCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = prefArgs Repos+    , commandArgdefaults = defaultRepo+    , commandOptions = pushOpts+    }+  where+    pushBasicOpts+      = O.matchSeveral+      ^ O.selectDeps+      ^ O.interactive+      ^ O.sign+      ^ O.dryRunXml+      ^ O.withSummary+      ^ O.repoDir+      ^ O.setDefault+      ^ O.inheritDefault+      ^ O.allowUnrelatedRepos+      ^ O.reorderPush+    pushAdvancedOpts+      = O.applyAs+      ^ O.changesReverse+      ^ O.compress+      ^ O.remoteDarcs+    pushOpts = pushBasicOpts `withStdOpts` pushAdvancedOpts++pushCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+pushCmd (_, o) opts [unfixedrepodir] = do+  repodir <- fixUrl o unfixedrepodir+  here <- getCurrentDirectory+  checkOptionsSanity opts repodir+  -- make sure we aren't trying to push to the current repo+  when (repodir == here) $ die "Cannot push from repository to itself."+  bundle <-+    withRepository (useCache ? opts) $ RepoJob $ prepareBundle opts repodir+  sbundle <- signString (O.sign ? opts) bundle+  let body =+        if isValidLocalPath repodir+          then sbundle+          else makeEmail repodir [] Nothing Nothing sbundle Nothing+  rval <- remoteApply opts repodir body+  case rval of+    ExitFailure ec -> do+      ePutDocLn (text "Apply failed!")+      exitWith (ExitFailure ec)+    ExitSuccess -> putFinished opts "pushing"+pushCmd _ _ [] = die "No default repository to push to, please specify one."+pushCmd _ _ _ = die "Cannot push to more than one repo."++prepareBundle :: (RepoPatch p, ApplyState p ~ Tree)+              => [DarcsFlag] -> String -> Repository rt p wU wR -> IO Doc+prepareBundle opts repodir repository = do+  old_default <- getPreflist Defaultrepo+  when (old_default == [repodir]) $+       let pushing = if dryRun ? opts == YesDryRun then "Would push" else "Pushing"+       in  putInfo opts $ text pushing <+> "to" <+> quoted repodir <> "..."+  them <- identifyRepositoryFor Writing repository (useCache ? opts) repodir >>= readPatches+  addRepoSource repodir (dryRun ? opts) (setDefault False opts)+      (O.inheritDefault ? opts) (isInteractive True opts)+  us <- readPatches repository+  common :> only_us <- return $ findCommonWithThem us them+  prePushChatter opts us (reverseFL only_us) them+  let direction = if changesReverse ? opts then FirstReversed else First+      selection_config = selectionConfig direction "push" (pushPatchSelOpts opts) Nothing Nothing+  runSelection only_us selection_config+                   >>= bundlePatches opts common++prePushChatter :: (RepoPatch p, ShowPatch a)+               => [DarcsFlag] -> PatchSet p Origin wX+               -> RL a wC wX -> PatchSet p Origin wY -> IO ()+prePushChatter opts us only_us them = do+  checkUnrelatedRepos (O.allowUnrelatedRepos ? opts) us them+  let num_to_pull = snd $ countUsThem us them+      pull_reminder = if num_to_pull > 0+                      then text $ "The remote repository has " ++ show num_to_pull+                      ++ " " ++ englishNum num_to_pull (Noun "patch") " to pull."+                      else empty+  putVerbose opts $ text "We have the following patches to push:" $$ vcat (mapRL description only_us)+  unless (nullRL only_us) $ putInfo opts pull_reminder+  when (nullRL only_us) $ do+      putInfo opts $ text "No recorded local patches to push!"+      exitSuccess++bundlePatches :: (RepoPatch p, ApplyState p ~ Tree)+              => [DarcsFlag] -> PatchSet p wA wZ+              -> (FL (PatchInfoAnd p) :> t) wZ wW+              -> IO Doc+bundlePatches opts common (to_be_pushed :> _) =+    do+      setEnvDarcsPatches to_be_pushed+      printDryRunMessageAndExit "push"+        (verbosity ? opts)+        (O.withSummary ? opts)+        (dryRun ? opts)+        (xmlOutput ? opts)+        (isInteractive True opts)+        to_be_pushed+      when (nullFL to_be_pushed) $ do+          putInfo opts $+            text "You don't want to push any patches, and that's fine with me!"+          exitSuccess+      makeBundle Nothing common (mapFL_FL hopefully to_be_pushed)++checkOptionsSanity :: [DarcsFlag] -> String -> IO ()+checkOptionsSanity opts repodir =+  if isHttpUrl repodir then do+       when (isJust $ applyAs ? opts) $+           abortRun opts $ text "Cannot --apply-as when pushing to URLs"+       let lprot = takeWhile (/= ':') repodir+           msg = text ("Pushing to "++lprot++" URLs is not supported.")+       abortRun opts msg+   else when (O.sign ? opts /= O.NoSign) $+        abortRun opts $ text "Signing doesn't make sense for local repositories or when pushing over ssh."+++pushPatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+pushPatchSelOpts flags = S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = O.matchSeveral ? flags+    , S.interactive = isInteractive True flags+    , S.selectDeps = selectDeps ? flags+    , S.withSummary = O.withSummary ? flags+    }++remoteApply :: [DarcsFlag] -> String -> Doc -> IO ExitCode+remoteApply opts repodir bundle+    = case applyAs ? opts of+        Nothing+            | isSshUrl repodir -> applyViaSsh opts (splitSshUrl repodir) bundle+            | otherwise -> applyViaLocal opts repodir bundle+        Just un+            | isSshUrl repodir -> applyViaSshAndSudo opts (splitSshUrl repodir) un bundle+            | otherwise -> applyViaSudo opts un repodir bundle++applyViaSudo :: [DarcsFlag] -> String -> String -> Doc -> IO ExitCode+applyViaSudo opts user repo bundle =+  darcsProgram >>= \darcs ->+    pipeDoc "sudo" ("-u" : user : darcs : darcsArgs opts repo) bundle++applyViaLocal :: [DarcsFlag] -> String -> Doc -> IO ExitCode+applyViaLocal opts repo bundle =+  darcsProgram >>= \darcs -> pipeDoc darcs (darcsArgs opts repo) bundle++applyViaSsh :: [DarcsFlag] -> SshFilePath -> Doc -> IO ExitCode+applyViaSsh opts repo =+  pipeDocSSH+    (O.compress ? opts)+    repo+    [ unwords $+        R.remoteDarcs (O.remoteDarcs ? opts) :+        darcsArgs opts (shellQuote (sshRepo repo))+    ]++applyViaSshAndSudo :: [DarcsFlag] -> SshFilePath -> String -> Doc -> IO ExitCode+applyViaSshAndSudo opts repo username =+  pipeDocSSH+    (O.compress ? opts)+    repo+    [ unwords $+        "sudo" : "-u" : username :+        R.remoteDarcs (O.remoteDarcs ? opts) :+        darcsArgs opts (shellQuote (sshRepo repo))+    ]++darcsArgs :: [DarcsFlag] -> String -> [String]+darcsArgs opts repodir = "apply" : standardFlags ++ reorderFlags ++ debugFlags+  where+    standardFlags = ["--all", "--repodir", repodir]+    reorderFlags = if O.yes (O.reorderPush ? opts) then ["--reorder-patches"] else []+    debugFlags = if O.debug ? opts then ["--debug"] else []++shellQuote :: String -> String+shellQuote s = "'" ++ escapeQuote s ++ "'"+  where+    escapeQuote [] = []+    escapeQuote cs@('\'':_) = '\\' : escapeQuote cs+    escapeQuote (c:cs) = c : escapeQuote cs
+ src/Darcs/UI/Commands/Rebase.hs view
@@ -0,0 +1,1124 @@+--  Copyright (C) 2009 Ganesh Sittampalam+--+--  BSD3++module Darcs.UI.Commands.Rebase ( rebase ) where++import Darcs.Prelude++import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts+    , normalCommand, hiddenCommand+    , commandAlias+    , defaultRepo, nodefaults+    , putInfo+    , amInHashedRepository+    )+import Darcs.UI.Commands.Apply ( applyCmd )+import Darcs.UI.Commands.Log ( changelog, logInfoFL )+import Darcs.UI.Commands.Pull ( pullCmd )+import Darcs.UI.Commands.Util ( historyEditHelp, preselectPatches )+import Darcs.UI.Completion ( Pref(Repos), fileArgs, prefArgs, noArgs )+import Darcs.UI.Flags+    ( DarcsFlag+    , allowConflicts+    , diffingOpts+    , reorder, verbosity+    , useCache, wantGuiPause+    , umask, changesReverse+    , diffAlgorithm, isInteractive+    , selectDeps, hasXmlOutput+    )+import qualified Darcs.UI.Flags as Flags ( getAuthor )+import Darcs.UI.Options ( oid, (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.PatchHeader+    ( AskAboutDeps(..)+    , HijackOptions(..)+    , HijackT+    , editLog+    , getAuthor+    , patchHeaderConfig+    , runHijackT+    , updatePatchHeader+    )+import Darcs.Repository+    ( Repository, RepoJob(..), AccessType(..), withRepoLock, withRepository+    , tentativelyAddPatches, finalizeRepositoryChanges+    , tentativelyRemovePatches, readPatches+    , setTentativePending, unrecordedChanges, applyToWorking+    )+import Darcs.Repository.Flags+    ( AllowConflicts(..)+    , ResolveConflicts(..)+    , UpdatePending(..)+    )+import Darcs.Repository.Merge ( tentativelyMergePatches )+import Darcs.Repository.Rebase+    ( checkHasRebase+    , readRebase+    , readTentativeRebase+    , writeTentativeRebase+    )+import Darcs.Repository.Resolution+    ( StandardResolution(..)+    , rebaseResolution+    , announceConflicts+    )+import Darcs.Repository.State ( updateIndex )+import Darcs.Repository.Transaction ( upgradeOldStyleRebase )++import Darcs.Patch ( PrimOf, invert, effect, commute, RepoPatch )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.CommuteFn ( commuterFLId, commuterIdFL )+import Darcs.Patch.Info ( displayPatchInfo, piName )+import Darcs.Patch.Match ( secondMatch, splitSecondFL )+import Darcs.Patch.Merge ( cleanMerge )+import Darcs.Patch.Named ( fmapFL_Named, patchcontents, patch2patchinfo )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, info, n2pia )+import Darcs.Patch.Prim ( canonizeFL, PrimPatch )+import Darcs.Patch.Rebase.Change+    ( RebaseChange(RC), rcToPia+    , extractRebaseChange, reifyRebaseChange+    , partitionUnconflicted+    , WithDroppedDeps(..), WDDNamed, commuterIdWDD+    , simplifyPush, simplifyPushes+    )+import Darcs.Patch.Rebase.Fixup+    ( RebaseFixup(..)+    , commuteNamedFixup+    , flToNamesPrims+    )+import Darcs.Patch.Rebase.Name ( RebaseName(..), commuteNameNamed )+import Darcs.Patch.Rebase.Suspended ( Suspended(..), addToEditsToSuspended )+import qualified Darcs.Patch.Rebase.Suspended as S ( simplifyPush )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanFL, partitionConflictingFL )+import Darcs.Patch.Progress ( progressRL )+import Darcs.Patch.Set ( PatchSet, Origin, patchSet2RL )+import Darcs.Patch.Split ( primSplitter )+import Darcs.UI.ApplyPatches+    ( PatchApplier(..)+    , PatchProxy(..)+    , applyPatchesStart+    , applyPatchesFinish+    )+import Darcs.UI.External ( viewDocWith )+import Darcs.UI.PrintPatch+    ( printContent+    , printContentWithPager+    , printFriendly+    , printSummary+    )+import Darcs.UI.Prompt ( PromptChoice(..), PromptConfig(..), runPrompt )+import Darcs.UI.SelectChanges+    ( runSelection, runInvertibleSelection+    , selectionConfig, selectionConfigGeneric, selectionConfigPrim+    , WhichChanges(First, Last, LastReversed)+    , viewChanges+    )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Patch.Witnesses.Eq ( EqCheck(..) )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), (+>+), mapFL_FL+    , concatFL, mapFL, nullFL, lengthFL, reverseFL+    , (:>)(..)+    , (:\/:)(..)+    , (:/\:)(..)+    , RL(..), reverseRL, mapRL_RL+    , Fork(..)+    , (+>>+)+    )+import Darcs.Patch.Witnesses.Sealed+    ( Sealed(..), seal, unseal+    , Sealed2(..)+    )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Util.English ( englishNum, Noun(Noun) )+import Darcs.Util.Printer+    ( text, redText+    , putDocLnWith, prefix+    , simplePrinters+    , formatWords+    , formatText+    , vcat+    , ($+$), ($$)+    )+import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.Path ( AbsolutePath )++import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Tree ( Tree )++import Control.Exception ( throwIO, try )+import Control.Monad ( unless, when, void )+import Control.Monad.Trans ( liftIO )+import System.Exit ( ExitCode(ExitSuccess), exitSuccess )++rebase :: DarcsCommand+rebase = SuperCommand+    { commandProgramName = "darcs"+    , commandName = "rebase"+    , commandHelp = rebaseHelp+    , commandDescription = rebaseDescription+    , commandPrereq = amInHashedRepository+    , commandSubCommands =+        [ normalCommand pull+        , normalCommand apply+        , normalCommand suspend+        , normalCommand unsuspend+        , normalCommand edit+        , hiddenCommand reify+        , hiddenCommand inject+        , normalCommand obliterate+        , normalCommand log+        , hiddenCommand changes+        , normalCommand upgrade+        ]+    }+  where+    rebaseDescription = "Edit several patches at once."+    rebaseHelp = formatText 80+      [ "The `darcs rebase' command is used to edit a collection of darcs patches."+      , "The basic idea is that you can suspend patches from the end of\+        \ a repository. These patches are no longer part of the history and\+        \ have no effect on the working tree. Suspended patches are invisible\+        \ to commands that access the repository from the outside, such as\+        \ push, pull, clone, send, etc."+      , "The sequence of suspended patches can be manipulated in ways that are\+        \ not allowed for normal patches. For instance, `darcs rebase obliterate`\+        \ allows you to remove a patch in this sequence, even if other suspended\+        \ patches depend on it. These other patches will as a result become\+        \ conflicted."+      , "You can also operate on the normal patches in the usual way. If you add\+        \ or remove normal patches, the suspended patches will be automatically\+        \ adapted to still apply to the pristine state, possibly becoming\+        \ conflicted in the course."+      , "Note that as soon as a patch gets suspended, it will irrevocably loose\+        \ its identity. This means that suspending a patch is subject to the\+        \ usual warnings about editing the history of your project."+      , "The opposite of suspending a patch is to unsuspend it.\+        \ This turns it back into a normal patch.\+        \ If the patch is conflicted as a result of previous operations on\+        \ either the normal patches or the suspended patches, unsuspending\+        \ will create appropriate conflict markup. Note, however, that the\+        \ unsuspended patch itself WILL NOT BE CONFLICTED itself. This means\+        \ that there is no way to re-generate the conflict markup. Once you\+        \ removed it, by editing files or using `darcs revert`, any information\+        \ about the conflict is lost."+      , "As long as you have suspended patches, darcs will display a short\+        \ message after each command to remind you that your patch editing\+        \ operation is still in progress."+      ]++suspend :: DarcsCommand+suspend = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "suspend"+    , commandHelp = text suspendDescription $+$ historyEditHelp+    , commandDescription = suspendDescription+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = suspendCmd+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = suspendOpts+    }+  where+    suspendBasicOpts+      = O.notInRemote+      ^ O.matchSeveralOrLast+      ^ O.selectDeps+      ^ O.interactive+      ^ O.withSummary+      ^ O.diffAlgorithm+    suspendAdvancedOpts+      = O.changesReverse+      ^ O.umask+    suspendOpts = suspendBasicOpts `withStdOpts` suspendAdvancedOpts+    suspendDescription =+      "Select patches to move into a suspended state at the end of the repo."++suspendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+suspendCmd _ opts _args =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    suspended <- readTentativeRebase _repository+    (_ :> candidates) <- preselectPatches opts _repository+    let direction = if changesReverse ? opts then Last else LastReversed+        selection_config = selectionConfig+                              direction "suspend" (patchSelOpts True opts) Nothing Nothing+    (_ :> psToSuspend) <-+        runSelection+            candidates+            selection_config+    when (nullFL psToSuspend) $ do+        putStrLn "No patches selected!"+        exitSuccess+    -- test all patches for hijacking and abort if rejected+    runHijackT RequestHijackPermission+        $ mapM_ (getAuthor "suspend" False Nothing)+        $ mapFL info psToSuspend+    (_repository, Sealed toWorking) <-+      doSuspend "suspend" opts _repository suspended psToSuspend+    withSignalsBlocked $ do+      void $ finalizeRepositoryChanges _repository (O.dryRun ? opts)+      unless (O.yes (O.dryRun ? opts)) $+        void $ applyToWorking _repository (verbosity ? opts) toWorking++doSuspend+    :: (RepoPatch p, ApplyState p ~ Tree)+    => String+    -> [DarcsFlag]+    -> Repository 'RW p wU wR+    -> Suspended p wR+    -> FL (PatchInfoAnd p) wX wR+    -> IO (Repository 'RW p wU wX, Sealed (FL (PrimOf p) wU))+doSuspend cmdname opts _repository suspended to_suspend = do+  unrecorded <- unrecordedChanges (diffingOpts opts) _repository Nothing+  case genCommuteWhatWeCanFL (commuterFLId commute) (effect to_suspend :> unrecorded) of+    unrecorded' :> to_suspend_after_unrecorded :> to_revert -> do+      effect_to_suspend <-+        case to_revert of+          NilFL -> return to_suspend_after_unrecorded+          _ ->+            if isInteractive True opts then do+              putStrLn $+                "These unrecorded changes conflict with the " ++ cmdname ++ ":"+              printFriendly O.Verbose O.NoSummary to_revert+              yes <- promptYorn "Do you want to revert these changes?"+              if yes then+                return $ to_suspend_after_unrecorded +>+ to_revert+              else do+                putStrLn $ "Okay, " ++ cmdname ++ " cancelled."+                exitSuccess+            else+              fail $+                "Can't suspend these patches without reverting some unrecorded changes."+      _repository <-+        tentativelyRemovePatches _repository NoUpdatePending to_suspend+      -- rely on sifting to commute out prims not belonging in pending:+      setTentativePending _repository unrecorded'+      new_suspended <-+        addToEditsToSuspended (O.diffAlgorithm ? opts)+          (mapFL_FL hopefully to_suspend) suspended+      writeTentativeRebase _repository new_suspended+      return (_repository, Sealed (invert effect_to_suspend))++unsuspend :: DarcsCommand+unsuspend = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "unsuspend"+    , commandHelp = text unsuspendDescription+    , commandDescription = unsuspendDescription+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = unsuspendCmd "unsuspend" False+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = unsuspendOpts+    }+  where+    unsuspendBasicOpts+      = O.conflictsYes+      ^ O.matchSeveralOrFirst+      ^ O.interactive+      ^ O.withSummary+      ^ O.author+      ^ O.selectAuthor+      ^ O.patchname+      ^ O.askDeps+      ^ O.askLongComment+      ^ O.keepDate+      ^ O.diffAlgorithm+    unsuspendOpts = unsuspendBasicOpts `withStdOpts` oid+    unsuspendDescription =+      "Select suspended patches to restore to the end of the repo."++reify :: DarcsCommand+reify = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "reify"+    , commandHelp = text reifyDescription+    , commandDescription = reifyDescription+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = unsuspendCmd "reify" True+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = reifyOpts+    }+  where+    reifyBasicOpts+      = O.matchSeveralOrFirst+      ^ O.interactive+      ^ O.withSummary+      ^ O.keepDate+      ^ O.author+      ^ O.diffAlgorithm+    reifyOpts = reifyBasicOpts `withStdOpts` O.umask+    reifyDescription =+      "Select suspended patches to restore to the end of the repo,\+      \ reifying any fixup patches."++unsuspendCmd :: String -> Bool -> (AbsolutePath, AbsolutePath)+             -> [DarcsFlag] -> [String] -> IO ()+unsuspendCmd cmd reifyFixups _ opts _args =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    checkHasRebase _repository+    Items suspended <- readTentativeRebase _repository++    let matchFlags = O.matchSeveralOrFirst ? opts+    inRange :> outOfRange <-+        return $+            if secondMatch matchFlags then+            splitSecondFL rcToPia matchFlags suspended+            else suspended :> NilFL++    offer :> dontoffer <-+        return $+            case O.conflictsYes ? opts of+              Nothing -> partitionUnconflicted inRange -- skip conflicts+              Just _ -> inRange :> NilRL++    let warnSkip NilRL = return ()+        warnSkip _ = putStrLn "Skipping some patches which would cause conflicts."++    warnSkip dontoffer++    let selection_config =+          selectionConfigGeneric rcToPia First cmd+            (patchSelOpts True opts) Nothing+    (chosen :> keep) <- runSelection offer selection_config+    when (nullFL chosen) $ do putStrLn "No patches selected!"+                              exitSuccess++    ps_to_unsuspend :> chosen_fixups <-+      if reifyFixups+        then do+          author <- Flags.getAuthor (O.author ? opts) False+          reifyRebaseChange author chosen+        else return $ extractRebaseChange (diffAlgorithm ? opts) chosen++    let ps_to_keep = simplifyPushes da chosen_fixups $+                     keep +>+ reverseRL dontoffer +>+ outOfRange++    context <- readPatches _repository++    let conflicts =+          rebaseResolution (patchSet2RL context) $+          progressRL "Examining patches for conflicts" $+          mapRL_RL wddPatch $+          reverseFL ps_to_unsuspend++    have_conflicts <- announceConflicts cmd (allowConflicts opts) conflicts+    debugMessage "Working out conflict markup..."+    Sealed resolution <-+      if have_conflicts then+        case O.conflictsYes ? opts of+          Just (YesAllowConflicts (ExternalMerge _)) ->+            error $ "external resolution for "++cmd++" not implemented yet"+          Just (YesAllowConflicts NoResolveConflicts) -> return $ seal NilFL+          Just (YesAllowConflicts MarkConflicts) -> return $ mangled conflicts+          Just NoAllowConflicts -> error "impossible" -- was handled in announceConflicts+          Nothing -> error "impossible"+      else return $ seal NilFL++    unrec <- unrecordedChanges (diffingOpts opts) _repository Nothing++    -- TODO should catch logfiles (fst value from updatePatchHeader) and+    -- clean them up as in AmendRecord+    -- Note: we can allow hijack attempts here without warning the user+    -- because we already asked about that on suspend time+    (unsuspended_ps, ps_to_keep') <-+      runHijackT IgnoreHijack $ handleUnsuspend ps_to_unsuspend (unseal Items ps_to_keep)+    _repository <-+      tentativelyAddPatches _repository NoUpdatePending unsuspended_ps+    let effect_unsuspended = concatFL (mapFL_FL effect unsuspended_ps)+    case cleanMerge (effect_unsuspended :\/: unrec) of+      Nothing ->+        fail $ "Can't "++cmd++" because there are conflicting unrecorded changes."+      Just (unrec' :/\: effect_unsuspended') ->+        case cleanMerge (resolution :\/: unrec') of+          Nothing ->+            fail $ "Can't "++cmd++" because there are conflicting unrecorded changes."+          Just (unrec'' :/\: resolution') -> do+            let effect_to_apply = effect_unsuspended' +>+ resolution'+            setTentativePending _repository (resolution +>+ unrec'')+            writeTentativeRebase _repository ps_to_keep'+            withSignalsBlocked $ do+              _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+              unless (O.yes (O.dryRun ? opts)) $+                void $ applyToWorking _repository (verbosity ? opts) effect_to_apply++    where da = diffAlgorithm ? opts++          handleUnsuspend+                 :: forall p wR wT. (RepoPatch p, ApplyState p ~ Tree)+                 => FL (WDDNamed p) wR wT+                 -> Suspended p wT+                 -> HijackT IO (FL (PatchInfoAnd p) wR wT, Suspended p wT)+          handleUnsuspend NilFL to_keep = return (NilFL, to_keep)+          handleUnsuspend (p :>: ps) to_keep = do+              case wddDependedOn p of+                  [] -> return ()+                  deps -> liftIO $ do+                      -- It might make sense to only print out this message+                      -- once, but we might find that the dropped dependencies+                      -- are interspersed with other output, e.g. if running+                      -- with --ask-deps+                      let indent n = prefix (replicate n ' ')+                      putDocLnWith fancyPrinters $+                        redText ("Dropping the following explicit " +++                          englishNum (length deps) (Noun "dependency") ":") $$+                        displayPatchInfo (patch2patchinfo (wddPatch p)) $$+                        indent 1 (redText "depended on:") $$+                        indent 2 (vcat (map displayPatchInfo deps))++              -- TODO should catch logfiles (fst value from updatePatchHeader)+              -- and clean them up as in AmendRecord+              -- TODO should also ask user to supply explicit dependencies as+              -- replacements for those that have been lost (if any, see above)+              p' <- snd <$> updatePatchHeader @p cmd+                      NoAskAboutDeps+                      (patchSelOpts True opts)+                      (patchHeaderConfig opts)+                      (fmapFL_Named effect (wddPatch p)) NilFL+              -- Create a rename that undoes the change we just made, so that the+              -- context of patch names match up in the following sequence. We don't+              -- track patch names properly in witnesses yet and so the rename appears+              -- to have a null effect on the context.+              --   p' :: WDDNamed p wR wR2+              --   rename :: RebaseName wR2 wR2+              --   ps :: FL (WDDNamed p) wR2 wT+              let rename :: RebaseName wR2 wR2+                  rename = Rename (info p') (patch2patchinfo (wddPatch p))+              -- push it through the remaining patches to fix them up, which should leave+              -- us with+              --   p' :: WDDNamed p wR wR2+              --   ps2 :: FL (WDDNamed p) wR2 wT2+              --   rename2 :: RebaseName wT2 wT2+              Just (ps2 :> (rename2 :: RebaseName wT2 wT2')) <-+                return $ commuterIdFL (commuterIdWDD commuteNameNamed) (rename :> ps)+              -- However the commute operation loses the information that the rename2 has+              -- a null effect on the context so we have to assert it manually.+              IsEq <- return (unsafeCoerceP IsEq :: EqCheck wT2 wT2')+              to_keep' <- return $ S.simplifyPush da (NameFixup rename2) to_keep+              (converted, to_keep'') <- handleUnsuspend ps2 to_keep'+              return (p' :>: converted, to_keep'')++inject :: DarcsCommand+inject = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "inject"+    , commandHelp = text injectDescription+    , commandDescription = injectDescription+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = injectCmd+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = injectOpts+    }+  where+    injectBasicOpts = O.keepDate ^ O.author ^ O.diffAlgorithm+    injectOpts = injectBasicOpts `withStdOpts` O.umask+    injectDescription =+      "Merge a change from the fixups of a patch into the patch itself."++injectCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+injectCmd _ opts _args =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $+    \(_repository :: Repository 'RW p wU wR) -> do+    checkHasRebase _repository+    Items selects <- readTentativeRebase _repository++    -- TODO this selection doesn't need to respect dependencies+    -- TODO we only want to select one patch: generalise withSelectedPatchFromList+    let selection_config =+          selectionConfigGeneric rcToPia First "inject into" (patchSelOpts True opts) Nothing+    (to_inject :> keep) <- runSelection selects selection_config++    let extractSingle :: FL (RebaseChange prim) wX wY -> RebaseChange prim wX wY+        extractSingle (rc :>: NilFL) = rc+        extractSingle _ = error "You must select precisely one patch!"++    rc <- return $ extractSingle to_inject+    Sealed new <- injectOne opts rc keep++    writeTentativeRebase _repository $ Items new+    void $ finalizeRepositoryChanges _repository (O.dryRun ? opts)++-- | Inject fixups into a 'RebaseChange' and update the remainder of the rebase+-- state. This is in 'IO' because it involves interactive selection of the+-- fixups to inject.+-- TODO: We currently offer only prim fixups, not name fixups, for injection. I+-- think it would make sense to extend this to name fixups, so the user can+-- explicitly resolve a lost dependency in cases where is clear that it won't+-- re-appear.+injectOne+  :: (PrimPatch prim, ApplyState prim ~ Tree)+  => [DarcsFlag]+  -> RebaseChange prim wX wY+  -> FL (RebaseChange prim) wY wZ+  -> IO (Sealed (FL (RebaseChange prim) wX))+injectOne opts (RC fixups toedit) rest_suspended = do+  name_fixups :> prim_fixups <- return $ flToNamesPrims fixups+  let prim_selection_config =+        selectionConfigPrim+          Last+          "inject"+          (patchSelOpts True opts)+          (Just (primSplitter (diffAlgorithm ? opts)))+          Nothing+  (rest_fixups :> injects) <-+    runInvertibleSelection prim_fixups prim_selection_config+  let da = diffAlgorithm ? opts+      toeditNew = fmapFL_Named (canonizeFL da . (injects +>+)) toedit+  return $+    unseal (simplifyPushes da (mapFL_FL NameFixup name_fixups)) $+    simplifyPushes da (mapFL_FL PrimFixup rest_fixups) $+    RC NilFL toeditNew :>: rest_suspended+++obliterate :: DarcsCommand+obliterate = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "obliterate"+    , commandHelp = text obliterateDescription+    , commandDescription = obliterateDescription+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = obliterateCmd+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = obliterateOpts+    }+  where+    obliterateBasicOpts = O.diffAlgorithm+    obliterateOpts = obliterateBasicOpts `withStdOpts` O.umask+    obliterateDescription =+      "Obliterate a patch that is currently suspended."++obliterateCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+obliterateCmd _ opts _args =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    checkHasRebase _repository+    Items selects <- readTentativeRebase _repository++    -- TODO this selection doesn't need to respect dependencies+    let selection_config = selectionConfigGeneric rcToPia First "obliterate" (obliteratePatchSelOpts opts) Nothing+    (chosen :> keep) <- runSelection selects selection_config+    when (nullFL chosen) $ do putStrLn "No patches selected!"+                              exitSuccess++    let ps_to_keep =+          foldSealedFL (obliterateOne (diffAlgorithm ? opts)) chosen (Sealed keep)+    writeTentativeRebase _repository (unseal Items ps_to_keep)++    void $ finalizeRepositoryChanges _repository (O.dryRun ? opts)++-- TODO: move to Darcs.Patch.Witnesses.Ordered ?+-- | Map a cons-like operation that may change the end state over an 'FL'.+-- Unfortunately this can't be generalized to 'foldrwFL', even though it has+-- exactly the same definition, because 'Sealed' doesn't have the right kind.+-- We could play with a newtype wrapper to fix this but the ensuing wrapping+-- and unwrapping would hardly make it clearer what's going on.+foldSealedFL+  :: (forall wA wB . p wA wB -> Sealed (q wB) -> Sealed (q wA))+  -> FL p wX wY -> Sealed (q wY) -> Sealed (q wX)+-- kind error: foldSealedFL = foldrwFL+foldSealedFL _ NilFL acc = acc+foldSealedFL f (p :>: ps) acc = f p (foldSealedFL f ps acc)++obliterateOne+  :: PrimPatch prim+  => O.DiffAlgorithm+  -> RebaseChange prim wX wY+  -> Sealed (FL (RebaseChange prim) wY)+  -> Sealed (FL (RebaseChange prim) wX)+obliterateOne da (RC fs e) =+  unseal (simplifyPushes da fs) .+  -- since Named doesn't have any witness context for the+  -- patch names, the AddName here will be inferred to be wX wX+  unseal (simplifyPush da (NameFixup (AddName (patch2patchinfo e)))) .+  unseal (simplifyPushes da (mapFL_FL PrimFixup (patchcontents e)))++edit :: DarcsCommand+edit = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "edit"+    , commandHelp = text description+    , commandDescription = description+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = editCmd+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = opts+    }+  where+    basicOpts = O.diffAlgorithm ^ O.withSummary+    opts = basicOpts `withStdOpts` O.umask+    description = "Edit suspended patches."++data EditState prim wX = EditState+  { count :: Int+  , index :: Int+  , patches :: Sealed ((RL (RebaseChange prim) :> FL (RebaseChange prim)) wX)+  }++data Edit prim wX = Edit+  { eWhat :: String+  , eState :: EditState prim wX+  }++editCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+editCmd _ opts _args =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    checkHasRebase _repository+    Items items <- readTentativeRebase _repository+    let initial_state =+          EditState+            { count = lengthFL items+            , index = 0+            , patches = Sealed (NilRL :> items)+            }+    Sealed items' <- interactiveEdit opts [] initial_state []+    writeTentativeRebase _repository (Items items')+    void $ finalizeRepositoryChanges _repository (O.dryRun ? opts)++interactiveEdit+  :: (PrimPatch prim, ApplyState prim ~ Tree)+  => [DarcsFlag]+  -> [Edit prim wR]     -- ^ stack of undone edits, for redo+  -> EditState prim wR  -- ^ current state+  -> [Edit prim wR]     -- ^ stack of past edits, for undo+  -> IO (Sealed (FL (RebaseChange prim) wR))+interactiveEdit opts redos s@EditState{..} undos =+  -- invariants:+  --  * the "todo" patches are empty only if the "done" patches are; formally:+  --      case patches of Sealed (done :> todo) -> nullFL todo ==> nullRL done+  case patches of+    Sealed (_ :> NilFL) -> prompt+    Sealed (_ :> p :>: _) -> defaultPrintFriendly p >> prompt+  where+    da = diffAlgorithm ? opts++    -- helper functions+    defaultPrintFriendly =+      liftIO . printFriendly (O.verbosity ? opts) (O.withSummary ? opts)++    -- common actions+    undo =+      case undos of+        [] -> error "impossible"+        e : undos' ->+          -- pop last state from undos, push current state onto redos+          interactiveEdit opts (Edit (eWhat e) s : redos) (eState e) undos'+    redo =+      case redos of+        [] -> error "impossible"+        e : redos' ->+          -- pop last state from redos, push current state onto undos+          interactiveEdit opts redos' (eState e) (Edit (eWhat e) s : undos)+    quit = do+      putInfo opts $ text "Okay, rebase edit cancelled."+      exitSuccess+    commit =+      case patches of+        Sealed (done :> todo) -> return $ Sealed (done +>>+ todo)+    list = mapM_ (putStrLn . eWhat) (reverse undos) >> prompt+    choicesCommon =+      [ PromptChoice 'q' True quit "quit, discard all edits"+      , PromptChoice 'd' True commit "done editing, commit"+      , PromptChoice 'l' True list "list edits made so far"+      , PromptChoice 'u' (not (null undos)) undo "undo previous edit"+      , PromptChoice 'r' (not (null redos)) redo "redo previously undone edit"+      ]++    prompt =+      case patches of+        Sealed (_ :> NilFL) -> -- empty rebase state+          runPrompt PromptConfig+            { pPrompt = "No more suspended patches. What shall I do?"+            , pVerb = "rebase edit"+            , pChoices = [choicesCommon]+            , pDefault = Nothing+            }+        Sealed (done :> todo@(p :>: todo')) -> -- non-empty rebase state+          runPrompt PromptConfig+            { pPrompt = "What shall I do with this patch? " +++                  "(" ++ show (index + 1) ++ "/" ++ show count ++ ")"+            , pVerb = "rebase edit"+            , pChoices = [choicesEdit, choicesCommon, choicesView, choicesNav]+            , pDefault = Nothing+            }+          where++            choicesEdit =+              [ PromptChoice 'o' True dropit "drop (obliterate, dissolve into fixups)"+              , PromptChoice 'e' True reword "edit name and/or long comment (log)"+              , PromptChoice 's' (index > 0) squash "squash with previous patch"+              , PromptChoice 'i' can_inject inject' "inject fixups"+              -- TODO+              -- , PromptChoice 'c' True ??? "select individual changes for editing"+              ]+            choicesView =+              [ PromptChoice 'v' True view "view this patch in full"+              , PromptChoice 'p' True pager "view this patch in full with pager"+              , PromptChoice 'y' True display "view this patch"+              , PromptChoice 'x' can_summarize summary+                "view a summary of this patch"+              ]+            choicesNav =+              [ PromptChoice 'n' (index + 1 < count) next "skip to next patch"+              , PromptChoice 'k' (index > 0) prev "back up to previous patch"+              , PromptChoice 'g' (index > 0) first "start over from the first patch"+              ]++            -- helper functions+            edit' op s' = do+              let what =+                    case p of RC _ np -> op ++ " " ++ piName (patch2patchinfo np)+              -- set new state s' and push the current one onto the undo stack+              -- discarding the redo stack+              interactiveEdit opts [] s' (Edit what s : undos)+            navigate s' =+              -- set new state s' with no undo or redo stack modification+              interactiveEdit opts redos s' undos++            can_summarize = not (O.yes (O.withSummary ? opts))+            can_inject = case p of (RC NilFL _) -> False; _ -> True++            -- editing+            dropit = do+              Sealed todo'' <- return $ obliterateOne da p (Sealed todo')+              edit' "drop  " s { count = count - 1 , patches = Sealed (done :> todo'') }+            inject' = do+              result <- try $ injectOne opts p todo'+              case result of+                Left ExitSuccess -> prompt+                Left e -> throwIO e+                Right (Sealed todo'') ->+                  edit' "inject" s { patches = Sealed (done :> todo'') }+            reword = do+              Sealed todo'' <- rewordOne da p todo'+              edit' "reword" s { patches = Sealed (done :> todo'') }+            squash =+              case done of+                NilRL -> error "impossible"+                done' :<: q ->+                  case squashOne da q p todo' of+                    Just (Sealed todo'') ->+                      -- this moves back by one so the new squashed patch is+                      -- selected; useful in case you now want to edit the+                      -- comment or look at the result+                      edit' "squash" s+                        { count = count - 1+                        , index = index - 1+                        , patches = Sealed (done' :> todo'')+                        }+                    Nothing -> do+                      putStrLn "Failed to commute fixups backward, try inject first."+                      prompt++            -- viewing+            view = printContent p >> prompt+            pager = printContentWithPager p >> prompt+            display = defaultPrintFriendly p >> prompt+            summary = printSummary p >> prompt++            -- navigation+            next =+              case todo' of+                NilFL -> error "impossible"+                _ ->+                  navigate+                    s { index = index + 1, patches = Sealed (done :<: p :> todo') }+            prev =+              case done of+                NilRL -> error "impossible"+                done' :<: p' ->+                  navigate+                    s { index = index - 1, patches = Sealed (done' :> p' :>: todo) }+            first =+              navigate s { index = 0, patches = Sealed (NilRL :> done +>>+ todo) }++-- | Squash second patch with first, updating the rest of the rebase state.+-- This can fail if the second patch has fixups that don't commute with the+-- contents of the first patch.+squashOne+  :: PrimPatch prim+  => O.DiffAlgorithm+  -> RebaseChange prim wX wY+  -> RebaseChange prim wY wZ+  -> FL (RebaseChange prim) wZ wW+  -> Maybe (Sealed (FL (RebaseChange prim) wX))+squashOne da (RC fs1 e1) (RC fs2 e2) rest = do+  fs2' :> e1' <- commuterIdFL commuteNamedFixup (e1 :> fs2)+  let e1'' = fmapFL_Named (canonizeFL da . (+>+ patchcontents e2)) e1'+      e2_name_fixup = NameFixup (AddName (patch2patchinfo e2))+  return $+    case simplifyPush da e2_name_fixup rest of+      Sealed rest' -> simplifyPushes da (fs1 +>+ fs2') (RC NilFL e1'' :>: rest')++rewordOne+  :: (PrimPatch prim, ApplyState prim ~ Tree)+  => O.DiffAlgorithm+  -> RebaseChange prim wX wY+  -> FL (RebaseChange prim) wY wZ+  -> IO (Sealed (FL (RebaseChange prim) wX))+rewordOne da (RC fs e) rest = do+  e' <- editLog e+  let rename = NameFixup $ Rename (patch2patchinfo e') (patch2patchinfo e)+  case simplifyPush da rename rest of+    Sealed rest' -> return $ Sealed $ RC fs e' :>: rest'++pull :: DarcsCommand+pull = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "pull"+    , commandHelp = text pullDescription+    , commandDescription = pullDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[REPOSITORY]..."]+    , commandCommand = pullCmd RebasePatchApplier+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = prefArgs Repos+    , commandArgdefaults = defaultRepo+    , commandOptions = pullOpts+    }+  where+    pullBasicOpts+      = O.matchSeveral+      ^ O.reorder+      ^ O.interactive+      ^ O.conflictsYes+      ^ O.testChanges+      ^ O.dryRunXml+      ^ O.withSummary+      ^ O.selectDeps+      ^ O.repoDir+      ^ O.allowUnrelatedRepos+      ^ O.diffAlgorithm+    pullAdvancedOpts+      = O.repoCombinator+      ^ O.setScriptsExecutable+      ^ O.umask+      ^ O.changesReverse+      ^ O.remoteDarcs+    pullOpts = pullBasicOpts `withStdOpts` pullAdvancedOpts+    pullDescription =+      "Copy and apply patches from another repository,\+      \ suspending any local patches that conflict."++stdindefault :: a -> [String] -> IO [String]+stdindefault _ [] = return ["-"]+stdindefault _ x = return x++apply :: DarcsCommand+apply = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "apply"+    , commandHelp = text applyDescription+    , commandDescription = applyDescription+    , commandExtraArgs = 1+    , commandExtraArgHelp = ["<PATCHFILE>"]+    , commandCommand = applyCmd RebasePatchApplier+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = fileArgs+    , commandArgdefaults = const stdindefault+    , commandOptions = applyOpts+    }+  where+    applyBasicOpts+      = O.verify+      ^ O.reorder+      ^ O.interactive+      ^ O.dryRunXml+      ^ O.matchSeveral+      ^ O.repoDir+      ^ O.diffAlgorithm+    applyAdvancedOpts+      = O.setScriptsExecutable+      ^ O.umask+      ^ O.changesReverse+      ^ O.pauseForGui+    applyOpts = applyBasicOpts `withStdOpts` applyAdvancedOpts+    applyDescription =+      "Apply a patch bundle, suspending any local patches that conflict."++data RebasePatchApplier = RebasePatchApplier++instance PatchApplier RebasePatchApplier where+    repoJob RebasePatchApplier f = RepoJob (f PatchProxy)+    applyPatches RebasePatchApplier PatchProxy = applyPatchesForRebaseCmd++applyPatchesForRebaseCmd+    :: forall p wR wU wZ+     . ( RepoPatch p, ApplyState p ~ Tree )+    => String+    -> [DarcsFlag]+    -> Repository 'RW p wU wR+    -> Fork (PatchSet p)+            (FL (PatchInfoAnd p))+            (FL (PatchInfoAnd p)) Origin wR wZ+    -> IO ()+applyPatchesForRebaseCmd cmdName opts _repository (Fork common us' to_be_applied) = do+    applyPatchesStart cmdName opts to_be_applied++    usOk :> usConflicted <- return $ partitionConflictingFL us' to_be_applied++    when (lengthFL usConflicted > 0) $+        putInfo opts $ text "The following local patches are in conflict:"++    -- TODO: we assume the options apply only to the main+    -- command, review if there are any we should keep+    let selection_config = selectionConfig LastReversed "suspend" applyPatchSelOpts Nothing Nothing++    (usKeep :> usToSuspend) <- runSelection usConflicted selection_config++    -- test all patches for hijacking and abort if rejected+    runHijackT RequestHijackPermission+        $ mapM_ (getAuthor "suspend" False Nothing)+        $ mapFL info usToSuspend++    suspended <- readTentativeRebase _repository++    (_repository, Sealed toWorking) <-+      doSuspend cmdName opts _repository suspended usToSuspend+    -- the new rebase patch containing the suspended patches is now in the repo+    -- and the suspended patches have been removed++    -- We must apply the suspend to working because tentativelyMergePatches+    -- calls unrecordedChanges. We also have to update the index, since that is+    -- used to filter the working tree (unless --ignore-times is in effect).+    updateIndex _repository+    _repository <- withSignalsBlocked $ do+        applyToWorking _repository (verbosity ? opts) toWorking++    Sealed pw <-+        tentativelyMergePatches+            _repository cmdName+            (allowConflicts opts)+            (wantGuiPause opts)+            (reorder ? opts) (diffingOpts opts)+            (Fork common (usOk +>+ usKeep) to_be_applied)++    applyPatchesFinish cmdName opts _repository pw (nullFL to_be_applied)++applyPatchSelOpts :: S.PatchSelectionOptions+applyPatchSelOpts = S.PatchSelectionOptions+    { S.verbosity = O.NormalVerbosity+    , S.matchFlags = []+    , S.interactive = True+    , S.selectDeps = O.PromptDeps -- option not supported, use default+    , S.withSummary = O.NoSummary+    }++obliteratePatchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+obliteratePatchSelOpts opts = (patchSelOpts True opts)+    { S.selectDeps = O.NoDeps+    }++patchSelOpts :: Bool -> [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts defInteractive flags = S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = O.matchSeveralOrLast ? flags+    , S.interactive = isInteractive defInteractive flags+    , S.selectDeps = selectDeps ? flags+    , S.withSummary = O.withSummary ? flags+    }++log :: DarcsCommand+log = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "log"+    , commandHelp = text logDescription+    , commandDescription = logDescription+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = logCmd+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = logOpts+    }+  where+    logBasicOpts = O.withSummary ^ O.interactive -- False+    logAdvancedOpts = oid+    logOpts = logBasicOpts `withStdOpts` logAdvancedOpts+    logDescription = "List the currently suspended changes."++logCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+logCmd _ opts _files =+    withRepository (useCache ? opts) $ RepoJob $ \_repository -> do+        checkHasRebase _repository+        Items ps <- readRebase _repository+        let psToShow = mapFL_FL n2pia ps+        if isInteractive False opts+            then viewChanges (patchSelOpts False opts) (mapFL Sealed2 psToShow)+            else do+                debugMessage "About to print the changes..."+                let printers = if hasXmlOutput opts then simplePrinters else fancyPrinters+                let logDoc = changelog opts (reverseFL psToShow) (logInfoFL psToShow)+                viewDocWith printers logDoc++-- | changes is an alias for log+changes :: DarcsCommand+changes = commandAlias "changes" Nothing log++upgrade :: DarcsCommand+upgrade = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "upgrade"+    , commandHelp = help+    , commandDescription = desc+    , commandPrereq = amInHashedRepository+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = upgradeCmd+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = opts+    }+  where+    basicOpts = oid+    opts = basicOpts `withStdOpts` O.umask+    desc = "Upgrade a repo with an old-style rebase in progress."+    help = text desc $+$ formatWords+      [ "Doing this means you won't be able to use darcs version < 2.15"+      , "with this repository until the rebase is finished."+      ]++upgradeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+upgradeCmd _ opts _args =+  withRepoLock (useCache ? opts) (umask ? opts) $ OldRebaseJob $ \repo ->+    upgradeOldStyleRebase repo++{-+TODO:++ - amend-record shows the diff between the conflicted state and the+   resolution, which is unhelpful+ - make aggregate commands+ - argument handling+ - what should happen to patch comment on unsuspend?+ - warn about suspending conflicts+ - indication of expected conflicts on unsuspend+    - why isn't ! when you do x accurate?+ - rebase pull/apply should suspend patches such that their order is not changed+ - amended patches will often be in both the target repo and in the rebase context, detect?+ - can we be more intelligent about conflict resolutions?+ - --all option to unsuspend+ - review other conflict options for unsuspend+ - darcs check should check integrity of rebase patch+ - review existence of reify and inject commands - bit of an internals hack+-}
+ src/Darcs/UI/Commands/Record.hs view
@@ -0,0 +1,353 @@+--  Copyright (C) 2002-2003 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}++module Darcs.UI.Commands.Record+    ( record+    , commit+    ) where++import Darcs.Prelude++import Control.Exception ( handleJust )+import Control.Monad ( unless, void, when )+import Data.Char ( ord )+import Data.Foldable ( traverse_ )+import System.Directory ( removeFile )+import System.Exit ( ExitCode(..), exitFailure, exitSuccess )++import Darcs.Patch ( PrimOf, RepoPatch, canonizeFL, summaryFL )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Depends ( contextPatches )+import Darcs.Patch.Info ( PatchInfo, patchinfo )+import Darcs.Patch.Named ( adddeps, infopatch )+import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch.Progress ( progressFL )+import Darcs.Patch.Split ( primSplitter )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..), nullFL, (+>+) )+import Darcs.Repository+    ( RepoJob(..)+    , Repository+    , AccessType(..)+    , finalizeRepositoryChanges+    , readPendingAndWorking+    , readPristine+    , readPatches+    , tentativelyAddPatch+    , tentativelyRemoveFromPW+    , withRepoLock+    )+import Darcs.Repository.Flags ( UpdatePending(..) )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , commandAlias+    , nodefaults+    , setEnvDarcsFiles+    , setEnvDarcsPatches+    , withStdOpts+    )+import Darcs.UI.Commands.Util+    ( announceFiles+    , filterExistingPaths+    , testTentativeAndMaybeExit+    )+import Darcs.UI.Completion ( modifiedFileArgs )+import Darcs.UI.Flags+    ( DarcsFlag+    , diffingOpts+    , fileHelpAuthor+    , getAuthor+    , getDate+    , pathSetFromArgs+    )+import Darcs.UI.Options ( Config, (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.PatchHeader ( getLog )+import Darcs.UI.SelectChanges+    ( WhichChanges(..)+    , askAboutDepends+    , runInvertibleSelection+    , selectionConfigPrim+    )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Util.Exception ( clarifyErrors )+import Darcs.Util.Global ( darcsLastMessage )+import Darcs.Util.Path ( AbsolutePath, AnchoredPath, displayPath )+import Darcs.Util.Printer+    ( Doc+    , formatWords+    , pathlist+    , putDocLn+    , text+    , vcat+    , vsep+    , ($+$)+    , (<+>)+    )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.Tree ( Tree )++recordHelp :: Doc+recordHelp =+  vsep (map formatWords+  [ [ "The `darcs record` command is used to create a patch from changes in"+    , "the working tree.  If you specify a set of files and directories,"+    , "changes to other files will be skipped."+    ]+  , [ "Every patch has a name, an optional description, an author and a date."+    ]+  , [ "Darcs will launch a text editor (see `darcs help environment`) after the"+    , "interactive selection, to let you enter the patch name (first line) and"+    , "the patch description (subsequent lines)."+    ]+  , [ "You can supply the patch name in advance with the `-m` option, in which"+    , "case no text editor is launched, unless you use `--edit-long-comment`."+    ]+  , [ "The patch description is an optional block of free-form text.  It is"+    , "used to supply additional information that doesn't fit in the patch"+    , "name.  For example, it might include a rationale of WHY the change was"+    , "necessary."+    ]+  , [ "A technical difference between patch name and patch description, is"+    , "that matching with the flag `-p` is only done on patch names."+    ]+  , [ "Finally, the `--logfile` option allows you to supply a file that already"+    , "contains the patch name and description.  This is useful if a previous"+    , "record failed and left a `_darcs/patch_description.txt` file."+    ]+  , fileHelpAuthor+  , [ "If you want to manually define any explicit dependencies for your patch,"+    , "you can use the `--ask-deps` flag. Some dependencies may be automatically"+    , "inferred from the patch's content and cannot be removed. A patch with"+    , "specific dependencies can be empty."+    ]+  , [ "The patch date is generated automatically.  It can only be spoofed by"+    , "using the `--pipe` option."+    ]+  , [ "If you run record with the `--pipe` option, you will be prompted for"+    , "the patch date, author, and the long comment. The long comment will extend"+    , "until the end of file or stdin is reached. This interface is intended for"+    , "scripting darcs, in particular for writing repository conversion scripts."+    , "The prompts are intended mostly as a useful guide (since scripts won't"+    , "need them), to help you understand the input format. Here's an example of"+    , "what the `--pipe` prompts look like:"+    ]+  ])+  $+$ vcat+    [ "    What is the date? Mon Nov 15 13:38:01 EST 2004"+    , "    Who is the author? David Roundy"+    , "    What is the log? One or more comment lines"+    ]+  $+$ vsep (map formatWords+  [ [ "If a test command has been defined with `darcs setpref`, attempting to"+    , "record a patch will cause the test command to be run in a clean copy"+    , "of the working tree (that is, including only recorded changes).  If"+    , "the test fails, you will be offered to abort the record operation."+    ]+  , [ "The `--set-scripts-executable` option causes scripts to be made"+    , "executable in the clean copy of the working tree, prior to running the"+    , "test.  See `darcs clone` for an explanation of the script heuristic."+    ]+  , [ "If your test command is tediously slow (e.g. `make all`) and you are"+    , "recording several patches in a row, you may wish to use `--no-test` to"+    , "skip all but the final test."+    ]+  , [ "To see some context (unchanged lines) around each change, use the"+    , "`--unified` option."+    ]+  ])++record :: DarcsCommand+record = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "record"+    , commandHelp = recordHelp+    , commandDescription = "Create a patch from unrecorded changes."+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+    , commandCommand = recordCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = modifiedFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = allOpts+    }+  where+    basicOpts+      = O.patchname+      ^ O.author+      ^ O.testChanges+      ^ O.interactive+      ^ O.pipe+      ^ O.askDeps+      ^ O.askLongComment+      ^ O.lookforadds+      ^ O.lookforreplaces+      ^ O.lookformoves+      ^ O.repoDir+      ^ O.diffAlgorithm+    advancedOpts+      = O.logfile+      ^ O.umask+      ^ O.setScriptsExecutable+    allOpts = basicOpts `withStdOpts` advancedOpts++-- | commit is an alias for record+commit :: DarcsCommand+commit = commandAlias "commit" Nothing record++reportNonExisting :: O.LookForAdds -> ([AnchoredPath], [AnchoredPath]) -> IO ()+reportNonExisting lfa (paths_only_in_working, _) = do+  unless (lfa /= O.NoLookForAdds || null paths_only_in_working) $  putDocLn $+    "These paths are not yet in the repository and will be added:" <+>+    pathlist (map displayPath paths_only_in_working)++recordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+recordCmd fps cfg args = do+    checkNameIsNotOption (O.patchname ? cfg) (isInteractive cfg)+    withRepoLock (O.useCache ? cfg) (O.umask ? cfg) $ RepoJob $ \(repository :: Repository 'RW p wU wR) -> do+      existing_files <- do+        files <- pathSetFromArgs fps args+        files' <-+          traverse+            (filterExistingPaths repository (O.verbosity ? cfg) (diffingOpts cfg)) files+        when (O.verbosity ? cfg /= O.Quiet) $+            traverse_ (reportNonExisting (O.lookforadds ? cfg)) files'+        let files'' = fmap snd files'+        when (files'' == Just []) $+            fail "None of the files you specified exist."+        return files''+      announceFiles (O.verbosity ? cfg) existing_files "Recording changes in"+      debugMessage "About to get the unrecorded changes."+      changes <-+        readPendingAndWorking (diffingOpts cfg) repository existing_files+      case changes of+          NilFL :> NilFL | not (O.askDeps ? cfg) -> do+              -- We need to grab any input waiting for us, since we+              -- might break scripts expecting to send it to us; we+              -- don't care what that input is, though.+              void (getDate (O.pipe ? cfg))+              putStrLn "No changes!"+              exitFailure+          _ -> doRecord repository cfg existing_files changes++-- | Check user specified patch name is not accidentally a command line flag+checkNameIsNotOption :: Maybe String -> Bool -> IO ()+checkNameIsNotOption Nothing     _      = return ()+checkNameIsNotOption _           False  = return ()+checkNameIsNotOption (Just name) True   =+  case name of+    [_] -> warnPatchName+    ('-':_) -> warnPatchName+    _ -> return ()+  where+    warnPatchName = do+        confirmed <- promptYorn $ "You specified " ++ show name ++ " as the patch name. Is that really what you want?"+        unless confirmed $ putStrLn "Okay, aborting the record." >> exitFailure++doRecord :: (RepoPatch p, ApplyState p ~ Tree)+         => Repository 'RW p wU wR -> Config -> Maybe [AnchoredPath]+         -> (FL (PrimOf p) :> FL (PrimOf p)) wR wU -> IO ()+doRecord repository cfg files pw@(pending :> working) = do+    debugMessage "I've got unrecorded changes."+    date <- getDate (O.pipe ? cfg)+    my_author <- getAuthor (O.author ? cfg) (O.pipe ? cfg)+    debugMessage "I'm slurping the repository."+    debugMessage "About to select changes..."+    let da = O.diffAlgorithm ? cfg+    (chs :> _ ) <- runInvertibleSelection (canonizeFL da $ pending +>+ working) $+                      selectionConfigPrim+                          First "record" (patchSelOpts cfg)+                          (Just (primSplitter (O.diffAlgorithm ? cfg)))+                          files+    when (not (O.askDeps ? cfg) && nullFL chs) $+              do putStrLn "Ok, if you don't want to record anything, that's fine!"+                 exitSuccess+    handleJust onlySuccessfulExits (\_ -> return ()) $+             do deps <- if O.askDeps ? cfg+                        then do+                          _ :> patches <- contextPatches <$> readPatches repository+                          askAboutDepends patches chs (patchSelOpts cfg) []+                        else return []+                when (O.askDeps ? cfg) $ debugMessage "I've asked about dependencies."+                if nullFL chs && null deps+                  then putStrLn "Ok, if you don't want to record anything, that's fine!"+                  else do setEnvDarcsFiles chs+                          (name, my_log, logf) <-+                            getLog (O.patchname ? cfg) (O.pipe ? cfg)+                              (O.logfile ? cfg) (O.askLongComment ? cfg)+                              Nothing (summaryFL chs)+                          debugMessage ("Patch name as received from getLog: " ++ show (map ord name))+                          doActualRecord repository cfg name date my_author my_log logf deps chs pw++doActualRecord :: (RepoPatch p, ApplyState p ~ Tree)+               => Repository 'RW p wU wR+               -> Config+               -> String -> String -> String+               -> [String] -> Maybe String+               -> [PatchInfo] -> FL (PrimOf p) wR wX+               -> (FL (PrimOf p) :> FL (PrimOf p)) wR wU -> IO ()+doActualRecord _repository cfg name date my_author my_log logf deps chs+      (pending :> working) = do+    debugMessage "Writing the patch file..."+    myinfo <- patchinfo date name my_author my_log+    let mypatch = infopatch myinfo $ progressFL "Writing changes" chs+    let pia = n2pia $ adddeps mypatch deps+    _repository <-+      tentativelyAddPatch _repository NoUpdatePending pia+    tp <- readPristine _repository+    testTentativeAndMaybeExit tp cfg+      ("you have a bad patch: '" ++ name ++ "'")+      "record it" (Just failuremessage)+    tentativelyRemoveFromPW _repository chs pending working+    _repository <-+      finalizeRepositoryChanges _repository (O.dryRun ? cfg)+      `clarifyErrors` failuremessage+    debugMessage "Syncing timestamps..."+    removeLogFile logf+    unless (O.verbosity ? cfg == O.Quiet) $+      putDocLn $ text $ "Finished recording patch '" ++ name ++ "'"+    setEnvDarcsPatches (pia :>: NilFL)+  where+    removeLogFile :: Maybe String -> IO ()+    removeLogFile Nothing = return ()+    removeLogFile (Just lf)+      | lf == darcsLastMessage = return ()+      | otherwise = removeFile lf+    failuremessage =+      "Failed to record patch '" ++ name ++ "'" +++        case logf of+          Just lf -> "\nLogfile left in " ++ lf ++ "."+          Nothing -> ""++onlySuccessfulExits :: ExitCode -> Maybe ()+onlySuccessfulExits ExitSuccess = Just ()+onlySuccessfulExits _ = Nothing++patchSelOpts :: Config -> S.PatchSelectionOptions+patchSelOpts cfg = S.PatchSelectionOptions+    { S.verbosity = O.verbosity ? cfg+    , S.matchFlags = []+    , S.interactive = isInteractive cfg+    , S.selectDeps = O.PromptDeps -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default+    }++isInteractive :: Config -> Bool+isInteractive cfg = maybe True id (O.interactive ? cfg)
+ src/Darcs/UI/Commands/Remove.hs view
@@ -0,0 +1,191 @@+--  Copyright (C) 2002-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Remove ( remove, rm, unadd ) where++import Darcs.Prelude++import Control.Monad ( when, foldM, void )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , withStdOpts, nodefaults+    , commandAlias, commandStub+    , putWarning, putInfo+    , amInHashedRepository+    )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.UI.Flags+    ( DarcsFlag, diffingOpts+    , useCache, umask, diffAlgorithm, pathsFromArgs )+import Darcs.UI.Options ( (^), parseFlags, (?) )+import qualified Darcs.UI.Options.All as O++import Darcs.Repository+    ( Repository+    , withRepoLock+    , RepoJob(..)+    , addToPending+    , finalizeRepositoryChanges+    , readPristineAndPending+    , readUnrecorded+    )+import Darcs.Repository.Diff( treeDiff )+import Darcs.Repository.State ( restrictSubpaths, applyTreeFilter )++import Darcs.Patch ( RepoPatch, PrimOf, PrimPatch, adddir, rmdir, addfile, rmfile,+                     listTouchedFiles )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.Witnesses.Ordered ( FL(..), concatGapsFL, nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Gap(..), FreeLeft, unFreeLeft )+import Darcs.Repository.Prefs ( filetypeFunction, FileType )+import Darcs.Util.Tree( Tree, TreeItem(..), explodePaths )+import qualified Darcs.Util.Tree as T ( find, modifyTree, expand, list )+import Darcs.Util.Path( AnchoredPath, displayPath, isRoot, AbsolutePath )+import Darcs.Util.Printer ( Doc, text, vcat )++removeDescription :: String+removeDescription = "Remove files from version control."++removeHelp :: Doc+removeHelp = text $+ "The `darcs remove` command exists primarily for symmetry with `darcs\n" +++ "add`, as the normal way to remove a file from version control is\n" +++ "simply to delete it from the working tree.  This command is only\n" +++ "useful in the unusual case where one wants to record a removal patch\n" +++ "WITHOUT deleting the copy in the working tree (which can be re-added).\n" +++ "\n" +++ "Note that applying a removal patch to a repository (e.g. by pulling\n" +++ "the patch) will ALWAYS affect the working tree of that repository.\n"++remove :: DarcsCommand+remove = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "remove"+    , commandHelp = removeHelp+    , commandDescription = removeDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["<FILE or DIRECTORY> ..."]+    , commandCommand = removeCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = knownFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = removeOpts+    }+  where+    removeBasicOpts = O.repoDir ^ O.recursive+    removeAdvancedOpts = O.umask+    removeOpts = removeBasicOpts `withStdOpts` removeAdvancedOpts++removeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+removeCmd fps opts relargs = do+    when (null relargs) $+        fail "Nothing specified, nothing removed."+    paths <- pathsFromArgs fps relargs+    when (any isRoot paths) $+        fail "Cannot remove a repository's root directory!"+    withRepoLock (useCache ? opts) (umask ? opts) $+      RepoJob $ \repository -> do+        pathFilter <- restrictSubpaths repository paths+        pristine <-+            T.expand =<<+            applyTreeFilter pathFilter <$> readPristineAndPending repository+        let exploded_paths =+              (if parseFlags O.recursive opts+                then reverse . explodePaths pristine+                else id) paths+        Sealed p <- makeRemovePatch opts repository exploded_paths pristine+        when (nullFL p && not (null paths)) $+            fail "No files were removed."+        addToPending repository (diffingOpts opts) p+        void $ finalizeRepositoryChanges repository+            (O.dryRun ? opts)+        putInfo opts $ vcat $ map text $ ["Will stop tracking:"] +++            map displayPath (listTouchedFiles p)++-- | makeRemovePatch builds a list of patches to remove the given filepaths.+--   This function does not recursively process directories. The 'Recursive'+--   flag should be handled by the caller by adding all offspring of a directory+--   to the files list.+makeRemovePatch :: (RepoPatch p, ApplyState p ~ Tree)+                => [DarcsFlag] -> Repository rt p wU wR+                -> [AnchoredPath] -> Tree IO -> IO (Sealed (FL (PrimOf p) wU))+makeRemovePatch opts repository files pristine = do+  unrecorded <- readUnrecorded repository (O.useIndex ? opts) $ Just files+  ftf <- filetypeFunction+  result <- foldM removeOnePath (ftf, pristine, unrecorded, []) files+  case result of+    (_, _, _, patches) ->+      return $+      unFreeLeft $ concatGapsFL $ reverse patches+  where+    removeOnePath (ftf, recorded, unrecorded, patches) f = do+      let recorded' = T.modifyTree recorded f Nothing+          unrecorded' = T.modifyTree unrecorded f Nothing+      local <- makeRemoveGap opts ftf recorded unrecorded unrecorded' f+      -- we can tell if the remove succeeded by looking if local is+      -- empty. If the remove succeeded, we should pass on updated+      -- recorded and unrecorded that reflect the removal+      return $+        case local of+          Just gap -> (ftf, recorded', unrecorded', gap : patches)+          _ -> (ftf, recorded, unrecorded, patches)++-- | Takes a file path and returns the FL of patches to remove that, wrapped in+--   a 'Gap'.+--   Returns 'Nothing' in case the path cannot be removed (if it is not tracked,+--   or if it's a directory and it's not tracked).+--   The three 'Tree' arguments are the recorded state, the unrecorded state+--   excluding the removal of this file, and the unrecorded state including the+--   removal of this file.+makeRemoveGap :: PrimPatch prim => [DarcsFlag] -> (FilePath -> FileType)+                -> Tree IO -> Tree IO -> Tree IO -> AnchoredPath+                -> IO (Maybe (FreeLeft (FL prim)))+makeRemoveGap opts ftf recorded unrecorded unrecorded' path =+    case (T.find recorded path, T.find unrecorded path) of+        (Just (SubTree _), Just (SubTree unrecordedChildren)) ->+            if not $ null (T.list unrecordedChildren)+              then skipAndWarn "it is not empty"+              else return $ Just $ freeGap (rmdir path :>: NilFL)+        (Just (File _), Just (File _)) -> do+            Just `fmap` treeDiff (diffAlgorithm ? opts) ftf unrecorded unrecorded'+        (Just (File _), _) ->+            return $ Just $ freeGap (addfile path :>: rmfile path :>: NilFL)+        (Just (SubTree _), _) ->+            return  $ Just $ freeGap (adddir path :>: rmdir path :>: NilFL)+        (_, _) -> skipAndWarn "it is not tracked by darcs"+  where skipAndWarn reason =+            do putWarning opts . text $ "Can't remove " ++ displayPath path+                                        ++ " (" ++ reason ++ ")"+               return Nothing+++rmDescription :: String+rmDescription = "Help newbies find `darcs remove'."++rmHelp :: Doc+rmHelp = text $+ "The `darcs rm' command does nothing.\n" +++ "\n" +++ "The normal way to remove a file from version control is simply to\n" +++ "delete it from the working tree.  To remove a file from version\n" +++ "control WITHOUT affecting the working tree, see `darcs remove'.\n"++rm :: DarcsCommand+rm = commandStub "rm" rmHelp rmDescription remove++unadd :: DarcsCommand+unadd = commandAlias "unadd" Nothing remove
+ src/Darcs/UI/Commands/Repair.hs view
@@ -0,0 +1,181 @@+--  Copyright (C) 2002-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.Repair ( repair, check ) where++import Darcs.Prelude++import Control.Monad ( when, unless, void )+import Data.Maybe ( isJust )+import System.IO.Error ( catchIOError )+import System.Exit ( exitFailure )+import System.Directory( renameFile )+import System.FilePath ( (<.>) )++import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts, nodefaults+    , putInfo, putVerbose, putWarning, amInHashedRepository+    )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags+    ( DarcsFlag, verbosity, umask, useIndex+    , useCache, diffAlgorithm, quiet+    )+import Darcs.UI.Options ( DarcsOption, oid, (?), (^) )+import qualified Darcs.UI.Options.All as O++import Darcs.Repository.Paths ( indexPath )+import Darcs.Repository.Repair+    ( replayRepository, checkIndex, replayRepositoryInTemp+    , RepositoryConsistency(..)+    )+import Darcs.Repository+    ( withRepository, RepoJob(..)+    , withRepoLock, writePristine+    , finalizeRepositoryChanges+    )+import Darcs.Repository.Hashed ( writeTentativeInventory )+import Darcs.Repository.Pending ( setTentativePending )++import Darcs.Patch ( displayPatch )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )++import Darcs.Util.Printer ( Doc, text, ($$) )+++repairDescription :: String+repairDescription = "Repair a corrupted repository."++repairHelp :: Doc+repairHelp = text $+  "The `darcs repair` command attempts to fix corruption in the current\n\+  \repository.\n\+  \It works by successively applying all patches in the repository to an\n\+  \empty tree, each time checking that the patch can be cleanly applied\n\+  \to the current pristine tree. If we detect a problem, we try to repair\n\+  \the patch. Finally we compare the existing pristine with the newly\n\+  \reconstructed one and if they differ, replace the existing one.\n\+  \Any problem encountered is reported.\n\+  \The flag `--dry-run` makes this operation read-only and causes it to\n\+  \exit unsuccessfully (with a non-zero exit status) in case any problems\n\+  \are enountered.\n"++commonBasicOpts :: DarcsOption a+                   (Maybe String -> O.DiffAlgorithm -> a)+commonBasicOpts = O.repoDir ^ O.diffAlgorithm++repair :: DarcsCommand+repair = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "repair"+    , commandHelp = repairHelp+    , commandDescription = repairDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = withFpsAndArgs repairCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , ..+    }+  where+    basicOpts = commonBasicOpts ^ O.dryRun+    advancedOpts = O.umask+    allOpts = basicOpts `withStdOpts` advancedOpts+    commandOptions = allOpts++withFpsAndArgs :: (b -> d) -> a -> b -> c -> d+withFpsAndArgs cmd _ opts _ = cmd opts++maybeDo :: Monad m => Maybe t -> (t -> m ()) -> m ()+maybeDo (Just x) f = f x+maybeDo Nothing _ = return ()++repairCmd :: [DarcsFlag] -> IO ()+repairCmd opts+  | O.yes (O.dryRun ? opts) = checkCmd opts+  | otherwise =+    withRepoLock (useCache ? opts) (umask ? opts) $+    RepoJob $ \repo -> do+      bad_replay <- replayRepository+        (diffAlgorithm ? opts)+        repo+        (verbosity ? opts) $ \RepositoryConsistency {..} -> do+          maybeDo fixedPatches $ \ps -> do+            putInfo opts "Writing out repaired patches..."+            writeTentativeInventory repo ps+          maybeDo fixedPristine $ \(tree, Sealed diff) -> do+            putVerbose opts $ "Pristine differences:" $$ displayPatch diff+            putInfo opts "Fixing pristine tree..."+            void $ writePristine repo tree+          maybeDo fixedPending $ \(Sealed pend) -> do+            putInfo opts "Writing out repaired pending..."+            setTentativePending repo pend+          return $ isJust fixedPatches || isJust fixedPristine || isJust fixedPending+      index_ok <- checkIndex repo (quiet opts)+      unless index_ok $ do+        renameFile indexPath (indexPath <.> "bad")+        putInfo opts "Bad index discarded."+      if bad_replay || not index_ok+        then void $ finalizeRepositoryChanges repo (O.dryRun ? opts)+        else putInfo opts "The repository is already consistent, no changes made."++-- |check is an alias for repair, with implicit DryRun flag.+check :: DarcsCommand+check = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "check"+    , commandHelp = "See `darcs repair` for details."+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = withFpsAndArgs checkCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , ..+    }+  where+    basicOpts = commonBasicOpts+    advancedOpts = oid+    allOpts = basicOpts `withStdOpts` advancedOpts+    commandOptions = allOpts+    commandDescription = "Alias for `darcs " ++ commandName repair ++ " --dry-run'."++checkCmd :: [DarcsFlag] -> IO ()+checkCmd opts = withRepository (useCache ? opts) $ RepoJob $ \repository -> do+  RepositoryConsistency {..} <-+    replayRepositoryInTemp (diffAlgorithm ? opts) repository (verbosity ? opts)+  maybeDo fixedPatches $ \_ ->+    putInfo opts "Found broken patches."+  maybeDo fixedPristine $ \(_, Sealed diff) -> do+    putInfo opts "Found broken pristine tree."+    putVerbose opts $ "Differences:" $$ displayPatch diff+  maybeDo fixedPending $ \_ ->+    putInfo opts "Found broken pending."+  bad_index <-+    if useIndex ? opts == O.IgnoreIndex+      then return False+      else+        not <$> do+          checkIndex repository (quiet opts) `catchIOError` \e -> do+            putWarning opts ("Warning, cannot access the index:" $$ text (show e))+            return True+  when bad_index $ putInfo opts "Bad index."+  if isJust fixedPatches || isJust fixedPristine || isJust fixedPending || bad_index+    then exitFailure+    else putInfo opts "The repository is consistent!"
+ src/Darcs/UI/Commands/Replace.hs view
@@ -0,0 +1,281 @@+--  Copyright (C) 2002-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Replace+    ( replace+    , defaultToks+    ) where++import Darcs.Prelude++import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B+import Data.Char ( isAscii, isPrint, isSpace )+import Data.List.Ordered ( nubSort )+import Data.Maybe ( fromJust, isJust )+import Safe ( headErr, tailErr )+import Control.Monad ( unless, filterM, void, when )+import Darcs.Util.Tree( readBlob, modifyTree, findFile, TreeItem(..), Tree+                      , makeBlobBS )+import Darcs.Util.Path( AbsolutePath )+import Darcs.UI.Flags+    ( DarcsFlag, diffingOpts+    , verbosity, useCache, umask, diffAlgorithm, pathsFromArgs )+import Darcs.UI.Options ( (^), (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.Repository.Diff( treeDiff )+import Darcs.Patch ( PrimPatch, tokreplace, forceTokReplace+                   , maybeApplyToTree )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch.RegChars ( regChars )+import Darcs.Repository+    ( withRepoLock+    , RepoJob(..)+    , addToPending+    , finalizeRepositoryChanges+    , applyToWorking+    , readUnrecorded+    )+import Darcs.Patch.TokenReplace ( defaultToks )+import Darcs.Repository.Prefs ( FileType(TextFile) )+import Darcs.Util.Path ( AnchoredPath, displayPath )+import Darcs.Util.Printer ( Doc, formatWords, vsep )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , concatFL+    , consGapFL+    , joinGapsFL+    , nullFL+    , (+>+)+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal, FreeLeft, Gap(..), unFreeLeft, unseal )++replaceDescription :: String+replaceDescription = "Substitute one word for another."++replaceHelp :: Doc+replaceHelp = vsep $ map formatWords+  [ [ "In addition to line-based patches, Darcs supports a limited form of"+    , "lexical substitution.  Files are treated as sequences of words, and"+    , "each occurrence of the old word is replaced by the new word."+    , "This is intended to provide a clean way to rename a function or"+    , "variable.  Such renamings typically affect lines all through the"+    , "source code, so a traditional line-based patch would be very likely to"+    , "conflict with other branches, requiring manual merging."+    ]+  , [ "Files are tokenized according to one simple rule: words are strings of"+    , "valid token characters, and everything between them (punctuation and"+      -- FIXME: this heuristic is ham-fisted and silly.  Can we drop it?+    , "whitespace) is discarded.  By default, valid token characters are"+    , "letters, numbers and the underscore (i.e. `[A-Za-z0-9_]`).  However if"+    , "the old and/or new token contains either a hyphen or period, BOTH"+    , "hyphen and period are treated as valid (i.e. `[A-Za-z0-9_.-]`)."+    ]+  , [ "The set of valid characters can be customized using the `--token-chars`"+    , "option.  The argument must be surrounded by square brackets.  If a"+    , "hyphen occurs between two characters in the set, it is treated as a"+    , "set range.  For example, in most locales `[A-Z]` denotes all uppercase"+    , "letters.  If the first character is a caret, valid tokens are taken to"+    , "be the complement of the remaining characters.  For example, `[^:\\n]`"+    , "could be used to match fields in the passwd(5), where records and"+    , "fields are separated by newlines and colons respectively."+    ]+  , [ "If you choose to use `--token-chars`, you are STRONGLY encouraged to do"+    , "so consistently.  The consequences of using multiple replace patches"+    , "with different `--token-chars` arguments on the same file are not well"+    , "tested nor well understood."+    ]+  , [ "By default Darcs will refuse to perform a replacement if the new token"+    , "is already in use, because the replacements would be not be"+    , "distinguishable from the existing tokens.  This behaviour can be"+    , "overridden by supplying the `--force` option, but an attempt to `darcs"+    , "rollback` the resulting patch will affect these existing tokens."+    ]+  , [ "Limitations:"+    ]+  , [ "The tokenizer treats files as byte strings, so it is not possible for"+    , "`--token-chars` to include multi-byte characters, such as the non-ASCII"+    , "parts of UTF-8.  Similarly, trying to replace a \"high-bit\" character"+    , "from a unibyte encoding will also result in replacement of the same"+    , "byte in files with different encodings.  For example, an acute a from"+    , "ISO 8859-1 will also match an alpha from ISO 8859-7."+    ]+  , [ "Due to limitations in the patch file format, `--token-chars` arguments"+    , "cannot contain literal whitespace.  For example, `[^ \\n\\t]` cannot be"+    , "used to declare all characters except the space, tab and newline as"+    , "valid within a word, because it contains a literal space."+    ]+  , [ "Unlike POSIX regex(7) bracket expressions, character classes (such as"+    , "`[[:alnum:]]`) are NOT supported by `--token-chars`, and will be silently"+    , "treated as a simple set of characters."+    ]+  ]++replace :: DarcsCommand+replace = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "replace"+    , commandHelp = replaceHelp+    , commandDescription = replaceDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = [ "<OLD>"+                            , "<NEW>"+                            , "<FILE> ..."+                            ]+    , commandCommand = replaceCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = replaceArgs+    , commandArgdefaults = nodefaults+    , commandOptions = replaceOpts+    }+  where+    replaceBasicOpts = O.tokens ^ O.forceReplace ^ O.repoDir+    replaceAdvancedOpts = O.umask+    replaceOpts = replaceBasicOpts `withStdOpts` replaceAdvancedOpts++replaceArgs  :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO [String]+replaceArgs fps flags args =+  if length args < 2+    then return []+    else knownFileArgs fps flags args++replaceCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+replaceCmd fps opts (old : new : args@(_ : _)) =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $+    \_repository -> do+        paths <- nubSort <$> pathsFromArgs fps args+        when (null paths) $ fail "No valid repository paths were given."+        toks <- chooseToks (O.tokens ? opts) old new+        let checkToken tok = unless (isTok toks tok) $+                                 fail $ "'" ++ tok ++ "' is not a valid token!"+        mapM_ checkToken [ old, new ]+        working <- readUnrecorded _repository (O.useIndex ? opts) Nothing+        files <- filterM (exists working) paths+        Sealed replacePs <- mapSeal concatFL . unFreeLeft . joinGapsFL <$>+            mapM (doReplace toks working) files+        withSignalsBlocked $ do+          -- Note: addToPending takes care of commuting the replace patch and+          -- everything it depends on past the diff between pending and working+          addToPending _repository (diffingOpts opts) replacePs+          _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+          unless (O.yes (O.dryRun ? opts)) $+            void $ applyToWorking _repository (verbosity ? opts) replacePs+  where+    exists tree file = if isJust $ findFile tree file+                           then return True+                           else do putStrLn $ skipmsg file+                                   return False++    skipmsg f = "Skipping file '" ++ displayPath f+                ++ "' which isn't in the repository."++    doReplace :: forall prim . (PrimPatch prim,+              ApplyState prim ~ Tree) => String -> Tree IO+              -> AnchoredPath -> IO (FreeLeft (FL prim))+    doReplace toks work f = do+        workReplaced <- maybeApplyToTree replacePatch work+        case workReplaced of+          Just _ -> do+            return $ consGapFL replacePatch gapNilFL+          Nothing+            | O.forceReplace ? opts -> getForceReplace f toks work+            | otherwise -> putStrLn existsMsg >> return gapNilFL+      where+        -- FIXME Why do we say "perhaps"? Aren't we sure? Are there other+        -- reasons maybeApplyToTree can fail and what to do about them?+        existsMsg = "Skipping file '" ++ displayPath f ++ "'\nPerhaps the working"+                    ++ " version of this file already contains '" ++ new+                    ++ "'?\nUse the --force option to override."+        gapNilFL = emptyGap NilFL+        replacePatch = tokreplace f toks old new++    ftf _ = TextFile++    -- | getForceReplace returns the list of patches that consists first of+    -- hunk patches to normalise all occurences of the target token (changing+    -- them back to the source token) and then the replace patches from+    -- oldToken -> newToken.+    getForceReplace :: PrimPatch prim+                    => AnchoredPath -> String -> Tree IO -> IO (FreeLeft (FL prim))+    getForceReplace path toks tree = do+        content <- readBlob $ fromJust $ findFile tree path+        let newcontent = forceTokReplace toks (BC.pack new) (BC.pack old)+                            (B.concat $ BL.toChunks content)+            tree' = modifyTree tree path . Just . File $ makeBlobBS newcontent+        normaliseNewTokPatch <- treeDiff (diffAlgorithm ? opts) ftf tree tree'+        unless (unseal nullFL (unFreeLeft normaliseNewTokPatch)) $+            putStrLn $ "Don't be surprised!\n"+                       ++ "I've changed all instances of '" ++ new ++ "' to '"+                       ++ old ++ "' first\n"+                       ++ "so that darcs replace can token-replace them"+                       ++ " back into '" ++ new ++ "' again."+        return . joinGap (+>+) normaliseNewTokPatch $ freeGap $+            tokreplace path toks old new :>: NilFL+replaceCmd _ _ [_, _] = fail "You need to supply a list of files to replace in!"+replaceCmd _ _ _ = fail "Usage: darcs replace <OLD> <NEW> <FILE>..."++filenameToks :: String+filenameToks = "A-Za-z_0-9\\-\\."++-- | Given a set of characters and a string, returns true iff the string+-- contains only characters from the set. A set beginning with a caret (@^@) is+-- treated as a complementary set.+isTok :: String -> String -> Bool+isTok _ "" = False+isTok toks s = all (regChars toks) s++-- | This function checks for @--token-chars@ on the command-line. If found,+-- it validates the argument and returns it, without the surrounding square+-- brackets. Otherwise, it returns either 'defaultToks' or 'filenameToks' as+-- explained in 'replaceHelp'.+--+-- Note: Limitations in the current replace patch file format prevents tokens+-- and token-char specifiers from containing any whitespace.+chooseToks :: Maybe String -> String -> String -> IO String+chooseToks (Just t) a b+    | length t <= 2 =+        badTokenSpec $ "It must contain more than 2 characters, because it"+                       ++ " should be enclosed in square brackets"+    | headErr t /= '[' || last t /= ']' =+        badTokenSpec "It should be enclosed in square brackets"+    | '^' == headErr tok && length tok == 1 =+        badTokenSpec "Must be at least one character in the complementary set"+    | any isSpace t =+        badTokenSpec "Space is not allowed"+    | any (not . isAscii) t =+        badTokenSpec "Only ASCII characters are allowed"+    | any (not . isPrint) t =+        badTokenSpec "Only printable characters are allowed"+    | any isSpace a = badTokenSpec $ spaceyToken a+    | any isSpace b = badTokenSpec $ spaceyToken b+    | not (isTok tok a) = badTokenSpec $ notAToken a+    | not (isTok tok b) = badTokenSpec $ notAToken b+    | otherwise = return tok+  where+    tok = init $ tailErr t :: String+    badTokenSpec msg = fail $ "Bad token spec: " ++ show t ++ " (" ++ msg ++ ")"+    spaceyToken x = x ++ " must not contain any space"+    notAToken x = x ++ " is not a token, according to your spec"++chooseToks Nothing a b =+    if isTok defaultToks a && isTok defaultToks b+      then return defaultToks+      else return filenameToks
+ src/Darcs/UI/Commands/Revert.hs view
@@ -0,0 +1,215 @@+--  Copyright (C) 2002-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+module Darcs.UI.Commands.Revert ( revert, clean ) where++import Darcs.Prelude++import Control.Monad ( unless, when, void )++import Darcs.UI.Flags+    ( DarcsFlag+    , diffAlgorithm+    , diffingOpts+    , isInteractive+    , pathSetFromArgs+    , umask+    , useCache+    )+import Darcs.UI.Options ( (^), (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , commandAlias+    , nodefaults+    , putInfo+    , putFinished+    , withStdOpts+    )+import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths )+import Darcs.Repository.Unrevert ( writeUnrevert )+import Darcs.UI.Completion ( modifiedFileArgs )++import Darcs.Util.Global ( debugMessage )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, formatWords, vsep )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Repository+    ( RepoJob(..)+    , addToPending+    , finalizeRepositoryChanges+    , applyToWorking+    , readPatches+    , unrecordedChanges+    , withRepoLock+    )+import Darcs.Patch ( invert, commuteFL )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanRL )+import Darcs.Patch.Split ( reversePrimSplitter )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..)+    , (:>)(..)+    , nullFL+    , (+>>+)+    , reverseFL+    )+import Darcs.UI.SelectChanges+    ( WhichChanges(Last)+    , selectionConfigPrim+    , runInvertibleSelection+    )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+++revertDescription :: String+revertDescription = "Discard unrecorded changes."++revertHelp :: Doc+revertHelp = vsep $ map formatWords+  [ [ "The `darcs revert` command discards unrecorded changes in the working"+    , "tree.  As with `darcs record`, you will be asked which hunks (changes)"+    , "to revert.  The `--all` switch can be used to avoid such prompting. If"+    , "files or directories are specified, other parts of the working tree"+    , "are not reverted."+    ]+  , [ "In you accidentally reverted something you wanted to keep (for"+    , "example, typing `darcs rev -a` instead of `darcs rec -a`), you can"+    , "immediately run `darcs unrevert` to restore it.  This is only"+    , "guaranteed to work if the repository has not changed since `darcs"+    , "revert` ran."+    ]+  ]++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+    { S.verbosity = O.verbosity ? flags+    , S.matchFlags = []+    , S.interactive = isInteractive True flags+    , S.selectDeps = O.PromptDeps -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default+    }++revert :: DarcsCommand+revert = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "revert"+    , commandHelp = revertHelp+    , commandDescription = revertDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+    , commandCommand = revertCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = modifiedFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = opts+    }+  where+    basicOpts+      = O.interactive -- True+      ^ O.repoDir+      ^ O.diffAlgorithm+      ^ O.maybelookforadds O.NoLookForAdds+    advancedOpts = O.umask+    opts = withStdOpts basicOpts advancedOpts++revertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+revertCmd fps opts args =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    existing_paths <- existingPaths _repository =<< pathSetFromArgs fps args+    announceFiles verbosity existing_paths "Reverting changes in"+    changes <- unrecordedChanges diffOpts _repository existing_paths+    case changes of+      NilFL -> putInfo opts "There are no changes to revert!"+      _ -> do+        let selection_config =+              selectionConfigPrim Last "revert" (patchSelOpts opts)+                (Just (reversePrimSplitter (diffAlgorithm ? opts)))+                existing_paths+        norevert :> torevert <- runInvertibleSelection changes selection_config+        if nullFL torevert+          then+            putInfo opts $+              "If you don't want to revert after all, that's fine with me!"+          else do+            withSignalsBlocked $ do+              addToPending _repository diffOpts $ invert torevert+              debugMessage "About to write the unrevert file."+              {- The user has split unrecorded into the sequence 'norevert'+                 then 'torevert', which is natural as the bit we keep in+                 unrecorded should have pristine as the context.++                 But the unrevert patch also needs to have pristine as the+                 context, not unrecorded (which can be changed by the user+                 at any time).++                 So we need to commute 'torevert' with 'norevert', and if+                 that fails then we need to keep some of 'norevert' in the+                 actual unrevert patch so it still makes sense. The use of+                 genCommuteWhatWeCanRL minimises the amount of 'norevert'+                 that we need to keep.+              -}+              case genCommuteWhatWeCanRL commuteFL (reverseFL norevert :> torevert) of+                deps :> torevert' :> _ -> do+                  recorded <- readPatches _repository+                  writeUnrevert recorded (deps +>>+ torevert')+              _repository <-+                finalizeRepositoryChanges _repository+                  (O.dryRun ? opts)+              debugMessage "About to apply to the working tree."+              unless (O.yes (O.dryRun ? opts)) $+                void $ applyToWorking _repository verbosity (invert torevert)+            putFinished opts "reverting"+  where+    verbosity = O.verbosity ? opts+    diffOpts = diffingOpts opts+    existingPaths repo paths = do+      paths' <- traverse (filterExistingPaths repo verbosity diffOpts) paths+      let paths'' = fmap snd paths'+      when (paths'' == Just []) $ fail "None of the paths you specified exist."+      return paths''++-- | An alias for 'revert -l' i.e. remove every (non-boring) file or change+-- that is not in pristine.+clean :: DarcsCommand+clean = alias+    { commandDescription = desc+    , commandHelp = vsep $ map formatWords+        [ [ "Remove unrecorded changes from the working tree."+          ]+        , [ "This is an alias for `darcs revert -l/--look-for-adds` which"+          , "means it works also on files that have not been added."+          , "You can additionally pass `--boring` to get rid of *every*"+          , "unrecorded file or directory."+          ]+        , [ "See description of `darcs revert` for more details."+          ]+        ]+    , commandOptions = opts+    }+  where+    alias = commandAlias "clean" Nothing revert+    desc = "Alias for `darcs " ++ commandName revert ++ " -l`."+    basicOpts+      = O.interactive -- True+      ^ O.repoDir+      ^ O.diffAlgorithm+      ^ O.maybelookforadds O.YesLookForAdds+    advancedOpts = O.umask+    opts = withStdOpts basicOpts advancedOpts
+ src/Darcs/UI/Commands/Rollback.hs view
@@ -0,0 +1,150 @@+--  Copyright (C) 2002-2004,2007 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Rollback ( rollback ) where++import Darcs.Prelude++import Control.Monad ( unless, when, void )+import System.Exit ( exitSuccess )++import Darcs.Patch.Match ( firstMatch )+import Darcs.Patch.PatchInfoAnd ( n2pia )+import Darcs.Patch ( canonizeFL, effect, invert )+import Darcs.Patch.Named ( anonymous )+import Darcs.Patch.Set ( emptyPatchSet, patchSet2FL )+import Darcs.Patch.Split ( reversePrimSplitter )+import Darcs.Patch.Witnesses.Ordered ( Fork(..), FL(..), (:>)(..), nullFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Repository ( withRepoLock, RepoJob(..),+                          applyToWorking, readPatches,+                          finalizeRepositoryChanges, addToPending,+                          considerMergeToWorking )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, setEnvDarcsPatches,+                           amInHashedRepository, putInfo )+import Darcs.UI.Commands.Util ( announceFiles, getLastPatches )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.UI.Flags ( DarcsFlag, verbosity, umask, useCache,+                        wantGuiPause, diffingOpts,+                        diffAlgorithm, isInteractive, pathSetFromArgs )+import Darcs.UI.Options ( parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.SelectChanges ( WhichChanges(..),+                                selectionConfig, selectionConfigPrim,+                                runSelection, runInvertibleSelection )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.SignalHandler ( withSignalsBlocked )+++rollbackDescription :: String+rollbackDescription =+ "Apply the inverse of recorded changes to the working tree."++rollbackHelp :: Doc+rollbackHelp = text $ unlines+    [ "Rollback is used to undo the effects of some changes from patches"+    , "in the repository. The selected changes are undone in your working"+    , "tree, but the repository is left unchanged. First you are offered a"+    , "choice of which patches to undo, then which changes within the"+    , "patches to undo."+    , ""+    , "Before doing `rollback`, you may want to temporarily undo the changes"+    , "of your working tree (if there are) and save them for later use."+    , "To do so, you can run `revert`, then run `rollback`, record a patch,"+    , "and run `unrevert` to restore the saved changes into your working tree."+    ]++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = parseFlags O.matchSeveralOrLast flags+    , S.interactive = isInteractive True flags+    , S.selectDeps = O.PromptDeps+    , S.withSummary = O.NoSummary+    }++rollback :: DarcsCommand+rollback = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "rollback"+    , commandHelp = rollbackHelp+    , commandDescription = rollbackDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+    , commandCommand = rollbackCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = knownFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = rollbackOpts+    }+  where+    rollbackBasicOpts+      = O.matchSeveralOrLast+      ^ O.interactive -- True+      ^ O.repoDir+      ^ O.diffAlgorithm+    rollbackAdvancedOpts = O.umask+    rollbackOpts = rollbackBasicOpts `withStdOpts` rollbackAdvancedOpts++exitIfNothingSelected :: FL p wX wY -> String -> IO ()+exitIfNothingSelected ps what =+    when (nullFL ps) $ putStrLn ("No " ++ what ++ " selected!") >> exitSuccess++rollbackCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+rollbackCmd fps opts args = withRepoLock (useCache ? opts)+    (umask ? opts) $ RepoJob $ \_repo -> do+        files <- pathSetFromArgs fps args+        announceFiles (verbosity ? opts) files "Rolling back changes in"+        allpatches <- readPatches _repo+        let matchFlags = parseFlags O.matchSeveralOrLast opts+        (_ :> patches) <- return $+            if firstMatch matchFlags+                then getLastPatches matchFlags allpatches+                else emptyPatchSet :> patchSet2FL allpatches+        (_ :> ps) <-+            runSelection patches $+                selectionConfig LastReversed "rollback" (patchSelOpts opts) Nothing files++        exitIfNothingSelected ps "patches"+        setEnvDarcsPatches ps+        let prim_selection_context =+              selectionConfigPrim+                  Last "rollback" (patchSelOpts opts)+                  (Just (reversePrimSplitter (diffAlgorithm ? opts)))+                  files+            hunks = canonizeFL (diffAlgorithm ? opts) . effect+        _ :> to_undo <- runInvertibleSelection (hunks ps) prim_selection_context+        exitIfNothingSelected to_undo "changes"+        -- Note: use of anonymous is unproblematic here because we+        -- only store effects by adding them to pending and working)+        rbp <- n2pia `fmap` anonymous (invert to_undo)+        Sealed pw <- considerMergeToWorking _repo "rollback"+                         (O.YesAllowConflicts O.MarkConflicts)+                         (wantGuiPause opts)+                         O.NoReorder+                         (diffingOpts opts)+                         (Fork allpatches NilFL (rbp :>: NilFL))+        addToPending _repo (diffingOpts opts) pw+        withSignalsBlocked $ do+            _repo <- finalizeRepositoryChanges _repo (O.dryRun ? opts)+            unless (O.yes (O.dryRun ? opts)) $+              void $ applyToWorking _repo (verbosity ? opts) pw+        debugMessage "Finished applying unrecorded rollback patch"+        putInfo opts $ text "Changes rolled back in working tree"
+ src/Darcs/UI/Commands/Send.hs view
@@ -0,0 +1,648 @@+--  Copyright (C) 2002-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}++module Darcs.UI.Commands.Send ( send ) where++import Darcs.Prelude++import System.Directory ( renameFile )+import System.Exit ( exitSuccess )+import System.IO ( hClose )+import Control.Exception ( catch, IOException, onException )+import Control.Monad ( when, unless, forM_ )+import Darcs.Util.Tree ( Tree )+import Data.List ( intercalate, isPrefixOf )+import Data.List ( stripPrefix )+import Data.Maybe ( isNothing, fromMaybe )++import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts+    , putInfo+    , putVerbose+    , setEnvDarcsPatches+    , defaultRepo+    , amInHashedRepository+    )+import Darcs.UI.Commands.Clone ( otherHelpInheritDefault )+import Darcs.UI.Commands.Util ( printDryRunMessageAndExit, checkUnrelatedRepos )+import Darcs.UI.Flags+    ( DarcsFlag+    , willRemoveLogFile, changesReverse, dryRun, useCache, setDefault+    , fixUrl+    , getCc+    , getAuthor+    , getSubject+    , getInReplyTo+    , getSendmailCmd+    , getOutput+    , charset+    , verbosity+    , isInteractive+    , author+    , hasLogfile+    , selectDeps+    , minimize+    , editDescription+    )+import Darcs.UI.Options ( (?), (^) )+import qualified Darcs.UI.Options.All as O++import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, hopefully, patchDesc )+import Darcs.Repository+    ( Repository+    , AccessType(..)+    , repoLocation+    , PatchSet+    , identifyRepositoryFor+    , ReadingOrWriting(..)+    , withRepository+    , RepoJob(..)+    , readPatches+    , readPristine+    , prefsUrl )+import Darcs.Patch.Set ( Origin )+import Darcs.Patch.Apply( ApplyState )+import Darcs.Patch ( RepoPatch, description, applyToTree, effect, invert )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Patch.Witnesses.Unsafe ( unsafeCoerceP )+import Darcs.Patch.Witnesses.Ordered+    ( FL(..), (:>)(..), (:\/:)(..),+    mapFL, mapFL_FL, lengthFL, nullFL )+import Darcs.Patch.Bundle+    ( makeBundle+    , minContext+    , readContextFile+    )+import Darcs.Repository.Prefs+    ( Pref(Defaultrepo, Email, Post, Repos)+    , addRepoSource+    , getPreflist+    )+import Darcs.Repository.Flags ( DryRun(..) )+import Darcs.Util.File ( fetchFilePS, Cachable(..) )+import Darcs.UI.External+    ( signString+    , sendEmailDoc+    , generateEmail+    , editFile+    , checkDefaultSendmail+    )+import Darcs.Util.ByteString ( mmapFilePS, isAscii )+import qualified Data.ByteString.Char8 as BC (unpack)+import Darcs.Util.File ( withOpenTemp )+import Darcs.Util.Lock+    ( writeDocBinFile+    , readDocBinFile+    , removeFileMayNotExist+    )+import Darcs.UI.SelectChanges+    ( WhichChanges(..)+    , selectionConfig+    , runSelection+    )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Patch.Depends ( findCommonWithThem )+import Darcs.Util.Prompt ( askUser, promptYorn )+import Data.Text.Encoding       ( decodeUtf8' )+import Darcs.Util.Progress ( debugMessage )+import Darcs.UI.Email ( makeEmail )+import Darcs.UI.Completion ( prefArgs )+import Darcs.UI.Commands.Util ( getUniqueDPatchName )+import Darcs.Util.Printer+    ( Doc, formatWords, vsep, text, ($$), (<+>), putDoc, putDocLn+    , quoted, renderPS, sentence, vcat+    )+import Darcs.Util.English ( englishNum, Noun(..) )+import Darcs.Util.Exception ( catchall )+import Darcs.Util.Path ( FilePathLike, toFilePath, AbsolutePath, AbsolutePathOrStd,+                        getCurrentDirectory, useAbsoluteOrStd, makeAbsoluteOrStd )+import Darcs.Util.HTTP ( postUrl )+import Darcs.Util.Global ( darcsSendMessage, darcsSendMessageFinal )+import Darcs.Util.SignalHandler ( catchInterrupt )++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = O.matchSeveral ? flags+    , S.interactive = isInteractive True flags+    , S.selectDeps = selectDeps ? flags+    , S.withSummary = O.withSummary ? flags+    }++send :: DarcsCommand+send = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "send"+    , commandHelp = cmdHelp+    , commandDescription = cmdDescription+    , commandExtraArgs = 1+    , commandExtraArgHelp = ["[REPOSITORY]"]+    , commandCommand = sendCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = prefArgs Repos+    , commandArgdefaults = defaultRepo+    , commandOptions = sendOpts+    }+  where+    sendBasicOpts+      = O.matchSeveral+      ^ O.selectDeps+      ^ O.interactive -- True+      ^ O.headerFields+      ^ O.author+      ^ O.charset+      ^ O.mail+      ^ O.sendmailCmd+      ^ O.output+      ^ O.sign+      ^ O.dryRunXml+      ^ O.withSummary+      ^ O.editDescription+      ^ O.setDefault+      ^ O.inheritDefault+      ^ O.repoDir+      ^ O.minimize+      ^ O.allowUnrelatedRepos+    sendAdvancedOpts+      = O.logfile+      ^ O.sendToContext +      ^ O.changesReverse+      ^ O.remoteDarcs+    sendOpts = sendBasicOpts `withStdOpts` sendAdvancedOpts++sendCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+sendCmd fps opts [""] = sendCmd fps opts []+sendCmd (_,o) opts [unfixedrepodir] =+ withRepository (useCache ? opts) $ RepoJob $+  \(repository :: Repository 'RO p wU wR) -> do+  when (O.mail ? opts && dryRun ? opts == O.NoDryRun) $ do+    -- If --mail is used and the user has not provided a --sendmail-command+    -- and we can detect that the system has no default way to send emails, +    -- then we want to fail early i.e. before asking the user any questions.+    sm_cmd <- getSendmailCmd opts+    when (isNothing sm_cmd) checkDefaultSendmail+  case O.sendToContext ? opts of+    Just contextfile -> do+        wtds <- decideOnBehavior opts (Nothing :: Maybe (Repository rt p wU wR))+        ref <- readPatches repository+        Sealed them <- readContextFile ref (toFilePath contextfile)+        sendToThem repository opts wtds "CONTEXT" them+    Nothing -> do+        repodir <- fixUrl o unfixedrepodir+        -- Test to make sure we aren't trying to push to the current repo+        here <- getCurrentDirectory+        when (repodir == toFilePath here) $+           fail cannotSendToSelf+        old_default <- getPreflist Defaultrepo+        when (old_default == [repodir]) $+            putInfo opts (creatingPatch repodir)+        repo <- identifyRepositoryFor Reading repository (useCache ? opts) repodir+        them <- readPatches repo+        addRepoSource repodir (dryRun ? opts) (setDefault False opts)+          (O.inheritDefault ? opts) (isInteractive True opts)+        wtds <- decideOnBehavior opts (Just repo)+        sendToThem repository opts wtds repodir them+sendCmd _ _ _ = error "impossible case"++sendToThem :: (RepoPatch p, ApplyState p ~ Tree)+           => Repository rt p wU wR -> [DarcsFlag] -> [WhatToDo] -> String+           -> PatchSet p Origin wX -> IO ()+sendToThem repo opts wtds their_name them = do+  us <- readPatches repo+  common :> us' <- return $ findCommonWithThem us them+  checkUnrelatedRepos (O.allowUnrelatedRepos ? opts) us them+  case us' of+      NilFL -> do putInfo opts nothingSendable+                  exitSuccess+      _     -> putVerbose opts $ selectionIs (mapFL description us')+  pristine <- readPristine repo+  let direction = if changesReverse ? opts then FirstReversed else First+      selection_config = selectionConfig direction "send" (patchSelOpts opts) Nothing Nothing+  (to_be_sent :> _) <- runSelection us' selection_config+  printDryRunMessageAndExit "send"+      (verbosity ? opts)+      (O.withSummary ? opts)+      (dryRun ? opts)+      O.NoXml+      (isInteractive True opts)+      to_be_sent+  when (nullFL to_be_sent) $ do+      putInfo opts selectionIsNull+      exitSuccess+  setEnvDarcsPatches to_be_sent++  let genFullBundle = prepareBundle opts common  (Right (pristine, us':\/:to_be_sent))+  bundle <- if not (minimize ? opts)+             then genFullBundle+             else do putInfo opts "Minimizing context, to send with full context hit ctrl-C..."+                     ( case minContext common to_be_sent of+                         Sealed (common' :> to_be_sent') -> prepareBundle opts common' (Left to_be_sent') )+                     `catchInterrupt` genFullBundle+  here   <- getCurrentDirectory+  let make_fname (tb:>:_) = getUniqueDPatchName $ patchDesc tb+      make_fname _ = error "impossible case"+  let fname = make_fname to_be_sent+  let outname = case getOutput opts fname of+                    Just f  -> Just f+                    Nothing | O.mail ? opts -> Nothing+                            | not $ null [ p | PostHttp p <- wtds] -> Nothing+                            | otherwise        -> Just (makeAbsoluteOrStd here <$> fname)+  case outname of+    Just fname' -> fname' >>= \f -> writeBundleToFile opts to_be_sent bundle f wtds their_name+    Nothing     -> fname >>= \f -> sendBundle opts to_be_sent bundle f wtds their_name+++prepareBundle :: forall p wX wY wZ. (RepoPatch p, ApplyState p ~ Tree)+              => [DarcsFlag] -> PatchSet p Origin wZ+              -> Either (FL (PatchInfoAnd p) wX wY)+                        (Tree IO, (FL (PatchInfoAnd p) :\/: FL (PatchInfoAnd p)) wX wY)+              -> IO Doc+prepareBundle opts common e = do+  unsig_bundle <-+     case e of+       (Right (pristine, us' :\/: to_be_sent)) -> do+         pristine' <- applyToTree (invert $ effect us') pristine+         makeBundle (Just pristine')+                     (unsafeCoerceP common)+                     (mapFL_FL hopefully to_be_sent)+       Left to_be_sent -> makeBundle Nothing+                                      (unsafeCoerceP common)+                                      (mapFL_FL hopefully to_be_sent)+  signString (O.sign ? opts) unsig_bundle++sendBundle+  :: forall p wX wY+   . (RepoPatch p, ApplyState p ~ Tree)+  => [DarcsFlag]+  -> FL (PatchInfoAnd p) wX wY+  -> Doc+  -> String+  -> [WhatToDo]+  -> String+  -> IO ()+sendBundle opts to_be_sent bundle fname wtds their_name = do+  let auto_subject :: forall pp wA wB. FL (PatchInfoAnd pp) wA wB -> String+      auto_subject (p :>: NilFL) = "darcs patch: " ++ trim (patchDesc p) 57+      auto_subject (p :>: ps) =+        "darcs patch: " +++        trim (patchDesc p) 43 ++ " (and " ++ show (lengthFL ps) ++ " more)"+      auto_subject _ = error "Tried to get a name from empty patch list."+      trim st n =+        if length st <= n+          then st+          else take (n - 3) st ++ "..."+  thetargets <- getTargets wtds+  from <- getAuthor (author ? opts) False+  let thesubject = fromMaybe (auto_subject to_be_sent) $ getSubject opts+  (mailcontents, mailfile, mailcharset) <-+    getDescription opts their_name to_be_sent+  let warnMailBody =+        case mailfile of+          Just mf -> putDocLn $ emailBackedUp mf+          Nothing -> return ()+      warnCharset msg = do+        confirmed <- promptYorn $ promptCharSetWarning msg+        unless confirmed $ do+          putDocLn charsetAborted+          warnMailBody+          exitSuccess+  thecharset <-+    case charset ? opts of+      -- Always trust provided charset+      providedCset@(Just _) ->+        return providedCset+      Nothing ->+        case mailcharset of+          Nothing -> do+            warnCharset charsetCouldNotGuess+            return mailcharset+          Just "utf-8" ->+            return mailcharset+          -- Trust other cases (us-ascii)+          Just _ -> return mailcharset+  let body =+        makeEmail+          their_name+          (maybe [] (\x -> [("In-Reply-To", x), ("References", x)]) .+           getInReplyTo $+           opts)+          (Just mailcontents) thecharset bundle (Just fname)+      contentAndBundle = Just (mailcontents, bundle)+      sendmail =+        (do let to = generateEmailToString thetargets+            sm_cmd <- getSendmailCmd opts+            sendEmailDoc from to thesubject (getCc opts) sm_cmd+              contentAndBundle body+            putInfo opts (success to (getCc opts)))+        `onException`+        warnMailBody+  when (null [p | PostHttp p <- thetargets]) sendmail+  nbody <-+    withOpenTemp $ \(fh, fn) -> do+      let to = generateEmailToString thetargets+      generateEmail fh from to thesubject (getCc opts) body+      hClose fh+      mmapFilePS fn+  forM_+    [p | PostHttp p <- thetargets]+    (\url -> do+       putInfo opts $ postingPatch url+       postUrl url nbody "message/rfc822") `catch`+    (\(_ :: IOException) -> sendmail)+  cleanup opts mailfile++generateEmailToString :: [WhatToDo] -> String+generateEmailToString = intercalate " , " . filter (/= "") . map extractEmail+  where+    extractEmail (SendMail t) = t+    extractEmail _ = ""++cleanup :: (FilePathLike t) => [DarcsFlag] -> Maybe t -> IO ()+cleanup opts (Just mailfile) = when (isNothing (hasLogfile opts) || willRemoveLogFile opts) $+                                      removeFileMayNotExist mailfile+cleanup _ Nothing = return ()++writeBundleToFile :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree)+                  => [DarcsFlag] -> FL (PatchInfoAnd p) wX wY -> Doc ->+                    AbsolutePathOrStd -> [WhatToDo] -> String -> IO ()+writeBundleToFile opts to_be_sent bundle fname wtds their_name =+    do (d,f,_) <- getDescription opts their_name to_be_sent+       let putabs a = do writeDocBinFile a (d $$ bundle)+                         putDocLn (wroteBundle a)+           putstd = putDoc (d $$ bundle)+       useAbsoluteOrStd putabs putstd fname+       let to = generateEmailToString wtds+       unless (null to) $ putInfo opts $ savedButNotSent to+       cleanup opts f++data WhatToDo+    = PostHttp String    -- ^ POST the patch via HTTP+    | SendMail String    -- ^ send patch via email++decideOnBehavior :: [DarcsFlag] -> Maybe (Repository rt p wU wR) -> IO [WhatToDo]+decideOnBehavior opts remote_repo =+    case the_targets of+    [] -> do wtds <- case remote_repo of+                     Nothing -> return []+                     Just r -> check_post r+             unless (null wtds) $ announce_recipients wtds+             return wtds+    ts -> do announce_recipients ts+             return ts+    where the_targets = collectTargets opts+          check_post the_remote_repo =+                       do p <- ((readPost . BC.unpack) `fmap`+                                fetchFilePS (prefsUrl (repoLocation the_remote_repo) Post)+                                (MaxAge 600)) `catchall` return []+                          emails <- who_to_email the_remote_repo+                          return (p++emails)+          readPost = map parseLine . lines where+              parseLine t = maybe (PostHttp t) SendMail $ stripPrefix "mailto:" t+          who_to_email repo =+              do email <- (BC.unpack `fmap`+                           fetchFilePS (prefsUrl (repoLocation repo) Email)+                                       (MaxAge 600))+                          `catchall` return ""+                 if '@' `elem` email then return . map SendMail $ lines email+                                     else return []+          announce_recipients emails =+            let pn (SendMail s) = s+                pn (PostHttp p) = p+                msg = willSendTo (dryRun ? opts) (map pn emails)+            in case dryRun ? opts of+                O.YesDryRun -> putInfo opts msg+                O.NoDryRun  -> when (null the_targets && isNothing (getOutput opts (return ""))) $+                                putInfo opts msg++getTargets :: [WhatToDo] -> IO [WhatToDo]+getTargets [] = fmap ((:[]) . SendMail) $ askUser promptTarget+getTargets wtds = return wtds++collectTargets :: [DarcsFlag] -> [WhatToDo]+collectTargets flags = [ f t | t <- O._to (O.headerFields ? flags) ] where+    f url | "http:" `isPrefixOf` url = PostHttp url+    f em = SendMail em++getDescription :: RepoPatch p+               => [DarcsFlag] -> String -> FL (PatchInfoAnd p) wX wY -> IO (Doc, Maybe String, Maybe String)+getDescription opts their_name patches =+    case get_filename of+        Just file -> do+                     when (editDescription ? opts) $ do+                       when (isNothing $ hasLogfile opts) $+                            writeDocBinFile file patchdesc+                       debugMessage $ aboutToEdit file+                       (_, changed) <- editFile file+                       unless changed $ do+                         confirmed <- promptYorn promptNoDescriptionChange+                         unless confirmed $ do putDocLn aborted+                                               exitSuccess+                       return ()+                     +                     updatedFile <- updateFilename file+                     doc <- readDocBinFile updatedFile+                     +                     return (doc, Just updatedFile, tryGetCharset doc)+        Nothing -> return (patchdesc, Nothing, tryGetCharset patchdesc)+    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+          get_filename = case hasLogfile opts of+                                Just f -> Just $ toFilePath f+                                Nothing -> if editDescription ? opts+                                              then Just darcsSendMessage+                                              else Nothing+          tryGetCharset content = let body = renderPS content in+                                  if isAscii body+                                  then Just "us-ascii"+                                  else either (const Nothing)+                                              (const $ Just "utf-8")+                                              (decodeUtf8' body)++cmdDescription :: String+cmdDescription =+    "Prepare a bundle of patches to be applied to some target repository."++cmdHelp :: Doc+cmdHelp = vsep $+  map formatWords+  [ [ "Send is used to prepare a bundle of patches that can be applied to a target"+    , "repository.  Send accepts the URL of the repository as an argument.  When"+    , "called without an argument, send will use the most recent repository that"+    , "was either pushed to, pulled from or sent to.  By default, the patch bundle"+    , "is saved to a file, although you may directly send it by mail."+    ]+  , [ "The `--output`, `--output-auto-name`, and `--to` flags determine"+    , "what darcs does with the patch bundle after creating it.  If you provide an"+    , "`--output` argument, the patch bundle is saved to that file.  If you"+    , "specify `--output-auto-name`, the patch bundle is saved to a file with an"+    , "automatically generated name.  If you give one or more `--to` arguments,"+    , "the bundle of patches is sent to those locations. The locations may either"+    , "be email addresses or urls that the patch should be submitted to via HTTP."+    ]+  , [ "If you provide the `--mail` flag, darcs will look at the contents"+    , "of the `_darcs/prefs/email` file in the target repository (if it exists),"+    , "and send the patch by email to that address.  In this case, you may use"+    , "the `--cc` option to specify additional recipients without overriding the"+    , "default repository email address."+    ]+  , [ "If `_darcs/prefs/post` exists in the target repository, darcs will"+    , "upload to the URL contained in that file, which may either be a"+    , "`mailto:` URL, or an `http://` URL.  In the latter case, the"+    , "patch is posted to that URL."+    ]+  , [ "If there is no email address associated with the repository, darcs will"+    , "prompt you for an email address."+    ]+  , [ "Use the `--subject` flag to set the subject of the e-mail to be sent."+    , "If you don't provide a subject on the command line, darcs will make one up"+    , "based on names of the patches in the patch bundle."+    ]+  , [ "Use the `--in-reply-to` flag to set the In-Reply-To and References headers"+    , "of the e-mail to be sent. By default no additional headers are included so"+    , "e-mail will not be treated as reply by mail readers."+    ]+  , [ "If you want to include a description or explanation along with the bundle"+    , "of patches, you need to specify the `--edit-description` flag, which"+    , "will cause darcs to open up an editor with which you can compose a message"+    , "to go along with your patches."+    ]+  , [ "If you want to use a command different from the default one for sending"+    , "email, you need to specify a command line with the `--sendmail-command`"+    , "option. The command line can contain some format specifiers which are"+    , "replaced by the actual values. Accepted format specifiers are `%s` for"+    , "subject, `%t` for to, `%c` for cc, `%b` for the body of the mail, `%f` for"+    , "from, `%a` for the patch bundle and the same specifiers in uppercase for the"+    , "URL-encoded values."+    , "Additionally you can add `%<` to the end of the command line if the command"+    , "expects the complete email message on standard input. E.g. the command lines"+    , "for evolution and msmtp look like this:"+    ]+  ]+  +++  -- TODO autoformatting for indented paragraphs+  [ vcat+    [ "    evolution \"mailto:%T?subject=%S&attach=%A&cc=%C&body=%B\""+    , "    msmtp -t %<"+    ]+  ]+  ++ map formatWords+  [ [ "Do not confuse the `--author` options with the return address"+    , "that `darcs send` will set for your patch bundle."+    ]+  , [ "For example, if you have two email addresses A and B:"+    ]+  ]+  +++  -- TODO autoformatting for bullet lists+  [ vcat+    [ "  * If you use `--author A` but your machine is configured to send"+    , "    mail from address B by default, then the return address on your"+    , "    message will be B."+    , "  * If you use `--from A` and your mail client supports setting the"+    , "    From: address arbitrarily (some non-Unix-like mail clients,"+    , "    especially, may not support this), then the return address will"+    , "    be A; if it does not support this, then the return address will"+    , "    be B."+    , "  * If you supply neither `--from` nor `--author` then the return"+    , "    address will be B."+    ]+  ]+  +++  [ formatWords+    [ "In addition, unless you specify the sendmail command with"+    , "`--sendmail-command`, darcs sends email using the default email"+    , "command on your computer. This default command is determined by the"+    , "`configure` script. Thus, on some non-Unix-like OSes,"+    , "`--from` is likely to not work at all."+    ]+  , otherHelpInheritDefault+  ]++cannotSendToSelf :: String+cannotSendToSelf = "Can't send to current repository! Did you mean send --context?"++creatingPatch :: String -> Doc+creatingPatch repodir = "Creating patch to" <+> quoted repodir <> "..."++nothingSendable :: Doc+nothingSendable = "No recorded local changes to send!"++selectionIs :: [Doc] -> Doc+selectionIs descs = text "We have the following patches to send:" $$ vcat descs++selectionIsNull :: Doc+selectionIsNull = text "You don't want to send any patches, and that's fine with me!"++emailBackedUp :: String -> Doc+emailBackedUp mf = sentence $ "Email body left in" <+> text mf <> "."++promptCharSetWarning :: String -> String+promptCharSetWarning msg = "Warning: " ++ msg ++ "  Send anyway?"++charsetAborted :: Doc+charsetAborted = "Aborted.  You can specify charset with the --charset option."++charsetCouldNotGuess :: String+charsetCouldNotGuess = "darcs could not guess the charset of your mail."++aborted :: Doc+aborted = "Aborted."++success :: String -> String -> Doc+success to cc = sentence $+    "Successfully sent patch bundle to:" <+> text to <+> copies cc+  where+    copies "" = ""+    copies x  = "and cc'ed" <+> text x++postingPatch :: String -> Doc+postingPatch url = "Posting patch to" <+> text url++wroteBundle :: FilePathLike a => a -> Doc+wroteBundle a = sentence $ "Wrote patch to" <+> text (toFilePath a)++savedButNotSent :: String -> Doc+savedButNotSent to =+        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 =+    "Patch bundle" <+> will <+> " be sent to:" <+> text (unwords addresses)+  where+    will = case dr of { YesDryRun -> "would"; NoDryRun  -> "will" }++promptTarget :: String+promptTarget = "What is the target email address? "++aboutToEdit :: FilePath -> String+aboutToEdit file = "About to edit file " ++ file++promptNoDescriptionChange :: String+promptNoDescriptionChange = "File content did not change. Continue anyway?"
+ src/Darcs/UI/Commands/SetPref.hs view
@@ -0,0 +1,128 @@+--  Copyright (C) 2003 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.SetPref ( setpref ) where++import Darcs.Prelude++import System.Exit ( exitWith, ExitCode(..) )+import Control.Monad ( when, void )+import Data.Maybe ( fromMaybe )++import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , nodefaults+    , withStdOpts+    )+import Darcs.UI.Flags ( DarcsFlag, diffingOpts, useCache, umask)+import Darcs.UI.Options ( (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository+    ( RepoJob(..)+    , addToPending+    , finalizeRepositoryChanges+    , withRepoLock+    )+import Darcs.Patch ( changepref )+import Darcs.Patch.Witnesses.Ordered ( FL(..) )+import Darcs.Repository.Prefs ( getPrefval, changePrefval )+import Darcs.Util.English ( orClauses )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, text )++-- | A list of all valid preferences for @_darcs/prefs/prefs@.+validPrefData :: [(String, String)] -- ^ (name, one line description)+validPrefData =+    [("test", "a shell command that runs regression tests"),+     ("predist", "a shell command to run before `darcs dist'"),+     ("boringfile", "the path to a version-controlled boring file"),+     ("binariesfile", "the path to a version-controlled binaries file")]++validPrefs :: [String]+validPrefs = map fst validPrefData++setprefDescription :: String+setprefDescription =+    "Set a preference (" ++ orClauses validPrefs ++ ")."++setprefHelp :: Doc+setprefHelp = text $+ "When working on project with multiple repositories and contributors,\n" +++ "it is sometimes desirable for a preference to be set consistently\n" +++ "project-wide.  This is achieved by treating a preference set with\n" +++ "`darcs setpref` as an unrecorded change, which can then be recorded\n" +++ "and then treated like any other patch.\n" +++ "\n" +++ "Valid preferences are:\n" +++ "\n" +++ unlines ["* "++x++" -- "++y | (x,y) <- validPrefData] +++ "\n" +++ "For example, a project using GNU autotools, with a `make test` target\n" +++ "to perform regression tests, might enable Darcs' integrated regression\n" +++ "testing with the following command:\n" +++ "\n" +++ "    darcs setpref test 'autoconf && ./configure && make && make test'\n" +++ "\n" +++ "Note that merging is not currently implemented for preferences: if two\n" +++ "patches attempt to set the same preference, the last patch applied to\n" +++ "the repository will always take precedence.  This is considered a\n" +++ "low-priority bug, because preferences are seldom set.\n"++setpref :: DarcsCommand+setpref = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "setpref"+    , commandHelp = setprefHelp+    , commandDescription = setprefDescription+    , commandExtraArgs = 2+    , commandExtraArgHelp = ["<PREF>", "<VALUE>"]+    , commandCommand = setprefCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = completeArgs+    , commandArgdefaults = nodefaults+    , commandOptions = setprefOpts+    }+  where+    setprefBasicOpts = O.repoDir+    setprefAdvancedOpts = O.umask+    setprefOpts = setprefBasicOpts `withStdOpts` setprefAdvancedOpts+    completeArgs _ _ [] = return validPrefs+    completeArgs _ _ _args = return []++setprefCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+setprefCmd _ opts [pref,val] =+ withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \repository -> do+  when (' ' `elem` pref) $ do+    putStrLn $ "'"++pref+++               "' is not a valid preference name: no spaces allowed!"+    exitWith $ ExitFailure 1+  when (pref `notElem` validPrefs) $ do+    putStrLn $ "'"++pref++"' is not a valid preference name!"+    putStrLn $ "Try one of: " ++ unwords validPrefs+    exitWith $ ExitFailure 1+  oval <- getPrefval pref+  let old = fromMaybe "" oval+  when ('\n' `elem` val) $ do+    putStrLn $ val ++ "is not a valid preference value: newlines forbidden!"+    exitWith $ ExitFailure 1+  changePrefval pref old val+  putStrLn $ "Changing value of "++pref++" from '"++old++"' to '"++val++"'"+  addToPending repository (diffingOpts opts) (changepref pref old val :>: NilFL)+  void $ finalizeRepositoryChanges repository (O.dryRun ? opts)+setprefCmd _ _ _ = error "impossible case"+
+ src/Darcs/UI/Commands/Show.hs view
@@ -0,0 +1,63 @@+--  Copyright (C) 2002-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Show ( showCommand ) where++import Darcs.Prelude++import Darcs.UI.Commands ( DarcsCommand(..)+                         , normalCommand+                         , amInRepository+                         )+import Darcs.UI.Commands.ShowAuthors ( showAuthors )+import Darcs.UI.Commands.ShowContents ( showContents )+import Darcs.UI.Commands.ShowDependencies ( showDeps )+import Darcs.UI.Commands.ShowFiles ( showFiles )+import Darcs.UI.Commands.ShowTags ( showTags )+import Darcs.UI.Commands.ShowRepo ( showRepo )+import Darcs.UI.Commands.ShowIndex ( showIndex, showPristine )+import Darcs.UI.Commands.ShowPatchIndex ( showPatchIndex )+import Darcs.Util.Printer ( Doc, formatWords )++showDescription :: String+showDescription = "Show information about the given repository."++showHelp :: Doc+showHelp = formatWords+  [ "Display various information about a repository. See description of the"+  , "subcommands for details."+  ]++showCommand :: DarcsCommand+showCommand = SuperCommand+    { commandProgramName = "darcs"+    , commandName = "show"+    , commandHelp = showHelp+    , commandDescription = showDescription+    , commandPrereq = amInRepository+    , commandSubCommands =+      [ normalCommand showContents+      , normalCommand showDeps+      , normalCommand showFiles+      , normalCommand showIndex+      , normalCommand showPristine+      , normalCommand showRepo+      , normalCommand showAuthors+      , normalCommand showTags+      , normalCommand showPatchIndex ]+    }+
+ src/Darcs/UI/Commands/ShowAuthors.hs view
@@ -0,0 +1,211 @@+--  Copyright (C) 2004-2009 David Roundy, Eric Kow, Simon Michael, Tomas Caithaml+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.ShowAuthors+    ( showAuthors, Spelling, compiledAuthorSpellings, canonizeAuthor, rankAuthors+    ) where++import Control.Arrow ( (&&&), (***) )+import Data.Char ( toLower, isSpace )+import Data.Function ( on )+import Data.List ( isInfixOf, sortBy, sort )+import Data.List.NonEmpty ( group, groupBy )+import qualified Data.List.NonEmpty as NE+import Data.Maybe( isJust )+import Data.Ord ( comparing )+import System.IO.Error ( catchIOError )+import Text.ParserCombinators.Parsec hiding ( lower, count, Line )+import Text.ParserCombinators.Parsec.Error++import Darcs.Prelude++import Darcs.UI.Flags ( DarcsFlag, useCache, verbose )+import Darcs.UI.Options ( oid, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, putWarning, amInRepository )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.External ( viewDoc )+import Darcs.Patch.PatchInfoAnd ( info )+import Darcs.Patch.Info ( piAuthor )+import Darcs.Patch.Set ( patchSet2RL )+import Darcs.Repository ( readPatches, withRepository, RepoJob(..) )+import Darcs.Patch.Witnesses.Ordered ( mapRL )+import Darcs.Util.Lock ( readTextFile )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Regex ( Regex, mkRegexWithOpts, matchRegex )++data Spelling = Spelling String String [Regex] -- name, email, regexps+type ParsedLine = Maybe Spelling -- Nothing for blank lines++showAuthorsDescription :: String+showAuthorsDescription = "List authors by patch count."++showAuthorsHelp :: Doc+showAuthorsHelp = text $+ "The `darcs show authors` command lists the authors of the current\n" +++ "repository, sorted by the number of patches contributed.  With the\n" +++ "`--verbose` option, this command simply lists the author of each patch\n" +++ "(without aggregation or sorting).\n" +++ "\n" +++ "An author's name or email address may change over time.  To tell Darcs\n" +++ "when multiple author strings refer to the same individual, create an\n" +++ "`.authorspellings` file in the root of the working tree.  Each line in\n" +++ "this file begins with an author's canonical name and address, and may\n" +++ "be followed by a comma separated list of extended regular expressions.\n" +++ "Blank lines and lines beginning with two hyphens are ignored.\n" +++ "The format of `.authorspelling` can be described by this pattern:\n" +++ "\n" +++ "    name <address> [, regexp ]*\n" +++ "\n" +++ "There are some pitfalls concerning special characters:\n" +++ "Whitespaces are stripped, if you need space in regexp use [ ]. \n" +++ "Because comma serves as a separator you have to escape it if you want\n" +++ "it in regexp. Note that `.authorspelling` use extended regular\n" +++ "expressions so +, ? and so on are metacharacters and you need to \n" +++ "escape them to be interpreted literally.\n" +++ "\n" +++ "Any patch with an author string that matches the canonical address or\n" +++ "any of the associated regexps is considered to be the work of that\n" +++ "author.  All matching is case-insensitive and partial (it can match a\n" +++ "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 log` use author strings\n" +++ "verbatim.\n" +++ "\n" +++ "An example `.authorspelling` file is:\n" +++ "\n" +++ "    -- This is a comment.\n" +++ "    Fred Nurk <fred@example.com>\n" +++ "    John Snagge <snagge@bbc.co.uk>, John, snagge@, js@(si|mit).edu\n" +++ "    Chuck Jones\\, Jr. <chuck@pobox.com>, cj\\+user@example.com\n"++showAuthors :: DarcsCommand+showAuthors = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "authors"+    , commandHelp = showAuthorsHelp+    , commandDescription = showAuthorsDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = authorsCmd+    , commandPrereq = amInRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = showAuthorsOpts+    }+  where+    showAuthorsBasicOpts = O.repoDir+    showAuthorsOpts = showAuthorsBasicOpts `withStdOpts` oid++authorsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+authorsCmd _ flags _ = withRepository (useCache ? flags) $ RepoJob $ \repository -> do+    patches <- readPatches repository+    spellings <- compiledAuthorSpellings flags+    let authors = mapRL (piAuthor . info) $ patchSet2RL patches+    viewDoc $ text $ unlines $+        if verbose flags+            then authors+            else rankAuthors spellings authors++rankAuthors :: [Spelling] -> [String] -> [String]+rankAuthors spellings authors =+              -- A list of the form ["#<rank> <count> <canonical name>"].+              -- Turn the final result into a list of strings.+              map (\ (rank, (count, name)) -> "#" ++ show rank ++ "\t"+                                              ++ show count ++ "\t" ++ name) .+              zip ([1..] :: [Int]) .+              -- Sort by descending patch count.+              reverse $ sortBy (comparing fst) .+              -- Combine duplicates from a list [(count, canonized name)]+              -- with duplicates canonized names (see next comment).+              map ((sum *** NE.head) . NE.unzip) .+              groupBy ((==) `on` snd) .+              sortBy  (comparing snd) .+              -- Because it would take a long time to canonize "foo" into+              -- "foo <foo@bar.baz>" once per patch, the code below+              -- generates a list [(count, canonized name)].+              map (length &&& (canonizeAuthor spellings . NE.head)) .+              group $ sort authors++canonizeAuthor :: [Spelling] -> String -> String+canonizeAuthor spells author = getName canonicals+  where+    getName [] = author+    getName (Spelling name email _ : _) = name ++ " <" ++ email ++ ">"+    canonicals = filter (ismatch author) spells+    ismatch s (Spelling _ mail regexps) =+        s `correspondsTo` mail || any (s `contains_regex`) regexps+    contains_regex a r = isJust $ matchRegex r a+    correspondsTo a b = lower b `isInfixOf` lower a+    lower = map toLower++compiledAuthorSpellings :: [DarcsFlag] -> IO [Spelling]+compiledAuthorSpellings flags = do+    let as_file = ".authorspellings"+    content_lines <- readTextFile as_file `catchIOError` (const (return []))+    let parse_results = map (parse sentence as_file) content_lines+    clean 1 parse_results+  where+    clean :: Int -> [Either ParseError ParsedLine] -> IO [Spelling]+    clean _ [] = return []+    -- print parse error+    clean n (Left err : xs) = do+      let npos = setSourceLine (errorPos err) n+      putWarning flags . text . show $ setErrorPos npos err+      clean (n + 1) xs+    -- skip blank line+    clean n (Right Nothing : xs)  = clean (n + 1) xs+    -- unwrap Spelling+    clean n (Right (Just a) : xs) = do+      as <- clean (n + 1) xs+      return (a : as)++----------+-- PARSERS++sentence :: Parser ParsedLine+sentence = spaces >> (comment <|> blank <|> addressline)+  where+    comment = string "--" >> return Nothing+    blank = eof >> return Nothing++addressline :: Parser ParsedLine+addressline = do+    name <- canonicalName <?> "Canonical name"+    addr <- between (char '<') (char '>') (many1 (noneOf ">")) <?> "Address"+    spaces+    rest <- option [] (char ',' >> regexp `sepBy` char ',')+            <?> "List of regexps"+    return $ Just $ Spelling (strip name) addr (compile rest)+  where+    strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse+    makeRegex s = mkRegexWithOpts s True False+    compile = map makeRegex . filter (not . null) . map strip++    parseComma = string "\\," >> return ','++    regexp :: Parser String+    regexp = many1 p <?> "Regular expression"+      where+        p = try parseComma <|> noneOf ","++    canonicalName :: Parser String+    canonicalName = many1 p+      where+        p = try parseComma <|> noneOf ",<"
+ src/Darcs/UI/Commands/ShowContents.hs view
@@ -0,0 +1,81 @@+--  Copyright (C) 2007 Eric Kow+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.ShowContents ( showContents ) where++import Control.Monad ( filterM, forM_, forM, when )+import System.IO ( stdout )++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL++import Darcs.Prelude++import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags ( DarcsFlag, useCache, pathsFromArgs )+import Darcs.UI.Options ( (^), oid, parseFlags, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Patch.Match ( patchSetMatch )+import Darcs.Repository ( withRepository, RepoJob(..), readPristine )+import Darcs.Repository.Match ( getPristineUpToMatch )+import qualified Darcs.Util.Tree.Monad as TM+import Darcs.Util.Path( AbsolutePath )+import Darcs.Util.Printer ( Doc, text )++showContentsDescription :: String+showContentsDescription = "Outputs a specific version of a file."++showContentsHelp :: Doc+showContentsHelp = text $+  "Show contents can be used to display an earlier version of some file(s).\n"+++  "If you give show contents no version arguments, it displays the recorded\n"+++  "version of the file(s).\n"++showContents :: DarcsCommand+showContents = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "contents"+    , commandHelp = showContentsHelp+    , commandDescription = showContentsDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[FILE]..."]+    , commandCommand = showContentsCmd+    , commandPrereq = findRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = showContentsOpts+    }+  where+    showContentsOpts = O.matchUpToOne ^ O.repoDir `withStdOpts` oid++showContentsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showContentsCmd _ _ [] = fail "show contents needs at least one argument."+showContentsCmd fps opts args = do+  paths <- pathsFromArgs fps args+  when (null paths) $ fail "No valid repository paths were given."+  let matchFlags = parseFlags O.matchUpToOne opts+  withRepository (useCache ? opts) $ RepoJob $ \repository -> do+    let readContents = do+          okpaths <- filterM TM.fileExists paths+          forM okpaths $ \f -> (B.concat . BL.toChunks) `fmap` TM.readFile f+        execReadContents tree = fst `fmap` TM.virtualTreeIO readContents tree+    files <-+      (case patchSetMatch matchFlags of+        Just psm -> getPristineUpToMatch repository psm+        Nothing -> readPristine repository) >>= execReadContents+    forM_ files $ B.hPut stdout
+ src/Darcs/UI/Commands/ShowDependencies.hs view
@@ -0,0 +1,169 @@+{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.ShowDependencies ( showDeps ) where++import Darcs.Prelude++import qualified Data.Map.Strict as M+import Data.Maybe( fromJust, fromMaybe )+import qualified Data.Set as S++import Darcs.Repository ( RepoJob(..), readPatches, withRepositoryLocation )++import Darcs.UI.Flags ( DarcsFlag, getRepourl, useCache )+import Darcs.UI.Options ( oid, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands ( DarcsCommand(..), nodefaults, findRepository, withStdOpts )+import Darcs.UI.Commands.Util ( matchRange )+import Darcs.UI.Completion ( noArgs )++import Darcs.Util.Hash ( sha1short, showAsHex )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer+    ( Doc+    , (<+>)+    , ($+$)+    , formatText+    , formatWords+    , hsep+    , prefixLines+    , putDocLn+    , quoted+    , renderString+    , text+    , vcat+    )+import Darcs.Util.Progress ( beginTedious, endTedious, progress, tediousSize )++import Darcs.Patch.Commute ( Commute, commuteFL )+import Darcs.Patch.Ident ( PatchId, Ident(..) )+import Darcs.Patch.Info ( PatchInfo, piName, makePatchname )+import Darcs.Patch.Witnesses.Ordered+    ( (:>)(..)+    , FL(..)+    , RL(..)+    , reverseFL+    , lengthFL+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )++showDepsDescription :: String+showDepsDescription = "Generate the graph of dependencies."++showDepsHelp :: Doc+showDepsHelp =+  formatWords+    [ "This command creates a graph of the dependencies between patches."+    , "The output format is the Dot Language, see"+    , "https://www.graphviz.org/doc/info/lang.html. The resulting graph"+    , "is transitively reduced, in other words,"+    , "it contains only the direct dependencies, not the indirect ones."+    ]+  $+$ formatWords+    [ "By default all patches in your repository are considered. You can"+    , "limit this to a range of patches using patch matching options, see"+    , "`darcs help patterns` and the options avaiable for this command."+    , "For instance, to visualize the dependencies between all patches"+    , "since the last tag, do:"+    ]+  $+$ "    darcs show dependencies --from-tag=. | dot -Tpdf -o FILE.pdf"+  $+$ formatWords+    [ "This command can take a very(!) long time to compute its result,"+    , "depending on the number of patches in the selected range. For N"+    , "patches it needs to do on the order of N^3 commutations in the"+    , "worst case."+    ]++showDeps :: DarcsCommand+showDeps = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "dependencies"+    , commandHelp = showDepsHelp+    , commandDescription = showDepsDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = depsCmd+    , commandPrereq = findRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = showDepsOpts+    }+  where+    showDepsBasicOpts = O.matchRange+    showDepsOpts = showDepsBasicOpts `withStdOpts` oid++progressKey :: String+progressKey = "Determining dependencies"++depsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+depsCmd _ opts _ = do+    let repodir = fromMaybe "." (getRepourl opts)+    withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo -> do+        Sealed2 range <- matchRange (O.matchRange ? opts) <$> readPatches repo+        beginTedious progressKey+        tediousSize progressKey (lengthFL range)+        putDocLn $ renderDepsGraphAsDot $ depsGraph $ reverseFL range+        endTedious progressKey++-- | A 'M.Map' from 'PatchId's to 'Deps'.+type DepsGraph p = M.Map (PatchId p) (Deps p)++-- | A pair of (direct, indirect) dependencies. For the result we need only the+-- direct dependencies. We store the indirect ones as an optimization to avoid+-- doing commutes for which we already know that they cannot succeed. Note that+-- the two sets are always disjoint.+type Deps p = (S.Set (PatchId p), S.Set (PatchId p))++-- | Determine the 'DepsGraph' of an 'RL' of patches.+depsGraph :: forall p wX wY. (Commute p, Ident p) => RL p wX wY -> DepsGraph p+depsGraph NilRL = M.empty+depsGraph (ps :<: p) =+  M.insert (ident p) (foldDeps ps (p :>: NilFL) NilFL (S.empty, S.empty)) m+  where+    -- First recurse on the context. The result now has all the 'Deps' for+    -- all patches preceding p.+    m = depsGraph ps+    -- Lookup all (direct and indirect) dependencies of a patch in a given+    -- 'DepsGraph'+    allDeps j = uncurry S.union . fromJust . M.lookup j+    -- Add all (direct and indirect) dependencies of a patch to a given set+    addDeps j = S.insert j . S.union (allDeps j m)+    -- Add direct and indirect dependencies of a patch, assuming that the+    -- graph has already been constructed for all patches in the context.+    foldDeps :: RL p wA wB -> FL p wB wC -> FL p wC wD -> Deps p -> Deps p+    foldDeps NilRL _ _ acc = progress progressKey acc+    foldDeps (qs :<: q) p_and_deps non_deps acc@(direct, indirect)+      -- If we already know we indirectly depend on q, then there is+      -- nothing left to do. Note that (j `S.member` direct) is impossible.+      | j `S.member` indirect = foldDeps qs (q :>: p_and_deps) non_deps acc+      -- If q commutes past p_and_deps then we don't depend on it+      | Just (p_and_deps' :> q') <- commuteFL (q :> p_and_deps) =+        foldDeps qs p_and_deps' (q' :>: non_deps) acc+      -- We have a new dependency which must be a direct one, so add it to+      -- 'direct' and all its dependencies to 'indirect'. The invariant that+      -- direct and indirect are disjoint is maintained because neither the+      -- direct nor indirect deps of a patch contain its own 'PatchId'.+      | otherwise =+        foldDeps qs (q :>: p_and_deps) non_deps (S.insert j direct, addDeps j indirect)+      where+        j = ident q++-- | Render a 'DepsGraph' in the Dot Language format. This function+-- considers only the direct dependencies.+renderDepsGraphAsDot :: M.Map PatchInfo (S.Set PatchInfo, S.Set PatchInfo) -> Doc+renderDepsGraphAsDot g = vcat ["digraph {", indent body, "}"]+  where+    indent = prefixLines ("  ")+    body = vcat+      [ "graph [rankdir=LR];"+      , "node [imagescale=true];"+      , vcat (map showNode (map fst pairs))+      , vcat (map showEdges pairs)+      ]+    pairs = M.toList $ M.map fst g+    showEdges (i, ds)+      | S.null ds = mempty+      | otherwise =+          hsep [showID i, "->", "{" <> hsep (map showID (S.toList ds)) <> "}"]+    showNode i = showID i <+> "[label=" <> showLabel i <> "]"+    showID = quoted . showAsHex . sha1short . makePatchname+    showLabel i = text $ show $ renderString $ formatText 20 [piName i]
+ src/Darcs/UI/Commands/ShowFiles.hs view
@@ -0,0 +1,127 @@+--  Copyright (C) 2005 Florian Weimer+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.ShowFiles ( showFiles ) where++import Darcs.Prelude++import Darcs.Patch.Match ( patchSetMatch )+import Darcs.Repository ( RepoJob(..), withRepository )+import Darcs.Repository.Match ( getPristineUpToMatch )+import Darcs.Repository.State ( readPristine, readPristineAndPending )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInRepository+    , nodefaults+    , withStdOpts+    )+import Darcs.UI.Completion ( knownFileArgs )+import Darcs.UI.Flags ( DarcsFlag, pathsFromArgs, useCache )+import Darcs.UI.Options ( oid, parseFlags, (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path+    ( AbsolutePath+    , AnchoredPath+    , anchoredRoot+    , displayPath+    , isPrefix+    )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Tree ( Tree, TreeItem(..), expand, list )++showFilesDescription :: String+showFilesDescription = "Show version-controlled files in the working tree."++showFilesHelp :: Doc+showFilesHelp = text $+ "The `darcs show files` command lists those files and directories in\n" +++ "the working tree that are under version control.  This command is\n" +++ "primarily for scripting purposes; end users will probably want `darcs\n" +++ "whatsnew --summary`.\n" +++ "\n" +++ "A file is \"pending\" if it has been added but not recorded.  By\n" +++ "default, pending files (and directories) are listed; the `--no-pending`\n" +++ "option prevents this.\n" +++ "\n" +++ "By default `darcs show files` lists both files and directories, but the\n" +++ "`--no-files` and `--no-directories` flags modify this behaviour.\n" +++ "\n" +++ "By default entries are one-per-line (i.e. newline separated).  This\n" +++ "can cause problems if the files themselves contain newlines or other\n" +++ "control characters.  To get around this, the `--null` option uses the\n" +++ "null character instead.  The script interpreting output from this\n" +++ "command needs to understand this idiom; `xargs -0` is such a command.\n" +++ "\n" +++ "For example, to list version-controlled files by size:\n" +++ "\n" +++ "    darcs show files -0 | xargs -0 ls -ldS\n"++showFiles :: DarcsCommand+showFiles = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "files"+    , commandHelp = showFilesHelp+    , commandDescription = showFilesDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+    , commandCommand = manifestCmd+    , commandPrereq = amInRepository+    , commandCompleteArgs = knownFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = showFilesOpts+    }+  where+    showFilesBasicOpts+      = O.files+      ^ O.directories+      ^ O.pending+      ^ O.nullFlag+      ^ O.matchUpToOne+      ^ O.repoDir+    showFilesOpts = showFilesBasicOpts `withStdOpts` oid++manifestCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+manifestCmd fps opts args = do+    paths <- pathsFromArgs fps args+    mapM_ output =<< manifestHelper opts paths+  where+    output_null name = do { putStr name ; putChar '\0' }+    output = if parseFlags O.nullFlag opts then output_null else putStrLn++manifestHelper :: [DarcsFlag] -> [AnchoredPath] -> IO [FilePath]+manifestHelper opts prefixes =+  fmap (map displayPath . onlysubdirs prefixes . listFilesOrDirs) $+    withRepository (useCache ? opts) $ RepoJob $ \r -> do+      case (patchSetMatch matchFlags, parseFlags O.pending opts) of+        (Nothing, False)  -> expand =<< readPristine r+        (Nothing, True)   -> expand =<< readPristineAndPending r+        (Just psm, False) -> getPristineUpToMatch r psm+        (Just _, True)    -> fail "can't mix match and pending flags"+  where+    matchFlags = parseFlags O.matchUpToOne opts++    onlysubdirs [] = id+    onlysubdirs dirs = filter (\p -> any (`isPrefix` p) dirs)++    listFilesOrDirs :: Tree IO -> [AnchoredPath]+    listFilesOrDirs =+        filesDirs (parseFlags O.files opts) (parseFlags O.directories opts)+      where+        filesDirs False False _ = []+        filesDirs False True t = anchoredRoot : [p | (p, SubTree _) <- list t]+        filesDirs True False t = [p | (p, File _) <- list t]+        filesDirs True True t = anchoredRoot : map fst (list t)
+ src/Darcs/UI/Commands/ShowIndex.hs view
@@ -0,0 +1,127 @@+-- Copyright (C) 2009 Petr Rockai+--+-- 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+-- SOFTWARE.++{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+module Darcs.UI.Commands.ShowIndex+    ( showIndex+    , showPristine+    ) where++import Darcs.Prelude++import Darcs.UI.Flags ( DarcsFlag, useCache )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Options ( (^), oid, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository ( withRepository, RepoJob(..) )+import Darcs.Repository.State ( readPristine )+import Darcs.Repository.Paths ( indexPath )++import Darcs.Util.Hash ( showHash )+import Darcs.Util.Tree( list, expand, itemHash, Tree, TreeItem( SubTree ) )+import Darcs.Util.Index( IndexEntry(..), dumpIndex )+import Darcs.Util.Path( anchorPath, AbsolutePath, anchoredRoot, realPath )+import Darcs.Util.Printer ( Doc, putDocLn, text, vcat )++import System.Posix.Types ( FileID )++import Control.Monad ( (>=>) )+import Data.Int ( Int64 )+import qualified Data.Map as M ( Map, lookup )+import Data.Maybe ( fromJust )+import Text.Printf ( printf )++showIndexHelp :: Doc+showIndexHelp = text $+  "The `darcs show index` command lists all version-controlled files and " +++  "directories along with their hashes as stored in `_darcs/index`. " +++  "For files, the fields correspond to file size, sha256 of the current " +++  "file content and the filename."++showIndex :: DarcsCommand+showIndex = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "index"+    , commandDescription = "Dump contents of working tree index."+    , commandHelp = showIndexHelp+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = showIndexCmd+    , commandPrereq = amInRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = showIndexOpts+    }+  where+    showIndexBasicOpts = O.nullFlag ^ O.repoDir+    showIndexOpts = showIndexBasicOpts `withStdOpts` oid++dump :: [DarcsFlag] -> Maybe (M.Map FilePath FileID) -> Tree IO -> IO ()+dump opts fileids tree = do+  let line | O.nullFlag ? opts = \t -> putStr t >> putChar '\0'+           | otherwise = putStrLn+      output (p, i) = do+        let hash = showHash (itemHash i)+            path = anchorPath "" p+            isdir = case i of+                      SubTree _ -> "/"+                      _ -> ""+            fileid = case fileids of+                       Nothing -> ""+                       Just fileids' -> " " ++ (show $ fromJust $ M.lookup path fileids')+        line $ hash ++ fileid ++ " " ++ path ++ isdir+  x <- expand tree+  mapM_ output $ (anchoredRoot, SubTree x) : list x++showIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showIndexCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $ \_repo -> do+  entries <- dumpIndex indexPath+  putDocLn $ vcat $ header : map formatEntry entries+  where+    header =+      text $ printf "%-64s %1s %12s %20s %12s %s" "HASH" "T" "SIZE" "AUX" "FILEID" "PATH"+    formatEntry IndexEntry{..} =+      let fileid :: Int64+          fileid = fromIntegral ieFileID+          hash = showHash ieHash+      in text $ printf "%64s %c %12d %20d %12d %s"+          hash ieType ieSize ieAux fileid (realPath iePath)++showPristineCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showPristineCmd _ opts _ = withRepository (useCache ? opts) $ RepoJob $+  readPristine >=> dump opts Nothing++showPristineHelp :: Doc+showPristineHelp = text $+  "The `darcs show pristine` command lists all version-controlled files " +++  "and directories along with the hashes of their pristine copies. " +++  "For files, the fields correspond to file size, sha256 of the pristine " +++  "file content and the filename."++showPristine :: DarcsCommand+showPristine = showIndex+    { commandName = "pristine"+    , commandDescription = "Dump contents of pristine cache."+    , commandHelp = showPristineHelp+    , commandCommand = showPristineCmd+    }
+ src/Darcs/UI/Commands/ShowPatchIndex.hs view
@@ -0,0 +1,55 @@+module Darcs.UI.Commands.ShowPatchIndex ( showPatchIndex ) where++import Darcs.Prelude++import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts, nodefaults, amInHashedRepository )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags ( DarcsFlag, useCache, verbose )+import Darcs.UI.Options+    ( (^), oid, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Repository ( withRepository, RepoJob(..), repoLocation )+import Darcs.Repository.PatchIndex+    ( dumpPatchIndex, piTest, doesPatchIndexExist, isPatchIndexInSync)+import Darcs.Util.Printer ( Doc, text )++help :: Doc+help = text $+  "When given the `--verbose` flag, the command dumps the complete content\n" +++  "of the patch index and checks its integrity."++showPatchIndex :: DarcsCommand+showPatchIndex = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "patch-index"+    , commandDescription = "Check integrity of patch index"+    , commandHelp = help+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = showPatchIndexCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = showPatchIndexOpts+    }+  where+    showPatchIndexBasicOpts = O.nullFlag ^ O.repoDir+    showPatchIndexOpts = showPatchIndexBasicOpts `withStdOpts` oid++showPatchIndexCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+showPatchIndexCmd _ opts _+  | verbose opts =+    withRepository (useCache ? opts) $ RepoJob $ \repo ->+      let loc = repoLocation repo in dumpPatchIndex loc >> piTest loc+  | otherwise =+    withRepository (useCache ? opts) $ RepoJob $ \repo -> do+    ex <- doesPatchIndexExist (repoLocation repo)+    if ex then do+          sy <- isPatchIndexInSync repo+          if sy+            then putStrLn "Patch Index is in sync with repo."+            else putStrLn "Patch Index is outdated. Run darcs optimize enable-patch-index"+     else putStrLn "Patch Index is not yet created. Run darcs optimize enable-patch-index"+
+ src/Darcs/UI/Commands/ShowRepo.hs view
@@ -0,0 +1,182 @@+--  Copyright (C) 2007 Kevin Quick+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.ShowRepo ( showRepo ) where++import Darcs.Prelude++import Data.Char ( toLower, isSpace )+import Data.List ( intercalate )+import Control.Monad ( when, unless, liftM )+import Text.Html ( tag, stringToHtml )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.UI.Flags ( DarcsFlag, useCache, hasXmlOutput, enumeratePatches )+import Darcs.UI.Options ( (^), oid, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )+import Darcs.UI.Completion ( noArgs )+import Darcs.Repository+    ( Repository+    , repoFormat+    , repoLocation+    , repoPristineType+    , repoCache+    , withRepository+    , RepoJob(..)+    , readPatches )+import Darcs.Repository.Hashed( repoXor )+import Darcs.Repository.PatchIndex ( isPatchIndexDisabled, doesPatchIndexExist )+import Darcs.Repository.Prefs+    ( Pref(Author, Defaultrepo, Prefs)+    , getMotd+    , getPreflist+    )+import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Set ( patchSet2RL )+import Darcs.Patch.Witnesses.Ordered ( lengthRL )+import qualified Data.ByteString.Char8 as BC  (unpack)+import Darcs.Patch.Apply( ApplyState )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Tree ( Tree )++showRepoHelp :: Doc+showRepoHelp = text $+ "The `darcs show repo` command displays statistics about the current\n" +++ "repository, allowing third-party scripts to access this information\n" +++ "without inspecting `_darcs` directly (and without breaking when the\n" +++ "`_darcs` format changes).\n" +++ "\n" +++ "The 'Weak Hash' identifies the set of patches of a repository independently\n" +++ "of ordering. It can be used to easily compare two repositories of a same\n" +++ "project. It is not cryptographically secure.\n" +++ "\n" +++ "By default, output includes statistics that require walking through the patches\n" +++ "recorded in the repository, namely the 'Weak Hash' and the count of patches.\n" +++ "If this data isn't needed, use `--no-enum-patches` to accelerate this command\n" +++ "from O(n) to O(1).\n" +++ "\n" +++ "By default, output is in a human-readable format.  The `--xml-output`\n" +++ "option can be used to generate output for machine postprocessing.\n"++showRepoDescription :: String+showRepoDescription = "Show repository summary information"++showRepo :: DarcsCommand+showRepo = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "repo"+    , commandHelp = showRepoHelp+    , commandDescription = showRepoDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = repoCmd+    , commandPrereq = amInRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = showRepoOpts+    }+  where+    showRepoBasicOpts = O.repoDir ^ O.xmlOutput ^ O.enumPatches+    showRepoOpts = showRepoBasicOpts `withStdOpts` oid++repoCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+repoCmd _ opts _ =+  let put_mode = if hasXmlOutput opts then showInfoXML else showInfoUsr+  in withRepository (useCache ? opts) $+     RepoJob $ \repository ->+       actuallyShowRepo (putInfo put_mode) repository opts++-- Some convenience functions to output a labelled text string or an+-- XML tag + value (same API).  If no value, output is suppressed+-- entirely.  Borrow some help from Text.Html to perform XML output.++type ShowInfo = String -> String -> String++showInfoXML :: ShowInfo+showInfoXML t i = show $ tag (safeTag t) $ stringToHtml i++safeTag :: String -> String+safeTag [] = []+safeTag (' ':cs) = safeTag cs+safeTag ('#':cs) = "num_" ++ safeTag cs+safeTag (c:cs) = toLower c : safeTag cs++-- labelled strings: labels are right-aligned at 15 characters;+-- subsequent lines in multi-line output are indented accordingly.+showInfoUsr :: ShowInfo+showInfoUsr t i = replicate (15 - length t) ' ' ++ t ++ ": " +++                  intercalate ('\n' : replicate 17 ' ') (lines i) ++ "\n"++type PutInfo = String -> String -> IO ()+putInfo :: ShowInfo -> PutInfo+putInfo m t i = unless (null i) (putStr $ m t i)++-- Primary show-repo operation.  Determines ordering of output for+-- sub-displays.  The `out' argument is one of the above operations to+-- output a labelled text string or an XML tag and contained value.++actuallyShowRepo+  :: (RepoPatch p, ApplyState p ~ Tree)+  => PutInfo -> Repository rt p wU wR -> [DarcsFlag] -> IO ()+actuallyShowRepo out r opts = do+  when (hasXmlOutput opts) (putStr "<repository>\n")+  out "Format" $ showInOneLine $ repoFormat r+  let loc = repoLocation r+  out "Root" loc+  out "PristineType" $ show $ repoPristineType r+  out "Cache" $ showInOneLine $ repoCache r+  piExists <- doesPatchIndexExist loc+  piDisabled <- isPatchIndexDisabled loc+  out "PatchIndex" $+    case (piExists, piDisabled) of+      (_, True) -> "disabled"+      (True, False) -> "enabled"+      (False, False) -> "enabled, but not yet created"+  showRepoPrefs out+  when (enumeratePatches opts) (do numPatches r >>= (out "Num Patches" . show)+                                   showXor out r)+  showRepoMOTD out r+  when (hasXmlOutput opts) (putStr "</repository>\n")++showXor :: (RepoPatch p, ApplyState p ~ Tree)+        => PutInfo -> Repository rt p wU wR -> IO ()+showXor out repo = do+  theXor <- repoXor repo+  out "Weak Hash" (show theXor)++-- Most of the actual elements being displayed are part of the Show+-- class; that's fine for a Haskeller, but not for the common user, so+-- the routines below work to provide more human-readable information+-- regarding the repository elements.++showInOneLine :: Show a => a -> String+showInOneLine = intercalate ", " . lines . show++showRepoPrefs :: PutInfo -> IO ()+showRepoPrefs out = do+    getPreflist Prefs >>= mapM_ prefOut+    getPreflist Author >>= out "Author" . unlines+    getPreflist Defaultrepo >>= out "Default Remote" . unlines+  where prefOut = uncurry out . (\(p,v) -> (p++" Pref", dropWhile isSpace v)) . break isSpace++showRepoMOTD :: PutInfo -> Repository rt p wU wR -> IO ()+showRepoMOTD out repo = getMotd (repoLocation repo) >>= out "MOTD" . BC.unpack++-- Support routines to provide information used by the PutInfo operations above.++numPatches :: (RepoPatch p, ApplyState p ~ Tree) => Repository rt p wU wR -> IO Int+numPatches r = (lengthRL . patchSet2RL) `liftM` readPatches r
+ src/Darcs/UI/Commands/ShowTags.hs view
@@ -0,0 +1,87 @@+--  Copyright (C) 2007 Florian Weimer+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.ShowTags+    ( showTags+    ) where++import Darcs.Prelude++import Control.Monad ( unless )+import Data.Maybe ( fromMaybe )+import System.IO ( stderr, hPutStrLn )++import Darcs.Patch.Set ( PatchSet, patchSetTags )+import Darcs.Repository ( readPatches, withRepositoryLocation, RepoJob(..) )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, findRepository )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags ( DarcsFlag, useCache, getRepourl )+import Darcs.UI.Options ( oid, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, formatText )++showTagsDescription :: String+showTagsDescription = "Show all tags in the repository."++showTagsHelp :: Doc+showTagsHelp = formatText 80+    [ "The tags command writes a list of all tags in the repository to "+      ++ "standard output."+    , "Tab characters (ASCII character 9) in tag names are changed to spaces "+      ++ "for better interoperability with shell tools. A warning is printed "+      ++ "if this happens."+    ]++showTags :: DarcsCommand+showTags = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "tags"+    , commandHelp = showTagsHelp+    , commandDescription = showTagsDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = tagsCmd+    , commandPrereq = findRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = showTagsOpts+    }+  where+    showTagsBasicOpts = O.possiblyRemoteRepo+    showTagsOpts = showTagsBasicOpts `withStdOpts` oid++tagsCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+tagsCmd _ opts _ = let repodir = fromMaybe "." (getRepourl opts) in+    withRepositoryLocation (useCache ? opts) repodir $ RepoJob $ \repo ->+        readPatches repo >>= printTags+  where+    printTags :: PatchSet p wW wZ -> IO ()+    printTags = mapM_ process . patchSetTags+    process :: String -> IO ()+    process t = normalize t t False >>= putStrLn+    normalize :: String -> String -> Bool -> IO String+    normalize _ [] _ = return []+    normalize t (x : xs) flag =+        if x == '\t' then do+            unless flag $+                hPutStrLn stderr $ "warning: tag with TAB character: " ++ t+            rest <- normalize t xs True+            return $ ' ' : rest+        else do+            rest <- normalize t xs flag+            return $ x : rest
+ src/Darcs/UI/Commands/Tag.hs view
@@ -0,0 +1,204 @@+--  Copyright (C) 2003-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Tag ( tag ) where++import Darcs.Prelude++import Control.Monad ( when )+import System.IO ( hPutStr, stderr )++import Darcs.Patch ( RepoPatch )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Depends ( getUncovered )+import Darcs.Patch.Info ( patchinfo )+import Darcs.Patch.Named ( adddeps, infopatch )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )+import Darcs.Patch.Set ( appendPSFL, emptyPatchSet, patchSet2FL, patchSetTags )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), mapSeal )++import Darcs.Repository+    ( AccessType(..)+    , RepoJob(..)+    , Repository+    , finalizeRepositoryChanges+    , readPatches+    , tentativelyAddPatch+    , withRepoLock+    )+import Darcs.Repository.Flags ( UpdatePending(..) )++import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , nodefaults+    , putFinished+    , withStdOpts+    )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags+    ( DarcsFlag+    , author+    , getAuthor+    , getDate+    , umask+    , useCache+    , verbosity+    )+import Darcs.UI.Options ( (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.PatchHeader ( getLog )+import Darcs.UI.SelectChanges+    ( SelectionConfig(allowSkipAll)+    , WhichChanges(..)+    , runSelection+    , selectionConfig+    )+import qualified Darcs.UI.SelectChanges as S++import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, formatWords, vsep )+import Darcs.Util.Tree ( Tree )+++tagDescription :: String+tagDescription = "Name the current repository state for future reference."++tagHelp :: Doc+tagHelp =+  vsep $ map formatWords+  [ [ "The `darcs tag` command names the current repository state, so that it"+    , "can easily be referred to later. It does so by recording a special kind"+    , "of patch that makes no changes and which explicitly depends on all"+    , "patches currently existing in the repository (except for those which"+    , "are depended upon by other tags already in the repository). In the"+    , "common case of a sequential series of tags, this means that the tag"+    , "depends on all patches since the last tag, plus that tag itself."+    ]+  , [ "Every *important* state should be"+    , "tagged; in particular it is good practice to tag each stable release"+    , "with a number or codename.  Advice on release numbering can be found"+    , "at <http://producingoss.com/en/development-cycle.html>."+    ]+  , [ "To reproduce the state of a repository `R` as at tag `t`, use the"+    , "command `darcs clone --tag t R`. Note however that tags are matched"+    , "as regular expressions, like with `--patch`. To make sure you get the"+    , "right tag it may be better to use `darcs clone --tag '^t$'`."+    , "The command `darcs show tags` lists all tags in the current repository."+    ]+  , [ "Tagging also provides significant performance benefits: when Darcs"+    , "reaches a tag that depends on all preceding patches, it can often"+    , "stop processing. A tag in such a position is called \"clean\". For"+    , "instance, operations like push and pull need to examine only patches"+    , "that come after the latest shared clean tag."+    ]+  , [ "Like normal patches, a tag has a name, an author, a timestamp and an"+    , "optional long description, but it does not change the working tree."+    , "A tag can have any name, but it is generally best to pick a naming"+    , "scheme and stick to it."+    ]+  , [ "By default a tag names the entire repository state at the time the tag"+    , "is created. If the --ask-deps option is used, the patches to include"+    , "as part of the tag can be explicitly selected."+    ]+  , [ "The `darcs tag` command accepts the `--pipe` option, which behaves as"+    , "described in `darcs record`."+    ]+  ]++tag :: DarcsCommand+tag = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "tag"+    , commandHelp = tagHelp+    , commandDescription = tagDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[TAGNAME]"]+    , commandCommand = tagCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = tagOpts+    }+  where+    tagBasicOpts+      = O.patchname+      ^ O.author+      ^ O.pipe+      ^ O.askLongComment+      ^ O.askDeps+      ^ O.repoDir+    tagAdvancedOpts = O.umask+    tagOpts = tagBasicOpts `withStdOpts` tagAdvancedOpts++tagCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+tagCmd _ opts args =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \(repository :: Repository 'RW p wU wR) -> do+    date <- getDate hasPipe+    the_author <- getAuthor (author ? opts) hasPipe+    patches <- readPatches repository+    tags <- return $ patchSetTags patches+    Sealed chosenPatches <-+        if O.askDeps ? opts+            then mapSeal (appendPSFL emptyPatchSet) <$> askAboutTagDepends opts (patchSet2FL patches)+            else return $ Sealed patches+    let deps = getUncovered chosenPatches+    (name, long_comment)  <- get_name_log tags+    myinfo <- patchinfo date name the_author long_comment+    let mypatch = infopatch myinfo NilFL+    _ <- tentativelyAddPatch repository YesUpdatePending+             $ n2pia $ adddeps mypatch deps+    _ <- finalizeRepositoryChanges repository (O.dryRun ? opts)+    putFinished opts $ "tagging '"++name++"'"+  where+    get_name_log :: [String] -> IO (String, [String])+    get_name_log tags = do+      (name, comment, _) <-+        getLog+          (case O.patchname ? opts of+             Nothing+                | null args -> Nothing+                | otherwise -> Just (unwords args)+             Just s -> Just s)+          hasPipe (O.logfile ? opts) (O.askLongComment ? opts) Nothing mempty+      when (length name < 2) $+        hPutStr stderr $+        "Do you really want to tag '" +++        name ++ "'? If not type: darcs obliterate --last=1\n"+      when (name `elem` tags) $+        putStrLn $ "WARNING: The tag " ++ "\"" ++ name ++ "\"" ++ " already exists."+      return ("TAG " ++ name, comment)+    hasPipe = O.pipe ? opts++askAboutTagDepends+     :: forall p wX wY . (RepoPatch p, ApplyState p ~ Tree)+     => [DarcsFlag]+     -> FL (PatchInfoAnd p) wX wY+     -> IO (Sealed (FL (PatchInfoAnd p) wX))+askAboutTagDepends flags ps = do+  let opts = S.PatchSelectionOptions+             { S.verbosity = verbosity ? flags+             , S.matchFlags = []+             , S.interactive = True+             , S.selectDeps = O.PromptDeps+             , S.withSummary = O.NoSummary+             }+  (deps:>_) <- runSelection ps $+                     ((selectionConfig FirstReversed "depend on" opts Nothing Nothing)+                          { allowSkipAll = False })+  return $ Sealed deps
+ src/Darcs/UI/Commands/Test.hs view
@@ -0,0 +1,204 @@+--  Copyright (C) 2002-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.Test+    (+      test+    ) where++import Darcs.Prelude hiding ( init )++import Control.Monad( when )++import System.Process ( system )+import System.Exit ( ExitCode(..), exitWith )++import Darcs.Patch ( description )+import Darcs.Patch.PatchInfoAnd ( hopefully )+import Darcs.Patch.Set ( patchSet2RL )+import Darcs.Patch.Witnesses.Ordered ( mapFL, mapRL_RL )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )+import Darcs.Repository+    ( RepoJob(..)+    , createPristineDirectoryTree+    , readPatches+    , setAllScriptsExecutable+    , withRepository+    )+import Darcs.Repository.Prefs ( getPrefval )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , nodefaults+    , putInfo+    , withStdOpts+    )+import Darcs.UI.Commands.Test.Impl+    ( StrategyResultRaw(..)+    , PatchSeq(..)+    , exitCodeToTestResult+    , explanatoryTextFor+    , mkTestCmd+    , runTestable+    , patchTreeToFL+    )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags ( DarcsFlag, useCache )+import Darcs.UI.Options ( (^), (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Lock ( withPermDir, withTempDir )+import Darcs.Util.Path ( AbsolutePath, toFilePath )+import Darcs.Util.Printer ( Doc, putDocLn, text )+++testDescription :: String+testDescription = "Run tests and search for the patch that introduced a bug."++testHelp :: Doc+testHelp = text $+ unlines+ [ "Run test on the current recorded state of the repository.  Given no"+  ,"arguments, it uses the default repository test (see `darcs setpref`)."+  ,"Given one argument, it treats it as a test command."+  ,"Given two arguments, the first is an initialization command and the"+  ,"second is the test (meaning the exit code of the first command is not"+  ,"taken into account to determine success of the test)."+  ,"If given the `--linear` or `--bisect` flags, it tries to find the most"+  ,"recent version in the repository which passes a test."+  ,""+  ,"`--linear` does linear search starting from head, and moving away"+  ,"from head. This strategy is best when the test runs very quickly"+  ,"or the patch you're seeking is near the head."+  ,""+  ,"`--bisect` does binary search.  This strategy is best when the test"+  ,"runs very slowly or the patch you're seeking is likely to be in"+  ,"the repository's distant past."+  ,""+  ,"`--backoff` starts searching from head, skipping further and further"+  ,"into the past until the test succeeds.  It then does a binary search"+  ,"on a subset of those skipped patches.  This strategy works well unless"+  ,"the patch you're seeking is in the repository's distant past."+  ,""+  ,"Under the assumption that failure is monotonous, `--linear` and"+  ,"`--bisect` produce the same result.  (Monotonous means that when moving"+  ,"away from head, the test result changes only once from \"fail\" to"+  ,"\"ok\".)  If failure is not monotonous, any one of the patches that"+  ,"break the test is found at random."+  ,""+  ,"If the test command returns an exit code of 125, the repository"+  ,"state is treated as \"untestable\" - for example you might get it to"+  ,"do this for a build break or other result that isn't the actual"+  ,"problem you want to track down. This can lead to multiple patches"+  ,"being reported as the source of the failure."+  ,""+  ,"For example, if patch 1 introduces a build break, patch 2 breaks a"+  ,"test in an unrelated bit of the code, and patch 3 fixes the build"+  ,"break, then patches 1,2 and 3 would be identified as causing the"+  ,"failure."+  ,""+  ,"The `--shrink-failures` option, on by default, adds a post-processing"+  ,"step to reorder patches to try to narrow down a failure more"+  ,"precisely. In the example above, it's likely that patch 2 could be"+  ,"moved before patch 1 or after patch 3, allowing it to be identified"+  ,"as the sole cause of the failure."+  ,""+  ,"This shrinking can be disabled with `--no-shrink-failures`."+ ]++test :: DarcsCommand+test = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "test"+    , commandHelp = testHelp+    , commandDescription = testDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[[INITIALIZATION]", "COMMAND]"]+    , commandCommand = testCommand+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = testOpts+    }+  where+    testBasicOpts = O.testStrategy ^ O.leaveTestDir ^ O.repoDir+    testAdvancedOpts = O.setScriptsExecutable ^ O.shrinkFailure+    testOpts = testBasicOpts `withStdOpts` testAdvancedOpts++testCommand :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+testCommand _ opts args =+ withRepository (useCache ? opts) $ RepoJob $ \repository -> do+  patches <- readPatches repository+  (init :: IO ExitCode,testCmd) <- case args of+    [] ->+      do t <- getTest+         return (return ExitSuccess, mkTestCmd (exitCodeToTestResult <$> t))+    [cmd] ->+      do putStrLn $ "Using test command:\n"++cmd+         return (return ExitSuccess, mkTestCmd (exitCodeToTestResult <$> system cmd))+    [init,cmd] ->+      do putStrLn $ "Using initialization command:\n"++init+         putStrLn $ "Using test command:\n"++cmd+         return (system init, mkTestCmd (exitCodeToTestResult <$> system cmd))+    _ -> fail "Test expects zero to two arguments."+  let wd = case O.leaveTestDir ? opts of+            O.YesLeaveTestDir -> withPermDir+            O.NoLeaveTestDir -> withTempDir+  wd "testing" $ \d -> do+    createPristineDirectoryTree repository (toFilePath d) O.WithWorkingDir+    when (O.yes (O.setScriptsExecutable ? opts)) setAllScriptsExecutable+    _ <- init+    putInfo opts "Running test...\n"+    result <-+      runTestable+        (O.setScriptsExecutable ? opts)+        testCmd+        (O.testStrategy ? opts)+        (O.shrinkFailure ? opts)+        (mapRL_RL hopefully . patchSet2RL $ patches)+    case result of+      NoPasses -> putStrLn "Noone passed the test!"+      NoFailureOnHead -> putStrLn "Test does not fail on head."+      Blame (Sealed2 ps) -> do+        let extraText = explanatoryTextFor (O.testStrategy ? opts)+        case ps of+          Single p -> do+            putStrLn ("Last recent patch that fails the test" ++ extraText ++ ":")+            putDocLn (description p)+          _ -> do+            putStrLn "These patches jointly trigger the failure:"+            sequence_ $ mapFL (putDocLn . description) (patchTreeToFL ps)+      RunSuccess -> putInfo opts "Test ran successfully.\n"+      RunFailed n -> do+        putInfo opts "Test failed!\n"+        exitWith (ExitFailure n)++ where+    getTest :: IO (IO ExitCode)+    getTest = do+      testline <- getPrefval "test"+      return $+        case testline of+          Nothing -> return ExitSuccess+          Just testcode -> do+            putInfo opts "Running test...\n"+            ec <- system testcode+            if ec == ExitSuccess+              then putInfo opts "Test ran successfully.\n"+              else putInfo opts "Test failed!\n"+            return ec
+ src/Darcs/UI/Commands/Test/Impl.hs view
@@ -0,0 +1,763 @@+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RebindableSyntax #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+module Darcs.UI.Commands.Test.Impl+    ( TestRunner(..), runStrategy+    , TestResult(..), TestResultValid(..), TestFailure(..)+    , TestingDone+    , PatchSeq(..), patchTreeToFL+    , StrategyResult, StrategyResultRaw(..)+    , explanatoryTextFor+    , runTestingEnv+    , exitCodeToTestResult+    , mkTestCmd+    , runTestable+    ) where++import Darcs.Prelude hiding ( init, Monad(..) )+import Darcs.Util.IndexedMonad++import qualified Control.Monad as Base ( Monad(..) )++import Data.Constraint ( Dict(..) )+import Data.String ( fromString )++import GHC.Exts ( Constraint )+import GHC.Show ( showSpace )++import System.Exit ( ExitCode(..) )+import System.IO ( hFlush, stdout )++import qualified Darcs.UI.Options.All as O+import Darcs.Repository ( setScriptsExecutablePatches )+import Darcs.Patch.Witnesses.Ordered+    ( RL(..)+    , FL(..)+    , (:>)(..)+    , splitAtRL+    , reverseRL+    , lengthRL+    , mapRL_RL+    , lengthFL+    , reverseFL+    , (+>+)+    )+import Darcs.Patch.Witnesses.Sealed ( Sealed2(..) )+import Darcs.Patch.Witnesses.Show+  ( Show1(..), Show2(..)+  , showsPrec2+  )+import Darcs.Patch.ApplyMonad ( ApplyMonad )+import Darcs.Patch.Apply ( Apply(..) )+import Darcs.Patch.Commute ( Commute, commute )+import Darcs.Patch.CommuteFn ( commuterIdFL )+import Darcs.Patch.Inspect ( PatchInspect(..) )+import Darcs.Patch ( description )+import Darcs.Patch.Show ( ShowPatch )+import Darcs.Util.Printer ( putDocLn )+import Darcs.Repository.ApplyPatches ( DefaultIO, runDefault )++-- |This type is used to track the state of the testing tree.+-- For example, 'Testing IO wX wY Int' requires that the testing+-- tree start in state 'wX', and leaves it in state 'wY'.+newtype Testing m (wX :: *) (wY :: *) a = Testing { unTesting :: m a }++-- |Once we've finished tracking down a test failure, we no longer care+-- about tracking the actual state of the testing tree. This witness+-- constant is never used in any patch, so once we use it for the state+-- of the testing tree, in practice we can no longer do anything more with+-- that tree.+--+-- We could also use some kind of existential or different monad type+-- to represent this, but it would make composing code with 'do' harder.+data TestingDone++type TestingIO = Testing IO++instance Base.Monad m => Monad (Testing m) where+  return v = Testing (Base.return v)+  Testing m >>= f = Testing (m Base.>>= unTesting . f)+  Testing m1 >> Testing m2 = Testing (m1 Base.>> m2)++instance LiftIx Testing where+  liftIx = Testing++data TestingParams =+  TestingParams+  { tpSetScriptsExecutable :: O.SetScriptsExecutable+  , tpTestCmd :: TestCmd+  }++-- |The 'Testing' monad, augmented with configuration parameters+newtype TestingEnv m wX wY a =+  TestingEnv { unTestingEnv :: ReaderT TestingParams (Testing m) wX wY a }++type TestingEnvIO = TestingEnv IO++deriving instance Base.Monad m => Monad (TestingEnv m)+deriving instance Base.Monad m => MonadReader TestingParams (TestingEnv m)++instance LiftIx TestingEnv where+  liftIx m = TestingEnv (ReaderT (\_ -> liftIx m))++runTestingEnv :: TestingParams -> TestingEnv m wA TestingDone a -> m a+runTestingEnv args = unTesting . ($ args) . runReaderT . unTestingEnv++liftTesting :: Testing m wX wY a -> TestingEnv m wX wY a+liftTesting m = TestingEnv $ ReaderT $ \_ -> m++-- |An indexed monad that can be used to run tests. 'TestingEnvIO' is+-- the only real implementation, the unit tests for testing are based on+-- mock implementations.+class Monad m => TestRunner m where+  type ApplyPatchReqs m (p :: * -> * -> *) :: Constraint+  type DisplayPatchReqs m (p :: * -> * -> *) :: Constraint++  -- |Output a message+  writeMsg :: String -> m wX wX ()++  -- |Output a message containing the name of a patch+  mentionPatch :: DisplayPatchReqs m p => p wA wB -> m wX wX ()+  +  -- |Apply a patch to the testing tree.+  applyPatch :: ApplyPatchReqs m p => p wX wY -> m wX wY ()++  -- |Unapply a patch from the testing tree+  unapplyPatch :: ApplyPatchReqs m p => p wX wY -> m wY wX ()++  -- |Get the current status (pass/skip/fail) of the testing tree,+  -- e.g. by running the test command.+  getCurrentTestResult :: m wX wX (TestResult wX)++  -- |Flag that all testing has completed.+  finishedTesting :: a -> m wX TestingDone a++type TestRunnerPatchReqs m p =+  ( -- Having to enumerate these different cases for ApplyPatchReqs is+    -- a bit ugly, but necessary because it is a type function and we+    -- don't know that ApplyPatchReqs m p => ApplyPatchReqs m (FL p), etc.+    -- In theory QuantifiedConstraints could be used to simplify this but+    -- the fact that ApplyPatchReqs is a type function makes this a bit tricky.+    ApplyPatchReqs m p, ApplyPatchReqs m (RL p), ApplyPatchReqs m (FL p)+  , ApplyPatchReqs m (PatchSeq p), ApplyPatchReqs m (RL (PatchSeq p))+  , DisplayPatchReqs m p)++type TestablePatch m p = (TestRunner m, TestRunnerPatchReqs m p, Commute p)++instance TestRunner TestingEnvIO where+  type ApplyPatchReqs TestingEnvIO p = (Apply p, ApplyMonad (ApplyState p) DefaultIO, PatchInspect p)+  type DisplayPatchReqs TestingEnvIO p = ShowPatch p++  writeMsg str = liftIx (putStrLn str Base.>> hFlush stdout)+  mentionPatch p = liftIx (putDocLn (description p) Base.>> hFlush stdout)++  applyPatch p = do+    liftTesting $ Testing $ runDefault (apply p)+    opts <- asks tpSetScriptsExecutable+    when (opts == O.YesSetScriptsExecutable) $+      liftIx $ setScriptsExecutablePatches p++  unapplyPatch p = do+    liftTesting $ Testing $ runDefault (unapply p)+    opts <- asks tpSetScriptsExecutable+    when (opts == O.YesSetScriptsExecutable) $+      liftIx $ setScriptsExecutablePatches p++  getCurrentTestResult = do+    testCmd <- asks tpTestCmd+    liftTesting $ runTestCmd testCmd++  finishedTesting r = TestingEnv $ ReaderT $ \_ -> Testing (Base.return r)++-- |The result of running a test on state 'wX' of the repository.+data TestResult wX+  = Testable (TestResultValid wX) -- ^We got a usable test result.+  | Untestable+    -- ^The test result could not be identified as either pass or fail,+    -- for example it might have been a build failure. External test+    -- scripts report this by reporting exit code 125.++-- |A usable test result, i.e. not an untestable state.+data TestResultValid wX+  = Success -- ^The test passed.+  | Failure (TestFailure wX) -- ^The test failed with the given exit code.++data TestFailure wX = TestFailure Int++exitCodeToTestResult :: ExitCode -> TestResult wX+exitCodeToTestResult ExitSuccess = Testable Success+exitCodeToTestResult (ExitFailure 125) = Untestable+exitCodeToTestResult (ExitFailure n) = Testable (Failure (TestFailure n))++-- |A 'TestCmd' runs the test on a given repository state.+data TestCmd = TestCmd (forall (wX :: *) . TestingIO wX wX (TestResult wX))++runTestCmd :: TestCmd -> TestingIO wX wX (TestResult wX)+runTestCmd (TestCmd cmd) = cmd++mkTestCmd :: (forall (wX :: *) . IO (TestResult wX)) -> TestCmd+mkTestCmd cmd = TestCmd (Testing cmd)++-- |'PatchSeq' is a sequence of patches, implemented as a binary tree,+-- balanced in an arbitrary way depending on how it happened to be constructed.+-- In the 'darcs test' implementation it is used to+-- wrap up a single patch or group of patches that might be the cause of a failure.+data PatchSeq p wX wY where+  Single :: p wX wY -> PatchSeq p wX wY+  Joined :: PatchSeq p wX wY -> PatchSeq p wY wZ -> PatchSeq p wX wZ++instance Show2 p => Show (PatchSeq p wX wY) where+  showsPrec prec (Single p) =+    showParen (prec >= 11) (showString "Darcs.UI.Commands.Test.Single " . showsPrec2 11 p)+  showsPrec prec (Joined p1 p2) =+    showParen (prec >= 11)+              (showString "Darcs.UI.Commands.Test.Joined "+                 . showsPrec2 11 p1 . showSpace . showsPrec2 11 p2)+++instance Show2 p => Show1 (PatchSeq p wX) where+  showDict1 = Dict++instance Show2 p => Show2 (PatchSeq p) where+  showDict2 = Dict++instance Apply p => Apply (PatchSeq p) where+  type ApplyState (PatchSeq p) = ApplyState p+  apply (Single p) = apply p+  apply (Joined p1 p2) = apply p1 Base.>> apply p2+  unapply (Single p) = unapply p+  unapply (Joined p1 p2) = unapply p2 Base.>> unapply p1++instance PatchInspect p => PatchInspect (PatchSeq p) where+  listTouchedFiles (Single p) = listTouchedFiles p+  listTouchedFiles (Joined p1 p2) = listTouchedFiles p1 ++ listTouchedFiles p2+  hunkMatches f (Single p) = hunkMatches f p+  hunkMatches f (Joined p1 p2) = hunkMatches f p1 || hunkMatches f p2++patchTreeToFL :: PatchSeq p wX wY -> FL p wX wY+patchTreeToFL t = go t NilFL+  where+    go :: PatchSeq p wA wB -> FL p wB wC -> FL p wA wC+    go (Single p) rest = p :>: rest+    go (Joined p1 p2) rest = go p1 (go p2 rest)++flToPatchTree :: p wX wY -> FL p wY wZ -> PatchSeq p wX wZ+flToPatchTree p NilFL = Single p+flToPatchTree p (q :>: qs) = Joined (Single p) (flToPatchTree q qs)++rlToPatchTree :: RL p wX wY -> p wY wZ -> PatchSeq p wX wZ+rlToPatchTree NilRL p = Single p+rlToPatchTree (qs :<: q) p = Joined (rlToPatchTree qs q) (Single p)++-- |The result of running a test strategy.+data StrategyResultRaw patches =+    NoPasses -- ^The chosen strategy didn't find any passing states in the repository.+  | NoFailureOnHead -- ^The test didn't fail on head so there's no failure to track down.+  | Blame patches -- ^The failure was tracked down to the given patches.+  -- these two are just for oneTest+  | RunSuccess -- ^The single test run passed.+  | RunFailed Int -- ^The single test run failed with the given exit code.+  deriving (Eq, Show, Functor)++type StrategyResult p wSuccess wFailure =+  StrategyResultRaw (PatchSeq p wSuccess wFailure)++type StrategyResultSealed p =+  StrategyResultRaw (Sealed2 (PatchSeq p))++-- |'WithResult' is a continuation passed to a test strategy indicating+-- what should be done with the final result of the strategy. This for+-- example allows a post-processing "minimise blame" pass to be run.+-- The witnesses make it hard to wrap this up in a standard abstraction.+data WithResult (m :: * -> * -> * -> *) p a =+  WithResult+  { runWithResult+      :: forall wSuccess wFailure+       . StrategyResult p wSuccess wFailure+      -> m wSuccess TestingDone a+  }++-- |After a strategy has finished, untestable states might mean that it+-- was only able to assign blame to a group of patches rather than a+-- single patch. This function tries to reorder the group of patches+-- (using commutation). The hope is that a reordered sequence will reveal+-- a testable state, allowing us to cut down the group.+--+-- The type is logically+-- something like 'StrategyResult -> m StrategyResult', but is expressed+-- as a transformation of a 'WithResult' to manage the witnesses. These+-- are complicated because we want to re-use the testing tree left by the+-- strategy.+minimiseBlame :: forall m p a . TestablePatch m p => WithResult m p a -> WithResult m p a+minimiseBlame (WithResult finalRunner) =+  WithResult $ \result ->+    case result of+      Blame p -> doMinimiseFwd NilRL (patchTreeToFL p)+      _ -> finalRunner result+  where+    -- This minimisation code is a bit ad-hoc and almost certainly+    -- doesn't find every possible minimisation (which might require+    -- an exponential search). It also doesn't cache anything and+    -- therefore may do some repeated shuffling.+    +    -- The witnesses do guarantee that it is+    -- correct and the implementation is structured to guarantee+    -- termination.++    -- The overall algorithm is to work through the sequence from left+    -- to right, treating each patch in turn as a 'focus'. We then try+    -- to commute the focus with the patches to the left of it, and test+    -- each new intermediate state this produces.+    --+    -- If we do find a testable intermediate state, we can chop the sequence+    -- at that state.++    -- In 'doMinimiseFwd kept rest', 'kept' are the patches that we+    -- have looked at already, and 'rest' are the ones still to be+    -- processed.+    doMinimiseFwd+      :: RL p wSuccess wFocus+      -> FL p wFocus wFailure+      -> m wFocus TestingDone a++    doMinimiseFwd kept (focus :>: rest) = do+      -- Call 'doMinimiseRev' to work on the first of the so-far-unprocessed+      -- patches. In the end 'doMinimiseRev' will call back to 'doMinimiseFwd',+      -- and either 'focus' will have been moved into 'kept' or dropped entirely+      -- because the sequence has been cut down.+      --+      -- Whilst 'kept' marks the patches that have already been visited,+      -- 'doMinimiseRev' will still try to commute them with the 'focus' patch.+      doMinimiseRev kept (focus :>: NilFL :> NilFL :> rest)++    doMinimiseFwd (kept :<: final) NilFL = do+      -- This unapply is only needed because WithResult+      -- is based around leaving the test tree in the 'wSuccess'+      -- state in case something else needs it.+      -- In practice no more tests will be run after we finish minimising blame,+      -- so it's wasted work.+      -- It could probably be removed by making the type of WithResult+      -- more sophisticated somehow, but it's not clear the complexity+      -- is worth it.+      unapplyPatch (kept :<: final)+      finalRunner (Blame (rlToPatchTree kept final))++    doMinimiseFwd NilRL NilFL = error "internal error: trying to minimise an empty sequence"++    -- In 'doMinimiseRev tocommute (focus :> ps :> qs)':+    --   - 'qs' are the patches that are yet to be processed. They will just be sent+    --     back to 'doMinimiseFwd' unless we end up dropping them entirely.+    --   - 'ps' are patches we have managed to commute with 'focus' but still produced+    --     untestable states.+    --   - 'focus' are the patches we are trying to move around to see if it helps+    --     find a testable state. It starts out as a singleton but gains more patches+    --     as commutes fail.+    --   - 'tocommute' are the patches we still need to commute with the 'focus'.+    doMinimiseRev+      :: RL p wSuccess wFocus+      -> (FL p :> FL p :> FL p) wFocus wFailure+      -> m wFocus TestingDone a++    doMinimiseRev NilRL (focus :> ps :> qs) = do+      -- We've run out of things to commute, so pass everything that we+      -- looked at back to 'doMinimiseFwd' as the 'kept' parameter.+      let kept = reverseFL (focus +>+ ps)+      applyPatch kept+      doMinimiseFwd kept qs++    doMinimiseRev (tocommute :<: p) (focus :> ps :> qs) = do+      unapplyPatch p+      case commuterIdFL commute (p :> focus) of+        Nothing ->+          -- if we can't commute just attach it to the focus+          doMinimiseRev tocommute (p :>: focus :> ps :> qs)+        Just (focus' :> p') -> do+          applyPatch focus'+          testResult <- getCurrentTestResult+          case testResult of+            Untestable -> do+              -- The newly commuted state is also untestable, leave the patch we+              -- just commuted in 'ps' and keep working on the focus.+              unapplyPatch focus'+              doMinimiseRev tocommute (focus' :> p' :>: ps :> qs)+            -- Since we got a result, we can chop the sequence here, we just need+            -- to decide which part to keep.+            -- The full sequence after the commute is kept ; focus' | p' ; ps ; qs+            Testable Success -> doMinimiseRev NilRL (NilFL :> p' :>: ps :> qs)+            Testable (Failure _) -> do+              unapplyPatch focus'+              doMinimiseRev tocommute (focus' :> NilFL :> NilFL)++-- |StrategyDone captures the final result of running a "test strategy" like+-- bisect, backoff, linear or once. It has a slightly complicated type because of the+-- witnesses and because we may want to run a continuation afterwards to minimise+-- the result. Essentially it is just a 'StrategyResult'.+type StrategyDone m p wY = forall a . WithResult m p a ->  m wY TestingDone a++-- |Report that the strategy has finished with the given result.+strategyDone :: StrategyResult p wSuccess wFailure -> StrategyDone m p wSuccess+strategyDone result withResult = runWithResult withResult result++-- |The implementation type for a given "test strategy" like bisect, backoff, linear or once.+-- It is given a sequence of patches we might want to search inside to identify the cause of+-- a test failure, and also passed the initial testing result for the end of that sequence.+type Strategy+   = forall m p wOlder wNewer+   . TestablePatch m p+  => TestResult wNewer+  -> RL p wOlder wNewer+  -> StrategyDone m p wNewer++-- runStrategy orchestrates the whole process of isolating patches+-- triggering the failure.+runStrategy+  :: TestablePatch m p+  => O.TestStrategy+  -> O.ShrinkFailure+  -> RL p wOlder wNewer+  -> m wNewer TestingDone (StrategyResultSealed p)+runStrategy strategy shrinkFailure patches = do+  -- The starting point is a full patch sequence 'RL p wStart wEnd' with the+  -- testing tree in state 'wEnd'. We get the initial testing result for that+  -- state as 'Strategy' requires it.+  testResult <- getCurrentTestResult+  -- We narrow down the failure via a strategy (linear/bisect/backoff). If we+  -- find patches to blame, this has type 'Testing p wSuccess wFailure', leaving the testing+  -- tree in state 'wSuccess'.+  -- If the strategy is "one test" then the result is just success/failure.+  chooseStrategy strategy testResult patches $+    -- What to do with the result of the strategy is passed as a continuation to the strategy.+    -- First we try to minimise any patches to blame, resulting in 'Testing p wSuccess2 wFailure2'.+    -- The testing tree is left in state 'wSuccess2' although we don't actually care about+    -- it any more.+    (if shrinkFailure == O.ShrinkFailure then minimiseBlame else id) $+    -- Finally the result is wrapped up in a Sealed2 and returned.+    WithResult (finishedTesting . fmap Sealed2)++runTestable+  :: ( Commute p+     , TestRunner (TestingEnv m)+     , TestRunnerPatchReqs (TestingEnv m) p+     )+  => O.SetScriptsExecutable+  -> TestCmd+  -> O.TestStrategy+  -> O.ShrinkFailure+  -> RL p wStart wA+  -> m (StrategyResultSealed p)+runTestable sse tcmd strategy shrinkFailure ps =+  runTestingEnv (TestingParams sse tcmd) $ runStrategy strategy shrinkFailure ps++chooseStrategy :: O.TestStrategy -> Strategy+chooseStrategy O.Bisect = trackBisect+chooseStrategy O.Linear = trackLinear+chooseStrategy O.Backoff = trackBackoff+chooseStrategy O.Once = oneTest++explanatoryTextFor :: O.TestStrategy -> String+explanatoryTextFor strategy =+  case strategy of+    O.Bisect -> assumedMonotony+    O.Backoff -> assumedMonotony+    O.Linear -> wasLinear+    O.Once -> wasLinear -- this case won't actually be reached+  where+    -- We did a bisection type search so a given patch that causes+    -- the failure is only the most recent if there is actually only+    -- one transition from "passed" to "failed" in the repository history.+    assumedMonotony = " (assuming monotony in the given range)"+    -- We did a linear search so the patch we found is definitely the+    -- most recent to have triggered a failure.+    wasLinear = ""++-- | test only the last recorded state+oneTest :: Strategy+oneTest (Testable Success) _ = strategyDone RunSuccess+oneTest Untestable  _ = strategyDone $ RunFailed 125+oneTest (Testable (Failure (TestFailure n)))  _ = strategyDone $ RunFailed n++-- | linear search (with --linear)+trackLinear :: Strategy+trackLinear (Testable (Failure _)) ps = trackNextLinear NilFL ps+trackLinear _ _ = strategyDone NoFailureOnHead++-- |The guts of tracking down a test failure by linear search+-- Precondition: 'wZ' is a failing state and any states+-- in the (possibly empty) range of states '[wY, wZ)' are untestable.+trackNextLinear+  :: TestablePatch m p+  => FL p wY wZ -- ^a buffer of patches that start with an untestable state+  -> RL p wX wY -- ^patches we haven't visited yet+  -> StrategyDone m p wY+trackNextLinear _ NilRL withResult = strategyDone NoPasses withResult+trackNextLinear untestables (ps:<:p) withResult = do+  unapplyPatch p+  writeMsg "Trying without the patch:"+  mentionPatch p+  testResult <- getCurrentTestResult+  case testResult of+    -- If the test passes we're done.+    Testable Success -> strategyDone (Blame (flToPatchTree p untestables)) withResult+    -- If the test fails then we can drop the 'untestables' buffer and keep going.+    Testable (Failure _) -> trackNextLinear NilFL ps withResult+    -- If the state is untestable then we add to the 'untestables' buffer and keep going.+    Untestable -> trackNextLinear (p :>: untestables) ps withResult++-- |A 'TestingState' is used to keep track of the set of patches+-- a search strategy is currently working on, split at a given point+-- with an explicit witness for that intermediate point (the 'focus'),+-- so we can connect it to the state of the testing tree.+data TestingState p wOlder wFocus wNewer where+  TestingState+    :: RL (PatchSeq p) wOlder wFocus+    -> FL (PatchSeq p) wFocus wNewer+    -> TestingState p wOlder wFocus wNewer++lengthTS :: TestingState p wX wZ wY -> Int+lengthTS (TestingState ps1 ps2) = lengthRL ps1 + lengthFL ps2++lengthsTS :: TestingState p wX wZ wY -> (Int, Int)+lengthsTS (TestingState ps1 ps2) = (lengthFL ps2, lengthRL ps1)++-- |Exponential backoff search (with --backoff): first search backwards looking for+-- a successful state, then bisect between that successful state and the current (failed)+-- state.+trackBackoff :: Strategy+trackBackoff (Testable (Failure tf)) ps =+  -- 4 is an arbitrary choice for how far to start jumping backwards+  trackNextBackoff tf 4 (mapRL_RL Single ps)+trackBackoff _ _ = strategyDone NoFailureOnHead++-- |Precondition: the test fails at 'wNewer'.+trackNextBackoff+  :: TestablePatch m p+  => TestFailure wNewer -- ^Failure witness+  -> Int -- ^Number of patches to skip.+  -> RL (PatchSeq p) wOlder wNewer -- ^Patches not yet skipped.+  -> StrategyDone m p wNewer++-- Normal base case: we've run out of patches.+trackNextBackoff _ _ NilRL withResult = strategyDone NoPasses withResult++-- Edge case: if there's just one patch left then either the test+-- passes before this patch and we can blame it, or we've run out of+-- places to look for success.+trackNextBackoff _ _ (NilRL :<: p) withResult = do+  unapplyPatch p+  testResult <- getCurrentTestResult+  case testResult of+    Testable Success -> strategyDone (Blame p) withResult+    _ -> strategyDone NoPasses withResult++-- There's more than one patch to go.+trackNextBackoff tf n ahead withResult = do+  case splitAtRL n ahead of+    ahead' :> skipped' -> do+      writeMsg $ "Skipping " ++ show n ++ " patches..."++show (lengthRL skipped', lengthRL ahead')+      unapplyPatch skipped'+      -- After backing off by n more patches, look for a testable state, working through the skipped+      -- patches if necessary because the current state isn't testable.+      findTestableTowardsNewer (Failure tf) (TestingState ahead' (reverseRL skipped')) $+        \testResult (TestingState ahead'' skipped'') ->+        case testResult of+          -- Another failure, keep going. Note that it's possible that+          -- findTestableTowardsNewer will have to go all the way to the end of+          -- skipped', leaving us in the same testing position as before, but+          -- the backoff count is doubled so we'll still make progress.+          Failure tf2 -> trackNextBackoff tf2 (2*n) ahead'' withResult+          -- Found a success state, so now we can start the bisect.+          Success -> initialBisect (TestingState NilRL skipped'') withResult++-- |Given a patch sequence which has a valid test result at the end ('wNewer'),+-- try to find another point with a valid test result, starting from 'wFocus' and+-- jumping towards 'wNewer' if necessary.+findTestableTowardsNewer+  :: TestablePatch m p+  => TestResultValid wNewer+  -> TestingState p wOlder wFocus wNewer+  -> (forall wFocus2+       . TestResultValid wFocus2+      -> TestingState p wOlder wFocus2 wNewer+      -> m wFocus2 wResult a+     )+  -> m wFocus wResult a++findTestableTowardsNewer newerResult ts@(TestingState _ NilFL) cont = cont newerResult ts+findTestableTowardsNewer newerResult ts@(TestingState older (p :>: ps)) cont = do+  focusResult <- getCurrentTestResult+  case focusResult of+    Testable res -> cont res ts+    Untestable -> do+      writeMsg $ "Found untestable state " ++ show (lengthsTS ts)+      applyPatch p+      let+        -- The 'wB' state is untestable, so try to attach the patches on either side of+        -- it together into the same 'PatchSeq' so we don't try it again.+        joinT :: RL (PatchSeq p) wA wB -> PatchSeq p wB wC -> RL (PatchSeq p) wA wC+        -- If we don't have any patches on the left, we can't do anything.+        joinT NilRL x = NilRL :<: x+        -- Otherwise peel off the first patch on the left and attach it to the patch on the right.+        joinT (ys :<: y) x = ys :<: Joined y x+      moveHalfNewer (TestingState (joinT older p) ps) $ \tsNew ->+        findTestableTowardsNewer newerResult tsNew cont+++-- |Binary search (with --bisect): bisect from the start of the repository.+-- This strategy is a bit dubious as the test probably doesn't actually pass+-- at the start of the repository so the hope is that at some point during the+-- bisect we will come across a passing state. The two different entry points into+-- 'initialBisect' (trackBisect and trackBackoff) also complicate the set of cases+-- we have to consider.+trackBisect :: Strategy+trackBisect (Testable (Failure _)) ps = initialBisect (TestingState (mapRL_RL Single ps) NilFL)+trackBisect _ _ = strategyDone NoFailureOnHead++-- |Progress of Bisect: current step, currently predicted total steps.+-- The total steps prediction will increase if we run into untestable states.+type BisectProgress = (Int, Int)++-- |Launch a bisect. Precondition: the test fails at 'wNewer'.+-- If called via backoff, then the test also passes at 'wOlder',+-- but there is no guarantee if bisect is called directly. +initialBisect+  :: TestablePatch m p+  => TestingState p wOlder wFocus wNewer+  -> StrategyDone m p wFocus+initialBisect ps = trackNextBisect currProg ps+  where+    flooredLength = lengthTS ps `min` 1+    maxProg  = 1 + round ((logBase 2 $ fromIntegral flooredLength) :: Double)+    currProg = (1, maxProg) :: BisectProgress++-- |Given a testing state, work out what to do next.+-- Precondition: the test fails at 'wNewer'.+trackNextBisect+  :: forall m p wOlder wNewer wFocus+   . TestablePatch m p+  => BisectProgress+  -> TestingState p wOlder wFocus wNewer+  -> StrategyDone m p wFocus++trackNextBisect _ (TestingState NilRL NilFL) withResult = strategyDone NoPasses withResult++-- With these two cases we're down to a single patch, so either it's to blame+-- or there are no passing states found (subject to the limitations of the bisect strategy -+-- not every state was visited).+trackNextBisect _ (TestingState NilRL (p :>: NilFL)) withResult = checkAndReturnFinalBisectResult p withResult+trackNextBisect _ (TestingState (NilRL :<: p) NilFL) withResult = do+  unapplyPatch p+  checkAndReturnFinalBisectResult p withResult++-- More than one patch left. Find the middle of the TestingState and work from that.+trackNextBisect (dnow, dtotal) ps withResult = do+  writeMsg $ "Trying " ++ show dnow ++ "/" ++ show dtotal ++ " sequences..." ++ show (lengthsTS ps)+  moveToMiddle ps (\ts -> runNextBisect (dnow, dtotal) ts withResult)++-- |Once we only have one patch left in bisect, we need to check that the test passes before the patch.+-- This is not guaranteed when bisect is called directly from the command-line. If we changed the UI to+-- ensure that bisect was only launched with both a passing and a failing state, we could strengthen+-- the precondition of 'initialBisect' and things it calls, and this function would be unnecessary.+-- Precondition: the test fails at 'wNewer'.+checkAndReturnFinalBisectResult+  :: TestablePatch m p+  => PatchSeq p wOlder wNewer+  -> StrategyDone m p wOlder+checkAndReturnFinalBisectResult p withResult = do+  testResult <- getCurrentTestResult+  case testResult of+    Testable Success -> strategyDone (Blame p) withResult+    _ -> strategyDone NoPasses withResult++-- |The guts of bisection. Normally it will be passed an evenly split+-- 'TestingState older newer' with the focus in the middle, but if we find an+-- untestable state then we will start jumping around to find something testable.+-- Preconditions: 'older' is non-empty; the test fails at wNewer.+runNextBisect+  :: forall m p wOlder wNewer wFocus+   . TestablePatch m p+  => BisectProgress+  -> TestingState p wOlder wFocus wNewer+  -> StrategyDone m p wFocus+runNextBisect (dnow, dtotal) (TestingState older newer) withResult = do+  testResult <- getCurrentTestResult+  case testResult of++    -- The standard case for bisect: we have a result for the focus and we use it to pick+    -- either the left or right half.+    Testable result -> do+      let doNext newState = trackNextBisect (dnow+1, dtotal) newState withResult+      case result of+        Success   -> doNext (TestingState NilRL newer) -- continue left  (to the present)+        Failure _ -> doNext (TestingState older NilFL) -- continue right (to the past)++    -- If we couldn't test the bisect state then we need to move around to try to find+    -- a testable state.+    Untestable -> do+      writeMsg $ "Found untestable state " ++ show (lengthsTS (TestingState older newer))+      case (older, newer) of+        (NilRL, _) -> error "internal error: older bisect state reached 0 patches (runNextBisect)"+        -- Although 'newer' can become empty, the precondition that the test fails at wNewer means+        -- we shouldn't get here.+        -- TODO the user might supply an unreliable test script, maybe we should deal with the NilFL+        -- case before running the test.+        (_, NilFL) -> error "internal error: newer bisect state reached 0 patches (runNextBisect)"+        (older' :<: p1, p2 :>: newer') -> do+          applyPatch p2+          moveHalfNewer (TestingState (older' :<: Joined p1 p2) newer') $+            \ts -> runNextBisect (dnow+1, dtotal+1) ts withResult++-- |Given a 'TestingState older newer', move the focus to the middle of 'newer',+-- updating the testing tree to match, and call the given continuation.+moveHalfNewer+  :: forall m p wOlder wNewer wFocus wResult a+   . TestablePatch m p+  => TestingState p wOlder wFocus wNewer+  -> (forall wFocus2 . TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)+  -> m wFocus wResult a++moveHalfNewer (TestingState older newer) f = doMove older (lengthFL newer `div` 2, newer)+  where+    doMove+      :: forall wFocus2+       . RL (PatchSeq p) wOlder wFocus2+      -> (Int, FL (PatchSeq p) wFocus2 wNewer)+      -> m wFocus2 wResult a++    doMove ps1 (0, ps2) = f (TestingState ps1 ps2)+    doMove _ (_, NilFL) = error "impossible: exhausted newer patches (moveHalfNewer)"+    doMove ps1 (n, p :>: ps2) = do+      applyPatch p+      doMove (ps1 :<: p) (n-1, ps2)++-- |Given a 'TestingState older newer', move the focus to the middle of+-- 'older +>+ newer', updating the testing tree to match, and call the given+-- continuation.+moveToMiddle+  :: forall m p wOlder wNewer wFocus wResult a+   . TestablePatch m p+  => TestingState p wOlder wFocus wNewer+  -> (forall wFocus2 . TestingState p wOlder wFocus2 wNewer -> m wFocus2 wResult a)+  -> m wFocus wResult a++moveToMiddle (TestingState older newer) f = doMove (lengthRL older, older) (lengthFL newer, newer)+  where+    doMove+      :: forall wFocus2+       . (Int, RL (PatchSeq p) wOlder wFocus2)+      -> (Int, FL (PatchSeq p) wFocus2 wNewer)+      -> m wFocus2 wResult a++    doMove (len1, ps1) (len2, ps2) | abs (len1 - len2) <= 1 = f (TestingState ps1 ps2)++    doMove (len1, ps1 :<: p1) (len2, ps2) | len1 > len2 = do+      unapplyPatch p1+      doMove (len1-1, ps1) (len2+1, p1 :>: ps2)++    doMove (len1, ps1) (len2, p2 :>: ps2) = do -- len2 > len1+      applyPatch p2+      doMove (len1+1, ps1 :<: p2) (len2-1, ps2)++    -- these cases should only be reachable if the lengths get out of sync+    doMove (_, NilRL) _ = error "internal error: right bisect state reached 0 patches (moveToMiddle)"+    doMove _ (_, NilFL) = error "internal error: left bisect state reached 0 patches (moveToMiddle)"
+ src/Darcs/UI/Commands/TransferMode.hs view
@@ -0,0 +1,94 @@+--  Copyright (C) 2008 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++-- The pragma above is only for pattern guards.+module Darcs.UI.Commands.TransferMode ( transferMode ) where++import Darcs.Prelude++import System.Directory ( withCurrentDirectory )+import Control.Exception ( catch )+import System.IO ( stdout, hFlush )++import Darcs.Util.Exception ( prettyException )+import Darcs.UI.Commands ( DarcsCommand(..), withStdOpts, nodefaults, amInRepository )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags ( DarcsFlag )+import Darcs.UI.Options ( oid )+import qualified Darcs.UI.Options.All as O+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Progress ( setProgressMode )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Ssh ( transferModeHeader )++import qualified Data.ByteString as B (hPut, readFile, length, ByteString)++transferModeDescription :: String+transferModeDescription = "Internal command for efficient ssh transfers."++transferModeHelp :: Doc+transferModeHelp = text $+ "When pulling from or pushing to a remote repository over ssh, if both\n" +++ "the local and remote ends have Darcs 2, the `transfer-mode' command\n" +++ "will be invoked on the remote end.  This allows Darcs to intelligently\n" +++ "transfer information over a single ssh connection.\n" +++ "\n" +++ "If either end runs Darcs 1, a separate ssh connection will be created\n" +++ "for each transfer.  As well as being less efficient, this means users\n" +++ "who do not run ssh-agent will be prompted for the ssh password tens or\n" +++ "hundreds of times!\n"++transferMode :: DarcsCommand+transferMode = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "transfer-mode"+    , commandHelp = transferModeHelp+    , commandDescription = transferModeDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCompleteArgs = noArgs+    , commandCommand = transferModeCmd+    , commandPrereq = amInRepository+    , commandArgdefaults = nodefaults+    , commandOptions = transferModeOpts+    }+  where+    transferModeBasicOpts = O.repoDir+    transferModeOpts = transferModeBasicOpts `withStdOpts` oid++transferModeCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+transferModeCmd _ _ _ = do setProgressMode False+                           putStrLn transferModeHeader+                           hFlush stdout+                           withCurrentDirectory darcsdir transfer++transfer :: IO ()+transfer = do 'g':'e':'t':' ':fn <- getLine+              x <- readfile fn+              case x of+                Right c -> do putStrLn $ "got " ++ fn+                              print $ B.length c+                              B.hPut stdout c+                              hFlush stdout+                Left e -> do putStrLn $ "error " ++ fn+                             print e+                             hFlush stdout+              transfer++readfile :: String -> IO (Either String B.ByteString)+readfile fn = (Right `fmap` B.readFile fn) `catch` (return . Left  . prettyException)
+ src/Darcs/UI/Commands/Unrecord.hs view
@@ -0,0 +1,321 @@+--  Copyright (C) 2002-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}++module Darcs.UI.Commands.Unrecord+    ( unrecord+    , unpull+    , obliterate+    ) where++import Darcs.Prelude++import Control.Monad ( unless, void, when )+import Darcs.Util.Tree ( Tree )+import Data.Maybe ( fromJust, isJust )+import System.Directory ( doesPathExist )+import System.Exit ( exitSuccess )++import Darcs.Patch ( RepoPatch, commute, effect, invert )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Bundle ( makeBundle, minContext )+import Darcs.Patch.CommuteFn ( commuterFLId )+import Darcs.Patch.Depends ( removeFromPatchSet )+import Darcs.Patch.PatchInfoAnd ( hopefully, patchDesc )+import Darcs.Patch.Permutations ( genCommuteWhatWeCanFL )+import Darcs.Patch.Set ( Origin, PatchSet )+import Darcs.Patch.Witnesses.Ordered ( FL(..), mapFL_FL, nullFL, (:>)(..), (+>+) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..) )+import Darcs.Repository+    ( PatchInfoAnd+    , RepoJob(..)+    , applyToWorking+    , finalizeRepositoryChanges+    , readPatches+    , setTentativePending+    , tentativelyRemovePatches+    , unrecordedChanges+    , withRepoLock+    )+import Darcs.Repository.Flags ( UpdatePending(..) )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , commandAlias+    , nodefaults+    , putFinished+    , putInfo+    , putVerbose+    , setEnvDarcsPatches+    , withStdOpts+    )+import Darcs.UI.Commands.Util+    ( getUniqueDPatchName+    , historyEditHelp+    , preselectPatches+    , printDryRunMessageAndExit+    )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags+    ( DarcsFlag+    , changesReverse+    , diffingOpts+    , dryRun+    , getOutput+    , isInteractive+    , minimize+    , selectDeps+    , umask+    , useCache+    , verbosity+    , xmlOutput+    )+import Darcs.UI.Options ( (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.PrintPatch ( printFriendly )+import Darcs.UI.SelectChanges ( WhichChanges(..), runSelection, selectionConfig )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Util.English ( presentParticiple )+import Darcs.Util.Lock ( writeDocBinFile )+import Darcs.Util.Path ( AbsolutePath, toFilePath, useAbsoluteOrStd )+import Darcs.Util.Printer ( Doc, formatWords, putDoc, sentence, text, ($+$), (<+>) )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.SignalHandler ( catchInterrupt, withSignalsBlocked )++unrecordDescription :: String+unrecordDescription =+  "Remove recorded patches without changing the working tree."++unrecordHelp :: Doc+unrecordHelp = formatWords+  [ "Unrecord does the opposite of record: it deletes patches from"+  , "the repository without changing the working tree. The changes"+  , "are now again visible with `darcs whatsnew` and you can record"+  , "or revert them as you please."+  ]+  $+$ historyEditHelp++unrecord :: DarcsCommand+unrecord = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "unrecord"+    , commandHelp = unrecordHelp+    , commandDescription = unrecordDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = unrecordCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = unrecordOpts+    }+  where+    unrecordBasicOpts+      = O.notInRemote+      ^ O.matchSeveralOrLast+      ^ O.selectDeps+      ^ O.interactive -- True+      ^ O.repoDir+    unrecordAdvancedOpts+      = O.umask+      ^ O.changesReverse+    unrecordOpts = unrecordBasicOpts `withStdOpts` unrecordAdvancedOpts++unrecordCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+unrecordCmd _ opts _ =+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    (_ :> removal_candidates) <- preselectPatches opts _repository+    let direction = if changesReverse ? opts then Last else LastReversed+        selection_config =+          selectionConfig direction "unrecord" (patchSelOpts opts) Nothing Nothing+    (_ :> to_unrecord) <- runSelection removal_candidates selection_config+    when (nullFL to_unrecord) $ do+      putInfo opts "No patches selected!"+      exitSuccess+    putVerbose opts $+      text "About to write out (potentially) modified patches..."+    setEnvDarcsPatches to_unrecord+    _repository <-+      tentativelyRemovePatches _repository YesUpdatePending to_unrecord+    _ <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+    putInfo opts "Finished unrecording."++unpullDescription :: String+unpullDescription =+  "Opposite of pull; unsafe if patch is not in remote repository."++unpullHelp :: Doc+unpullHelp =+  text $ "Unpull is an alias for what is nowadays called `obliterate`."++unpull :: DarcsCommand+unpull =+  (commandAlias "unpull" Nothing obliterate)+    { commandHelp = unpullHelp+    , commandDescription = unpullDescription+    , commandCommand = obliterateCmd "unpull"+    }++obliterateDescription :: String+obliterateDescription = "Delete selected patches from the repository."++obliterateHelp :: Doc+obliterateHelp = formatWords+  [ "Obliterate completely removes recorded patches from your local"+  , "repository. The changes will be undone in your working tree and the"+  , "patches will not be shown in your changes list anymore. Beware that"+  , "you can lose precious code by obliterating!"+  ]+  $+$ formatWords+  [ "One way to save obliterated patches is to use the -O flag. A patch"+  , "bundle will be created locally, that you will be able to apply"+  , "later to your repository with `darcs apply`. See `darcs send` for"+  , "a more detailed description."+  ]+  $+$ historyEditHelp++obliterate :: DarcsCommand+obliterate = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "obliterate"+    , commandHelp = obliterateHelp+    , commandDescription = obliterateDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = obliterateCmd "obliterate"+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = obliterateOpts+    }+  where+    obliterateBasicOpts+      = O.notInRemote+      ^ O.matchSeveralOrLast+      ^ O.selectDeps+      ^ O.interactive+      ^ O.repoDir+      ^ O.withSummary+      ^ O.output+      ^ O.minimize+      ^ O.diffAlgorithm+      ^ O.dryRunXml+    obliterateAdvancedOpts+      = O.umask+      ^ O.changesReverse+    obliterateOpts = obliterateBasicOpts `withStdOpts` obliterateAdvancedOpts++obliterateCmd+  :: String -> (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+obliterateCmd cmdname _ opts _ = do+  let verbOpt = verbosity ? opts+  withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+    unrecorded <- unrecordedChanges (diffingOpts opts) _repository Nothing+    (_ :> removal_candidates) <- preselectPatches opts _repository+    let direction = if changesReverse ? opts then Last else LastReversed+        selection_config =+          selectionConfig direction cmdname (patchSelOpts opts) Nothing Nothing+    (_ :> removed) <- runSelection removal_candidates selection_config+    when (nullFL removed) $ do+      putInfo opts "No patches selected!"+      exitSuccess+    case genCommuteWhatWeCanFL (commuterFLId commute) (effect removed :> unrecorded) of+      unrecorded' :> removed_after_unrecorded :> to_revert -> do+        effect_removed <-+          case to_revert of+            NilFL -> return removed_after_unrecorded+            _ ->+              if isInteractive True opts then do+                putStrLn $+                  "These unrecorded changes conflict with the " ++ cmdname ++ ":"+                printFriendly O.Verbose O.NoSummary to_revert+                yes <- promptYorn "Do you want to revert these unrecorded changes?"+                if yes then+                  return $ removed_after_unrecorded +>+ to_revert+                else do+                  putStrLn $ "Okay, " ++ cmdname ++ " cancelled."+                  exitSuccess+              else+                fail $+                  "Can't " ++ cmdname +++                    " these patches without reverting some unrecorded changes."+        printDryRunMessageAndExit+          "obliterate" verbOpt (O.withSummary ? opts) (dryRun ? opts)+          (xmlOutput ? opts) (isInteractive True opts) removed+        setEnvDarcsPatches removed+        when (isJust $ getOutput opts (return "")) $+          -- The call to preselectPatches above may have unwrapped the latest+          -- clean tag. If we don't want to remove it, we lost information+          -- about that tag being clean, so we have to access it's inventory.+          -- To avoid that, and thus preserve laziness, we re-read our original+          -- patchset and use that to create the context for the bundle.+          readPatches _repository >>= savetoBundle opts removed+        _repository <-+          tentativelyRemovePatches _repository NoUpdatePending removed+        -- rely on sifting to commute out prims not belonging in pending:+        setTentativePending _repository unrecorded'+        withSignalsBlocked $ do+          _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+          debugMessage "Applying patches to working tree..."+          unless (O.yes (O.dryRun ? opts)) $+            void $ applyToWorking _repository verbOpt (invert effect_removed)+        putFinished opts (presentParticiple cmdname)++savetoBundle+  :: (RepoPatch p, ApplyState p ~ Tree)+  => [DarcsFlag]+  -> FL (PatchInfoAnd p) wX wR+  -> PatchSet p Origin wR+  -> IO ()+savetoBundle _ NilFL _ = return ()+savetoBundle opts removed@(x :>: _) orig = do+  let kept = fromJust $ removeFromPatchSet removed orig+      genFullBundle = makeBundle Nothing kept (mapFL_FL hopefully removed)+  bundle <-+    if not (minimize ? opts)+      then genFullBundle+      else do+        putInfo opts+          "Minimizing context, to generate bundle with full context hit ctrl-C..."+        (case minContext kept removed of+          Sealed (kept' :> removed') ->+            makeBundle Nothing kept' (mapFL_FL hopefully removed'))+          `catchInterrupt` genFullBundle+  let filename = getUniqueDPatchName (patchDesc x)+  outname <- fromJust (getOutput opts filename)+  exists <- useAbsoluteOrStd (doesPathExist . toFilePath) (return False) outname+  when exists $+    fail $ "Directory or file named '" ++ (show outname) ++ "' already exists."+  useAbsoluteOrStd writeDocBinFile putDoc outname bundle+  putInfo opts $ sentence $+    useAbsoluteOrStd+      (("Saved patch bundle" <+>) . text . toFilePath)+      (text "stdout")+      outname++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags =+  S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = O.matchSeveralOrLast ? flags+    , S.interactive = isInteractive True flags+    , S.selectDeps = selectDeps ? flags+    , S.withSummary = O.withSummary ? flags+    }
+ src/Darcs/UI/Commands/Unrevert.hs view
@@ -0,0 +1,150 @@+--  Copyright (C) 2003-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.Commands.Unrevert ( unrevert ) where++import Darcs.Prelude++import Control.Monad ( unless, when, void )++import Darcs.Patch ( commute )+import Darcs.Patch.Depends ( findCommon )+import Darcs.Patch.Witnesses.Ordered ( (:>)(..), FL(..), (+>+) )+import Darcs.Patch.Witnesses.Sealed ( Sealed(Sealed) )+import Darcs.Repository+    ( RepoJob(..)+    , applyToWorking+    , considerMergeToWorking+    , finalizeRepositoryChanges+    , readPatches+    , addToPending+    , unrecordedChanges+    , withRepoLock+    )+import Darcs.Repository.Flags+    ( AllowConflicts(..)+    , ResolveConflicts(..)+    , Reorder(..)+    , WantGuiPause(..)+    )+import Darcs.Repository.Unrevert ( readUnrevert, writeUnrevert )+import Darcs.UI.Commands+    ( DarcsCommand(..)+    , amInHashedRepository+    , nodefaults+    , putFinished+    , withStdOpts+    )+import Darcs.UI.Completion ( noArgs )+import Darcs.UI.Flags+    ( diffingOpts+    , isInteractive+    , umask+    , useCache+    , verbosity+    )+import Darcs.UI.Flags ( DarcsFlag )+import Darcs.UI.Options ( (?), (^) )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.SelectChanges+    ( WhichChanges(First)+    , runInvertibleSelection+    , selectionConfigPrim+    )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.Util.Path ( AbsolutePath )+import Darcs.Util.Printer ( Doc, text )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Prompt ( promptYorn )+import Darcs.Util.SignalHandler ( withSignalsBlocked )++unrevertDescription :: String+unrevertDescription =+ "Undo the last revert."++unrevertHelp :: Doc+unrevertHelp = text $+ "Unrevert is a rescue command in case you accidentally reverted\n" +++ "something you wanted to keep (for example, typing `darcs rev -a`\n" +++ "instead of `darcs rec -a`).\n" +++ "\n" +++ "This command may fail if the repository has changed since the revert\n" +++ "took place.  Darcs will ask for confirmation before executing an\n" +++ "interactive command that will DEFINITELY prevent unreversion.\n"++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = []+    , S.interactive = isInteractive True flags+    , S.selectDeps = O.PromptDeps -- option not supported, use default+    , S.withSummary = O.NoSummary -- option not supported, use default+    }++unrevert :: DarcsCommand+unrevert = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "unrevert"+    , commandHelp = unrevertHelp+    , commandDescription = unrevertDescription+    , commandExtraArgs = 0+    , commandExtraArgHelp = []+    , commandCommand = unrevertCmd+    , commandPrereq = amInHashedRepository+    , commandCompleteArgs = noArgs+    , commandArgdefaults = nodefaults+    , commandOptions = unrevertOpts+    }+  where+    unrevertBasicOpts+      = O.interactive -- True+      ^ O.repoDir+      ^ O.diffAlgorithm+    unrevertAdvancedOpts = O.umask+    unrevertOpts = unrevertBasicOpts `withStdOpts` unrevertAdvancedOpts++unrevertCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+unrevertCmd _ opts [] =+ withRepoLock (useCache ? opts) (umask ? opts) $ RepoJob $ \_repository -> do+  us <- readPatches _repository+  Sealed them <- readUnrevert us+  unrecorded <- unrecordedChanges (diffingOpts opts) _repository Nothing+  Sealed pw <- considerMergeToWorking _repository "unrevert"+                      (YesAllowConflicts MarkConflicts)+                      NoWantGuiPause+                      NoReorder+                      (diffingOpts opts)+                      (findCommon us them)+  let selection_config =+        selectionConfigPrim+            First "unrevert" (patchSelOpts opts)+            Nothing Nothing+  (to_unrevert :> to_keep) <- runInvertibleSelection pw selection_config+  addToPending _repository (diffingOpts opts) to_unrevert+  recorded <- readPatches _repository+  debugMessage "I'm about to writeUnrevert."+  case commute ((unrecorded +>+ to_unrevert) :> to_keep) of+    Nothing -> do+      yes <- promptYorn "You will not be able to undo this operation! Proceed?"+      when yes $ writeUnrevert recorded NilFL -- i.e. remove unrevert+    Just (to_keep' :> _) -> writeUnrevert recorded to_keep'+  withSignalsBlocked $ do+    _repository <- finalizeRepositoryChanges _repository (O.dryRun ? opts)+    unless (O.yes (O.dryRun ? opts)) $+      void $ applyToWorking _repository (verbosity ? opts) to_unrevert+  putFinished opts "unreverting"+unrevertCmd _ _ _ = error "impossible case"
+ src/Darcs/UI/Commands/Util.hs view
@@ -0,0 +1,348 @@+--  Copyright (C) 2002-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Commands.Util+    ( announceFiles+    , filterExistingPaths+    , testTentativeAndMaybeExit+    , printDryRunMessageAndExit+    , getUniqueRepositoryName+    , getUniqueDPatchName+    , doesDirectoryReallyExist+    , checkUnrelatedRepos+    , preselectPatches+    , getLastPatches+    , matchRange+    , historyEditHelp+    , commonHelpWithPrefsTemplates+    ) where++import Control.Monad ( when, unless )++import Darcs.Prelude++import Control.Exception ( catch )+import Data.Char ( isAlpha, toLower, isDigit, isSpace )+import Data.Maybe ( fromMaybe )++import System.Exit ( ExitCode(..), exitWith, exitSuccess )+import System.Posix.Files ( isDirectory )++import Darcs.Patch ( RepoPatch, xmlSummary )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Depends+    ( areUnrelatedRepos+    , findCommonWithThem+    , patchSetUnion+    )+import Darcs.Patch.Info ( toXml )+import Darcs.Patch.Match+    ( MatchFlag+    , MatchableRP+    , firstMatch+    , matchFirstPatchset+    , matchSecondPatchset+    , matchingHead+    )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, hopefullyM )+import Darcs.Patch.Set ( PatchSet, SealedPatchSet, Origin, emptyPatchSet )+import Darcs.Patch.Witnesses.Ordered ( FL, (:>)(..), mapFL )+import Darcs.Patch.Witnesses.Sealed ( Sealed(..), Sealed2(..) )++import Darcs.Repository+    ( ReadingOrWriting(..)+    , Repository+    , identifyRepositoryFor+    , readPristine+    , readPatches+    )+import Darcs.Repository.Prefs ( getDefaultRepo, globalPrefsDirDoc )+import Darcs.Repository.State ( readUnrecordedFiltered )++import Darcs.UI.Commands ( putInfo )+import Darcs.UI.Flags ( DarcsFlag, isInteractive )+import Darcs.UI.PrintPatch ( showFriendly )+import Darcs.UI.Options ( (?) )+import Darcs.UI.Options.All+    ( Verbosity(..)+    , DiffOpts(..)+    , WithSummary(..), DryRun(..), XmlOutput(..)+    )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.TestChanges ( testTree )++import Darcs.Util.English ( anyOfClause, itemizeVertical )+import Darcs.Util.Exception ( clarifyErrors )+import Darcs.Util.File ( getFileStatus )+import Darcs.Util.Path ( AnchoredPath, displayPath, getUniquePathName )+import Darcs.Util.Printer+    ( Doc, formatWords, ($+$), text, (<+>), hsep, ($$), vcat, vsep+    , putDocLn, insertBeforeLastline, prefix+    , putDocLnWith, pathlist+    )+import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Util.Prompt ( PromptConfig(..), promptChar, promptYorn )+import Darcs.Util.Tree.Monad ( virtualTreeIO, exists )+import Darcs.Util.Tree ( Tree )+++announceFiles :: Verbosity -> Maybe [AnchoredPath] -> String -> IO ()+announceFiles Quiet _ _ = return ()+announceFiles _ (Just paths) message = putDocLn $+    text message <> text ":" <+> pathlist (map displayPath paths)+announceFiles _ _ _ = return ()++testTentativeAndMaybeExit :: Tree IO+                          -> [DarcsFlag]+                          -> String+                          -> String+                          -> Maybe String+                          -> IO ()+testTentativeAndMaybeExit tree opts failMessage confirmMsg withClarification = do+  testResult <- testTree opts tree+  unless (testResult == ExitSuccess) $ do+    let doExit =+          maybe id (flip clarifyErrors) withClarification $ exitWith testResult+    unless (isInteractive True opts) doExit+    putStrLn $ "Looks like " ++ failMessage+    let prompt = "Shall I " ++ confirmMsg ++ " anyway?"+    yn <- promptChar (PromptConfig prompt "yn" [] (Just 'n') [])+    unless (yn == 'y') doExit++-- | @'printDryRunMessageAndExit' action flags patches@ prints a string+-- representing the action that would be taken if the @--dry-run@ option had+-- not been passed to darcs. Then darcs exits successfully.  @action@ is the+-- name of the action being taken, like @\"push\"@ @flags@ is the list of flags+-- which were sent to darcs @patches@ is the sequence of patches which would be+-- touched by @action@.+printDryRunMessageAndExit :: RepoPatch p+                          => String+                          -> Verbosity -> WithSummary -> DryRun -> XmlOutput+                          -> Bool -- interactive+                          -> FL (PatchInfoAnd p) wX wY+                          -> IO ()+printDryRunMessageAndExit action v s d x interactive patches = do+    when (d == YesDryRun) $ do+        putInfoX $ hsep [ "Would", text action, "the following patches:" ]+        putDocLnWith fancyPrinters put_mode+        putInfoX $ text ""+        putInfoX $ text "Making no changes: this is a dry run."+        exitSuccess+    when (not interactive && s == YesSummary) $ do+        putInfoX $ hsep [ "Will", text action, "the following patches:" ]+        putDocLn put_mode+  where+    put_mode = if x == YesXml+                   then text "<patches>" $$+                        vcat (mapFL (indent . xml_info s) patches) $$+                        text "</patches>"+                   else vsep $ mapFL (showFriendly v s) patches++    putInfoX = if x == YesXml then const (return ()) else putDocLn++    xml_info YesSummary = xml_with_summary+    xml_info NoSummary  = toXml . info++    xml_with_summary hp+        | Just p <- hopefullyM hp = insertBeforeLastline (toXml $ info hp)+                                        (indent $ xmlSummary p)+    xml_with_summary hp = toXml (info hp)++    indent = prefix "    "++-- | Given a repository and two common command options, classify the given list+-- of paths according to whether they exist in the pristine or working tree.+-- Paths which are neither in working nor pristine are reported and dropped.+-- The result is a pair of path lists: those that exist only in the working tree,+-- and those that exist in pristine or working.+filterExistingPaths :: (RepoPatch p, ApplyState p ~ Tree)+                    => Repository rt p wU wR+                    -> Verbosity+                    -> DiffOpts+                    -> [AnchoredPath]+                    -> IO ([AnchoredPath],[AnchoredPath])+filterExistingPaths repo verb DiffOpts{..} paths = do+      pristine <- readPristine repo+      working <-+        readUnrecordedFiltered repo withIndex lookForAdds lookForMoves (Just paths)+      let check = virtualTreeIO $ mapM exists paths+      (in_pristine, _) <- check pristine+      (in_working, _) <- check working+      let paths_with_info       = zip3 paths in_pristine in_working+          paths_in_neither      = [ p | (p,False,False) <- paths_with_info ]+          paths_only_in_working = [ p | (p,False,True) <- paths_with_info ]+          paths_in_either       = [ p | (p,inp,inw) <- paths_with_info, inp || inw ]+          or_not_added =+            if lookForAdds == O.NoLookForAdds+              then " or not added "+              else " "+      unless (verb == Quiet || null paths_in_neither) $ putDocLn $+        "Ignoring non-existing" <> or_not_added <> "paths:" <+>+        pathlist (map displayPath paths_in_neither)+      return (paths_only_in_working, paths_in_either)++getUniqueRepositoryName :: Bool -> FilePath -> IO FilePath+getUniqueRepositoryName talkative name = getUniquePathName talkative buildMsg buildName+  where+    buildName i = if i == -1 then name else name++"_"++show i+    buildMsg n = "Directory or file '"++ name +++                 "' already exists, creating repository as '"+++                 n ++"'"++getUniqueDPatchName :: FilePath -> IO FilePath+getUniqueDPatchName name =+  catch+    (getUniquePathName False (const "") buildName)+    (\(e :: IOError) ->+      fail $ "Error constructing filename corresponding to " ++ show name ++ ": " ++ show e +++             "\nConsider using '-o' to specify an output filename."+    )+  where+    buildName i =+      if i == -1 then patchFilename name else patchFilename $ name++"_"++show i++-- |patchFilename maps a patch description string to a safe (lowercased, spaces+-- removed and only letters/digits) patch filename.+patchFilename :: String -> String+patchFilename the_summary = name ++ ".dpatch"+  where+    name = map safeFileChar the_summary+    safeFileChar c | isAlpha c = toLower c+                   | isDigit c = c+                   | isSpace c = '-'+    safeFileChar _ = '_'++doesDirectoryReallyExist :: FilePath -> IO Bool+doesDirectoryReallyExist f = maybe False isDirectory `fmap` getFileStatus f++checkUnrelatedRepos :: RepoPatch p+                    => Bool+                    -> PatchSet p Origin wX+                    -> PatchSet p Origin wY+                    -> IO ()+checkUnrelatedRepos allowUnrelatedRepos us them =+    when ( not allowUnrelatedRepos && areUnrelatedRepos us them ) $+         do confirmed <- promptYorn "Repositories seem to be unrelated. Proceed?"+            unless confirmed $ putStrLn "Cancelled." >> exitSuccess++-- | Get the union of the set of patches in each specified location+remotePatches :: RepoPatch p+              => [DarcsFlag]+              -> Repository rt p wU wR -> [O.NotInRemote]+              -> IO (SealedPatchSet p Origin)+remotePatches opts repository nirs = do+    nirsPaths <- mapM getNotInRemotePath nirs+    putInfo opts $+      "Determining patches not in" <+>+      anyOfClause nirsPaths $$ itemizeVertical 2 nirsPaths+    patchSetUnion `fmap` mapM readNir nirsPaths+  where+    readNir n = do+        r <- identifyRepositoryFor Reading repository (O.useCache ? opts) n+        rps <- readPatches r+        return (Sealed rps)++    getNotInRemotePath :: O.NotInRemote -> IO String+    getNotInRemotePath (O.NotInRemotePath p) = return p+    getNotInRemotePath O.NotInDefaultRepo = do+        defaultRepo <- getDefaultRepo+        let err = fail $ "No default push/pull repo configured, please pass a "+                         ++ "repo name to --" ++ O.notInRemoteFlagName+        maybe err return defaultRepo++getLastPatches :: RepoPatch p+               => [O.MatchFlag] -> PatchSet p Origin wR+               -> (PatchSet p :> FL (PatchInfoAnd p)) Origin wR+getLastPatches matchFlags ps =+  case matchFirstPatchset matchFlags ps of+    Just (Sealed p1s) -> findCommonWithThem ps p1s+    Nothing -> error "precondition: getLastPatches requires a firstMatch"++preselectPatches+  :: RepoPatch p+  => [DarcsFlag]+  -> Repository rt p wU wR+  -> IO ((PatchSet p :> FL (PatchInfoAnd p)) Origin wR)+preselectPatches opts repo = do+  allpatches <- readPatches repo+  let matchFlags = O.matchSeveralOrLast ? opts+  case O.notInRemote ? opts of+    [] -> do+      return $+        if firstMatch matchFlags+          then getLastPatches matchFlags allpatches+          else matchingHead matchFlags allpatches+    -- FIXME what about match options when we have --not-in-remote?+    -- It looks like they are simply ignored.+    nirs -> do+      (Sealed thems) <-+        remotePatches opts repo nirs+      return $ findCommonWithThem allpatches thems++matchRange :: MatchableRP p+           => [MatchFlag]+           -> PatchSet p Origin wY+           -> Sealed2 (FL (PatchInfoAnd p))+matchRange matchFlags ps =+  case (sp1s, sp2s) of+    (Sealed p1s, Sealed p2s) ->+      case findCommonWithThem p2s p1s of+        _ :> us -> Sealed2 us+  where+    sp1s = fromMaybe (Sealed emptyPatchSet) $ matchFirstPatchset matchFlags ps+    sp2s = fromMaybe (Sealed ps) $ matchSecondPatchset matchFlags ps++historyEditHelp :: Doc+historyEditHelp = formatWords+  [ "Note that this command edits the history of your repo. It is"+  , "primarily intended to be used on patches that you authored yourself"+  , "and did not yet publish. Using it for patches that are already"+  , "published, or even ones you did not author yourself, may cause"+  , "confusion and can disrupt your own and other people's work-flow."+  , "This depends a lot on how your project is organized, though, so"+  , "there may be valid exceptions to this rule."+  ]+  $+$ formatWords+  [ "Using the `--not-in-remote` option is a good way to guard against"+  , "accidentally editing published patches. Without arguments, this"+  , "deselects any patches that are also present in the `defaultrepo`."+  , "If you work in a clone of some publically hosted repository,"+  , "then your `defaultrepo` will be that public repo. You can also"+  , "give the option an argument which is a path or URL of some other"+  , "repository; you can use the option multiple times with"+  , "different repositories, which has the effect of treating all"+  , "of them as \"upstream\", that is, it prevents you from selecting"+  , "a patch that is contained in any of these repos."+  ]+  $+$ formatWords+  [ "You can also guard only against editing another developer's patch"+  , "by using an appropriate `--match` option with the `author` keyword."+  , "For instance, you could add something like `<cmd> match Your Name`"+  , "to your `" ++ globalPrefsDirDoc ++ "defaults`."+  ]++commonHelpWithPrefsTemplates :: Doc+commonHelpWithPrefsTemplates = formatWords+  [ "Initialize and clone commands create the preferences files in"+  , "_darcs/prefs/ directory of the newly created repository. With option"+  , "--with-prefs-templates `boring` and `binaries` preferences files will be"+  , "filled with default templates. If you want to leave these files empty"+  , "use --no-prefs-templates option. If you prefer to keep the relevant"+  , "settings globally, it will be convenient to add 'ALL no-prefs-templates'"+  , "to your ~/darcs/defaults file."+  ]
+ src/Darcs/UI/Commands/WhatsNew.hs view
@@ -0,0 +1,424 @@+--  Copyright (C) 2002-2004 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+module Darcs.UI.Commands.WhatsNew+    ( whatsnew+    , status+    ) where++import Darcs.Prelude++import Control.Monad ( void, when )+import Control.Monad.Reader ( runReaderT )+import Control.Monad.State ( evalStateT, liftIO )+import Data.Maybe ( isJust )+import System.Exit ( ExitCode (..), exitSuccess, exitWith )++import Darcs.Patch+    ( PrimOf, PrimPatch, RepoPatch+    , applyToTree, plainSummaryPrims+    )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Choices ( mkPatchChoices, labelPatches, unLabel )+import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.FileHunk ( IsHunk (..) )+import Darcs.Patch.Inspect ( PatchInspect (..) )+import Darcs.Patch.Permutations ( partitionRL )+import Darcs.Patch.Prim.Class ( PrimDetails (..) )+import Darcs.Patch.Show+    ( ShowContextPatch+    , ShowPatch(..)+    , ShowPatchBasic(..)+    , displayPatch+    )+import Darcs.Patch.TouchesFiles ( chooseTouching )+import Darcs.Patch.Witnesses.Ordered+    ( (:>) (..), FL (..)+    , reverseFL, reverseRL+    )+import Darcs.Patch.Witnesses.Sealed+    ( Sealed (..), Sealed2 (..)+    , unFreeLeft+    )+import Darcs.Repository+    ( RepoJob (..), Repository, AccessType(RO)+    , readPristine+    , unrecordedChanges, withRepository+    )+import Darcs.Repository.Diff ( treeDiff )+import Darcs.Repository.Prefs ( filetypeFunction )+import Darcs.UI.Commands+    ( DarcsCommand(..), withStdOpts, amInRepository+    , commandAlias, nodefaults+    )+import Darcs.UI.Completion ( modifiedFileArgs )+import Darcs.UI.Commands.Util ( announceFiles, filterExistingPaths )+import Darcs.UI.External ( viewDocWith )+import Darcs.UI.Flags+    ( DarcsFlag, diffAlgorithm+    , useCache, pathSetFromArgs+    , verbosity, isInteractive+    , diffingOpts+    )+import Darcs.UI.Options ( (^), parseFlags, (?), oid )+import qualified Darcs.UI.Options.All as O+import Darcs.UI.PrintPatch ( contextualPrintPatchWithPager )+import Darcs.UI.SelectChanges+    ( InteractiveSelectionM, KeyPress (..)+    , WhichChanges (..)+    , initialSelectionState+    , backAll+    , backOne, currentFile+    , currentPatch, decide+    , decideWholeFile, helpFor+    , keysFor, prompt+    , selectionConfigPrim, skipMundane+    , skipOne+    )+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions (..) )+import Darcs.Util.Path ( AbsolutePath, AnchoredPath )+import Darcs.Util.Printer+    ( Doc, formatWords, putDocLn, putDocLnWith, renderString+    , text, vcat, ($+$)+    )+import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Util.Prompt ( PromptConfig (..), promptChar )+import Darcs.Util.Tree ( Tree )++patchSelOpts :: [DarcsFlag] -> S.PatchSelectionOptions+patchSelOpts flags = S.PatchSelectionOptions+    { S.verbosity = verbosity ? flags+    , S.matchFlags = []+    , S.interactive = isInteractive True flags+    , S.selectDeps = O.PromptDeps -- option not supported, use default+    , S.withSummary = getSummary flags+    }++-- lookForAdds and machineReadable set YesSummary+-- unless NoSummary was given expressly+-- (or by default e.g. status)+getSummary :: [DarcsFlag] -> O.WithSummary+getSummary flags = case O.maybeSummary Nothing ? flags of+  Just O.NoSummary -> O.NoSummary+  Just O.YesSummary -> O.YesSummary+  Nothing+    | O.yes (O.lookforadds ? flags) -> O.YesSummary+    | O.machineReadable ? flags -> O.YesSummary+    | otherwise -> O.NoSummary++whatsnew :: DarcsCommand+whatsnew = DarcsCommand+    { commandProgramName = "darcs"+    , commandName = "whatsnew"+    , commandHelp = whatsnewHelp+    , commandDescription = whatsnewDescription+    , commandExtraArgs = -1+    , commandExtraArgHelp = ["[FILE or DIRECTORY]..."]+    , commandCommand = whatsnewCmd+    , commandPrereq = amInRepository+    , commandCompleteArgs = modifiedFileArgs+    , commandArgdefaults = nodefaults+    , commandOptions = whatsnewOpts+    }+  where+    whatsnewBasicOpts+      = O.maybeSummary Nothing+      ^ O.withContext+      ^ O.machineReadable+      ^ O.maybelookforadds O.NoLookForAdds+      ^ O.lookforreplaces+      ^ O.lookformoves+      ^ O.diffAlgorithm+      ^ O.repoDir+      ^ O.interactive -- False+    whatsnewOpts = withStdOpts whatsnewBasicOpts oid++whatsnewDescription :: String+whatsnewDescription = "List unrecorded changes in the working tree."++whatsnewHelp :: Doc+whatsnewHelp =+  formatWords+  [ "The `darcs whatsnew` command lists unrecorded changes to the working"+  , "tree.  If you specify a set of files and directories, only unrecorded"+  , "changes to those files and directories are listed."+  ]+  $+$ formatWords+  [ "With the `--summary` option, the changes are condensed to one line per"+  , "file, with mnemonics to indicate the nature and extent of the change."+  , "The `--look-for-adds` option causes candidates for `darcs add` to be"+  , "included in the summary output.  WithSummary mnemonics are as follows:"+  ]+  -- TODO autoformat bullet lists+  $+$ vcat+  [ "  * `A f` and `A d/` respectively mean an added file or directory."+  , "  * `R f` and `R d/` respectively mean a removed file or directory."+  , "  * `M f -N +M rP` means a modified file, with `N` lines deleted, `M`"+  , "    lines added, and `P` lexical replacements."+  , "  * `f -> g` means a moved file or directory."+  , "  * `a f` and `a d/` respectively mean a new, but unadded, file or"+  , "    directory, when using `--look-for-adds`."+  , "  * An exclamation mark (!) as in `R! foo.c`, means the change"+  , "    conflicts with a change in an earlier patch. The phrase `duplicated`"+  , "    means the change is identical to a change in an earlier patch."+  ]+  $+$ formatWords+  [ "The `--machine-readable` option implies `--summary` while making it more"+  , "parsable. Modified files are only shown as `M f`, and moves are shown in"+  , "two lines: `F f` and `T g` (as in 'From f To g')."+  ]+  $+$ formatWords+  [ "By default, `darcs whatsnew` uses Darcs' internal format for changes."+  , "To see some context (unchanged lines) around each change, use the"+  , "`--unified` option. (This option has no effect in interactive mode.)"+  , "To view changes in conventional `diff` format, use"+  , "the `darcs diff` command; but note that `darcs diff` cannot properly"+  , "display changes when file renames are involved."+  ]+  $+$ formatWords+  [ "This command exits unsuccessfully (returns a non-zero exit status) if"+  , "there are no unrecorded changes."+  ]++whatsnewCmd :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO ()+whatsnewCmd fps opts args =+   withRepository (useCache ? opts) $ RepoJob $ \(repo :: Repository 'RO p wU wR) -> do+    existing_files <- do+      files <- pathSetFromArgs fps args+      files' <-+        traverse+          (filterExistingPaths repo (verbosity ? opts) (diffingOpts opts)) files+      let files'' = fmap snd files'+      when (files'' == Just []) $+        fail "None of the files you specified exist."+      return files''++    -- get all unrecorded changes, possibly including unadded or even boring+    -- files if the appropriate options were supplied+    Sealed allInterestingChanges <-+      filteredUnrecordedChanges (diffingOpts opts) repo existing_files++    -- get the recorded state+    pristine <- readPristine repo++    -- the case --look-for-adds and --summary must be handled specially+    -- in order to distinguish added and unadded files++    -- TODO: it would be nice if we could return the pair+    -- (noLookChanges,unaddedNewPathsPs) in one go and also+    -- with proper witnesses (e.g. as noLookChanges +>+ unaddedNewPathsPs)+    -- This would also obviate the need for samePatchType.+    Sealed noLookChanges <-+      if haveLookForAddsAndSummary+        then+          -- do *not* look for adds here:+          let dopts = diffingOpts opts+          in filteredUnrecordedChanges+                dopts {O.lookForAdds = O.NoLookForAdds} repo existing_files+        else return (Sealed NilFL)+    Sealed unaddedNewPathsPs <-+      if haveLookForAddsAndSummary+        then do+          noLookAddsTree <- applyAddPatchesToPristine noLookChanges pristine+          lookAddsTree <- applyAddPatchesToPristine allInterestingChanges pristine+          ftf <- filetypeFunction+          -- Return the patches that create files/dirs that aren't yet added.+          unFreeLeft <$> treeDiff (diffAlgorithm ? opts) ftf noLookAddsTree lookAddsTree+        else return (Sealed NilFL)+    -- avoid ambiguous typing for unaddedNewPathsPs:+    samePatchType noLookChanges unaddedNewPathsPs++    exitOnNoChanges allInterestingChanges+    announceFiles (verbosity ? opts) existing_files "What's new in"+    if maybeIsInteractive opts+      then+        runInteractive interactiveHunks (patchSelOpts opts) allInterestingChanges+      else+        if haveLookForAddsAndSummary+          then do+            printChanges pristine noLookChanges+            printUnaddedPaths unaddedNewPathsPs+          else do+            printChanges pristine allInterestingChanges+  where+    haveSummary = O.yes (getSummary opts)+    haveLookForAddsAndSummary = haveSummary && O.yes (O.lookforadds ? opts)++    -- Filter out hunk patches (leaving add patches) and return the tree+    -- resulting from applying the filtered patches to the pristine tree.+    applyAddPatchesToPristine ps pristine = do+        adds :> _ <- return $ partitionRL (isJust . isHunk) $ reverseFL ps+        applyToTree (reverseRL adds) pristine++    exitOnNoChanges :: FL p wX wY -> IO ()+    exitOnNoChanges NilFL = do putStrLn "No changes!"+                               exitWith $ ExitFailure 1+    exitOnNoChanges _ = return ()++    -- This function does nothing. Its purpose is to enforce the+    -- same patch type for the two passed FLs. This is necessary+    -- in order to avoid ambiguous typing for unaddedNewPathsPs.+    samePatchType :: FL p wX wY -> FL p wU wV -> IO ()+    samePatchType _ _ = return ()++    printUnaddedPaths :: PrimPatch p => FL p wX wY -> IO ()+    printUnaddedPaths NilFL = return ()+    printUnaddedPaths ps =+        putDocLn . lowercaseAs . renderString . (plainSummaryPrims False) $ ps++    -- Make any add markers lowercase, to distinguish new-but-unadded files+    -- from those that are unrecorded, but added.+    lowercaseAs x = vcat $ map (text . lowercaseA) $ lines x+    lowercaseA ('A' : x) = 'a' : x+    lowercaseA x = x++    -- Appropriately print changes, according to the passed flags.+    -- Note this cannot make distinction between unadded and added files.+    printChanges :: ( PrimPatch p, ApplyState p ~ Tree)+                 => Tree IO -> FL p wX wY+                 -> IO ()+    printChanges pristine changes+        | haveSummary = putDocLn $ plainSummaryPrims machineReadable changes+        | O.yes (O.withContext ? opts) = contextualPrintPatchWithPager pristine changes+        | otherwise = printPatchPager changes+     where machineReadable = parseFlags O.machineReadable opts++    -- return the unrecorded changes that affect an optional list of paths.+    filteredUnrecordedChanges :: forall rt p wR wU. (RepoPatch p, ApplyState p ~ Tree)+                              => O.DiffOpts+                              -> Repository rt p wU wR+                              -> Maybe [AnchoredPath]+                              -> IO (Sealed (FL (PrimOf p) wR))+    filteredUnrecordedChanges diffing repo paths =+        chooseTouching paths <$> unrecordedChanges diffing repo paths++-- | Runs the 'InteractiveSelectionM' code+runInteractive :: InteractiveSelectionM p wX wY () -- Selection to run+               -> S.PatchSelectionOptions+               -> FL p wX wY      -- A list of patches+               -> IO ()+runInteractive i patchsel ps' = do+    let lps' = labelPatches Nothing ps'+        choices' = mkPatchChoices lps'+        ps = evalStateT i (initialSelectionState lps' choices')+    void $+      runReaderT ps $+        selectionConfigPrim First "view" patchsel Nothing Nothing++-- | The interactive part of @darcs whatsnew@+interactiveHunks :: (IsHunk p, ShowPatch p, ShowContextPatch p, Commute p,+                     PatchInspect p, PrimDetails p, ApplyState p ~ Tree)+                 => InteractiveSelectionM p wX wY ()+interactiveHunks = do+    c <- currentPatch+    case c of+        Nothing -> liftIO $ putStrLn "No more changes!"+        Just (Sealed2 lp) -> do+            liftIO $ printPatchPager (unLabel lp)+            repeatThis lp+  where+    repeatThis lp = do+        thePrompt <- prompt -- "Shall I view this change? (n/m)"+        yorn <- liftIO $ promptChar+                (PromptConfig thePrompt (keysFor basic_options) (keysFor adv_options)+                 (Just 'n') "?h")+        case yorn of+            -- View change+            'v' -> liftIO (printPatch (unLabel lp))+                   >> repeatThis lp+            -- View summary of the change+            'x' -> liftIO (putDocLn $ summary $ unLabel lp)+                   >> repeatThis lp+            -- View change and move on+            'y' -> liftIO (printPatch (unLabel lp))+                   >> decide True lp >> next_hunk+            -- Go to the next patch+            'n' -> decide False lp >> next_hunk+            -- Skip the whole file+            's' -> do+                currentFile >>= maybe+                    (return ())+                    (\f -> decideWholeFile f False)+                next_hunk+            -- View change in a pager+            'p' -> liftIO (printPatchPager $ unLabel lp)+                   >> repeatThis lp+            -- Next change+            'j' -> next_hunk+            -- Previous change+            'k' -> prev_hunk+            -- Start from the first change+            'g' -> start_over+            -- Quit whatsnew+            'q' -> liftIO $ exitSuccess+            _ -> do liftIO . putStrLn $+                        helpFor "whatsnew" basic_options adv_options+                    repeatThis lp+    start_over = backAll >> interactiveHunks+    next_hunk  = skipOne >> skipMundane >> interactiveHunks+    prev_hunk  = backOne >> interactiveHunks+    options_yn =+        [ KeyPress 'v' "view this change"+        , KeyPress 'y' "view this change and go to the next one"+        , KeyPress 'n' "skip this change and its dependencies"+        ]+    optionsView =+        [ KeyPress 'p' "view this change with pager"+        , KeyPress 'x' "view a summary of this change"+        ]+    optionsNav =+        [ KeyPress 'q' "quit whatsnew"+        , KeyPress 's' "skip the rest of the changes to this file"+        , KeyPress 'j' "go to the next change"+        , KeyPress 'k' "back up to previous change"+        , KeyPress 'g' "start over from the first change"+        ]+    basic_options = [ options_yn ]+    adv_options = [ optionsView, optionsNav ]++printPatchPager :: ShowPatchBasic p => p wX wY -> IO ()+printPatchPager = viewDocWith fancyPrinters . displayPatch++printPatch :: ShowPatchBasic p => p wX wY -> IO ()+printPatch = putDocLnWith fancyPrinters . displayPatch++-- | An alias for 'whatsnew', with implicit @-l@ (and thus implicit @-s@)+-- flags. We override the default description, to include these flags.+status :: DarcsCommand+status = statusAlias+    { commandDescription = statusDesc+    , commandOptions = statusOpts+    }+  where+    statusAlias = commandAlias "status" Nothing whatsnew+    statusDesc = "Alias for `darcs " ++ commandName whatsnew ++ " -ls`."+    statusBasicOpts+      = O.maybeSummary (Just O.YesSummary)+      ^ O.withContext+      ^ O.machineReadable+      ^ O.maybelookforadds O.YesLookForAdds+      ^ O.lookforreplaces+      ^ O.lookformoves+      ^ O.diffAlgorithm+      ^ O.repoDir+      ^ O.interactive+    statusOpts = withStdOpts statusBasicOpts oid++maybeIsInteractive :: [DarcsFlag] -> Bool+maybeIsInteractive = maybe False id . parseFlags O.interactive
+ src/Darcs/UI/Completion.hs view
@@ -0,0 +1,176 @@+-- | How to complete arguments+{-# LANGUAGE NamedFieldPuns #-}+module Darcs.UI.Completion+    ( fileArgs+    , knownFileArgs+    , unknownFileArgs+    , modifiedFileArgs+    , noArgs+    , Pref(..) -- re-export+    , prefArgs+    ) where++import Darcs.Prelude++import Data.List ( (\\), stripPrefix )+import Data.List.Ordered ( nubSort, minus )+import Data.Maybe ( mapMaybe )++import Darcs.Patch ( listTouchedFiles )++import Darcs.Repository.Flags+    ( UseCache(..)+    )+import Darcs.Repository.Prefs+    ( Pref(..), getPreflist+    )+import Darcs.Repository.Job+    ( RepoJob(..)+    , withRepository+    )+import Darcs.Repository.State+    ( readPristineAndPending+    , readUnrecordedFiltered+    , unrecordedChanges+    , restrictDarcsdir+    , applyTreeFilter+    , TreeFilter(..)+    )++import Darcs.UI.Flags ( DarcsFlag )+import qualified Darcs.UI.Flags as Flags+import Darcs.UI.Options ( (?) )+import qualified Darcs.UI.Options.All as O++import Darcs.Util.File+    ( doesDirectoryReallyExist+    )+import Darcs.Util.Global+    ( darcsdir+    )+import Darcs.Util.Path+    ( AnchoredPath, realPath+    , AbsolutePath, toPath, floatSubPath, makeSubPathOf+    )+import Darcs.Util.Tree as Tree+    ( Tree, ItemType(..)+    , expand, expandPath, list, findTree, itemType, emptyTree+    )+import Darcs.Util.Tree.Plain ( readPlainTree )++-- | Return all files available under the original working+-- directory regardless of their repo state.+fileArgs :: (AbsolutePath, AbsolutePath)+         -> [DarcsFlag]+         -> [String]+         -> IO [FilePath]+fileArgs (_, orig) _flags args =+  notYetListed args $+  fmap (map anchoredToFilePath . listItems) $+  Tree.expand . applyTreeFilter restrictDarcsdir =<< readPlainTree (toPath orig)++-- | Return all files available under the original working directory that+-- are unknown to darcs but could be added.+unknownFileArgs :: (AbsolutePath, AbsolutePath)+                -> [DarcsFlag]+                -> [String]+                -> IO [FilePath]+unknownFileArgs fps flags args = notYetListed args $ do+  let lfa = if O.includeBoring ? flags then O.EvenLookForBoring else O.YesLookForAdds+      dopts = Flags.diffingOpts flags+  RepoTrees {have, known} <- repoTrees dopts {O.lookForAdds = lfa}+  known_paths <- listHere known fps+  have_paths <- listHere have fps+  return $+    map anchoredToFilePath $ nubSort have_paths `minus` nubSort known_paths++-- | Return all files available under the original working directory that+-- are known to darcs (either recorded or pending).+knownFileArgs :: (AbsolutePath, AbsolutePath)+              -> [DarcsFlag]+              -> [String]+              -> IO [FilePath]+knownFileArgs fps flags args = notYetListed args $ do+  RepoTrees {known} <- repoTrees (Flags.diffingOpts flags)+  map anchoredToFilePath <$> listHere known fps++-- | Return all files available under the original working directory that+-- are modified (relative to the recorded state).+modifiedFileArgs :: (AbsolutePath, AbsolutePath)+                 -> [DarcsFlag]+                 -> [String]+                 -> IO [FilePath]+modifiedFileArgs fps flags args = notYetListed args $ do+  RepoTrees {new} <- repoTrees (Flags.diffingOpts flags)+  case uncurry makeSubPathOf fps of+    Nothing -> return []+    Just here ->+      return $ mapMaybe (stripPathPrefix (toPath here)) $ map realPath new++-- | Return the available prefs of the given kind.+prefArgs :: Pref+         -> (AbsolutePath, AbsolutePath)+         -> [DarcsFlag]+         -> [String]+         -> IO [String]+prefArgs name _ _ _ = getPreflist name++-- | Return an empty list.+noArgs :: (AbsolutePath, AbsolutePath) -> [DarcsFlag] -> [String] -> IO [String]+noArgs _ _ _ = return []++-- * unexported helper functions++data RepoTrees m = RepoTrees+  { have  :: Tree m       -- ^ working tree+  , known :: Tree m       -- ^ recorded and pending+  , new :: [AnchoredPath] -- ^ unrecorded paths+  }++repoTrees :: O.DiffOpts -> IO (RepoTrees IO)+repoTrees dopts@O.DiffOpts {..} = do+  inDarcsRepo <- doesDirectoryReallyExist darcsdir+  if inDarcsRepo then+    withRepository NoUseCache $ RepoJob $ \r -> do+      known <- readPristineAndPending r+      have <- readUnrecordedFiltered r withIndex lookForAdds lookForMoves Nothing+      new <- listTouchedFiles <$> unrecordedChanges dopts r Nothing+      return $ RepoTrees {..}+  else+    return RepoTrees {have = emptyTree, known = emptyTree, new = []}++-- this is for completion which should give us everything under the original wd+subtreeHere :: Tree IO -> (AbsolutePath, AbsolutePath) -> IO (Maybe (Tree IO))+subtreeHere tree fps =+  case either error id . floatSubPath <$> uncurry makeSubPathOf fps of+    Nothing -> do+      return Nothing -- here is no subtree of the repo+    Just here -> do+      flip findTree here <$> expandPath tree here++listHere :: Tree IO+         -> (AbsolutePath, AbsolutePath)+         -> IO [(AnchoredPath, ItemType)]+listHere tree fps = do+  msubtree <- subtreeHere tree fps+  case msubtree of+    Nothing -> return []+    Just subtree -> listItems <$> expand subtree++listItems :: Tree m -> [(AnchoredPath, ItemType)]+listItems = map (\(p, i) -> (p, itemType i)) . Tree.list++anchoredToFilePath :: (AnchoredPath, ItemType) -> [Char]+anchoredToFilePath (path, _) = realPath path++stripPathPrefix :: FilePath -> FilePath -> Maybe FilePath+stripPathPrefix = stripPrefix . addSlash where+  addSlash [] = []+  addSlash xs = xs ++ "/"++-- | Turn an action that creates all possible completions into one+-- that removes already given arguments.+notYetListed :: [String] -> IO [String] -> IO [String]+notYetListed already complete = do+  possible <- complete+  return $ possible \\ already
+ src/Darcs/UI/Defaults.hs view
@@ -0,0 +1,239 @@+module Darcs.UI.Defaults ( applyDefaults ) where++import Darcs.Prelude++import Control.Monad.Writer+import Data.Char ( isLetter, isSpace )+import Data.Either ( partitionEithers )+import Data.Functor.Compose ( Compose(..) )+import Data.List ( nub )+import Data.Maybe ( catMaybes )+import qualified Data.Map as M+import System.Console.GetOpt+import Text.Regex.Applicative+    ( (<|>)+    , match, many, some, sym+    , psym, anySym, string )++import Darcs.UI.Flags ( DarcsFlag )+import Darcs.UI.Options ( DarcsOptDescr, OptMsg(..), withDashes )++import Darcs.UI.Commands+    ( DarcsCommand+    , commandAlloptions+    , commandCheckOptions+    , commandDefaults+    , commandName+    , extractAllCommands+    )+import Darcs.UI.TheCommands ( commandControlList )+import Darcs.Util.Path ( AbsolutePath )++-- | Apply defaults from all sources to a list of 'DarcsFlag's (e.g. from the+-- command line), given the command (and possibly super command) name, and a+-- list of all options for the command.+-- +-- Sources for defaults are+-- +--  * the builtin (hard-coded) defaults,+-- +--  * the defaults file in the user's configuration, and+-- +--  * the defaults file in the current repository.+-- +-- Note that the pseudo command @ALL@ is allowed in defaults files to specify+-- that an option should be the default for all commands to which it applies.+-- +-- The order of precedence for conflicting options (i.e. those belonging to+-- same group of mutually exclusive options) is from less specific to more+-- specific. In other words, options from the command line override all+-- defaults, per-repo defaults override per-user defaults, which in turn+-- override the built-in defaults. Inside the options from a defaults file,+-- options for the given command override options for the @ALL@ pseudo command.+-- +-- Conflicting options at the same level of precedence are not allowed.+--+-- Errors encountered during processing of command line or defaults flags+-- are formatted and added as (separate) strings to the list of error messages+-- that are returned together with the resulting flag list.+applyDefaults+  :: Maybe String -- ^ maybe name of super command+  -> DarcsCommand -- ^ the darcs command+  -> AbsolutePath -- ^ the original working directory, i.e.+                  --   the one from which darcs was invoked+  -> [String]     -- ^ lines from user defaults+  -> [String]     -- ^ lines from repo defaults+  -> [DarcsFlag]  -- ^ flags from command line+  -> ([DarcsFlag], ([String], [String])) -- new flags, warnings, errors+applyDefaults msuper cmd cwd user repo flags =+  splitMessages $ runWriter $ do+    cl_flags  <- runChecks "Command line" check_opts flags+    user_defs <- get_flags "User defaults" user+    repo_defs <- get_flags "Repo defaults" repo+    return $ cl_flags ++ repo_defs ++ user_defs ++ builtin_defs+  where+    cmd_name = mkCmdName msuper (commandName cmd)+    builtin_defs = commandDefaults cmd+    check_opts = commandCheckOptions cmd+    opts = uncurry (++) $ commandAlloptions cmd+    get_flags source = parseDefaults source cwd cmd_name opts check_opts+    splitMessages (r,ms) = (r,partitionOptMsgs ms)++-- | Name of a normal command, or name of super and sub command.+data CmdName = NormalCmd String | SuperCmd String String++-- | Make a 'CmdName' from a possible super command name and a sub command name.+mkCmdName :: Maybe String -> String -> CmdName+mkCmdName Nothing cmd = NormalCmd cmd+mkCmdName (Just super) sub = SuperCmd super sub++-- | Turn a 'CmdName' into a 'String'. For a 'SuperCmd' concatenate with a space in between.+showCmdName :: CmdName -> String+showCmdName (SuperCmd super sub) = unwords [super,sub]+showCmdName (NormalCmd name) = name++runChecks :: String -> ([DarcsFlag] -> [OptMsg]) -> [DarcsFlag] -> Writer [OptMsg] [DarcsFlag]+runChecks source check fs = do+  tell $ map (mapOptMsg ((source++": ")++)) $ check fs+  return fs++mapOptMsg :: (String -> String) -> OptMsg -> OptMsg+mapOptMsg f (OptWarning s) = OptWarning (f s)+mapOptMsg f (OptError s) = OptError (f s)++partitionOptMsgs :: [OptMsg] -> ([String], [String])+partitionOptMsgs = partitionEithers . map toEither where+  toEither (OptWarning s) = Left s+  toEither (OptError s) = Right s++-- | Parse a list of lines from a defaults file, returning a list of 'DarcsFlag',+-- given the current working directory, the command name, and a list of 'DarcsOption'+-- for the command.+--+-- In the result, defaults for the given command come first, then come defaults+-- for @ALL@ commands.+--+-- We check that matching options actually exist.+--+--  * lines matching the command name: the option must exist in the command's+--    option map.+--+--  * lines matching @ALL@: there must be at least *some* darcs command with+--    that option.+--+parseDefaults :: String+              -> AbsolutePath+              -> CmdName+              -> [DarcsOptDescr DarcsFlag]+              -> ([DarcsFlag] -> [OptMsg])+              -> [String]+              -> Writer [OptMsg] [DarcsFlag]+parseDefaults source cwd cmd opts check_opts def_lines = do+    cmd_flags <- flags_for (M.keys opt_map) cmd_defs >>=+      runChecks (source++" for command '"++showCmdName cmd++"'") check_opts+    all_flags <- flags_for allOptionSwitches all_defs >>=+      runChecks (source++" for ALL commands") check_opts+    return $ cmd_flags ++ all_flags+  where+    opt_map = optionMap opts+    cmd_defs = parseDefaultsLines cmd def_lines+    all_defs = parseDefaultsLines (NormalCmd "ALL") def_lines+    to_flag all_switches (switch,arg) =+      if switch `notElem` all_switches then do+        tell [ OptWarning $ source++": command '"++showCmdName cmd+             ++"' has no option '"++switch++"'."]+        return Nothing+      else+        mapErrors ((OptWarning $ source++" for command '"++showCmdName cmd++"':"):)+          $ defaultToFlag cwd opt_map (switch,arg)+    -- the catMaybes filters out options that are not defined+    -- for this command+    flags_for all_switches = fmap catMaybes . mapM (to_flag all_switches)+    mapErrors f = mapWriter (\(r, es) -> (r, if null es then [] else f es))++-- | Result of parsing a defaults line: switch and argument(s).+type Default = (String, String)++-- | Extract 'Default's from lines of a defaults file that match the given 'CmdName'.+-- +-- The syntax is+--+-- @+--  supercmd subcmd [--]switch [args...]+-- @+--+-- for (super) commands with a sub command, and+--+-- @+--  cmd default [--]default [args...]+-- @+--+-- for normal commands (including the @ALL@ pseudo command).+parseDefaultsLines :: CmdName -> [String] -> [Default]+parseDefaultsLines cmd = catMaybes . map matchLine+  where+    matchLine = match $ (,) <$> (match_cmd cmd *> spaces *> option) <*> rest+    match_cmd (NormalCmd name) = string name+    match_cmd (SuperCmd super sub) = string super *> spaces *> string sub+    option = short <|> long+    short = (\c1 c2 -> [c1,c2]) <$> sym '-' <*> psym isLetter+    long = (++) <$> opt_dashes <*> word+    opt_dashes = string "--" <|> pure "--"+    word = (:) <$> psym isLetter <*> many (psym (not.isSpace))+    spaces = some $ psym isSpace+    rest = spaces *> many anySym <|> pure ""++-- | Search an option list for a switch. If found, apply the flag constructor+-- from the option to the arg, if any. The first parameter is the current working+-- directory, which, depending on the option type, may be needed to create a flag+-- from an argument.+-- +-- Fails if (default has argument /= corresponding option has argument).+defaultToFlag :: AbsolutePath+              -> OptionMap+              -> Default+              -> Writer [OptMsg] (Maybe DarcsFlag)+defaultToFlag cwd opts (switch, arg) = case M.lookup switch opts of+    -- This case is not impossible! A default flag defined for ALL commands+    -- is not necessarily defined for the concrete command in question.+    Nothing -> return Nothing+    Just opt -> flag_from $ getArgDescr $ getCompose opt+  where+    getArgDescr (Option _ _ a _) = a+    flag_from (NoArg mkFlag) = do+      if not (null arg) then do+        tell+          [ OptWarning $+            "'"++switch++"' takes no argument, but '"++arg++"' argument given." ]+        return Nothing+      else+        return $ Just $ mkFlag cwd+    flag_from (OptArg mkFlag _) =+      return $ Just $ mkFlag (if null arg then Nothing else Just arg) cwd+    flag_from (ReqArg mkFlag _) = do+      if null arg then do+        tell+          [ OptError $+            "'"++switch++"' requires an argument, but no argument given." ]+        return Nothing+      else+        return $ Just $ mkFlag arg cwd++-- | Get all the flag names from an options+optionSwitches :: DarcsOptDescr DarcsFlag -> [String]+optionSwitches (Compose (Option short long _ _)) = withDashes short long++-- | A finite map from flag names to 'DarcsOptDescr's.+type OptionMap = M.Map String (DarcsOptDescr DarcsFlag)++-- | Build an 'OptionMap' from a list of 'DarcsOption's.+optionMap :: [DarcsOptDescr DarcsFlag] -> OptionMap+optionMap = M.fromList . concatMap sel where+  add_option opt switch = (switch, opt)+  sel o = map (add_option o) (optionSwitches o)++-- | List of option switches of all commands (except help but that has no options).+allOptionSwitches :: [String]+allOptionSwitches = nub $ concatMap optionSwitches $+  concatMap (uncurry (++) . commandAlloptions) $+            extractAllCommands commandControlList
+ src/Darcs/UI/Email.hs view
@@ -0,0 +1,261 @@+module Darcs.UI.Email+    ( makeEmail+    , readEmail+    , formatHeader+    -- just for testing+    , prop_qp_roundtrip+    ) where++import Darcs.Prelude++import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper )+import Data.List ( isInfixOf )+import Darcs.Util.Printer+    ( Doc, ($$), (<+>), text, empty, packedString, renderPS )++import Darcs.Util.ByteString ( packStringToUTF8, dropSpace, linesPS, betweenLinesPS )+import qualified Data.ByteString          as B  (ByteString, length, null, tail+                                                ,drop, head, concat, singleton+                                                ,pack, append, empty, unpack, snoc+                                                )+import qualified Data.ByteString.Char8    as BC (index, head, pack)+import Data.ByteString.Internal as B (c2w, createAndTrim)+import System.IO.Unsafe ( unsafePerformIO )+import Foreign.Ptr ( Ptr, plusPtr )+import Foreign.Storable ( poke )+import Data.Word ( Word8 )+import Data.Maybe ( fromMaybe )++-- lineMax is maximum number of characters in an e-mail line excluding the CRLF+-- at the end. qlineMax is the number of characters in a q-encoded or+-- quoted-printable-encoded line.+lineMax, qlineMax :: Int+lineMax  = 78+qlineMax = 75++-- | Formats an e-mail header by encoding any non-ascii characters using UTF-8+--   and Q-encoding, and folding lines at appropriate points. It doesn't do+--   more than that, so the header name and header value should be+--   well-formatted give or take line length and encoding. So no non-ASCII+--   characters within quoted-string, quoted-pair, or atom; no semantically+--   meaningful signs in names; no non-ASCII characters in the header name;+--   etcetera.+formatHeader :: String -> String -> B.ByteString+formatHeader headerName headerValue =+    B.append nameColon encodedValue+  where nameColon = B.pack (map B.c2w (headerName ++ ":")) -- space for folding+        encodedValue = foldAndEncode (' ':headerValue)+                                       (B.length nameColon) False False++-- run through a string and encode non-ascii words and fold where appropriate.+-- the integer argument is the current position in the current line.+-- the string in the first argument must begin with whitespace, or be empty.+foldAndEncode :: String -> Int -> Bool -> Bool -> B.ByteString+foldAndEncode [] _ _               _         = B.empty+foldAndEncode s  p lastWordEncoded inMidWord =+  let newline  = B.singleton 10+      space    = B.singleton 32+      s2bs     = B.pack . map B.c2w+      -- the twelve there is the max number of ASCII chars to encode a single+      -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte+      safeEncChunkLength = (qlineMax - B.length encodedWordStart+                                      - B.length encodedWordEnd) `div` 12+      (curSpace, afterCurSpace) = span (== ' ') s+      (curWord,  afterCurWord)  = break (== ' ') afterCurSpace+      qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord)+               | otherwise       = qEncode curWord+      mustEncode = inMidWord+                   || any (\c -> not (isPrint c) || ord c > 127) curWord+                   || length curWord > lineMax - 1+                   || isInfixOf "=?" curWord+      mustFold+        | mustEncode && lastWordEncoded+            = p + 1 + B.length qEncWord > lineMax+        | mustEncode+            = p + length curSpace + B.length qEncWord > lineMax+        | otherwise+            = p + length curSpace + length curWord > lineMax+      mustSplit = (B.length qEncWord > qlineMax && mustEncode)+                  || length curWord > lineMax - 1+      spaceToInsert | mustEncode && lastWordEncoded = space+                    | otherwise                     = s2bs curSpace+      wordToInsert+        | mustEncode && mustSplit = qEncode (take safeEncChunkLength curWord)+        | mustEncode = qEncWord+        | otherwise  = s2bs curWord+      doneChunk | mustFold  = B.concat [newline, spaceToInsert, wordToInsert]+                | otherwise = B.concat [spaceToInsert, wordToInsert]+      (rest, nextP)+        | mustSplit+            = (drop safeEncChunkLength curWord ++ afterCurWord, qlineMax + 1)+        | mustEncode && mustFold+            = (afterCurWord, B.length spaceToInsert + B.length wordToInsert)+        | otherwise+            = (afterCurWord, p + B.length doneChunk)+  in B.append doneChunk (foldAndEncode rest nextP mustEncode mustSplit)++-- | Turns a piece of string into a q-encoded block+--   Applies q-encoding, for use in e-mail header values, as defined in RFC 2047.+--   It just takes a string and builds an encoded-word from it, it does not check+--   length or necessity.+qEncode :: String -> B.ByteString+qEncode s = B.concat [encodedWordStart,+                      encodedString,+                      encodedWordEnd]+  where encodedString =  B.concat (map qEncodeChar s)++encodedWordStart, encodedWordEnd :: B.ByteString+encodedWordStart = B.pack (map B.c2w "=?UTF-8?Q?")+encodedWordEnd   = B.pack (map B.c2w "?=")++-- turns a character into its q-encoded bytestring value. For most printable+-- ASCII characters, that's just the singleton bytestring with that char.+qEncodeChar :: Char -> B.ByteString+qEncodeChar c+    | c == ' '                          = c2bs '_'+    | isPrint c+      && c `notElem` "?=_"+      && ord c < 128                    = c2bs c+    | otherwise                         = B.concat+                                            (map qbyte+                                              (B.unpack+                                                (packStringToUTF8 [c])))+  where c2bs = B.singleton . B.c2w+        -- qbyte turns a byte into its q-encoded "=hh" representation+        qbyte b = B.pack (map B.c2w ['='+                                    ,word8ToUDigit (b `div` 16)+                                    ,word8ToUDigit (b `mod` 16)+                                    ])+        word8ToUDigit :: Word8 -> Char+        word8ToUDigit = toUpper . intToDigit . fromIntegral++-- Encode a ByteString according to "Quoted Printable" defined by MIME+-- (https://tools.ietf.org/html/rfc2045#section-6.7)+qpencode :: B.ByteString -> B.ByteString+qpencode s = unsafePerformIO+           -- Really only (3 + 2/75) * length or something in the worst case+           $ B.createAndTrim (4 * B.length s) (\buf -> encode s qlineMax buf 0)++encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int+encode ps _ _ bufi | B.null ps = return bufi+encode ps n buf bufi = case B.head ps of+  c | c == newline ->+        do poke (buf `plusPtr` bufi) newline+           encode ps' qlineMax buf (bufi+1)+    | n == 0 && B.length ps >= 1 ->+        do poke (buf `plusPtr` bufi) equals+           poke (buf `plusPtr` (bufi+1)) newline+           encode ps qlineMax buf (bufi + 2)+    | c == tab || c == space ->+        if B.null ps' || B.head ps' == newline+        then do poke (buf `plusPtr` bufi) c+                poke (buf `plusPtr` (bufi+1)) equals+                poke (buf `plusPtr` (bufi+2)) newline+                encode ps' qlineMax buf (bufi + 3)+        else do poke (buf `plusPtr` bufi) c+                encode ps' (n - 1) buf (bufi + 1)+    | c >= bang && c /= equals && c /= period && c <= tilde ->+        do poke (buf `plusPtr` bufi) c+           encode ps' (n - 1) buf (bufi + 1)+    | n < 3 ->+        encode ps 0 buf bufi+    | otherwise ->+        do let (x, y) = c `divMod` 16+               h1 = intToUDigit x+               h2 = intToUDigit y+           poke (buf `plusPtr` bufi) equals+           poke (buf `plusPtr` (bufi+1)) h1+           poke (buf `plusPtr` (bufi+2)) h2+           encode ps' (n - 3) buf (bufi + 3)+    where ps' = B.tail ps+          newline = B.c2w '\n'+          tab     = B.c2w '\t'+          space   = B.c2w ' '+          bang    = B.c2w '!'+          tilde   = B.c2w '~'+          equals  = B.c2w '='+          period  = B.c2w '.'+          intToUDigit i+            | i >= 0  && i <= 9  = B.c2w '0' + i+            | i >= 10 && i <= 15 = B.c2w 'A' + i - 10+            | otherwise = error $ "intToUDigit: '"++show i++"'not a digit"++qpdecode :: B.ByteString -> B.ByteString+qpdecode s = unsafePerformIO+             -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n"+           $ B.createAndTrim (B.length s + 1) (\buf -> decode (linesPS s) buf 0)++decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int+decode [] _ bufi = return bufi+decode (ps:pss) buf bufi+ | B.null (dropSpace ps)+    = do poke (buf `plusPtr` bufi) newline+         decode pss buf (bufi+1)+ | is_equals && B.length ps >= 3 && isHexDigit c1 && isHexDigit c2+    = do poke (buf `plusPtr` bufi)+              (toWord8 $ digitToInt c1 * 16 + digitToInt c2)+         decode (B.drop 3 ps:pss) buf (bufi+1)+ | is_equals && B.null (dropSpace (B.tail ps)) = decode pss buf bufi+ | otherwise = do poke (buf `plusPtr` bufi) (B.head ps)+                  decode (B.tail ps:pss) buf (bufi+1)+    where is_equals = BC.head ps == '='+          c1 = BC.index ps 1+          c2 = BC.index ps 2+          newline = B.c2w '\n'+          toWord8 :: Int -> Word8+          toWord8 = fromIntegral++makeEmail :: String -> [(String, String)] -> Maybe Doc -> Maybe String -> Doc -> Maybe String -> Doc+makeEmail repodir headers mcontents mcharset bundle mfilename =+    text "DarcsURL:" <+> text repodir+ $$ foldl (\m (h,v) -> m $$ (text (h ++ ":") <+> text v)) empty headers+ $$ text "MIME-Version: 1.0"+ $$ text "Content-Type: multipart/mixed; boundary=\"=_\""+ $$ text ""+ $$ text "--=_"+ $$ (case mcontents of+       Just contents ->+            text ("Content-Type: text/plain; charset=\"" +++              fromMaybe "x-unknown" mcharset ++ "\"")+         $$ text "Content-Transfer-Encoding: quoted-printable"+         $$ text ""+         $$ packedString (qpencode (renderPS contents))+         $$ text ""+         $$ text "--=_"+       Nothing -> empty)+ $$ text "Content-Type: text/x-darcs-patch; name=\"patch-preview.txt\""+ $$ text "Content-Disposition: inline"+ $$ text "Content-Transfer-Encoding: quoted-printable"+ $$ text "Content-Description: Patch preview"+ $$ text ""+ $$ (case betweenLinesPS (BC.pack "New patches:") (BC.pack "Context:") (renderPS bundle) of+     Just s -> packedString $ qpencode s+     -- this should not happen, but in case it does, keep everything+     Nothing -> packedString $ qpencode $ renderPS bundle)+ $$ text "--=_"+ $$ text "Content-Type: application/x-darcs-patch" <>+      (case mfilename of+         Just filename -> text "; name=\"" <> text filename <> text "\""+         Nothing -> empty)+ $$ text "Content-Transfer-Encoding: quoted-printable"+ $$ text "Content-Disposition: attachment"+ $$ text "Content-Description: A darcs patch for your repository!"+ $$ text ""+ $$ packedString (qpencode (renderPS bundle))+ $$ text "--=_--"+ $$ text ""+ $$ text "."+ $$ text ""+ $$ text ""++readEmail :: B.ByteString -> B.ByteString+readEmail s =+    case betweenLinesPS+         (BC.pack "Content-Description: A darcs patch for your repository!")+         (BC.pack "--=_--") s of+    Nothing -> s -- if it wasn't an email in the first place, just pass along.+    Just s' -> qpdecode s'++-- note: qpdecode appends an extra '\n'+prop_qp_roundtrip :: B.ByteString -> Bool+prop_qp_roundtrip s = B.snoc s 10 == (qpdecode . qpencode) s
+ src/Darcs/UI/External.hs view
@@ -0,0 +1,533 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.UI.External+    ( sendEmail+    , generateEmail+    , sendEmailDoc+    , signString+    , verifyPS+    , execDocPipe+    , pipeDoc+    , pipeDocSSH+    , viewDoc+    , viewDocWith+    , checkDefaultSendmail+    , diffProgram+    , darcsProgram+    , editText+    , editFile+    --  * Locales+    , setDarcsEncodings+    ) where++import Darcs.Prelude++import Data.Maybe ( isJust )+import Safe ( tailErr )+import Control.Monad ( unless, when, filterM, void )+#ifndef WIN32+import Control.Monad ( liftM2 )+#endif+import System.Exit ( ExitCode(..) )+import System.Environment+    ( getEnv+    , getExecutablePath+    )+import System.Directory ( doesFileExist, findExecutable )+import System.IO+    ( Handle+    , hClose+    , hIsTerminalDevice+    , stderr+    , stdout+    )+#ifndef WIN32+import System.FilePath.Posix ( (</>) )+#endif+import System.Process ( createProcess, proc, CreateProcess(..), runInteractiveProcess, waitForProcess, StdStream(..) )++#ifndef WIN32+import GHC.IO.Encoding+    ( getFileSystemEncoding+    , setForeignEncoding+    , setLocaleEncoding )+#endif++import Control.Concurrent ( forkIO, newEmptyMVar, putMVar, takeMVar )+import Control.Exception ( IOException, finally, try )+import System.IO.Error ( ioeGetErrorType )+import GHC.IO.Exception ( IOErrorType(ResourceVanished) )+#ifdef WIN32+import Foreign.C ( withCString )+import Foreign.C.String ( CString )+import Foreign.Ptr ( nullPtr )+import Darcs.Util.Lock ( writeDocBinFile )+import System.Directory ( canonicalizePath )+#endif++import Darcs.UI.Options.All ( Sign(..), Verify(..), Compression(..) )+import Darcs.Util.Path+    ( AbsolutePath+    , toFilePath+    , FilePathLike+    )+import Darcs.Util.Progress ( withoutProgress, debugMessage )++import Darcs.Util.ByteString (linesPS, unlinesPS)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC++import Darcs.Util.File ( withOpenTemp, withTemp )+import Darcs.Util.Lock ( withNamedTemp )+import Darcs.Util.Ssh ( getSSH, SSHCmd(..) )+import Darcs.Util.CommandLine ( parseCmd, addUrlencoded )+#ifndef WIN32+import Darcs.Util.English ( orClauses )+#endif+import Darcs.Util.Exception ( catchall )+import Darcs.Util.Exec ( execInteractive, exec, Redirect(..), withoutNonBlock )+import Darcs.Util.URL ( SshFilePath, sshUhost )+import Darcs.Util.Printer+    ( Doc+    , Printers+    , hPutDoc+    , hPutDocCompr+    , hPutDocLn+    , hPutDocLnWith+    , hPutDocWith+    , packedString+    , renderPS+    , renderString+    , simplePrinters+    , text+    )+import Darcs.UI.Email ( formatHeader )++#ifndef WIN32+sendmailPath :: IO String+sendmailPath = do+  let searchPath = [ "/usr/sbin", "/sbin", "/usr/lib" ]+  l <- filterM doesFileExist $ liftM2 (</>)+                searchPath+                [ "sendmail" ]+  ex <- findExecutable "sendmail"+  case (ex, l) of+    (Just v, _) -> return v+    (_, v:_) -> return v+    _ -> fail $ "Cannot find the 'sendmail' program in " +++      orClauses ("your PATH" : searchPath) ++ "."+#endif++diffProgram :: IO String+diffProgram = do+  l <- filterM (fmap isJust . findExecutable) [ "gdiff", "gnudiff", "diff" ]+  case l of+    [] -> fail "Cannot find the \"diff\" program."+    v:_ -> return v++-- |Get the name of the darcs executable (as supplied by @getExecutablePath@)+darcsProgram :: IO String+darcsProgram = getExecutablePath++pipeDoc :: String -> [String] -> Doc -> IO ExitCode+pipeDoc = pipeDocInternal (PipeToOther simplePrinters)++data WhereToPipe = PipeToSsh Compression -- ^ if pipe to ssh, can choose to compress or not+                 | PipeToOther Printers  -- ^ otherwise, can specify printers++pipeDocInternal :: WhereToPipe -> String -> [String] -> Doc -> IO ExitCode+pipeDocInternal whereToPipe c args inp = withoutNonBlock $ withoutProgress $+    do debugMessage $ "Exec: " ++ unwords (map show (c:args))+       (Just i,_,_,pid) <- createProcess (proc c args){ std_in = CreatePipe+                                                      , delegate_ctlc = True}+       debugMessage "Start transferring data"+       case whereToPipe of+          PipeToSsh GzipCompression -> hPutDocCompr i inp+          PipeToSsh NoCompression   -> hPutDoc i inp+          PipeToOther printers      -> hPutDocWith printers i inp+       hClose i+       rval <- waitForProcess pid+       debugMessage "Finished transferring data"+       when (rval == ExitFailure 127) $+            putStrLn $ "Command not found:\n   "++ show (c:args)+       return rval++pipeDocSSH :: Compression -> SshFilePath -> [String] -> Doc -> IO ExitCode+pipeDocSSH compress remoteAddr args input = do+    (ssh, ssh_args) <- getSSH SSH+    pipeDocInternal (PipeToSsh compress) ssh (ssh_args ++ ("--":sshUhost remoteAddr:args)) input++sendEmail :: String -> String -> String -> String -> Maybe String -> String -> IO ()+sendEmail f t s cc scmd body =+  sendEmailDoc f t s cc scmd Nothing (text body)+++generateEmail+    :: Handle  -- ^ handle to write email to+    -> String  -- ^ From+    -> String  -- ^ To+    -> String  -- ^ Subject+    -> String  -- ^ CC+    -> Doc     -- ^ body+    -> IO ()+generateEmail h f t s cc body = do+     putHeader "To" t+     putHeader "From" f+     putHeader "Subject" s+     unless (null cc) $ putHeader "Cc" cc+     putHeader "X-Mail-Originator" "Darcs Version Control System"+     hPutDocLn h body+  where putHeader field value+            = B.hPut h (B.append (formatHeader field value) newline)+        newline = B.singleton 10++checkDefaultSendmail :: IO ()+#ifndef WIN32+checkDefaultSendmail = void sendmailPath+#else+-- FIXME find a way to detect if sending via MAPI would work+checkDefaultSendmail = return ()+{-+  TODO do we want a warning message like this one here?+  hPutStr stderr+    "Warning: Using MAPI for sending mail. This may hang indefinitely " +++    "if not properly configured.\n"+-}+#endif++-- | Send an email, optionally containing a patch bundle+--   (more precisely, its description and the bundle itself)+sendEmailDoc+  :: String           -- ^ from+  -> String           -- ^ to+  -> String           -- ^ subject+  -> String           -- ^ cc+  -> Maybe String     -- ^ send command+  -> Maybe (Doc, Doc) -- ^ (content,bundle)+  -> Doc              -- ^ body+  -> IO ()+sendEmailDoc _ "" _ "" _ _ _ = return ()+sendEmailDoc f "" s cc scmd mbundle body =+  sendEmailDoc f cc s "" scmd mbundle body+#ifdef WIN32+sendEmailDoc f t s cc Nothing _mbundle body = do+  r <- withCString t $ \tp ->+           withCString f $ \fp ->+            withCString cc $ \ccp ->+             withCString s $ \sp ->+              withOpenTemp $ \(h,fn) -> do+               hPutDoc h body+               hClose h+               writeDocBinFile "mailed_patch" body+               cfn <- canonicalizePath fn+               withCString cfn $ \pcfn ->+                c_send_email fp tp ccp sp nullPtr pcfn+  when (r /= 0) $ do+    fail $ "Failed to send mail via MAPI to: " ++ recipients t cc+#endif+sendEmailDoc f t s cc scmd mbundle body =+  withOpenTemp $ \(h,fn) -> do+    generateEmail h f t s cc body+    hClose h+    withOpenTemp $ \(hat,at) -> do+      ftable' <- case mbundle of+                 Just (content,bundle) -> do+                     hPutDocLn hat bundle+                     return [ ('b', renderString content) , ('a', at) ]+                 Nothing ->+                     return [ ('b', renderString body) ]+      hClose hat+      let ftable = [ ('t',addressOnly t),('c',cc),('f',f),('s',s) ] ++ ftable'+      r <- execSendmail ftable scmd fn+      when (r /= ExitSuccess) $+        fail ("Failed to send mail to: " ++ recipients t cc)+  where addressOnly a =+          case dropWhile (/= '<') a of+          ('<':a2) -> takeWhile (/= '>') a2+          _        -> a++recipients :: String -> String -> String+recipients to "" = to+recipients to cc = to ++ " and cc'ed " ++ cc++execSendmail :: [(Char,String)] -> Maybe String -> String -> IO ExitCode+#ifdef WIN32+execSendmail _ Nothing _ = error "impossible"+#else+execSendmail _ Nothing fn = do+  scmd <- sendmailPath+  exec scmd ["-i", "-t"] (File fn, Null, AsIs)+#endif+execSendmail ftable (Just scmd) fn =+  case parseCmd (addUrlencoded ftable) scmd of+    Right (arg0:opts, wantstdin) ->+      let stdin = if wantstdin then File fn else Null+      in do+        debugMessage $ unwords $ "execSendmail:" : map show (arg0 : opts)+        exec arg0 opts (stdin, Null, AsIs)+    Right ([], _) ->+      fail $ "Invalid sendmail-command "++show scmd+    Left e ->+      fail $ "Invalid sendmail-command "++show scmd++"\n"++show e++#ifdef WIN32+foreign import ccall "win32/send_email.h send_email" c_send_email+             :: CString -> {- sender -}+                CString -> {- recipient -}+                CString -> {- cc -}+                CString -> {- subject -}+                CString -> {- body -}+                CString -> {- path -}+                IO Int+#endif++execPSPipe :: String -> [String] -> B.ByteString -> IO B.ByteString+execPSPipe command args input =+  withoutProgress $ do+    (hi, ho, he, pid) <- runInteractiveProcess command args Nothing Nothing+    _ <- forkIO $ B.hPut hi input >> hClose hi+    done <- newEmptyMVar+    _ <- forkIO $ (B.hGetContents he >>= B.hPut stderr) `finally` putMVar done ()+    output <- B.hGetContents ho+    rval <- waitForProcess pid+    takeMVar done+    case rval of+      ExitFailure ec ->+        fail $+        "External program '" ++ command ++ "' failed with exit code " ++ show ec+      ExitSuccess -> return output++execDocPipe :: String -> [String] -> Doc -> IO Doc+execDocPipe command args input =+  packedString <$> execPSPipe command args (renderPS input)++signString :: Sign -> Doc -> IO Doc+signString NoSign d = return d+signString Sign d = signPGP [] d+signString (SignAs keyid) d = signPGP ["--local-user", keyid] d+signString (SignSSL idf) d = signSSL idf d++signPGP :: [String] -> Doc -> IO Doc+signPGP args = execDocPipe "gpg" ("--clearsign":args)++signSSL :: String -> Doc -> IO Doc+signSSL idfile t =+    withTemp $ \cert -> do+    opensslPS ["req", "-new", "-key", idfile,+               "-outform", "PEM", "-days", "365"]+                (BC.pack "\n\n\n\n\n\n\n\n\n\n\n")+                >>= opensslPS ["x509", "-req", "-extensions",+                               "v3_ca", "-signkey", idfile,+                               "-outform", "PEM", "-days", "365"]+                >>= opensslPS ["x509", "-outform", "PEM"]+                >>= B.writeFile cert+    opensslDoc ["smime", "-sign", "-signer", cert,+                "-inkey", idfile, "-noattr", "-text"] t+    where opensslDoc = execDocPipe "openssl"+          opensslPS = execPSPipe "openssl"+++verifyPS :: Verify -> B.ByteString -> IO (Maybe B.ByteString)+verifyPS NoVerify ps = return $ Just ps+verifyPS (VerifyKeyring pks) ps = verifyGPG pks ps+verifyPS (VerifySSL auks) ps = verifySSL auks ps++verifyGPG :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)+verifyGPG goodkeys s =+    withOpenTemp $ \(th,tn) -> do+      B.hPut th s+      hClose th+      rval <- exec "gpg"  ["--batch","--no-default-keyring",+                           "--keyring",fix_path $ toFilePath goodkeys, "--verify"]+                           (File tn, Null, Null)+      case rval of+          ExitSuccess -> return $ Just gpg_fixed_s+          _ -> return Nothing+      where gpg_fixed_s = let+                not_begin_signature x =+                    x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----"+                    &&+                    x /= BC.pack "-----BEGIN PGP SIGNED MESSAGE-----\r"+                in unlinesPS $ map fix_line $ tailErr $ dropWhile not_begin_signature $ linesPS s+            fix_line x | B.length x < 3 = x+                       | BC.pack "- -" `B.isPrefixOf` x = B.drop 2 x+                       | otherwise = x+#ifdef WIN32+            fix_sep c | c=='/' = '\\'   | otherwise = c+            fix_path p = map fix_sep p+#else+            fix_path p = p+#endif++verifySSL :: AbsolutePath -> B.ByteString -> IO (Maybe B.ByteString)+verifySSL goodkeys s = do+    certdata <- opensslPS ["smime", "-pk7out"] s+                >>= opensslPS ["pkcs7", "-print_certs"]+    cruddy_pk <- opensslPS ["x509", "-pubkey"] certdata+    let key_used = B.concat $ tailErr $+                   takeWhile (/= BC.pack"-----END PUBLIC KEY-----")+                           $ linesPS cruddy_pk+        in do allowed_keys <- linesPS `fmap` B.readFile (toFilePath goodkeys)+              if key_used `notElem` allowed_keys+                then return Nothing -- Not an allowed key!+                else withTemp $ \cert ->+                     withTemp $ \on ->+                     withOpenTemp $ \(th,tn) -> do+                     B.hPut th s+                     hClose th+                     B.writeFile cert certdata+                     rval <- exec "openssl" ["smime", "-verify", "-CAfile",+                                             cert, "-certfile", cert]+                                             (File tn, File on, Null)+                     case rval of+                       ExitSuccess -> Just `fmap` B.readFile on+                       _ -> return Nothing+    where opensslPS = execPSPipe "openssl"++viewDoc :: Doc -> IO ()+viewDoc = viewDocWith simplePrinters++viewDocWith :: Printers -> Doc -> IO ()+viewDocWith pr msg = do+  isTerminal <- hIsTerminalDevice stdout+  void $ if isTerminal && lengthGreaterThan (20 :: Int) (lines $ renderString msg)+     then do mbViewerPlusArgs <- getViewer+             case mbViewerPlusArgs of+                  Just viewerPlusArgs -> do+                    case words viewerPlusArgs of+                      [] -> pipeDocToPager "" [] pr msg+                      (viewer : args) -> pipeDocToPager viewer args pr msg+                  Nothing -> return $ ExitFailure 127 -- No such command+               `ortryrunning` pipeDocToPager  "less" ["-R"] pr msg+               `ortryrunning` pipeDocToPager  "more" [] pr msg+#ifdef WIN32+               `ortryrunning` pipeDocToPager  "more.com" [] pr msg+#endif+               `ortryrunning` pipeDocToPager "" [] pr msg+     else pipeDocToPager "" [] pr msg+              where lengthGreaterThan n _ | n <= 0 = True+                    lengthGreaterThan _ [] = False+                    lengthGreaterThan n (_:xs) = lengthGreaterThan (n-1) xs++getViewer :: IO (Maybe String)+getViewer = Just `fmap` (getEnv "DARCS_PAGER" `catchall` getEnv "PAGER")+            `catchall`+            return Nothing++pipeDocToPager :: String -> [String] -> Printers -> Doc -> IO ExitCode++pipeDocToPager "" _ pr inp = do+  hPutDocLnWith pr stdout inp+  return ExitSuccess++pipeDocToPager c args pr inp = pipeDocInternal (PipeToOther pr) c args inp++-- | Given two shell commands as arguments, execute the former.  The+-- latter is then executed if the former failed because the executable+-- wasn't found (code 127), wasn't executable (code 126) or some other+-- exception occurred (save from a resource vanished/broken pipe error).+-- Other failures (such as the user holding ^C)+-- do not cause the second command to be tried.+ortryrunning :: IO ExitCode+             -> IO ExitCode+             -> IO ExitCode+a `ortryrunning` b = do+  ret <- try a+  case ret of+    (Right (ExitFailure 126)) -> b -- command not executable+    (Right (ExitFailure 127)) -> b -- command not found+#ifdef WIN32+    (Right (ExitFailure 9009)) -> b -- command not found by cmd.exe on Windows+#endif+    (Right x) -> return x          -- legitimate success/failure+    (Left (e :: IOException)) -> case ioeGetErrorType e of+                                   -- case where pager is quit before darcs has fed it entirely:+                                   ResourceVanished -> return ExitSuccess+                                   -- other exception:+                                   _                -> b+++editText :: String -> B.ByteString -> IO B.ByteString+editText desc txt = withNamedTemp desc $ \f -> do+  B.writeFile f txt+  _ <- runEditor f+  B.readFile f++-- | @editFile f@ lets the user edit a file which could but does not need to+-- already exist. This function returns the exit code from the text editor and a+-- flag indicating if the user made any changes.+editFile :: FilePathLike p+         => p+         -> IO (ExitCode, Bool)+editFile ff = do+    old_content <- file_content+    ec <- runEditor f+    new_content <- file_content+    return (ec, new_content /= old_content)+  where+    f = toFilePath ff+    file_content = do+      exists <- doesFileExist f+      if exists then do content <- B.readFile f+                        return $ Just content+                else return Nothing+++runEditor :: FilePath+          -> IO ExitCode+runEditor f = do+    ed <- getEditor+    let mf = Just f+    execInteractive ed mf+         `ortryrunning` execInteractive "vi" mf+         `ortryrunning` execInteractive "emacs" mf+         `ortryrunning` execInteractive "emacs -nw" mf+#ifdef WIN32+         `ortryrunning` execInteractive "edit" mf+#endif+++getEditor :: IO String+getEditor = getEnv "DARCS_EDITOR" `catchall`+             getEnv "VISUAL" `catchall`+             getEnv "EDITOR" `catchall` return "nano"++-- | On Posix systems, GHC by default uses the user's locale encoding to+-- determine how to decode/encode the raw byte sequences in the Posix API+-- to/from 'String'. It also uses certain special variants of this+-- encoding to determine how to handle encoding errors.+--+-- See "GHC.IO.Encoding" for details.+--+-- In particular, the default variant used for command line arguments and+-- environment variables is //ROUNDTRIP, which means that /any/ byte sequence+-- can be decoded and re-encoded w/o failure or loss of information. To+-- enable this, GHC uses code points that are outside the range of the regular+-- unicode set. This is what you get with 'getFileSystemEncoding'.+--+-- We need to preserve the raw bytes e.g. for file names passed in by the+-- user and also when reading file names from disk; also when re-generating+-- files from patches, and when we display them to the user.+--+-- So we want to use this encoding variant for *all* IO and for (almost) all+-- conversions between raw bytes and 'String's. The encoding used for IO from+-- and to handles is controlled by 'setLocaleEncoding' which we use here to+-- make it equal to the //ROUNDTRIP variant.+--+-- @setDarcsEncoding@ should be called before the+-- first time any darcs operation is run, and again if anything else might have+-- set those encodings to different values.+--+-- Note that it isn't thread-safe and has a global effect on your program.+--+-- On Windows, this function does (and should) not do anything.+setDarcsEncodings :: IO ()+#ifdef WIN32+setDarcsEncodings = return ()+#else+setDarcsEncodings = do+    e <- getFileSystemEncoding+    -- TODO check if we have to set this, too.+    setForeignEncoding e+    setLocaleEncoding e+#endif
+ src/Darcs/UI/Flags.hs view
@@ -0,0 +1,471 @@+-- Copyright (C) 2002-2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+-- | Helper functions to access option contents. Some of them are here only to+-- ease the transition from the legacy system where we manually parsed the flag+-- list to the new(er) option system. At some point this module should be+-- renamed and the re-exports from "Darcs.UI.Options.All" removed.+module Darcs.UI.Flags+    ( F.DarcsFlag+    , diffingOpts+    , wantGuiPause+    , isInteractive+    , willRemoveLogFile+    , setDefault+    , allowConflicts+    , hasXmlOutput+    , hasLogfile+    , quiet+    , verbose+    , enumeratePatches++    , fixUrl+    , pathsFromArgs+    , pathSetFromArgs+    , getRepourl+    , getAuthor+    , promptAuthor+    , getEasyAuthor+    , getSendmailCmd+    , fileHelpAuthor+    , environmentHelpEmail+    , getSubject+    , getInReplyTo+    , getCc+    , environmentHelpSendmail+    , getOutput+    , getDate+    , workRepo+    , withNewRepo++    -- * Re-exports+    , O.diffAlgorithm+    , O.reorder+    , O.minimize+    , O.editDescription+    , O.maxCount+    , O.matchAny+    , O.withContext+    , O.allowCaseDifferingFilenames+    , O.allowWindowsReservedFilenames+    , O.changesReverse+    , O.usePacks+    , O.onlyToFiles+    , O.amendUnrecord+    , O.verbosity+    , O.useCache+    , O.useIndex+    , O.umask+    , O.dryRun+    , O.testChanges+    , O.setScriptsExecutable+    , O.withWorkingDir+    , O.leaveTestDir+    , O.cloneKind+    , O.patchIndexNo+    , O.patchIndexYes+    , O.xmlOutput+    , O.selectDeps+    , O.author+    , O.patchFormat+    , O.charset+    , O.siblings+    , O.applyAs+    , O.enumPatches+    ) where++import Darcs.Prelude++import Data.List ( intercalate )+import Data.List.Ordered ( nubSort )+import Data.Maybe+    ( isJust+    , maybeToList+    , isNothing+    , catMaybes+    )+import Control.Monad ( void, unless )+import System.Directory ( createDirectory, doesDirectoryExist, withCurrentDirectory )+import System.FilePath.Posix ( (</>) )+import System.Environment ( lookupEnv )+import System.Posix.Files ( getSymbolicLinkStatus )++import qualified Darcs.UI.Options.Flags as F ( DarcsFlag )+import Darcs.UI.Options ( Config, (?), (^), oparse, parseFlags, unparseOpt )+import qualified Darcs.UI.Options.All as O++import Darcs.Util.Exception ( catchall, ifDoesNotExistError )+import Darcs.Util.Prompt+    ( askUser+    , askUserListItem+    )+import Darcs.Util.Lock ( writeTextFile )+import Darcs.Repository.Flags ( WorkRepo(..) )+import Darcs.Repository.Prefs+    ( Pref(Author)+    , getPreflist+    , getGlobal+    , globalPrefsDirDoc+    , globalPrefsDir+    , prefsDirPath+    )+import Darcs.Util.IsoDate ( getIsoDateTime, cleanLocalDate )+import Darcs.Util.Path+    ( AbsolutePath+    , AbsolutePathOrStd+    , AnchoredPath+    , floatSubPath+    , inDarcsdir+    , ioAbsolute+    , makeAbsolute+    , makeAbsoluteOrStd+    , makeRelativeTo+    , toFilePath+    )+import Darcs.Util.Printer ( pathlist, putDocLn, text, ($$), (<+>) )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.URL ( isValidLocalPath )++verbose :: Config -> Bool+verbose = (== O.Verbose) . parseFlags O.verbosity++quiet :: Config -> Bool+quiet = (== O.Quiet) . parseFlags O.verbosity++enumeratePatches :: Config -> Bool+enumeratePatches = (== O.YesEnumPatches) . parseFlags O.enumPatches++diffingOpts :: Config -> O.DiffOpts+diffingOpts flags =+  O.DiffOpts+    (O.useIndex ? flags)+    (O.lookforadds ? flags)+    (O.lookforreplaces ? flags)+    (O.lookformoves ? flags)+    (O.diffAlgorithm ? flags)++-- | This will become dis-entangled as soon as we inline these functions.+wantGuiPause :: Config -> O.WantGuiPause+wantGuiPause fs =+  if (hasDiffCmd fs || hasExternalMerge fs) && hasPause fs+    then O.YesWantGuiPause+    else O.NoWantGuiPause+  where+    hasDiffCmd = isJust . O.diffCmd . parseFlags O.extDiff+    hasExternalMerge flags =+      case O.conflictsNo ? flags of+        Just (O.YesAllowConflicts (O.ExternalMerge _)) -> True+        _ -> False+    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 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+    decide _           _        _                     (Just False) = False+    decide _           _        (Just O.CountPatches) Nothing      = False+    decide _           O.YesXml _                     Nothing      = False+    decide O.YesDryRun _        _                     Nothing      = False+    decide _           _        _                     Nothing      = def++willRemoveLogFile :: Config -> Bool+willRemoveLogFile = O._rmlogfile . parseFlags O.logfile++setDefault :: Bool -> Config -> O.SetDefault+setDefault defYes = maybe def noDef . parseFlags O.setDefault where+  def = if defYes then O.YesSetDefault False else O.NoSetDefault False+  noDef yes = if yes then O.YesSetDefault True else O.NoSetDefault True++allowConflicts :: Config -> O.AllowConflicts+allowConflicts = maybe O.NoAllowConflicts id . parseFlags O.conflictsNo++-- | The first argument is an 'AbsolutePath', the second a 'String' that may be+-- a file path or a URL. It returns either the URL, or an absolute version of+-- the path, interpreted relative to the first argument.+fixUrl :: AbsolutePath -> String -> IO String+fixUrl d f =+  if isValidLocalPath f+    then withCurrentDirectory (toFilePath d) (toFilePath <$> ioAbsolute f)+    else return f++-- TODO move the following four functions somewhere else,+-- they have nothing to do with flags++-- | Used by commands that expect arguments to be paths in the current repo.+-- Invalid paths are dropped and a warning is issued. This may leave no valid+-- paths to return. Although these commands all fail if there are no remaining+-- valid paths, they do so in various different ways, issuing error messages+-- tailored to the command.+pathsFromArgs :: (AbsolutePath, AbsolutePath) -> [String] -> IO [AnchoredPath]+pathsFromArgs fps args = catMaybes <$> maybeFixSubPaths fps args++-- | Used by commands that interpret a set of optional path arguments as+-- "restrict to these paths", which affects patch selection (e.g. in log+-- command) or selection of subtrees (e.g. in record). Because of the special+-- meaning of "no arguments", we must distinguish it from "no valid arguments".+-- A result of 'Nothing' here means "no restriction to the set of paths". If+-- 'Just' is returned, the set is guaranteed to be non-empty.+pathSetFromArgs :: (AbsolutePath, AbsolutePath)+                -> [String]+                -> IO (Maybe [AnchoredPath])+pathSetFromArgs _ [] = return Nothing+pathSetFromArgs fps args = do+  pathSet <- nubSort . catMaybes <$> maybeFixSubPaths fps args+  case pathSet of+    [] -> fail "No valid arguments were given."+    _ -> return $ Just pathSet++-- | @maybeFixSubPaths (repo_path, orig_path) file_paths@ tries to turn+-- @file_paths@ into 'SubPath's, taking into account the repository path and+-- the original path from which darcs was invoked.+--+-- A 'SubPath' is a path /under/ (or inside) the repo path. This does /not/+-- mean it must exist as a file or directory, nor that the path has been added+-- to the repository; it merely means that it /could/ be added.+--+-- When converting a relative path to an absolute one, this function first tries+-- to interpret the relative path with respect to the current working directory.+-- If that fails, it tries to interpret it with respect to the repository+-- directory. Only when that fails does it put a @Nothing@ in the result at the+-- position of the path that cannot be converted.+--+-- It is intended for validating file arguments to darcs commands.+maybeFixSubPaths :: (AbsolutePath, AbsolutePath)+                 -> [String]+                 -> IO [Maybe AnchoredPath]+maybeFixSubPaths (r, o) fs = do+  fixedFs <- mapM (fmap dropInDarcsdir . fixit) fs+  let bads = snd . unzip . filter (isNothing . fst) $ zip fixedFs fs+  unless (null bads) $+    ePutDocLn $ text "Ignoring invalid repository paths:" <+> pathlist bads+  return fixedFs+ where+    dropInDarcsdir (Just p) | inDarcsdir p = Nothing+    dropInDarcsdir mp = mp+    -- special case here because fixit otherwise converts+    -- "" to (SubPath "."), which is a valid path+    fixit "" = return Nothing+    fixit p = do+      -- raise an exception if the given path has a trailing pathSeparator+      -- but refers to an existing non-directory+      ifDoesNotExistError () $ void (getSymbolicLinkStatus p)+      msp <- makeRelativeTo r (makeAbsolute o p)+      case msp of+        Just sp -> return $ floatIt sp+        Nothing -> do+          msp' <- makeRelativeTo r (makeAbsolute r p)+          case msp' of+            Nothing -> return Nothing+            Just sp' -> return $ floatIt sp'+    floatIt = either (const Nothing) Just . floatSubPath++-- | 'getRepourl' takes a list of flags and returns the url of the+-- repository specified by @Repodir \"directory\"@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--repodir=DIRECTORY@+getRepourl :: Config -> Maybe String+getRepourl fs = case parseFlags O.possiblyRemoteRepo fs of+  Nothing -> Nothing+  Just d -> if not (isValidLocalPath d) then Just d else Nothing++fileHelpAuthor :: [String]+fileHelpAuthor = [+ "Each patch is attributed to its author, usually by email address (for",+ "example, `Fred Bloggs <fred@example.net>`).  Darcs looks in several",+ "places for this author string: the `--author` option, the files",+ "`_darcs/prefs/author` (in the repository) and `" ++ globalPrefsDirDoc ++ "author` (in your",+ "home directory), and the environment variables `$DARCS_EMAIL` and",+ "`$EMAIL`.  If none of those exist, Darcs will prompt you for an author",+ "string and write it to `" ++ globalPrefsDirDoc ++ "author`.  Note that if you have more",+ "than one email address, you can put them all in `" ++ globalPrefsDirDoc ++ "author`,",+ "one author per line.  Darcs will still prompt you for an author, but it",+ "allows you to select from the list, or to type in an alternative."+ ]++environmentHelpEmail :: ([String], [String])+environmentHelpEmail = (["DARCS_EMAIL","EMAIL"], fileHelpAuthor)++-- | 'getAuthor' takes a list of flags and returns the author of the+-- change specified by @Author \"Leo Tolstoy\"@ in that list of flags, if any.+-- Otherwise, if @Pipe@ is present, asks the user who is the author and+-- returns the answer. If neither are present, try to guess the author,+-- from repository or global preference files or environment variables,+-- and if it's not possible, ask the user.+getAuthor :: Maybe String -> Bool -> IO String+getAuthor (Just author) _ = return author+getAuthor Nothing pipe =+  if pipe+    then askUser "Who is the author? "+    else promptAuthor True False++-- | 'promptAuthor' try to guess the author, from repository or+-- global preference files or environment variables, and+-- if it's not possible or alwaysAsk parameter is true, ask the user.+-- If store parameter is true, the new author is added into+-- @_darcs/prefs@.+promptAuthor :: Bool -- Store the new author+             -> Bool -- Author selection even if already stored+             -> IO String+promptAuthor store alwaysAsk = do+  as <- getEasyAuthor+  case as of+    [a] -> if alwaysAsk then+             askForAuthor False (fancyPrompt as) (fancyPrompt as)+           else return a+    []  -> askForAuthor True shortPrompt longPrompt+    _   -> askForAuthor False (fancyPrompt as) (fancyPrompt as)+ where+  shortPrompt = askUser "What is your email address? "+  longPrompt  = askUser "What is your email address (e.g. Fred Bloggs <fred@example.net>)? "+  fancyPrompt xs =+    do putDocLn $ text "" $$+                  text "You have saved the following email addresses to your global settings:"+       str <- askUserListItem "Please select an email address for this repository: " (xs ++ ["Other"])+       if str == "Other"+          then longPrompt+          else return str+  askForAuthor storeGlobal askfn1 askfn2 = do+      aminrepo <- doesDirectoryExist prefsDirPath+      if aminrepo && store then do+          prefsdir <- if storeGlobal+                         then tryGlobalPrefsDir+                         else return prefsDirPath+          putDocLn $+            text "Each patch is attributed to its author, usually by email address (for" $$+            text "example, `Fred Bloggs <fred@example.net>').  Darcs could not determine" $$+            text "your email address, so you will be prompted for it." $$+            text "" $$+            text ("Your address will be stored in " ++ prefsdir)+          if prefsdir /= prefsDirPath then+            putDocLn $+              text "It will be used for all patches you record in ALL repositories." $$+              text ("If you move that file to " ++ prefsDirPath </> "author" ++ ", it will") $$+              text "be used for patches recorded in this repository only."+          else+            putDocLn $+              text "It will be used for all patches you record in this repository only." $$+              text ("If you move that file to " ++ globalPrefsDirDoc ++ "author, it will") $$+              text "be used for all patches recorded in ALL repositories."+          add <- askfn1+          writeTextFile (prefsdir </> "author") $+                          unlines ["# " ++ line | line <- fileHelpAuthor] ++ "\n" ++ add+          return add+        else askfn2+  tryGlobalPrefsDir = do+    maybeprefsdir <- globalPrefsDir+    case maybeprefsdir of+      Nothing -> do+        putStrLn "WARNING: Global preference directory could not be found."+        return prefsDirPath+      Just dir -> do exists <- doesDirectoryExist dir+                     unless exists $ createDirectory dir+                     return dir++-- | 'getEasyAuthor' tries to get the author name first from the repository+-- preferences, then from global preferences, then from environment variables.+-- Returns @[]@ if it could not get it. Note that it may only return multiple+-- possibilities when reading from global preferences.+getEasyAuthor :: IO [String]+getEasyAuthor =+  firstNotNullIO [ (take 1 . nonblank) `fmap` getPreflist Author+                 , nonblank    `fmap` getGlobal Author+                 , maybeToList `fmap` lookupEnv "DARCS_EMAIL"+                 , maybeToList `fmap` lookupEnv "EMAIL"+                 ]+ where+  nonblank = filter (not . null)+  -- this could perhaps be simplified with Control.Monad+  -- but note that we do NOT want to concatenate the results+  firstNotNullIO [] = return []+  firstNotNullIO (e:es) = do+    v <- e `catchall` return []+    if null v then firstNotNullIO es else return v++getDate :: Bool -> IO String+getDate hasPipe = if hasPipe then cleanLocalDate =<< askUser "What is the date? "+                  else getIsoDateTime++environmentHelpSendmail :: ([String], [String])+environmentHelpSendmail = (["SENDMAIL"], [+ "On Unix, the `darcs send` command relies on sendmail(8).  The",+ "`--sendmail-command` or $SENDMAIL environment variable can be used to",+ "provide an explicit path to this program; otherwise the standard",+ "locations /usr/sbin/sendmail and /usr/lib/sendmail will be tried."])+-- FIXME: mention the following also:+-- * sendmail(8) is not sendmail-specific;+-- * nowadays, desktops often have no MTA or an unconfigured MTA --+--   which is awful, because it accepts mail but doesn't relay it;+-- * in this case, can be a sendmail(8)-emulating wrapper on top of an+--   MUA that sends mail directly to a smarthost; and+-- * on a multi-user system without an MTA and on which you haven't+--   got root, can be msmtp.++-- |'getSendmailCmd' takes a list of flags and returns the sendmail command+-- to be used by @darcs send@. Looks for a command specified by+-- @SendmailCmd \"command\"@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--sendmail-command=COMMAND@+-- Alternatively the user can set @$S@@ENDMAIL@ which will be used as a+-- fallback if present.+getSendmailCmd :: Config -> IO (Maybe String)+getSendmailCmd fs =+  case parseFlags O.sendmailCmd fs of+    Nothing -> lookupEnv "SENDMAIL"+    justcmd -> return justcmd++-- | Accessor for output option. Takes and returns IO actions+-- so that the default value is only calculated if needed,+-- as it might involve filesystem actions that can fail.+getOutput :: Config -> IO FilePath -> Maybe (IO AbsolutePathOrStd)+getOutput fs fp = fmap go (parseFlags O.output fs) where+  go (O.Output ap)         = return ap+  go (O.OutputAutoName ap) = makeAbsoluteOrStd ap <$> fp++-- |'getSubject' takes a list of flags and returns the subject of the mail+-- to be sent by @darcs send@. Looks for a subject specified by+-- @Subject \"subject\"@ in that list of flags, if any.+-- This flag is present if darcs was invoked with @--subject=SUBJECT@+getSubject :: Config -> Maybe String+getSubject = O._subject . parseFlags O.headerFields++-- |'getCc' takes a list of flags and returns the addresses to send a copy of+-- the patch bundle to when using @darcs send@.+-- looks for a cc address specified by @Cc \"address\"@ in that list of flags.+-- Returns the addresses as a comma separated string.+getCc :: Config -> String+getCc = intercalate " , " . O._cc . parseFlags O.headerFields++getInReplyTo :: Config -> Maybe String+getInReplyTo = O._inReplyTo . parseFlags O.headerFields++hasXmlOutput :: Config -> Bool+hasXmlOutput = (== O.YesXml) . parseFlags O.xmlOutput++hasLogfile :: Config -> Maybe AbsolutePath+hasLogfile = O._logfile . parseFlags O.logfile++workRepo :: Config -> WorkRepo+workRepo = oparse (O.repoDir ^ O.possiblyRemoteRepo) go+  where+    go (Just s) _ = WorkRepoDir s+    go Nothing (Just s) = WorkRepoPossibleURL s+    go Nothing Nothing = WorkRepoCurrentDir++withNewRepo :: String -> Config -> Config+withNewRepo dir = unparseOpt O.newRepo (Just dir)
+ src/Darcs/UI/Options.hs view
@@ -0,0 +1,25 @@+module Darcs.UI.Options+    ( module Darcs.UI.Options.Core+    , DarcsOption+    , PrimDarcsOption+    , DarcsOptDescr+    , optDescr+    , Config+    , withDashes+    ) where++import Darcs.Prelude++import Data.Functor.Compose ( getCompose )+import System.Console.GetOpt ( OptDescr )++import Darcs.UI.Options.All ( DarcsOption )+import Darcs.UI.Options.Core+import Darcs.UI.Options.Util ( DarcsOptDescr, Flag, PrimDarcsOption, withDashes )+import Darcs.Util.Path ( AbsolutePath )++-- | Instantiate a 'DarcsOptDescr' with an 'AbsolutePath'+optDescr :: AbsolutePath -> DarcsOptDescr f -> OptDescr f+optDescr path = fmap ($ path) . getCompose++type Config = [Flag]
+ src/Darcs/UI/Options/All.hs view
@@ -0,0 +1,1309 @@+{- | All the concrete options.++Notes:++  * The term \"option\" refers to a flag or combination of flags that+    together form a part of a command's configuration. Ideally, options+    should be orthogonal to each other, so we can freely combine them.++  * A primitive (indivisible) option has an associate value type.++  * An option named \"xyzActions\" represents a set of flags that act as+    mutually exclusive sub-commands. They typically have a dedicated value+    type named \"XyzAction\".++  * This module is probably best imported qualified. This is in contrast to+    the current practice of using subtly differing names to avoid name+    clashes for closely related items. For instance, the data constructors+    for an option's value type and the corresponding data constructors in+    'F.DarcsFlag' may coincide. This is also why we import "Darcs.UI.Flags"+    qualified here.++  * When the new options system is finally in place, no code other than the+    one for constructing options should directly refer to 'F.DarcsFlag'+    constructors.++-}+module Darcs.UI.Options.All+    ( DarcsOption++    -- conversion to 'Bool'+    , YesNo (..)++    -- root+    , RootAction (..)+    , rootActions++    -- all commands+    , StdCmdAction (..)+    , stdCmdActions+    , debug+    , Verbosity (..) -- re-export+    , verbosity+    , timings+    , debugging+    , HooksConfig (..)+    , HookConfig (..)+    , preHook+    , postHook+    , hooks+    , UseCache (..) -- re-export+    , useCache++    -- interactivity+    , XmlOutput (..)+    , xmlOutput+    , DryRun (..) -- re-export+    , dryRun+    , dryRunXml+    , interactive+    , pipe+    , WantGuiPause (..) -- re-export+    , pauseForGui+    , askDeps++    -- patch selection+    , module Darcs.UI.Options.Matching -- re-export+    , SelectDeps (..)+    , selectDeps+    , changesReverse+    , maxCount++    -- local or remote repo(s)+    , repoDir+    , possiblyRemoteRepo+    , newRepo+    , NotInRemote (..)+    , notInRemote+    , notInRemoteFlagName+    , RepoCombinator (..)+    , repoCombinator+    , allowUnrelatedRepos+    , justThisRepo+    , WithWorkingDir (..) -- re-export+    , withWorkingDir+    , SetDefault (..) -- re-export+    , setDefault+    , InheritDefault (..) -- re-export+    , inheritDefault+    , WithPrefsTemplates (..) -- re-export+    , withPrefsTemplates++    -- patch meta-data+    , patchname+    , author+    , AskLongComment (..)+    , askLongComment+    , keepDate+    , Logfile (..)+    , logfile++    -- looking for changes+    , UseIndex (..) -- re-export+    , includeBoring+    , LookForAdds (..) -- re-export+    , LookForMoves (..) -- re-export+    , LookForReplaces (..) -- re-export+    , DiffOpts (..)+    , lookforadds+    , maybelookforadds+    , lookforreplaces+    , lookformoves++    -- files to consider+    , allowProblematicFilenames+    , allowCaseDifferingFilenames+    , allowWindowsReservedFilenames+    , onlyToFiles+    , useIndex+    , recursive++    -- differences+    , DiffAlgorithm (..) -- re-export+    , diffAlgorithm+    , WithContext (..)+    , withContext+    , ExternalDiff (..)+    , extDiff++    -- tests+    , TestChanges (..)+    , testChanges+    , RunTest (..) -- re-export+    , LeaveTestDir (..) -- re-export+    , leaveTestDir++    -- mail related+    , HeaderFields (..)+    , headerFields+    , sendToContext+    , mail+    , sendmailCmd+    , charset+    , editDescription++    -- patch bundles+    , applyAs+    , Sign (..)+    , sign+    , Verify (..)+    , verify++    -- merging patches+    , AllowConflicts (..) -- re-export+    , conflictsNo+    , conflictsYes+    , ResolveConflicts (..) -- re-export+    , reorder+    , reorderPush++    -- optimizations+    , Compression (..)+    , compress+    , usePacks+    , WithPatchIndex (..) -- re-export+    , patchIndexNo+    , patchIndexYes+    , Reorder (..) -- re-export+    , minimize+    , storeInMemory+    , OptimizeDeep (..)+    , optimizeDeep++    -- miscellaneous+    , Output (..)+    , output+    , WithSummary (..)+    , withSummary+    , maybeSummary+    , RemoteDarcs (..) -- re-export+    , remoteDarcs+    , UMask (..) -- re-export+    , umask+    , SetScriptsExecutable (..) -- re-export+    , setScriptsExecutable++    -- command specific++    -- amend+    , amendUnrecord+    , selectAuthor++    -- annotate+    , machineReadable++    -- clone+    , CloneKind (..)+    , cloneKind++    -- dist+    , distname+    , distzip++    -- convert import/export, init+    , marks+    , readMarks+    , writeMarks+    , PatchFormat (..)+    , patchFormat+    , hashed++    -- log+    , ChangesFormat (..)+    , changesFormat++    -- replace+    , tokens+    , forceReplace++    -- test+    , TestStrategy (..)+    , testStrategy+    , ShrinkFailure (..)+    , shrinkFailure++    -- show files/index+    , files+    , directories+    , pending+    , nullFlag++    -- show repo+    , EnumPatches (..)+    , enumPatches++    -- gzcrcs+    , GzcrcsAction (..)+    , gzcrcsActions++    -- optimize+    , siblings+    ) where++import Darcs.Prelude++import Darcs.Repository.Flags+    ( RemoteDarcs (..)+    , Reorder (..)+    , Verbosity (..)+    , UseCache (..)+    , UMask (..)+    , DryRun (..)+    , LookForAdds (..)+    , LookForMoves (..)+    , LookForReplaces (..)+    , DiffAlgorithm (..)+    , DiffOpts (..)+    , RunTest (..)+    , SetScriptsExecutable (..)+    , LeaveTestDir (..)+    , SetDefault (..)+    , InheritDefault (..)+    , UseIndex (..)+    , CloneKind (..)+    , AllowConflicts (..)+    , ResolveConflicts (..)+    , WantGuiPause (..)+    , WithPatchIndex (..)+    , WithWorkingDir (..)+    , PatchFormat (..)+    , WithPrefsTemplates(..)+    , OptimizeDeep(..)+    )++import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) )+import Darcs.UI.Options.Core+import Darcs.UI.Options.Iso+import Darcs.UI.Options.Util+import Darcs.UI.Options.Matching++-- * Type instantiations++-- | 'DarcsOption' instantiates the first two type parameters of 'OptSpec' to+-- what we need in darcs.+type DarcsOption = OptSpec DarcsOptDescr Flag++type RawDarcsOption = forall v. v -> RawOptSpec Flag v++-- * Conversion to 'Bool'++class YesNo a where+  yes :: a -> Bool+  no :: a -> Bool+  no = not . yes++instance YesNo Compression where+  yes NoCompression = False+  yes GzipCompression = True++instance YesNo WithPatchIndex where+  yes NoPatchIndex = False+  yes YesPatchIndex = True++instance YesNo Reorder where+  yes NoReorder = False+  yes Reorder = True++instance YesNo UseCache where+  yes NoUseCache = False+  yes YesUseCache = True++instance YesNo DryRun where+  yes NoDryRun = False+  yes YesDryRun = True++instance YesNo LookForAdds where+  yes NoLookForAdds = False+  yes YesLookForAdds = True+  yes EvenLookForBoring = True++instance YesNo LookForReplaces where+  yes NoLookForReplaces = False+  yes YesLookForReplaces = True++instance YesNo LookForMoves where+  yes NoLookForMoves = False+  yes YesLookForMoves = True++instance YesNo RunTest where+  yes NoRunTest = False+  yes YesRunTest = True++instance YesNo SetScriptsExecutable where+  yes NoSetScriptsExecutable = False+  yes YesSetScriptsExecutable = True++instance YesNo LeaveTestDir where+  yes NoLeaveTestDir = False+  yes YesLeaveTestDir = True++instance YesNo UseIndex where+  yes IgnoreIndex = False+  yes UseIndex = True++instance YesNo WantGuiPause where+  yes NoWantGuiPause = False+  yes YesWantGuiPause = True++instance YesNo WithWorkingDir where+  yes NoWorkingDir = False+  yes WithWorkingDir = True++data EnumPatches = NoEnumPatches | YesEnumPatches deriving (Eq, Show)++instance YesNo EnumPatches where+  yes NoEnumPatches = False+  yes YesEnumPatches = True++instance YesNo InheritDefault where+  yes NoInheritDefault = False+  yes YesInheritDefault = True++instance YesNo WithPrefsTemplates where+  yes NoPrefsTemplates = False+  yes WithPrefsTemplates = True++-- * Root command++-- | Options for darcs iself that act like sub-commands.+data RootAction = RootHelp | Version | ExactVersion | ListCommands deriving (Eq, Show)++rootActions :: PrimDarcsOption (Maybe RootAction)+rootActions = withDefault Nothing+  [ RawNoArg ['h'] ["help"] F.Help (Just RootHelp)+    "show a brief description of all darcs commands and top-level options"+  , RawNoArg ['v','V'] ["version"] F.Version  (Just Version) "show the darcs version"+  , RawNoArg [] ["exact-version"] F.ExactVersion (Just ExactVersion)+    "show the exact darcs version"+    -- the switch --commands is here for compatibility only+  , RawNoArg [] ["commands"] F.ListCommands (Just ListCommands)+    "show plain list of available options and commands, for auto-completion"+  ]++-- * Common to all commands++-- ** Standard command actions++data StdCmdAction = Help | ListOptions | Disable deriving (Eq, Show)++stdCmdActions :: PrimDarcsOption (Maybe StdCmdAction)+stdCmdActions = withDefault Nothing+  [ RawNoArg [] ["help"] F.Help (Just Help)+    "show a description of the command and its options"+  , RawNoArg [] ["list-options"] F.ListOptions (Just ListOptions)+    "show plain list of available options and commands, for auto-completion"+  , RawNoArg [] ["disable"] F.Disable (Just Disable) "disable this command" ]++-- ** Verbosity related++debug :: PrimDarcsOption Bool+debug = singleNoArg [] ["debug"] F.Debug "enable general debug output"++verbosity :: PrimDarcsOption Verbosity+verbosity = withDefault NormalVerbosity+  [ RawNoArg ['q'] ["quiet"] F.Quiet Quiet "suppress informational output"+  , RawNoArg [] ["standard-verbosity"] F.NormalVerbosity NormalVerbosity+      "neither verbose nor quiet output"+  , RawNoArg ['v'] ["verbose"] F.Verbose Verbose "enable verbose output" ]++timings :: PrimDarcsOption Bool+timings = singleNoArg [] ["timings"] F.Timings "provide debugging timings information"++debugging :: DarcsOption a (Bool -> Bool -> a)+debugging = debug ^ timings++-- ** Hooks++data HooksConfig = HooksConfig+  { pre :: HookConfig+  , post :: HookConfig+  }++data HookConfig = HookConfig+  { cmd :: Maybe String+  , prompt :: Bool+  }++hooks :: DarcsOption a (HooksConfig -> a)+hooks = imap (Iso fw bw) $ preHook ^ postHook where+  fw k (HooksConfig pr po) = k pr po+  bw k pr po = k (HooksConfig pr po)++hookIso :: Iso (Maybe String -> Bool -> a) (HookConfig -> a)+hookIso = (Iso fw bw) where+    fw k (HookConfig c p) = k c p+    bw k c p = k (HookConfig c p)++preHook :: DarcsOption a (HookConfig -> a)+preHook = imap hookIso $ prehookCmd ^ hookPrompt "prehook" F.AskPrehook F.RunPrehook++postHook :: DarcsOption a (HookConfig -> a)+postHook = imap hookIso $ posthookCmd ^ hookPrompt "posthook" F.AskPosthook F.RunPosthook++prehookCmd :: PrimDarcsOption (Maybe String)+prehookCmd = withDefault Nothing+    [ RawStrArg [] ["prehook"] F.PrehookCmd unF Just unV+      "COMMAND" "specify command to run before this darcs command"+    , RawNoArg [] ["no-prehook"] F.NoPrehook Nothing+      "don't run prehook command" ]+  where unF f = [ s | F.PrehookCmd s <- [f] ]+        unV v = [ s | Just s <- [v] ]++posthookCmd :: PrimDarcsOption (Maybe String)+posthookCmd = withDefault Nothing+    [ RawStrArg [] ["posthook"] F.PosthookCmd unF Just unV "COMMAND"+      "specify command to run after this darcs command"+    , RawNoArg [] ["no-posthook"] F.NoPosthook Nothing+      "don't run posthook command" ]+  where unF f = [ s | F.PosthookCmd s <- [f] ]+        unV v = [ s | Just s <- [v] ]++hookPrompt :: String -> Flag -> Flag -> PrimDarcsOption Bool+hookPrompt name fask frun = withDefault False+  [ RawNoArg [] ["prompt-"++name] fask True+    ("prompt before running "++name)+  , RawNoArg [] ["run-"++name] frun False+    ("run "++name++" command without prompting") ]++-- ** Misc++useCache :: PrimDarcsOption UseCache+useCache = (imap . cps) (Iso fw bw) $ singleNoArg [] ["no-cache"] F.NoCache "don't use patch caches"+  where+    fw True = NoUseCache+    fw False = YesUseCache+    bw NoUseCache = True+    bw YesUseCache = False++-- * Interactivity related++{- TODO: These options interact (no pun intended) in complex ways that are+very hard to figure out for users as well as maintainers. I think the only+solution here is a more radical (and probably incompatible) re-design+involving all interactivity related options. -}++data XmlOutput = NoXml | YesXml deriving (Eq, Show)++instance YesNo XmlOutput where+  yes NoXml = False+  yes YesXml = True++xmlOutput :: PrimDarcsOption XmlOutput+xmlOutput = withDefault NoXml [__xmloutput YesXml]++__xmloutput :: RawDarcsOption+__xmloutput val = RawNoArg [] ["xml-output"] F.XMLOutput val "generate XML formatted output"++-- | TODO someone wrote here long ago that any time --dry-run is a possibility+-- automated users should be able to examine the results more+-- easily with --xml. See also issue2397.+-- dryRun w/o xml is currently used in add, pull, and repair.++dryRun :: PrimDarcsOption DryRun+dryRun = withDefault NoDryRun+  [ RawNoArg ['n'] ["dry-run"] F.DryRun YesDryRun "don't actually take the action" ]++dryRunXml :: DarcsOption a (DryRun -> XmlOutput -> a)+dryRunXml = dryRun ^ xmlOutput++pipe :: PrimDarcsOption Bool+pipe = singleNoArg [] ["pipe"] F.Pipe "ask user interactively for the patch metadata"++interactive :: PrimDarcsOption (Maybe Bool)+interactive = withDefault Nothing+  [ RawNoArg ['a'] ["all","no-interactive"] F.All (Just False) "answer yes to all patches"+  , RawNoArg ['i'] ["interactive"] F.Interactive (Just True) "prompt user interactively" ]++pauseForGui :: PrimDarcsOption WantGuiPause+pauseForGui = withDefault YesWantGuiPause+  [ RawNoArg [] ["pause-for-gui"] F.PauseForGui YesWantGuiPause+    "pause for an external diff or merge command to finish"+  , RawNoArg [] ["no-pause-for-gui"] F.NoPauseForGui NoWantGuiPause+    "return immediately after external diff or merge command finishes" ]++askDeps :: PrimDarcsOption Bool+askDeps = withDefault False+  [ RawNoArg [] ["ask-deps"] F.AskDeps True "manually select dependencies"+  , RawNoArg [] ["no-ask-deps"] F.NoAskDeps False "automatically select dependencies" ]++-- * Patch selection related++data SelectDeps = NoDeps | AutoDeps | PromptDeps deriving (Eq, Show)++selectDeps :: PrimDarcsOption SelectDeps+selectDeps = withDefault PromptDeps+  [ RawNoArg [] ["no-deps"] F.DontGrabDeps NoDeps+    "don't automatically fulfill dependencies"+  , RawNoArg [] ["auto-deps","dont-prompt-for-dependencies"] F.DontPromptForDependencies AutoDeps+    "don't ask about patches that are depended on by matched patches (with --match or --patch)"+  , RawNoArg [] ["prompt-deps","prompt-for-dependencies"] F.PromptForDependencies PromptDeps+    "prompt about patches that are depended on by matched patches" ]++changesReverse :: PrimDarcsOption Bool+changesReverse = withDefault False+  [ RawNoArg [] ["reverse"] F.Reverse True "show/consider changes in reverse order"+  , RawNoArg [] ["no-reverse"] F.Forward False "show/consider changes in the usual order" ]++maxCount :: PrimDarcsOption (Maybe Int)+maxCount = withDefault Nothing+  [ RawStrArg [] ["max-count"] F.MaxCount unF toV unV "NUMBER" "return only NUMBER results" ]+  where+    unF f = [ s | F.MaxCount s <- [f] ]+    unV x = [ showIntArg n | Just n <- [x] ]+    toV = Just . parseIntArg "count" (>=0)++-- * Local or remote repo++repoDir :: PrimDarcsOption (Maybe String)+repoDir = singleStrArg [] ["repodir"] F.WorkRepoDir arg "DIRECTORY"+    "specify the repository directory in which to run"+  where arg (F.WorkRepoDir s) = Just s+        arg _ = Nothing++-- | This option is for when a new repo gets created. Used for clone, convert+-- import, convert darcs-2, and initialize. For clone and initialize it has the+-- same effect as giving the name as a normal argument.+--+-- The @--repodir@ alias is there for compatibility, should be removed eventually.+--+-- TODO We need a way to deprecate options / option names.+newRepo :: PrimDarcsOption (Maybe String)+newRepo = singleStrArg [] ["repo-name","repodir"] F.NewRepo arg "DIRECTORY" "path of output directory"+  where arg (F.NewRepo s) = Just s; arg _ = Nothing++possiblyRemoteRepo :: PrimDarcsOption (Maybe String)+possiblyRemoteRepo = singleStrArg [] ["repo"] F.WorkRepoUrl arg "URL"+    "specify the repository URL"+  where arg (F.WorkRepoUrl s) = Just s+        arg _ = Nothing++notInRemoteFlagName :: String+notInRemoteFlagName = "not-in-remote"++data NotInRemote+  = NotInDefaultRepo+  | NotInRemotePath String++notInRemote :: PrimDarcsOption [NotInRemote]+notInRemote = (imap . cps) (Iso (map fw) (map bw)) $+    multiOptStrArg [] [notInRemoteFlagName] F.NotInRemote args "URL/PATH" $+        "select all patches not in the default push/pull repository or at "+        ++ "location URL/PATH"+  where+    args fs = [s | F.NotInRemote s <- fs]+    fw (Just s) = NotInRemotePath s+    fw Nothing = NotInDefaultRepo+    bw (NotInRemotePath s) = Just s+    bw NotInDefaultRepo = Nothing++data RepoCombinator = Intersection | Union | Complement deriving (Eq, Show)++repoCombinator :: PrimDarcsOption RepoCombinator+repoCombinator = withDefault Union+  [ RawNoArg [] ["intersection"] F.Intersection Intersection+    "take intersection of all repositories"+  , RawNoArg [] ["union"] F.Union Union+    "take union of all repositories"+  , RawNoArg [] ["complement"] F.Complement Complement+    "take complement of repositories (in order listed)" ]++allowUnrelatedRepos :: PrimDarcsOption Bool+allowUnrelatedRepos = singleNoArg [] ["ignore-unrelated-repos"] F.AllowUnrelatedRepos+  "do not check if repositories are unrelated"++justThisRepo :: PrimDarcsOption Bool+justThisRepo = singleNoArg [] ["just-this-repo"] F.JustThisRepo+  "Limit the check or repair to the current repo"++-- | convert, clone, init+withWorkingDir :: PrimDarcsOption WithWorkingDir+withWorkingDir = withDefault WithWorkingDir+  [ RawNoArg [] ["with-working-dir"] F.UseWorkingDir WithWorkingDir+    "Create a working tree (normal repository)"+  , RawNoArg [] ["no-working-dir"] F.UseNoWorkingDir NoWorkingDir+    "Do not create a working tree (bare repository)" ]++setDefault :: PrimDarcsOption (Maybe Bool)+setDefault = withDefault Nothing+  [ RawNoArg [] ["set-default"] F.SetDefault (Just True) "set default repository"+  , RawNoArg [] ["no-set-default"] F.NoSetDefault (Just False) "don't set default repository" ]++inheritDefault :: PrimDarcsOption InheritDefault+inheritDefault = withDefault NoInheritDefault+  [ RawNoArg [] ["inherit-default"] F.InheritDefault YesInheritDefault "inherit default repository"+  , RawNoArg [] ["no-inherit-default"] F.NoInheritDefault NoInheritDefault "don't inherit default repository" ]++withPrefsTemplates :: PrimDarcsOption WithPrefsTemplates+withPrefsTemplates = withDefault WithPrefsTemplates+  [ RawNoArg [] ["with-prefs-templates"] F.WithPrefsTemplates WithPrefsTemplates "create template-filled preferences"+  , RawNoArg [] ["no-prefs-templates"] F.NoPrefsTemplates NoPrefsTemplates "create empty preferences"+  ]++-- * Specifying patch meta-data++patchname :: PrimDarcsOption (Maybe String)+patchname = singleStrArg ['m'] ["name"] F.PatchName arg "PATCHNAME"+    "name of patch"+  where arg (F.PatchName s) = Just s+        arg _ = Nothing++author :: PrimDarcsOption (Maybe String)+author = singleStrArg ['A'] ["author"] F.Author arg+    "EMAIL" "specify author id"+  where arg (F.Author s) = Just s+        arg _ = Nothing++data AskLongComment = NoEditLongComment | YesEditLongComment | PromptLongComment+  deriving (Eq, Show)++askLongComment :: PrimDarcsOption (Maybe AskLongComment)+askLongComment = withDefault Nothing+  [ RawNoArg [] ["edit-long-comment"] F.EditLongComment (Just YesEditLongComment)+    "edit the long comment by default"+  , RawNoArg [] ["skip-long-comment"] F.NoEditLongComment (Just NoEditLongComment)+    "don't give a long comment"+  , RawNoArg [] ["prompt-long-comment"] F.PromptLongComment (Just PromptLongComment)+    "prompt for whether to edit the long comment" ]++keepDate :: PrimDarcsOption Bool+keepDate = withDefault False+  [ RawNoArg [] ["keep-date"] F.KeepDate True+   "keep the date of the original patch"+  , RawNoArg [] ["no-keep-date"] F.NoKeepDate False+   "use the current date for the amended patch" ]++-- record, send+data Logfile = Logfile+  { _logfile :: Maybe AbsolutePath+  , _rmlogfile :: Bool+  }++logfile :: PrimDarcsOption Logfile+logfile = imap (Iso fw bw) (__logfile ^ __rmlogfile) where+  fw k (Logfile x y) = k x y+  bw k x y = k (Logfile x y)++__logfile :: PrimDarcsOption (Maybe AbsolutePath)+__logfile = singleAbsPathArg [] ["logfile"] F.LogFile arg "FILE"+    "give patch name and comment in file"+  where arg (F.LogFile s) = Just s+        arg _ = Nothing++__rmlogfile :: PrimDarcsOption Bool+__rmlogfile = withDefault False+  [ RawNoArg [] ["delete-logfile"] F.RmLogFile True+    "delete the logfile when done"+  , RawNoArg [] ["no-delete-logfile"] F.DontRmLogFile False+    "keep the logfile when done" ]++-- * Looking for changes++lookforadds :: PrimDarcsOption LookForAdds+lookforadds = maybelookforadds NoLookForAdds++maybelookforadds :: LookForAdds -> PrimDarcsOption LookForAdds+maybelookforadds def = withDefault def+  [ RawNoArg [] ["dont-look-for-adds","no-look-for-adds"] F.NoLookForAdds NoLookForAdds+    "don't look for files that could be added"+  , RawNoArg ['l'] ["look-for-adds"] F.LookForAdds YesLookForAdds+    "look for files that could be added"+  , RawNoArg [] ["boring"] F.Boring EvenLookForBoring+    "look for any file that could be added, even boring files" ]++lookforreplaces :: PrimDarcsOption LookForReplaces+lookforreplaces = withDefault NoLookForReplaces+  [ RawNoArg [] ["look-for-replaces"] F.LookForReplaces YesLookForReplaces+    "look for replaces that could be marked"+  , RawNoArg [] ["dont-look-for-replaces","no-look-for-replaces"]+    F.NoLookForReplaces NoLookForReplaces+    "don't look for any replaces" ]++lookformoves :: PrimDarcsOption LookForMoves+lookformoves = withDefault NoLookForMoves+  [ RawNoArg [] ["look-for-moves"] F.LookForMoves YesLookForMoves+   "look for files that may be moved/renamed"+  , RawNoArg [] ["dont-look-for-moves","no-look-for-moves"]+    F.NoLookForMoves NoLookForMoves+   "don't look for any files that could be moved/renamed" ]++-- * Files to consider++useIndex :: PrimDarcsOption UseIndex+useIndex = (imap . cps) (Iso fw bw) ignoreTimes where+  fw False = UseIndex+  fw True = IgnoreIndex+  bw UseIndex = False+  bw IgnoreIndex = True++includeBoring :: PrimDarcsOption Bool+includeBoring = withDefault False+  [ RawNoArg [] ["boring"] F.Boring True "don't skip boring files"+  , RawNoArg [] ["no-boring"] F.SkipBoring False "skip boring files" ]++allowProblematicFilenames :: DarcsOption a (Bool -> Bool -> a)+allowProblematicFilenames = allowCaseDifferingFilenames ^ allowWindowsReservedFilenames++allowCaseDifferingFilenames :: PrimDarcsOption Bool+allowCaseDifferingFilenames = withDefault False+  [ RawNoArg [] ["case-ok"] F.AllowCaseOnly True+    "don't refuse to add files differing only in case"+  , RawNoArg [] ["no-case-ok"] F.DontAllowCaseOnly False+    "refuse to add files whose name differ only in case" ]++allowWindowsReservedFilenames :: PrimDarcsOption Bool+allowWindowsReservedFilenames = withDefault False+  [ RawNoArg [] ["reserved-ok"] F.AllowWindowsReserved True+    "don't refuse to add files with Windows-reserved names"+  , RawNoArg [] ["no-reserved-ok"] F.DontAllowWindowsReserved False+    "refuse to add files with Windows-reserved names" ]++-- | TODO: see issue2395+onlyToFiles :: PrimDarcsOption Bool+onlyToFiles = withDefault False+  [ RawNoArg [] ["only-to-files"] F.OnlyChangesToFiles True+    "show only changes to specified files"+  , RawNoArg [] ["no-only-to-files"] F.ChangesToAllFiles False+    "show changes to all files" ]++ignoreTimes :: PrimDarcsOption Bool+ignoreTimes = withDefault False+  [ RawNoArg [] ["ignore-times"] F.IgnoreTimes True+    "don't trust the file modification times"+  , RawNoArg [] ["no-ignore-times"] F.DontIgnoreTimes False+    "trust modification times to find modified files" ]++recursive :: PrimDarcsOption Bool+recursive = withDefault False+  [ RawNoArg ['r'] ["recursive"] F.Recursive True "recurse into subdirectories"+  , RawNoArg [] ["not-recursive","no-recursive"] F.NoRecursive False ("don't recurse into subdirectories") ]++-- * Differences++diffAlgorithm :: PrimDarcsOption DiffAlgorithm+diffAlgorithm = withDefault PatienceDiff+  [ RawNoArg [] ["myers"] F.UseMyersDiff MyersDiff+    "use myers diff algorithm"+  , RawNoArg [] ["patience"] F.UsePatienceDiff PatienceDiff+    "use patience diff algorithm" ]++data WithContext = NoContext | YesContext deriving (Eq, Show)++instance YesNo WithContext where+  yes NoContext = False+  yes YesContext = True++withContext :: PrimDarcsOption WithContext+withContext = (imap . cps) (Iso fw bw) $ withDefault False+  [ RawNoArg ['u'] ["unified"] F.Unified True+    "output changes in a darcs-specific format similar to diff -u"+  , RawNoArg  [] ["no-unified"] F.NonUnified False+    "output changes in darcs' usual format" ]+  where fw False = NoContext+        fw True = YesContext+        bw NoContext = False+        bw YesContext = True++data ExternalDiff = ExternalDiff+  { diffCmd :: Maybe String+  , diffOptions :: [String]+  , diffUnified :: Bool+  } deriving (Eq, Show)++extDiff :: PrimDarcsOption ExternalDiff+extDiff = imap (Iso fw bw) $ __extDiffCmd ^ __extDiffOpts ^ __unidiff where+  fw k (ExternalDiff cmd opts uni) = k cmd opts uni+  bw k cmd opts uni = k (ExternalDiff cmd opts uni)++__extDiffCmd :: PrimDarcsOption (Maybe String)+__extDiffCmd = singleStrArg [] ["diff-command"] F.DiffCmd arg "COMMAND"+    "specify diff command (ignores --diff-opts)"+  where arg (F.DiffCmd s) = Just s+        arg _ = Nothing++__extDiffOpts :: PrimDarcsOption [String]+__extDiffOpts = multiStrArg [] ["diff-opts"] F.DiffFlags mkV "OPTIONS"+    "options to pass to diff"+  where mkV fs = [ s | F.DiffFlags s <- fs ]++__unidiff :: PrimDarcsOption Bool+__unidiff = withDefault True+  [ RawNoArg ['u'] ["unified"] F.Unified True "pass -u option to diff"+  , RawNoArg  [] ["no-unified"] F.NonUnified False "output patch in diff's dumb format" ]++-- * Running tests++data TestChanges = NoTestChanges | YesTestChanges LeaveTestDir deriving (Eq)++testChanges :: PrimDarcsOption TestChanges+testChanges = imap (Iso fw bw) $ __runTest ^ leaveTestDir where+  fw k NoTestChanges = k NoRunTest NoLeaveTestDir+  fw k (YesTestChanges ltd) = k YesRunTest ltd+  bw k NoRunTest _ = k NoTestChanges+  bw k YesRunTest ltd = k (YesTestChanges ltd)++__runTest :: PrimDarcsOption RunTest+__runTest = withDefault NoRunTest+  [ RawNoArg [] ["test"] F.Test YesRunTest "run the test script"+  , RawNoArg [] ["no-test"] F.NoTest NoRunTest "don't run the test script" ]++leaveTestDir :: PrimDarcsOption LeaveTestDir+leaveTestDir = withDefault NoLeaveTestDir+  [ RawNoArg [] ["leave-test-directory"]+    F.LeaveTestDir YesLeaveTestDir "don't remove the test directory"+  , RawNoArg [] ["remove-test-directory"]+    F.NoLeaveTestDir NoLeaveTestDir "remove the test directory" ]++-- * Mail related++data HeaderFields = HeaderFields+  { _to, _cc :: [String]+  , _from, _subject, _inReplyTo :: Maybe String+  }++headerFields :: PrimDarcsOption HeaderFields+headerFields = imap (Iso fw bw) $ to ^ cc ^ from ^ subject ^ inReplyTo where+  fw k (HeaderFields t f c s i) = k t f c s i+  bw k t f c s i = k (HeaderFields t f c s i)++from :: PrimDarcsOption (Maybe String)+from = singleStrArg [] ["from"] F.Author arg+    "EMAIL" "specify email address"+  where arg (F.Author s) = Just s+        arg _ = Nothing++to :: PrimDarcsOption [String]+to = multiStrArg [] ["to"] F.To mkV "EMAIL" "specify destination email"+  where mkV fs = [ s | F.To s <- fs ]++cc :: PrimDarcsOption [String]+cc = multiStrArg [] ["cc"] F.Cc mkV "EMAIL" "mail results to additional EMAIL(s)"+  where mkV fs = [ s | F.Cc s <- fs ]++subject :: PrimDarcsOption (Maybe String)+subject = singleStrArg [] ["subject"] F.Subject arg+    "SUBJECT" "specify mail subject"+  where arg (F.Subject s) = Just s+        arg _ = Nothing++inReplyTo :: PrimDarcsOption (Maybe String)+inReplyTo = singleStrArg [] ["in-reply-to"] F.InReplyTo arg+    "EMAIL" "specify in-reply-to header"+  where arg (F.InReplyTo s) = Just s+        arg _ = Nothing++sendToContext :: PrimDarcsOption (Maybe AbsolutePath)+sendToContext = singleAbsPathArg [] ["context"] F.Context arg "FILENAME"+    "send to context stored in FILENAME"+  where arg (F.Context s) = Just s+        arg _ = Nothing++mail :: PrimDarcsOption Bool+mail = singleNoArg [] ["mail"] F.Mail "send patch using sendmail"++sendmailCmd :: PrimDarcsOption (Maybe String)+sendmailCmd = singleStrArg [] ["sendmail-command"] F.SendmailCmd arg "COMMAND"+    "specify sendmail command"+  where arg (F.SendmailCmd s) = Just s+        arg _ = Nothing++minimize :: PrimDarcsOption Bool+minimize = withDefault True+  [ RawNoArg [] ["minimize"] F.Minimize True "minimize context of patch bundle"+  , RawNoArg [] ["no-minimize"] F.NoMinimize False ("don't minimize context of patch bundle") ]++charset :: PrimDarcsOption (Maybe String)+charset = singleStrArg [] ["charset"] F.Charset arg+    "CHARSET" "specify mail charset"+  where arg (F.Charset s) = Just s+        arg _ = Nothing++editDescription :: PrimDarcsOption Bool+editDescription = withDefault True+  [ RawNoArg [] ["edit-description"] F.EditDescription True+    "edit the patch bundle description"+  , RawNoArg [] ["dont-edit-description","no-edit-description"] F.NoEditDescription False+    "don't edit the patch bundle description" ]++-- * Patch bundle related++applyAs :: PrimDarcsOption (Maybe String)+applyAs = withDefault Nothing+  [ RawStrArg [] ["apply-as"] F.ApplyAs unF Just unV "USERNAME"+    "apply patch as another user using sudo"+  , RawNoArg [] ["no-apply-as"] F.NonApply Nothing+    "don't use sudo to apply as another user" ]+  where+    unF f = [ s | F.ApplyAs s <- [f] ]+    unV x = [ s | Just s <- [x] ]++data Sign = NoSign | Sign | SignAs String | SignSSL String deriving (Eq, Show)++sign :: PrimDarcsOption Sign+sign = withDefault NoSign+  [ RawNoArg [] ["sign"] F.Sign Sign "sign the patch with your gpg key"+  , RawStrArg [] ["sign-as"] F.SignAs unFSignAs SignAs unSignAs "KEYID"+    "sign the patch with a given keyid"+  , RawStrArg [] ["sign-ssl"] F.SignSSL  unFSignSSL SignSSL unSignSSL "IDFILE"+    "sign the patch using openssl with a given private key"+  , RawNoArg [] ["dont-sign","no-sign"] F.NoSign NoSign "don't sign the patch" ]+  where unFSignAs f = [ s | F.SignAs s <- [f] ]+        unSignAs v = [ s | SignAs s <- [v] ]+        unFSignSSL f = [ s | F.SignSSL s <- [f] ]+        unSignSSL v = [ s | SignSSL s <- [v] ]++data Verify = NoVerify | VerifyKeyring AbsolutePath | VerifySSL AbsolutePath deriving (Eq, Show)++verify :: PrimDarcsOption Verify+verify = withDefault NoVerify+  [ RawAbsPathArg [] ["verify"] F.Verify unFKeyring VerifyKeyring unVKeyring "PUBRING"+    "verify that the patch was signed by a key in PUBRING"+  , RawAbsPathArg [] ["verify-ssl"] F.VerifySSL unFSSL VerifySSL unVSSL "KEYS"+    "verify using openSSL with authorized keys from file KEYS"+  , RawNoArg [] ["no-verify"] F.NonVerify NoVerify+    "don't verify patch signature" ]+  where+    unFKeyring f = [ s | F.Verify s <- [f] ]+    unVKeyring x = [ s | VerifyKeyring s <- [x] ]+    unFSSL f = [ s | F.VerifySSL s <- [f] ]+    unVSSL x = [ s | VerifySSL s <- [x] ]++-- * Merging patches++-- | push, apply, rebase apply: default to 'NoAllowConflicts'+conflictsNo :: PrimDarcsOption (Maybe AllowConflicts)+conflictsNo = conflicts NoAllowConflicts++-- | pull, rebase pull: default to 'YesAllowConflicts' 'MarkConflicts'+conflictsYes :: PrimDarcsOption (Maybe AllowConflicts)+conflictsYes = conflicts (YesAllowConflicts MarkConflicts)++conflicts :: AllowConflicts -> PrimDarcsOption (Maybe AllowConflicts)+conflicts def = withDefault (Just def)+  [ RawNoArg [] ["mark-conflicts"]+      F.MarkConflicts (Just (YesAllowConflicts MarkConflicts)) "mark conflicts"+  , RawNoArg [] ["allow-conflicts"]+      F.AllowConflicts (Just (YesAllowConflicts NoResolveConflicts))+      "allow conflicts, but don't mark them"+  , RawStrArg [] ["external-merge"]+    F.ExternalMerge (\f -> [s | F.ExternalMerge s <- [f]])+    (Just . YesAllowConflicts . ExternalMerge)+    (\v -> [s | Just (YesAllowConflicts (ExternalMerge s)) <- [v]])+    "COMMAND" "use external tool to merge conflicts"+  , RawNoArg [] ["dont-allow-conflicts","no-allow-conflicts","no-resolve-conflicts"]+      F.NoAllowConflicts (Just NoAllowConflicts) "fail if there are patches that would create conflicts"+  , RawNoArg [] ["skip-conflicts"]+      F.SkipConflicts Nothing "filter out any patches that would create conflicts" ]++-- | pull, apply, rebase pull, rebase apply+reorder :: PrimDarcsOption Reorder+reorder = withDefault NoReorder+  [ RawNoArg [] ["reorder-patches"] F.Reorder Reorder+    "put local-only patches on top of remote ones"+  , RawNoArg [] ["no-reorder-patches"] F.NoReorder NoReorder+    "put remote-only patches on top of local ones" ]++-- | push; same as 'reorder' but with help descriptions swapped+reorderPush :: PrimDarcsOption Reorder+reorderPush = withDefault NoReorder+  [ RawNoArg [] ["reorder-patches"] F.Reorder Reorder+    "put remote-only patches on top of local ones"+  , RawNoArg [] ["no-reorder-patches"] F.NoReorder NoReorder+    "put local-only patches on top of remote ones" ]++-- * Optimizations++data Compression = NoCompression | GzipCompression+  deriving ( Eq, Show )++-- | push+compress :: PrimDarcsOption Compression+compress = withDefault GzipCompression+  [ RawNoArg [] ["compress"] F.Compress GzipCompression "compress patch data"+  , RawNoArg [] ["dont-compress","no-compress"] F.NoCompress NoCompression "don't compress patch data" ]++usePacks :: PrimDarcsOption Bool+usePacks = withDefault True+  [ RawNoArg [] ["packs"] F.Packs True "use repository packs"+  , RawNoArg [] ["no-packs"] F.NoPacks False "don't use repository packs" ]++-- for init, clone and convert: patch index disabled by default+patchIndexNo :: PrimDarcsOption WithPatchIndex+patchIndexNo = withDefault NoPatchIndex [__patchIndex YesPatchIndex, __noPatchIndex NoPatchIndex]++-- for log and annotate: patch index enabled by default+patchIndexYes :: PrimDarcsOption WithPatchIndex+patchIndexYes = withDefault YesPatchIndex [__patchIndex YesPatchIndex, __noPatchIndex NoPatchIndex]++__patchIndex, __noPatchIndex :: RawDarcsOption+__patchIndex val = RawNoArg [] ["with-patch-index"] F.PatchIndexFlag val "build patch index"+__noPatchIndex val = RawNoArg [] ["no-patch-index"] F.NoPatchIndexFlag val "don't build patch index"++-- diff, dist+storeInMemory :: PrimDarcsOption Bool+storeInMemory = withDefault False+  [ RawNoArg [] ["store-in-memory"] F.StoreInMemory True+    "do patch application in memory rather than on disk"+  , RawNoArg [] ["no-store-in-memory"] F.ApplyOnDisk False+    "do patch application on disk" ]++optimizeDeep :: PrimDarcsOption OptimizeDeep+optimizeDeep = withDefault OptimizeShallow+  [ RawNoArg [] ["deep"] F.OptimizeDeep OptimizeDeep+    "also optimize clean tags in the complete history"+  , RawNoArg [] ["shallow"] F.OptimizeShallow OptimizeShallow+    "only reorder recent patches (works with lazy repo)" ]++-- * Output++data Output = Output AbsolutePathOrStd+            | OutputAutoName AbsolutePath+            deriving (Eq, Show)++output :: PrimDarcsOption (Maybe Output)+output = withDefault Nothing+    [ RawAbsPathOrStdArg ['o'] ["output"]+      F.Output unOutputF (Just . Output) unOutput+      "FILE" "specify output filename"+    , RawOptAbsPathArg ['O'] ["output-auto-name"]+      F.OutputAutoName unOutputAutoNameF (Just . OutputAutoName) unOutputAutoName+      "." "DIRECTORY"+      "output to automatically named file in DIRECTORY, default: current directory"+    ]+  where+    unOutputF f = [ p | F.Output p <- [f] ]+    unOutput (Just (Output p)) = [p]+    unOutput _ = []+    unOutputAutoNameF f = [ p | F.OutputAutoName p <- [f] ]+    unOutputAutoName (Just (OutputAutoName p)) = [p]+    unOutputAutoName _ = []++-- * Miscellaneous++data WithSummary = NoSummary | YesSummary deriving (Eq, Show)++instance YesNo WithSummary where+  yes NoSummary = False+  yes YesSummary = True++-- all commands except whatsnew+withSummary :: PrimDarcsOption WithSummary+withSummary = (imap . cps) (Iso fw bw) $ maybeSummary Nothing+  where+    fw Nothing = NoSummary+    fw (Just NoSummary) = NoSummary+    fw (Just YesSummary) = YesSummary+    bw NoSummary = Nothing+    bw YesSummary = Just YesSummary++-- needed for whatsnew+maybeSummary :: Maybe WithSummary -> PrimDarcsOption (Maybe WithSummary)+maybeSummary def = withDefault def+  [ RawNoArg ['s'] ["summary"] F.Summary (Just YesSummary) "summarize changes"+  , RawNoArg [] ["no-summary"] F.NoSummary (Just NoSummary) "don't summarize changes" ]++remoteDarcs :: PrimDarcsOption RemoteDarcs+remoteDarcs = imap (Iso fw bw)+  $ singleStrArg [] ["remote-darcs"] F.RemoteDarcsOpt arg "COMMAND"+    "name of the darcs executable on the remote server"+  where+    arg (F.RemoteDarcsOpt s) = Just s+    arg _ = Nothing+    fw k (RemoteDarcs y) = k (Just y)+    fw k DefaultRemoteDarcs = k Nothing+    bw k (Just y) = k (RemoteDarcs y)+    bw k Nothing = k DefaultRemoteDarcs++umask :: PrimDarcsOption UMask+umask = (imap . cps) (Iso fw bw) $ singleStrArg [] ["umask"] F.UMask arg "UMASK"+    "specify umask to use when writing"+  where+    arg (F.UMask s) = Just s+    arg _ = Nothing+    fw (Just s) = YesUMask s+    fw Nothing = NoUMask+    bw (YesUMask s) = Just s+    bw NoUMask = Nothing++setScriptsExecutable :: PrimDarcsOption SetScriptsExecutable+setScriptsExecutable = withDefault NoSetScriptsExecutable+  [ RawNoArg [] ["set-scripts-executable"] F.SetScriptsExecutable YesSetScriptsExecutable+    "make scripts executable"+  , RawNoArg [] ["dont-set-scripts-executable","no-set-scripts-executable"]+    F.DontSetScriptsExecutable NoSetScriptsExecutable "don't make scripts executable" ]++-- * Specific to a single command++-- ** amend++amendUnrecord :: PrimDarcsOption Bool+amendUnrecord = withDefault False+  [ RawNoArg [] ["unrecord"] F.AmendUnrecord True "remove changes from the patch"+  , RawNoArg [] ["record"] F.NoAmendUnrecord False "add more changes to the patch" ]++selectAuthor :: PrimDarcsOption Bool+selectAuthor = singleNoArg [] ["select-author"] F.SelectAuthor+  "select author id from a menu"++-- ** annotate++machineReadable :: PrimDarcsOption Bool+machineReadable = withDefault False+  [ __humanReadable False+  , __machineReadable True ]++__humanReadable :: RawDarcsOption+__humanReadable val = RawNoArg [] ["human-readable"] F.HumanReadable val "normal human-readable output"++__machineReadable :: RawDarcsOption+__machineReadable val = RawNoArg [] ["machine-readable"] F.MachineReadable val "machine-readable output"++-- ** clone++cloneKind :: PrimDarcsOption CloneKind+cloneKind = withDefault NormalClone+  [ RawNoArg [] ["lazy"] F.Lazy LazyClone "get patch files only as needed"+  , RawNoArg [] ["complete"] F.Complete CompleteClone "get a complete copy of the repository" ]++-- ** convert import/export++marks :: DarcsOption a (Maybe AbsolutePath -> Maybe AbsolutePath -> a)+marks = readMarks ^ writeMarks++readMarks :: PrimDarcsOption (Maybe AbsolutePath)+readMarks = singleAbsPathArg [] ["read-marks"] F.ReadMarks arg+    "FILE" "continue conversion, previously checkpointed by --write-marks"+  where arg (F.ReadMarks s) = Just s+        arg _ = Nothing++writeMarks :: PrimDarcsOption (Maybe AbsolutePath)+writeMarks = singleAbsPathArg [] ["write-marks"] F.WriteMarks arg+    "FILE" "checkpoint conversion to continue it later"+  where arg (F.WriteMarks s) = Just s+        arg _ = Nothing++-- | Deprecated flag, still present to output an error message.+hashed :: PrimDarcsOption ()+hashed = deprecated+  [ "All repositories are now \"hashed\", so this option was removed."+  , "Use --darcs-1 to get the effect that --hashed had previously." ] $+  [ RawNoArg [] ["hashed"] F.Hashed () "deprecated, use --darcs-1 instead" ]++patchFormat :: PrimDarcsOption PatchFormat+patchFormat = withDefault PatchFormat2+  [ RawNoArg [] ["darcs-3"] F.UseFormat3 PatchFormat3+    "New darcs patch format"+  , RawNoArg [] ["darcs-2"] F.UseFormat2 PatchFormat2+    "Standard darcs patch format"+  , RawNoArg [] ["darcs-1"] F.UseFormat1 PatchFormat1+    "Older patch format (for compatibility)" ]++-- ** dist++distname :: PrimDarcsOption (Maybe String)+distname = singleStrArg ['d'] ["dist-name"] F.DistName arg "DISTNAME" "name of version"+  where arg (F.DistName s) = Just s+        arg _ = Nothing++distzip :: PrimDarcsOption Bool+distzip = singleNoArg [] ["zip"] F.DistZip "generate zip archive instead of gzip'ed tar"++-- ** log++data ChangesFormat+  = HumanReadable+  | MachineReadable+  | GenContext+  | GenXml+  | NumberPatches+  | CountPatches+  deriving (Eq, Show)++changesFormat :: PrimDarcsOption (Maybe ChangesFormat)+changesFormat = withDefault Nothing+  [ RawNoArg [] ["context"] F.GenContext (Just GenContext) "produce output suitable for clone --context"+  , __xmloutput (Just GenXml)+  , __humanReadable (Just HumanReadable)+  , __machineReadable (Just MachineReadable)+  , RawNoArg [] ["number"] F.NumberPatches (Just NumberPatches) "number the changes"+  , RawNoArg [] ["count"] F.Count (Just CountPatches) "output count of changes" ]++-- ** replace++tokens :: PrimDarcsOption (Maybe String)+tokens = singleStrArg [] ["token-chars"] F.Toks arg "\"[CHARS]\""+    "define token to contain these characters"+  where arg (F.Toks s) = Just s; arg _ = Nothing++forceReplace :: PrimDarcsOption Bool+forceReplace = withDefault False+  [ RawNoArg ['f'] ["force"] F.ForceReplace True+    "proceed with replace even if 'new' token already exists"+  , RawNoArg [] ["no-force"] F.NonForce False+    "don't force the replace if it looks scary" ]++-- ** test++data TestStrategy = Once | Linear | Backoff | Bisect deriving (Eq, Show)++testStrategy :: PrimDarcsOption TestStrategy+testStrategy = withDefault Once+  [ RawNoArg [] ["once"] F.Once Once "run test on current version only"+  , RawNoArg [] ["linear"] F.Linear Linear "locate the most recent version lacking an error"+  , RawNoArg [] ["backoff"] F.Backoff Backoff "exponential backoff search"+  , RawNoArg [] ["bisect"] F.Bisect Bisect "binary instead of linear search" ]++data ShrinkFailure = ShrinkFailure | NoShrinkFailure deriving (Eq, Show)++shrinkFailure :: PrimDarcsOption ShrinkFailure+shrinkFailure = withDefault ShrinkFailure+  [ RawNoArg [] ["shrink-failure"] F.ShrinkFailure ShrinkFailure+      "try to cut down the set of patches causing a test failure"+  , RawNoArg [] ["no-shrink-failure"] F.NoShrinkFailure NoShrinkFailure+      "don't try to cut down the set of patches causing a test failure"+  ]++-- ** show files++files :: PrimDarcsOption Bool+files = withDefault True+  [ RawNoArg [] ["files"] F.Files True "include files in output"+  , RawNoArg [] ["no-files"] F.NoFiles False "don't include files in output" ]++directories :: PrimDarcsOption Bool+directories = withDefault True+  [ RawNoArg [] ["directories"] F.Directories True "include directories in output"+  , RawNoArg [] ["no-directories"] F.NoDirectories False "don't include directories in output" ]++pending :: PrimDarcsOption Bool+pending = withDefault True+  [ RawNoArg [] ["pending"] F.Pending True "reflect pending patches in output"+  , RawNoArg [] ["no-pending"] F.NoPending False "only include recorded patches in output" ]++-- "null" is already taken+nullFlag :: PrimDarcsOption Bool+nullFlag = singleNoArg ['0'] ["null"] F.NullFlag "separate file names by NUL characters"++-- ** show repo++enumPatches :: PrimDarcsOption EnumPatches+enumPatches = withDefault YesEnumPatches+  [ RawNoArg [] ["enum-patches"] F.EnumPatches YesEnumPatches+    "include statistics requiring enumeration of patches"+  , RawNoArg [] ["no-enum-patches"] F.NoEnumPatches NoEnumPatches+    "don't include statistics requiring enumeration of patches" ]++-- ** gzcrcs++data GzcrcsAction = GzcrcsCheck | GzcrcsRepair deriving (Eq, Show)++gzcrcsActions :: PrimDarcsOption (Maybe GzcrcsAction)+gzcrcsActions = withDefault Nothing+  [ RawNoArg [] ["check"] F.Check (Just GzcrcsCheck) "Specify checking mode"+  , RawNoArg [] ["repair"] F.Repair (Just GzcrcsRepair) "Specify repair mode" ]++-- ** optimize++siblings :: PrimDarcsOption [AbsolutePath]+siblings = multiAbsPathArg [] ["sibling"] F.Sibling mkV "DIRECTORY"+    "specify a sibling directory"+  where mkV fs = [ s | F.Sibling s <- fs ]
+ src/Darcs/UI/Options/Core.hs view
@@ -0,0 +1,312 @@+{-| Option specifications using continuations with a changing answer type.++Based on++@<www.is.ocha.ac.jp/~asai/papers/tr08-2.pdf>@++with additional inspiration provided by++@<http://okmij.org/ftp/typed-formatting/FPrintScan.html#DSL-FIn>@++which shows how the same format specifiers can be used for both @sprintf@ and+@sscanf@.++The 'OptSpec' type corresponds to the format specifiers for the sprintf and+sscanf functions, which I called 'ounparse' and 'oparse' here; they no+longer work on 'String's but instead on any list (the intention is, of+course, that this is a list of flags).++As explained in the original paper by Kenichi Asai, we cannot use+'Control.Monad.Trans.Cont.Cont', even with the recent additions of the+@shift@ and @reset@ combinators, since 'Control.Monad.Trans.Cont.Cont'+requires that the answer type remains the same over the whole computation,+while the trick used here requires that the answer type can change.++Besides parsing and unparsing, the 'OptSpec' type contains two more members:+'odesc' is the list of 'OptDescr' that 'System.Console.GetOpt.getOpt' needs+as input for parsing the command line and for generating the usage help,+while 'ocheck' takes a list of flags and returns a list of error messages,+which can be used to check for conflicting options.++-}+module Darcs.UI.Options.Core where++import Darcs.Prelude++import Darcs.UI.Options.Iso++-- * Option specifications++data OptMsg = OptWarning String | OptError String++{-| A type for option specifications.++It consists of four components: a parser, an unparser, a checker, and a list+of descriptions.++The parser converts a flag list to some result value. This can never fail:+we demand that primitive parsers are written so that there is always a+default value (use 'Maybe' with default 'Nothing' as a last resort).++The unparser does the opposite of the parser: a value is converted back+to a flag list.++The checker returns a list of error messages (which should be empty if there+are no problems found). This can be used to e.g. check whether there are+conflicting flags in the list.++Separating the checker and parser is unusual. The reason for this is that we+want to support flags coming from multiple sources, such as the command line+or a defaults file. Prioritising these sources is done by concatenating the+flag lists in the order of precedence, so that earlier flags win over later+ones. That means that when parsing the (final) flag list, conflicting flags+are resolved by picking the first flag that matches an option. The checker,+on the other hand, can be called for each source separately.++The last component is a list of descriptors for each single switch/flag that+the option is made of.++The 'OptSpec' type is heavily parameterized. The type arguments are:++[@f@] The flag type, such as 'Darcs.UI.Flags.DarcsFlag'.++[@d@] A type that describes an single flag, such as+  'System.Console.GetOpt.OptDescr' or 'Darcs.UI.Options.DarcsOptDescr'. It+  should be a 'Data.Functor.Functor'.++Abstracting over these types is not technically necessary: for the intended+application in Darcs, we could as well fix them as+@d='Darcs.UI.Options.DarcsOptDescr'@, and @f='Darcs.UI.Flags.DarcsFlag'@,+saving two type parameters. However, doing that here would only obscure+what's going on, making the code harder to understand, not easier. Besides,+the resulting more general type signatures give us additional guarantees,+known as \"free theorems\" (free as in beer, not in speak).++In contrast, the type parameters++[@a@, @b@] are necessary to make chaining of options a la typed printf/scanf+  possible. In a nutshell, @a@ is the result type of a function that+  consumes the result of parsing or unparsing an option, while @b@ is the+  complete type of such a function.++The 'ounparse' and 'oparse' members use continuation passing style, which is+the reason for their apparently \"inverted\" type signature. To understand+them, it helps to look at the type of \"primitive\" (not yet combined)+options (see 'PrimOptSpec' below). For a primitive option, @b@ gets+instantiated to @v -> a@, where @v@ is the type of values associated with+the option. The whole option spec then has type++>  o :: 'OptSpec' d f a (v -> a)++so that the 'oparse' and 'ounparse' members are instantiated to++>  ounparse :: forall a. ([f] -> a) -> (x -> a)+>  oparse   :: forall a. (x -> a) -> ([f] -> a)++which can be easily seen to be equivalent to++>  ounparse :: x -> [f]+>  oparse   :: [f] -> x++Chaining such options results in a combined option of type++>  o1 ^ o2 ^ ... :: OptSpec d f a (v1 -> v2 -> ... -> a)++that is, @b@ gets instantiated to++>  v1 -> v2 -> ... -> a++To use such an option (primitive or combined), you pass in the consumer. A+typical consumer of option values is a command implementation. Given++>  cmd :: v1 -> v2 -> ... -> [String] -> IO ()++we can parse the flags and pass the results to @cmd@:++>  oparse (o1 ^ o2 ^ ...) cmd flags++-}+data OptSpec d f a b = OptSpec+  { ounparse :: ([f] -> a) -> b+    -- ^ Convert option value (back) to flag list, in CPS.+  , oparse :: b -> ([f] -> a)+    -- ^ Convert flag list to option value, in CPS. Note: as a pure+    -- function, it is not supposed to fail.+  , ocheck :: [f] -> [OptMsg]+    -- ^ Check for erros in a flag list, returns error messages.+  , odesc :: [d f]+    -- ^ Descriptions, one for each flag that makes up the option.+  }++-- ** Primitive combinators++{- $category++The type @'OptSpec' d f@, together with the operation '^' and the unit+'oid' forms a category. We could express this with an++@+  instance 'Control.Category.Category' ('OptSpec' d f) where+    'Control.Category.id' = 'oid'+    ('Control.Category..') = ('^')+@++I decided against doing that because I like the 'id' and '.' from the+"Prelude".++Proving the category laws is easy because the operation and unit are+implemented independently for each component. This means @'OptSpec' d f@+is simply the product of four categories, reducing the problem to proving+the laws for each component separately.++['odesc'] This is just list concatenation, which is a monoid, and every+  monoid is a category (by adding two phantom type arguments).++['ocheck'] Same here, noting that @([f] ->)@ is a monoid homomorphism+  (as expressed by the @instance 'Monoid' b => 'Monoid' (a -> b)@ in+  "Data.Monoid").++['oparse'] This can be seen by flipping the arguments (which is a functor+  i.e. preserves category laws), so the type becomes @[f] -> b -> a@, and+  noting as before that @([f] ->)@ is a monoid homomorphism and thus a+  functor (by adding two phantom type arguments), reducing the operation to+  simple function composition. If this rather abstract argument doesn't+  convince you, do the calculations as an exercise.++['ounparse'] for this I don't have an easy abstract argument at hand,+  so I'll do the calculation:++@+    o1 ^ (o2 ^ o3)+  =   definition outer (^)+    \k -> o1 (\f1 -> (o2 ^ o3) (\f23 -> k (f1 ++ f23)))+  =   definition inner (^)+    \k -> o1 (\f1 -> (\k' -> o2 (\f2 -> o3 (\f3 -> k' (f2 ++ f3)))) (\f23 -> k (f1 ++ f23)))+  =   beta reduce: f1 --> \f23 -> k (f1 ++ f23)+    \k -> o1 (\f1 -> (o2 (\f2 -> o3 (\f3 -> (\f23 -> k (f1 ++ f23)) (f2 ++ f3)))))+  =   beta reduce: f23 --> f2 ++ f3+    \k -> o1 (\f1 -> (o2 (\f2 -> o3 (\f3 -> (k (f1 ++ (f2 ++ f3)))))))+@++and from the other side:++@+    (o1 ^ o2) ^ o3+  =   definition outer (^)+    \k -> (o1 ^ o2) (\f12 -> o3 (\f3 -> k (f12 ++ f3)))+  =   definition inner (^)+    \k -> (\k' -> o1 (\f1 -> o2 (\f2 -> k' (f1 ++ f2)))) (\f12 -> o3 (\f3 -> k (f12 ++ f3)))+  =   beta reduce: k' --> \f12 -> o3 (\f3 -> k (f12 ++ f3))+    \k -> (o1 (\f1 -> o2 (\f2 -> (\f12 -> o3 (\f3 -> k (f12 ++ f3))) (f1 ++ f2))))+  =   beta reduce: f12 --> f1 ++ f2+    \k -> (o1 (\f1 -> o2 (\f2 -> (o3 (\f3 -> k ((f1 ++ f2) ++ f3))))))+@++so again we have reduced the problem to the associativity of @('++')@. Left+and right unit laws are left to the reader...++-}++-- | Identity 'OptSpec', unit for '^'+oid :: OptSpec d f a a+oid = OptSpec {..} where+  ounparse k = k []+  oparse k _ = k+  ocheck _ = []+  odesc = []++-- | 'OptSpec' composition, associative+(^) :: OptSpec d f b c -> OptSpec d f a b -> OptSpec d f a c+OptSpec ou1 op1 oc1 od1 ^ OptSpec ou2 op2 oc2 od2 = OptSpec {..} where+  ounparse k = ou1 (\fs1 -> ou2 (\fs2 -> k (fs1 ++ fs2)))+  oparse k fs = op2 (op1 k fs) fs+  ocheck fs = oc1 fs ++ oc2 fs+  odesc = od1 ++ od2++-- ** Derived combinators++-- | Normalise a flag list by parsing and then unparsing it. This adds all+-- implicit (default) flags to the list.+--+-- prop> onormalise opts = (oparse opts . ounparse opts) id+onormalise :: OptSpec d f [f] b -> [f] -> [f]+onormalise opts = (oparse opts . ounparse opts) id++-- | The list of default flags for an 'OptSpec'.+--+-- prop> defaultFlags opts = onormalise opts []+defaultFlags :: OptSpec d f [f] b -> [f]+defaultFlags opts = onormalise opts []++-- ** Lifting isomorphisms++-- | Lift an isomorphism between @b@ and @c@ to one between+-- @'OptSpec' d f a b@ and @'OptSpec' d f a c@.+--+-- The forward component of the 'Iso' is needed for 'ounparse', the backward+-- component for 'oparse'. For the other two components this is the identity.+oimap :: Iso b c -> OptSpec d f a b -> OptSpec d f a c+oimap (Iso fw bw) (OptSpec ou op oc od) = OptSpec {..} where+  ounparse k = fw (ou k)+  oparse k = op (bw k)+  ocheck = oc+  odesc = od++instance IsoFunctor (OptSpec d f a) where+  imap = oimap++-- * Primitive options++-- | Type of primitive (not yet combined) options. The type parameter @b@+-- gets instantiated to @(v -> a)@, adding one argument of type @v@+-- to the answer type of the continuation.+type PrimOptSpec d f a v = OptSpec d f a (v -> a)++-- | Combine two list valued options of the same type \"in parellel\". This+-- is done by concatenating the resulting option values ('oparse'), flags+-- ('ounparse'), errors ('ocheck'), and descriptors ('odesc'),+-- respectively, of the input options.+oappend :: PrimOptSpec d f a [v] -> PrimOptSpec d f a [v] -> PrimOptSpec d f a [v]+OptSpec ou1 op1 oc1 od1 `oappend` OptSpec ou2 op2 oc2 od2 = OptSpec {..} where+  ounparse k bs = ou1 (\fs1 -> ou2 (\fs2 -> k (fs1 ++ fs2)) bs) bs+  oparse k fs = op2 (\bs2 -> op1 (\bs1 -> k (bs1 ++ bs2)) fs) fs+  ocheck fs = oc1 fs ++ oc2 fs+  odesc = od1 ++ od2++-- | Unit for 'oappend'.+oempty :: PrimOptSpec d f a [v]+oempty = OptSpec {..} where+  ounparse k _ = k []+  oparse k _ = k []+  ocheck _ = []+  odesc = []++instance Semigroup (PrimOptSpec d f a [v]) where+  (<>) = oappend++-- | See 'oappend' and 'oempty'.+instance Monoid (PrimOptSpec d f a [v]) where+  mappend = (<>)+  mempty = oempty++-- | Parse a list of flags against a primitive option spec, returning the+-- value associated with the option. As noted above, this cannot fail because+-- options always have a default value.+--+-- prop> parseFlags o fs = oparse o id fs+parseFlags :: (forall a. PrimOptSpec d f a v) -> [f] -> v+parseFlags o fs = oparse o id fs++-- | Unparse a primitive option spec and append it to a list of flags.+unparseOpt :: (forall a. PrimOptSpec d f a v) -> v -> [f] -> [f]+unparseOpt o v fs = ounparse o (\xfs -> fs ++ xfs) v++-- no associativity, higher precedence than comparisons operators (4)+-- and lower than arithemic operators (6,7,8)+infix 5 ?++-- | Operator version of 'parseFlags'+--+-- prop> opt ? flags = parseFlags opt flags+(?) :: (forall a. PrimOptSpec d f a v) -> [f] -> v+(?) = parseFlags
+ src/Darcs/UI/Options/Flags.hs view
@@ -0,0 +1,103 @@+-- |This module should only be imported by Darcs.UI.Options.*+-- and by 'Darcs.UI.Flags'. Other modules needing access to 'DarcsFlag'+-- should import 'Darcs.UI.Flags'+module Darcs.UI.Options.Flags ( DarcsFlag(..) ) where++import Darcs.Prelude++import Darcs.Util.Path ( AbsolutePath, AbsolutePathOrStd )++-- | The 'DarcsFlag' type is a list of all flags that can ever be+-- passed to darcs, or to one of its commands.+data DarcsFlag = Version | ExactVersion | ListCommands+               | Help | ListOptions | NoTest | Test+               | OnlyChangesToFiles | ChangesToAllFiles+               | LeaveTestDir | NoLeaveTestDir+               | Timings | Debug | DebugHTTP+               | Verbose | NormalVerbosity | Quiet+               | To String | Cc String+               | Output AbsolutePathOrStd | OutputAutoName AbsolutePath | Mail+               | Subject String | InReplyTo String | Charset String+               | SendmailCmd String | Author String | SelectAuthor | PatchName String+               | OnePatch String | SeveralPatch String+               | AfterPatch String | UpToPatch String+               | OnePattern String | SeveralPattern String+               | AfterPattern String | UpToPattern String+               | OneHash String | AfterHash String | UpToHash String+               | OneTag String | SeveralTag String | AfterTag String | UpToTag String+               | LastN String | MaxCount String+               | IndexRange String | OneIndex String+               | NumberPatches+               | GenContext | Context AbsolutePath | Count+               | LogFile AbsolutePath | RmLogFile | DontRmLogFile+               | DistName String | DistZip | All+               | Recursive | NoRecursive+               | Minimize | NoMinimize+               | Reorder | NoReorder+               | RestrictPaths | DontRestrictPaths+               | AskDeps | NoAskDeps | IgnoreTimes | DontIgnoreTimes+               | LookForAdds | NoLookForAdds+               | LookForMoves | NoLookForMoves+               | LookForReplaces | NoLookForReplaces+               | UseMyersDiff | UsePatienceDiff+               | Intersection | Union | Complement+               | Sign | SignAs String | NoSign | SignSSL String+               | HappyForwarding | NoHappyForwarding+               | Verify AbsolutePath | VerifySSL AbsolutePath+               | RemoteDarcsOpt String+               | EditDescription | NoEditDescription+               | Toks String+               | EditLongComment | NoEditLongComment | PromptLongComment+               | KeepDate | NoKeepDate+               | AllowConflicts | MarkConflicts | NoAllowConflicts+               | SkipConflicts+               | Boring | SkipBoring+               | AllowCaseOnly | DontAllowCaseOnly+               | AllowWindowsReserved | DontAllowWindowsReserved+               | DontGrabDeps | DontPromptForDependencies | PromptForDependencies+               | Compress | NoCompress | UnCompress+               | WorkRepoDir String | WorkRepoUrl String+               | NewRepo String+               | NotInRemote (Maybe String)+               | Reply String | ApplyAs String+               | MachineReadable | HumanReadable+               | Pipe | Interactive+               | DiffCmd String+               | ExternalMerge String | Summary | NoSummary+               | PauseForGui | NoPauseForGui+               | Unified | NonUnified | Reverse | Forward+               | Complete | Lazy+               | DiffFlags String+               | XMLOutput+               | ForceReplace+               | NonApply | NonVerify | NonForce+               | DryRun+               | InheritDefault | NoInheritDefault+               | SetDefault | NoSetDefault+               | Disable | SetScriptsExecutable | DontSetScriptsExecutable+               | Once | Linear | Backoff | Bisect+               | ShrinkFailure | NoShrinkFailure+               | Hashed -- deprecated flag, here to output an error message+               | UseFormat1 | UseFormat2 | UseFormat3+               | UseNoWorkingDir | UseWorkingDir+               | Sibling AbsolutePath+               | Files | NoFiles | Directories | NoDirectories+               | Pending | NoPending+               | PosthookCmd String | NoPosthook | AskPosthook | RunPosthook+               | PrehookCmd String  | NoPrehook  | AskPrehook  | RunPrehook+               | UMask String+               | StoreInMemory | ApplyOnDisk+               | NoHTTPPipelining+               | Packs | NoPacks+               | NoCache+               | AllowUnrelatedRepos+               | Check | Repair | JustThisRepo+               | ReadMarks AbsolutePath | WriteMarks AbsolutePath+               | NullFlag+               | NoAmendUnrecord | AmendUnrecord+               | PatchIndexFlag+               | NoPatchIndexFlag+               | EnumPatches | NoEnumPatches+               | WithPrefsTemplates | NoPrefsTemplates+               | OptimizeDeep | OptimizeShallow+                 deriving ( Eq, Show )
+ src/Darcs/UI/Options/Iso.hs view
@@ -0,0 +1,28 @@+module Darcs.UI.Options.Iso where++import Darcs.Prelude++-- * Isomorphisms++-- | Lightweight type ismomorphisms (a.k.a. invertible functions). If+-- +-- > Iso fw bw :: Iso a b+--+-- then @fw@ and @bw@ are supposed to satisfy+--+-- prop> fw . bw = id = bw . fw+data Iso a b = Iso (a -> b) (b -> a)++-- | Lift an isomorphism between @a@ and @b@ to one between @f a@ and @f b@.+-- Like 'Functor', except we can only map invertible functions (i.e. an+-- Isomorphisms).+class IsoFunctor f where+  imap :: Iso a b -> f a -> f b++-- | Apply an iso under a functor.+under :: Functor f => Iso a b -> Iso (f a) (f b)+under (Iso fw bw) = Iso (fmap fw) (fmap bw)++-- | Apply an iso under cps (which is a cofunctor).+cps :: Iso a b -> Iso (a -> c) (b -> c)+cps (Iso fw bw) = Iso (\k -> k . bw) (\k -> k . fw)
+ src/Darcs/UI/Options/Markdown.hs view
@@ -0,0 +1,37 @@+-- Support for @darcs help markdown@+module Darcs.UI.Options.Markdown ( optionsMarkdown ) where++import Darcs.Prelude++import Data.Functor.Compose ( Compose(..) )+import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) )+import Darcs.UI.Options.Util ( DarcsOptDescr )++optionsMarkdown :: [DarcsOptDescr f] -> String+optionsMarkdown opts = unlines+  [ "<table>", unlines (map optionMarkdown opts), "</table>" ]++optionMarkdown :: DarcsOptDescr f -> String+optionMarkdown (Compose (Option a b (NoArg _) h)) = unlines+ [ "<tr>", "<td>", showShortOptionsMd a, "</td>"+         , "<td>", showLongOptionsMd b , "</td>"+         , "<td>", h, "</td>"+ , "</tr>" ]+optionMarkdown (Compose (Option a b (ReqArg _ arg) h)) = unlines+ [ "<tr>", "<td>", showShortOptionsMd a, "</td>"+         , "<td>", showLongOptionsMd (map (++(' ' : arg)) b), "</td>"+         , "<td>", h, "</td>", "</tr>" ]+optionMarkdown (Compose (Option a b (OptArg _ arg) h)) = unlines+ [ "<tr>", "<td>", showShortOptionsMd a, "</td>"+         , "<td>", showLongOptionsMd (map (++("[="++arg++"]")) b), "</td>"+         , "<td>", h, "</td>", "</tr>" ]++showShortOptionsMd :: [Char] -> String+showShortOptionsMd []     = ""+showShortOptionsMd [c]    = "`-"++[c]++"` "+showShortOptionsMd (c:cs) = "`-"++[c]++"`,"++showShortOptionsMd cs++showLongOptionsMd :: [String] -> String+showLongOptionsMd []     = " "+showLongOptionsMd [s]    = "`--" ++ s ++ "` "+showLongOptionsMd (s:ss) = "`--" ++ s ++ "`,"++ showLongOptionsMd ss
+ src/Darcs/UI/Options/Matching.hs view
@@ -0,0 +1,241 @@+{-| Patch matching options.++These are all of the same type 'MatchOption' defined below.++Multiple flags per option are allowed and do not raise a conflict error.+This is how Darcs currently operates, even though I suspect that it ignores+all but the first 'MatchFlag' (since it does so for many other options).++Given a suitable semantics (and documentation thereof), for instance \"all+the given patterns must match\", this could be turned into a useful feature.++-}+module Darcs.UI.Options.Matching+    ( MatchFlag(..) -- re-export+    , matchUpToOne+    , matchOneContext+    , matchOneNontag+    , matchSeveral+    , matchSeveralOrFirst+    , matchSeveralOrLast+    , matchRange+    , matchOneOrRange+    , matchSeveralOrRange+    -- * exported for for checking+    , context+    , matchLast+    , matchFrom+    , matchAny -- temporary hack+    ) where++import Darcs.Prelude hiding ( last )++import Darcs.Patch.Match ( MatchFlag(..) )+import qualified Darcs.UI.Options.Flags as F ( DarcsFlag(..) )+import Darcs.UI.Options.Core+import Darcs.UI.Options.Util++-- * Type instantiations++type MatchOption = PrimDarcsOption [MatchFlag]++-- * Combined matching options++matchUpToOne :: MatchOption -- ^ show files/contents, dist, annotate+matchUpToOne = mconcat [match, patch, hash, tag, index]++-- | Used by: clone+matchOneContext :: MatchOption+matchOneContext = mconcat [toMatch, toPatch, toHash, tag, context]++-- [NOTE --index removed from matchOneNontag because issue1926]+-- The --index option was removed for 2.5 release because it isn't handled+-- by amend-record (see issue1926).+--+-- At this moment, amend-record is the only command that uses 'matchOneNontag',+-- so there is no other command affected.++-- | Used by: amend+matchOneNontag :: MatchOption+matchOneNontag =  match <> patch <> hash++-- | Used by: rebase pull/apply, send, push, pull, apply, fetch+matchSeveral :: MatchOption+matchSeveral = matches <> patches <> tags <> hash++matchLast :: MatchOption+matchLast = last++-- | Used by: rebase unsuspend/reify+matchSeveralOrFirst :: MatchOption+matchSeveralOrFirst = mconcat [ matchTo, last, matches, patches, tags, hash ]++-- | Used by: unrecord, obliterate, rebase suspend, rollback+matchSeveralOrLast :: MatchOption+matchSeveralOrLast = mconcat [ matchFrom, last, matches, patches, tags, hash ]++-- | Used by: diff+matchOneOrRange :: MatchOption+matchOneOrRange = mconcat [ match, patch, hash ] <> matchRange++-- | Used by: show dependencies+matchRange :: MatchOption+matchRange = mconcat [ matchTo, matchFrom, last, indexes ]++-- | Used by: log+matchSeveralOrRange :: MatchOption+matchSeveralOrRange = mconcat+  [ matchTo, matchFrom, last, indexes, matches, patches, tags, hash ]++matchTo :: MatchOption+matchTo = toMatch <> toPatch <> toHash <> toTag++matchFrom :: MatchOption+matchFrom = fromMatch <> fromPatch <> fromHash <> fromTag++matchAny :: MatchOption+matchAny = mconcat [ toMatch, toPatch, toHash, toTag,+  fromMatch, fromPatch, fromHash, fromTag,+  tag, tags, patch, patches, hash, match, matches, index, indexes, context, last ]++-- * Primitive matching options++toMatch, toPatch, toHash, toTag,+  fromMatch, fromPatch, fromHash, fromTag,+  tag, tags,+  patch, patches,+  hash,+  match, matches,+  index, indexes,+  context, last :: MatchOption++toMatch = OptSpec {..} where+  ounparse k mfs = k [ F.UpToPattern s | UpToPattern s <- mfs ]+  oparse k fs = k [ UpToPattern s | F.UpToPattern s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["to-match"] F.UpToPattern "PATTERN"+    "select changes up to a patch matching PATTERN" ]++toPatch = OptSpec {..} where+  ounparse k mfs = k [ F.UpToPatch s | UpToPatch s <- mfs ]+  oparse k fs = k [ UpToPatch s | F.UpToPatch s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["to-patch"] F.UpToPatch "REGEXP"+    "select changes up to a patch matching REGEXP" ]++toHash = OptSpec {..} where+  ounparse k mfs = k [ F.UpToHash s | UpToHash s <- mfs ]+  oparse k fs = k [ UpToHash s | F.UpToHash s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["to-hash"] F.UpToHash "HASH"+    "select changes up to a patch whose hash prefix matches HASH" ]++context = OptSpec {..} where+  ounparse k mfs = k [ F.Context p | Context p <- mfs ]+  oparse k fs = k [ Context p | F.Context p <- fs ]+  ocheck _ = []+  odesc = [ absPathArg [] ["context"] F.Context "FILENAME"+    "version specified by the context in FILENAME" ]++toTag = OptSpec {..} where+  ounparse k mfs = k [ F.UpToTag s | UpToTag s <- mfs ]+  oparse k fs = k [ UpToTag s | F.UpToTag s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["to-tag"] F.UpToTag "REGEXP"+    "select changes up to a tag matching REGEXP" ]++fromMatch = OptSpec {..} where+  ounparse k mfs = k [ F.AfterPattern s | AfterPattern s <- mfs ]+  oparse k fs = k [ AfterPattern s | F.AfterPattern s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["from-match"] F.AfterPattern "PATTERN"+    "select changes starting with a patch matching PATTERN" ]++fromPatch = OptSpec {..} where+  ounparse k mfs = k [ F.AfterPatch s | AfterPatch s <- mfs ]+  oparse k fs = k [ AfterPatch s | F.AfterPatch s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["from-patch"] F.AfterPatch "REGEXP"+    "select changes starting with a patch matching REGEXP" ]++fromHash = OptSpec {..} where+  ounparse k mfs = k [ F.AfterHash s | AfterHash s <- mfs ]+  oparse k fs = k [ AfterHash s | F.AfterHash s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["from-hash"] F.AfterHash "HASH"+    "select changes starting with a patch whose hash prefix matches HASH" ]++fromTag = OptSpec {..} where+  ounparse k mfs = k [ F.AfterTag s | AfterTag s <- mfs ]+  oparse k fs = k [ AfterTag s | F.AfterTag s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["from-tag"] F.AfterTag "REGEXP"+    "select changes starting with a tag matching REGEXP" ]++tag = OptSpec {..} where+  ounparse k mfs = k [ F.OneTag s | OneTag s <- mfs ]+  oparse k fs = k [ OneTag s | F.OneTag s <- fs ]+  ocheck _ = []+  odesc = [ strArg ['t'] ["tag"] F.OneTag "REGEXP" "select tag matching REGEXP" ]++tags = OptSpec {..} where+  ounparse k mfs = k [ F.SeveralTag s | SeveralTag s <- mfs ]+  oparse k fs = k [ SeveralTag s | F.SeveralTag s <- fs ]+  ocheck _ = []+  odesc = [ strArg ['t'] ["tags"] F.SeveralTag "REGEXP" "select tags matching REGEXP" ]++patch = OptSpec {..} where+  ounparse k mfs = k [ F.OnePatch s | OnePatch s <- mfs ]+  oparse k fs = k [ OnePatch s | F.OnePatch s <- fs ]+  ocheck _ = []+  odesc = [ strArg ['p'] ["patch"] F.OnePatch "REGEXP"+    "select a single patch matching REGEXP" ]++patches = OptSpec {..} where+  ounparse k mfs = k [ F.SeveralPatch s | SeveralPatch s <- mfs ]+  oparse k fs = k [ SeveralPatch s | F.SeveralPatch s <- fs ]+  ocheck _ = []+  odesc = [ strArg ['p'] ["patches"] F.SeveralPatch "REGEXP"+    "select patches matching REGEXP" ]++hash = OptSpec {..} where+  ounparse k mfs = k [ F.OneHash s | OneHash s <- mfs ]+  oparse k fs = k [ OneHash s | F.OneHash s <- fs ]+  ocheck _ = []+  odesc = [ strArg ['h'] ["hash"] F.OneHash "HASH"+    "select a single patch whose hash prefix matches HASH" ]++match = OptSpec {..} where+  ounparse k mfs = k [ F.OnePattern s | OnePattern s <- mfs ]+  oparse k fs = k [ OnePattern s | F.OnePattern s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["match"] F.OnePattern "PATTERN"+    "select a single patch matching PATTERN" ]++matches = OptSpec {..} where+  ounparse k mfs = k [ F.SeveralPattern s | SeveralPattern s <- mfs ]+  oparse k fs = k [ SeveralPattern s | F.SeveralPattern s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["matches"] F.SeveralPattern "PATTERN"+    "select patches matching PATTERN" ]++last = OptSpec {..} where+  ounparse k mfs = k [ F.LastN (showIntArg n) | LastN n <- mfs ]+  oparse k fs = k [ LastN (argparse s) | F.LastN s <- fs ]+  ocheck _ = []+  odesc = [ strArg [] ["last"] F.LastN "NUMBER" "select the last NUMBER patches" ]+  argparse = parseIntArg "count" (>=0)++index = OptSpec {..} where+  ounparse k mfs = k [ F.OneIndex (showIntArg n) | OneIndex n <- mfs ]+  oparse k fs = k [ OneIndex (argparse s) | F.OneIndex s <- fs ]+  ocheck _ = []+  odesc = [ strArg ['n'] ["index"] F.OneIndex "N" "select one patch" ]+  argparse = parseIntArg "index" (>0)++indexes = OptSpec {..} where+  ounparse k mfs = k [ F.IndexRange (showIndexRangeArg (n,m)) | IndexRange n m <- mfs ]+  oparse k fs = k [ uncurry IndexRange (argparse s) | F.IndexRange s <- fs ]+  ocheck _ = []+  odesc = [ strArg ['n'] ["index"] F.IndexRange "N-M" "select a range of patches" ]+  argparse = parseIndexRangeArg
+ src/Darcs/UI/Options/Util.hs view
@@ -0,0 +1,326 @@+-- | Constructing 'OptSpec's and 'OptDescr's+module Darcs.UI.Options.Util+    ( Flag+    -- * Instantiating 'OptSpec' and 'PrimOptSpec'+    , DarcsOptDescr+    , PrimDarcsOption+    -- * Constructing 'DarcsOptDescr's+    , noArg+    , strArg+    , optStrArg+    , absPathArg+    , absPathOrStdArg+    , optAbsPathArg+      -- * Raw option specs+    , RawOptSpec(..)+    , withDefault+    -- * Simple primitive scalar valued options+    , singleNoArg+    , singleStrArg+    -- * Simple primitive list valued options+    , multiStrArg+    , multiOptStrArg+    , singleAbsPathArg+    , multiAbsPathArg+    , deprecated+    -- * Parsing/showing option arguments+    , parseIntArg+    , parseIndexRangeArg+    , showIntArg+    , showIndexRangeArg+    , withDashes+    -- * Re-exports+    , AbsolutePath+    , AbsolutePathOrStd+    ) where++import Darcs.Prelude++import Control.Exception ( Exception, throw )+import Data.Functor.Compose+import Data.List ( intercalate )+import Data.Maybe ( maybeToList, fromMaybe )+import Data.Typeable ( Typeable )+import System.Console.GetOpt ( OptDescr(..), ArgDescr(..) )++import Darcs.UI.Options.Core+import Darcs.UI.Options.Flags ( DarcsFlag )+import Darcs.UI.Options.Iso+import Darcs.Util.Path+    ( AbsolutePath+    , AbsolutePathOrStd+    , makeAbsolute+    , makeAbsoluteOrStd+    )++-- * Instantiating 'OptSpec' and 'PrimOptSpec'++-- | This type synonym is here for brevity and because we want to import+-- the data constructors (but not the type) of 'DarcsFlag' qualified.+type Flag = DarcsFlag++{- | We do not instantiate the @d@ in @'OptSpec' d f@ directly with+'System.Console.GetOpt.OptDescr'. Instead we (post-) compose it with @(->)+'DarcsUtil.Path.AbsolutePath'@. Modulo newtype noise, this is the same as++@ type 'DarcsOptDescr' f = 'System.Console.GetOpt.OptDescr' ('AbsolutePath' -> f)@++This is so we can pass a directory relative to which an option argument is+interpreted (if it has the form of a relative path).+-}+type DarcsOptDescr = Compose OptDescr ((->) AbsolutePath)++-- | This is 'PrimOptSpec' instantiated with 'DarcsOptDescr' and 'Flag'.+type PrimDarcsOption v = forall a. PrimOptSpec DarcsOptDescr Flag a v++-- * Constructing 'DarcsOptDescr's++-- | Construct a 'DarcsOptDescr' with no arguments.+noArg :: [Char] -> [String] -> f -> String -> DarcsOptDescr f+noArg s l f h = Compose $ Option s l (NoArg (const f)) h++-- | A 'DarcsOptDescr' that requires a single argument of type 'a' and handles+-- flags of type 'f'.+type SingleArgOptDescr a f =+        [Char] -> [String] -> (a -> f) -> String -> String -> DarcsOptDescr f++-- | Construct a 'DarcsOptDescr' with a 'String' argument.+strArg :: SingleArgOptDescr String f+strArg s l f a h = Compose $ Option s l (ReqArg (\x _ -> f x) a) h++-- | Construct a 'DarcsOptDescr' with an optional 'String' argument.+optStrArg :: SingleArgOptDescr (Maybe String) f+optStrArg s l f a h = Compose $ Option s l (OptArg (\x _ -> f x) a) h++-- | Construct a 'DarcsOptDescr' with an 'AbsolutePath'+-- argument.+absPathArg :: SingleArgOptDescr AbsolutePath f+absPathArg s l f a h = Compose $ Option s l (ReqArg (\x wd -> f $ makeAbsolute wd x) a) h++-- | Construct a 'DarcsOptDescr' with an 'AbsolutePathOrStd'+-- argument.+absPathOrStdArg :: SingleArgOptDescr AbsolutePathOrStd f+absPathOrStdArg s l f a h = Compose $ Option s l (ReqArg (\x wd -> f $ makeAbsoluteOrStd wd x) a) h++-- | Construct a 'DarcsOptDescr' with an optional 'AbsolutePath'+-- argument.+optAbsPathArg :: [Char] -> [String] -> String -> (AbsolutePath -> f)+              -> String -> String -> DarcsOptDescr f+optAbsPathArg s l d f a h = Compose $ Option s l (OptArg (\x wd -> f $ makeAbsolute wd $ fromMaybe d x) a) h++-- * Raw option specs++-- | The raw material from which multi-valued options are built. See 'withDefault'.+data RawOptSpec f v+  = RawNoArg [Char] [String] f v String+  | RawStrArg [Char] [String] (String -> f) (f -> [String]) (String -> v) (v -> [String])+      String String+  | RawAbsPathArg [Char] [String] (AbsolutePath -> f) (f -> [AbsolutePath])+      (AbsolutePath -> v) (v -> [AbsolutePath]) String String+  | RawAbsPathOrStdArg [Char] [String] (AbsolutePathOrStd -> f) (f -> [AbsolutePathOrStd])+      (AbsolutePathOrStd -> v) (v -> [AbsolutePathOrStd]) String String+  | RawOptAbsPathArg [Char] [String] (AbsolutePath -> f) (f -> [AbsolutePath])+      (AbsolutePath -> v) (v -> [AbsolutePath]) String String String++instance IsoFunctor (RawOptSpec f) where+  imap (Iso fw _)  (RawNoArg s l f v h) = RawNoArg s l f (fw v) h+  imap (Iso fw bw) (RawStrArg s l mkF unF mkV unV n h) = RawStrArg s l mkF unF (fw . mkV) (unV . bw) n h+  imap (Iso fw bw) (RawAbsPathArg s l mkF unF mkV unV n h) = RawAbsPathArg s l mkF unF (fw . mkV) (unV . bw) n h+  imap (Iso fw bw) (RawAbsPathOrStdArg s l mkF unF mkV unV n h) = RawAbsPathOrStdArg s l mkF unF (fw . mkV) (unV . bw) n h+  imap (Iso fw bw) (RawOptAbsPathArg s l mkF unF mkV unV d n h) = RawOptAbsPathArg s l mkF unF (fw . mkV) (unV . bw) d n h++-- | Get the short and long switch names from a raw option.+-- Used to construct error and warning messages.+switchNames :: RawOptSpec f v -> [String]+switchNames (RawNoArg s l _ _ _)                 = withDashes s l+switchNames (RawStrArg s l _ _ _ _ _ _)          = withDashes s l+switchNames (RawAbsPathArg s l _ _ _ _ _ _)      = withDashes s l+switchNames (RawAbsPathOrStdArg s l _ _ _ _ _ _) = withDashes s l+switchNames (RawOptAbsPathArg s l _ _ _ _ _ _ _) = withDashes s l++withDashes :: [Char] -> [String] -> [String]+withDashes short long = map (\c -> ['-',c]) short ++ map ("--" ++) long++-- | Given a list of 'RawOptSpec', find all flags that match a given value.+rawUnparse :: Eq v => [RawOptSpec f v] -> v -> [f]+rawUnparse ropts val =+     [ f | RawNoArg _ _ f v _ <- ropts, v == val ]+  ++ [ mkF s | RawStrArg _ _ mkF _ mkV unV _ _ <- ropts, s <- unV val, mkV s == val ]+  ++ [ mkF p | RawAbsPathArg _ _ mkF _ mkV unV _ _ <- ropts, p <- unV val, mkV p == val ]+  ++ [ mkF p | RawAbsPathOrStdArg _ _ mkF _ mkV unV _ _ <- ropts, p <- unV val, mkV p == val ]+  ++ [ mkF p | RawOptAbsPathArg _ _ mkF _ mkV unV _ _ _ <- ropts, p <- unV val, mkV p == val ]++-- | Given a list of 'RawOptSpec', find all values that match a given flag list+-- in the order in which they appear in the flag list.+rawParse :: Eq f => [RawOptSpec f v] -> [f] -> [(v,RawOptSpec f v)]+rawParse ropts = concatMap rawParseFlag where+  rawParseFlag f = concatMap (go f) ropts+  go f o@(RawNoArg _ _ f' v _)                    = [ (v, o) | f == f' ]+  go f o@(RawStrArg _ _ _ unF mkV _ _ _)          = [ (mkV s, o) | s <- unF f ]+  go f o@(RawAbsPathArg _ _ _ unF mkV _ _ _)      = [ (mkV p, o) | p <- unF f ]+  go f o@(RawAbsPathOrStdArg _ _ _ unF mkV _ _ _) = [ (mkV p, o) | p <- unF f ]+  go f o@(RawOptAbsPathArg _ _ _ unF mkV _ _ _ _) = [ (mkV p, o) | p <- unF f ]++--      [ (v, o)     | f <- fs, o@(RawNoArg _ _ f' v _) <- ropts, f == f' ]+--   ++ [ (mkV s, o) | f <- fs, o@(RawStrArg _ _ _ unF mkV _ _ _) <- ropts, s <- unF f ]+--   ++ [ (mkV p, o) | f <- fs, o@(RawAbsPathArg _ _ _ unF mkV _ _ _) <- ropts, p <- unF f ]+--   ++ [ (mkV p, o) | f <- fs, o@(RawAbsPathOrStdArg _ _ _ unF mkV _ _ _) <- ropts, p <- unF f ]+--   ++ [ (mkV p, o) | f <- fs, o@(RawOptAbsPathArg _ _ _ unF mkV _ _ _ _) <- ropts, p <- unF f ]++-- | The first element of a list, or a default if the list is empty.+defHead :: a -> [a] -> a+defHead def []    = def+defHead _   (x:_) = x++-- | Append \" [DEFAULT\" to the help text of options that match the default value.+addDefaultHelp :: Eq v => v -> RawOptSpec f v -> DarcsOptDescr f+addDefaultHelp dval (RawNoArg s l f v h)+  | dval == v = noArg s l f (h++" [DEFAULT]")+  | otherwise = noArg s l f h+addDefaultHelp dval (RawStrArg s l mkF _ mkV unV a h)+  | [dval] == map mkV (unV dval) = strArg s l mkF a (h++" [DEFAULT]")+  | otherwise = strArg s l mkF a h+addDefaultHelp dval (RawAbsPathArg s l mkF _ mkV unV a h)+  | [dval] == map mkV (unV dval) = absPathArg s l mkF a (h++" [DEFAULT]")+  | otherwise = absPathArg s l mkF a h+addDefaultHelp dval (RawAbsPathOrStdArg s l mkF _ mkV unV a h)+  | [dval] == map mkV (unV dval) = absPathOrStdArg s l mkF a (h++" [DEFAULT]")+  | otherwise = absPathOrStdArg s l mkF a h+addDefaultHelp dval (RawOptAbsPathArg s l mkF _ mkV unV d a h)+  | [dval] == map mkV (unV dval) = optAbsPathArg s l d mkF a (h++" [DEFAULT]")+  | otherwise = optAbsPathArg s l d mkF a h++-- | Construct a 'PrimDarcsOption' from a default value and a list of 'RawOptSpec'.+--+-- Precondition: the list must have an entry for each possible value (type @v@).+withDefault :: Eq v => v -> [RawOptSpec Flag v] -> PrimDarcsOption v+withDefault dval ropts = OptSpec {..} where+  ounparse k = k . rawUnparse ropts+  oparse k = k . defHead dval . map fst . rawParse ropts+  ocheck fs = case map snd (rawParse ropts fs) of+    [] -> [] -- error "this should not happen"+    [_] -> []+    ropts' ->+      [ OptError $+        "conflicting options: " +++        intercalate ", " (map (intercalate "/" . switchNames) ropts')+      ]+  odesc = map (addDefaultHelp dval) ropts++-- * Simple primitive scalar valued options++-- | Construct a 'Bool' valued option with a single flag that takes no arguments+-- and has no default flag.+--+-- The arguments are: short switches, long switches, flag value, help string.+singleNoArg :: [Char] -> [String] -> Flag -> String -> PrimDarcsOption Bool+singleNoArg s l f h = withDefault False [RawNoArg s l f True h]++-- | Construct a @'Maybe' 'String'@ valued option with a single flag that takes a+-- 'String' argument and has no default flag.+--+-- The arguments are: short switches, long switches, flag constructor, single flag+-- parser, help string.+singleStrArg :: [Char] -> [String] -> (String -> Flag) -> (Flag -> Maybe String)+             -> String -> String -> PrimDarcsOption (Maybe String)+singleStrArg s l mkf isf n h =+  withDefault Nothing [ RawStrArg s l mkf (maybeToList . isf) Just maybeToList n h ]++-- | Construct a @'Maybe' 'AbsolutePath'@ valued option with a single flag that+-- takes an 'AbsolutePath' argument and has no default flag.+--+-- The arguments are: short switches, long switches, flag constructor, single flag+-- parser, help string.+singleAbsPathArg :: [Char] -> [String]+             -> (AbsolutePath -> Flag) -> (Flag -> Maybe AbsolutePath)+             -> String -> String -> PrimDarcsOption (Maybe AbsolutePath)+singleAbsPathArg s l mkf isf n h =+  withDefault Nothing [ RawAbsPathArg s l mkf (maybeToList . isf) Just maybeToList n h ]++-- * Simple primitive list valued options++-- | Similar to 'singleStrArg', except that the flag can be given more than once.+-- The flag arguments are collected in a list of 'String's.+multiStrArg :: [Char] -> [String] -> (String -> Flag) -> ([Flag] -> [String])+             -> String -> String -> PrimDarcsOption [String]+multiStrArg = multiArg strArg++-- | Similar to 'multiStrArg', except that the flag arguments are optional.+multiOptStrArg :: [Char] -> [String] -> (Maybe String -> Flag)+               -> ([Flag] -> [Maybe String]) -> String -> String+               -> PrimDarcsOption [Maybe String]+multiOptStrArg = multiArg optStrArg++-- | Similar to 'singleAbsPathArg', except that the flag can be given more than once.+-- The flag arguments are collected in a list of 'AbsolutePath's.+multiAbsPathArg :: [Char] -> [String] -> (AbsolutePath -> Flag) -> ([Flag] -> [AbsolutePath])+             -> String -> String -> PrimDarcsOption [AbsolutePath]+multiAbsPathArg = multiArg absPathArg++-- | A multi-arg option, defined in terms of a single-arg option, returning a+-- list of single args.+--+-- The parameters are: single argument description, short switches, long+-- switches, flag constructor, flag list parser, arg name string, help string.+multiArg :: SingleArgOptDescr a Flag+         -> [Char] -> [String] -> (a -> Flag) -> ([Flag] -> [a])+         -> String -> String -> PrimDarcsOption [a]+multiArg singleArg s l mkf isf n h = OptSpec {..} where+  ounparse k xs = k [ mkf x | x <- xs ]+  oparse k = k . isf+  ocheck _ = []+  odesc = [singleArg s l mkf n h]++-- | A deprecated option. If you want to deprecate only some flags and not the+-- whole option, extract the 'RawOptSpec's out of the original option and create+-- a new deprecated option.+-- The strings in the first argument are appended to the automatically generated+-- error message in case additional hints should be provided.+deprecated :: [String] -> [RawOptSpec Flag v] -> PrimDarcsOption ()+deprecated comments ropts = OptSpec {..} where+  ounparse k _ = k []+  oparse k _ = k ()+  ocheck fs =+    case map snd (rawParse ropts fs) of+      [] -> []+      ropts' ->+        map OptWarning $+          ( "deprecated option(s): " +++            intercalate ", " (concatMap switchNames ropts')+          ) : comments+  odesc = map noDefaultHelp ropts+  noDefaultHelp (RawNoArg s l f _ h) = noArg s l f h+  noDefaultHelp (RawStrArg s l mkF _ _ _ a h) = strArg s l mkF a h+  noDefaultHelp (RawAbsPathArg s l mkF _ _ _ a h) = absPathArg s l mkF a h+  noDefaultHelp (RawAbsPathOrStdArg s l mkF _ _ _ a h) = absPathOrStdArg s l mkF a h+  noDefaultHelp (RawOptAbsPathArg s l mkF _ _ _ d a h) = optAbsPathArg s l d mkF a h++-- * Parsing option arguments++data ArgumentParseError = ArgumentParseError String String+  deriving (Eq, Typeable)++instance Exception ArgumentParseError++instance Show ArgumentParseError where+  show (ArgumentParseError arg expected) =+    unwords ["cannot parse flag argument",show arg,"as",expected]++parseIntArg :: String -> (Int -> Bool) -> String -> Int+parseIntArg expected cond s =+  case reads s of+    (n,""):_ | cond n -> n+    _ -> throw (ArgumentParseError s expected)++parseIndexRangeArg :: String -> (Int,Int)+parseIndexRangeArg s =+  case reads s of+    (n,""):_ | n > 0 -> (n,n)+    (n,'-':s'):_ | n > 0, (m,""):_ <- reads s', m > 0 -> (n,m)+    _ -> throw (ArgumentParseError s "index range")++showIntArg :: Int -> String+showIntArg = show++showIndexRangeArg :: (Int,Int) -> String+showIndexRangeArg (n,m) = show n ++ "-" ++ show m
+ src/Darcs/UI/PatchHeader.hs view
@@ -0,0 +1,351 @@+module Darcs.UI.PatchHeader+    ( getLog+    , getAuthor+    , editLog+    , updatePatchHeader, AskAboutDeps(..)+    , PatchHeaderConfig+    , patchHeaderConfig+    , HijackT, HijackOptions(..)+    , runHijackT+    ) where++import Darcs.Prelude++import Darcs.Patch ( PrimOf, RepoPatch, summaryFL )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Info+    ( PatchInfo+    , patchinfo+    , piAuthor+    , piDateString+    , piLog+    , piName+    )+import Darcs.Patch.Named+    ( Named+    , adddeps+    , getdeps+    , infopatch+    , patch2patchinfo+    , patchcontents+    , setinfo+    )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, n2pia )+import Darcs.Patch.Prim ( canonizeFL )++import Darcs.Patch.Witnesses.Ordered ( FL(..), RL(..), (+>+) )++import Darcs.Util.Lock ( readTextFile, writeTextFile )++import Darcs.UI.External ( editFile )+import Darcs.UI.Flags ( getEasyAuthor, promptAuthor, getDate )+import Darcs.UI.Options ( Config, (?) )+import qualified Darcs.UI.Options.All as O+import qualified Darcs.UI.SelectChanges as S ( PatchSelectionOptions(..) )+import Darcs.UI.SelectChanges ( askAboutDepends )++import qualified Darcs.Util.Diff as D ( DiffAlgorithm )+import Darcs.Util.English ( capitalize )+import Darcs.Util.Global ( darcsLastMessage )+import Darcs.Util.Path ( FilePathLike, toFilePath )+import Darcs.Util.Prompt ( PromptConfig(..), askUser, promptChar, promptYorn )+import Darcs.Util.Printer ( Doc, text, ($+$), vcat, prefixLines, renderString )+import qualified Darcs.Util.Ratified as Ratified ( hGetContents )++import Darcs.Util.Tree ( Tree )++import Control.Exception ( catch, IOException )+import Control.Monad ( when, void )+import Control.Monad.Trans              ( liftIO )+import Control.Monad.Trans.State.Strict ( StateT(..), evalStateT, get, put  )+import Data.List ( isPrefixOf, stripPrefix )+import Data.Maybe ( fromMaybe, isJust )+import System.Exit ( exitSuccess )+import System.IO ( stdin )++data PName = FlagPatchName String | PriorPatchName String | NoPatchName++-- | Options for how to deal with the situation where we are somehow+--   modifying a patch that is not our own+data HijackOptions = IgnoreHijack                  -- ^ accept all hijack requests+                   | RequestHijackPermission       -- ^ prompt once, accepting subsequent hijacks if yes+                   | AlwaysRequestHijackPermission -- ^ always prompt++-- | Transformer for interactions with a hijack warning state that we+--   need to thread through+type HijackT = StateT HijackOptions++-- | Get the patch name and long description from one of+--+--  * the configuration (flags, defaults, hard-coded)+--+--  * an existing log file+--+--  * stdin (e.g. a pipe)+--+--  * a text editor+--+-- It ensures the patch name is not empty nor starts with the prefix TAG.+--+-- The last result component is a possible path to a temporary file that should be removed later.+getLog :: Maybe String                          -- ^ patchname option+       -> Bool                                  -- ^ pipe option+       -> O.Logfile                             -- ^ logfile option+       -> Maybe O.AskLongComment                -- ^ askLongComment option+       -> Maybe (String, [String])              -- ^ possibly an existing patch name and long description+       -> Doc                                   -- ^ summary of changes to record+       -> IO (String, [String], Maybe String)   -- ^ patch name, long description and possibly the path+                                                --   to the temporary file that should be removed later+getLog m_name has_pipe log_file ask_long m_old chs =+  restoreTagPrefix <$> go has_pipe log_file ask_long+ where+  go True _ _ = do+      p <- case patchname_specified of+             FlagPatchName p  -> check_badname p >> return p+             PriorPatchName p -> return p+             NoPatchName      -> prompt_patchname False+      putStrLn "What is the log?"+      thelog <- lines `fmap` Ratified.hGetContents stdin+      return (p, thelog, Nothing)+  go _ (O.Logfile { O._logfile = Just f }) _ = do+      mlp <- readTextFile f `catch` (\(_ :: IOException) -> return [])+      firstname <- case (patchname_specified, mlp) of+                     (FlagPatchName  p, []) -> check_badname p >> return p+                     (_, p:_)               -> if is_badname p+                                                 then prompt_patchname True+                                                 else return p -- logfile trumps prior!+                     (PriorPatchName p, []) -> return p+                     (NoPatchName, [])      -> prompt_patchname True+      append_info f firstname+      when (ask_long == Just O.YesEditLongComment) (void $ editFile f)+      (name, thelog) <- read_long_comment f firstname+      return (name, thelog, if O._rmlogfile log_file then Just $ toFilePath f else Nothing)+  go _ _ (Just O.YesEditLongComment) =+      case patchname_specified of+          FlagPatchName  p  -> get_log_using_editor p+          PriorPatchName p  -> get_log_using_editor p+          NoPatchName       -> get_log_using_editor ""+  go _ _ (Just O.NoEditLongComment) =+      case patchname_specified of+          FlagPatchName  p  -> check_badname p >> return (p, default_log, Nothing) -- record (or amend) -m+          PriorPatchName p  -> return (p, default_log, Nothing) -- amend+          NoPatchName       -> do p <- prompt_patchname True -- record+                                  return (p, [], Nothing)+  go _ _ (Just O.PromptLongComment) =+      case patchname_specified of+          FlagPatchName p   -> check_badname p >> prompt_long_comment p -- record (or amend) -m+          PriorPatchName p  -> prompt_long_comment p+          NoPatchName       -> prompt_patchname True >>= prompt_long_comment+  go _ _ Nothing =+      case patchname_specified of+          FlagPatchName  p  -> check_badname p >> return (p, default_log, Nothing)  -- record (or amend) -m+          PriorPatchName "" -> get_log_using_editor ""+          PriorPatchName p  -> return (p, default_log, Nothing)+          NoPatchName       -> get_log_using_editor ""++  tagPrefix = "TAG "++  hasTagPrefix name = tagPrefix `isPrefixOf` name++  restoreTagPrefix (name, log, file)+    | Just (old_name, _) <- m_old+    , hasTagPrefix old_name = (tagPrefix ++ name, log, file)+  restoreTagPrefix args = args++  stripTagPrefix name = fromMaybe name $ stripPrefix tagPrefix name++  patchname_specified =+    case (m_name, m_old) of+      (Just name, _)              -> FlagPatchName name+      (Nothing,   Just (name, _)) -> PriorPatchName (stripTagPrefix name)+      (Nothing,   Nothing)        -> NoPatchName++  default_log = case m_old of+                  Nothing    -> []+                  Just (_,l) -> l++  check_badname = maybe (return ()) fail . just_a_badname++  prompt_patchname retry = do+      n <- askUser "What is the patch name? "+      maybe (return n) prompt_again $ just_a_badname n+    where+      prompt_again msg = do+        putStrLn msg+        if retry then prompt_patchname retry else fail "Bad patch name!"++  just_a_badname n =+    if null n then+      Just "Error: The patch name must not be empty!"+    else if hasTagPrefix n then+      Just "Error: The patch name must not start with \"TAG \"!"+    else+      Nothing++  is_badname = isJust . just_a_badname++  prompt_long_comment oldname =+    do let verb = case m_old of Nothing -> "add a"; Just _ -> "edit the"+       y <- promptYorn $ "Do you want to "++verb++" long comment?"+       if y then get_log_using_editor oldname+            else return (oldname, default_log, Nothing)++  get_log_using_editor p =+                       do let logf = darcsLastMessage+                          writeTextFile logf $ unlines $ p : default_log+                          append_info logf p+                          _ <- editFile logf+                          (name,long) <- read_long_comment logf p+                          check_badname name+                          return (name,long,Just logf)++  read_long_comment :: FilePathLike p => p -> String -> IO (String, [String])+  read_long_comment f oldname =+      do t <- readTextFile f+         let filter_out_info = filter (not.("#" `isPrefixOf`))+         case reverse $ dropWhile null $ reverse $ filter_out_info t of+            []     -> return (oldname, [])+            (n:ls) -> do+                check_badname n+                return (n, ls)++  append_info f oldname = do+    fc <- readTextFile f+    writeTextFile f $ renderString+      $ vcat (map text $ if null fc then [oldname] else fc)+      $+$ vcat+        [ text "# Please enter the patch name in the first line, and"+        , text "# optionally, a long description in the following lines."+        , text "#"+        , text "# Lines starting with '#' will be ignored."+        , text "#"+        , text "#"+        , text "# Summary of selected changes:"+        , text "#"+        , prefixLines (text "#") chs+        ]++editLog :: Named prim wX wY -> IO (Named prim wX wY)+editLog p = do+  let pi = patch2patchinfo p+  (name, log, _) <-+    getLog Nothing False (O.Logfile Nothing False)+      (Just O.YesEditLongComment) (Just (piName pi, piLog pi)) mempty+  pi' <- patchinfo (piDateString pi) name (piAuthor pi) log+  return $ setinfo pi' p++-- | Specify whether to ask about dependencies with respect to a particular+-- 'PatchSet', or not+data AskAboutDeps p wX where+  AskAboutDeps :: (RL (PatchInfoAnd p) w wX) -> AskAboutDeps p wX+  NoAskAboutDeps :: AskAboutDeps p wX++-- | Run a job that involves a hijack confirmation prompt.+--+--   See 'RequestHijackPermission' for initial values+runHijackT :: Monad m => HijackOptions -> HijackT m a -> m a+runHijackT = flip evalStateT++data PatchHeaderConfig = PatchHeaderConfig+  { diffAlgorithm :: D.DiffAlgorithm+  , keepDate :: Bool+  , selectAuthor :: Bool+  , author :: Maybe String+  , patchname :: Maybe String+  , askLongComment :: Maybe O.AskLongComment+  }++patchHeaderConfig :: Config -> PatchHeaderConfig+patchHeaderConfig cfg = PatchHeaderConfig+  { diffAlgorithm   = O.diffAlgorithm ? cfg+  , keepDate        = O.keepDate ? cfg+  , selectAuthor    = O.selectAuthor ? cfg+  , author          = O.author ? cfg+  , patchname       = O.patchname ? cfg+  , askLongComment  = O.askLongComment ? cfg+  }++-- | Update the metadata for a patch.+--   This potentially involves a bit of interactivity, so we may return @Nothing@+--   if there is cause to abort what we're doing along the way+updatePatchHeader :: forall p wX wY wZ . (RepoPatch p, ApplyState p ~ Tree)+                  => String -- ^ verb: command name+                  -> AskAboutDeps p wX+                  -> S.PatchSelectionOptions+                  -> PatchHeaderConfig+                  -> Named (PrimOf p) wX wY+                  -- ^ patch to edit, must be conflict-free as conflicts can't+                  -- be preserved when changing the identity of a patch. If+                  -- necessary this can be achieved by calling @fmapFL_Named+                  -- effect@ on an @Named p@ first, but some callers might+                  -- already have @Named (PrimOf p)@ available.+                  -> FL (PrimOf p) wY wZ -- ^new primitives to add+                  -> HijackT IO (Maybe String, PatchInfoAnd p wX wZ)+updatePatchHeader verb ask_deps pSelOpts PatchHeaderConfig{..} oldp chs = do++    let newchs = canonizeFL diffAlgorithm (patchcontents oldp +>+ chs)++    let old_pdeps = getdeps oldp+    newdeps <-+        case ask_deps of+           AskAboutDeps patches ->+              liftIO $ askAboutDepends patches newchs pSelOpts old_pdeps+           NoAskAboutDeps -> return old_pdeps++    let old_pinf = patch2patchinfo oldp+        prior    = (piName old_pinf, piLog old_pinf)+    date <- if keepDate then return (piDateString old_pinf) else liftIO $ getDate False+    new_author <- getAuthor verb selectAuthor author old_pinf+    liftIO $ do+        (new_name, new_log, mlogf) <- getLog+            patchname False (O.Logfile Nothing False) askLongComment (Just prior) (summaryFL chs)+        new_pinf <- patchinfo date new_name new_author new_log+        let newp = n2pia (adddeps (infopatch new_pinf newchs) newdeps)+        return (mlogf, newp)+++-- | @getAuthor@ tries to return the updated author for the patch.+--   There are two different scenarios:+--+--   * [explicit] Either we want to override the patch author, be it by+--     prompting the user (@select@) or having them pass it in from+--     the UI (@new_author@), or+--+--   * [implicit] We want to keep the original author, in which case we+--     also double-check that we are not inadvertently \"hijacking\"+--     somebody else's patch (if the patch author is not the same as the+--     repository author, we give them a chance to abort the whole+--     operation)+getAuthor :: String          -- ^ verb:   command name+          -> Bool            -- ^ select: prompt for new auhor+          -> Maybe String    -- ^ new author: explict new author+          -> PatchInfo       -- ^ patch to update+          -> HijackT IO String+getAuthor _ True  _ _  = do+    auth <- liftIO $ promptAuthor False True+    return auth+getAuthor _    False (Just new) _   =+    return new+getAuthor verb False Nothing pinfo = do+    whitelist <- liftIO $ getEasyAuthor+    hj <- get+    if orig `elem` whitelist || canIgnore hj+        then allowHijack+        else do+            hijackResp <- liftIO $ askAboutHijack hj+            case hijackResp of+                'y' -> allowHijack+                'a' -> put IgnoreHijack >> allowHijack+                _   -> liftIO exitSuccess+  where+    askAboutHijack hj = promptChar (PromptConfig msg opts [] Nothing [])+       where+         msg  = "You're not " ++ orig ++"! " ++ capitalize verb ++ " anyway? "+         opts = case hj of+             AlwaysRequestHijackPermission -> "yn"+             _ -> "yna"+    canIgnore IgnoreHijack                  = True+    canIgnore RequestHijackPermission       = False+    canIgnore AlwaysRequestHijackPermission = False+    allowHijack = return orig+    orig = piAuthor pinfo
+ src/Darcs/UI/PrintPatch.hs view
@@ -0,0 +1,80 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.PrintPatch+    ( contextualPrintPatchWithPager+    , printContent+    , printContentWithPager+    , printFriendly+    , printSummary+    , showFriendly+    , showWithSummary+    ) where++import Darcs.Prelude++import Darcs.Patch ( description, content, summary )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.ApplyMonad ( ApplyMonadTrans )+import Darcs.Patch.Show+    ( ShowContextPatch+    , ShowPatch+    , ShowPatchFor(ForDisplay)+    , showPatchWithContext+    )+import Darcs.UI.External ( viewDocWith )+import Darcs.UI.Options.All ( Verbosity(..), WithSummary(..) )+import Darcs.Util.Printer ( Doc, prefix, putDocLnWith, ($$) )+import Darcs.Util.Printer.Color ( fancyPrinters )++-- | @'printFriendly' opts patch@ prints @patch@ in accordance with the flags+-- in opts, ie, whether @--verbose@ or @--summary@ were passed at the+-- command-line.+printFriendly :: ShowPatch p => Verbosity -> WithSummary -> p wX wY -> IO ()+printFriendly v s = putDocLnWith fancyPrinters . showFriendly v s++-- | @'showFriendly' flags patch@ returns a 'Doc' representing the right+-- way to show @patch@ given the list @flags@ of flags darcs was invoked with.+showFriendly :: ShowPatch p => Verbosity -> WithSummary -> p wX wY -> Doc+showFriendly Verbose _          = showWithContents+showFriendly _       YesSummary = showWithSummary+showFriendly _       NoSummary  = description++showWithSummary :: ShowPatch p => p wX wY -> Doc+showWithSummary p = description p $$ prefix "    " (summary p)++showWithContents :: ShowPatch p => p wX wY -> Doc+showWithContents p = description p $$ prefix "    " (content p)++printSummary :: ShowPatch p => p wX wY -> IO ()+printSummary = putDocLnWith fancyPrinters . prefix "    " . summary++printContent :: ShowPatch p => p wX wY -> IO ()+printContent = putDocLnWith fancyPrinters . prefix "    " . content++printContentWithPager :: ShowPatch p => p wX wY -> IO ()+printContentWithPager = viewDocWith fancyPrinters . prefix "    " . content++-- | Print a patch, together with its context, on standard output, using a+-- pager.+contextualPrintPatchWithPager+  :: (ApplyMonadTrans (ApplyState p) IO, ShowContextPatch p)+  => ApplyState p IO+  -> p wX wY+  -> IO ()+contextualPrintPatchWithPager s p = do+    showPatchWithContext ForDisplay s p >>= viewDocWith fancyPrinters
+ src/Darcs/UI/Prompt.hs view
@@ -0,0 +1,51 @@+-- | A more high-level API for what "Darcs.Util.Prompt" offers+module Darcs.UI.Prompt+    ( PromptChoice(..)+    , PromptConfig(..)+    , runPrompt+    ) where++import Darcs.Prelude+import Data.List ( find, intercalate )+import qualified Darcs.Util.Prompt as P++data PromptChoice a = PromptChoice+  { pcKey :: Char+  , pcWhen :: Bool+  , pcAction :: IO a+  , pcHelp :: String+  }++data PromptConfig a = PromptConfig+  { pPrompt :: String               -- what to ask the user+  , pVerb :: String                 -- command (what we are doing)+  , pChoices :: [[PromptChoice a]]  -- list of choice groups+  , pDefault :: Maybe Char          -- default choice, capitalized+  }++-- | Generate the help string from a verb and list of choice groups+helpFor :: String -> [[PromptChoice a]] -> String+helpFor jn choices =+  unlines $+    [ "How to use " ++ jn ++ ":" ] +++    intercalate [""] (map (map help . filter pcWhen) choices) +++    [ ""+    , "?: show this help"+    , ""+    , "<Space>: accept the current default (which is capitalized)"+    ]+  where+    help i = pcKey i : (": " ++ pcHelp i)++lookupAction :: Char -> [PromptChoice a] -> Maybe (IO a)+lookupAction key choices = pcAction <$> find ((==key).pcKey) choices++runPrompt :: PromptConfig a -> IO a+runPrompt pcfg@PromptConfig{..} = do+  let choices = filter pcWhen $ concat pChoices+  key <-+    P.promptChar $+      P.PromptConfig pPrompt (map pcKey choices) [] Nothing "?h"+  case lookupAction key choices of+    Just action -> action+    Nothing -> putStrLn (helpFor pVerb pChoices) >> runPrompt pcfg
+ src/Darcs/UI/RunCommand.hs view
@@ -0,0 +1,239 @@+-- Copyright (C) 2002,2003,2005 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE OverloadedStrings #-}+-- | This is the actual heavy lifter code, which is responsible for parsing the+-- arguments and then running the command itself.+module Darcs.UI.RunCommand+  ( runTheCommand+  , runWithHooks -- exported for darcsden+  ) where++import Darcs.Prelude++import Control.Monad ( unless, when )+import Data.List ( intercalate )+import System.Console.GetOpt( ArgOrder( Permute, RequireOrder ),+                              OptDescr( Option ),+                              getOpt )+import System.Exit ( ExitCode ( ExitSuccess ), exitWith )++import Darcs.UI.Options ( (^), odesc, oparse, parseFlags, optDescr, (?) )+import Darcs.UI.Options.All+    ( stdCmdActions, StdCmdAction(..)+    , debugging, verbosity, Verbosity(..)+    , HooksConfig(..), hooks )++import Darcs.UI.Defaults ( applyDefaults )+import Darcs.UI.External ( viewDoc )+import Darcs.UI.Flags ( DarcsFlag, matchAny, withNewRepo )+import Darcs.UI.Commands+    ( CommandArgs( CommandOnly, SuperCommandOnly, SuperCommandSub )+    , CommandControl+    , DarcsCommand+    , commandName+    , commandCommand+    , commandPrereq+    , commandExtraArgHelp+    , commandExtraArgs+    , commandArgdefaults+    , commandCompleteArgs+    , commandOptDescr+    , commandName+    , disambiguateCommands+    , getSubcommands+    , extractCommands+    , superName+    )+import Darcs.UI.Commands.GZCRCs ( doCRCWarnings )+import Darcs.UI.Commands.Clone ( makeRepoName, cloneToSSH )+import Darcs.UI.RunHook ( runPosthook, runPrehook )+import Darcs.UI.Usage+    ( getCommandHelp+    , getCommandMiniHelp+    , subusage+    )++import Darcs.Patch.Match ( checkMatchSyntax )+import Darcs.Repository.Prefs ( Pref(Defaults), getGlobal, getPreflist )+import Darcs.Util.AtExit ( atexit )+import Darcs.Util.Exception ( die )+import Darcs.Util.Global ( setDebugMode, setTimingsMode )+import Darcs.Util.Path ( AbsolutePath, getCurrentDirectory, toPath, ioAbsoluteOrRemote, makeAbsolute )+import Darcs.Util.Printer ( (<+>), ($+$), renderString, text, vcat )+import Darcs.Util.Printer.Color ( ePutDocLn )+import Darcs.Util.Progress ( setProgressMode )++runTheCommand :: [CommandControl] -> String -> [String] -> IO ()+runTheCommand commandControlList cmd args =+  either die rtc $ disambiguateCommands commandControlList cmd args+ where+  rtc (CommandOnly c,       as) = runCommand Nothing c as+  rtc (SuperCommandOnly c,  as) = runRawSupercommand c as+  rtc (SuperCommandSub c s, as) = runCommand (Just c) s as++runCommand :: Maybe DarcsCommand -> DarcsCommand -> [String] -> IO ()+runCommand _ _ args -- Check for "dangerous" typoes...+    | "-all" `elem` args = -- -all indicates --all --look-for-adds!+        die "Are you sure you didn't mean --all rather than -all?"+runCommand msuper cmd args = do+  old_wd <- getCurrentDirectory+  let options = commandOptDescr old_wd cmd+  case fixupMsgs $ getOpt Permute options args of+    (cmdline_flags,orig_extra,getopt_errs) -> do+      -- FIXME This code is highly order-dependent because of hidden state: the+      -- current directory. Like almost all Repository functions, getGlobal and+      -- getPreflist assume that the cwd is the base of our work repo (if any).+      -- This is supposed to be ensured by commandPrereq. Which means we must+      -- first call commandPrereq, then getGlobal and getPreflist, and then we+      -- must use the (saved) original working directory to resolve possibly+      -- relative paths to absolute paths.+      prereq_errors <- commandPrereq cmd cmdline_flags+      -- we must get the cwd again because commandPrereq has the side-effect of changing it.+      new_wd <- getCurrentDirectory+      user_defs <- getGlobal Defaults+      repo_defs <- getPreflist Defaults+      let (flags, (flag_warnings, flag_errors)) =+            applyDefaults (fmap commandName msuper) cmd old_wd user_defs repo_defs cmdline_flags+      case parseFlags stdCmdActions flags of+        Just Help -> viewDoc $ getCommandHelp msuper cmd+        Just ListOptions -> do+          setProgressMode False+          possible_args <- commandCompleteArgs cmd (new_wd, old_wd) flags orig_extra+          mapM_ putStrLn $ optionList options ++ possible_args+        Just Disable ->+          die $ "Command "++commandName cmd++" disabled with --disable option!"+        Nothing -> case prereq_errors of+          Left complaint -> die $+            "Unable to '" ++ "darcs " ++ superName msuper ++ commandName cmd +++            "' here:\n" ++ complaint+          Right () -> do+            ePutDocLn $ vcat $ map text $ flag_warnings+            case getopt_errs ++ flag_errors of+              [] -> do+                extra <- commandArgdefaults cmd flags old_wd orig_extra+                case extraArgumentsError extra cmd msuper of+                  Nothing     -> runWithHooks cmd (new_wd, old_wd) flags extra+                  Just msg    -> die msg+              errors -> fail $ intercalate "\n" errors++fixupMsgs :: (a, b, [String]) -> (a, b, [String])+fixupMsgs (fs,as,es) = (fs,as,map (("command line: "++).chompTrailingNewline) es)+  where+    chompTrailingNewline "" = ""+    chompTrailingNewline s = if last s == '\n' then init s else s++runWithHooks :: DarcsCommand+             -> (AbsolutePath, AbsolutePath)+             -> [DarcsFlag] -> [String] -> IO ()+runWithHooks cmd (new_wd, old_wd) flags extra = do+   checkMatchSyntax $ matchAny ? flags+   -- set any global variables+   oparse (verbosity ^ debugging) setGlobalVariables flags+   -- actually run the command and its hooks+   let hooksCfg = parseFlags hooks flags+   let verb = parseFlags verbosity flags+   preHookExitCode <- runPrehook (pre hooksCfg) verb new_wd+   if preHookExitCode /= ExitSuccess+      then exitWith preHookExitCode+      else do phDir <- getPosthookDir new_wd cmd flags extra+              commandCommand cmd (new_wd, old_wd) flags extra+              postHookExitCode <- runPosthook (post hooksCfg) verb phDir+              exitWith postHookExitCode++setGlobalVariables :: Verbosity -> Bool -> Bool -> IO ()+setGlobalVariables verb debug timings = do+  when timings setTimingsMode+  when debug setDebugMode+  when (verb == Quiet) $ setProgressMode False+  unless (verb == Quiet) $ atexit $ doCRCWarnings (verb == Verbose)++-- | Returns the working directory for the posthook. For most commands, the+-- first parameter is returned. For the \'get\' command, the path of the newly+-- created repository is returned if it is not an ssh url.+getPosthookDir :: AbsolutePath -> DarcsCommand -> [DarcsFlag] -> [String] -> IO AbsolutePath+getPosthookDir new_wd cmd flags extra | commandName cmd `elem` ["get","clone"] = do+    case extra of+      [inrepodir, outname] -> getPosthookDir new_wd cmd (withNewRepo outname flags) [inrepodir]+      [inrepodir] ->+        case cloneToSSH flags of+         Nothing -> do+          repodir <- toPath <$> ioAbsoluteOrRemote inrepodir+          newRepo <- makeRepoName False flags repodir+          return $ makeAbsolute new_wd newRepo+         _ -> return new_wd+      _ -> die "You must provide 'clone' with either one or two arguments."+getPosthookDir new_wd _ _ _ = return new_wd+++-- | Checks if the number of extra arguments matches the number of extra+-- arguments supported by the command as specified in `commandExtraArgs`.+-- Extra arguments are arguments that follow the command but aren't+-- considered a flag. In `darcs push xyz`, xyz would be an extra argument.+extraArgumentsError :: [String]             -- extra commands provided by user+                    -> DarcsCommand+                    -> Maybe DarcsCommand+                    -> Maybe String+extraArgumentsError extra cmd msuper+    | extraArgsCmd < 0 = Nothing+    | extraArgsInput > extraArgsCmd = Just badArg+    | extraArgsInput < extraArgsCmd = Just missingArg+    | otherwise = Nothing+        where+            extraArgsInput = length extra+            extraArgsCmd = commandExtraArgs cmd+            badArg     = "Bad argument: `" ++ unwords extra +++                         "'\n" ++ getCommandMiniHelp msuper cmd+            missingArg = "Missing argument:  " ++ nthArg (length extra + 1) +++                         "\n" ++ getCommandMiniHelp msuper cmd+            nthArg n       = nthOf n (commandExtraArgHelp cmd)+            nthOf 1 (h:_)  = h+            nthOf n (_:hs) = nthOf (n-1) hs+            nthOf _ []     = "UNDOCUMENTED"++optionList :: [OptDescr DarcsFlag] -> [String]+optionList = concatMap names+  where+    names (Option sos los _ desc) =+      map (short desc) sos ++ map (long desc) los+    short d o = '-' : o : ";" ++ d+    long d o = "--" ++ o ++ ";" ++ d++runRawSupercommand :: DarcsCommand -> [String] -> IO ()+runRawSupercommand super [] =+  die $ renderString $+    "Command '" <> text (commandName super) <> "' requires a subcommand!"+    $+$+    subusage super+runRawSupercommand super args = do+  cwd <- getCurrentDirectory+  case fixupMsgs $ getOpt RequireOrder (map (optDescr cwd) (odesc stdCmdActions)) args of+    -- note: we do not apply defaults here+    (flags,_,getopt_errs) -> case parseFlags stdCmdActions flags of+      Just Help ->+        viewDoc $ getCommandHelp Nothing super+      Just ListOptions -> do+        putStrLn "--help"+        mapM_ (putStrLn . commandName) (extractCommands $ getSubcommands super)+      Just Disable -> do+        die $ renderString $+          "Command" <+> text (commandName super) <+> "disabled with --disable option!"+      Nothing ->+        die $ renderString $+          case getopt_errs of+            [] -> text "Invalid subcommand!" $+$ subusage super+            _ -> vcat (map text getopt_errs)
+ src/Darcs/UI/RunHook.hs view
@@ -0,0 +1,71 @@+--  Copyright (C) 2002-2005 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; see the file COPYING.  If not, write to+--  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+--  Boston, MA 02110-1301, USA.++module Darcs.UI.RunHook+    ( runPosthook+    , runPrehook+    )+where++import Darcs.Prelude++import System.Directory ( withCurrentDirectory )+import System.Exit ( ExitCode(..) )+import System.Process ( system )+import System.IO ( hPutStrLn, stderr )+import Control.Monad ( when )++import Darcs.UI.Options.All ( HookConfig(..), Verbosity(..) )++import Darcs.Util.Path ( AbsolutePath, toFilePath )+import Darcs.Util.Prompt ( promptYorn )++runPosthook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode+runPosthook (HookConfig mPostHook askPostHook) verb repodir+    = do ph <- getHook "Posthook" mPostHook askPostHook+         withCurrentDirectory (toFilePath repodir) $ runHook verb "Posthook" ph++runPrehook :: HookConfig -> Verbosity -> AbsolutePath -> IO ExitCode+runPrehook (HookConfig mPreHookCmd askPreHook) verb repodir =+    do ph <- getHook "Prehook" mPreHookCmd askPreHook+       withCurrentDirectory (toFilePath repodir) $ runHook verb "Prehook" ph++getHook :: String -> Maybe String -> Bool -> IO (Maybe String)+getHook name mPostHookCmd askHook =+ case mPostHookCmd of+   Nothing -> return Nothing+   Just command ->+     if askHook+      then do yorn <-+                promptYorn+                  ("The following command is set to execute:\n"++command+++                   "\nExecute this command now?")+              if yorn+                then return $ Just command+                else putStrLn (name ++ " cancelled...") >> return Nothing+      else return $ Just command++runHook :: Verbosity -> String -> Maybe String -> IO ExitCode+runHook _ _ Nothing = return ExitSuccess+runHook verb cname (Just command) =+    do ec <- system command+       when (verb /= Quiet) $+         if ec == ExitSuccess+         then putStrLn $ cname++" ran successfully."+         else hPutStrLn stderr $ cname++" failed!"+       return ec+
+ src/Darcs/UI/SelectChanges.hs view
@@ -0,0 +1,1088 @@+-- Copyright (C) 2002-2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE RecordWildCards #-}+module Darcs.UI.SelectChanges+    ( -- * Working with changes+      WhichChanges(..)+    , viewChanges+    , withSelectedPatchFromList+    , runSelection+    , runInvertibleSelection+    , selectionConfigPrim+    , selectionConfigGeneric+    , selectionConfig+    , SelectionConfig(allowSkipAll)+    -- * Interactive selection utils+    , PatchSelectionOptions(..)+    , InteractiveSelectionM+    , InteractiveSelectionState(..)+    , initialSelectionState+    -- ** Navigating the patchset+    , currentPatch+    , skipMundane+    , skipOne+    , backOne+    , backAll+    -- ** Decisions+    , decide+    , decideWholeFile+    -- ** Prompts and queries+    , isSingleFile+    , currentFile+    , promptUser+    , prompt+    , KeyPress(..)+    , keysFor+    , helpFor+    , askAboutDepends+    ) where++import Darcs.Prelude++import Control.Monad ( liftM, unless, when, (>=>) )+import Control.Monad.Identity ( Identity (..) )+import Control.Monad.Reader+    ( ReaderT+    , asks+    , runReaderT+    )+import Control.Monad.State+    ( StateT, execStateT, gets+    , modify, runStateT, state+    )+import Control.Monad.Trans ( liftIO )+import Data.List ( intercalate, union, (\\) )+import Data.Maybe ( isJust )+import System.Exit ( exitSuccess )++import Darcs.Patch+    ( RepoPatch, PrimOf+    , commuteFL, invert+    , listTouchedFiles+    )+import qualified Darcs.Patch ( thing, things )+import Darcs.Patch.Apply ( ApplyState )+import Darcs.Patch.Choices+    ( PatchChoices, Slot (..), LabelledPatch+    , forceFirst, forceLast, forceMatchingFirst+    , forceMatchingLast, getChoices+    , makeEverythingLater, makeEverythingSooner+    , forceMiddle, patchChoices+    , patchSlot+    , refineChoices, selectAllMiddles+    , separateFirstFromMiddleLast+    , substitute, label, unLabel+    , labelPatches+    )+import Darcs.Patch.Commute ( Commute )+import Darcs.Patch.Ident ( Ident(..), PatchId )+import Darcs.Patch.Info ( PatchInfo )+import Darcs.Patch.Inspect ( PatchInspect )+import Darcs.Patch.Invert ( Invert )+import Darcs.Patch.Invertible+import Darcs.Patch.Match+    ( Matchable+    , MatchableRP+    , haveNonrangeMatch+    , matchAPatch+    )+import Darcs.Patch.Named ( adddeps, anonymous )+import Darcs.Patch.PatchInfoAnd ( PatchInfoAnd, info, n2pia )+import Darcs.Patch.Permutations ( commuteWhatWeCanRL )+import Darcs.Patch.Show ( ShowPatch, ShowContextPatch )+import Darcs.Patch.Split ( Splitter(..) )+import Darcs.Patch.TouchesFiles ( selectNotTouching, deselectNotTouching )+import Darcs.Patch.Witnesses.Ordered+    ( (:>) (..), (:||:) (..), FL (..)+    , RL (..), filterFL, lengthFL, mapFL+    , mapFL_FL, spanFL, spanFL_M+    , (+>+), (+<<+)+    , reverseFL, reverseRL+    )+import Darcs.Patch.Witnesses.Sealed+    ( FlippedSeal (..), Sealed2 (..)+    , seal2, unseal2+    )+import Darcs.Patch.Witnesses.WZipper+    ( FZipper (..), focus, jokers, left, right+    , rightmost, toEnd, toStart+    )+import Darcs.UI.External ( editText )+import Darcs.UI.Options.All+    ( Verbosity(..), WithSummary(..)+    , SelectDeps(..), MatchFlag )+import Darcs.UI.PrintPatch+    ( printContent+    , printContentWithPager+    , printFriendly+    , printSummary+    , showFriendly+    )+import Darcs.Util.English ( Noun (..), englishNum, capitalize )+import Darcs.Util.Path ( AnchoredPath )+import Darcs.Util.Printer ( putDocLnWith, greenText, vcat )+import Darcs.Util.Printer.Color ( fancyPrinters )+import Darcs.Util.Prompt ( PromptConfig (..), promptYorn, promptChar )+import Darcs.Util.Tree ( Tree )+++-- | When asking about patches, we either ask about them in+-- oldest-first or newest first (with respect to the current ordering+-- of the repository), and we either want an initial segment or a+-- final segment of the poset of patches.+--+-- 'First': ask for an initial+-- segment, first patches first (default for all pull-like commands)+--+-- 'FirstReversed': ask for an initial segment, last patches first+-- (used to ask about dependencies in record, and for pull-like+-- commands with the @--reverse@ flag).+--+-- 'LastReversed': ask for a final segment, last patches first. (default+-- for unpull-like commands, except for selecting *primitive* patches in+-- rollback)+--+-- 'Last': ask for a final segment, first patches first. (used for selecting+-- primitive patches in rollback, and for unpull-like commands with the+-- @--reverse@ flag+--+-- IOW: First = initial segment+--      Last = final segment+--      Reversed = start with the newest patch instead of oldest+-- As usual, terminology is not, ahem, very intuitive.+data WhichChanges = Last | LastReversed | First | FirstReversed deriving (Eq, Show)++-- | A 'WhichChanges' is 'backward' if the segment of patches we ask for+-- is at the opposite end of where we start to present them.+backward :: WhichChanges -> Bool+backward w = w == Last || w == FirstReversed++-- | A 'WhichChanges' is reversed if the order in which patches are presented+-- is latest (or newest) patch first.+reversed :: WhichChanges -> Bool+reversed w = w == LastReversed || w == FirstReversed++-- | The type of the function we use to filter patches when @--match@ is+-- given.+data MatchCriterion p = MatchCriterion+   { mcHasNonrange :: Bool+   , mcFunction :: forall wA wB. p wA wB -> Bool+   }++data PatchSelectionOptions = PatchSelectionOptions+  { verbosity :: Verbosity+  , matchFlags :: [MatchFlag]+  , interactive :: Bool+  , selectDeps :: SelectDeps+  , withSummary :: WithSummary+  }++-- | All the static settings for selecting patches.+data SelectionConfig p =+  PSC { opts :: PatchSelectionOptions+      , splitter :: Maybe (Splitter p)+      , files :: Maybe [AnchoredPath]+      , matchCriterion :: MatchCriterion p+      , jobname :: String+      , allowSkipAll :: Bool+      , whichChanges :: WhichChanges+      }++-- | A 'SelectionConfig' for selecting 'Prim' patches.+selectionConfigPrim :: WhichChanges+                    -> String+                    -> PatchSelectionOptions+                    -> Maybe (Splitter prim)+                    -> Maybe [AnchoredPath]+                    -> SelectionConfig prim+selectionConfigPrim whch jn o spl fs =+ PSC { opts = o+     , splitter = spl+     , files = fs+     , matchCriterion = triv+     , jobname = jn+     , allowSkipAll = True+     , whichChanges = whch+     }++-- | A 'SelectionConfig' for selecting full ('Matchable') patches+selectionConfig :: Matchable p+                 => WhichChanges+                 -> String+                 -> PatchSelectionOptions+                 -> Maybe (Splitter p)+                 -> Maybe [AnchoredPath]+                 -> SelectionConfig p+selectionConfig whch jn o spl fs =+ PSC { opts = o+     , splitter = spl+     , files = fs+     , matchCriterion = iswanted seal2 (matchFlags o)+     , jobname = jn+     , allowSkipAll = True+     , whichChanges = whch+     }++-- | A generic 'SelectionConfig'.+selectionConfigGeneric :: Matchable p+                       => (forall wX wY . q wX wY -> Sealed2 p)+                       -> WhichChanges+                       -> String+                       -> PatchSelectionOptions+                       -> Maybe [AnchoredPath]+                       -> SelectionConfig q+selectionConfigGeneric extract whch jn o fs =+ PSC { opts = o+     , splitter = Nothing+     , files = fs+     , matchCriterion = iswanted extract (matchFlags o)+     , jobname = jn+     , allowSkipAll = True+     , whichChanges = whch+     }++-- | The dynamic parameters for interactive selection of patches.+data InteractiveSelectionState p wX wY =+ ISC { total :: Int                           -- ^ total number of patches+     , current :: Int                         -- ^ number of already-seen patches+     , lps :: FZipper (LabelledPatch p) wX wY -- ^ the patches we offer+     , choices :: PatchChoices p wX wY        -- ^ the user's choices+     }++type PatchSelectionM p a = ReaderT (SelectionConfig p) a++type InteractiveSelectionM p wX wY a =+    StateT (InteractiveSelectionState p wX wY)+           (PatchSelectionM p IO) a++-- Common match criteria++-- | For commands without @--match@, 'triv' matches all patches+triv :: MatchCriterion p+triv = MatchCriterion { mcHasNonrange = False, mcFunction = \ _ -> True }++-- | 'iswanted' selects patches according to the given match flags+iswanted :: Matchable p+         => (forall wX wY . q wX wY -> Sealed2 p)+         -> [MatchFlag]+         -> MatchCriterion q+iswanted extract mflags = MatchCriterion+    { mcHasNonrange = haveNonrangeMatch mflags+    , mcFunction = unseal2 (matchAPatch mflags) . extract+    }++-- | Run a 'PatchSelection' action in the given 'SelectionConfig',+-- without assuming that patches are invertible.+runSelection :: ( MatchableRP p, ShowPatch p, ShowContextPatch p+                , ApplyState p ~ Tree, ApplyState p ~ ApplyState (PrimOf p)+                )+             => FL p wX wY+             -> SelectionConfig p+             -> IO ((FL p :> FL p) wX wY)+runSelection _ PSC { splitter = Just _ } =+  -- a Splitter makes sense for prim patches only and these are invertible anyway+  error "cannot use runSelection with Splitter"+runSelection ps PSC { matchCriterion = mc, .. } = do+    unwrapOutput <$> runInvertibleSelection (wrapInput ps) ictx+  where+    convertMC :: MatchCriterion p -> MatchCriterion (Invertible p)+    convertMC MatchCriterion { mcFunction = mcf, .. } =+      MatchCriterion { mcFunction = withInvertible mcf, .. }+    ictx = PSC { matchCriterion = convertMC mc, splitter = Nothing, .. }+    wrapInput = mapFL_FL mkInvertible+    unwrapOutput (xs :> ys) =+      mapFL_FL fromPositiveInvertible xs :> mapFL_FL fromPositiveInvertible ys++-- | Run a 'PatchSelection' action in the given 'SelectionConfig',+-- assuming patches are invertible.+runInvertibleSelection :: forall p wX wY .+                          ( Invert p, MatchableRP p, ShowPatch p+                          , ShowContextPatch p, ApplyState p ~ Tree+                          )+                       => FL p wX wY+                       -> SelectionConfig p+                       -> IO ((FL p :> FL p) wX wY)+runInvertibleSelection ps psc = runReaderT (selection ps) psc where+  selection+    | reversed whch = fmap invert . doit . invert+    | otherwise = doit+  -- efficiency note: we should first filterUnwanted to apply matchers,+  -- as this often requires to read only metadata; then filterNotTouching+  -- applies path restrictions which needs to read patch contents+  doit =+    fmap (canonizeAfterSplitter . selectedPatches) .+    selectChanges . filterNotTouching . filterUnwanted . patchChoices++  -- configuration+  whch = whichChanges psc+  fs = files psc+  os = opts psc+  crit = matchCriterion psc+  mspl = splitter psc++  -- after selecting with a splitter, the results may not be canonical+  canonizeAfterSplitter :: (FL p :> FL p) wA wB -> (FL p :> FL p) wA wB+  canonizeAfterSplitter (x :> y) =+    let+      canonizeIfNeeded =+        case mspl of+          Just s -> canonizeSplit s+          Nothing -> id+    in canonizeIfNeeded x :> canonizeIfNeeded y++  -- retrieve the results of patch selection+  selectedPatches :: PatchChoices p wA wB -> (FL p :> FL p) wA wB+  selectedPatches pc+    | backward whch =+        case getChoices pc of+          fc :> mc :> lc -> mapFL_FL unLabel (fc +>+ mc) :> mapFL_FL unLabel lc+    | otherwise =+        case separateFirstFromMiddleLast pc of+          xs :> ys -> mapFL_FL unLabel xs :> mapFL_FL unLabel ys++  selectChanges :: PatchChoices p wA wB+                -> PatchSelectionM p IO (PatchChoices p wA wB)+  selectChanges+    | interactive os = refineChoices textSelect+    | otherwise      = return . promote++  promote+    | backward whch = makeEverythingLater+    | otherwise     = makeEverythingSooner+  demote+    | backward whch = makeEverythingSooner+    | otherwise     = makeEverythingLater++  filterNotTouching+    | backward whch = selectNotTouching fs+    | otherwise     = deselectNotTouching fs++  -- when using @--match@, remove unmatched patches+  -- not depended upon by matched patches+  filterUnwanted :: PatchChoices p wA wB -> PatchChoices p wA wB+  filterUnwanted+    | mcHasNonrange crit =+        case selectDeps os of+          NoDeps -> deselectUnwanted+          _      -> demote . selectWanted+    | otherwise = id++  selectWanted+    | backward whch = forceMatchingLast iswanted_+    | otherwise     = forceMatchingFirst iswanted_+  deselectUnwanted+    | backward whch = forceMatchingFirst (not . iswanted_)+    | otherwise     = forceMatchingLast (not . iswanted_)+  iswanted_ = mcFunction crit . unLabel++  {- end of runInvertibleSelection -}++-- | The equivalent of 'runSelection' for the @darcs log@ command+viewChanges :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)+            => PatchSelectionOptions -> [Sealed2 p] -> IO ()+viewChanges ps_opts = textView ps_opts Nothing 0 []++-- | The type of the answers to a "shall I [wiggle] that [foo]?" question+-- They are found in a [[KeyPress]] bunch, each list representing a set of+-- answers which belong together+data KeyPress = KeyPress { kp     :: Char+                           , kpHelp :: String }++-- | Generates the help for a set of basic and advanced 'KeyPress' groups.+helpFor :: String -> [[KeyPress]] -> [[KeyPress]] -> String+helpFor jn basicKeypresses advancedKeyPresses =+  unlines $ [ "How to use "++jn++":" ]+            ++ intercalate [""] (map (map help) keypresses)+            ++ [ ""+               , "?: show this help"+               , ""+               , "<Space>: accept the current default (which is capitalized)"+               ]+  where help i = kp i:(": "++kpHelp i)+        keypresses = basicKeypresses ++ advancedKeyPresses++-- | The keys used by a list of 'keyPress' groups.+keysFor :: [[KeyPress]] -> [Char]+keysFor = concatMap (map kp)++-- | The function for selecting a patch to amend record. Read at your own risks.+withSelectedPatchFromList+    :: (Commute p, Matchable p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)+    => String   -- name of calling command (always "amend" as of now)+    -> RL p wX wY+    -> PatchSelectionOptions+    -> ((RL p :> p) wX wY -> IO ())+    -> IO ()+withSelectedPatchFromList jn patches o job = do+    sp <- wspfr jn (matchAPatch $ matchFlags o) patches NilFL+    case sp of+        Just (skipped :> selected') -> job (skipped :> selected')+        Nothing ->+            putStrLn $ "Cancelling " ++ jn ++ " since no patch was selected."++data SkippedReason = SkippedAutomatically | SkippedManually++data WithSkipped p wX wY = WithSkipped+    { _skippedReason :: SkippedReason+    , skippedPatch :: p wX wY+    }++-- | This ensures that the selected patch commutes freely with the skipped+-- patches, including pending and also that the skipped sequences has an+-- ending context that matches the recorded state, z, of the repository.+wspfr :: forall p wX wY wZ.+         (Commute p, Matchable p, ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)+      => String+      -> (forall wA wB . p wA wB -> Bool)+      -> RL p wX wY+      -> FL (WithSkipped p) wY wZ+      -> IO (Maybe ((RL p :> p) wX wZ))+wspfr _ _ NilRL _ = return Nothing+wspfr jn matches remaining@(pps:<:p) skipped+    | not $ matches p = wspfr jn matches pps+                            (WithSkipped SkippedAutomatically p :>: skipped)+    | otherwise =+    case commuteFL (p :> mapFL_FL skippedPatch skipped) of+    Nothing -> do putStrLn "\nSkipping depended-upon patch:"+                  defaultPrintFriendly p+                  wspfr jn matches pps (WithSkipped SkippedAutomatically p :>: skipped)++    Just (skipped' :> p') -> do+        defaultPrintFriendly p+        let repeatThis = do+              yorn <- promptChar+                    PromptConfig { pPrompt = prompt'+                                 , pBasicCharacters = keysFor basicOptions+                                 , pAdvancedCharacters = keysFor advancedOptions+                                 , pDefault = Just 'n'+                                 , pHelp = "?h" }+              case yorn of+                'y' -> return $ Just $ (pps +<<+ skipped') :> p'+                'n' -> nextPatch+                'j' -> nextPatch+                'k' -> previousPatch remaining skipped+                'v' -> printContent p >> repeatThis+                'p' -> printContentWithPager p >> repeatThis+                'x' -> do printSummary p+                          repeatThis+                'r' -> defaultPrintFriendly p >> repeatThis+                'q' -> do putStrLn $ (capitalize jn) ++ " cancelled."+                          exitSuccess+                _   -> do putStrLn $ helpFor jn basicOptions advancedOptions+                          repeatThis+        repeatThis+  where prompt' = "Shall I " ++ jn ++ " this patch?"+        nextPatch = wspfr jn matches pps (WithSkipped SkippedManually p:>:skipped)+        previousPatch :: RL p wA wB+                      -> FL (WithSkipped p) wB wC+                      -> IO (Maybe ((RL p :> p) wA wC))+        previousPatch remaining' NilFL = wspfr jn matches remaining' NilFL+        previousPatch remaining' (WithSkipped sk prev :>: skipped'') =+            case sk of+                SkippedManually -> wspfr jn matches (remaining' :<: prev) skipped''+                SkippedAutomatically -> previousPatch (remaining' :<: prev) skipped''+        basicOptions =+                    [[ KeyPress 'y' (jn ++ " this patch")+                     , KeyPress 'n' ("don't " ++ jn ++ " it")+                     , KeyPress 'j' "skip to next patch"+                     , KeyPress 'k' "back up to previous patch"+                    ]]+        advancedOptions =+                    [[ KeyPress 'v' "view this patch in full"+                     , KeyPress 'p' "view this patch in full with pager"+                     , KeyPress 'x' "view a summary of this patch"+                     , KeyPress 'r' "view this patch"+                     , KeyPress 'q' ("cancel " ++ jn)+                    ]]+        defaultPrintFriendly =+          printFriendly NormalVerbosity NoSummary++-- | Runs a function on the underlying @PatchChoices@ object+liftChoices :: StateT (PatchChoices p wX wY) Identity a+            -> InteractiveSelectionM p wX wY a+liftChoices act = do+  ch <- gets choices+  let (result, _) = runIdentity $ runStateT act ch+  modify $ \isc -> isc {choices = ch} -- Should this be ch or the result of runState?+  return result++-- | @justDone n@ notes that @n@ patches have just been processed+justDone :: Int -> InteractiveSelectionM p wX wY ()+justDone n = modify $ \isc -> isc{ current = current isc + n}++initialSelectionState :: FL (LabelledPatch p) wX wY+                      -> PatchChoices p wX wY+                      -> InteractiveSelectionState p wX wY+initialSelectionState lps pcs =+  ISC { total = lengthFL lps+      , current = 0+      , lps = FZipper NilRL lps+      , choices = pcs+      }++-- | The actual interactive selection process.+textSelect :: ( Commute p, Invert p, ShowPatch p, ShowContextPatch p+              , PatchInspect p, ApplyState p ~ Tree )+           => FL (LabelledPatch p) wX wY+           -> PatchChoices p wX wY+           -> PatchSelectionM p IO (PatchChoices p wX wY)+textSelect lps' pcs =+  choices <$>+    execStateT (skipMundane >> printCurrent >> textSelectIfAny)+      (initialSelectionState lps' pcs)+  where+    textSelectIfAny = do+      z <- gets lps+      unless (rightmost z) $ textSelect'++textSelect' :: ( Commute p, Invert p, ShowPatch p, ShowContextPatch p+               , PatchInspect p, ApplyState p ~ Tree )+            => InteractiveSelectionM p wX wY ()+textSelect' = do+  z <- gets lps+  done <- if not $ rightmost z+           then textSelectOne+           else lastQuestion+  unless done $ textSelect'++optionsBasic :: String -> String -> [KeyPress]+optionsBasic jn aThing =+    [ KeyPress 'y' (jn++" this "++aThing)+    , KeyPress 'n' ("don't "++jn++" it")+    , KeyPress 'w' "wait and decide later, defaulting to no" ]++optionsFile :: String -> [KeyPress]+optionsFile jn =+    [ KeyPress 's' ("don't "++jn++" the rest of the changes to this file")+    , KeyPress 'f' (jn++" the rest of the changes to this file") ]++optionsView :: String -> String -> [KeyPress]+optionsView aThing someThings =+    [ KeyPress 'v' ("view this "++aThing++" in full")+    , KeyPress 'p' ("view this "++aThing++" in full with pager")+    , KeyPress 'r' ("view this "++aThing)+    , KeyPress 'l' ("list all selected "++someThings) ]++optionsSummary :: String -> [KeyPress]+optionsSummary aThing =+    [ KeyPress 'x' ("view a summary of this "++aThing) ]++optionsQuit :: String -> Bool -> String -> [KeyPress]+optionsQuit jn allowsa someThings =+    [ KeyPress 'd' (jn++" selected "++someThings+++                    ", skipping all the remaining "++someThings)+            | allowsa ]+    +++    [ KeyPress 'a' (jn++" all the remaining "++someThings)+    , KeyPress 'q' ("cancel "++jn) ]++optionsNav :: String -> Bool -> [KeyPress]+optionsNav aThing isLast=+    [ KeyPress 'j' ("skip to next "++ aThing) | not isLast ]+    +++    [ KeyPress 'k' ("back up to previous "++ aThing)+    , KeyPress 'g' ("start over from the first "++aThing)]++optionsSplit :: Maybe (Splitter a) -> String -> [KeyPress]+optionsSplit split aThing+    | Just _ <- split+             = [ KeyPress 'e' ("interactively edit this "++ aThing) ]+    | otherwise = []++optionsLast :: String -> String -> ([[KeyPress]], [[KeyPress]])+optionsLast jn aThing =+  (optionsNav aThing True:+   [[ KeyPress 'y' "confirm this operation"+    , KeyPress 'q' ("cancel " ++ jn) ]+    , [ KeyPress 'l' "list all selected" ]+   ]+  ,[[KeyPress 'a' "confirm this operation"+    , KeyPress 'd' "confirm this operation"+    , KeyPress 'n' ("cancel " ++ jn) ]])++options :: (ShowPatch p)+        => Bool+        -> InteractiveSelectionM p wX wY ([[KeyPress]],[[KeyPress]])+options single = do+  split <- asks splitter+  jn <- asks jobname+  allowsa <- asks allowSkipAll+  aThing <- thing+  someThings <- things+  o <- asks opts+  return ([optionsBasic jn aThing]+         ,[optionsSplit split aThing]+         ++ [optionsFile jn | single]+         ++ [optionsView aThing someThings +++                if withSummary o == YesSummary+                    then []+                    else optionsSummary aThing]+         ++ [optionsQuit jn allowsa someThings]+         ++ [optionsNav aThing False]+         )++-- | Returns a 'Sealed2' version of the patch we are asking the user+-- about.+currentPatch :: InteractiveSelectionM p wX wY (Maybe (Sealed2 (LabelledPatch p)))+currentPatch = focus <$> gets lps++-- | Returns the patches we have yet to ask the user about.+todo :: InteractiveSelectionM p wX wY (FlippedSeal (FL (LabelledPatch p)) wY)+todo = jokers <$> gets lps++-- | Modify the underlying @PatchChoices@ by some function+modifyChoices :: (PatchChoices p wX wY -> PatchChoices p wX wY)+              -> InteractiveSelectionM p wX wY ()+modifyChoices f = modify $ \isc -> isc{choices = f $ choices isc}++-- | returns @Just f@ if the 'currentPatch' only modifies @f@,+-- @Nothing@ otherwise.+currentFile :: (PatchInspect p)+            => InteractiveSelectionM p wX wY (Maybe AnchoredPath)+currentFile = do+  c <- currentPatch+  return $ case c of+             Nothing -> Nothing+             Just (Sealed2 lp) ->+                 case listTouchedFiles lp of+                   [f] -> Just f+                   _ -> Nothing++-- | @decide True@ selects the current patch, and @decide False@ deselects+-- it.+decide :: Commute p+       => Bool+       -> LabelledPatch p wA wB+       -> InteractiveSelectionM p wX wY ()+decide takeOrDrop lp = do+    whch <- asks whichChanges+    if backward whch == takeOrDrop -- we go backward xor we are dropping+    then modifyChoices $ forceLast (label lp)+    else modifyChoices $ forceFirst (label lp)++-- | like 'decide', but for all patches touching @file@+decideWholeFile :: (Commute p, PatchInspect p)+                => AnchoredPath -> Bool -> InteractiveSelectionM p wX wY ()+decideWholeFile path takeOrDrop =+    do+      FlippedSeal lps_todo <- todo+      let patches_to_skip =+              filterFL (\lp' -> listTouchedFiles lp' == [path]) lps_todo+      mapM_ (unseal2 $ decide takeOrDrop) patches_to_skip++-- | Undecide the current patch.+postponeNext :: Commute p => InteractiveSelectionM p wX wY ()+postponeNext =+    do+      Just (Sealed2 lp) <- currentPatch+      modifyChoices $ forceMiddle (label lp)++-- | Focus the next patch.+skipOne :: InteractiveSelectionM p wX wY ()+skipOne = modify so+    where so x = x{lps = right (lps x), current = current x +1}++-- | Focus the previous patch.+backOne :: InteractiveSelectionM p wX wY ()+backOne = modify so+    where so isc = isc{lps = left (lps isc), current = max (current isc-1) 0}++-- | Split the current patch (presumably a hunk), and add the replace it+-- with its parts.+splitCurrent :: Splitter p+             -> InteractiveSelectionM p wX wY ()+splitCurrent s = do+    FZipper lps_done (lp:>:lps_todo) <- gets lps+    case applySplitter s (unLabel lp) of+      Nothing -> return ()+      Just (text, parse) ->+          do+            newText <- liftIO $ editText "darcs-patch-edit" text+            case parse newText of+               Nothing -> return ()+               Just ps -> do+                 lps_new <- liftIO $ return $ labelPatches (Just (label lp)) ps+                 modify $ \isc -> isc { total = total isc + lengthFL lps_new - 1+                                      , lps = FZipper lps_done+                                               (lps_new +>+ lps_todo)+                                      , choices = substitute+                                                   (seal2 (lp :||: lps_new))+                                                   (choices isc)+                                      }++-- | Print the list of the selected patches. We currently choose to display+-- them in "commuted" form, that is, in the order in which they have been+-- selected and with deselected patches moved out of the way.+printSelected :: (Commute p, ShowPatch p) => InteractiveSelectionM p wX wY ()+printSelected = do+  someThings <- things+  o <- asks opts+  w <- asks whichChanges+  let showFL = vcat . mapFL (showFriendly (verbosity o) (withSummary o) . unLabel)+  (first_chs :> _ :> last_chs) <- getChoices <$> gets choices+  liftIO $ putDocLnWith fancyPrinters $ vcat+    [ greenText $ "---- selected "++someThings++" ----"+    , if backward w then showFL last_chs else showFL first_chs+    , greenText $ "---- end of selected "++someThings++" ----"+    ]++-- | Skips all remaining patches.+skipAll ::  InteractiveSelectionM p wX wY ()+skipAll = modify $ \isc -> isc {lps = toEnd $ lps isc}++backAll ::  InteractiveSelectionM p wX wY ()+backAll = modify $ \isc -> isc {lps = toStart $ lps isc+                               ,current = 0}++isSingleFile :: PatchInspect p => p wX wY -> Bool+isSingleFile p = length (listTouchedFiles p) == 1++askConfirmation ::  InteractiveSelectionM p wX wY ()+askConfirmation = do+    jn <- asks jobname+    liftIO $ when (jn `elem` ["unpull", "unrecord", "obliterate"]) $ do+               yes <- promptYorn $ "Really " ++ jn ++ " all undecided patches?"+               unless yes exitSuccess++-- | The singular form of the noun for items of type @p@.+thing :: (ShowPatch p) => InteractiveSelectionM p wX wY String+thing = (Darcs.Patch.thing . helper) `liftM` gets choices+        where+          helper :: PatchChoices p wA wB -> p wA wB+          helper = undefined++-- | The plural form of the noun for items of type @p@.+things :: (ShowPatch p) => InteractiveSelectionM p wX wY String+things = (Darcs.Patch.things . helper) `liftM` gets choices+        where+          helper :: PatchChoices p wA wB -> p wA wB+          helper = undefined++-- | The question to ask about one patch.+prompt :: (ShowPatch p) => InteractiveSelectionM p wX wY String+prompt = do+  jn <- asks jobname+  aThing <- thing+  n <- gets current+  n_max <- gets total+  return $ "Shall I "++jn++" this "++aThing++"? "+             ++ "(" ++ show (n+1) ++ "/" ++ show n_max ++ ") "++-- | Asks the user about one patch, returns their answer.+promptUser :: (ShowPatch p)+           => Bool -> Char -> InteractiveSelectionM p wX wY Char+promptUser single def = do+  thePrompt <- prompt+  (basicOptions,advancedOptions) <- options single+  liftIO $ promptChar PromptConfig { pPrompt = thePrompt+                                   , pBasicCharacters = keysFor basicOptions+                                   , pAdvancedCharacters = keysFor advancedOptions+                                   , pDefault = Just def+                                   , pHelp = "?h"+                                   }++-- | Ask the user what to do with the next patch.+textSelectOne :: ( Commute p, ShowPatch p, PatchInspect p )+              => InteractiveSelectionM p wX wY Bool+textSelectOne = do+ c <- currentPatch+ case c of+   Nothing -> return False+   Just (Sealed2 lp) ->+       do+         jn <- asks jobname+         spl <- asks splitter+         whichch <- asks whichChanges+         let singleFile = isSingleFile (unLabel lp)+             p = unLabel lp+         (basicOptions,advancedOptions) <- options singleFile+         theSlot <- liftChoices $ state $ patchSlot lp+         let the_default = getDefault (backward whichch) theSlot+         yorn <- promptUser singleFile the_default+         let nextPatch = skipMundane >> printCurrent+         case yorn of+               'y' -> decide True lp >> skipOne >> nextPatch+                      >> return False+               'n' -> decide False lp >> skipOne >> nextPatch+                      >> return False+               'w' -> postponeNext >> skipOne >> nextPatch+                      >> return False+               'e' | (Just s) <- spl -> splitCurrent s >> printCurrent+                                        >> return False+               's' -> currentFile >>= maybe+                       (return ())+                       (\f -> decideWholeFile f False) >> nextPatch+                       >> return False+               'f' -> currentFile >>= maybe+                       (return ())+                       (\f -> decideWholeFile f True) >> nextPatch+                       >> return False+               'v' -> liftIO $ printContent p >> return False+               'p' -> liftIO $ printContentWithPager p >> return False+               'r' -> printCurrent >> return False+               'l' -> printSelected >> printCurrent >> return False+               'x' -> liftIO $ printSummary p >> return False+               'd' -> skipAll >> return True+               'g' -> backAll >> printCurrent >> return False+               'a' ->+                   do+                     askConfirmation+                     modifyChoices $ selectAllMiddles (backward whichch)+                     skipAll+                     return True+               'q' -> liftIO $+                      do putStrLn $ capitalize jn ++ " cancelled."+                         exitSuccess+               'j' -> skipOne >> printCurrent >> return False+               'k' -> backOne >> printCurrent >> return False+               _   -> do+                 liftIO . putStrLn $ helpFor jn basicOptions advancedOptions+                 return False++lastQuestion :: (Commute p, ShowPatch p)+             => InteractiveSelectionM p wX wY Bool+lastQuestion = do+  jn <- asks jobname+  theThings <- things+  aThing <- thing+  let (basicOptions, advancedOptions) = optionsLast jn aThing+  num <- numSelected+  if num == 0 then do+    liftIO $ putStrLn "Nothing selected."+    return True+  else do+    yorn <- liftIO . promptChar $+            PromptConfig { pPrompt = "Do you want to "++capitalize jn+++                                      " these "++theThings++"?"+                         , pBasicCharacters = "yglqk"+                         , pAdvancedCharacters = "dan"+                         , pDefault = Just 'y'+                         , pHelp = "?h"}+    case yorn of+               c | c `elem` "yda" -> return True+                 | c `elem` "qn" -> liftIO $+                                    do putStrLn $ jn ++" cancelled."+                                       exitSuccess+               'g' -> backAll >> printCurrent >> return False+               'l' -> printSelected >> return False+               'k' -> backOne >> printCurrent >> return False+               _ -> do+                 liftIO . putStrLn $ helpFor "this confirmation prompt"+                    basicOptions advancedOptions+                 return False++numSelected :: Commute p => InteractiveSelectionM p wX wY Int+numSelected = do+  w <- asks whichChanges+  (first_chs :> _ :> last_chs) <- getChoices <$> gets choices+  return $+    if backward w then lengthFL last_chs else lengthFL first_chs++-- | Shows the current patch as it should be seen by the user.+printCurrent :: ShowPatch p => InteractiveSelectionM p wX wY ()+printCurrent = do+  o <- asks opts+  c <- currentPatch+  case c of+    Nothing -> return ()+    Just (Sealed2 lp) ->+      liftIO $ printFriendly (verbosity o) (withSummary o) $ unLabel lp++-- | The interactive part of @darcs changes@+textView :: (ShowPatch p, ShowContextPatch p, ApplyState p ~ Tree)+         => PatchSelectionOptions -> Maybe Int -> Int+         -> [Sealed2 p] -> [Sealed2 p]+         -> IO ()+textView _ _ _ _ [] = return ()+textView o n_max n+            ps_done ps_todo@(p:ps_todo') = do+      defaultPrintFriendly p+      repeatThis -- prompt the user+    where+        defaultPrintFriendly =+          unseal2 (printFriendly (verbosity o) (withSummary o))+        prev_patch :: IO ()+        prev_patch = case ps_done of+                       [] -> repeatThis+                       (p':ps_done') ->+                         textView o+                            n_max (n-1) ps_done' (p':ps_todo)+        next_patch :: IO ()+        next_patch = case ps_todo' of+                         [] -> -- May as well work out the length now we have all+                                  -- the patches in memory+                               textView o n_max+                                   n ps_done []+                         _ -> textView o n_max+                                  (n+1) (p:ps_done) ps_todo'+        first_patch = textView o n_max 0 [] (ps_done++ps_todo)+        options_yn =+          [ KeyPress 'y' "view this patch and go to the next"+          , KeyPress 'n' "skip to the next patch" ]+        optionsView' =+          [ KeyPress 'v' "view this patch in full"+          , KeyPress 'p' "view this patch in full with pager"+          , KeyPress 'r' "view this patch" ]+        optionsSummary' =+          [ KeyPress 'x' "view a summary of this patch" ]+        optionsNav' =+          [ KeyPress 'q' "quit view changes"+          , KeyPress 'k' "back up to previous patch"+          , KeyPress 'j' "skip to next patch"+          , KeyPress 'g' "start over from the first patch"+          , KeyPress 'c' "count total patch number" ]+        basicOptions = [ options_yn ]+        advancedOptions =+                     (optionsView' +++                        if withSummary o == YesSummary then [] else optionsSummary')+                  : [ optionsNav' ]+        prompt' = "Shall I view this patch? "+               ++ "(" ++ show (n+1) ++ "/" ++ maybe "?" show n_max ++ ")"+        repeatThis :: IO ()+        repeatThis = do+          yorn <- promptChar (PromptConfig prompt' (keysFor basicOptions) (keysFor advancedOptions) (Just 'n') "?h")+          case yorn of+            'y' -> unseal2 printContent p >> next_patch+            'n' -> next_patch+            'v' -> unseal2 printContent p >> repeatThis+            'p' -> unseal2 printContentWithPager p >> repeatThis+            'r' -> do defaultPrintFriendly p+                      repeatThis+            'x' -> do unseal2 printSummary p+                      repeatThis+            'q' -> exitSuccess+            'k' -> prev_patch+            'j' -> next_patch+            'g' -> first_patch+            'c' -> textView o+                       count_n_max n ps_done ps_todo+            _   -> do putStrLn $ helpFor "view changes" basicOptions advancedOptions+                      repeatThis+        count_n_max | isJust n_max = n_max+                    | otherwise    = Just $ length ps_done + length ps_todo++-- | Skips patches we should not ask the user about+skipMundane :: (Commute p, ShowPatch p)+            => InteractiveSelectionM p wX wY ()+skipMundane = do+  (FZipper lps_done lps_todo) <- gets lps+  o <- asks opts+  crit <- asks matchCriterion+  jn <- asks jobname+  (skipped :> unskipped) <- liftChoices $ spanFL_M+                                 (state . patchSlot >=> return . decided)+                                 lps_todo+  let numSkipped = lengthFL skipped+  when (numSkipped > 0) . liftIO $ show_skipped o jn numSkipped skipped+  let boringThenInteresting =+          if selectDeps o == AutoDeps+          then spanFL (not . mcFunction crit . unLabel) unskipped+          else NilFL :> unskipped+  case boringThenInteresting of+    boring :> interesting ->+        do+          justDone $ lengthFL boring + numSkipped+          modify $ \isc -> isc {lps = FZipper (lps_done +<<+ skipped +<<+ boring)+                                      interesting}+    where+      show_skipped o jn n ps = do putStrLn $ _nevermind_ jn ++ _these_ n ++ "."+                                  when (verbosity o == Verbose) $+                                       showskippedpatch ps+      _nevermind_ jn = "Will not ask whether to " ++ jn ++ " "+      _these_ n  = show n ++ " already decided " ++ _elem_ n ""+      _elem_ n = englishNum n (Noun "patch")+      showskippedpatch :: ShowPatch p => FL (LabelledPatch p) wY wZ -> IO ()+      showskippedpatch =+        putDocLnWith fancyPrinters . vcat . mapFL (showFriendly NormalVerbosity NoSummary . unLabel)++decided :: Slot -> Bool+decided InMiddle = False+decided _ = True++-- | The action bound to space, depending on the current status of the+-- patch.+getDefault :: Bool -> Slot -> Char+getDefault _ InMiddle = 'w'+getDefault True InFirst  = 'n'+getDefault True InLast   = 'y'+getDefault False InFirst = 'y'+getDefault False InLast  = 'n'++-- | For a given sequence of preceding patches to choose from, and a sequence+-- of prims which will become a new named patch, let the user select a subset+-- such that the new patch will explicitly depend on them. The patches offered+-- include only those that the new patch does not already depend on. To support+-- amend, we pass in the old dependencies, too.+askAboutDepends+  :: (RepoPatch p, ApplyState p ~ Tree)+  => RL (PatchInfoAnd p) wX wR  -- ^ patches to choose from+  -> FL (PrimOf p) wR wT        -- ^ tentative content of new patch+  -> PatchSelectionOptions+  -> [PatchInfo]                -- ^ old explicit dependencies+  -> IO [PatchInfo]+askAboutDepends to_ask pa' ps_opts olddeps = do+  -- Ideally we'd just default the olddeps to yes but still ask about them.+  -- SelectChanges doesn't currently (17/12/09) offer a way to do this so would+  -- have to have this support added first. This is not easy to do, though.++  -- As a cheap alternative we do two selection passes: one where the user can+  -- drop old dependencies and one where they can add new ones.+  _ :> to_drop <-+    runSelection (reverseRL to_ask) $+      -- An explicit dependency that we /drop/ can be commuted to the right+      -- i.e. forward in the history without dragging others with them, thus we+      -- use LastReversed. We also use a custom match criterion to offer only+      -- patches we do explicitly depend on.+      selectionConfigDepends LastReversed "drop dependency on" (`elem` olddeps)+  let keep = olddeps \\ mapFL info to_drop+      dropped = olddeps \\ keep+  -- Note: using anonymous here is safe since we don't store any patches+  -- and only return a list of PatchInfo+  pa <- n2pia . flip adddeps keep <$> anonymous pa'+  -- get rid of all (implicit and explicit) dependencies of pa+  _ :> _ :> non_deps <- return $ commuteWhatWeCanRL (to_ask :> pa)+  candidates :> _ <-+    runSelection (reverseRL non_deps) $+      -- Adding explicit dependencies should drag dependent patches with them+      -- (though they will be filtered out later), so we use FirstReversed. The+      -- matcher is there so we don't re-offer dependencies we dropped in the+      -- previous run.+      selectionConfigDepends FirstReversed "depend on" (`notElem` dropped)+  return $ keep `union` independentPatchIds (reverseFL candidates)+  where+    selectionConfigDepends whch name matchFn =+      PSC+        { opts = ps_opts {matchFlags = [], interactive = True}+        , splitter = Nothing+        , files = Nothing+        , matchCriterion =+            MatchCriterion+              {mcHasNonrange = True, mcFunction = matchFn . info}+        , jobname = name+        , allowSkipAll = True+        , whichChanges = whch+        }++-- | From an 'RL' of patches select the identities of those that are+-- not depended upon by later patches.+independentPatchIds :: (Commute p, Ident p) => RL p wX wY -> [PatchId p]+independentPatchIds NilRL = []+independentPatchIds (ps :<: p) =+  case commuteWhatWeCanRL (ps :> p) of+    _ :> _ :> non_deps ->+      ident p : independentPatchIds non_deps
+ src/Darcs/UI/TestChanges.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.TestChanges ( testTree ) where++import Darcs.Prelude++import System.Exit ( ExitCode(..) )+import System.Process ( system )++import Darcs.UI.Commands ( putInfo )+import Darcs.UI.Options ( Config, (?) )+import qualified Darcs.UI.Options.All as O+import Darcs.Repository.Prefs ( getPrefval )+import Darcs.Repository.Working ( setAllScriptsExecutable )++import Darcs.Util.Lock ( withTempDir, withPermDir )+import Darcs.Util.Path ( toPath )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Tree ( Tree )+import Darcs.Util.Tree.Plain ( writePlainTree )++testTree :: Config -> Tree IO -> IO ExitCode+testTree cfg tree = do+  debugMessage "Considering whether to test..."+  ifRunTest (O.testChanges ? cfg) $ \leaveTestDir -> do+    debugMessage "About to run test if it exists."+    testline <- getPrefval "test"+    case testline of+      Nothing -> return ExitSuccess+      Just testcode -> do+        withDir leaveTestDir "testing" $ \dir -> do+          writePlainTree tree (toPath dir)+          putInfo cfg "Running test..."+          sse (O.setScriptsExecutable ? cfg)+          ec <- system testcode+          putInfo cfg $+            if ec == ExitSuccess+              then "Test ran successfully."+              else "Test failed!"+          return ec+  where+    withDir O.YesLeaveTestDir = withPermDir+    withDir O.NoLeaveTestDir = withTempDir+    sse O.YesSetScriptsExecutable = setAllScriptsExecutable+    sse O.NoSetScriptsExecutable = return ()+    ifRunTest (O.YesTestChanges leaveTestDir) test = test leaveTestDir+    ifRunTest O.NoTestChanges _ = return ExitSuccess
+ src/Darcs/UI/TheCommands.hs view
@@ -0,0 +1,102 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.UI.TheCommands ( commandControlList ) where+++import Darcs.UI.Commands.Add ( add )+import Darcs.UI.Commands.Amend ( amend, amendrecord )+import Darcs.UI.Commands.Annotate ( annotate )+import Darcs.UI.Commands.Apply ( apply )+import Darcs.UI.Commands.Clone ( clone, get, put )+import Darcs.UI.Commands.Convert ( convert )+import Darcs.UI.Commands.Diff ( diffCommand )+import Darcs.UI.Commands.Dist ( dist )+import Darcs.UI.Commands.GZCRCs ( gzcrcs )+import Darcs.UI.Commands.Init ( initialize )+import Darcs.UI.Commands.Log ( log, changes )+import Darcs.UI.Commands.Show ( showCommand )+import Darcs.UI.Commands.MarkConflicts ( markconflicts )+import Darcs.UI.Commands.Move ( move, mv )+import Darcs.UI.Commands.Optimize ( optimize )+import Darcs.UI.Commands.Pull ( pull, fetch )+import Darcs.UI.Commands.Push ( push )+import Darcs.UI.Commands.Rebase ( rebase )+import Darcs.UI.Commands.Record ( record, commit )+import Darcs.UI.Commands.Remove ( remove, rm, unadd )+import Darcs.UI.Commands.Repair ( repair, check )+import Darcs.UI.Commands.Replace ( replace )+import Darcs.UI.Commands.Revert ( revert, clean )+import Darcs.UI.Commands.Rollback ( rollback )+import Darcs.UI.Commands.Send ( send )+import Darcs.UI.Commands.SetPref ( setpref )+import Darcs.UI.Commands.Tag ( tag )+import Darcs.UI.Commands.Test ( test )+import Darcs.UI.Commands.TransferMode ( transferMode )+import Darcs.UI.Commands.Unrecord ( unrecord, unpull, obliterate )+import Darcs.UI.Commands.Unrevert ( unrevert )+import Darcs.UI.Commands.WhatsNew ( whatsnew, status )+import Darcs.UI.Commands ( CommandControl, normalCommand, hiddenCommand, commandGroup )++-- | The commands that darcs knows about (e.g. whatsnew, record),+--   organized into thematic groups.  Note that hidden commands+--   are also listed here.+commandControlList :: [CommandControl]+commandControlList =+    [ commandGroup "Most used/starting out:"+    , normalCommand initialize+    , normalCommand add+    , normalCommand whatsnew, hiddenCommand status+    , normalCommand record, hiddenCommand commit+    , normalCommand clone, hiddenCommand get, hiddenCommand put+    , normalCommand pull+    , normalCommand push+    , commandGroup "Preparing patches before recording:"+    , normalCommand move, hiddenCommand mv+    , normalCommand remove, hiddenCommand unadd, hiddenCommand rm+    , normalCommand replace+    , commandGroup "Querying the repository:"+    , normalCommand log, hiddenCommand changes+    , normalCommand annotate+    , normalCommand diffCommand+    , normalCommand showCommand+    , normalCommand test+    , commandGroup "Undoing and correcting:"+    , normalCommand revert+    , normalCommand unrevert+    , normalCommand amend, hiddenCommand amendrecord+    , normalCommand rebase+    , normalCommand rollback+    , normalCommand unrecord+    , normalCommand obliterate, hiddenCommand unpull+    , normalCommand clean+    , commandGroup "Direct modification of the repository:"+    , normalCommand tag+    , normalCommand setpref+    , commandGroup "Exchanging patches by e-mail:"+    , normalCommand send+    , normalCommand apply+    , commandGroup "Other commands:"+    , normalCommand optimize+    , normalCommand dist+    , normalCommand markconflicts+    , normalCommand repair, hiddenCommand check+    , normalCommand convert+    , normalCommand fetch+    , hiddenCommand gzcrcs+    , hiddenCommand transferMode+    ]
+ src/Darcs/UI/Usage.hs view
@@ -0,0 +1,186 @@+{-# LANGUAGE OverloadedStrings #-}+module Darcs.UI.Usage+    ( getCommandHelp+    , getSuperCommandHelp+    , getCommandMiniHelp+    , usage+    , subusage+    ) where++import Darcs.Prelude++import Data.Functor.Compose+import Safe ( headErr )+import System.Console.GetOpt( OptDescr(..), ArgDescr(..) )+import Darcs.UI.Options.All ( stdCmdActions )+import Darcs.UI.Commands+    ( CommandControl(..)+    , DarcsCommand(..)+    , commandName+    , commandDescription+    , getSubcommands+    , commandAlloptions+    )+import Darcs.UI.Options ( DarcsOptDescr, odesc )+import Darcs.Util.Printer+    ( Doc, text, vsep, ($$), vcat, hsep+    , renderString+    )++formatOptions :: [DarcsOptDescr a] -> [String]+formatOptions optDescrs = table+   where (ss,ls,ds)     = (unzip3 . concatMap fmtOpt) optDescrs+         table          = zipWith3 paste+                            shortPadded+                            (zipWith (++) (map (unlines' . init) ls)+                                          (sameLen $ map last ls))+                            ds+         shortPadded    = sameLen ss+         prePad         = replicate (3 + length (headErr shortPadded)) ' '+         -- Similar to unlines (additional ',' and padding):+         unlines'       = concatMap (\x -> x ++ ",\n" ++ prePad)+         -- Unchanged:+         paste x y z    = "  " ++ x ++ " " ++ y ++ "  " ++ z+         sameLen xs     = flushLeft ((maximum . map length) xs) xs+         flushLeft n xs = [ take n (x ++ repeat ' ') | x <- xs ]++-- Mild variant of the standard definition: 'losFmt' is a list rather than a+-- comma separated string.+fmtOpt :: DarcsOptDescr a -> [(String,[String],String)]+fmtOpt (Compose (Option sos los ad descr)) =+   case lines descr of+     []     -> [(sosFmt,losFmt,"")]+     (d:ds) ->  (sosFmt,losFmt,d) : [ ("",[],d') | d' <- ds ]+   where endBy _  []     = ""+         endBy ch [x]    = x ++ [ch]+         endBy ch (x:xs) = x ++ ch:' ':endBy ch xs+         sosFmt = endBy ',' (map fmtShort sos)+         losFmt = map (fmtLong ad) los++--------------------------------------------------------------------------------+-- Verbatim copies: these definitions aren't exported by System.Console.GetOpt+--------------------------------------------------------------------------------++fmtShort :: Char -> String+fmtShort so = "-" ++ [so]++fmtLong :: ArgDescr a -> String -> String+fmtLong (NoArg  _   ) lo = "--" ++ lo+fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad+fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]"+--------------------------------------------------------------------------------++usage :: [CommandControl] -> Doc+usage cs = vsep +    [ "Usage: darcs COMMAND ..."+    , "Commands:" $$ usageHelper cs+    , vcat+      [ "Use 'darcs help COMMAND' or 'darcs COMMAND --help' for help on a single command."+      , "Use 'darcs help patterns' for help on patch matching."+      , "Use 'darcs help environment' for help on environment variables."+      , "Use 'darcs help manpage' to display help in the manpage format."+      , "Use 'darcs help markdown' to display help in the markdown format."+      , "Use 'darcs --version' to see the darcs version number."+      , "Use 'darcs --exact-version' to see a detailed darcs version."+      ]+    , "Check bug reports at http://bugs.darcs.net/"+    ]++subusage :: DarcsCommand -> Doc+subusage super = vsep+    [ superUsage super $$ text (commandDescription super)+    , usageHelper (getSubcommands super)+    , "Options:"+    , vcat $ map text $ formatOptions $ odesc stdCmdActions+    , commandHelp super+    ]++superUsage :: DarcsCommand -> Doc+superUsage super = hsep $ map text+    [ "Usage:"+    , commandProgramName super+    , commandName super+    , "SUBCOMMAND [OPTION]..."+    ]++usageHelper :: [CommandControl] -> Doc+usageHelper xs = vsep (groups xs)+  where+    groups [] = []+    groups (HiddenCommand _:cs) = groups cs+    groups (GroupName n:cs) =+      mempty : case groups cs of+        [] -> [text n]+        (g:gs) -> (text n $$ g) : gs+    groups (CommandData c:cs) =+      case groups cs of+        [] -> [cmdHelp c]+        (g:gs) -> (cmdHelp c $$ g) : gs++    cmdHelp c = text $ "  " +++      padSpaces maxwidth (commandName c) +++      commandDescription c++    padSpaces n s = s ++ replicate (n - length s) ' '++    maxwidth = maximum $ 15 : (map cwidth xs)++    cwidth (CommandData c) = length (commandName c) + 2+    cwidth _               = 0++getCommandMiniHelp :: Maybe DarcsCommand -> DarcsCommand -> String+getCommandMiniHelp msuper cmd = renderString $ vsep+    [ getCommandHelpCore msuper cmd+    , hsep $ map text+        [ "See"+        , commandProgramName cmd+        , "help"+        , maybe "" ((++ " ") . commandName) msuper ++ commandName cmd+        , "for details."+        ]+    ]++getCommandHelp :: Maybe DarcsCommand -> DarcsCommand -> Doc+getCommandHelp msuper cmd = vsep+    [ getCommandHelpCore msuper cmd+    , subcommandsHelp+    , withHeading "Options:" basicOptionsHelp+    , withHeading "Advanced options:" advancedOptionsHelp+    , commandHelp cmd+    ]+  where+    withHeading _ [] = mempty+    withHeading h ls = vcat (text h : map text ls)++    (basic, advanced) = commandAlloptions cmd+    -- call formatOptions with combined options so that+    -- both get the same formatting+    (basicOptionsHelp, advancedOptionsHelp) =+        splitAt (length basic) $ formatOptions (basic ++ advanced)++    subcommandsHelp =+      case msuper of+        Nothing -> usageHelper (getSubcommands cmd)+        -- we don't want to list subcommands if we're already specifying them+        Just _ -> mempty++getSuperCommandHelp :: DarcsCommand -> Doc+getSuperCommandHelp super =+  vsep [superUsage super, usageHelper (getSubcommands super), commandHelp super]++getCommandHelpCore :: Maybe DarcsCommand -> DarcsCommand -> Doc+getCommandHelpCore msuper cmd = vcat+    [ hsep $+        [ "Usage:"+        , text $ commandProgramName cmd+        , maybe mempty (text . commandName) msuper+        , text $ commandName cmd+        , "[OPTION]..."+        ]+        ++ args_help+    , text $ commandDescription cmd+    ]+  where+    args_help = case cmd of+                    (DarcsCommand {}) -> map text $ commandExtraArgHelp cmd+                    _ -> []
− src/Darcs/URL.hs 
@@ -1,126 +0,0 @@-{-# LANGUAGE CPP #-}--{--Copyright (C) 2004 David Roundy--This program is free software; you can redistribute it and/or modify-it under the terms of the GNU General Public License as published by-the Free Software Foundation; either version 2, or (at your option)-any later version.--This program is distributed in the hope that it will be useful,-but WITHOUT ANY WARRANTY; without even the implied warranty of-MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the-GNU General Public License for more details.--You should have received a copy of the GNU General Public License-along with this program; see the file COPYING.  If not, write to-the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,-Boston, MA 02110-1301, USA.--}--{-|--  Path resolving:--    * An http URL contains the sequence @\"http(s):\/\/\"@.--    * A local filepath does not contain colons, except-      as second character (windows drives) when this-      filepath is meant to be used as repository name--    * A path that is neither an http URL nor a local file-      is an ssh-path.--  Examples:--  > /usr/repo/foo                 -- local file-  > c:/src/darcs                  -- local file-  > http://darcs.net/             -- URL-  > peter@host:/path              -- ssh-  > droundy@host:                 -- ssh-  > host:/path                    -- ssh--  This means that single-letter hosts in ssh-paths do not work,-  unless a username is provided.--  Perhaps ssh-paths should use @\"ssh:\/\/user\@host\/path\"@-syntax instead?--}--module Darcs.URL (-    isFile, isHttpUrl, isSshUrl, isRelative, isAbsolute,-    isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, urlOf, splitSshUrl-  ) where--import Darcs.Global(darcsdir)-import Data.List ( isPrefixOf, isInfixOf )-import Data.Char ( isSpace )-import qualified System.FilePath as FP (isRelative, isAbsolute, isValid)--#include "impossible.h"--isRelative :: String -> Bool-isRelative "" = bug "Empty filename in isRelative"-isRelative f  = FP.isRelative f--isAbsolute :: String -> Bool-isAbsolute "" = bug "isAbsolute called with empty filename"-isAbsolute f = FP.isAbsolute f--isFile :: String -> Bool-isFile f@(_:_:fou) = ':' `notElem` fou && FP.isValid f-isFile f = FP.isValid f--isHttpUrl :: String -> Bool-isHttpUrl u =-    let u' = dropWhile isSpace u in-            ("http://" `isPrefixOf` u') || ("https://" `isPrefixOf` u')---isSshUrl :: String -> Bool-isSshUrl s = isu' (dropWhile isSpace s)-    where-      isu' s'-          | "ssh://" `isPrefixOf` s' = True-          | "://" `isInfixOf` s' = False-          | isFile s' = False-          | otherwise = ":" `isInfixOf` s'--isSshNopath :: String -> Bool-isSshNopath s = case reverse s of-                  ':':x@(_:_:_) -> ':' `notElem` x-                  _ -> False---- | Gives the (user, host, dir) out of an ssh url-splitSshUrl :: String -> SshFilePath-splitSshUrl s | "ssh://" `isPrefixOf` s =-  let s' = drop (length "ssh://") $ dropWhile isSpace s-      (dir, file) = cleanrepodir '/' s'-  in-  SshFP { sshUhost = takeWhile (/= '/') s'-        , sshRepo = dir-        , sshFile = file }-splitSshUrl s =-  let (dir, file) = cleanrepodir ':' s in-  SshFP { sshUhost = dropWhile isSpace $ takeWhile (/= ':') s-        , sshRepo = dir-        , sshFile = file }---cleanrepourl :: String -> (String, String)-cleanrepourl zzz | dd `isPrefixOf` zzz = ([], drop (length dd) zzz)-                 where dd = darcsdir++"/"-cleanrepourl (z:zs) =-  let (repo',file) = cleanrepourl zs in-  (z : repo', file)-cleanrepourl "" = ([],[])--cleanrepodir :: Char -> String -> (String, String)-cleanrepodir sep = cleanrepourl . drop 1 . dropWhile (/= sep)--data SshFilePath = SshFP { sshUhost :: String-                        , sshRepo :: String-                        , sshFile :: String}--urlOf :: SshFilePath -> String-urlOf (SshFP uhost dir file) = uhost ++ ":" ++ dir ++ "/" ++ darcsdir ++ "/" ++ file
+ src/Darcs/Util/AtExit.hs view
@@ -0,0 +1,66 @@+-- Copyright (C) 2005 Tomasz Zielonka+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module      : Darcs.Util.AtExit+-- Copyright   : 2005 Tomasz Zielonka+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable+--+-- This was originally Tomasz Zielonka's AtExit module, slightly generalised+-- to include global variables.  Here, we attempt to cover broad, global+-- features, such as exit handlers.  These features slightly break the Haskellian+-- purity of darcs, in favour of programming convenience.++module Darcs.Util.AtExit ( atexit , withAtexit ) where++import Darcs.Prelude++import Control.Concurrent.MVar+import Control.Exception ( SomeException, catch, finally )+import System.IO ( hPrint, hPutStrLn, stderr )+import System.IO.Unsafe ( unsafePerformIO )++atexitActions :: MVar (Maybe [IO ()])+atexitActions = unsafePerformIO (newMVar (Just []))+{-# NOINLINE atexitActions #-}++-- | Registers an IO action to run just before darcs exits. Useful for removing+-- temporary files and directories, for example. Referenced in Issue1914.+atexit :: IO () -> IO ()+atexit action =+    modifyMVar_ atexitActions $ \ml ->+        case ml of+            Just l ->+                return (Just (action : l))+            Nothing -> do+                hPutStrLn stderr "It's too late to use atexit"+                return Nothing++withAtexit :: IO a -> IO a+withAtexit job = job `finally` runAtexitActions+  where+    runAtexitActions = do+        Just actions <- swapMVar atexitActions Nothing+        -- from now on atexit will not register new actions+        mapM_ runAction actions+    runAction action =+        catch action $ \(exn :: SomeException) -> do+            hPutStrLn stderr "Exception thrown by an atexit registered action:"+            hPrint stderr exn
+ src/Darcs/Util/ByteString.hs view
@@ -0,0 +1,423 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Darcs.Util.ByteString+-- Copyright   :  (c) The University of Glasgow 2001,+--                    David Roundy 2003-2005+-- License : GPL (I'm happy to also license this file BSD style but don't+--           want to bother distributing two license files with darcs.+--+-- Maintainer  :  droundy@abridgegame.org+-- Stability   :  experimental+-- Portability :  portable+--+-- GZIp and MMap IO for ByteStrings, encoding utilities, and miscellaneous+-- functions for Data.ByteString+--+module Darcs.Util.ByteString+    (+    -- * IO with mmap or gzip+      gzReadFilePS+    , mmapFilePS+    , gzWriteFilePS+    , gzWriteFilePSs+    , gzReadStdin+    , gzWriteHandle+    , FileSegment+    , readSegment+    -- * gzip handling+    , isGZFile+    , gzDecompress+    -- * list utilities+    , dropSpace+    , linesPS+    , unlinesPS+    , hashPS+    , breakFirstPS+    , breakLastPS+    , substrPS+    , isFunky+    , fromHex2PS+    , fromPS2Hex+    , betweenLinesPS+    , intercalate+    -- * encoding and unicode utilities+    , isAscii+    , decodeLocale+    , encodeLocale+    , unpackPSFromUTF8+    , packStringToUTF8+    -- * properties+    , prop_unlinesPS_linesPS_left_inverse+    , prop_linesPS_length+    , prop_unlinesPS_length+    , propHexConversion+    , spec_betweenLinesPS+    ) where++import Darcs.Prelude++import qualified Data.ByteString            as B+import qualified Data.ByteString.Char8      as BC+import qualified Data.ByteString.Lazy       as BL+import Data.ByteString (intercalate)+import qualified Data.ByteString.Base16     as B16++import System.Directory ( getFileSize )+import System.IO ( withFile, IOMode(ReadMode)+                 , hSeek, SeekMode(SeekFromEnd,AbsoluteSeek)+                 , openBinaryFile, hClose, Handle, hGetChar+                 , stdin)+import System.IO.Error          ( catchIOError )+import System.IO.Unsafe         ( unsafePerformIO )++import Data.Bits                ( rotateL )+import Data.Char                ( ord )+import Data.Word                ( Word8 )+import Data.Int                 ( Int32, Int64 )+import Data.List                ( intersperse )+import Control.Monad            ( when )+import Control.Monad.ST.Lazy    ( ST )++import qualified Codec.Compression.GZip as GZ+import qualified Codec.Compression.Zlib.Internal as ZI+import Darcs.Util.Encoding ( decode, encode, decodeUtf8, encodeUtf8 )+import Darcs.Util.Global ( addCRCWarning )++#if mingw32_HOST_OS+#else+import System.IO.MMap( mmapFileByteString )+#endif+import System.Mem( performGC )++------------------------------------------------------------------------+-- A locale-independent isspace(3) so patches are interpreted the same everywhere.+-- ((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) == '\r')+isSpaceWord8 :: Word8 -> Bool+isSpaceWord8 0x20 = True+isSpaceWord8 0x09 = True+isSpaceWord8 0x0A = True+isSpaceWord8 0x0D = True+isSpaceWord8 _    = False+{-# INLINE isSpaceWord8 #-}++-- | Drop leading white space, where white space is defined as+-- consisting of ' ', '\t', '\n', or '\r'.+dropSpace :: B.ByteString -> B.ByteString+dropSpace bs = B.dropWhile isSpaceWord8 bs++------------------------------------------------------------------------++{-# INLINE isFunky #-}+isFunky :: B.ByteString -> Bool+isFunky ps = 0 `B.elem` ps || 26 `B.elem` ps++------------------------------------------------------------------------++{-# INLINE hashPS #-}+hashPS :: B.ByteString -> Int32+hashPS = B.foldl' hashByte 0++{-# INLINE hashByte #-}+hashByte :: Int32 -> Word8 -> Int32+hashByte h x = fromIntegral x + rotateL h 8++{-# INLINE substrPS #-}+substrPS :: B.ByteString -> B.ByteString -> Maybe Int+substrPS tok str+    | B.null tok = Just 0+    | B.length tok > B.length str = Nothing+    | otherwise = do n <- B.elemIndex (B.head tok) str+                     let ttok = B.tail tok+                         reststr = B.drop (n+1) str+                     if ttok == B.take (B.length ttok) reststr+                        then Just n+                        else ((n+1)+) `fmap` substrPS tok reststr++------------------------------------------------------------------------++-- TODO: replace breakFirstPS and breakLastPS with definitions based on+-- ByteString's break/breakEnd+{-# INLINE breakFirstPS #-}+breakFirstPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)+breakFirstPS c p = case BC.elemIndex c p of+                   Nothing -> Nothing+                   Just n -> Just (B.take n p, B.drop (n+1) p)++{-# INLINE breakLastPS #-}+breakLastPS :: Char -> B.ByteString -> Maybe (B.ByteString,B.ByteString)+breakLastPS c p = case BC.elemIndexEnd c p of+                  Nothing -> Nothing+                  Just n -> Just (B.take n p, B.drop (n+1) p)++------------------------------------------------------------------------+-- linesPS and unlinesPS++{-# INLINE linesPS #-}+-- | Split the input into lines, that is, sections separated by '\n' bytes,+-- unless it is empty, in which case the result has one empty line.+linesPS :: B.ByteString -> [B.ByteString]+linesPS ps+     | B.null ps = [B.empty]+     | otherwise = BC.split '\n' ps++{-# INLINE unlinesPS #-}+-- | Concatenate the inputs with '\n' bytes in interspersed.+unlinesPS :: [B.ByteString] -> B.ByteString+unlinesPS = B.concat . intersperse (BC.singleton '\n')++-- properties of linesPS and unlinesPS++prop_unlinesPS_linesPS_left_inverse :: B.ByteString -> Bool+prop_unlinesPS_linesPS_left_inverse x = unlinesPS (linesPS x) == x++prop_linesPS_length :: B.ByteString -> Bool+prop_linesPS_length x = length (linesPS x) == length (BC.elemIndices '\n' x) + 1++prop_unlinesPS_length :: [B.ByteString] -> Bool+prop_unlinesPS_length xs =+  B.length (unlinesPS xs) == if null xs then 0 else sum (map B.length xs) + length xs - 1++-- -----------------------------------------------------------------------------+-- gzReadFilePS++-- |Decompress the given bytestring into a lazy list of chunks, along with a boolean+-- flag indicating (if True) that the CRC was corrupted.+-- Inspecting the flag will cause the entire list of chunks to be evaluated (but if+-- you throw away the list immediately this should run in constant space).+gzDecompress :: Maybe Int -> BL.ByteString -> ([B.ByteString], Bool)+gzDecompress mbufsize =+    -- This is what the code would be without the bad CRC recovery logic:+    -- return . BL.toChunks . GZ.decompressWith decompressParams+    decompressWarn (ZI.decompressST ZI.gzipFormat decompressParams)+  where+        decompressParams = case mbufsize of+                              Just bufsize -> GZ.defaultDecompressParams { GZ.decompressBufferSize = bufsize }+                              Nothing -> GZ.defaultDecompressParams++        decompressWarn :: (forall s . ZI.DecompressStream (ST s)) -> BL.ByteString -> ([B.ByteString], Bool)+        decompressWarn = ZI.foldDecompressStreamWithInput+                           (\x ~(xs, b) -> (x:xs, b))+                           (\xs -> if BL.null xs+                                      then ([], False)+                                      else error "trailing data at end of compressed stream"+                           )+                           handleBad++        -- For a while a bug in darcs caused gzip files with good data but bad CRCs to be+        -- produced. Trap bad CRC messages, run the specified action to report that it happened,+        -- but continue on the assumption that the data is valid.+        handleBad (ZI.DataFormatError "incorrect data check") = ([], True)+        handleBad e = error (show e)++isGZFile :: FilePath -> IO (Maybe Int)+isGZFile f = do+    h <- openBinaryFile f ReadMode+    header <- B.hGet h 2+    if header /= B.pack [31,139]+       then do hClose h+               return Nothing+       else do hSeek h SeekFromEnd (-4)+               len <- hGetLittleEndInt h+               hClose h+               return (Just len)++-- | Read an entire file, which may or may not be gzip compressed, directly+-- into a 'B.ByteString'.+gzReadFilePS :: FilePath -> IO B.ByteString+gzReadFilePS f = do+    mlen <- isGZFile f+    case mlen of+       Nothing -> mmapFilePS f+       Just len ->+            do -- Passing the length to gzDecompress means that it produces produces one chunk,+               -- which in turn means that B.concat won't need to copy data.+               -- If the length is wrong this will just affect efficiency, not correctness+               let doDecompress buf = let (res, bad) = gzDecompress (Just len) buf+                                      in do when bad $ addCRCWarning f+                                            return res+               compressed <- (BL.fromChunks . return) `fmap` mmapFilePS f+               B.concat `fmap` doDecompress compressed++hGetLittleEndInt :: Handle -> IO Int+hGetLittleEndInt h = do+    b1 <- ord `fmap` hGetChar h+    b2 <- ord `fmap` hGetChar h+    b3 <- ord `fmap` hGetChar h+    b4 <- ord `fmap` hGetChar h+    return $ b1 + 256*b2 + 65536*b3 + 16777216*b4++gzWriteFilePS :: FilePath -> B.ByteString -> IO ()+gzWriteFilePS f ps = gzWriteFilePSs f [ps]++gzWriteFilePSs :: FilePath -> [B.ByteString] -> IO ()+gzWriteFilePSs f pss  =+    BL.writeFile f $ GZ.compress $ BL.fromChunks pss++gzWriteHandle :: Handle -> [B.ByteString] -> IO ()+gzWriteHandle h pss  =+    BL.hPut h $ GZ.compress $ BL.fromChunks pss++-- | Read standard input, which may or may not be gzip compressed, directly+-- into a 'B.ByteString'.+gzReadStdin :: IO B.ByteString+gzReadStdin = do+    header <- B.hGet stdin 2+    rest   <- B.hGetContents stdin+    let allStdin = B.concat [header,rest]+    return $+     if header /= B.pack [31,139]+      then allStdin+      else let decompress = fst . gzDecompress Nothing+               compressed = BL.fromChunks [allStdin]+           in+           B.concat $ decompress compressed++-- | Pointer to a filesystem, possibly with start/end offsets. Supposed to be+-- fed to (uncurry mmapFileByteString) or similar.+type FileSegment = (FilePath, Maybe (Int64, Int))++-- | Read in a FileSegment into a Lazy ByteString. Implemented using mmap.+readSegment :: FileSegment -> IO BL.ByteString+readSegment (f,range) = do+    bs <- tryToRead+       `catchIOError` (\_ -> do+                     size <- getFileSize f+                     if size == 0+                        then return B.empty+                        else performGC >> tryToRead)+    return $ BL.fromChunks [bs]+  where+    tryToRead =+        case range of+            Nothing -> B.readFile f+            Just (off, size) -> withFile f ReadMode $ \h -> do+                hSeek h AbsoluteSeek $ fromIntegral off+                B.hGet h size+{-# INLINE readSegment #-}++-- -----------------------------------------------------------------------------+-- mmapFilePS++-- | Like readFilePS, this reads an entire file directly into a+-- 'B.ByteString', but it is even more efficient.  It involves directly+-- mapping the file to memory.  This has the advantage that the contents of+-- the file never need to be copied.  Also, under memory pressure the page+-- may simply be discarded, wile in the case of readFilePS it would need to+-- be written to swap.  If you read many small files, mmapFilePS will be+-- less memory-efficient than readFilePS, since each mmapFilePS takes up a+-- separate page of memory.  Also, you can run into bus errors if the file+-- is modified.++mmapFilePS :: FilePath -> IO B.ByteString+#if mingw32_HOST_OS+mmapFilePS = B.readFile+#else+mmapFilePS f =+  mmapFileByteString f Nothing+   `catchIOError` (\_ -> do+                     size <- getFileSize f+                     if size == 0+                        then return B.empty+                        else performGC >> mmapFileByteString f Nothing)+#endif++-- -------------------------------------------------------------------------+-- fromPS2Hex++fromPS2Hex :: B.ByteString -> B.ByteString+fromPS2Hex = B16.encode++-- -------------------------------------------------------------------------+-- fromHex2PS++fromHex2PS :: B.ByteString -> Either String B.ByteString+fromHex2PS s =+  case B16.decode s of+    Right result -> Right result+    Left msg -> Left $ "fromHex2PS: input is not hex encoded: "++msg++propHexConversion :: B.ByteString -> Bool+propHexConversion x = fromHex2PS (fromPS2Hex x) == Right x++-- -------------------------------------------------------------------------+-- betweenLinesPS++-- | Return the B.ByteString between the two lines given,+-- or Nothing if either of them does not appear.+--+-- Precondition: the first two arguments (start and end line)+-- must be non-empty and contain no newline bytes.+betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString+               -> Maybe B.ByteString+betweenLinesPS start end ps = do+  at_start <- findLine 0 start ps+  at_end <- findLine 0 end (B.drop (at_start + B.length start) ps)+  -- the "drop 1" eliminates the newline after start+  -- (a trailing newline before end, if present, is retained)+  return $ B.drop 1 $ B.take at_end $ B.drop (at_start + B.length start) ps+  where+    -- find index of substring x if it is a full line+    findLine i x s =+      case B.breakSubstring x s of+        (before, at)+          | B.null at -> Nothing -- not found at all+          | not (B.null after) && BC.head after /= '\n' -> do+              -- found but not followed by newline+              next_nl <- BC.elemIndex '\n' after+              findLine (i + i_after + next_nl) x (B.drop next_nl after)+          | not (B.null before) && BC.last before /= '\n' ->+              -- found, followed by newline but not preceded by newline+              findLine (i + i_after) x after+          | otherwise -> Just (i + i_before)+          where+            after = B.drop l_x at+            l_x = B.length x+            i_before = B.length before+            i_after = i_before + l_x++-- | Simpler but less efficient variant of 'betweenLinesPS'. Note+-- that this is only equivalent under the stated preconditions.+spec_betweenLinesPS :: B.ByteString -> B.ByteString -> B.ByteString+                    -> Maybe B.ByteString+spec_betweenLinesPS start end ps =+  case break (start ==) (linesPS ps) of+    (_, _:after_start) ->+      case break (end ==) after_start of+        (before_end, _:_) ->+          Just $ if null before_end then B.empty else BC.unlines before_end+        _ -> Nothing+    _ -> Nothing++-- | Test if a ByteString is made of ascii characters+isAscii :: B.ByteString -> Bool+isAscii = B.all (< 128)++-- * Encoding functions++-- Use of 'unsafePerformIO' is ratified by the fact that these+-- really are pure functions.++-- | Decode a 'ByteString' containing UTF-8 to a 'String'. Decoding errors+-- are flagged with the U+FFFD character.+unpackPSFromUTF8 :: B.ByteString -> String+unpackPSFromUTF8  = unsafePerformIO . decodeUtf8++-- | Encode a 'String' to a 'ByteString' using UTF-8.+packStringToUTF8 :: String -> B.ByteString+packStringToUTF8 = unsafePerformIO . encodeUtf8++-- | Decode a 'ByteString' to a 'String' according to the current locale,+-- using lone surrogates for un-decodable bytes.+decodeLocale :: B.ByteString -> String+decodeLocale = unsafePerformIO . decode++-- | Encode a 'String' to a 'ByteString' according to the current locale,+-- converting lone surrogates back to the original byte. If that+-- fails (because the locale does not support the full unicode range)+-- then encode using utf-8, assuming that the un-ecodable characters+-- come from patch meta data.+--+-- See also 'Darcs.UI.Commands.setEnvCautiously'.+encodeLocale :: String -> B.ByteString+encodeLocale s = unsafePerformIO $ encode s `catchIOError` (\_ -> encodeUtf8 s)
+ src/Darcs/Util/Cache.hs view
@@ -0,0 +1,583 @@+module Darcs.Util.Cache+    ( Cache+    , mkCache+    , mkDirCache+    , mkRepoCache+    , cacheEntries+    , CacheType(..)+    , CacheLoc(..)+    , WritableOrNot(..)+    , HashedDir(..)+    , hashedDir+    , bucketFolder+    , filterRemoteCaches+    , cleanCaches+    , cleanCachesWithHint+    , fetchFileUsingCache+    , speculateFileUsingCache+    , speculateFilesUsingCache+    , writeFileUsingCache+    , peekInCache+    , parseCacheLoc+    , showCacheLoc+    , writable+    , isThisRepo+    , hashedFilePath+    , allHashedDirs+    , reportBadSources+    , closestWritableDirectory+    , dropNonRepos+    ) where++import Control.Concurrent.MVar ( MVar, modifyMVar_, newMVar, readMVar )+import Control.Monad ( filterM, forM_, liftM, mplus, unless, when )+import qualified Data.ByteString as B ( ByteString )+import Data.List ( intercalate, nub, sortBy )+import Data.Maybe ( catMaybes, fromMaybe, listToMaybe )+import System.Directory+    ( createDirectoryIfMissing+    , doesDirectoryExist+    , doesFileExist+    , getDirectoryContents+    , getPermissions+    , removeFile+    , withCurrentDirectory+    )+import qualified System.Directory as SD ( writable )+import System.FilePath.Posix ( dropFileName, joinPath, (</>) )+import System.IO ( hPutStrLn, stderr )+import System.IO.Error ( isAlreadyExistsError )+import System.IO.Unsafe ( unsafePerformIO )+import System.Posix.Files ( createLink, getSymbolicLinkStatus, linkCount )+import Text.Regex.Applicative ( anySym, many, match, string, (<|>) )++import Darcs.Prelude++import Darcs.Util.ByteString ( gzWriteFilePS )+import Darcs.Util.English ( Noun(..), Pronoun(..), englishNum )+import Darcs.Util.Exception ( catchall, handleOnly )+import Darcs.Util.File+    ( Cachable(Cachable)+    , copyFileOrUrl+    , fetchFilePS+    , gzFetchFilePS+    , speculateFileOrUrl+    , withTemp+    )+import Darcs.Util.Global ( darcsdir, defaultRemoteDarcsCmd )+import Darcs.Util.Lock ( gzWriteAtomicFilePS )+import Darcs.Util.Progress ( debugMessage, progressList )+import Darcs.Util.URL ( isHttpUrl, isSshUrl, isValidLocalPath )+import Darcs.Util.ValidHash+    ( ValidHash(..)+    , HashedDir(..)+    , checkHash+    , encodeValidHash+    , okayHash+    , calcValidHash+    )++-- * Caches++hashedDir :: HashedDir -> FilePath+hashedDir HashedPristineDir = "pristine.hashed"+hashedDir HashedPatchesDir = "patches"+hashedDir HashedInventoriesDir = "inventories"++allHashedDirs :: [HashedDir]+allHashedDirs = [ HashedPristineDir+                , HashedPatchesDir+                , HashedInventoriesDir+                ]++data WritableOrNot = Writable+                   | NotWritable+                   deriving ( Eq, Show )++data CacheType = Repo+               | Directory+               deriving ( Eq, Show )++data CacheLoc = Cache+    { cacheType :: !CacheType+    , cacheWritable :: !WritableOrNot+    , cacheSource :: !String+    }++-- | Cache is an abstract type for hiding the underlying cache locations+newtype Cache = Ca [CacheLoc]++-- | Smart constructor for 'Cache'.+mkCache :: [CacheLoc] -> Cache+mkCache = Ca . nub . sortBy compareByLocality++mkDirCache :: FilePath -> Cache+mkDirCache dir = mkCache [Cache Directory Writable dir]++mkRepoCache :: FilePath -> Cache+mkRepoCache dir = mkCache [Cache Repo Writable dir]++cacheEntries :: Cache -> [CacheLoc]+cacheEntries (Ca entries) = entries++-- | Note: this non-structural instance ignores the 'cacheWritable' field. This+-- is so that when we 'nub' a list of locations we retain only one (the first)+-- variant.+instance Eq CacheLoc where+    (Cache aTy _ aSrc) == (Cache bTy _ bSrc) = aTy == bTy && aSrc == bSrc++showCacheLoc :: CacheLoc -> String+showCacheLoc (Cache Repo Writable a) = "thisrepo:" ++ a+showCacheLoc (Cache Repo NotWritable a) = "repo:" ++ a+showCacheLoc (Cache Directory Writable a) = "cache:" ++ a+showCacheLoc (Cache Directory NotWritable a) = "readonly:" ++ a++instance Show Cache where+    show (Ca cs) = intercalate "\n" $ map showCacheLoc cs++parseCacheLoc :: String -> Maybe CacheLoc+parseCacheLoc = match reCacheLoc+  where+    reCacheLoc =+      Cache Repo Writable <$> (string "thisrepo:" *> rest) <|>+      Cache Repo NotWritable <$> (string "repo:" *> rest) <|>+      Cache Directory Writable <$> (string "cache:" *> rest) <|>+      Cache Directory NotWritable <$> (string "readonly:" *> rest)+    rest = many anySym++-- | Filter caches for remote repos. This affects only entries that are locally+-- valid paths (i.e. not network URLs): they are removed if non-existent, or+-- demoted to NotWritable if they are not actually writable in the file system.+filterRemoteCaches :: Cache -> IO Cache+filterRemoteCaches (Ca remote) = mkCache . catMaybes <$> filtered+  where+    filtered = mapM (\x -> mbGetRemoteCacheLoc x `catchall` return Nothing) remote+    mbGetRemoteCacheLoc :: CacheLoc -> IO (Maybe CacheLoc)+    mbGetRemoteCacheLoc c@(Cache t _ url)+        | isValidLocalPath url = do+            ex <- doesDirectoryExist url+            if ex+                then do+                    p <- getPermissions url+                    return $ Just $ if writable c && SD.writable p+                                        then c+                                        else Cache t NotWritable url+                else return Nothing+        | otherwise = return $ Just c++-- | Compares two caches, a remote cache is greater than a local one.+-- The order of the comparison is given by: local < http < ssh+compareByLocality :: CacheLoc -> CacheLoc -> Ordering+compareByLocality (Cache _ w x) (Cache _ z y)+    | isValidLocalPath x && isRemote y  = LT+    | isRemote x && isValidLocalPath y = GT+    | isHttpUrl x && isSshUrl y = LT+    | isSshUrl x && isHttpUrl y = GT+    | isValidLocalPath x && isWritable w+        && isValidLocalPath y && isNotWritable z = LT+    | otherwise = EQ+  where+    isRemote r = isHttpUrl r || isSshUrl r+    isWritable = (==) Writable+    isNotWritable = (==) NotWritable++-- |@fetchFileUsingCache cache dir hash@ receives a list of caches @cache@, the+-- directory for which that file belongs @dir@ and the @hash@ of the file to+-- fetch.  It tries to fetch the file from one of the sources, trying them in+-- order one by one.  If the file cannot be fetched from any of the sources,+-- this operation fails. Otherwise we return the path where we found the file+-- and its content.+fetchFileUsingCache :: ValidHash h => Cache -> h+                    -> IO (FilePath, B.ByteString)+fetchFileUsingCache = fetchFileUsingCachePrivate Anywhere++writable :: CacheLoc -> Bool+writable (Cache _ NotWritable _) = False+writable (Cache _ Writable _) = True++-- | This keeps only 'Repo' 'NotWritable' entries.+dropNonRepos :: Cache -> Cache+dropNonRepos (Ca cache) = Ca $ filter notRepo cache where+  notRepo xs = case xs of+    Cache Directory _ _ -> False+    -- we don't want to write thisrepo: entries to the disk+    Cache Repo Writable _ -> False+    _ -> True++closestWritableDirectory :: Cache -> Maybe String+closestWritableDirectory (Ca cs) =+  listToMaybe . catMaybes .flip map cs $ \case+    Cache Directory Writable x -> Just x+    _ -> Nothing++isThisRepo :: CacheLoc -> Bool+isThisRepo (Cache Repo Writable _) = True+isThisRepo _ = False++bucketFolder :: FilePath -> FilePath+bucketFolder f = take 2 (cleanHash f)+    where+        cleanHash fileName = case dropWhile (/= '-') fileName of+            []  -> fileName+            s   -> drop 1 s++-- | The full filepath of a simple file name inside a given 'CacheLoc'+-- under 'HashedDir'.+hashedFilePath :: CacheLoc -> HashedDir -> FilePath -> FilePath+hashedFilePath (Cache Directory Writable d) s f =+    joinPath [d, hashedDir s, bucketFolder f, f]+hashedFilePath (Cache Directory NotWritable d) s f =+    joinPath [d, hashedDir s, f]+hashedFilePath (Cache Repo _ r) s f =+    joinPath [r, darcsdir, hashedDir s, f]++-- | Return whether the 'Cache' contains a file with the given hash in a+-- writable position.+peekInCache :: ValidHash h => Cache -> h -> IO Bool+peekInCache (Ca cache) sh = cacheHasIt cache `catchall` return False+  where+    subdir = dirofValidHash sh+    cacheHasIt [] = return False+    cacheHasIt (c : cs)+        | not $ writable c = cacheHasIt cs+        | otherwise = do+            ex <- doesFileExist $ hashedFilePath c subdir (encodeValidHash sh)+            if ex then return True else cacheHasIt cs++-- | Add pipelined downloads to the (low-priority) queue, for the rest it is a noop.+speculateFileUsingCache :: ValidHash h => Cache -> h -> IO ()+speculateFileUsingCache c hash = do+    let filename = encodeValidHash hash+    debugMessage $ "Speculating on " ++ filename+    copyFileUsingCache OnlySpeculate c (dirofValidHash hash) filename++-- | Do 'speculateFilesUsingCache' for files not already in a writable cache+-- position.+speculateFilesUsingCache :: ValidHash h => Cache -> [h] -> IO ()+speculateFilesUsingCache _ [] = return ()+speculateFilesUsingCache cache hs = do+    hs' <- filterM (fmap not . peekInCache cache) hs+    forM_ hs' $ speculateFileUsingCache cache++data OrOnlySpeculate = ActuallyCopy+                     | OnlySpeculate+                     deriving ( Eq, Show )++-- | If the first parameter of type 'OrOnlySpeculate' is 'ActuallyCopy', try to+-- ensure that a file with the given name (hash) exists in a writable location+-- (which means in particular that it is stored in the local file system). If+-- it is 'OnlySpeculate', then merely schedule download of that file into such+-- a location (the actual download will be executed asynchronously).+--+-- If the file is already present in some writeable location, or if there is no+-- writable location at all, this procedure does nothing.+--+-- If the copy should occur between two locations of the same filesystem, a+-- hard link is made.+--+-- If the first parameter is 'ActuallyCopy', use 'copyFileOrUrl' and try to+-- find the file in any non-writable location. Otherwise ('OnlySpeculate'), use+-- 'speculateFileOrUrl' and try only the first non-writable location (which+-- makes sense since 'speculateFileOrUrl' is asynchronous and thus can't fail+-- in any interesting way).+copyFileUsingCache :: OrOnlySpeculate -> Cache -> HashedDir -> FilePath -> IO ()+copyFileUsingCache oos (Ca cache) subdir f = do+    debugMessage $ unwords ["copyFileUsingCache:", show oos, hashedDir subdir, f]+    Just stickItHere <- cacheLoc cache+    createDirectoryIfMissing True (dropFileName stickItHere)+    filterBadSources cache >>= sfuc stickItHere+    `catchall`+    return ()+  where+    -- Return last writeable cache/repo location for file 'f'.+    -- Usually returns the global cache unless `--no-cache` is passed.+    -- Throws exception if file already exists in a writable location.+    cacheLoc [] = return Nothing+    cacheLoc (c : cs)+        | not $ writable c = cacheLoc cs+        | otherwise = do+            let attemptPath = hashedFilePath c subdir f+            ex <- doesFileExist attemptPath+            if ex+                then fail "File already present in writable location."+                else do+                    othercache <- cacheLoc cs+                    return $ othercache `mplus` Just attemptPath+    -- Do the actual copy, or hard link, or put file in download queue. This+    -- tries to find the file in all non-writable locations, in order, unless+    -- we have OnlySpeculate.+    sfuc _ [] = return ()+    sfuc out (c : cs)+        | not (writable c) =+            let cacheFile = hashedFilePath c subdir f in+            case oos of+                OnlySpeculate ->+                     speculateFileOrUrl cacheFile out+                     `catchall`+                     checkCacheReachability c+                ActuallyCopy ->+                     do debugMessage $+                          "Copying from " ++ show cacheFile ++ " to  " ++ show out+                        copyFileOrUrl defaultRemoteDarcsCmd cacheFile out Cachable+                     `catchall`+                     (do checkCacheReachability c+                         sfuc out cs) -- try another read-only location+        | otherwise = sfuc out cs++data FromWhere = LocalOnly+               | Anywhere+               deriving ( Eq )++-- | Checks if a given cache entry is reachable or not.  It receives an error+-- caught during execution and the cache entry.  If the caches is not reachable+-- it is blacklisted and not longer tried for the rest of the session. If it is+-- reachable it is whitelisted and future errors with such cache get ignore.+-- To determine reachability:+--  * For a local cache, if the given source doesn't exist anymore, it is+--    blacklisted.+--  * For remote sources if the error is timeout, it is blacklisted, if not,+--    it checks if _darcs/hashed_inventory  exist, if it does, the entry is+--    whitelisted, if it doesn't, it is blacklisted.+checkCacheReachability :: CacheLoc -> IO ()+checkCacheReachability cache+    | isValidLocalPath source = doUnreachableCheck $+        checkFileReachability (doesDirectoryExist source)+    | isHttpUrl source = doUnreachableCheck $+        checkFileReachability (checkHashedInventoryReachability cache)+    | isSshUrl source = doUnreachableCheck $+        checkFileReachability (checkHashedInventoryReachability cache)+    | otherwise = fail $ "unknown transport protocol for: " ++ source+  where+    source = cacheSource cache++    doUnreachableCheck unreachableAction = do+        reachable <- isReachableSource+        unless (reachable source) unreachableAction++    checkFileReachability doCheck = do+        reachable <- doCheck+        if reachable+            then addReachableSource source+            else addBadSource source++-- | Returns a list of reachables cache entries, removing blacklisted entries.+filterBadSources :: [CacheLoc] -> IO [CacheLoc]+filterBadSources cache = do+    badSource <- isBadSource+    return $ filter (not . badSource . cacheSource) cache++-- | Checks if the _darcs/hashed_inventory exist and is reachable+checkHashedInventoryReachability :: CacheLoc -> IO Bool+checkHashedInventoryReachability cache = withTemp $ \tempout -> do+    let f = cacheSource cache </> darcsdir </> "hashed_inventory"+    copyFileOrUrl defaultRemoteDarcsCmd f tempout Cachable+    return True+    `catchall` return False++-- | Get contents of some hashed file taking advantage of the cache system.+-- We have a list of locations (@cache@) ordered from "closest/fastest"+-- (typically, the destination repo) to "farthest/slowest" (typically,+-- the source repo).+-- First, if possible it copies the file from remote location to local.+-- Then, it reads it contents, and links the file across all writeable+-- locations including the destination repository.+fetchFileUsingCachePrivate :: ValidHash h => FromWhere -> Cache -> h+                           -> IO (FilePath, B.ByteString)+fetchFileUsingCachePrivate fromWhere (Ca cache) hash = do+    when (fromWhere == Anywhere) $+        copyFileUsingCache ActuallyCopy (Ca cache) subdir filename+    filterBadSources cache >>= ffuc+  where+    filename = encodeValidHash hash+    subdir = dirofValidHash hash+    ffuc (c : cs)+        | not (writable c) &&+            (Anywhere == fromWhere || isValidLocalPath cacheFile) = do+            -- Looks like `copyFileUsingCache` could not copy the file we+            -- wanted. This can happen if `--no-cache` is NOT passed and the+            -- global cache is not accessible.+            debugMessage $+              "In fetchFileUsingCachePrivate I'm directly grabbing file contents from "+              ++ cacheFile+            x <- gzFetchFilePS cacheFile Cachable+            if not $ checkHash hash x+                then do+                    x' <- fetchFilePS cacheFile Cachable+                    unless (checkHash hash x') $ do+                        hPutStrLn stderr $ "Hash failure in " ++ cacheFile+                        fail $ "Hash failure in " ++ cacheFile+                    return (cacheFile, x')+                else return (cacheFile, x) -- FIXME: create links in caches+            `catchall` do+                -- something bad happened, check if cache became unaccessible+                -- and try other ones+                checkCacheReachability c+                filterBadSources cs >>= ffuc+        | writable c = do+            debugMessage $ "About to gzFetchFilePS from " ++ show cacheFile+            x1 <- gzFetchFilePS cacheFile Cachable+            debugMessage "gzFetchFilePS done."+            x <- if not $ checkHash hash x1+                     then do+                        x2 <- fetchFilePS cacheFile Cachable+                        unless (checkHash hash x2) $ do+                            hPutStrLn stderr $ "Hash failure in " ++ cacheFile+                            removeFile cacheFile+                            fail $ "Hash failure in " ++ cacheFile+                        return x2+                     else return x1+            -- Linking is optional here; the catchall prevents darcs from+            -- failing if repo and cache are on different file systems.+            mapM_ (tryLinking cacheFile filename subdir) cs `catchall` return ()+            return (cacheFile, x)+            `catchall` do+                debugMessage "Caught exception, now attempt creating cache."+                createCache c subdir filename `catchall` return ()+                checkCacheReachability c+                -- fetch file from remaining locations+                (fname, x) <- filterBadSources cs >>= ffuc+                debugMessage $+                  "Attempt creating link from: " ++ show fname ++ " to " ++ show cacheFile+                (createLink fname cacheFile >> debugMessage "successfully created link"+                                            >> return (cacheFile, x))+                  `catchall` do+                    debugMessage $ "Attempt writing file: " ++ show cacheFile+                    -- the following block is usually when files get actually written+                    -- inside of _darcs or global cache.+                    do createDirectoryIfMissing True (dropFileName cacheFile)+                       gzWriteFilePS cacheFile x+                       debugMessage "successfully wrote file"+                       `catchall` return ()+                    -- above block can fail if cache is not writeable+                    return (fname, x)+        | otherwise = ffuc cs+        where+          cacheFile = hashedFilePath c subdir filename++    ffuc [] = fail ("Couldn't fetch " ++ filename ++ "\nin subdir "+                          ++ hashedDir subdir ++ " from sources:\n"+                          ++ show (Ca cache)+                          ++ if subdir == HashedPristineDir+                             then "\nRun `darcs repair` to fix this problem."+                             else "")++tryLinking :: FilePath -> FilePath -> HashedDir -> CacheLoc -> IO ()+tryLinking source filename subdir c =+  when (writable c) $ do+    createCache c subdir filename+    let target = hashedFilePath c subdir filename+    debugMessage $ "Linking " ++ source ++ " to " ++ target+    handleOnly isAlreadyExistsError (return ()) $ createLink source target++createCache :: CacheLoc -> HashedDir -> FilePath -> IO ()+createCache (Cache Directory _ d) subdir filename =+    createDirectoryIfMissing True (d </> hashedDir subdir </> bucketFolder filename)+createCache _ _ _ = return ()++-- | Write file content, except if it is already in the cache, in+-- which case merely create a hard link to that file. The returned value+-- is the size and hash of the content.+writeFileUsingCache+  :: ValidHash h => Cache -> B.ByteString -> IO h+writeFileUsingCache (Ca cache) content = do+    debugMessage $ "writeFileUsingCache "++filename+    (fn, _) <- fetchFileUsingCachePrivate LocalOnly (Ca cache) hash+    mapM_ (tryLinking fn filename subdir) cache+    return hash+    `catchall`+    wfuc cache+    `catchall`+    fail ("Couldn't write " ++ filename ++ "\nin subdir "+               ++ hashedDir subdir ++ " to sources:\n\n"++ show (Ca cache))+  where+    subdir = dirofValidHash hash+    hash = calcValidHash content+    filename = encodeValidHash hash+    wfuc (c : cs)+        | not $ writable c = wfuc cs+        | otherwise = do+            createCache c subdir filename+            let cacheFile = hashedFilePath c subdir filename+            gzWriteAtomicFilePS cacheFile content+            -- create links in all other writable locations+            debugMessage $ "writeFileUsingCache remaining sources:\n"++show (Ca cs)+            -- Linking is optional here; the catchall prevents darcs from+            -- failing if repo and cache are on different file systems.+            mapM_ (tryLinking cacheFile filename subdir) cs `catchall` return ()+            return hash+    wfuc [] = fail $ "No location to write file " ++ (hashedDir subdir </> filename)++cleanCaches :: Cache -> HashedDir -> IO ()+cleanCaches c d = cleanCachesWithHint' c d Nothing++cleanCachesWithHint :: Cache -> HashedDir -> [String] -> IO ()+cleanCachesWithHint c d h = cleanCachesWithHint' c d (Just h)++cleanCachesWithHint' :: Cache -> HashedDir -> Maybe [String] -> IO ()+cleanCachesWithHint' (Ca cs) subdir hint = mapM_ cleanCache cs+  where+    cleanCache (Cache Directory Writable d) =+        withCurrentDirectory (d </> hashedDir subdir) (do+            fs' <- getDirectoryContents "."+            let fs = filter okayHash $ fromMaybe fs' hint+                cleanMsg = "Cleaning cache " ++ d </> hashedDir subdir+            mapM_ clean $ progressList cleanMsg fs)+        `catchall`+        return ()+    cleanCache _ = return ()+    clean f = do+        lc <- linkCount `liftM` getSymbolicLinkStatus f+        when (lc < 2) $ removeFile f+        `catchall`+        return ()++-- | Prints an error message with a list of bad caches.+reportBadSources :: IO ()+reportBadSources = do+    sources <- getBadSourcesList+    let size = length sources+    unless (null sources) $ hPutStrLn stderr $+        concat [ "\nBy the way, I could not reach the following "+               , englishNum size (Noun "location") ":"+               , "\n"+               , intercalate "\n" (map ("  " ++) sources)+               , "\nUnless you plan to restore access to "+               , englishNum size It ", you should delete "+               , "the corresponding "+               , englishNum size (Noun "entry") " from _darcs/prefs/sources."+               ]++-- * Global Variables++badSourcesList :: MVar [String]+badSourcesList = unsafePerformIO $ newMVar []+{-# NOINLINE badSourcesList #-}++addBadSource :: String -> IO ()+addBadSource cache = modifyMVarPure badSourcesList (cache:)++getBadSourcesList :: IO [String]+getBadSourcesList = readMVar badSourcesList++isBadSource :: IO (String -> Bool)+isBadSource = do+    badSources <- getBadSourcesList+    return (`elem` badSources)++reachableSourcesList :: MVar [String]+reachableSourcesList = unsafePerformIO $ newMVar []+{-# NOINLINE reachableSourcesList #-}++addReachableSource :: String -> IO ()+addReachableSource src = modifyMVarPure reachableSourcesList (src:)++getReachableSources :: IO [String]+getReachableSources = readMVar reachableSourcesList++isReachableSource :: IO (String -> Bool)+isReachableSource =  do+    reachableSources <- getReachableSources+    return (`elem` reachableSources)++modifyMVarPure :: MVar a -> (a -> a) -> IO ()+modifyMVarPure mvar f = modifyMVar_ mvar (return . f)
+ src/Darcs/Util/CommandLine.hs view
@@ -0,0 +1,121 @@+-- Copyright (C) 2005 Benedikt Schmidt+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module      : Darcs.Util.CommandLine+-- Copyright   : 2005 Benedikt Schmidt+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable+--+-- |A parser for commandlines, returns an arg list and expands+-- format strings given in a translation table. Additionally+-- the commandline can end with "%<" specifying that the command+-- expects input on stdin.+--+-- See Darcs.Test.Misc.CommandLine for tests.++module Darcs.Util.CommandLine+    ( parseCmd+    , addUrlencoded+    ) where++import Darcs.Prelude++import Control.Arrow ( (***) )+import Data.Char ( ord, intToDigit, toUpper )+import Data.List ( find )+import Text.ParserCombinators.Parsec++-- | assoc list mapping characters to strings+-- eg (c,s) means that %c is replaced by s+type FTable = [(Char,String)]++commandline :: FTable -> Parser ([String], Bool)+commandline ftable = consumeAll $ do+    l <- sepEndBy1 (arg ftable) (try separator)+    redir <- formatRedir+    spaces+    return (l,redir)++arg :: FTable -> Parser String+arg ftable = quotedArg ftable <|> unquotedArg ftable++unquotedArg :: FTable -> Parser String+unquotedArg ftable = try (format ftable) <|> many1 (noneOf " \t\"%")++quotedArg :: FTable -> Parser String+quotedArg ftable = between quoteChar quoteChar $ quoteContent ftable+  where+    quoteChar = char '"'++quoteContent :: FTable -> Parser String+quoteContent ftable = do s1 <- escape+                               <|> try (format ftable)+                               <|> many1 (noneOf "\"\\%")+                         s2 <- quoteContent ftable+                         return $ s1 ++ s2+                     <|> return ""++formatRedir :: Parser Bool+formatRedir = (string "%<" >> return True)+              <|> return False++format :: FTable -> Parser String+format ftable = do _ <- char '%'+                   c <- oneOf (map fst ftable)+                   return $ expandFormat ftable c++escape :: Parser String+escape = do _ <- char '\\'+            c <- anyChar+            return [c]++consumeAll :: Parser a -> Parser a+consumeAll p = do r <- p+                  eof+                  return r++separator :: Parser ()+separator = skipMany1 space++expandFormat :: FTable -> Char -> String+expandFormat ftable c = case find ((==c) . fst) ftable of+                            Just (_,s) -> s+                            Nothing -> error "impossible"++-- | parse a commandline returning a list of strings+-- (intended to be used as argv) and a bool value which+-- specifies if the command expects input on stdin+-- format specifiers with a mapping in ftable are accepted+-- and replaced by the given strings. E.g. if the ftable is+-- [('s',"Some subject")], then "%s" is replaced by "Some subject"+parseCmd :: FTable -> String -> Either ParseError ([String],Bool)+parseCmd ftable = parse (commandline ftable) ""++urlEncode :: String -> String+urlEncode = concatMap escapeC+    where escapeC x = if allowed x then [x] else '%' : intToHex (ord x)+          intToHex i = map intToDigit [i `div` 16, i `mod` 16]+          allowed x = x `elem` allowedChars+          allowedChars = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "!'()*-.~"++-- | for every mapping (c,s), add a mapping with uppercase c+-- and the urlencoded string s+addUrlencoded :: FTable -> FTable+addUrlencoded ftable = ftable ++ map (toUpper *** urlEncode) ftable
+ src/Darcs/Util/Compat.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++module Darcs.Util.Compat+    ( stdoutIsAPipe+    , maybeRelink+    , atomicCreate+    , sloppyAtomicCreate+    ) where++#ifdef WIN32+#define USE_CREAT+#else+#if MIN_VERSION_unix(2,8,0)+#define USE_CREAT+#endif+#endif++import Darcs.Prelude++import Control.Monad ( unless )+import Foreign.C.Types ( CInt(..) )+import Foreign.C.String ( CString, withCString )+import Foreign.C.Error ( throwErrno, eEXIST, getErrno )+import System.Directory ( getCurrentDirectory )+import System.IO.Error ( mkIOError, alreadyExistsErrorType )+import System.Posix.Files ( stdFileMode )+import System.Posix.IO ( openFd, closeFd,+#ifdef USE_CREAT+                         creat,+#endif+                         defaultFileFlags, exclusive,+                         OpenMode(WriteOnly) )++import Darcs.Util.SignalHandler ( stdoutIsAPipe )++foreign import ccall unsafe "maybe_relink.h maybe_relink" maybe_relink+    :: CString -> CString -> CInt -> IO CInt++-- Checks whether src and dst are identical.  If so, makes dst into a+-- link to src.  Returns True if dst is a link to src (either because+-- we linked it or it already was).  Safe against changes to src if+-- they are not in place, but not to dst.+maybeRelink :: String -> String -> IO Bool+maybeRelink src dst =+    withCString src $ \csrc ->+    withCString dst $ \cdst ->+    do rc <- maybe_relink csrc cdst 1+       case rc of+        0 -> return True+        1 -> return True+        -1 -> throwErrno ("Relinking " ++ dst)+        -2 -> return False+        -3 -> do putStrLn ("Relinking: race condition avoided on file " +++                            dst)+                 return False+        _ -> fail ("Unexpected situation when relinking " ++ dst)++sloppyAtomicCreate :: FilePath -> IO ()+sloppyAtomicCreate fp+#ifdef USE_CREAT+    = do fd <- openFd fp WriteOnly flags {creat = Just stdFileMode}+#else+    = do fd <- openFd fp WriteOnly (Just stdFileMode) flags+#endif+         closeFd fd+  where flags = defaultFileFlags { exclusive = True }++atomicCreate :: FilePath -> IO ()+atomicCreate fp = withCString fp $ \cstr -> do+    rc <- c_atomic_create cstr+    unless (rc >= 0) $+           do errno <- getErrno+              pwd <- getCurrentDirectory+              if errno == eEXIST+                 then ioError $ mkIOError alreadyExistsErrorType+                                          ("atomicCreate in "++pwd)+                                          Nothing (Just fp)+                 else throwErrno $ "atomicCreate "++fp++" in "++pwd++foreign import ccall unsafe "atomic_create.h atomic_create" c_atomic_create+    :: CString -> IO CInt
+ src/Darcs/Util/DateMatcher.hs view
@@ -0,0 +1,227 @@+-- Copyright (C) 2004 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module      : Darcs.Util.DateMatcher+-- Copyright   : 2004 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.Util.DateMatcher+    (+      parseDateMatcher+    -- for debugging only+    , DateMatcher(..)+    , getMatchers+    -- for testing (GHCi, etc)+    , testDate+    , testDateAt+    ) where++import Darcs.Prelude++import Control.Exception ( catchJust )+import Data.Maybe ( isJust )++import System.IO.Error ( isUserError, ioeGetErrorString )+import System.Time+import Text.ParserCombinators.Parsec ( eof, parse, ParseError )++import Darcs.Util.IsoDate+    ( parseDate, englishDateTime, englishInterval, englishLast+    , iso8601Interval, resetCalendar, subtractFromMCal, getLocalTz+    , MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime+    , unsetTime, readUTCDate+    )++-- | 'withinDay' @x y@ is true if @x <= y < (x + one_day)@+-- Note that this converts the two dates to @ClockTime@ to avoid+-- any timezone-related errors+withinDay :: CalendarTime -> CalendarTime -> Bool+withinDay a b = within (Just $ toClockTime a)+                       (Just (addToClockTime day $ toClockTime a))+                       (toClockTime b)+  where+    day = TimeDiff 0 0 1 0 0 0 0++-- | 'dateRange' @x1 x2 y@ is true if @x1 <= y < x2@+--   Since @x1@ and @x2@ can be underspecified, we simply assume the+--   first date that they could stand for.+dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool+dateRange a b = cDateRange (fmap unsafeToCalendarTime a)+                           (fmap unsafeToCalendarTime b)++-- | 'cDateRange' @x1 x2 y@ is true if @x1 <= y < x2@+cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool+cDateRange a b c = within (fmap toClockTime a)+                          (fmap toClockTime b) (toClockTime c)++-- | 'within' @x1 x2 y@ is true if @x1 <= y < x2@+within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool+within (Just start) (Just end) time = start <= time && time < end+within Nothing (Just end) time = time < end+within (Just start) Nothing time = start <= time+within _ _ _ = undefined++-- | 'samePartialDate' @range exact@ is true if @exact@ falls+--   within the a range of dates represented by @range@.+--   The purpose of this function is to support matching on partially+--   specified dates.  That is, if you only specify the date 2007,+--   this function should match any dates within that year.  On the+--   other hand, if you specify 2007-01, this function will match any+--   dates within that month.  This function only matches up to the+--   second.+samePartialDate :: MCalendarTime -> CalendarTime -> Bool+samePartialDate a b_ =+    within (Just clockA)+           (Just $ addToClockTime interval clockA)+           (toClockTime calB)+  where+    interval+        | isJust (mctSec a)   = second+        | isJust (mctMin a)   = minute+        | isJust (mctHour a)  = hour+        | isJust (mctYDay a)  = day+        | mctWeek a = maybe week (const day) (mctWDay a)+        | isJust (mctDay a)   = day+        | isJust (mctMonth a) = month+        | otherwise           = year+    year   = TimeDiff 1 0 0 0 0 0 0+    month  = TimeDiff 0 1 0 0 0 0 0+    week   = TimeDiff 0 0 7 0 0 0 0+    day    = TimeDiff 0 0 1 0 0 0 0+    hour   = TimeDiff 0 0 0 1 0 0 0+    minute = TimeDiff 0 0 0 0 1 0 0+    second = TimeDiff 0 0 0 0 0 1 0+    clockA = toClockTime $ unsafeToCalendarTime a+    calB   = resetCalendar b_++-- | A 'DateMatcher' combines a potential parse for a date string+--   with a "matcher" function that operates on a given date.+--   We use an existential type on the matcher to allow+--   the date string to either be interpreted as a point in time+--   or as an interval.+data DateMatcher = forall d . (Show d) => DM+    String                      --  name+    (Either ParseError d)       --  parser+    (d -> CalendarTime -> Bool) --  matcher++-- | 'parseDateMatcher' @s@ return the first  matcher in+--    'getMatchers' that can parse 's'+parseDateMatcher :: String -> IO (CalendarTime -> Bool)+parseDateMatcher d = testDateMatcher `catchUserError` handleError+  where+    catchUserError = catchJust $ \e ->+        if isUserError e then Just (ioeGetErrorString e) else Nothing++    -- If the user enters a date > maxint seconds ago, the toClockTime+    -- function cannot work.+    handleError e = if e == "Time.toClockTime: invalid input"+                        then error "Can't handle dates that far back!"+                        else error e++    -- Hack: test the matcher against the current date and discard the results.+    -- We just want to make sure it won't throw any exceptions when we use it+    -- for real.+    testDateMatcher = do+        matcher <- tryMatchers `fmap` getMatchers d+        matcher `fmap` now >>= (`seq` return matcher)++-- | 'getMatchers' @d@ returns the list of matchers that will be+--   applied on @d@.  If you wish to extend the date parsing code,+--   this will likely be the function that you modify to do so.+getMatchers :: String -> IO [DateMatcher]+getMatchers d = do+    rightNow <- now+    let midnightToday = unsetTime rightNow+        mRightNow = toMCalendarTime rightNow+        matchIsoInterval (Left dur) =+            let durAgo = dur `subtractFromMCal` mRightNow in+            dateRange (Just durAgo) (Just mRightNow)+        matchIsoInterval (Right (a,b)) = dateRange (Just a) (Just b)+    tzNow <- getLocalTz+    return+        -- note that the order of these is quite important as some matchers can+        -- match the same date.+        [ DM "from English date"+              (parseDateWith $ englishLast midnightToday)+              (\(a,_) -> cDateRange (Just a) Nothing)+        , DM "specific English date"+              (parseDateWith $ englishDateTime midnightToday)+              withinDay+        , DM "English interval"+              (parseDateWith $ englishInterval rightNow)+              (uncurry cDateRange)+        , DM "ISO 8601 interval"+              (parseDateWith $ iso8601Interval tzNow)+              matchIsoInterval+        , DM "CVS, ISO 8601, old style, or RFC2822 date"+              (parseDate tzNow d)+              samePartialDate+        ]+  where+    tillEof p = do { x <- p; eof; return x }+    parseDateWith p = parse (tillEof p) "" d+++--- The following functions are for toying around in GHCi+---+--- > testDate   "2008/05/22 10:34"+--- > testDateAt "2006-03-22 09:36" "2008/05/22 10:34"++-- | 'tryMatchers' @ms@ returns the first successful match in @ms@+--   It is an error if there are no matches+tryMatchers :: [DateMatcher] -> CalendarTime -> Bool+tryMatchers (DM _ parsed matcher : ms) =+    case parsed of+        Left _   -> tryMatchers ms+        Right  d -> matcher d+tryMatchers [] = error "Can't support fancy dates."++now :: IO CalendarTime+now = getClockTime >>= toCalendarTime++-- | 'testDate' @d@ shows the possible interpretations+--   for the date string @d@ and how they match against+--   the current date+testDate :: String -> IO ()+testDate d = do cnow <- now+                testDateAtCal cnow d++-- | 'testDate' @iso d@ shows the possible interpretations+--   for the date string @d@ and how they match against+--   the date represented by the ISO 8601 string @iso@+testDateAt :: String -> String -> IO ()+testDateAt iso = testDateAtCal (readUTCDate iso)++-- | helper function for 'testDate' and 'testDateAt'+testDateAtCal :: CalendarTime -> String -> IO ()+testDateAtCal c d =+ do ms <- getMatchers d+    putStr . unlines . map (showMatcher c) $ ms++-- | 'showMatcher' @c dm@ tells us if @dm@ applies to+--   'CalendarTime' @c@; or if @dm@ just represents the+--   failure to parse a date, in which case @c@ is moot.+showMatcher :: CalendarTime -> DateMatcher -> String+showMatcher cnow (DM n p m) =+   "==== " ++ n ++ " ====\n" +++   (case p of+     Left err -> shows err ""+     Right x  -> show x ++ "\n" ++ show (m x cnow))
+ src/Darcs/Util/DateTime.hs view
@@ -0,0 +1,69 @@+--  Copyright (C) 2011 Eric Sessoms+--+--  BSD3++module Darcs.Util.DateTime+    ( getCurrentTime, toSeconds+    , formatDateTime, fromClockTime, parseDateTime, startOfTime+    ) where++import Darcs.Prelude++import qualified Data.Time.Calendar as Calendar ( fromGregorian )+import Data.Time.Clock+    ( UTCTime(UTCTime), UniversalTime(ModJulianDate)+    , getModJulianDate, secondsToDiffTime, getCurrentTime+    )+import Data.Time.Format ( formatTime, parseTimeM )+import Data.Time.LocalTime+    ( utc+    , localTimeToUT1, ut1ToLocalTime+    , localTimeToUTC, utcToLocalTime+    )+import Data.Time ( defaultTimeLocale )+import System.Time ( ClockTime(TOD) )++toSeconds    :: UTCTime -> Integer+toSeconds dt = floor $+    (86400.0 :: Double) * fromRational (toMJD dt - startOfTimeMJD)++toMJD :: UTCTime -> Rational+toMJD = getModJulianDate . toUniversalTime++startOfTimeMJD :: Rational+startOfTimeMJD = toMJD startOfTime++startOfTime :: UTCTime+startOfTime = fromGregorian' 1970 1 1++fromGregorian'       :: Integer -> Int -> Int -> UTCTime+fromGregorian' y m d = fromGregorian y m d 0 0 0++fromGregorian :: Integer -> Int -> Int -> Int -> Int -> Int -> UTCTime+fromGregorian year month day hours minutes seconds =+    UTCTime day' (secondsToDiffTime . fromIntegral $ seconds')+  where+    day'     = Calendar.fromGregorian year month day+    seconds' = 3600 * hours + 60 * minutes + seconds++toUniversalTime :: UTCTime -> UniversalTime+toUniversalTime = localTimeToUT1 0 . utcToLocalTime utc++formatDateTime :: String -> UTCTime -> String+formatDateTime = formatTime defaultTimeLocale++parseDateTime :: String -> String -> Maybe UTCTime+parseDateTime = parseTimeM True defaultTimeLocale++fromClockTime           :: ClockTime -> UTCTime+fromClockTime (TOD s _) = fromSeconds s++fromSeconds   :: Integer -> UTCTime+fromSeconds s = fromMJD $+    fromIntegral s / 86400 + startOfTimeMJD++fromMJD :: Rational -> UTCTime+fromMJD = fromUniversalTime . ModJulianDate++fromUniversalTime :: UniversalTime -> UTCTime+fromUniversalTime = localTimeToUTC utc . ut1ToLocalTime 0
+ src/Darcs/Util/Diff.hs view
@@ -0,0 +1,20 @@+module Darcs.Util.Diff+    ( getChanges+    , DiffAlgorithm(..)+    ) where++import Darcs.Prelude++import qualified Darcs.Util.Diff.Myers as M ( getChanges )+import qualified Darcs.Util.Diff.Patience as P ( getChanges )+import qualified Data.ByteString as B ( ByteString )+++data DiffAlgorithm = PatienceDiff | MyersDiff+    deriving ( Eq, Show )++getChanges :: DiffAlgorithm -> [B.ByteString] -> [B.ByteString]+              -> [(Int,[B.ByteString],[B.ByteString])]+getChanges dac = case dac of+                   PatienceDiff -> P.getChanges+                   MyersDiff -> M.getChanges
+ src/Darcs/Util/Diff/Myers.hs view
@@ -0,0 +1,492 @@+-- Copyright (C) 2002 David Roundy+-- Copyright (C) 2005 Benedikt Schmidt+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module      : Darcs.Util.Diff.Myers+-- Copyright   : 2003 David Roundy+--               2005 Benedikt Schmidt+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable+--+-- LCS stands for Longest Common Subsequence, and it is a relatively+-- challenging problem to find an LCS efficiently.  This module implements+-- the algorithm described in:+--+--   "An O(ND) Difference Algorithm and its Variations", Eugene Myers,+--   Algorithmica Vol. 1 No. 2, 1986, pp. 251-266;+--   especially the variation described in section 4.2 and most refinements+--   implemented in GNU diff (D is the edit-distance).+--+-- There is currently no heuristic to reduce the running time and produce+-- suboptimal output for large inputs with many differences. It behaves like+-- GNU diff with the -d option in this regard.+--+-- In the first step, a hash value for every line is calculated and collisions+-- are marked with a special value. This reduces a string comparison to an+-- int comparison for line tuples where at least one of the hash values is+-- not equal to the special value. After that, lines which only exists in one+-- of the files are removed and marked as changed which reduces the running+-- time of the following difference algorithm. GNU diff additionally removes+-- lines that appear very often in the other file in some cases.+-- The last step tries to create longer changed regions and line up deletions+-- in the first file to insertions in the second by shifting changed lines+-- forward and backward.++module Darcs.Util.Diff.Myers+    ( getChanges+    , shiftBoundaries+    , initP+    , aLen+    , PArray+    , getSlice+    ) where++import Darcs.Prelude++import Control.Monad+import Data.Int+import Control.Monad.ST+import Data.Maybe+import Darcs.Util.ByteString (hashPS)+import qualified Data.ByteString as B (empty, ByteString)+import Data.Array.Base+import Data.Array.Unboxed+import qualified Data.Map as Map ( lookup, empty, insertWith )++-- | create a list of changes between a and b, each change has the form+--   (starta, lima, startb, limb) which means that a[starta, lima)+--   has to be replaced by b[startb, limb)+getChanges ::  [B.ByteString] -> [B.ByteString]+           -> [(Int,[B.ByteString],[B.ByteString])]+getChanges a b = dropStart (initP a) (initP b) 1++dropStart ::  PArray -> PArray -> Int+           -> [(Int,[B.ByteString],[B.ByteString])]+dropStart a b off+  | off > aLen a = [(off - 1, [], getSlice b off (aLen b))]+  | off > aLen b = [(off - 1, getSlice a off (aLen a), [])]+  | a!off == b!off = dropStart a b (off + 1)+  | otherwise      = dropEnd a b off 0++dropEnd ::  PArray -> PArray -> Int -> Int+        -> [(Int,[B.ByteString],[B.ByteString])]+dropEnd a b off end+    | off > alast        = [(off - 1, [], getSlice b off blast)]+    | off > blast        = [(off - 1, getSlice a off alast, [])]+    | a!alast == b!blast = dropEnd a b off (end + 1)+    | otherwise          = getChanges' (a, (off, alast)) (b, (off, blast))+  where alast = aLen a - end+        blast = aLen b - end++getSlice :: PArray -> Int -> Int -> [B.ByteString]+getSlice a from to+  | from > to = []+  | otherwise = (a ! from) : getSlice a (from + 1) to++getChanges' :: (PArray, (Int, Int)) -> (PArray, (Int, Int))+            -> [(Int,[B.ByteString],[B.ByteString])]+getChanges' (a, abounds) (b, bbounds) =+    map (convertPatch 0 a b) $ createPatch c_a c_b+  where+        -- If the last few characters of two lines are the same, the lines are+        -- probably the same. The choice of 20 is plucked out of the air.+        toHash x bnds = listArray bnds [ hashPS $ x!i | i <- range bnds]+        ah = toHash a abounds :: HArray+        mkAMap m (i:is) =+            let ins (_,_,_,new) (collision,_,_,old) =+                    (collision || (new /= old), True, False, old)+                m' = Map.insertWith ins (ah!i) (False, True, False, a!i) m+            in mkAMap m' is+        mkAMap m _ = m+        hm_a = mkAMap Map.empty (range abounds)+        --+        bh = toHash b bbounds :: HArray+        mkBMap m (i:is) =+            let ins (_,_,_,new) (collision,in_a,_,old) =+                    (collision || (new /= old), in_a, True, old)+                m' = Map.insertWith ins (bh!i) (False, False, True, b!i) m+            in mkBMap m' is+        mkBMap m _ = m+        hm = mkBMap hm_a (range bbounds)+        -- take care of collisions, if there are different lines with the+        -- same hash in both files, then set the hash to markColl,+        -- PackedStrings are compared for two lines with the hash markColl+        get (i, h) = case Map.lookup h hm of+                      Just (_,False,_,_) -> Nothing+                      Just (_,_,False,_) -> Nothing+                      Just (False,True,True,_) -> Just (i, h)+                      Just (True,True,True,_) -> Just (i, markColl)+                      Nothing -> error "impossible case"++        a' = mapMaybe get [(i, ah!i) | i <- range (bounds ah)]+        b' = mapMaybe get [(i, bh!i) | i <- range (bounds bh)]++        (c_a, c_b) = diffArr a' b' (a, abounds) (b, bbounds)++-- | mark hash value where collision occured+markColl :: Int32+markColl = 2345677++-- | return arrays with changes in a and b (1 indexed), offsets start with 0+diffArr :: [(Int,Int32)] -> [(Int,Int32)]+        -> (PArray, (Int, Int)) -> (PArray, (Int, Int))+        -> (BArray, BArray)+diffArr a b (p_a, (off_a, l_a)) (p_b, (off_b, l_b)) = runST (+  do let h_a = initH (map snd a)+         h_b = initH (map snd b)+         m_a = initM (map fst a)+         m_b = initM (map fst b)+         end_a = aLen p_a+         end_b = aLen p_b+     c_a <- initVChanged end_a+     c_b <- initVChanged end_b+     mapM_ (\ (l,_) -> writeArray c_a l False) a+     mapM_ (\ (l,_) -> writeArray c_b l False) b+     _ <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b 0 0 (aLen h_a) (aLen h_b)+     let unchanged ar = do {xs <- getElems ar; return $ length (filter not xs) -1}+     err <- liftM2 (/=) (unchanged c_a) (unchanged c_b)+     when err $ error "impossible case"+     -- Mark common lines at beginning and end+     mapM_ (\ i -> writeArray c_a i False ) [1..(off_a - 1)]+     mapM_ (\ i -> writeArray c_b i False ) [1..(off_b - 1)]+     mapM_ (\ i -> writeArray c_a i False ) [(l_a + 1) .. end_a]+     mapM_ (\ i -> writeArray c_b i False ) [(l_b + 1) .. end_b]+     shiftBoundaries c_a c_b p_a 1 1+     shiftBoundaries c_b c_a p_b 1 1+     err1 <- liftM2 (/=) (unchanged c_a) (unchanged c_b)+     when err1 $ error "impossible case"+     c_a' <- unsafeFreeze c_a+     c_b' <- unsafeFreeze c_b+     return (c_a', c_b'))++-- | set changes array for a and b and return number of changed lines+cmpseq :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+       -> BSTArray s -> BSTArray s -> Int -> Int -> Int -> Int -> ST s Int+cmpseq _ _ _ _ _ _ _ _ _ _ 0 0 = return 0+cmpseq h_a h_b p_a p_b m_a m_b c_a c_b off_a off_b l_a l_b = do+  let lim_a = off_a+l_a+      lim_b = off_b+l_b+      off_a' = findSnake h_a h_b p_a p_b m_a m_b off_a off_b l_a l_b off_a off_b+      off_b' = off_b+off_a'-off_a+      lim_a' = findSnakeRev h_a h_b p_a p_b m_a m_b lim_a lim_b off_a' off_b'+      lim_b' = lim_b+lim_a'-lim_a+      l_a' = lim_a'-off_a'+      l_b' = lim_b'-off_b'+  if l_a' == 0 || l_b' == 0+     then if l_a' == 0+             then do when (l_b' > 0) $+                          mapM_ (\i -> writeArray c_b (m_b!i) True)+                                [(off_b' + 1) .. lim_b']+                     return l_b'+             else do when (l_a' > 0) $+                          mapM_ (\i -> writeArray c_a (m_a!i) True)+                                [(off_a' + 1) .. lim_a']+                     return l_a'+     else do let m = l_a' + l_b'+                 del = l_a' - l_b'+                 dodd = odd del+             v <- initV m+             vrev <- initVRev m l_a'+             writeArray vrev 0 l_a'+             writeArray v 0 0+             (xmid, ymid, _) <- findDiag 1 h_a h_b p_a p_b m_a m_b v vrev+                                off_a' off_b' l_a' l_b' del dodd+             when ((xmid == 0 && ymid == 0) || (xmid == l_a' && ymid == l_b')+                   || (xmid < 0 || ymid < 0 || xmid > l_a' || ymid > l_b'))+                     $ error "impossible case"+             c1 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b+                          off_a' off_b' xmid ymid+             c2 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b+                          (off_a' + xmid) (off_b' + ymid)+                          (l_a' - xmid) (l_b' - ymid)+             return $ c1 + c2++-- | return (xmid, ymid, cost) for the two substrings+--   a[off_a+1..off_a+1+l_a] and b+findDiag :: Int -> HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+         -> VSTArray s -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> Bool+         -> ST s (Int, Int, Int)+findDiag c h_a h_b p_a p_b m_a m_b v vrev off_a off_b l_a l_b del dodd = do+  when (c > l_a + l_b) $ error "findDiag failed"+  r <- findF+  case r of+    Just (xmid, ymid) -> return (xmid, ymid, c*2 - 1)+    Nothing ->+      do r' <- findR+         case r' of+           Just (xmid, ymid) -> return (xmid, ymid, c*2)+           Nothing -> findDiag (c + 1) h_a h_b p_a p_b m_a m_b v vrev+                      off_a off_b l_a l_b del dodd+ where fdmax = if c <= l_a then c else l_a - ((l_a + c) `mod` 2)+       rdmax = if c <= l_b then c else l_b - ((l_b + c) `mod` 2)+       lastrdmax = if (c-1) <= l_b then c-1 else l_b-(l_b + (c-1) `mod` 2)+       lastrdmin = -(if (c-1) <= l_a then c-1 else l_a-((l_a + (c-1)) `mod` 2))+       fdmin = -rdmax+       rdmin = -fdmax+       findF = findF' fdmax+       findR = findR' rdmax+       findF' d = do x <- findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b+                     if dodd && d - del >= lastrdmin && d - del <= lastrdmax+                        then do xr <- readArray vrev (d - del)+                                if xr <= x then return $ Just (x, x - d)+                                           else if d <= fdmin then return Nothing+                                                              else findF' (d-2)+                        else if d <= fdmin then return Nothing else findF' (d-2)+       findR' d = do x <- findOneRev h_a h_b p_a p_b m_a m_b vrev d del off_a off_b+                     if not dodd && (d + del >= fdmin) && (d + del <= fdmax)+                        then do xf <- readArray v (d + del)+                                if x <= xf then return $ Just (x,x-del-d)+                                           else if d <= rdmin then return Nothing+                                                              else findR' (d-2)+                        else if d <= rdmin then return Nothing else findR' (d-2)++-- | find position on diag d with one more insert/delete going forward+findOne  :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+         -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int+findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b = do+  x0 <- do xbelow <- readArray v (d - 1)+           xover <- readArray v (d + 1)+           return $ if xover > xbelow then xover else xbelow + 1+  let y0 = x0 - d+      x = findSnake h_a h_b p_a p_b  m_a m_b (x0+off_a) (y0+off_b)+            l_a l_b off_a off_b+  writeArray v d (x - off_a)+  return (x-off_a)++-- | follow snake from northwest to southeast, x and y are absolute positions+findSnake :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+          -> Int -> Int -> Int -> Int -> Int -> Int -> Int+findSnake h_a h_b p_a p_b  m_a m_b x y l_a l_b off_a off_b =+  if x < l_a + off_a && y < l_b + off_b && h_a!(x+1) == h_b!(y+1)+       && (h_a!(x+1) /= markColl || p_a!(m_a!(x+1)) == p_b!(m_b!(y+1)))+     then findSnake h_a h_b p_a p_b m_a m_b (x + 1) (y + 1) l_a l_b off_a off_b+     else x++-- | find position on diag d with one more insert/delete going backward+findOneRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+           -> VSTArray s -> Int -> Int -> Int -> Int -> ST s Int+findOneRev h_a h_b p_a p_b m_a m_b v d del off_a off_b = do+  x0 <- do xbelow <- readArray v (d - 1)+           xover <- readArray v (d + 1)+           return $ if xbelow < xover then xbelow else xover-1+  let y0 = x0 - del - d+      x = findSnakeRev h_a h_b p_a p_b m_a m_b (x0+off_a) (y0+off_b)+            off_a off_b+  writeArray v d (x-off_a)+  return (x-off_a)++-- | follow snake from southeast to northwest, x and y are absolute positions+findSnakeRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray+             -> Int -> Int -> Int -> Int -> Int+findSnakeRev h_a h_b p_a p_b m_a m_b x y off_a off_b =+  if x > off_a && y > off_b && h_a!x == h_b!y+       && (h_a!x /= markColl || p_a!(m_a!x) == p_b!(m_b!y))+     then findSnakeRev h_a h_b p_a p_b m_a m_b (x - 1) (y - 1) off_a off_b+     else x++-- | try to create nicer diffs by shifting around regions of changed lines+shiftBoundaries :: BSTArray s -> BSTArray s -> PArray -> Int -> Int -> ST s ()+shiftBoundaries c_a c_b p_a i_ j_ =+  do x <- nextChanged c_a i_+     case x of+       Just start ->+             do let skipped = start - i_+                j1 <- nextUnchangedN c_b skipped j_+                end <- nextUnchanged c_a start+                j2 <- nextUnchanged c_b j1+                (i3,j3) <- expand start end j2+                shiftBoundaries c_a c_b p_a i3 j3+       Nothing -> return () -- no change up to end of file+ where noline = aLen p_a + 1+       expand start i j =+         do let len = i - start+            (start0,i0,j0) <- shiftBackward start i j+            b <- if j0 > 1 then readArray c_b (j0-1) else return False+            let corr = if b then i0 else noline+            let blank = if p_a!(i0-1) == B.empty then i0+                                               else noline+            (start1,i1,j1,corr1,blank1) <- shiftForward start0 i0 j0 corr blank+            -- prefer corresponding to ending with blank line+            let newi = if corr1 == noline then blank1+                                          else corr1+            (start2,i2,j2) <- moveCorr start1 i1 j1 newi+            if len /= i2 - start2+                then expand start2 i2 j2+                else return (i2, j2)+       shiftBackward start i j =+         if start > 1 && p_a!(i-1) == p_a!(start-1)+            then do when (i == start) $ error "impossible case"+                    b1 <- readArray c_a (i-1)+                    b2 <- readArray c_a (start-1)+                    when (not b1 || b2) $ error "impossible case"+                    writeArray c_a (i-1) False+                    writeArray c_a (start-1) True+                    b <- if start > 2 then readArray c_a (start-2)+                                      else return False+                    start' <- if b then liftM (1+) (prevUnchanged c_a (start-2))+                                   else return (start-1)+                    j' <- prevUnchanged c_b (j-1)+                    shiftBackward start' (i-1) j'+            else return (start,i,j)+       shiftForward start i j corr blank =+         if i <= aLen p_a && p_a!i == p_a!start &&+             -- B.empty at the end of file marks empty line after final newline+             not ((i == aLen p_a) && (p_a!i == B.empty))+            then do when (i == start) $ error "impossible case"+                    b1 <- readArray c_a i+                    b2 <- readArray c_a start+                    when (not b2 ||  b1) $ error "impossible case"+                    writeArray c_a i True+                    writeArray c_a start False+                    i0 <- nextUnchanged c_a (i+1)+                    j0 <- nextUnchanged c_b (j+1)+                    let corr0+                            | i0 > (i+1) = noline+                            | j0-j > 2 = i0+                            | otherwise = corr+                    let blank0+                            | i0 > i+1 = noline+                            | p_a!(i0-1) == B.empty = i0+                            | otherwise = blank+                    shiftForward (start+1) i0 j0 corr0 blank0+            else return (start,i,j,corr,blank)+       moveCorr start i j corr =+         if corr >= i+            then return (start,i,j)+            else do b1 <- readArray c_a (i-1)+                    b2 <- readArray c_a (start-1)+                    when (not b1 || b2) $ error "impossible case"+                    when (p_a!(i-1) /= p_a!(start-1)) $ error "impossible case"+                    writeArray c_a (i-1) False+                    writeArray c_a (start-1) True+                    j' <- prevUnchanged c_b (j-1)+                    moveCorr (start-1) (i-1) j' corr++-- | goto next unchanged line, return the given line if unchanged+nextUnchanged :: BSTArray s -> Int -> ST s Int+nextUnchanged c i = do+  len <- aLenM c+  if i == len + 1 then return i+     else do b <- readArray c i+             if b then nextUnchanged c (i+1)+                  else return i++-- | skip at least one unchanged line, if there is none advance+--   behind the last line+skipOneUnChanged :: BSTArray s -> Int -> ST s Int+skipOneUnChanged c i = do+  len <- aLenM c+  if i == len + 1+     then return i+     else do b <- readArray c i+             if not b then return (i+1)+                      else skipOneUnChanged c (i+1)++-- | goto n-th next unchanged line+nextUnchangedN :: BSTArray s -> Int -> Int -> ST s Int+nextUnchangedN c n i =+  if n == 0 then return i+            else do i' <- skipOneUnChanged c i+                    nextUnchangedN c (n-1) i'++-- | goto next changed line, return the given line if changed+nextChanged :: BSTArray s -> Int -> ST s (Maybe Int)+nextChanged c i = do+  len <- aLenM c+  if i <= len+    then do b <- readArray c i+            if not b then nextChanged c (i+1)+                     else return $ Just i+    else return Nothing++-- | goto previous unchanged line, return the given line if unchanged+prevUnchanged :: BSTArray s -> Int -> ST s Int+prevUnchanged c i = do+  b <- readArray c i+  if b then prevUnchanged c (i-1)+       else return i++type HArray = UArray Int Int32+type BArray = UArray Int Bool+type PArray = Array Int B.ByteString+type MapArray = UArray Int Int+type VSTArray s = STUArray s Int Int+type BSTArray s = STUArray s Int Bool++initV :: Int -> ST s (VSTArray s)+initV dmax = newArray (-(dmax + 1), dmax + 1) (-1)++initVRev :: Int -> Int -> ST s (VSTArray s)+initVRev dmax xmax = newArray (-(dmax + 1), dmax + 1) (xmax + 1)++-- 1 indexed, v[0] is used as a guard element+initVChanged :: Int -> ST s (BSTArray s)+initVChanged l = do+  a <- newArray (0, l) True+  writeArray a 0 False+  return a+  -- set to false for all lines which have a mapping later+  -- other lines are only present in one of the files++initH :: [Int32] -> HArray+initH a = listArray (0, length a) (0:a)++initM :: [Int] -> MapArray+initM a = listArray (0, length a) (0:a)++initP :: [B.ByteString] -> PArray+initP a = listArray (0, length a) (B.empty:a)++aLen :: (IArray a e) => a Int e -> Int+aLen a = snd $ bounds a+aLenM :: (MArray a e m) => a Int e -> m Int+aLenM a = snd `liftM` getBounds a++convertPatch :: Int -> PArray -> PArray -> (Int, Int, Int, Int)+             -> (Int,[B.ByteString],[B.ByteString])+convertPatch off a b (a0,a1,b0,b1)+ | b0 == b1 = (b0+off,getDelete a a0 a1,[])+ | a0 == a1 = (b0+off,[],getInsert b b0 b1)+ | otherwise = (b0+off,getDelete a a0 a1,getInsert b b0 b1)++getInsert :: PArray -> Int -> Int -> [B.ByteString]+getInsert b from to+  | from >= to = []+  | otherwise = (b!(from+1)):getInsert b (from+1) to+getDelete :: PArray -> Int -> Int -> [B.ByteString]+getDelete a from to+  | from >= to = []+  | otherwise = (a!(from+1)):getDelete a (from+1) to++createPatch :: BArray -> BArray -> [(Int, Int, Int, Int)]+createPatch c_a c_b =+  reverse $ createP c_a c_b (aLen c_a) (aLen c_b)++createP :: BArray -> BArray -> Int -> Int -> [(Int, Int, Int, Int)]+createP _ _ 0 0 = []+createP c_a c_b ia ib =+  if c_a!ia || c_b!ib+     then let ia' = skipChangedRev c_a ia+              ib' = skipChangedRev c_b ib+          in (ia',ia,ib',ib):createP c_a c_b ia' ib'+     else createP c_a c_b (ia-1) (ib-1)++skipChangedRev :: BArray -> Int -> Int+skipChangedRev c i = if i >= 0 && c!i then skipChangedRev c (i-1) else i
+ src/Darcs/Util/Diff/Patience.hs view
@@ -0,0 +1,414 @@+--  Copyright (C) 2002,2008-2009 David Roundy+--+--  This program is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2, or (at your option)+--  any later version.+--+--  This program is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with this program; if not, write to the Free Software Foundation,+--  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.++module Darcs.Util.Diff.Patience+    ( getChanges+    ) where++import Darcs.Prelude++import Data.List ( sort )+import Data.Array.Unboxed+import Data.Array.ST+import Control.Monad.ST+import qualified Data.Set as S+import qualified Data.ByteString as B ( ByteString, elem )+import qualified Data.ByteString.Char8 as BC ( pack )+import qualified Data.Map.Strict as M+    ( Map, lookup, insertWith, empty, elems )+import qualified Data.Hashable as H ( hash )+import Darcs.Util.Diff.Myers (initP, aLen, PArray, getSlice)++empty :: HunkMap+empty = HunkMapInfo 0 M.empty++getChanges ::  [B.ByteString] -> [B.ByteString]+           -> [(Int,[B.ByteString],[B.ByteString])]+getChanges a b = dropStart (initP a) (initP b) 1++dropStart ::  PArray -> PArray -> Int+           -> [(Int,[B.ByteString],[B.ByteString])]+dropStart a b off+  | off > aLen a = [(off - 1, [], getSlice b off (aLen b))]+  | off > aLen b = [(off - 1, getSlice a off (aLen a), [])]+  | a!off == b!off = dropStart a b (off + 1)+  | otherwise      = dropEnd a b off 0++dropEnd ::  PArray -> PArray -> Int -> Int+        -> [(Int,[B.ByteString],[B.ByteString])]+dropEnd a b off end+    | off > alast        = [(off - 1, [], getSlice b off blast)]+    | off > blast        = [(off - 1, getSlice a off alast, [])]+    | a!alast == b!blast = dropEnd a b off (end + 1)+    | otherwise          = getChanges' (off-1) (getSlice a off (aLen a - end')) (getSlice b off (aLen b - end'))+  where end' = addBorings end -- don't drop Borings just in case. See hidden_conflict2.sh+        addBorings e | e > 0 && a!(aLen a - (e-1)) `elem` borings' = addBorings (e-1)+                     | otherwise = e+        alast = aLen a - end+        blast = aLen b - end++getChanges' :: Int -> [B.ByteString] -> [B.ByteString]+              -> [(Int, [B.ByteString], [B.ByteString])]+getChanges' off o n = convertLBS [] $ genNestedChanges [byparagraph, bylines] off oh nh+            where+              (_,m') = listToHunk borings' empty+              (oh,m) = listToHunk o m'+              (nh,lmap) = listToHunk n m+              convertLBS ys [] = reverse ys+              convertLBS ys ((i,os,ns):xs) = convertLBS ((i, hunkToBS os, hunkToBS ns):ys) xs+              hunkToBS hs = map (\h -> (!) harray (abs h)) hs+              harray = getBArray lmap++type HMap = M.Map+type Hash = Int+type Hunk = Int+data HunkMap = HunkMapInfo Int (HMap Hash [(Hunk, B.ByteString)])++getMap :: HunkMap -> HMap Hash [(Hunk, B.ByteString)]+getMap (HunkMapInfo _ m) = m++getSize :: HunkMap -> Int+getSize (HunkMapInfo s _) = s++getBArray :: HunkMap -> Array Hunk B.ByteString+getBArray (HunkMapInfo size b) = array (1,size) $ map (\(x,a) -> (abs x, a)) $ concat $ M.elems b++insert :: Hash -> B.ByteString -> HunkMap -> (Hunk, HunkMap)+insert h bs hmap = (hunknumber, HunkMapInfo newsize (M.insertWith (\_ o -> (hunknumber,bs):o) h [(hunknumber,bs)] $ getMap hmap))+      where hunknumber = if B.elem nl bs then -newsize -- used by bylines+                                         else newsize+            newsize = getSize hmap+1+            nl = 10 -- '\n'++--Given a HunkMap, check collisions and return the line with an updated Map+toHunk' :: HunkMap -> B.ByteString -> (Hunk, HunkMap)+toHunk' lmap bs =+  case M.lookup hash (getMap lmap) of+    Nothing -> insert hash bs lmap+    Just hunkpairs ->+        case filter ((== bs) . snd) hunkpairs of+            [] -> insert hash bs lmap+            (hunknumber, _):_ -> (hunknumber, lmap)+    where hash = H.hash bs++listToHunk :: [B.ByteString] -> HunkMap -> ([Hunk], HunkMap)+listToHunk [] hmap = ([], hmap)+listToHunk (x:xs) hmap = let (y, hmap') = toHunk' hmap x+                             (ys, hmap'') = listToHunk xs hmap'+                         in (y:ys, hmap'')++--listToHunk :: [B.ByteString] -> HunkMap -> ([Hunk], HunkMap)+--listToHunk = listToHunk' []+--      where listToHunk' xs [] hmap = (reverse xs, hmap)+--            listToHunk' xs (y:ys) hmap = let (h,hmap') = toHunk' hmap y+--                                         in listToHunk' (h:xs) ys hmap'+++genNestedChanges :: [[Hunk] -> [[Hunk]]]+                 -> Int -> [Hunk] -> [Hunk]+                 -> [(Int, [Hunk], [Hunk])]+genNestedChanges (br:brs) i0 o0 n0 = nc i0 (lcus ol nl) ol nl+    where nl = br n0+          ol = br o0+          nc i [] o n = easydiff i o n+          nc i (x:xs) o n =+              case break (==x) o of+                (oa, _:ob) ->+                    case break (==x) n of+                      (na, _:nb) ->+                         i' `seq` easydiff i oa na ++ nc i' xs ob nb+                             where i' = i + length (concat na) + length x+                      (_,[]) -> error "impossible case"+                (_,[]) -> error "impossible case"+          easydiff i o n = genNestedChanges brs i oo nn+              where (oo, nn) = (concat o, concat n)+genNestedChanges [] i o n = mkdiff (all (`elem` borings)) i mylcs o n+        where mylcs = patientLcs (filter (`notElem` borings) o)+                                 (filter (`notElem` borings) n)++borings :: [Hunk]+borings = fst $ listToHunk borings' empty++borings' :: [B.ByteString]+borings' = map BC.pack ["", "\n", " ", ")", "(", ","]++byparagraph :: [Hunk] -> [[Hunk]]+byparagraph = reverse . map reverse . byparagraphAcc []+    where byparagraphAcc xs [] = xs+          byparagraphAcc [] (a:b:c:d)+              | a == nl && c == nl && b == hnull = case d of+                                                   [] -> [[c,b,a]]+                                                   _  -> byparagraphAcc [[],[c,b,a]] d+          byparagraphAcc [] (a:as) = byparagraphAcc [[a]] as+          byparagraphAcc (x:xs) (a:b:c:d)+              | a == nl && c == nl && b == hnull = case d of+                                                   [] -> (c:b:a:x):xs+                                                   _  -> byparagraphAcc ([]:((c:b:a:x):xs)) d+          byparagraphAcc (x:xs) (a:as) = byparagraphAcc ((a:x):xs) as+          nl = -1 -- "\n" hunk+          hnull = 1 -- "" hunk toHunk $ BC.pack ""++bylines :: [Hunk] -> [[Hunk]]+bylines = reverse . bylinesAcc []+  where bylinesAcc !ys [] = ys+        bylinesAcc !ys xs = case break (<0) xs of+                              (_,[]) -> xs:ys+                              (a,n:b) -> bylinesAcc ((a++[n]):ys) b+++-- | the longest common subsequence of unique items++lcus :: Ord a => [a] -> [a] -> [a]+lcus xs0 ys0 = lcs (filter (`S.member`u) xs0) (filter (`S.member`u) ys0)+    where uxs = findUnique xs0+          uys = findUnique ys0+          u = S.intersection uxs uys+          findUnique xs = S.fromList $ gru $ sort xs+          gru (x:x':xs) | x == x' = gru (dropWhile (==x) xs)+          gru (x:xs) = x : gru xs+          gru [] = []+++mkdiff :: Ord a =>+          ([a] -> Bool) -> Int -> [a] -> [a] -> [a] -> [(Int,[a],[a])]+mkdiff b ny (l:ls) (x:xs) (y:ys)+    | l == x && l == y = mkdiff b (ny+1) ls xs ys+mkdiff boring ny (l:ls) xs ys+  | rmd == add = mkdiff boring (ny+length add+1) ls restx resty+  | boring rmd && boring add =+      case lcs rmd add of+        [] -> prefixPostfixDiff ny rmd add +++              mkdiff boring (ny+length add+1) ls restx resty+        ll -> mkdiff (const False) ny ll rmd add +++              mkdiff boring  (ny+length add+1) ls restx resty+  | otherwise = prefixPostfixDiff ny rmd add +++                mkdiff boring (ny+length add+1) ls restx resty+    where rmd = takeWhile (/= l) xs+          add = takeWhile (/= l) ys+          restx = drop (length rmd + 1) xs+          resty = drop (length add + 1) ys+mkdiff _ _ [] [] [] = []+mkdiff boring ny [] rmd add+  | boring rmd && boring add =+      case lcs rmd add of+        [] -> prefixPostfixDiff ny rmd add+        ll -> mkdiff (const False) ny ll rmd add+  | otherwise = prefixPostfixDiff ny rmd add++prefixPostfixDiff :: Ord a => Int -> [a] -> [a] -> [(Int,[a],[a])]+prefixPostfixDiff _ [] [] = []+prefixPostfixDiff ny [] ys = [(ny,[],ys)]+prefixPostfixDiff ny xs [] = [(ny,xs,[])]+prefixPostfixDiff ny (x:xs) (y:ys)+    | x == y = prefixPostfixDiff (ny+1) xs ys+    | otherwise = [(ny, reverse rxs', reverse rys')]+    where (rxs',rys') = dropPref (reverse (x:xs)) (reverse (y:ys))+          dropPref (a:as) (b:bs) | a == b = dropPref as bs+          dropPref as bs = (as,bs)++-- | The patientLcs algorithm is inspired by the "patience" algorithm+-- (for which I don't have a reference handy), in that it looks for+-- unique lines, and uses them to subdivide the problem.  I use lcs to+-- diff the unique lines.  It is slower, but should lead to "better"+-- diffs, in the sense of ones that better align with what humans+-- think changed.+-- +-- Note that when compared with the Meyers algorithm used in darcs,+-- this is somewhat slower (maybe 4x in some of my tests), but is+-- lacking its stack overflow problem.  I'm not sure how it scales in+-- general, but it scales fine (just 10x slower than GNU diff) when+-- comparing a 6M american english dictionary with a british english+-- dictionary of the same size (which isn't a great test, but is the+-- largest pair of somewhat-differing files I could find).+-- +-- Note that the patientLcs algorithm is slower than the one used in+-- lcs for sequences with mostly unique elements (as is common in text+-- files), but much *faster* when the sequence has a high degree of+-- redundancy.  i.e. lines /usr/share/dict/words vs lines (cat+-- /usr/share/dict/words | tr 'a-z' 'a')++{-# SPECIALIZE patientLcs ::[Hunk] -> [Hunk] -> [Hunk] #-}+patientLcs :: Ord a => [a] -> [a] -> [a]+patientLcs [] _ = []+patientLcs _ [] = []+patientLcs (c1:c1s) (c2:c2s)+    | c1 == c2 = c1: patientLcs c1s c2s+    | otherwise =+        reverse $ patientLcs0 (reverse (c1:c1s)) (reverse (c2:c2s))++patientLcs0 :: Ord a => [a] -> [a] -> [a]+patientLcs0 xs0@(cc1:cc1s) ys0@(cc2:cc2s)+    | cc1 == cc2 = cc1 : patientLcs0 cc1s cc2s+    | otherwise = case (filter (`S.member`uys) xs0, filter (`S.member`uxs) ys0) of+                    ([],_) -> lcs xs0 ys0+                    (_,[]) -> lcs xs0 ys0+                    (xs',ys') -> joinU (lcs xs' ys') xs0 ys0+    where uxs = findUnique xs0+          uys = findUnique ys0+          joinU [] x y = lcs x y+          joinU (b:bs) cs ds =+                 case break (==b) cs of+                   ([],_:c2) -> b : joinU bs c2 (drop 1 $ dropWhile (/= b) ds)+                   (c1,_:c2) -> case break (==b) ds of+                                  ([],_:d2) -> b : joinU bs c2 d2+                                  (d1,_:d2) -> lcs c1 d1 ++ b : joinU bs c2 d2+                                  _ -> error "impossible case"+                   _ -> error "impossible case"+          findUnique xs = S.fromList $ gru $ sort xs+          gru (x:x':xs) | x == x' = gru (dropWhile (==x) xs)+          gru (x:xs) = x : gru xs+          gru [] = []+          --findUnique xs = fu S.empty S.empty xs+          --    where fu _ uni [] = uni+          --          fu multi uni (y:ys)+          --              | y `S.member` multi = fu multi uni ys+          --              | y `S.member` uni = fu (S.insert y multi) (S.delete y uni) ys+          --              | otherwise = fu multi (S.insert y uni) ys+patientLcs0 [] _ = []+patientLcs0 _ [] = []++-- | ``LCS'' stands for ``Longest Common Subsequence,'' and it is a relatively+-- challenging problem to find an LCS efficiently.  I'm not going to explain+-- here what an LCS is, but will point out that it is useful in finding how+-- two sequences (lists, in this case) differ.  This module implements the+-- Hunt-Szymanski algorithm, which is appropriate for applications in which+-- the sequence is on an infinite alphabet, such as diffing the lines in two+-- files, where many, or most lines are unique.  In the best case scenario, a+-- permutation of unique lines, this algorithm is $O(n\log n)$.  In the worst+-- case scenario, that of a finite alphabet (i.e.\ where the number of elements+-- in the sequence is much greater than the number of unique elements), it is+-- an $O(n^2\log n)$ algorithm, which is pretty terrible.++{-# SPECIALIZE lcs ::[Hunk] -> [Hunk] -> [Hunk] #-}+lcs :: Ord a => [a] -> [a] -> [a]+lcs [] _ = []+lcs _ [] = []+lcs (c1:c1s) (c2:c2s)+    | c1 == c2 = c1: lcs c1s c2s+    | otherwise =+        reverse $ lcsSimple (reverse (c1:c1s)) (reverse (c2:c2s))++lcsSimple :: Ord a => [a] -> [a] -> [a]+lcsSimple [] _ = []+lcsSimple _ [] = []+lcsSimple s1@(c1:c1s) s2@(c2:c2s)+    | c1 == c2 = c1: lcs c1s c2s+    | otherwise = hunt $ pruneMatches s1 $! findMatches s1 s2++pruneMatches :: [a] -> [[Int]] -> [(a, [Int])]+pruneMatches _ [] = []+pruneMatches [] _ = []+pruneMatches (_:cs) ([]:ms) = pruneMatches cs ms+pruneMatches (c:cs) (m:ms) = (c,m): pruneMatches cs ms++type Threshold s a = STArray s Int (Int,[a])++hunt :: [(a, [Int])] -> [a]+hunt [] = []+hunt csmatches =+    runST ( do th <- emptyThreshold (length csmatches) l+               huntInternal csmatches th+               huntRecover th (-1) l )+    where l = maximum (0 : concat (map snd csmatches))++huntInternal :: [(a, [Int])] -> Threshold s a -> ST s ()+huntInternal [] _ = return ()+huntInternal ((c,m):csms) th = do+    huntOneChar c m th+    huntInternal csms th++huntOneChar :: a -> [Int] ->  Threshold s a -> ST s ()+huntOneChar _ [] _ = return ()+huntOneChar c (j:js) th = do+    index_k <- myBs j th+    case index_k of+      Nothing -> return ()+      Just k -> do+        (_, rest) <- readArray th (k-1)+        writeArray th k (j, c:rest)+    huntOneChar c js th++-- This is O(n), which is stupid.+huntRecover :: Threshold s a -> Int -> Int -> ST s [a]+huntRecover th n limit =+ do (_, th_max) <- getBounds th+    if n < 0+       then huntRecover th th_max limit+       else if n == 0 || n > th_max+            then return []+            else do (thn, sn) <- readArray th n+                    if thn <= limit+                      then return $ reverse sn+                      else huntRecover th (n-1) limit++emptyThreshold :: Int -> Int -> ST s (Threshold s a)+emptyThreshold l th_max = do+  th <- newArray (0,l) (th_max+1, [])+  writeArray th 0 (0, [])+  return th++myBs :: Int -> Threshold s a -> ST s (Maybe Int)+myBs j th = do bnds <- getBounds th+               myHelperBs j bnds th++myHelperBs :: Int -> (Int,Int) -> Threshold s a ->+                ST s (Maybe Int)+myHelperBs j (th_min,th_max) th =+    if th_max - th_min > 1 then do+       (midth, _) <- readArray th th_middle+       if j > midth+         then myHelperBs j (th_middle,th_max) th+         else myHelperBs j (th_min,th_middle) th+    else do+       (minth, _) <- readArray th th_min+       (maxth, _) <- readArray th th_max+       if minth < j && maxth > j+          then return $ Just th_max+          else if j < minth then return $ Just th_min+               else return Nothing+    where th_middle = (th_max+th_min) `div` 2++++findMatches :: Ord a => [a] -> [a] -> [[Int]]+findMatches [] [] = []+findMatches [] (_:bs) = []: findMatches [] bs+findMatches _ [] = []+findMatches a b =+    unzipIndexed $ sort $ findSortedMatches indexeda indexedb [] []+    where indexeda = sort $ zip a [1..]+          indexedb = sort $ zip b [1..]++unzipIndexed :: [(Int,[a])] -> [[a]]+unzipIndexed s = unzipIndexedHelper 1 s+    where unzipIndexedHelper _ [] = []+          unzipIndexedHelper thisl ((l,c):rest)+           | thisl == l = c: unzipIndexedHelper (l+1) rest+           | otherwise = []: unzipIndexedHelper (thisl+1) ((l,c):rest)++findSortedMatches :: Ord a => [(a, Int)] -> [(a, Int)] -> [a] -> [Int]+                             -> [(Int, [Int])]+findSortedMatches [] _ _ _ = []+findSortedMatches _ [] _ _ = []+findSortedMatches ((a,na):as) ((b,nb):bs) aold aoldmatches+    | [a] == aold = (na, aoldmatches) :+                    findSortedMatches as ((b,nb):bs) aold aoldmatches+    | a > b = findSortedMatches ((a,na):as) bs aold aoldmatches+    | a < b = findSortedMatches as ((b,nb):bs) aold aoldmatches+-- following line is inefficient if a line is repeated many times.+findSortedMatches ((a,na):as) bs _ _ -- a == b+      = (na, matches) : findSortedMatches as bs [a] matches+    where matches = reverse $ map snd $ filter ((==a) . fst) bs
+ src/Darcs/Util/Encoding.hs view
@@ -0,0 +1,68 @@+-- Copyright 2007-2009, Judah Jacobson.+-- All Rights Reserved.++-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:++-- - Redistribution of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.++-- - Redistribution in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.++-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+{-# LANGUAGE CPP #-}+module Darcs.Util.Encoding+    ( encode, decode+    , encodeUtf8, decodeUtf8+    ) where++import Darcs.Prelude++import qualified Data.ByteString as B+import GHC.IO.Encoding ( TextEncoding, mkTextEncoding )+import GHC.Foreign ( withCStringLen, peekCStringLen )++#ifdef WIN32+import Darcs.Util.Encoding.Win32 ( encode, decode )+#else++import GHC.IO.Encoding ( getFileSystemEncoding )++-- | Encode a 'String' into a 'B.ByteString' according to the user's locale+-- with the ghc specific //ROUNDTRIP feature added. This means the argument+-- is allowed to contain non-Unicode 'Char's as produced by 'decode'.+encode :: String -> IO B.ByteString+encode s = getFileSystemEncoding >>= textEncode s++-- | Decode a 'B.ByteString' into a 'String' according to the user's locale+-- with the ghc specific //ROUNDTRIP feature added. This means the result+-- may contain 'Char's that are not valid Unicode in case decoding with the+-- user's locale fails.+decode :: B.ByteString -> IO String+decode bs = getFileSystemEncoding >>= textDecode bs++#endif++encodeUtf8 :: String -> IO B.ByteString+encodeUtf8 s = mkTextEncoding "UTF-8//TRANSLIT" >>= textEncode s++decodeUtf8 :: B.ByteString -> IO String+decodeUtf8 bs = mkTextEncoding "UTF-8//TRANSLIT" >>= textDecode bs++textEncode :: String -> TextEncoding -> IO B.ByteString+textEncode s enc = withCStringLen enc s B.packCStringLen++textDecode :: B.ByteString -> TextEncoding -> IO String+textDecode bs enc = B.useAsCStringLen bs (peekCStringLen enc)+
+ src/Darcs/Util/Encoding/Win32.hs view
@@ -0,0 +1,87 @@+-- Copyright 2007-2009, Judah Jacobson.+-- All Rights Reserved.++-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:++-- - Redistribution of source code must retain the above copyright notice,+-- this list of conditions and the following disclaimer.++-- - Redistribution in binary form must reproduce the above copyright notice,+-- this list of conditions and the following disclaimer in the documentation+-- and/or other materials provided with the distribution.++-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY+-- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+-- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+-- DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE+-- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+-- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+-- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+-- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+-- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE+-- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module Darcs.Util.Encoding.Win32+    ( encode, decode+    ) where++import Darcs.Prelude++import Data.ByteString.Internal ( createAndTrim )+import qualified Data.ByteString as B+    ( ByteString, useAsCStringLen )+import Foreign ( castPtr, allocaArray0 )+import Foreign.C+    ( CInt(..), peekCWStringLen, withCWStringLen )+import System.Win32+    ( CodePage, nullPtr, getConsoleCP, getACP+    , LPCSTR, LPWSTR, LPCWSTR, LPBOOL, DWORD )++#include <windows_cconv.h>++-- | Encode a Unicode 'String' into a 'ByteString' suitable for the current+-- console.+encode :: String -> IO B.ByteString+encode str = getCodePage >>= flip unicodeToCodePage str++-- | Convert a 'ByteString' from the console's encoding into a Unicode 'String'.+decode :: B.ByteString -> IO String+decode str = getCodePage >>= flip codePageToUnicode str++------------------------+-- Multi-byte conversion++foreign import WINDOWS_CCONV "WideCharToMultiByte" wideCharToMultiByte+        :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt+                -> LPCSTR -> LPBOOL -> IO CInt++unicodeToCodePage :: CodePage -> String -> IO B.ByteString+unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do+    -- first, ask for the length without filling the buffer.+    outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen)+                    nullPtr 0 nullPtr nullPtr+    -- then, actually perform the encoding.+    createAndTrim (fromEnum outSize) $ \outBuff ->+        fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen)+                    (castPtr outBuff) outSize nullPtr nullPtr++foreign import WINDOWS_CCONV "MultiByteToWideChar" multiByteToWideChar+        :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt++codePageToUnicode :: CodePage -> B.ByteString -> IO String+codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do+    -- first ask for the size without filling the buffer.+    outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0+    -- then, actually perform the decoding.+    allocaArray0 (fromEnum outSize) $ \outBuff -> do+        outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize+        peekCWStringLen (outBuff, fromEnum outSize')++getCodePage :: IO CodePage+getCodePage = do+    conCP <- getConsoleCP+    if conCP > 0+        then return conCP+        else getACP+
+ src/Darcs/Util/English.hs view
@@ -0,0 +1,115 @@+-- Copyright (C) 2008 Eric Kow+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Copyright   : 2008 Eric Kow+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable+--+-- This modules provides rudimentary natural language generation+-- (NLG) utilities.  That is, generating natural language from a+-- machine representation.  Initially, only English is supported at+-- all.  Representations are implemented for:+--+--  * countable nouns (plurality); and+--  * lists of clauses (foo, bar and/or baz).++module Darcs.Util.English where++import Darcs.Prelude++import Data.Char (toUpper)+import Data.List (isSuffixOf)++import Darcs.Util.Printer ( Doc, vcat, text )++-- | > englishNum 0 (Noun "watch") "" == "watches"+--   > englishNum 1 (Noun "watch") "" == "watch"+--   > englishNum 2 (Noun "watch") "" == "watches"+englishNum :: Countable n => Int -> n -> ShowS+englishNum x = if x == 1 then singular else plural++-- | Things that have a plural and singular spelling+class Countable a where+    plural :: a -> ShowS+    singular :: a -> ShowS++-- | This only distinguishes between nouns with a final -ch,+--   and nouns which do not.+--   More irregular nouns will just need to have their own type+--+--   > plural (Noun "batch") "" == "batches"+--   > plural (Noun "bat")   "" == "bats"+--   > plural (Noun "mouse") "" == "mouses" -- :-(+newtype Noun = Noun String+data Pronoun = It++instance Countable Noun where+    -- more irregular nouns will just need to have their own type+    plural (Noun s) | "ch" `isSuffixOf` s = showString s .  showString "es"+    plural (Noun s) | "y" `isSuffixOf` s+                      && length s > 1+                      && last (init s) `notElem` "aeiou" =+                            showString (init s) . showString "ies"+    plural (Noun s) = showString s . showChar 's'+    singular (Noun s) =  showString s++instance Countable Pronoun where+    plural It = showString "them"+    singular It = showString "it"++-- | > singular This (Noun "batch") "" == "this batch"+--   > plural   This (Noun "batch") "" == "these batches"+data This = This Noun++instance Countable This where+    plural (This s)   = showString "these "  . plural s+    singular (This s) = showString "this "   . singular s++-- | Given a list of things, combine them thusly:+--+--   > orClauses ["foo", "bar", "baz"] == "foo, bar or baz"+andClauses, orClauses :: [String] -> String+andClauses = itemize "and"+orClauses = itemize "or"++anyOfClause :: [String] -> Doc+anyOfClause names = if length names > 1 then text "any of" else mempty++itemizeVertical :: Int -> [String] -> Doc+itemizeVertical indent = vcat . map (text . ((replicate indent ' ' ++ "- ") ++))++-- Should not be called with an empty list since this usually+-- prints an extra space. We allow it for compatibility.+itemize :: String -> [String] -> String+itemize _ [] = "" -- error "precondition in Darcs.Util.English.itemize"+itemize _ [x] = x+itemize sep [x,x'] = unwords [x, sep, x']+itemize sep (x:x':xs) = itemize' x x' xs where+  itemize' y y' [] = unwords [y ++ ",", sep, y']+  itemize' y y' (y'':ys) = unwords [y ++ ",", itemize' y' y'' ys]++presentParticiple :: String -> String+presentParticiple v | last v == 'e' = init v ++ "ing"+                     | otherwise = v ++ "ing"++-- | Capitalize the first letter of a word+capitalize :: String -> String+capitalize []     = []+capitalize (x:xs) = toUpper x : xs
+ src/Darcs/Util/Exception.hs view
@@ -0,0 +1,113 @@+module Darcs.Util.Exception+    ( firstJustIO+    , catchall+    , clarifyErrors+    , prettyException+    , prettyError+    , die+    , handleOnly+    , handleOnlyIOError+    , catchDoesNotExistError+    , handleDoesNotExistError+    , ifIOError+    , ifDoesNotExistError+    ) where+++import Darcs.Prelude++import Control.Exception+    ( Exception(fromException)+    , SomeException+    , catch+    , handle+    , throwIO+    )+import Data.Maybe ( isJust )++import System.Exit ( exitFailure )+import System.IO ( stderr, hPutStrLn )+import System.IO.Error+    ( ioeGetErrorString+    , ioeGetFileName+    , isDoesNotExistError+    , isUserError+    )++import Darcs.Util.Global ( debugMessage )+import Darcs.Util.SignalHandler ( catchNonSignal )++catchall :: IO a -> IO a -> IO a+a `catchall` b = a `catchNonSignal` (\e -> debugMessage ("catchall: "++show e) >> b)++-- | The firstJustM returns the first Just entry in a list of monadic+-- operations. This is close to `listToMaybe `fmap` sequence`, but the sequence+-- operator evaluates all monadic members of the list before passing it along+-- (i.e. sequence is strict). The firstJustM is lazy in that list member monads+-- are only evaluated up to the point where the first Just entry is obtained.+firstJustM :: Monad m+           => [m (Maybe a)]+           -> m (Maybe a)+firstJustM [] = return Nothing+firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)+++-- | The firstJustIO is a slight modification to firstJustM: the entries in the+-- list must be IO monad operations and the firstJustIO will silently turn any+-- monad call that throws an exception into Nothing, basically causing it to be+-- ignored.+firstJustIO :: [IO (Maybe a)]+            -> IO (Maybe a)+firstJustIO = firstJustM . map (`catchall` return Nothing)+++clarifyErrors :: IO a+              -> String+              -> IO a+clarifyErrors a e = a `catch` (\x -> die $ unlines [prettyException x,e])++prettyException :: SomeException+                -> String+prettyException e | Just ioe <- fromException e, isUserError ioe = ioeGetErrorString ioe+prettyException e | Just ioe <- fromException e, isDoesNotExistError ioe =+  case ioeGetFileName ioe of+    Just f  -> f ++ " does not exist"+    Nothing -> show e+prettyException e = show e+++prettyError :: IOError -> String+prettyError e | isUserError e = ioeGetErrorString e+              | otherwise = show e++-- | Terminate the program with an error message.+die :: String -> IO a+die msg = hPutStrLn stderr msg >> exitFailure++-- | Handle only actual IO exceptions i.e. not "user errors" e.g. those raised+-- by calling 'fail'.+--+-- We use 'fail' all over the place to signify erroneous conditions and we+-- normally don't want to handle such errors.+handleOnlyIOError :: IO a -> IO a -> IO a+handleOnlyIOError = handleOnly (not . isUserError)++-- | Handle only non-existence.+handleDoesNotExistError :: IO a -> IO a -> IO a+handleDoesNotExistError = handleOnly isDoesNotExistError++-- | Handle only non-existence.+catchDoesNotExistError :: IO a -> IO a -> IO a+catchDoesNotExistError = flip handleDoesNotExistError++-- | Like 'handleOnlyIOError' but restricted to returning a given value.+ifIOError :: a -> IO a -> IO a+ifIOError use_instead = handleOnlyIOError (return use_instead)++-- | Like 'ifIOError' but restricted to handling non-existence.+ifDoesNotExistError :: a -> IO a -> IO a+ifDoesNotExistError use_instead = handleOnly isDoesNotExistError (return use_instead)++-- | Handle only a those exceptions for which the predicate succeeds.+handleOnly :: Exception e => (e -> Bool) -> IO a -> IO a -> IO a+handleOnly pred handler = handle (\e -> if pred e then handler else throwIO e)
+ src/Darcs/Util/Exec.hs view
@@ -0,0 +1,258 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++-- |+-- Module      : Darcs.Util.Exec+-- Copyright   : 2003 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.Util.Exec+    (+      exec+    , execInteractive+    , readInteractiveProcess+    , renderExecException+    , withoutNonBlock+    , Redirects+    , Redirect(..)+    , ExecException(..)+    ) where++import Darcs.Prelude++#ifndef WIN32+import Control.Exception ( bracket )+import Control.Monad ( forM_ )+import System.Posix.Env ( setEnv, getEnv, unsetEnv )+import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput )+#else+import Control.Exception ( catchJust, IOException )+import Data.List ( isInfixOf )+#endif++import GHC.IO.Handle ( hDuplicate )++import Control.Concurrent ( forkIO )+import Control.Concurrent.MVar ( newEmptyMVar, takeMVar, putMVar )+import Control.Exception+    ( evaluate, bracketOnError, Exception(..), SomeException(..) )+import Data.Typeable ( Typeable, cast )+import System.Process ( system )+import qualified System.Process as P+import System.Exit ( ExitCode (..) )+import System.IO ( IOMode(..), openBinaryFile, stdin, stdout, hGetContents, hClose )+import System.Process   ( runProcess, terminateProcess, waitForProcess )++import Darcs.Util.Global ( whenDebugMode )+import Darcs.Util.Progress ( withoutProgress )++{-+   A redirection is a three-tuple of values (in, out, err).+   The most common values are:++     AsIs    don't change it+     Null    /dev/null on Unix, NUL on Windows+     File    open a file for reading or writing++   There is also the value Stdout, which is only meaningful for+   redirection of errors, and is performed AFTER stdout is+   redirected so that output and errors mix together. StdIn and+   StdErr could be added as well if they are useful.++   NOTE: Lots of care must be taken when redirecting stdin, stdout+   and stderr to one of EACH OTHER, since the ORDER in which they+   are changed have a significant effect on the result.+-}++type Redirects = (Redirect, Redirect, Redirect)++data Redirect = AsIs+              | Null+              | File FilePath+              | Stdout+                deriving Show++{-+  ExecException is thrown by exec if any system call fails,+  for example because the executable we're trying to run+  doesn't exist.+-}+--                   ExecException cmd    args     redirecs  errorDesc+data ExecException = ExecException+                        String     -- cmd+                        [String]   -- args+                        Redirects  -- redirects+                        String     -- errorDesc+                     deriving (Typeable)++instance Exception ExecException where+    toException = SomeException+    fromException (SomeException e) = cast e++renderExecException :: ExecException -> String+renderExecException (ExecException cmd args _ msg) =+  concat [+    "The program \"", unwords (cmd:args),+    "\" failed with error: \"",msg,"\"."]++instance Show ExecException where+  show = renderExecException++_devNull :: FilePath+#ifdef WIN32+-- since GHC 8.6, Windows special devices need to be referred to using+-- "device namespace" syntax. See+-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/win32-dlls.html#windows-file-paths+_devNull = "\\\\.\\NUL"+#else+_devNull = "/dev/null"+#endif++{-+  We use System.Process, which does the necessary quoting+  and redirection for us behind the scenes.+-}+exec  :: String -> [String] -> Redirects -> IO ExitCode+exec cmd args (inp,out,err) = withoutProgress $ do+    h_stdin  <- redirect inp ReadMode+    h_stdout <- redirect out WriteMode+    h_stderr <- redirect err WriteMode+    withExit127 $ bracketOnError+      (do doOptionalDebug+          runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr)+      terminateProcess+      waitForProcess+  where+    doOptionalDebug = whenDebugMode . putStrLn . unwords $+        cmd : args ++ ["; #"] ++ map show [inp, out, err]+    redirect AsIs               _    = return Nothing+    redirect Null               mode = Just `fmap` openBinaryFile _devNull mode+    redirect (File "/dev/null") mode = redirect Null mode+    redirect (File f)           mode = Just `fmap` openBinaryFile f mode+    -- hDuplicate stdout rather than passing stdout itself,+    -- because runProcess closes the Handles we pass it.+    redirect Stdout             _    = Just `fmap` hDuplicate stdout++execInteractive :: String -> Maybe String -> IO ExitCode+#ifndef WIN32+{-+This should handle arbitrary commands interpreted by the shell on Unix since+that's what people expect. But we don't want to allow the shell to interpret+the argument in any way, so we set an environment variable and call+cmd "$DARCS_ARGUMENT"+-}+execInteractive cmd mArg = withoutProgress $ do+    let var = "DARCS_ARGUMENT"+    stdin `seq` return ()+    withoutNonBlock $ bracket+      (do oldval <- getEnv var+          forM_ mArg $ \arg ->+            setEnv var arg True+          return oldval)+      (\oldval ->+         case oldval of+              Nothing -> unsetEnv var+              Just val -> setEnv var val True)+      (\_ -> withExit127 $ system $ cmd++ maybe "" (const (" \"$"++var++"\"")) mArg)++#else+-- The `system' function passes commands to execute via cmd.exe (or+-- command.com) it's return value is equivalent to the one returned by the+-- shell. For regular applications - this works correctly resulting in the+-- exit code of the program. However in case of a command/file which can't be+-- found - cmd.exe will return 1 instead of propagating the ExitFailure 9009+-- which on windows is equivalent to ExitFailure 127 from *nix machines.+--+-- Here we force return the exit code of the last cmd.exe action by appending+-- & exit !errorlevel! to the command being executed that way chaining with+-- ortryrunning works correctly.+--+-- SETLOCAL EnableDelayedExpansion makes sure that !variable! expansion is done+-- correctly on systems where that function is not enabled by default.+--+execInteractive cmd mArg = withoutProgress $+  withExit127 $ system $ "SETLOCAL EnableDelayedExpansion & " +++                          cmd ++ maybe "" (" " ++) mArg +++                          " & exit !errorlevel!"+#endif++withoutNonBlock :: IO a -> IO a+#ifndef WIN32+{-+Do IO without NonBlockingRead on stdInput.++This is needed when running unsuspecting external commands with interactive+mode - if read from terminal is non-blocking also write to terminal is+non-blocking.+-}+withoutNonBlock x =+    do nb <- queryFdOption stdInput NonBlockingRead+       if nb+          then bracket+                   (setFdOption stdInput NonBlockingRead False)+                   (\_ -> setFdOption stdInput NonBlockingRead True)+                   (\_ -> x)+          else x+#else+withoutNonBlock x = x+#endif++readInteractiveProcess+    :: FilePath                 -- ^ command to run+    -> [String]                 -- ^ any arguments+    -> IO (ExitCode,String)      -- ^ exitcode, stderr+readInteractiveProcess cmd args = do+    inh' <- hDuplicate stdin+    outh <- hDuplicate stdout+    (_, _, Just errh, pid) <-+        P.createProcess (P.proc cmd args){+          P.std_in  = P.UseHandle inh',+          P.std_out = P.UseHandle outh,+          P.std_err = P.CreatePipe }+    errMVar <- newEmptyMVar++    errors <- hGetContents errh+    _ <- forkIO $ do+      _ <- evaluate (length errors)+      putMVar errMVar errors++    err <- takeMVar errMVar+    hClose errh++    ex <- waitForProcess pid++    return (ex, err)+  +{-+Ensure that we exit 127 if the thing we are trying to run does not exist+(Only needed under Windows)+-}+withExit127 :: IO ExitCode -> IO ExitCode+#ifdef WIN32+withExit127 a = catchJust notFoundError a (const $ return $ ExitFailure 127)++notFoundError :: IOException -> Maybe ()+notFoundError e | "runProcess: does not exist" `isInfixOf` show e = Just ()+notFoundError _ = Nothing+#else+withExit127 = id+#endif
+ src/Darcs/Util/File.hs view
@@ -0,0 +1,235 @@+module Darcs.Util.File+    ( -- * Files and directories+      getFileStatus+    , doesDirectoryReallyExist+    , removeFileMayNotExist+    , getRecursiveContents+    , getRecursiveContentsFullPath+    , copyTree+      -- * Fetching files+    , fetchFilePS+    , fetchFileLazyPS+    , gzFetchFilePS+    , speculateFileOrUrl+    , copyFileOrUrl+    , Cachable(..)+      -- * Backup+    , backupByRenaming+    , backupByCopying+      -- * Temporary files+    , withTemp+    , withOpenTemp+    ) where++import Darcs.Prelude+import Darcs.Util.ByteString ( gzReadFilePS )+import Darcs.Util.Exception ( catchall, ifDoesNotExistError )+import Darcs.Util.Global ( defaultRemoteDarcsCmd )+import Darcs.Util.HTTP ( Cachable(..) )+import qualified Darcs.Util.HTTP as HTTP+import Darcs.Util.Path ( FilePathLike, toFilePath )+import Darcs.Util.Ssh ( copySSH )+import Darcs.Util.URL ( isHttpUrl, isSshUrl, isValidLocalPath, splitSshUrl )++import Control.Exception ( IOException, bracket, catch )+import Control.Monad ( forM, unless, when, zipWithM_ )+import qualified Data.ByteString as B ( ByteString, readFile )+import qualified Data.ByteString.Lazy as BL+import Network.URI ( parseURI, uriScheme )+import System.Directory+    ( copyFile+    , createDirectory+    , doesDirectoryExist+    , doesFileExist+    , listDirectory+    , removeFile+    , renameDirectory+    , renameFile+    )+import System.FilePath.Posix ( normalise, (</>) )+import System.IO ( Handle, hClose, openBinaryTempFile )+import System.IO.Error ( catchIOError, isDoesNotExistError )+import System.Posix.Files+    ( FileStatus+    , createLink+    , getSymbolicLinkStatus+    , isDirectory+    , isRegularFile+    )++-- | Badly named, since it is actually 'getSymbolicLinkStatus', with all+-- 'IOError's turned into 'Nothing'.+getFileStatus :: FilePath -> IO (Maybe FileStatus)+getFileStatus f =+  Just `fmap` getSymbolicLinkStatus f `catchIOError` (\_-> return Nothing)++-- | Whether a path is an existing directory, but not a symlink to one.+doesDirectoryReallyExist :: FilePath -> IO Bool+doesDirectoryReallyExist f =+    ifDoesNotExistError False (isDirectory `fmap` getSymbolicLinkStatus f)++-- | Variant of 'removeFile' that doesn't throw exception when file does not exist.+removeFileMayNotExist :: FilePathLike p => p -> IO ()+removeFileMayNotExist f = ifDoesNotExistError () (removeFile $ toFilePath f)++-- | Return all files under given directory that aren't directories.+getRecursiveContents :: FilePath -> IO [FilePath]+getRecursiveContents topdir = do+  entries <- listDirectory topdir+  paths <- forM entries $ \name -> do+    let path = topdir </> name+    isDir <- doesDirectoryExist path+    if isDir+      then getRecursiveContents path+      else return [name]+  return (concat paths)++-- | Return all files under given directory that aren't directories.+-- Unlike 'getRecursiveContents' this function returns the full path.+getRecursiveContentsFullPath :: FilePath -> IO [FilePath]+getRecursiveContentsFullPath topdir = do+  entries <- listDirectory topdir+  paths <- forM entries $ \name -> do+    let path = topdir </> name+    isDir <- doesDirectoryExist path+    if isDir+      then getRecursiveContentsFullPath path+      else return [path]+  return (concat paths)++-- | Very much darcs-specific copying procedure. For local files it tries+-- to hard-link, falling back to normal copy if it fails. Remote URLs are+-- downloaded using either HTTP or SSH. For SSH, this tries to use the+-- given remote darcs command to invoke it's transfer-mode command.+copyFileOrUrl :: String    -- ^ remote darcs executable+              -> String    -- ^ path representing the origin file or URL+              -> FilePath  -- ^ destination path+              -> Cachable  -- ^ tell whether file to copy is cachable+              -> IO ()+copyFileOrUrl _    fou out _     | isValidLocalPath fou = copyLocal fou out+copyFileOrUrl _    fou out cache | isHttpUrl fou = HTTP.copyRemote fou out cache+copyFileOrUrl rd   fou out _     | isSshUrl fou = copySSH rd (splitSshUrl fou) out+copyFileOrUrl _    fou _   _     = fail $ "unknown transport protocol: " ++ fou++-- | Hard-link file, falling back to normal copying it that fails.+copyLocal  :: String -> FilePath -> IO ()+copyLocal fou out = createLink fou out `catchall` copyFile fou out++-- | Recursively copy a directory, where the target directory is supposed to+-- already exist.+copyTree :: FilePath -> FilePath -> IO ()+copyTree source dest =+ do fs <- getSymbolicLinkStatus source+    if isDirectory fs then do+        fps <- listDirectory source+        zipWithM_ copySubTree (map (source </>) fps) (map (dest </>) fps)+     else fail ("copyTree: Bad source " ++ source)+   `catch` \(_ :: IOException) -> fail ("copyTree: Bad source " ++ source)++-- | Recursively copy a directory, where the target directory does not yet+-- exist but it's parent does.+copySubTree :: FilePath -> FilePath -> IO ()+copySubTree source dest =+ do fs <- getSymbolicLinkStatus source+    if isDirectory fs then do+        createDirectory dest+        fps <- listDirectory source+        zipWithM_ copySubTree (map (source </>) fps) (map (dest </>) fps)+     else if isRegularFile fs then+        copyFile source dest+     else fail ("copySubTree: Bad source "++ source)+    `catch` (\e -> unless (isDoesNotExistError e) $ ioError e)++backupByRenaming :: FilePath -> IO ()+backupByRenaming = backupBy rename+ where rename x y = do+         isD <- doesDirectoryExist x+         if isD then renameDirectory x y else renameFile x y++backupByCopying :: FilePath -> IO ()+backupByCopying = backupBy copy+ where+  copy x y = do+    isD <- doesDirectoryExist x+    if isD then do createDirectory y+                   copyTree (normalise x) (normalise y)+           else copyFile x y++backupBy :: (FilePath -> FilePath -> IO ()) -> FilePath -> IO ()+backupBy backup f =+           do hasBF <- doesFileExist f+              hasBD <- doesDirectoryExist f+              when (hasBF || hasBD) $ helper 0+  where+  helper :: Int -> IO ()+  helper i = do existsF <- doesFileExist next+                existsD <- doesDirectoryExist next+                if existsF || existsD+                   then helper (i + 1)+                   else do putStrLn $ "Backing up " ++ f ++ "(" ++ suffix ++ ")"+                           backup f next+             where next = f ++ suffix+                   suffix = ".~" ++ show i ++ "~"++-- | Generic file fetching support function that takes care of downloading+-- remote files to a temporary location if necessary before invoking the actual+-- reading procedure.+copyAndReadFile :: (FilePath -> IO a) -> String -> Cachable -> IO a+copyAndReadFile readfn fou _ | isValidLocalPath fou = readfn fou+copyAndReadFile readfn fou cache = withTemp $ \t -> do+  copyFileOrUrl defaultRemoteDarcsCmd fou t cache+  readfn t++-- | @fetchFilePS fileOrUrl cache@ returns the content of its argument (either a+-- file or an URL). If it has to download an url, then it will use a cache as+-- required by its second argument.+--+-- We always use default remote darcs, since it is not fatal if the remote+-- darcs does not exist or is too old -- anything that supports transfer-mode+-- should do, and if not, we will fall back to SFTP or SCP.+fetchFilePS :: String -> Cachable -> IO B.ByteString+fetchFilePS = copyAndReadFile B.readFile++-- | @fetchFileLazyPS fileOrUrl cache@ lazily reads the content of its argument+-- (either a file or an URL). Warning: this function may constitute a fd leak;+-- make sure to force consumption of file contents to avoid that. See+-- "fetchFilePS" for details.+fetchFileLazyPS :: String -> Cachable -> IO BL.ByteString+fetchFileLazyPS x c =+  case parseURI x of+    Just x'+      | let s = uriScheme x'+      , s == "http:" || s == "https:" -> HTTP.copyRemoteLazy x c+    _ -> copyAndReadFile BL.readFile x c++-- | Like 'fetchFilePS' but transparently handle gzip compressed files.+gzFetchFilePS :: String -> Cachable -> IO B.ByteString+gzFetchFilePS = copyAndReadFile gzReadFilePS++-- | Initiate background file download for the given file path or URL+-- to the given location.+speculateFileOrUrl :: String -> FilePath -> IO ()+speculateFileOrUrl fou out+  | isHttpUrl fou = HTTP.speculateRemote fou out+  | otherwise = return ()++-- | Invoke the given action on a file that is temporarily created+-- in the current directory, and removed afterwards.+withTemp :: (FilePath -> IO a) -> IO a+withTemp = bracket get_empty_file removeFileMayNotExist+  where+    get_empty_file = do+      (f, h) <- openBinaryTempFile "." "darcs"+      hClose h `catchall` return ()+      return f++-- | Invoke the given action on a file that is temporarily created and opened+-- in the current directory, and closed and removed afterwards.+withOpenTemp :: ((Handle, FilePath) -> IO a) -> IO a+withOpenTemp = bracket get_empty_file cleanup+  where+    cleanup (h, f) = do+      hClose h `catchall` return ()+      removeFileMayNotExist f+    get_empty_file = swap `fmap` openBinaryTempFile "." "darcs"+    swap (a, b) = (b, a)
+ src/Darcs/Util/Global.hs view
@@ -0,0 +1,138 @@+-- Copyright (C) 2005 Tomasz Zielonka+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module      : Darcs.Util.Global+-- Copyright   : 2005 Tomasz Zielonka+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable+--+-- This was originally Tomasz Zielonka's AtExit module, slightly generalised+-- to include global variables.  Here, we attempt to cover broad, global+-- features, such as exit handlers.  These features slightly break the Haskellian+-- purity of darcs, in favour of programming convenience.++module Darcs.Util.Global+    ( setTimingsMode+    , whenDebugMode+    , withDebugMode+    , setDebugMode+    , debugMessage+    , addCRCWarning+    , getCRCWarnings+    , resetCRCWarnings+    , darcsdir+    , darcsLastMessage+    , darcsSendMessage+    , darcsSendMessageFinal+    , defaultRemoteDarcsCmd+    ) where+++import Darcs.Prelude++import Control.Monad ( when )+import Data.IORef ( IORef, modifyIORef, newIORef, readIORef, writeIORef )+import Data.Time.Clock.System ( getSystemTime, systemToTAITime )+import Data.Time.Clock.TAI ( AbsoluteTime, diffAbsoluteTime )+import Data.Time.Format ( defaultTimeLocale, formatTime )+import System.FilePath.Posix ( combine, (<.>) )+import System.IO ( hPutStr, hPutStrLn, stderr )+import System.IO.Unsafe ( unsafePerformIO )+++-- Write-once-read-many global variables make it easier to implement flags, such+-- as --no-ssh-cm. Using global variables reduces the number of parameters that+-- we have to pass around, but it is rather unsafe and should be used sparingly.+++_debugMode :: IORef Bool+_debugMode = unsafePerformIO $ newIORef False+{-# NOINLINE _debugMode #-}+++setDebugMode :: IO ()+setDebugMode = writeIORef _debugMode True+++whenDebugMode :: IO () -> IO ()+whenDebugMode j = do b <- readIORef _debugMode+                     when b j+++withDebugMode :: (Bool -> IO a) -> IO a+withDebugMode j = readIORef _debugMode >>= j+++debugMessage :: String -> IO ()+debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m+++putTiming :: IO ()+putTiming = do+  readIORef _timingsMode >>= \case+    Nothing -> return ()+    Just start -> do+      now <- systemToTAITime <$> getSystemTime+      hPutStr stderr (format (diffAbsoluteTime now start))+  where+    -- mm:ss.micros, similar to `ts -s "%m:%.S"`+    format = formatTime defaultTimeLocale "%02m:%06ES "++_timingsMode :: IORef (Maybe AbsoluteTime)+_timingsMode = unsafePerformIO $ newIORef Nothing+{-# NOINLINE _timingsMode #-}++setTimingsMode :: IO ()+setTimingsMode = do+  start <- systemToTAITime <$> getSystemTime+  writeIORef _timingsMode (Just start)++type CRCWarningList = [FilePath]+_crcWarningList :: IORef CRCWarningList+_crcWarningList = unsafePerformIO $ newIORef []+{-# NOINLINE _crcWarningList #-}+++addCRCWarning :: FilePath -> IO ()+addCRCWarning fp = modifyIORef _crcWarningList (fp:)+++getCRCWarnings :: IO [FilePath]+getCRCWarnings = readIORef _crcWarningList+++resetCRCWarnings :: IO ()+resetCRCWarnings = writeIORef _crcWarningList []+++darcsdir :: String+darcsdir = "_darcs"++defaultRemoteDarcsCmd :: String+defaultRemoteDarcsCmd = "darcs"++darcsLastMessage :: String+darcsLastMessage = combine darcsdir "patch_description.txt"++darcsSendMessage :: String +darcsSendMessage = combine darcsdir "darcs-send"++darcsSendMessageFinal :: String+darcsSendMessageFinal = darcsSendMessage <.> "final"
+ src/Darcs/Util/Graph.hs view
@@ -0,0 +1,264 @@+{- The idea of the ltmis algorithm is based on this paper:++Loukakis, E & Tsouros, Constantin. (1981). A depth first search algorithm to+generate the family of maximal independent sets of a graph+lexicographically. Computing. 27. 349-366. 10.1007/BF02277184.++This is basically the same as Bron-Kerbosch but with two special+optimizations, one to avoid needless backtracking and one to avoid needless+branching. For large graphs the gains in efficiency are significant. On my+computer generating all MIS for the first 100000 graphs of size 12 takes+0.757 seconds with ltmis (True,True) and over 10 seconds with bkmis.++-}++{-# OPTIONS_GHC -Wno-name-shadowing #-}+module Darcs.Util.Graph+  ( Graph+  , Vertex+  , VertexSet+  , Component(..)+  -- * Algorithms+  , ltmis+  , bkmis+  , components+  -- * Generating graphs+  , genGraphs+  , genComponents+  -- * Properties+  , prop_ltmis_eq_bkmis+  , prop_ltmis_maximal_independent_sets+  , prop_ltmis_all_maximal_independent_sets+  , prop_components+  ) where++import Control.Monad ( filterM )+import Control.Monad.ST ( runST, ST )++import Data.List ( sort )+import qualified Data.Set as S++import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV+import qualified Data.Vector.Unboxed as U+import qualified Data.Vector.Unboxed.Mutable as MU++import Safe ( tailErr )++import Darcs.Prelude++-- | Vertices are represented as 'Int'.+type Vertex = Int++-- | Set of vertices, represented as a list for efficiency (yes, indeed).+type VertexSet = [Vertex]++-- | Undirected graph represented as a 'V.Vector' of adjacency 'VertexSet's.+type Graph = V.Vector VertexSet++data Component = Component Graph VertexSet deriving Show++-- | The neighbors of a 'Vertex' in a 'Graph'.+neighbours :: Graph -> Vertex -> VertexSet+neighbours g v = g V.! v++has_edge :: Graph -> Vertex -> Vertex -> Bool+has_edge g u v = u `elem` neighbours g v++has_any_edge :: Graph -> VertexSet -> Vertex -> Bool+has_any_edge g vs u = any (has_edge g u) vs++all_vertices :: Graph -> VertexSet+all_vertices g = [0..(gsize g - 1)]++-- | The number of vertices in a 'Graph'.+gsize :: Graph -> Int+gsize v = V.length v++-- * Maximal independent sets++-- | Simple helper type used in the 'ltmis' and 'components' algorithms.+type Helper = U.Vector Bool++-- | Determine the maximal independent sets in a 'Component' of a 'Graph'.+ltmis :: (Bool,Bool) -> Component -> [VertexSet]+ltmis (bt1,bt2) (Component g comp) =+    -- the map reverse is because we use (:) to add vertices to r+    -- when branching+    map reverse $ go [] 0 init_h+  where+    size = gsize g+    init_h = U.replicate (gsize g) True U.// zip comp (repeat False)+    -- h[v] = neighbours g v `intersectsWith` r || v `elem` r || v `notElem` comp+    go :: VertexSet -> Vertex -> Helper -> [VertexSet]+    go r !sep h =+      case candidates sep h of+        [] -> [r]+        br:_ ->+          (if bt1 && done_branching sep' h' then [] else go (br:r) sep' h')+          +++          (if bt2 && done_backtracking sep' h br then [] else go r sep' h)+          where+            h' = h U.// zip (br : neighbours g br) (repeat True)+            sep' = br + 1++    candidates :: Vertex -> Helper -> VertexSet+    candidates sep h = filter (not . (h U.!)) $ [sep..(size-1)]++    excludes :: Vertex -> Helper -> [Vertex]+    excludes sep h = filter (not . (h U.!)) [0 .. (sep-1)]++    is_candidate :: Vertex -> Helper -> Vertex -> Bool+    is_candidate sep h v = v >= sep && not ((h U.!) v)++    intersects_candidates :: Vertex -> Helper -> VertexSet -> Bool+    intersects_candidates sep h = any (is_candidate sep h)++    -- for some x in X, N(x) does not intersect C+    -- means whatever candidate we add we won't get an MIS+    -- so can stop branching+    done_branching :: Vertex -> Helper -> Bool+    done_branching sep h =+      any (not . intersects_candidates sep h) $ map (neighbours g) $ excludes sep h++    -- if done_backtracking (neighbours g v), then v must+    -- be a member of any MIS containing R+    done_backtracking :: Vertex -> Helper -> Vertex -> Bool+    done_backtracking sep h v = not $ intersects_candidates sep h $ neighbours g v++-- | The classic Bron-Kerbosch algorithm for determining the maximal+-- independent sets in a 'Graph'.+bkmis :: Graph -> [VertexSet]+bkmis g = reverse $ map reverse $ go [] [] (all_vertices g) where+  go r [] [] = [r]+  go r xs cs = loop xs cs where+    loop _ [] = []+    loop xs (c:cs) = loop (c:xs) cs ++ go (c:r) (res c xs) (res c cs)+    res v = filter (not . has_edge g v)++-- * Generating graphs++genGraph :: Monad m => (Int -> Int -> m VertexSet) -> Int -> m Graph+genGraph genSubset = go 0 where+  go _ 0 = return V.empty+  go s n = do -- list monad+    g <- go (s+1) (n-1)+    vs <- genSubset (s+1) (n-1)+    return $ V.modify (\h -> mapM_ (adjust h) vs) (V.cons vs g)+    where+      adjust g i = do+        vs <- MV.read g (i-s)+        MV.write g (i-s) (s:vs)++-- | Enumerate all (simple) graphs of a given size (number of vertices).+genGraphs :: Int -> [Graph]+genGraphs = genGraph subsets where+  -- Subsets of the n elements [s..(s+n-1)] (each subset is ordered)+  subsets _ 0 = return []+  subsets s n = do+    vs <- subsets (s+1) (n-1)+    [vs,s:vs]++genComponents :: Int -> [Component]+genComponents n = do+  g <- genGraphs n+  components g++-- * Connected components++-- | Split a 'Graph' into connected components. For efficiency we don't+-- represent the result as a list of Graphs, but rather of 'VertexSet's.+components :: Graph -> [Component]+components g = reverse $ map (Component g) $ runST go where+  size = gsize g+  go :: ST s [VertexSet]+  go = do+    mh <- MU.replicate size False+    loop 0 mh []+  loop v mh r+    | v == size = return r+    | otherwise = do+      c <- new_component v+      if null c+        then loop (v + 1) mh r+        else loop (v + 1) mh (c : r)+    where+      new_component v = do+        visited <- MU.read mh v+        if visited+          then return []+          else do+            -- mark v as visited+            MU.write mh v True+            cs <- mapM new_component (neighbours g v)+            return $ v : concat cs++-- * Properties++-- | Whether a 'VertexSet' is independent i.e. no edge exists between any+-- two of its vertices.+prop_is_independent_set :: Graph -> VertexSet -> Bool+prop_is_independent_set g vs = all (not . has_any_edge g vs) vs++-- | Whether a 'VertexSet' is maximally independent i.e. it is independent+-- and no longer independent if we add any other vertex.+prop_is_maximal_independent_set :: Component -> VertexSet -> Bool+prop_is_maximal_independent_set (Component g c) vs =+    prop_is_independent_set g vs &&+    all (has_any_edge g vs) other_vertices+  where+    other_vertices = filter (`notElem` vs) c++-- | Whether 'ltmis' is equivalent to 'bkmis'.+prop_ltmis_eq_bkmis :: Graph -> Bool+prop_ltmis_eq_bkmis g =+  ltmis (True, True) (Component g (all_vertices g)) == bkmis g++-- | Whether 'ltmis' generates only maximal independent sets.+prop_ltmis_maximal_independent_sets :: Component -> Bool+prop_ltmis_maximal_independent_sets sg =+  all (prop_is_maximal_independent_set sg) (ltmis (True, True) sg)++-- | Whether 'ltmis' generates /all/ maximal independent sets.+prop_ltmis_all_maximal_independent_sets :: Component -> Bool+prop_ltmis_all_maximal_independent_sets sg@(Component _ c) =+    all (not . prop_is_maximal_independent_set sg) other_subsets+  where+    mis = ltmis (True, True) sg+    all_subsets = powerset c+    other_subsets = filter (`notElem` mis) all_subsets++-- | Whether a list of 'VertexSet's of a 'Graph' is a partition of+-- the set of all its vertices.+prop_is_partition :: Graph -> [VertexSet] -> Bool+prop_is_partition g cs = sort (concat cs) == all_vertices g++-- | Whether there is no edge between a 'VertexSet' of a 'Graph' and the rest+-- of the 'Graph'.+prop_self_contained :: Graph -> VertexSet -> Bool+prop_self_contained g c =+  S.unions (map (S.fromList . neighbours g) c) `S.isSubsetOf` S.fromList c++-- | Whether a 'VertexSet' of a 'Graph' is connected.+prop_connected :: Graph -> VertexSet -> Bool+prop_connected g = not . any (prop_self_contained g) . proper_non_empty_subsets+  where+    proper_non_empty_subsets = filter (not . null) . tailErr . powerset++-- | Whether a 'VertexSet' is a connected component of the 'Graph'.+prop_connected_component :: Component -> Bool+prop_connected_component (Component g vs) =+  prop_self_contained g vs && prop_connected g vs++-- | Complete specification of the 'components' function.+prop_components :: Graph -> Bool+prop_components g =+    all prop_connected_component cs &&+      prop_is_partition g (map vertices cs) && all (== g) (map graph cs)+  where+    vertices (Component _ vs) = vs+    graph (Component g _) = g+    cs = components g++powerset :: VertexSet -> [VertexSet]+powerset = map sort . filterM (const [True, False])
+ src/Darcs/Util/HTTP.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE CPP #-}+module Darcs.Util.HTTP+    ( Cachable(..)+    , copyRemote+    , copyRemoteLazy+    , speculateRemote+    , postUrl+    , configureHttpConnectionManager+    ) where++import Control.Concurrent.Async ( async, cancel, poll )+import Control.Exception ( catch )+import Control.Monad ( void , (>=>) )+import Crypto.Random ( seedNew, seedToInteger )+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Char8 as BC++import Data.Conduit.Combinators ( sinkLazy )++import Foreign.C.Types ( CInt )++import Network.HTTP.Simple+    ( HttpException(..)+    , Request+    , httpBS+    , httpSink+    , httpNoBody+    , getResponseBody+    , setRequestHeaders+    , setRequestMethod+    , setRequestResponseTimeout+    )+import Network.HTTP.Conduit+    ( ResponseTimeout+    , parseUrlThrow+    , responseTimeoutDefault+    , responseTimeoutMicro+    )+import Network.HTTP.Types.Header+    ( hCacheControl+    , hPragma+    , hContentType+    , hAccept+    , hContentLength+    )++#ifdef HAVE_CRYPTON_CONNECTION+import Data.Default ( def )+import qualified Network.Connection as NC+import Network.HTTP.Client.TLS+    ( mkManagerSettings+    , newTlsManagerWith+    , setGlobalManager+    )+import qualified Network.TLS as TLS+#endif++import Numeric ( showHex )+import System.Directory ( renameFile )+import System.Environment ( lookupEnv )+import Text.Read ( readMaybe )++import Darcs.Prelude++import Darcs.Util.AtExit ( atexit )+import Darcs.Util.Global ( debugMessage )++data Cachable+  = Cachable+  | Uncachable+  | MaxAge !CInt+  deriving (Show, Eq)++darcsResponseTimeout :: IO ResponseTimeout+darcsResponseTimeout =+  lookupEnv "DARCS_CONNECTION_TIMEOUT" >>= \case+    Just s | Just n <- readMaybe s ->+      return $ responseTimeoutMicro $ 1000000 * n+    _ -> return responseTimeoutDefault -- 30 s, seems a bit long++copyRemote :: String -> FilePath -> Cachable -> IO ()+copyRemote url path cachable = do+  debugMessage $ "copyRemote: " ++ url+  junk <- flip showHex "" <$> seedToInteger <$> seedNew+  let tmppath = path ++ ".new_" ++ junk+  tmo <- darcsResponseTimeout+  handleHttpAndUrlExn url+    (httpBS . setRequestResponseTimeout tmo . addCacheControl cachable >=>+     B.writeFile tmppath . getResponseBody)+  renameFile tmppath path++-- TODO instead of producing a lazy ByteString we should re-write the+-- consumer (Darcs.Repository.Packs) to use proper streaming (e.g. conduit)+copyRemoteLazy :: String -> Cachable -> IO (BL.ByteString)+copyRemoteLazy url cachable = do+  debugMessage $ "copyRemoteLazy: " ++ url+  handleHttpAndUrlExn url+    (flip httpSink (const sinkLazy) . addCacheControl cachable)++speculateRemote :: String -> FilePath -> IO ()+speculateRemote url path = do+  r <- async $ do+    debugMessage $ "Start speculating on " ++ url+    -- speculations are always Cachable+    copyRemote url path Cachable+    debugMessage $ "Completed speculating on " ++ url+  atexit $ do+    result <- poll r+    case result of+      Just (Right ()) ->+        debugMessage $ "Already completed speculating on " ++ url+      Just (Left e) ->+        debugMessage $ "Speculating on " ++ url ++ " failed: " ++ show e+      Nothing -> do+        debugMessage $ "Abort speculating on " ++ url+        cancel r++postUrl+  :: String -- ^ url+  -> BC.ByteString -- ^ body+  -> String -- ^ mime type+  -> IO () -- ^ result+postUrl url body mime =+    handleHttpAndUrlExn url (void . httpNoBody . setMethodAndHeaders)+  where+    setMethodAndHeaders =+      setRequestMethod (BC.pack "POST") .+      setRequestHeaders+        [ (hContentType, BC.pack mime)+        , (hAccept, BC.pack "text/plain")+        , (hContentLength, BC.pack $ show $ B.length body)+        ]++addCacheControl :: Cachable -> Request -> Request+addCacheControl Uncachable =+  setRequestHeaders [(hCacheControl, noCache), (hPragma, noCache)]+addCacheControl (MaxAge seconds) | seconds > 0 =+  setRequestHeaders [(hCacheControl, BC.pack $ "max-age=" ++ show seconds)]+addCacheControl _ = id++noCache :: BC.ByteString+noCache = BC.pack "no-cache"++handleHttpAndUrlExn :: String -> (Request -> IO a) -> IO a+handleHttpAndUrlExn url action =+  catch (parseUrlThrow url >>= action) (\case+    InvalidUrlException _ reason ->+      fail $ "Invalid URI: " ++ url ++ ", reason: " ++ reason+    HttpExceptionRequest _ hec {- :: HttpExceptionContent -}+     -> fail $ "Error getting " ++ show url ++ ": " ++ show hec)++-- | To be called from main program in order to set up a connection manager+-- with changed TLS settings. Particularly, since tls-2.0 the default value for+-- 'TLS.supportedExtendedMainSecret' was changed from 'TLS.AllowEMS' to+-- 'TLS.RequireEMS', which is currently (2024-05-19) not yet supported by+-- hub.darcs.net.+configureHttpConnectionManager :: IO ()+#ifdef HAVE_CRYPTON_CONNECTION+configureHttpConnectionManager = do+  let tlsSettings =+        NC.TLSSettingsSimple False False False+          def { TLS.supportedExtendedMainSecret = TLS.AllowEMS }+  manager <- newTlsManagerWith $ mkManagerSettings tlsSettings Nothing+  setGlobalManager manager+#else+configureHttpConnectionManager = return ()+#endif
+ src/Darcs/Util/Hash.hs view
@@ -0,0 +1,147 @@+--  Copyright (C) 2009-2011 Petr Rockai BSD3+--  Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li>++module Darcs.Util.Hash+    ( Hash(..)+    , encodeBase16, decodeBase16, sha256, sha256strict, sha256sum, rawHash, mkHash+    , match, encodeHash, decodeHash, showHash+    -- SHA1 related (patch metadata hash)+    , sha1PS, SHA1(..), showAsHex, sha1Xor, sha1zero, sha1short+    , sha1Show, sha1Read+ ) where++-- we currently have to depend on the memory package in addition to cryptonite+-- just so that we can import this single function+import Data.ByteArray ( convert )++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Short as BS+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Base16 as B16++import qualified Crypto.Hash as H++import Data.Char( intToDigit, ord )++import Data.Binary ( Binary(..), decode, encode )+import Data.Bits ( xor, shiftL, (.|.) )+import Data.Word ( Word8, Word32 )++import Darcs.Prelude+++newtype Hash = SHA256 BS.ShortByteString+  deriving (Show, Eq, Ord, Read)++decodeHash :: String -> Maybe Hash+decodeHash = decodeBase16 . BC.pack++encodeHash :: Hash -> String+encodeHash = BC.unpack . encodeBase16++-- | Produce a base16 (ascii-hex) encoded string from a hash. This can be+-- turned back into a Hash (see "decodeBase16". This is a loss-less process.+encodeBase16 :: Hash -> B.ByteString+encodeBase16 (SHA256 bs) = B16.encode (BS.fromShort bs)++-- | Take a base16-encoded string and decode it as a "Hash". If the string is+-- malformed, yields Nothing.+decodeBase16 :: B.ByteString -> Maybe Hash+decodeBase16 bs+  | B.length bs == 64+  , Right dbs <- B16.decode bs = Just (SHA256 (BS.toShort dbs))+  | otherwise = Nothing++-- | Compute a sha256 of a (lazy) ByteString.+sha256 :: BL.ByteString -> Hash+sha256 bits = SHA256 (BS.toShort (convert (H.hashlazy bits :: H.Digest H.SHA256)))++-- | Same as previous but general purpose.+sha256sum :: B.ByteString -> String+sha256sum = BC.unpack . B16.encode . convert . H.hashWith H.SHA256++sha256strict :: B.ByteString -> Hash+sha256strict = SHA256 . BS.toShort . convert . H.hashWith H.SHA256++rawHash :: Hash -> B.ByteString+rawHash (SHA256 s) = BS.fromShort s++mkHash :: B.ByteString -> Hash+mkHash = SHA256 . BS.toShort++match :: Maybe Hash -> Maybe Hash -> Bool+Nothing `match` _ = False+_ `match` Nothing = False+Just x `match` Just y = x == y++showHash :: Maybe Hash -> String+showHash (Just h) = encodeHash h+showHash Nothing = "(no hash available)"++data SHA1 = SHA1 !Word32 !Word32 !Word32 !Word32 !Word32+  deriving (Eq,Ord)++instance Show SHA1 where+  show = BC.unpack . sha1Show++instance Binary SHA1 where+  put (SHA1 a b c d e) = put a >> put b >> put c >> put d >> put e+  get = do a <- get; b <- get; c <- get; d <- get; e <- get; return (SHA1 a b c d e)++sha1Xor :: SHA1 -> SHA1 -> SHA1+sha1Xor (SHA1 a1 b1 c1 d1 e1) (SHA1 a2 b2 c2 d2 e2) =+  SHA1 (a1 `xor` a2) (b1 `xor` b2) (c1 `xor` c2) (d1 `xor` d2) (e1 `xor` e2)++sha1zero :: SHA1+sha1zero = SHA1 0 0 0 0 0++sha1short :: SHA1 -> Word32+sha1short (SHA1 a _ _ _ _) = a++sha1PS:: B.ByteString -> SHA1+sha1PS = fromArray . convert . H.hashWith H.SHA1 where+  fromArray = decode . BL.fromStrict++showAsHex :: Word32 -> String+showAsHex n = showIt 8 n ""+   where+    showIt :: Int -> Word32 -> String -> String+    showIt 0 _ r = r+    showIt i x r = case quotRem x 16 of+                       (y, z) -> let c = intToDigit (fromIntegral z)+                                 in c `seq` showIt (i-1) y (c:r)++-- | Parse a 'SHA1' directly from its B16 encoding, given as a 'B.ByteString',+-- or return 'Nothing'. The implementation is quite low-level and optimized+-- because the current implementation of RepoPatchV3 has to read lots of 'SHA1'+-- hashes, and profiling showed that this is a bottleneck.+sha1Read :: B.ByteString -> Maybe SHA1+sha1Read bs+  | B.length bs == 40+  , B.all is_hex bs =+    Just $ SHA1 (readWord 0) (readWord 8) (readWord 16) (readWord 24) (readWord 32)+  | otherwise = Nothing+  where+    readWord i = B.foldl' readByte 0 (B.take 8 (B.drop i bs))+    readByte :: Word32 -> Word8 -> Word32+    readByte r b = r `shiftL` 4 .|. (fromHex b)+    fromHex :: Word8 -> Word32+    fromHex b | btw_0_9 b = fromIntegral (b - ord_0)+              | btw_a_f b = fromIntegral (b - ord_a) + 10+              | otherwise = error "impossible case"+    ord_0 :: Word8+    ord_0 = fromIntegral (ord '0')+    ord_9 :: Word8+    ord_9 = fromIntegral (ord '9')+    ord_a :: Word8+    ord_a = fromIntegral (ord 'a')+    ord_f :: Word8+    ord_f = fromIntegral (ord 'f')+    btw_0_9 b = b >= ord_0 && b <= ord_9+    btw_a_f b = b >= ord_a && b <= ord_f+    is_hex b = btw_0_9 b || btw_a_f b++{-# INLINE sha1Show #-}+sha1Show :: SHA1 -> B.ByteString+sha1Show = B16.encode . BL.toStrict . encode
+ src/Darcs/Util/Index.hs view
@@ -0,0 +1,768 @@+--  Copyright (C) 2009-2011 Petr Rockai+--            (C) 2013 Jose Neder+--  BSD3+{-# LANGUAGE MultiParamTypeClasses #-}++-- | This module contains plain tree indexing code. The index itself is a+-- CACHE: you should only ever use it as an optimisation and never as a primary+-- storage. In practice, this means that when we change index format, the+-- application is expected to throw the old index away and build a fresh+-- index. Please note that tracking index validity is out of scope for this+-- module: this is responsibility of your application. It is advisable that in+-- your validity tracking code, you also check for format validity (see+-- 'indexFormatValid') and scrap and re-create index when needed.+--+-- The index is a binary file that overlays a hashed tree over the working+-- copy. This means that every working file and directory has an entry in the+-- index, that contains its path and hash and validity data. The validity data+-- is a timestamp plus the file size. The file hashes are sha256's of the+-- file's content. It also contains the fileid to track moved files.+--+-- There are two entry types, a file entry and a directory entry. Both have a+-- common binary format (see 'Item'). The on-disk format is described by+-- the section /Index format/ below.+--+-- For each file, the index has a copy of the file's last modification+-- timestamp taken at the instant when the hash has been computed. This means+-- that when file size and timestamp of a file in working tree matches those in+-- the index, we assume that the hash stored in the index for given file is+-- valid. These hashes are then exposed in the resulting 'Tree' object, and can+-- be leveraged by eg. 'diffTrees' to compare many files quickly.+--+-- You may have noticed that we also keep hashes of directories. These are+-- assumed to be valid whenever the complete subtree has been valid. At any+-- point, as soon as a size or timestamp mismatch is found, the working file in+-- question is opened, its hash (and timestamp and size) is recomputed and+-- updated in-place in the index file (everything lives at a fixed offset and+-- is fixed size, so this isn't an issue). This is also true of directories:+-- when a file in a directory changes hash, this triggers recomputation of all+-- of its parent directory hashes; moreover this is done efficiently -- each+-- directory is updated at most once during an update run.+--+-- /Endianness/+--+-- Since version 6 (magic == "HSI6"), the file format depends on the endianness+-- of the architecture. To account for the (rare) case where darcs executables+-- from different architectures operate on the same repo, we make an additional+-- check in indexFormatValid to detect whether the file's endianness differs+-- from what we expect. If this is detected, the file is considered invalid and+-- will be re-created.+--+-- /Index format/+--+-- The index starts with a header consisting of a 4 bytes magic word, followed+-- by a 4 byte word to indicate the endianness of the encoding. This word+-- should, when read directly from the mmapped file, be equal to 1.+--+-- After the header comes the actual content of the index, which is a+-- sequence of 'Item's. An 'Item' consists of:+--+-- * size: item size, 8 bytes+-- * aux: timestamp (for file) or offset to sibling (for dir), 8 bytes+-- * fileid: inode or fhandle of the item, 8 bytes+-- * hash: sha256 of content, 32 bytes+-- * descriptor length: >= 2 due to type and null, 4 bytes+-- * descriptor:+--   * type: 'D' or 'F', one byte+--   * path: flattened path, variable >= 0+-- * null: terminating null byte+-- * alignment padding: 0 to 3 bytes+--+-- Each 'Item' is 4 byte aligned. Thus the descriptor length must be+-- rounded up to get the position of the next item using 'align'. Similar,+-- when determining the aux (offset to sibling) for dir items.+--+-- With directories, the aux holds the offset of the next sibling item in the+-- index, so we can efficiently skip reading the whole subtree starting at a+-- given directory (by just seeking aux bytes forward). The items are+-- pre-ordered with respect to directory structure -- the directory comes first+-- and after it come all its items. Cf. 'openIndex'.+--+-- For files, the aux field holds a timestamp.+--+-- Internally, the item is stored as a pointer to the first field (iBase)+-- from which we directly read off the first three fields (size, aux, fileid),+-- and a ByteString for the rest (iHashAndDescriptor), up to but not including+-- the terminating null byte.+--+-- TODO+--+-- The null byte terminator seems useless.+--+-- We could as well use a single plain pointer for the item. The dumpIndex+-- function demonstrates how this could be done.+--+-- Another possible improvement is to store only the Name of an item, not the+-- full path. We need to keep track of the current path anyway when traversing+-- the index.++module Darcs.Util.Index+    ( openIndex+    , updateIndexFrom+    , indexFormatValid+    , treeFromIndex+    , listFileIDs+    , Index+    , filter+    , getFileID+    , IndexEntry(..)+    , dumpIndex+    -- for testing+    , align+    ) where++import Darcs.Prelude hiding ( readFile, writeFile, filter )++import Darcs.Util.ByteString ( readSegment, decodeLocale )+import qualified Darcs.Util.File ( getFileStatus )+import Darcs.Util.Global ( debugMessage )+import Darcs.Util.Hash ( Hash(..), mkHash, rawHash, sha256 )+import Darcs.Util.Tree+import Darcs.Util.Tree.Hashed ( darcsTreeHash )+import Darcs.Util.Path+    ( AnchoredPath(..)+    , realPath+    , anchoredRoot+    , Name+    , rawMakeName+    , appendPath+    , flatten+    )+import Darcs.Util.Progress ( beginTedious, endTedious, finishedOneIO )++import Control.Monad( when )+import Control.Exception( catch, throw, SomeException, Exception )++import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.ByteString.Unsafe( unsafeHead, unsafeDrop )+import Data.ByteString.Internal+    ( c2w+    , fromForeignPtr+    , nullForeignPtr+    , toForeignPtr+    )+import qualified Data.ByteString.Short.Internal as BS++import Data.Int( Int64, Int32 )+import Data.Word( Word8 )+import Data.IORef( )+import Data.Maybe( fromJust, isJust, isNothing )+import Data.Typeable( Typeable )++import Foreign.Marshal.Utils ( copyBytes )+import Foreign.Storable+import Foreign.ForeignPtr( ForeignPtr, withForeignPtr, castForeignPtr )+import Foreign.Ptr( Ptr, plusPtr )++import System.IO ( hPutStrLn, stderr )+import System.IO.MMap( mmapFileForeignPtr, mmapWithFilePtr, Mode(..) )+import System.Directory( doesFileExist, getCurrentDirectory )+import System.Directory( renameFile )+import System.FilePath( (<.>) )++import qualified System.Posix.Files as F ( fileID )+import System.FilePath ( (</>) )+import qualified System.Posix.Files as F+    ( modificationTimeHiRes, fileSize, isDirectory, isSymbolicLink+    , FileStatus+    )+import System.Posix.Types ( FileID, FileOffset )++--------------------------+-- Indexed trees+--++-- | Description of a a single indexed item. The structure itself does not+-- contain any data, just pointers to the underlying mmap (bytestring is a+-- pointer + offset + length).+--+-- The structure is recursive-ish (as opposed to flat-ish structure, which is+-- used by git...) It turns out that it's hard to efficiently read a flat index+-- with our internal data structures -- we need to turn the flat index into a+-- recursive Tree object, which is rather expensive... As a bonus, we can also+-- efficiently implement subtree queries this way (cf. 'openIndex').+data Item = Item { iBase :: !(Ptr ())+                 , iHashAndDescriptor :: !B.ByteString+                 } deriving Show++index_version :: B.ByteString+index_version = BC.pack "HSI7"++-- | Stored to the index to verify we are on the same endianness when reading+-- it back. We will treat the index as invalid in this case so user code will+-- regenerate it.+index_endianness_indicator :: Int32+index_endianness_indicator = 1++size_header, size_magic, size_endianness_indicator :: Int+size_magic = 4 -- the magic word, first 4 bytes of the index+size_endianness_indicator = 4 -- second 4 bytes of the index+size_header = size_magic + size_endianness_indicator++size_dsclen, size_hash, size_size, size_aux, size_fileid :: Int+size_size = 8 -- file/directory size (Int64)+size_aux = 8 -- aux (Int64)+size_fileid = 8 -- fileid (inode or fhandle FileID)+size_dsclen = 4 -- this many bytes store the length of the descriptor+size_hash = 32 -- hash representation+size_type, size_null :: Int+size_type = 1 -- ItemType: 'D' for directory, 'F' for file+size_null = 1 -- null byte at the end of path++off_size, off_aux, off_hash, off_dsc, off_dsclen, off_fileid :: Int+off_size = 0+off_aux = off_size + size_size+off_fileid = off_aux + size_aux+off_dsclen = off_fileid + size_fileid+off_hash = off_dsclen + size_dsclen+off_dsc = off_hash + size_hash++itemAllocSize :: AnchoredPath -> Int+itemAllocSize apath = align 4 $+  size_size + size_aux + size_fileid + size_dsclen + size_hash ++  size_type + B.length (flatten apath) + size_null++itemSize :: Item -> Int+itemSize i =+  size_size + size_aux + size_fileid + size_dsclen ++  (B.length $ iHashAndDescriptor i) + size_null++itemNext :: Item -> Int+itemNext i = align 4 (itemSize i)++-- iDescriptor is:+--  * one byte for type of item ('D' or 'F')+--  * flattened path (w/o terminating null byte)+iHash, iDescriptor :: Item -> B.ByteString+iDescriptor = unsafeDrop size_hash . iHashAndDescriptor+iHash = B.take size_hash . iHashAndDescriptor++-- The "drop 1" here gets rid of the item type.+iPath :: Item -> FilePath+iPath = decodeLocale . unsafeDrop 1 . iDescriptor++iSize, iAux :: Item -> Ptr Int64+iSize i = plusPtr (iBase i) off_size+iAux i = plusPtr (iBase i) off_aux++iFileID :: Item -> Ptr FileID+iFileID i = plusPtr (iBase i) off_fileid++itemIsDir :: Item -> Bool+itemIsDir i = unsafeHead (iDescriptor i) == c2w 'D'++type FileStatus = Maybe F.FileStatus++-- We deal with hi res timestamps by noting that the actual resolution is in+-- nanoseconds. If we count the nanoseconds since the epoch we will overflow+-- (1<<63)/(1e9*60*60*24*366) =~ 290 years after the epoch. Comfortable.+modificationTime :: FileStatus -> Int64+modificationTime = maybe 0 (truncate . (*1e9) . F.modificationTimeHiRes)++fileSize :: FileStatus -> FileOffset+fileSize = maybe 0 F.fileSize++fileExists :: FileStatus -> Bool+fileExists = maybe False (const True)++isDirectory :: FileStatus -> Bool+isDirectory = maybe False F.isDirectory++fileID :: FileStatus -> FileID+fileID = maybe 0 F.fileID++-- | Lay out the basic index item structure in memory. The memory location is+-- given by a ForeignPointer () and an offset. The path and type given are+-- written out, and a corresponding Item is given back. The remaining bits of+-- the item can be filled out using 'update'.+createItem :: ItemType -> AnchoredPath -> ForeignPtr () -> Int -> IO Item+createItem typ apath fp off = do+  let dsc =+        B.concat+          [ BC.singleton $ if typ == TreeType then 'D' else 'F'+          , flatten apath -- this (currently) gives "." for anchoredRoot+          , B.singleton 0+          ]+      (dsc_fp, dsc_start, dsc_len) = toForeignPtr dsc+  withForeignPtr fp $ \p ->+    withForeignPtr dsc_fp $ \dsc_p -> do+      pokeByteOff p (off + off_dsclen) (fromIntegral dsc_len :: Int32)+      copyBytes+        (plusPtr p $ off + off_dsc)+        (plusPtr dsc_p dsc_start)+        (fromIntegral dsc_len)+      peekItem fp off++-- | Read the on-disk representation into internal data structure.+--+-- See the module-level section /Index format/ for details on how the index+-- is structured.+peekItem :: ForeignPtr () -> Int -> IO Item+peekItem fp off =+  withForeignPtr fp $ \p -> do+    nl' :: Int32 <- peekByteOff p (off + off_dsclen)+    when (nl' <= 2) $ fail "Descriptor too short in peekItem!"+    let nl = fromIntegral nl'+        dsc =+          fromForeignPtr+            (castForeignPtr fp)+            (off + off_hash)+            -- Note that iHashAndDescriptor does not include the terminating+            -- null byte, so we have to subtract its size here.+            (size_hash + nl - size_null)+    return $! Item {iBase = plusPtr p off, iHashAndDescriptor = dsc}++-- | Update an existing 'Item' with new size and hash. The hash must be+-- not be 'Nothing'.+updateItem :: Item -> Int64 -> Hash -> IO ()+updateItem item size hash =+    do poke (iSize item) size+       unsafePokeBS (iHash item) (rawHash hash)++updateFileID :: Item -> FileID -> IO ()+updateFileID item fileid = poke (iFileID item) fileid++updateAux :: Item -> Int64 -> IO ()+updateAux item aux = poke (iAux item) aux++updateTime :: Item -> Int64 -> IO ()+updateTime item mtime = updateAux item mtime++iHash' :: Item -> Maybe Hash+iHash' i = let ih = iHash i in if ih == nullHash then Nothing else Just (mkHash ih)++nullHash :: B.ByteString+nullHash = B.replicate size_hash 0++-- | Gives a ForeignPtr to mmapped index, which can be used for reading and+-- updates. The req_size parameter, if non-0, expresses the requested size of+-- the index file. mmapIndex will grow the index if it is smaller than this.+mmapIndex :: forall a. FilePath -> Int -> IO (ForeignPtr a, Int)+mmapIndex indexpath req_size = do+  act_size <- fromIntegral . fileSize <$> Darcs.Util.File.getFileStatus indexpath+  let size = case req_size > 0 of+        True -> req_size+        False | act_size >= size_header -> act_size - size_header+              | otherwise -> 0+  case size of+    0 -> return (castForeignPtr nullForeignPtr, size)+    _ -> do (x, _, _) <- mmapFileForeignPtr indexpath+                                            ReadWriteEx (Just (0, size + size_header))+            return (x, size)++data IndexM m = Index { mmap :: (ForeignPtr ())+                      , basedir :: FilePath+                      , predicate :: AnchoredPath -> TreeItem m -> Bool }+              | EmptyIndex++type Index = IndexM IO++-- FIXME This is not really a state: we modify it only when we recurse+-- down into a dir item, so this is rather more like an environment.+-- Instead of passing it explicitly we could use ReaderT.++-- | When we traverse the index, we keep track of some data about the+-- current parent directory.+data State = State+  { dirlength :: !Int     -- ^ length in bytes of current path prefix,+                          --   includes the trailing path separator+  , path :: !AnchoredPath -- ^ path of the current directory+  , start :: !Int         -- ^ offset of current directory in the index+  }++-- * Reading items from the index++data Result = Result+  { changed :: !Bool+  -- ^ Whether item has changed since the last update to the index.+  , next :: !Int+  -- ^ Position of the next item, in bytes.+  , treeitem :: !(Maybe (TreeItem IO))+  -- ^ Nothing in case of the item doesn't exist in the tree+  -- or is filtered by a FilterTree. Or a TreeItem otherwise.+  , resitem :: !Item+  -- ^ The item extracted.+  }++readItem :: String -> Index -> State -> IO Result+readItem progressKey index state = do+    item <- peekItem (mmap index) (start state)+    res' <- if itemIsDir item+                then readDir  item+                else readFile item+    finishedOneIO progressKey (iPath item)+    return res'+  where++    readDir item = do+      following <- fromIntegral <$> peek (iAux item)+      st <- getFileStatus (iPath item)+      let exists = fileExists st && isDirectory st+      fileid <- peek $ iFileID item+      when (fileid == 0) $ updateFileID item (fileID st)+      let substate = substateof item state+          want =+            exists && (predicate index) (path substate) (Stub undefined Nothing)+          oldhash = iHash' item+          subs off =+             case compare off following of+               LT -> do+                 result <- readItem progressKey index $ substate { start = off }+                 rest <- subs $ next result+                 return $! (nameof (resitem result) substate, result) : rest+               EQ -> return []+               GT ->+                 fail $+                   "Offset mismatch at " ++ show off +++                   " (ends at " ++ show following ++ ")"+      inferiors <- if want then subs $ start substate+                           else return []+      let we_changed = or [ changed x | (_, x) <- inferiors ] || nullleaf+          nullleaf = null inferiors && isNothing oldhash+          tree' =+            -- Note the partial pattern match on 'Just n' below is justified+            -- as we are traversing sub items here, which means 'Nothing' is+            -- impossible, see 'substateof' for details.+            makeTree+              [ (n, fromJust $ treeitem s)+              | (Just n, s) <- inferiors, isJust $ treeitem s ]+          treehash = if we_changed then Just (darcsTreeHash tree') else oldhash+          tree = tree' { treeHash = treehash }+      when (exists && we_changed) $+          -- fromJust is justified because we_changed implies (isJust treehash)+          updateItem item 0 (fromJust treehash)+      return $ Result { changed = not exists || we_changed+                      , next = following+                      , treeitem = if want then Just $ SubTree tree+                                           else Nothing+                      , resitem = item }++    readFile item = do+           st <- getFileStatus (iPath item)+           mtime <- fromIntegral <$> (peek $ iAux item)+           size <- peek $ iSize item+           fileid <- peek $ iFileID item+           let mtime' = modificationTime st+               size' = fromIntegral $ fileSize st+               readblob = readSegment (basedir index </> (iPath item), Nothing)+               exists = fileExists st && not (isDirectory st)+               we_changed = mtime /= mtime' || size /= size'+               hash = iHash' item+           when (exists && we_changed) $+                do hash' <- sha256 `fmap` readblob+                   updateItem item size' hash'+                   updateTime item mtime'+                   when (fileid == 0) $ updateFileID item (fileID st)+           return $ Result { changed = not exists || we_changed+                           , next = start state + itemNext item+                           , treeitem =+                              if exists+                                then Just $ File $ Blob readblob hash+                                else Nothing+                           , resitem = item }+++data CorruptIndex = CorruptIndex String deriving (Eq, Typeable)+instance Exception CorruptIndex+instance Show CorruptIndex where show (CorruptIndex s) = s++-- | Get the 'Name' of an 'Item' in the given 'State'. This fails for+-- the root 'Item' because it has no 'Name', so we return 'Nothing'.+nameof :: Item -> State -> Maybe Name+nameof item state+  | iDescriptor item == BC.pack "D." = Nothing+  | otherwise =+      case rawMakeName $ B.drop (dirlength state + 1) $ iDescriptor item of+        Left msg -> throw (CorruptIndex msg)+        Right name -> Just name++-- | 'Maybe' append a 'Name' to an 'AnchoredPath'.+maybeAppendName :: AnchoredPath -> Maybe Name -> AnchoredPath+maybeAppendName parent = maybe parent (parent `appendPath`)++-- | Calculate the next 'State' when entering an 'Item'. Works for the+-- top-level 'Item' i.e. the root directory only because we handle that+-- specially.+substateof :: Item -> State -> State+substateof item state =+  state+    { start = start state + itemNext item+    , path = path state `maybeAppendName` myname+    , dirlength =+        case myname of+          Nothing ->+            -- We are entering the root item. The current path prefix remains+            -- empty, so its length (which must be 0) doesn't change.+            dirlength state+          Just _ ->+            -- This works because the 'iDescriptor' is always one byte larger+            -- than the actual name. So @dirlength state@ will also be greater+            -- by 1, which accounts for the path separator when we strip the+            -- directory prefix from the full path.+            B.length (iDescriptor item)+    }+  where+    myname = nameof item state++-- * Reading (only) file IDs from the index++-- FIXME this seems copy-pasted from the code above and then adapted+-- to the purpose. Should factor out the traversal of the index as a+-- higher order function.++data ResultF = ResultF+  { nextF :: !Int+  -- ^ Position of the next item, in bytes.+  , resitemF :: !Item+  -- ^ The item extracted.+  , _fileIDs :: [((AnchoredPath, ItemType), FileID)]+  -- ^ The fileids of the files and folders inside,+  -- in a folder item and its own fileid for file item).+  }++-- | Return a list containing all the file/folder names in an index, with+-- their respective ItemType and FileID.+listFileIDs :: Index -> IO ([((AnchoredPath, ItemType), FileID)])+listFileIDs EmptyIndex = return []+listFileIDs index =+    do let initial = State { start = size_header+                           , dirlength = 0+                           , path = anchoredRoot }+       res <- readItemFileIDs index initial+       return $ _fileIDs res++readItemFileIDs :: Index -> State -> IO ResultF+readItemFileIDs index state = do+  item <- peekItem (mmap index) (start state)+  res' <- if itemIsDir item+              then readDirFileIDs  index state item+              else readFileFileID index state item+  return res'++readDirFileIDs :: Index -> State -> Item -> IO ResultF+readDirFileIDs index state item =+    do fileid <- peek $ iFileID item+       following <- fromIntegral <$> peek (iAux item)+       let substate = substateof item state+           subs off =+              case compare off following of+                LT -> do+                  result <- readItemFileIDs index $ substate {start = off}+                  rest <- subs $ nextF result+                  return $! (nameof (resitemF result) substate, result) : rest+                EQ -> return []+                GT ->+                  fail $+                    "Offset mismatch at " ++ show off +++                    " (ends at " ++ show following ++ ")"+       inferiors <- subs $ start substate+       return $ ResultF { nextF = following+                        , resitemF = item+                        , _fileIDs = (((path substate, TreeType), fileid):concatMap (_fileIDs . snd) inferiors) }++readFileFileID :: Index -> State -> Item -> IO ResultF+readFileFileID _ state item =+    do fileid' <- peek $ iFileID item+       let myname = nameof item state+       return $ ResultF { nextF = start state + itemNext item+                        , resitemF = item+                        , _fileIDs = [((path state `maybeAppendName` myname, BlobType), fileid')] }++-- * Reading and writing 'Tree's from/to the index++-- | Initialize an 'Index' from the given index file.+openIndex :: FilePath -> IO Index+openIndex indexpath = do+  (mmap_ptr, mmap_size) <- mmapIndex indexpath 0+  base <- getCurrentDirectory+  return $ if mmap_size == 0 then EmptyIndex+                             else Index { mmap = mmap_ptr+                                        , basedir = base+                                        , predicate = \_ _ -> True }++formatIndex :: ForeignPtr () -> Tree IO -> Tree IO -> IO ()+formatIndex mmap_ptr old reference =+    do _ <- create (SubTree reference) (anchoredRoot) size_header+       unsafePokeBS magic index_version+       withForeignPtr mmap_ptr $ \ptr ->+         pokeByteOff ptr size_magic index_endianness_indicator+    where magic = fromForeignPtr (castForeignPtr mmap_ptr) 0 4+          create (File _) path' off =+               do i <- createItem BlobType path' mmap_ptr off+                  -- TODO calling getFileStatus here is both slightly+                  -- inefficient and slightly race-prone+                  st <- getFileStatus (iPath i)+                  updateFileID i (fileID st)+                  case find old path' of+                    Nothing -> return ()+                    Just ti -> do let hash = itemHash ti+                                      mtime = modificationTime st+                                      size = fileSize st+                                  -- TODO prove that isNothing hash is impossible+                                  updateItem i (fromIntegral size) (fromJust hash)+                                  updateTime i mtime+                  return $ off + itemNext i+          create (SubTree s) path' off =+               do i <- createItem TreeType path' mmap_ptr off+                  st <- getFileStatus (iPath i)+                  updateFileID i (fileID st)+                  case find old path' of+                    Nothing -> return ()+                    Just ti ->+                      case itemHash ti of+                        Nothing -> return ()+                        Just h -> updateItem i 0 h+                  let subs [] = return $ off + itemNext i+                      subs ((name,x):xs) = do+                        let path'' = path' `appendPath` name+                        noff <- subs xs+                        create x path'' noff+                  lastOff <- subs (listImmediate s)+                  poke (iAux i) (fromIntegral lastOff)+                  return lastOff+          create (Stub _ _) path' _ =+               fail $ "Cannot create index from stubbed Tree at " ++ show path'++-- | Add and remove entries in the given 'Index' to make it match the given+-- 'Tree'. If an object in the 'Tree' does not exist in the current working+-- directory, its index entry will have zero hash, size, aux, and fileID. For+-- the hash this translates to 'Nothing', see 'iHash''.+updateIndexFrom :: FilePath -> Tree IO -> IO Index+updateIndexFrom indexpath ref =+    do debugMessage "Updating the index ..."+       old_tree <- treeFromIndex =<< openIndex indexpath+       reference <- expand ref+       let len_root = itemAllocSize anchoredRoot+           len = len_root + sum [ itemAllocSize p | (p, _) <- list reference ]+       exist <- doesFileExist indexpath+       -- Note that the file is still open via the mmaped pointer in+       -- the open index, and we /are/ going to write the index using+       -- that pointer. If we could rely on posix semantics,+       -- we would just delete the file. However, on windows this+       -- would fail, so instead we rename it.+       when exist $ renameFile indexpath (indexpath <.> "old")+       (mmap_ptr, _) <- mmapIndex indexpath len+       formatIndex mmap_ptr old_tree reference+       debugMessage "Done updating the index, reopening it ..."+       openIndex indexpath++-- | Read an 'Index', starting with the root, to create a 'Tree'.+treeFromIndex :: Index -> IO (Tree IO)+treeFromIndex EmptyIndex = return emptyTree+treeFromIndex index =+    do let initial = State { start = size_header+                           , dirlength = 0+                           , path = anchoredRoot }+           -- This is not a typo! As a side-effect of reading a tree from the+           -- index, it also gets updated and this is what can take a long time+           -- since it may involve reading all files in the working tree that+           -- are also in pristine+pending (to compute their hashes)+           progressKey = "Updating the index"+       beginTedious progressKey+       res <- readItem progressKey index initial+       endTedious progressKey+       case treeitem res of+         Just (SubTree tree) -> return $ filter (predicate index) tree+         _ -> fail "Unexpected failure in treeFromIndex!"++-- | Check that a given file is an index file with a format we can handle. You+-- should remove and re-create the index whenever this is not true.+indexFormatValid :: FilePath -> IO Bool+indexFormatValid path' =+  do+    (start, _, _) <- mmapFileForeignPtr path' ReadOnly (Just (0, size_header))+    let magic = fromForeignPtr (castForeignPtr start) 0 4+    endianness_indicator <- withForeignPtr start $ \ptr -> peekByteOff ptr 4+    return $+      index_version == magic && index_endianness_indicator == endianness_indicator+  `catch` \(_::SomeException) -> return False++instance FilterTree IndexM IO where+    filter _ EmptyIndex = EmptyIndex+    filter p index = index { predicate = \a b -> predicate index a b && p a b }+++-- * Getting the file ID from a path++-- | For a given path, get the corresponding fileID from the filesystem.+getFileID :: AnchoredPath -> IO (Maybe FileID)+getFileID p = fmap F.fileID <$> getFileStatus (realPath p)++-- * Low-level utilities++-- Wow, unsafe.+unsafePokeBS :: BC.ByteString -> BC.ByteString -> IO ()+unsafePokeBS to from =+    do let (fp_to, off_to, len_to) = toForeignPtr to+           (fp_from, off_from, len_from) = toForeignPtr from+       when (len_to /= len_from) $ fail $ "Length mismatch in unsafePokeBS: from = "+            ++ show len_from ++ " /= to = " ++ show len_to+       withForeignPtr fp_from $ \p_from ->+         withForeignPtr fp_to $ \p_to ->+           copyBytes+                  (plusPtr p_to off_to)+                  (plusPtr p_from off_from)+                  (fromIntegral len_to)++align :: Integral a => a -> a -> a+align boundary i = case i `rem` boundary of+                     0 -> i+                     x -> i + boundary - x+{-# INLINE align #-}++getFileStatus :: FilePath -> IO FileStatus+getFileStatus path = do+  mst <- Darcs.Util.File.getFileStatus path+  case mst of+    Just st+      | F.isSymbolicLink st -> do+          hPutStrLn stderr $ "Warning: ignoring symbolic link " ++ path+          return Nothing+    _ -> return mst++data IndexEntry = IndexEntry+  { ieSize :: Int64+  , ieAux :: Int64+  , ieFileID :: FileID+  , ieHash :: Maybe Hash+  , ieType :: Char+  , iePath :: AnchoredPath+  }++dumpIndex :: FilePath -> IO [IndexEntry]+dumpIndex indexpath =+  mmapWithFilePtr indexpath ReadOnly Nothing $ \(ptr, size) -> do+    magic <- BS.createFromPtr ptr 4+    when (magic /= BS.toShort index_version) $ fail "index format is invalid"+    readEntries (size - size_header) (ptr `plusPtr` size_header)+  where+    readEntries s _ | s < (next 0) = return []+    readEntries s p = do+      (entry, fwd) <- readEntry p+      entries <- readEntries (s - fwd) (p `plusPtr` fwd)+      return (entry : entries)+    readEntry p = do+      ieSize <- peekByteOff p off_size+      ieAux <- peekByteOff p off_aux+      ieFileID <- peekByteOff p off_fileid+      ieHash <- do+        h <- BS.createFromPtr (p `plusPtr` off_hash) size_hash+        return $ if h == shortNullHash then Nothing else Just (SHA256 h)+      dsclen :: Int32 <- peekByteOff p off_dsclen+      ieType <- b2c <$> peekByteOff p off_dsc+      path <-+        BS.fromShort <$>+        BS.createFromPtr (p `plusPtr` off_path) (fromIntegral dsclen - size_type - size_null)+      iePath <-+        either fail return $ AnchoredPath <$> mapM rawMakeName (BC.split '/' (fixRoot path))+      return (IndexEntry {..}, next (B.length path))+    b2c :: Word8 -> Char+    b2c = toEnum . fromIntegral+    off_path = off_dsc + size_type+    next pathlen =+      align 4 $ size_size + size_aux + size_fileid + size_hash + size_dsclen+              + size_type + pathlen + size_null+    fixRoot s | s == BC.pack "." = BC.empty+    fixRoot s = s+    shortNullHash = BS.toShort nullHash
+ src/Darcs/Util/IndexedMonad.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+module Darcs.Util.IndexedMonad+  ( Monad(..), LiftIx(..), when, ifThenElse+  , MonadReader(..), ReaderT(..), asks+  ) where++import Darcs.Prelude hiding ( Monad(..) )++-- This is required to implement the "if then else" syntax+-- because we are using RebindableSyntax.+-- It doesn't currently exist anywhere standard: see+-- https://gitlab.haskell.org/ghc/ghc/-/issues/18081+-- It doesn't strictly belong in this module but in practice+-- we only use RebindableSyntax to allow us to use the+-- indexed monad class.+ifThenElse :: Bool -> a -> a -> a+ifThenElse True  t _ = t+ifThenElse False _ e = e++-- At the moment the code is organised into different modules partially to+-- separate it by which Monad class we want (normal or indexed). Once qualified+-- do-notation is available (i.e. min GHC is 9.0) we can stop doing that.+-- |An alternative monad class, indexed by a "from" and "to" state.+class Monad m where+  return :: a -> m i i a+  (>>=) :: m i j a -> (a -> m j k b) -> m i k b+  (>>) :: m i j a -> m j k b -> m i k b++when :: Monad m => Bool -> m i i () -> m i i ()+when b m = if b then m else return ()++-- |A class for indexed monad transformers, going from normal Haskell monads+-- into our indexed monads.+class LiftIx t where+  liftIx :: m a -> t m i i a++-- |An indexed version of the standard 'MonadReader' class+class Monad m => MonadReader r m | m -> r where+  ask :: m i i r+  local :: (r -> r) -> m i i a -> m i i a++asks :: MonadReader r m => (r -> a) -> m i i a+asks f = ask >>= \r -> return (f r)++-- |An indexed version of the standard 'ReaderT' transformer+newtype ReaderT r m i j a = ReaderT { runReaderT :: r -> m i j a }++instance Monad m => Monad (ReaderT r m) where+  return v = ReaderT (\_ -> return v)+  ReaderT m >>= f = ReaderT (\r -> m r >>= \a -> runReaderT (f a) r)+  ReaderT m >> ReaderT n = ReaderT (\r -> m r >> n r)++instance Monad m => MonadReader r (ReaderT r m) where+  ask = ReaderT return+  local f (ReaderT m) = ReaderT (m . f)
+ src/Darcs/Util/IsoDate.hs view
@@ -0,0 +1,896 @@+-- Copyright (C) 2003 Peter Simons+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++-- |+-- Module      : Darcs.Util.IsoDate+-- Copyright   : 2003 Peter Simons+--               2003 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.Util.IsoDate+    ( getIsoDateTime, readUTCDate, readUTCDateOldFashioned+    , parseDate, getLocalTz+    , englishDateTime, englishInterval, englishLast+    , iso8601Interval, iso8601Duration+    , cleanLocalDate, resetCalendar+    , MCalendarTime(..), subtractFromMCal, addToMCal+    , toMCalendarTime, unsafeToCalendarTime+    , unsetTime, TimeInterval+    , showIsoDateTime+    , theBeginning+    ) where++import Darcs.Prelude+import Prelude ( (^) )++import Text.ParserCombinators.Parsec+import System.Time+import System.IO.Unsafe ( unsafePerformIO )+import Data.Char ( toUpper, isDigit )+import Data.Maybe ( fromMaybe )+import Control.Monad ( liftM, liftM2 )+import qualified Data.ByteString.Char8 as BC++type TimeInterval = (Maybe CalendarTime, Maybe CalendarTime)++-- | Read/interpret a date string, assuming UTC if timezone+--   is not specified in the string (see 'readDate')+--   Warning! This errors out if we fail to interpret the+--   date+readUTCDate :: String -> CalendarTime+readUTCDate = readDate 0++-- | Convert a date string into ISO 8601 format (yyyymmdd variant)+--   assuming local timezone if not specified in the string+--   Warning! This errors out if we fail to interpret the date+cleanLocalDate :: String -> IO String+cleanLocalDate str =+   do tz <- getLocalTz+      return . showIsoDateTime . resetCalendar . readDate tz $ str++-- | Return the local timezone offset from UTC in seconds+getLocalTz :: IO Int+getLocalTz = ctTZ `liftM` (getClockTime >>= toCalendarTime)++-- | Parse a date string with 'parseDate'+--   Warning! This errors out if we fail to interpret the date+--   Uses its first argument as the default time zone.+readDate :: Int -> String -> CalendarTime+readDate tz d =+             case parseDate tz d of+             Left e -> error $ "bad date: "++d++" - "++show e+             Right ct -> resetCalendar $ unsafeToCalendarTime ct++-- | Similar to 'readUTCDate', except we /ignore/ timezone info+-- in the input string. This is incorrect and ugly. The only reason+-- it still exists is so we can generate file names for old-fashioned+-- repositories in the same way that old darcs versions expected them.+-- You should not use this function except for the above stated purpose.+readUTCDateOldFashioned :: String -> CalendarTime+readUTCDateOldFashioned d = +             case parseDate 0 d of+             Left e -> error $ "bad date: "++d++" - "++show e+             Right ct -> (unsafeToCalendarTime ct) { ctTZ = 0 }++-- | Parse a date string, assuming a default timezone if+--   the date string does not specify one.  The date formats+--   understood are those of 'showIsoDateTime' and 'dateTime'+parseDate :: Int -> String -> Either ParseError MCalendarTime+parseDate tz d =+              if length d >= 14 && BC.all isDigit bd+              then Right $ toMCalendarTime $+                   CalendarTime (readI $ BC.take 4 bd)+                                (toEnum $ (+ (-1)) $ readI $ BC.take 2 $ BC.drop 4 bd)+                                (readI $ BC.take 2 $ BC.drop 6 bd) -- Day+                                (readI $ BC.take 2 $ BC.drop 8 bd) -- Hour+                                (readI $ BC.take 2 $ BC.drop 10 bd) -- Minute+                                (readI $ BC.take 2 $ BC.drop 12 bd) -- Second+                                0 Sunday 0 -- Picosecond, weekday and day of year unknown+                                "GMT" 0 False+              else let dt = do { x <- dateTime tz; eof; return x }+                   in parse dt "" d+  where bd = BC.pack (take 14 d)+        readI s = fst $ fromMaybe (error "parseDate: invalid date") (BC.readInt s)++-- | Display a 'CalendarTime' in the ISO 8601 format without any+--   separators, e.g. 20080825142503+showIsoDateTime :: CalendarTime -> String+showIsoDateTime ct = concat [ show $ ctYear ct+                            , twoDigit . show . (+1) . fromEnum $ ctMonth ct+                            , twoDigit . show $ ctDay ct+                            , twoDigit . show $ ctHour ct+                            , twoDigit . show $ ctMin ct+                            , twoDigit . show $ ctSec ct+                            ]+    where twoDigit []          = undefined+          twoDigit x@(_:[])    = '0' : x+          twoDigit x@(_:_:[])  = x+          twoDigit _           = undefined++-- | The current time in the format returned by 'showIsoDateTime'+getIsoDateTime          :: IO String+getIsoDateTime = (showIsoDateTime . toUTCTime) `liftM` getClockTime++----- Parser Combinators ---------------------------------------------++-- | Case-insensitive variant of Parsec's 'char' function.+caseChar        :: Char -> GenParser Char a Char+caseChar c       = satisfy (\x -> toUpper x == toUpper c)++-- | Case-insensitive variant of Parsec's 'string' function.+caseString      :: String -> GenParser Char a ()+caseString cs    = mapM_ caseChar cs <?> cs++-- [x,y] => x <|> y+caseStrings :: [String] -> GenParser Char a ()+caseStrings xs = foldl1 (<|>) $ map caseString xs++-- | Match a parser at least @n@ times.+manyN           :: Int -> GenParser a b c -> GenParser a b [c]+manyN n p+    | n <= 0     = return []+    | otherwise  = liftM2 (++) (count n p) (many p)++-- | Match a parser at least @n@ times, but no more than @m@ times.+manyNtoM        :: Int -> Int -> GenParser a b c -> GenParser a b [c]+manyNtoM n m p+    | n < 0      = return []+    | n > m      = return []+    | n == m     = count n p+    | n == 0     = foldr ((<|>) . (\x -> try $ count x p)) (return []) (reverse [1..m])+    | otherwise  = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)+++----- Date/Time Parser -----------------------------------------------++-- | Try each of these date parsers in the following order+--+--    (1) 'cvsDateTime'+--+--    (2) 'iso8601DateTime'+--+--    (3) 'oldDateTime'+--+--    (4) 'rfc2822DateTime'+dateTime :: Int -> CharParser a MCalendarTime+dateTime tz =+            choice [try $ toMCalendarTime `fmap` cvsDateTime tz,+                    try $ iso8601DateTime tz,+                    try $ toMCalendarTime `fmap` oldDateTime,+                    toMCalendarTime `fmap` rfc2822DateTime]++parseDHMS :: CharParser a (Int, Int, Int, Int)+parseDHMS = do+    d <- day+    _ <- mySpaces+    (h, m, s) <- parseHMS+    return (d, h, m, s)++parseHMS :: CharParser a (Int, Int, Int)+parseHMS = do+    h <- hour+    _ <- char ':'+    m <- minute+    _ <- char ':'+    s <- second+    return (h, m, s)++parseSpacesMonthName :: CharParser a Month+parseSpacesMonthName = do+    _ <- mySpaces+    mon <- monthName+    _ <- mySpaces+    return mon++-- | CVS-style date/times, e.g.+--   2007/08/25 14:25:39 GMT+--   Note that time-zones are optional here.+cvsDateTime :: Int -> CharParser a CalendarTime+cvsDateTime tz =+                do y <- year+                   _ <- char '/'+                   mon <- monthNum+                   _ <- char '/'+                   (d, h, m, s) <- parseDHMS+                   z <- option tz $ mySpaces >> zone+                   return (CalendarTime y mon d h m s 0 Monday 0 "" z False)++-- | \"Old\"-style dates, e.g.+--   Tue Jan 3 14:08:07 EST 1999+-- darcs-doc: Question (what does the "old" stand for really?)+oldDateTime   :: CharParser a CalendarTime+oldDateTime      = do wd <- dayName+                      mon <- parseSpacesMonthName+                      (d, h, m , s) <- parseDHMS+                      _ <- mySpaces+                      z <- zone+                      _ <- mySpaces+                      y <- year+                      return (CalendarTime y mon d h m s 0 wd 0 "" z False)++rfc2822DateTime :: CharParser a CalendarTime+rfc2822DateTime    = do wd <- dayName+                        _ <- char ','+                        _ <- mySpaces+                        d <- day+                        mon <- parseSpacesMonthName+                        y <- year+                        _ <- mySpaces+                        (h, m, s) <- parseHMS+                        _ <- mySpaces+                        z <- zone+                        return (CalendarTime y mon d h m s 0 wd 0 "" z False)++-- | ISO 8601 dates and times.  Please note the following flaws:+--+--   I am reluctant to implement:+--+--      * years > 9999+--+--      * truncated representations with implied century (89 for 1989)+--+--   I have not implemented:+--+--      * repeated durations (not relevant)+--+--      * lowest order component fractions in intervals+--+--      * negative dates (BC)+--+--   I have not verified or have left too relaxed:+--+--      * the difference between 24h and 0h+--+--      * allows stuff like 2005-1212; either you use the hyphen all the way+--        (2005-12-12) or you don't use it at all (20051212), but you don't use+--        it halfway, likewise with time+--+--      * No bounds checking whatsoever on intervals!+--        (next action: read iso doc to see if bounds-checking required?) -}+iso8601DateTime   :: Int -> CharParser a MCalendarTime+iso8601DateTime localTz = try $+  do d <- iso8601Date+     t <- option id $ try $ do optional $ oneOf " T"+                               iso8601Time+     return $ t $ d { mctTZ = Just localTz }++-- | Three types of ISO 8601 date:+--+--     * calendar date, e.g., 1997-07-17, 1997-07, 199707, 1997+--+--     * week+day in year, e.g.,  1997-W32-4+--+--     * day in year, e.g, 1997-273+iso8601Date :: CharParser a MCalendarTime+iso8601Date =+  do d <- calendar_date <|> week_date <|> ordinal_date+     return $ foldr ($) nullMCalendar d+  where+    calendar_date = -- yyyy-mm-dd+      try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]+               -- allow other variants to be parsed correctly+               notFollowedBy (digit <|> char 'W')+               return d+    week_date = --yyyy-Www-d+      try $ do yfn <- year_+               optional dash+               _ <- char 'W'+               -- offset human 'week 1' -> computer 'week 0'+               w'  <- (\x -> x-1) `liftM` twoDigits+               mwd  <- option Nothing $ do { optional dash; Just `fmap` nDigits 1 }+               let y = resetCalendar . unsafeToCalendarTime . yfn $ nullMCalendar { mctDay = Just 1 }+                   firstDay = ctWDay y+               -- things that make this complicated+               -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday+               -- 2. the first week is the one that contains at least Thursday+               --    if the year starts after Thursday, then some days of the year+               --    will have already passed before the first week+               let afterThursday = firstDay == Sunday || firstDay > Thursday+                   w  = if afterThursday then w'+1 else w'+                   yday = (7 * w) + fromMaybe 1 mwd+                   diff c = c { mctWeek = True+                              , mctWDay = toEnum `fmap` mwd+                              , mctDay  = Just yday }+               return [diff.yfn]+    ordinal_date = -- yyyy-ddd+      try $ optchain year_ [ (dash, yearDay_) ]+    --+    year_  = try $ do y <- fourDigits <?> "year (0000-9999)"+                      return $ \c -> c { mctYear = Just y }+    month_ = try $ do m <- twoDigits <?> "month (1 to 12)"+                      return $ \c -> c { mctMonth = Just $ intToMonth m }+    day_   = try $ do d <- twoDigits <?> "day in month (1 to 31)"+                      return $ \c -> c { mctDay = Just d }+    yearDay_ = try $ do d <- nDigits 3 <?> "day in year (001 to 366)"+                        return $ \c -> c { mctDay = Just d+                                         , mctYDay = Just (d - 1) }+    dash = char '-'++-- | Note that this returns a function which sets the time on+--   another calendar (see 'iso8601DateTime' for a list of+--   flaws+iso8601Time :: CharParser a (MCalendarTime -> MCalendarTime)+iso8601Time = try $+  do ts <- optchain hour_ [ (colon     , min_)+                          , (colon     , sec_)+                          , (oneOf ",.", pico_) ]+     z  <- option id $ choice [ zulu , offset ]+     return $ foldr (.) id (z:ts)+  where+    hour_ = do h <- twoDigits+               return $ \c -> c { mctHour = Just h }+    min_  = do m <- twoDigits+               return $ \c -> c { mctMin = Just m }+    sec_  = do s <- twoDigits+               return $ \c -> c { mctSec = Just s }+    pico_ = do digs <- many digit+               let picoExp = 12+                   digsExp = length digs+               let frac | null digs = 0+                        | digsExp > picoExp = read $ take picoExp digs+                        | otherwise = 10 ^ (picoExp - digsExp) * read digs+               return $ \c -> c { mctPicosec = Just frac }+    zulu   = do { _ <- char 'Z'; return (\c -> c { mctTZ = Just 0 }) }+    offset = do sign <- choice [ char '+' >> return   1+                               , char '-' >> return (-1) ]+                h <- twoDigits+                m <- option 0 $ do { optional colon; twoDigits }+                return $ \c -> c { mctTZ = Just $ sign * 60 * ((h*60)+m) }+    colon = char ':'++-- | Intervals in ISO 8601, e.g.,+--+--    * 2008-09/2012-08-17T16:30+--+--    * 2008-09/P2Y11MT16H30M+--+--    * P2Y11MT16H30M/2012-08-17T16:30+--+--   See 'iso8601Duration'+iso8601Interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime))+iso8601Interval localTz = leftDur <|> rightDur where+  leftDur  =+    do dur <- iso8601Duration+       end <- option Nothing $ do { _ <- char '/'; Just `liftM` isoDt }+       return $ case end of+                Nothing -> Left dur+                Just e  -> Right (dur `subtractFromMCal` e, e)+  rightDur =+    do start <- isoDt+       _ <- char '/'+       durOrEnd <- Left `liftM` iso8601Duration <|> Right `liftM` isoDt+       return $ case durOrEnd of+                Left dur  -> Right (start, dur `addToMCal` start)+                Right end -> Right (start, end)+  isoDt   = iso8601DateTime localTz++-- | Durations in ISO 8601, e.g.,+--+--    * P4Y (four years)+--+--    * P5M (five months)+--+--    * P4Y5M (four years and five months)+--+--    * P4YT3H6S (four years, three hours and six seconds)+iso8601Duration :: CharParser a TimeDiff+iso8601Duration =+  do _ <- char 'P'+     y   <- block 0 'Y'+     mon <- block 0 'M'+     d   <- block 0 'D'+     (h,m,s) <- option (0,0,0) $+       do _ <- char 'T'+          h' <- block (-1) 'H'+          m' <- block (-1) 'M'+          s' <- block (-1) 'S'+          let unset = (== (-1))+          if all unset [h',m',s']+             then fail "T should be omitted if time is unspecified"+             else let clear x = if unset x then 0 else x+                  in return (clear h', clear m', clear s')+     --+     return $ TimeDiff y mon d h m s 0+  where block d c = option d $ try $+          do n <- many1 digit+             _ <- char c+             return $ read n++-- | 'optchain' @p xs@ parses a string with the obligatory+--   parser @p@.  If this suceeds, it continues on to the+--   rest of the input using the next parsers down the+--   chain.  Each part of the chain consists of a parser+--   for a separator and for the content itself.  The+--   separator is optional.+--+--   A good use of this function is to help in parsing ISO+--   ISO 8601 dates and times.  For example, the parser+--   @optchain year [(dash, month), (dash, day)]@ accepts+--   dates like 2007 (only the year is used), 2007-07 (only+--   the year and month), 200707 (only the year and month+--   with no separator), 2007-07-19 (year, month and day).+optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]+optchain p next = try $+  do r1 <- p+     r2 <- case next of+           [] -> return []+           ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }+     return (r1:r2)++nDigits :: Int -> CharParser a Int+nDigits n = read `liftM` count n digit++twoDigits, fourDigits :: CharParser a Int+twoDigits = nDigits 2+fourDigits = nDigits 4++-- | One or more space.+--   WARNING! This only matches on the space character, not on+--   whitespace in general+mySpaces :: CharParser a String+mySpaces = manyN 1 $ char ' '++-- | English three-letter day abbreviations (e.g. Mon, Tue, Wed)+dayName        :: CharParser a Day+dayName         = choice+                       [ caseString "Mon"       >> return Monday+                       , try (caseString "Tue") >> return Tuesday+                       , caseString "Wed"       >> return Wednesday+                       , caseString "Thu"       >> return Thursday+                       , caseString "Fri"       >> return Friday+                       , try (caseString "Sat") >> return Saturday+                       , caseString "Sun"       >> return Sunday+                       ]++-- | Four-digit year+year            :: CharParser a Int+year             = fourDigits++-- | One or two digit month (e.g. 3 for March, 11 for November)+monthNum       :: CharParser a Month+monthNum =  do mn <- manyNtoM 1 2 digit+               return $ intToMonth (read mn :: Int)++-- | January is 1, February is 2, etc+intToMonth :: Int -> Month+intToMonth 1 = January+intToMonth 2 = February+intToMonth 3 = March+intToMonth 4 = April+intToMonth 5 = May+intToMonth 6 = June+intToMonth 7 = July+intToMonth 8 = August+intToMonth 9 = September+intToMonth 10 = October+intToMonth 11 = November+intToMonth 12 = December+intToMonth _  = error "invalid month!"++-- | English three-letter month abbreviations (e.g. Jan, Feb, Mar)+monthName      :: CharParser a Month+monthName       = choice+                       [ try (caseString "Jan") >> return January+                       , caseString "Feb"       >> return February+                       , try (caseString "Mar") >> return March+                       , try (caseString "Apr") >> return April+                       , caseString "May"       >> return May+                       , try (caseString "Jun") >> return June+                       , caseString "Jul"       >> return July+                       , caseString "Aug"       >> return August+                       , caseString "Sep"       >> return September+                       , caseString "Oct"       >> return October+                       , caseString "Nov"       >> return November+                       , caseString "Dec"       >> return December+                       ]++-- | day in one or two digit notation+day             :: CharParser a Int+day              = do d <- manyNtoM 1 2 digit+                      return (read d :: Int)++-- | hour in two-digit notation+hour            :: CharParser a Int+hour             = twoDigits++-- | minute in two-digit notation+minute          :: CharParser a Int+minute           = twoDigits++-- | second in two-digit notation+second          :: CharParser a Int+second           = twoDigits++-- | limited timezone support+--+--   * +HHMM or -HHMM+--+--   * Universal timezones: UTC, UT+--+--   * Zones from GNU coreutils/lib/getdate.y, less half-hour ones --+--     sorry Newfies.+--+--   * any sequence of alphabetic characters (WARNING! treated as 0!)+zone            :: CharParser a Int+zone             = choice+                       [ do { _ <- char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }+                       , do { _ <- char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }+                       , mkZone "UTC"  0+                       , mkZone "UT"  0+                       , mkZone "GMT" 0+                       , mkZone "WET" 0+                       , mkZone "WEST" 1+                       , mkZone "BST" 1+                       , mkZone "ART" (-3)+                       , mkZone "BRT" (-3)+                       , mkZone "BRST" (-2)+                       , mkZone "AST" (-4)+                       , mkZone "ADT" (-3)+                       , mkZone "CLT" (-4)+                       , mkZone "CLST" (-3)+                       , mkZone "EST" (-5)+                       , mkZone "EDT" (-4)+                       , mkZone "CST" (-6)+                       , mkZone "CDT" (-5)+                       , mkZone "MST" (-7)+                       , mkZone "MDT" (-6)+                       , mkZone "PST" (-8)+                       , mkZone "PDT" (-7)+                       , mkZone "AKST" (-9)+                       , mkZone "AKDT" (-8)+                       , mkZone "HST" (-10)+                       , mkZone "HAST" (-10)+                       , mkZone "HADT" (-9)+                       , mkZone "SST" (-12)+                       , mkZone "WAT" 1+                       , mkZone "CET" 1+                       , mkZone "CEST" 2+                       , mkZone "MET" 1+                       , mkZone "MEZ" 1+                       , mkZone "MEST" 2+                       , mkZone "MESZ" 2+                       , mkZone "EET" 2+                       , mkZone "EEST" 3+                       , mkZone "CAT" 2+                       , mkZone "SAST" 2+                       , mkZone "EAT" 3+                       , mkZone "MSK" 3+                       , mkZone "MSD" 4+                       , mkZone "SGT" 8+                       , mkZone "KST" 9+                       , mkZone "JST" 9+                       , mkZone "GST" 10+                       , mkZone "NZST" 12+                       , mkZone "NZDT" 13+                         -- if we don't understand it, just give a GMT answer...+                       , do { _ <- manyTill (oneOf $ ' ' : ['a'..'z']++['A'..'Z'])+                                       (lookAhead space_digit);+                              return 0 }+                       ]+     where mkZone n o  = try $ do { caseString n; return (o*60*60) }+           space_digit = try $ do { _ <- char ' '; oneOf ['0'..'9'] }++----- English dates and intervals -----------------------------------------------++-- | In English, either a date followed by a time, or vice-versa, e.g,+--+--    * yesterday at noon+--+--    * yesterday tea time+--+--    * 12:00 yesterday+--+--   See 'englishDate' and 'englishTime'+--   Uses its first argument as "now", i.e. the time relative to which+--   "yesterday", "today" etc are to be interpreted+englishDateTime :: CalendarTime -> CharParser a CalendarTime+englishDateTime now =+  try $ dateMaybeAtTime <|> timeThenDate+  where+   -- yesterday (at) noon+   dateMaybeAtTime = try $+     do ed <- englishDate now+        t  <- option Nothing $ try $+                do { _ <- space; optional $ caseString "at "; Just `liftM` englishTime }+        return $ fromMaybe id t ed+   -- tea time 2005-12-04+   timeThenDate = try $+     do t  <- englishTime+        optional $ char ','+        _ <- space+        ed <- englishDate now+        return $ t $ unsetTime ed++-- | Specific dates in English as specific points of time, e.g,+--+--    * today+--+--    * yesterday+--+--    * last week (i.e. the beginning of that interval)+--+--    * 4 months ago (via 'englishAgo')+--+--   The first argument is "now".+englishDate :: CalendarTime -> CharParser a CalendarTime+englishDate now = try $+      (caseString "today"     >> return (resetCalendar now))+  <|> (caseString "yesterday" >> return (oneDay `subtractFromCal` now))+  <|> fst `fmap` englishLast now+  <|> englishAgo now+  where oneDay    = TimeDiff 0 0 1 0 0 0 0++-- | English expressions for points in the past, e.g.+--+--    * 4 months ago+--+--    * 1 day ago+--+--    * day before yesterday+--+--   See 'englishDuration'+englishAgo :: CalendarTime -> CharParser a CalendarTime+englishAgo now =+  try $ do p <- englishDuration+           _ <- try space+           (m,ref) <- try (caseString "ago" >> return (-1, now))+                   <|> do m <- beforeMod <|> afterMod+                          _ <- space+                          d <- englishDate now+                               <|> fst `fmap` englishLast now+                               <|> unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now)+                          return (m,d)+           return $ multiplyDiff m p `addToCal` ref+  where+    beforeMod = try $ caseString "before" >> return (-1)+    afterMod  = try $ caseStrings ["after","since"] >> return 1++-- | English expressions for intervals of time,+--+--    * before tea time (i.e. from the beginning of time)+--+--    * after 14:00 last month (i.e. till now)+--+--    * between last year and last month+--+--    * in the last three months (i.e. from then till now)+--+--    * 4 months ago (i.e. till now; see 'englishAgo')+englishInterval :: CalendarTime -> CharParser a TimeInterval+englishInterval now = twixt <|> before <|> after <|> inTheLast <|> lastetc+  where+   englishDT = unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now)+                <|> englishDateTime now+   before = try $+     do caseString "before"+        _ <- space+        end <- englishDT+        return (Just theBeginning, Just end)+   after = try $+     do caseStrings ["after","since"]+        _ <- space+        start <- englishDT+        return (Just start, Nothing)+   twixt = try $+     do caseString "between"+        _ <- space+        start <- englishDT+        _ <- space+        caseString "and"+        _ <- space+        end <- englishDT+        return (Just start, Just end)+   inTheLast = try $+     do caseString "in the last"+        _ <- space+        dur <- englishDuration+        return (Just $ dur `subtractFromCal` now, Just now)+   lastetc =+     do l <- englishAgo now+        return (Just l, Just now)++-- | Durations in English that begin with the word \"last\",+--   E.g. \"last 4 months\" is treated as the duration between+--   4 months ago and now+englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime)+englishLast now =+    -- last year, last week, last 3 years, etc+    try $ do caseString "last"+             _ <- space+             d <- englishDuration+             return (d `subtractFromCal` now, now)++-- | Either an 'iso8601Time' or one of several common+--   English time expressions like 'noon' or 'tea time'+englishTime :: CharParser a (CalendarTime->CalendarTime)+englishTime = try $+  choice [ wrapM `fmap` iso8601Time+         , namedTime "noon"            12  0+         , namedTime "midnight"         0  0+         , namedTime "tea time"        16 30+         , namedTime "bed time"         2 30+         , namedTime "proper bed time" 21 30 ]+  where namedTime name h m = try $+          do caseString name+             return $ \c -> c { ctHour = h, ctMin = m }+        wrapM f = unsafeToCalendarTime . f . toMCalendarTime++-- | Some English durations, e.g.+--+--    * day+--+--    * 4 score+--+--    * 7 years+--+--    * 12 months+--+-- This is not particularly strict about what it accepts.+-- For example, "7 yeares", "4 scores" or "1 days" are+-- just fine.+englishDuration :: CharParser a TimeDiff+englishDuration = try $+  do n <- option 1 $ do x <- many1 digit+                        _ <- space+                        return $ read x+     b <- base+     optional (caseStrings ["es","s"])+     let current = multiplyDiff n b+     next <- option noTimeDiff $ try $ do+              { optional space; _ <- char ',' ; optional space ; englishDuration }+     return $ addDiff current next+  where+  base = choice+         [ try $ caseString "score"      >> return (TimeDiff 20 0  0 0 0 0 0) -- why not?+         ,       caseString "year"       >> return (TimeDiff  1 0  0 0 0 0 0)+         , try $ caseString "month"      >> return (TimeDiff  0 1  0 0 0 0 0)+         ,       caseString "fortnight"  >> return (TimeDiff  0 0 14 0 0 0 0)+         ,       caseString "week"       >> return (TimeDiff  0 0  7 0 0 0 0)+         ,       caseString "day"        >> return (TimeDiff  0 0  1 0 0 0 0)+         ,       caseString "hour"       >> return (TimeDiff  0 0  0 1 0 0 0)+         ,       caseString "minute"     >> return (TimeDiff  0 0  0 0 1 0 0)+         ,       caseString "second"     >> return (TimeDiff  0 0  0 0 0 1 0) ]++----- Calendar and TimeDiff manipulation ---------------------------------------------++-- | The very beginning of time, i.e. 1970-01-01+theBeginning :: CalendarTime+theBeginning = unsafePerformIO $ toCalendarTime $ TOD 0 0++-- | An 'MCalenderTime' is an underspecified 'CalendarTime'+--   It is used for parsing dates.  For example, if you want to parse+--   the date '4 January', it may be useful to underspecify the year+--   by setting it to 'Nothing'.  This uses almost the same fields as+--   'System.Time.CalendarTime', a notable exception being that we+--   introduce 'mctWeek' to indicate if a weekday was specified or not+data MCalendarTime = MCalendarTime+ { mctYear  :: Maybe Int+ , mctMonth :: Maybe Month+ , mctDay   :: Maybe Int+ , mctHour  :: Maybe Int+ , mctMin   :: Maybe Int+ , mctSec   :: Maybe Int+ , mctPicosec :: Maybe Integer+ , mctWDay     :: Maybe Day+ , mctYDay     :: Maybe Int+ , mctTZName   :: Maybe String+ , mctTZ       :: Maybe Int+ , mctIsDST    :: Maybe Bool+ , mctWeek     :: Bool -- is set or not+} deriving Show++-- | Trivially convert a 'CalendarTime' to a fully specified+--   'MCalendarTime' (note that this sets the 'mctWeek' flag to+--   @False@+toMCalendarTime :: CalendarTime -> MCalendarTime+toMCalendarTime (CalendarTime a b c d e f g h i j k l) =+  MCalendarTime (Just a) (Just b) (Just c) (Just d) (Just e) (Just f)+                (Just g) (Just h) (Just i) (Just j) (Just k) (Just l)+                False++-- | Returns the first 'CalendarTime' that falls within a 'MCalendarTime'+--   This is only unsafe in the sense that it plugs in default values+--   for fields that have not been set, e.g. @January@ for the month+--   or @0@ for the seconds field.+--   Maybe we should rename it something happier.+--   See also 'resetCalendar'+unsafeToCalendarTime :: MCalendarTime -> CalendarTime+unsafeToCalendarTime m =+ CalendarTime+  { ctYear = fromMaybe 0 $ mctYear m+  , ctMonth = fromMaybe January $ mctMonth m+  , ctDay = fromMaybe 1 $ mctDay m+  , ctHour = fromMaybe 0 $ mctHour m+  , ctMin = fromMaybe 0 $ mctMin m+  , ctSec = fromMaybe 0 $ mctSec m+  , ctPicosec = fromMaybe 0 $ mctPicosec m+  , ctWDay = fromMaybe Sunday $ mctWDay m+  , ctYDay = fromMaybe 0 $ mctYDay m+  , ctTZName = fromMaybe "" $ mctTZName m+  , ctTZ = fromMaybe 0 $ mctTZ m+  , ctIsDST = fromMaybe False $ mctIsDST m+ }++addToCal :: TimeDiff -> CalendarTime -> CalendarTime+addToCal td = toUTCTime . addToClockTime td . toClockTime++subtractFromCal :: TimeDiff -> CalendarTime -> CalendarTime+subtractFromCal = addToCal . multiplyDiff (-1)++addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime+addToMCal td mc =+ copyCalendar (addToCal td $ unsafeToCalendarTime mc) mc++subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime+subtractFromMCal = addToMCal . multiplyDiff (-1)++-- surely there is a more concise way to express these+addDiff :: TimeDiff -> TimeDiff -> TimeDiff+addDiff (TimeDiff a1 a2 a3 a4 a5 a6 a7) (TimeDiff b1 b2 b3 b4 b5 b6 b7) =+  TimeDiff (a1+b1) (a2+b2) (a3+b3) (a4+b4) (a5+b5) (a6+b6) (a7 + b7)++-- | 'multiplyDiff' @i d@ multiplies every field in @d@ with @i@+--+-- FIXME; this seems like a terrible idea! it seems like+-- we should get rid of it if at all possible, maybe adding an+-- invertDiff function+multiplyDiff :: Int -> TimeDiff -> TimeDiff+multiplyDiff m (TimeDiff a1 a2 a3 a4 a5 a6 a7) =+  TimeDiff (a1*m) (a2*m) (a3*m) (a4*m) (a5*m) (a6*m) (a7 * toInteger m)++nullMCalendar :: MCalendarTime+nullMCalendar = MCalendarTime Nothing Nothing Nothing Nothing Nothing Nothing+                              Nothing Nothing Nothing Nothing Nothing Nothing+                              False++-- | Set a calendar to UTC time any eliminate any inconsistencies within+--   (for example, where the weekday is given as @Thursday@, but this does not+--   match what the numerical date would lead one to expect)+resetCalendar :: CalendarTime -> CalendarTime+resetCalendar = toUTCTime . toClockTime++-- | 'copyCalendar' @c mc@ replaces any field which is+--   specified in @mc@ with the equivalent field in @c@+--   @copyCalendar c nullMCalendar == nullMCalendar@+copyCalendar :: CalendarTime -> MCalendarTime -> MCalendarTime+copyCalendar c mc = mc+  { mctYear  = mctYear mc  >> Just (ctYear c)+  , mctMonth = mctMonth mc >> Just (ctMonth c)+  , mctDay   = mctDay mc   >> Just (ctDay c)+  , mctHour  = mctHour mc  >> Just (ctHour c)+  , mctMin   = mctMin mc   >> Just (ctMin c)+  , mctSec   = mctSec mc   >> Just (ctSec c)+  , mctPicosec = mctPicosec mc >> Just (ctPicosec c)+  , mctWDay = mctWDay mc   >> Just (ctWDay c)+  , mctYDay = mctYDay mc   >> Just (ctYDay c)+  , mctTZName = mctTZName mc >> Just (ctTZName c)+  , mctTZ     = mctTZ mc    >> Just (ctTZ c)+  , mctIsDST  = mctIsDST mc >> Just (ctIsDST c)+  }++-- | Zero the time fields of a 'CalendarTime'+unsetTime :: CalendarTime -> CalendarTime+unsetTime mc = mc+  { ctHour  = 0+  , ctMin   = 0+  , ctSec   = 0+  , ctPicosec = 0+  }
+ src/Darcs/Util/Lock.hs view
@@ -0,0 +1,380 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Util.Lock+    ( withLock+    , withLockCanFail+    , environmentHelpLocks+    , withTempDir+    , withPermDir+    , withDelayedDir+    , withNamedTemp+    , writeBinFile+    , writeTextFile+    , writeDocBinFile+    , appendBinFile+    , appendTextFile+    , appendDocBinFile+    , readBinFile+    , readTextFile+    , readDocBinFile+    , writeAtomicFilePS+    , gzWriteAtomicFilePS+    , gzWriteAtomicFilePSs+    , gzWriteDocFile+    , removeFileMayNotExist+    , maybeRelink+    , tempdirLoc+    , environmentHelpTmpdir+    , environmentHelpKeepTmpdir+    , addToErrorLoc+    , withNewDirectory+    ) where++import Darcs.Prelude++import Data.List ( inits )+import Data.Maybe ( fromJust, isJust, listToMaybe )+import System.Exit ( exitWith, ExitCode(..) )+import System.IO+    ( withFile, withBinaryFile+    , Handle, hPutStr, hSetEncoding+    , IOMode(WriteMode, AppendMode), hFlush, stdout+    )+import System.IO.Error+    ( isAlreadyExistsError+    , annotateIOError+    , catchIOError+    )+import Control.Exception+    ( IOException+    , bracket+    , throwIO+    , catch+    , SomeException+    )+import System.Directory+    ( doesFileExist+    , doesDirectoryExist+    , createDirectory+    , getTemporaryDirectory+    , makeAbsolute+    , removePathForcibly+    , renameFile+    , renameDirectory+    )+import System.FilePath.Posix ( splitDirectories, splitFileName )+import System.Directory ( withCurrentDirectory )+import System.Environment ( lookupEnv )+import System.IO.Temp ( createTempDirectory )++import Control.Concurrent ( threadDelay )+import Control.Monad ( unless, when )++import System.Posix.Files ( fileMode, getFileStatus, setFileMode )++import GHC.IO.Encoding ( getFileSystemEncoding )++import Safe ( headErr )++import Darcs.Util.URL ( isRelative )+import Darcs.Util.Exception+    ( firstJustIO+    , catchall+    )+import Darcs.Util.File ( removeFileMayNotExist )+import Darcs.Util.Path ( AbsolutePath, FilePathLike, toFilePath,+                        getCurrentDirectory, setCurrentDirectory )++import Darcs.Util.ByteString ( gzWriteFilePSs )+import qualified Data.ByteString as B (null, readFile, hPut, ByteString)++import Darcs.Util.SignalHandler ( withSignalsBlocked )+import Darcs.Util.Printer ( Doc, hPutDoc, packedString, empty, renderPSs )+import Darcs.Util.AtExit ( atexit )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.Compat+    ( maybeRelink+    , atomicCreate+    , sloppyAtomicCreate+    )+import Darcs.Util.Progress ( debugMessage )+import Darcs.Util.Prompt ( askUser )++withLock :: String -> IO a -> IO a+withLock s job = bracket (getLock s 30) releaseLock (const job)++releaseLock :: String -> IO ()+releaseLock = removeFileMayNotExist++-- | Tries to perform some task if it can obtain the lock,+-- Otherwise, just gives up without doing the task+withLockCanFail :: String -> IO a -> IO (Either () a)+withLockCanFail s job =+  bracket (takeLock s `catchall` return False)+          (\l -> when l $ releaseLock s)+          (\l -> if l then Right <$> job+                      else return $ Left ())++getLock :: String -> Int -> IO String+getLock l 0 = do yorn <- askUser $ "Couldn't get lock "++l++". Abort (yes or anything else)? "+                 case yorn of+                    ('y':_) -> exitWith $ ExitFailure 1+                    _ -> getLock l 30+getLock lbad tl = do l <- makeAbsolute lbad+                     gotit <- takeLock l+                     if gotit then return l+                              else do putStrLn $ "Waiting for lock "++l+                                      hFlush stdout -- for Windows+                                      threadDelay 2000000+                                      getLock l (tl - 1)+++takeLock :: FilePathLike p => p -> IO Bool+takeLock fp =+    do atomicCreate $ toFilePath fp+       return True+  `catch` \e -> if isAlreadyExistsError e+                then return False+                else do pwd <- getCurrentDirectory+                        throwIO $ addToErrorLoc e+                                   ("takeLock "++toFilePath fp++" in "++toFilePath pwd)++takeFile :: FilePath -> IO Bool+takeFile fp =+    do sloppyAtomicCreate fp+       return True+  `catch` \e -> if isAlreadyExistsError e+                then return False+                else do pwd <- getCurrentDirectory+                        throwIO $ addToErrorLoc e+                                   ("takeFile "++fp++" in "++toFilePath pwd)++environmentHelpLocks :: ([String],[String])+environmentHelpLocks = (["DARCS_SLOPPY_LOCKS"],[+ "If on some filesystems you get an error of the kind:",+ "",+ "    darcs: takeLock [...]: atomic_create [...]: unsupported operation",+ "",+ "you may want to try to export DARCS_SLOPPY_LOCKS=True."])++tempdirLoc :: IO FilePath+tempdirLoc = fromJust <$>+    firstJustIO [ fmap (Just . headErr . words) (readFile (darcsdir++"/prefs/tmpdir")) >>= chkdir,+                  lookupEnv "DARCS_TMPDIR" >>= chkdir,+                  getTemporaryDirectory >>= chkdir . Just,+                  getCurrentDirectorySansDarcs,+                  return $ Just "."  -- always returns a Just+                ]+    where chkdir Nothing = return Nothing+          chkdir (Just d) = (\e -> if e then Just (d++"/") else Nothing) <$> doesDirectoryExist d++environmentHelpTmpdir :: ([String], [String])+environmentHelpTmpdir = (["DARCS_TMPDIR", "TMPDIR"], [+ "Darcs often creates temporary directories.  For example, the `darcs",+ "diff` command creates two for the working trees to be diffed.  By",+ "default temporary directories are created in /tmp, or if that doesn't",+ "exist, in _darcs (within the current repo).  This can be overridden by",+ "specifying some other directory in the file _darcs/prefs/tmpdir or the",+ "environment variable $DARCS_TMPDIR or $TMPDIR."])++getCurrentDirectorySansDarcs :: IO (Maybe FilePath)+getCurrentDirectorySansDarcs = do+  c <- getCurrentDirectory+  return $ listToMaybe $ drop 5 $ reverse $ takeWhile no_darcs $ inits $ toFilePath c+  where no_darcs x = darcsdir `notElem` splitDirectories x++data WithDirKind = Perm | Temp | Delayed++-- | Creates a directory based on the path parameter;+-- if a relative path is given the dir is created in the darcs temp dir.+-- If an absolute path is given this dir will be created if it doesn't exist.+-- If it is specified as a temporary dir, it is deleted after finishing the job.+withDir :: WithDirKind  -- specifies if and when directory will be deleted+        -> FilePath     -- path parameter+        -> (AbsolutePath -> IO a) -> IO a+withDir _ "" _ = error "withDir called with empty directory name"+withDir kind absoluteOrRelativeName job = do+  absoluteName <- if isRelative absoluteOrRelativeName+                   then fmap (++ absoluteOrRelativeName) tempdirLoc+                   else return absoluteOrRelativeName+  formerdir <- getCurrentDirectory+  bracket (createDir absoluteName)+          (\dir -> do+              setCurrentDirectory formerdir+              k <- keepTempDir+              unless k $+                  case kind of+                      Perm -> return ()+                      Temp -> cleanup (toFilePath dir)+                      Delayed -> atexit $ cleanup (toFilePath dir))+          job+    where createDir :: FilePath -> IO AbsolutePath+          createDir name+              = do let (parent,dir) = splitFileName name+                   createTempDirectory parent dir >>= setCurrentDirectory+                   getCurrentDirectory+          keepTempDir = isJust `fmap` lookupEnv "DARCS_KEEP_TMPDIR"+          toDelete dir = dir ++ "_done"+          cleanup path = do+              -- so asynchronous threads cannot add any more+              -- files while we are deleting+              debugMessage $ unwords ["atexit: renaming",path,"to",toDelete path]+              renameDirectory path (toDelete path)+              debugMessage $ unwords ["atexit: deleting",toDelete path]+              removePathForcibly (toDelete path) `catchIOError` const (return ())++environmentHelpKeepTmpdir :: ([String], [String])+environmentHelpKeepTmpdir = (["DARCS_KEEP_TMPDIR"],[+ "If the environment variable DARCS_KEEP_TMPDIR is defined, darcs will",+ "not remove the temporary directories it creates.  This is intended",+ "primarily for debugging Darcs itself, but it can also be useful, for",+ "example, to determine why your test preference (see `darcs setpref`)",+ "is failing when you run `darcs record`, but working when run manually."])++-- |'withPermDir' is like 'withTempDir', except that it doesn't+-- delete the directory afterwards.+withPermDir :: FilePath -> (AbsolutePath -> IO a) -> IO a+withPermDir = withDir Perm++-- |'withTempDir' creates a temporary directory, runs the action and then+-- removes the directory. The+-- location of that directory is determined by the contents of+-- _darcs/prefs/tmpdir, if it exists, otherwise by @$DARCS_TMPDIR@, and if+-- that doesn't exist then whatever your operating system considers to be a+-- a temporary directory (e.g. @$TMPDIR@ under Unix, @$TEMP@ under+-- Windows).+--+-- If none of those exist it creates the temporary directory+-- in the current directory, unless the current directory is under a _darcs+-- directory, in which case the temporary directory in the parent of the highest+-- _darcs directory to avoid accidentally corrupting darcs's internals.+-- This should not fail, but if it does indeed fail, we go ahead and use the+-- current directory anyway. If @$DARCS_KEEP_TMPDIR@ variable is set+-- temporary directory is not removed, this can be useful for debugging.+withTempDir :: FilePath -> (AbsolutePath -> IO a) -> IO a+withTempDir = withDir Temp++withDelayedDir :: FilePath -> (AbsolutePath -> IO a) -> IO a+withDelayedDir = withDir Delayed++worldReadableTemp :: FilePath -> IO FilePath+worldReadableTemp f = wrt 0+    where wrt :: Int -> IO FilePath+          wrt 100 = fail $ "Failure creating temp named "++f+          wrt n = let f_new = f++"-"++show n+                  in do ok <- takeFile f_new+                        if ok then return f_new+                              else wrt (n+1)++withNamedTemp :: FilePath -> (FilePath -> IO a) -> IO a+withNamedTemp n f = do+    when False $ debugMessage $ "withNamedTemp: " ++ show n+    bracket (worldReadableTemp n) removeFileMayNotExist f++readBinFile :: FilePathLike p => p -> IO B.ByteString+readBinFile = B.readFile . toFilePath++-- NOTE using 'seq' on the last element of the result causes the content to be+-- fully evaluated, so the file is read strictly; this is more efficient than+-- counting the number of characters; and in the (few) places where we use this+-- function we need the lines anyway.+readTextFile :: FilePathLike p => p -> IO [String]+readTextFile f = do+  result <- lines <$> readFile (toFilePath f)+  case result of+    [] -> return result+    xs -> last xs `seq` return result++readDocBinFile :: FilePathLike p => p -> IO Doc+readDocBinFile fp = do ps <- B.readFile $ toFilePath fp+                       return $ if B.null ps then empty else packedString ps++appendBinFile :: FilePathLike p => p -> B.ByteString -> IO ()+appendBinFile f s = appendToFile Binary f $ \h -> B.hPut h s++appendTextFile :: FilePathLike p => p -> String -> IO ()+appendTextFile f s = appendToFile Text f $ \h -> hPutStr h s++appendDocBinFile :: FilePathLike p => p -> Doc -> IO ()+appendDocBinFile f d = appendToFile Binary f $ \h -> hPutDoc h d++data FileType = Text | Binary++writeBinFile :: FilePathLike p => p -> B.ByteString -> IO ()+writeBinFile f s = writeToFile Binary f $ \h -> B.hPut h s++writeTextFile :: FilePathLike p => p -> String -> IO ()+writeTextFile f s = writeToFile Text f $ \h -> do+  getFileSystemEncoding >>= hSetEncoding h+  hPutStr h s++writeDocBinFile :: FilePathLike p => p -> Doc -> IO ()+writeDocBinFile f d = writeToFile Binary f $ \h -> hPutDoc h d++writeAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()+writeAtomicFilePS f ps = writeToFile Binary f $ \h -> B.hPut h ps++gzWriteAtomicFilePS :: FilePathLike p => p -> B.ByteString -> IO ()+gzWriteAtomicFilePS f ps = gzWriteAtomicFilePSs f [ps]++gzWriteAtomicFilePSs :: FilePathLike p => p -> [B.ByteString] -> IO ()+gzWriteAtomicFilePSs f pss =+    withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do+    gzWriteFilePSs newf pss+    already_exists <- doesFileExist $ toFilePath f+    when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)+                             setFileMode newf mode+             `catchall` return ()+    renameFile newf (toFilePath f)++gzWriteDocFile :: FilePathLike p => p -> Doc -> IO ()+gzWriteDocFile f d = gzWriteAtomicFilePSs f $ renderPSs d++writeToFile :: FilePathLike p => FileType -> p -> (Handle -> IO ()) -> IO ()+writeToFile t f job =+    withSignalsBlocked $ withNamedTemp (toFilePath f) $ \newf -> do+    (case t of+      Text -> withFile+      Binary -> withBinaryFile) newf WriteMode job+    already_exists <- doesFileExist (toFilePath f)+    when already_exists $ do mode <- fileMode `fmap` getFileStatus (toFilePath f)+                             setFileMode newf mode+             `catchall` return ()+    renameFile newf (toFilePath f)++appendToFile :: FilePathLike p => FileType -> p -> (Handle -> IO ()) -> IO ()+appendToFile t f job = withSignalsBlocked $+    (case t of+      Binary -> withBinaryFile+      Text -> withFile) (toFilePath f) AppendMode job+++addToErrorLoc :: IOException+              -> String+              -> IOException+addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing++-- | Do an action in a newly created directory of the given name. If the+-- directory is successfully created but the action raises an exception, the+-- directory and all its content is deleted. Caught exceptions are re-thrown.+withNewDirectory :: FilePath -> IO () -> IO ()+withNewDirectory name action = do+  createDirectory name+  withCurrentDirectory name action `catch` \e -> do+    removePathForcibly name `catchIOError` const (return ())+    throwIO (e :: SomeException)
+ src/Darcs/Util/Parser.hs view
@@ -0,0 +1,125 @@+module Darcs.Util.Parser+    ( Parser+    , anyChar+    , char+    , checkConsumes+    , choice+    , endOfInput+    , int+    , lexChar+    , lexString+    , linesStartingWith+    , linesStartingWithEndingWith+    , lexWord+    , A.lookAhead+    , many+    , option+    , optional+    , parse+    , parseAll+    , skipSpace+    , skipWhile+    , string+    , take+    , takeTill+    , takeTillChar+    , unsigned+    , withPath+    , (<|>)+    ) where++import Control.Applicative ( empty, many, optional, (<|>) )++import Darcs.Prelude hiding ( lex, take )++import qualified Data.Attoparsec.ByteString as A+import qualified Data.Attoparsec.Combinator as A+import Data.Attoparsec.ByteString.Char8 hiding ( parse, char, string )+import qualified Data.Attoparsec.ByteString.Char8 as AC+import qualified Data.ByteString as B++withPath :: FilePath -> Either String a -> Either String a+withPath fp (Left s) = Left ("in file: "++fp++": "++s)+withPath _ r = r++parseAll :: Parser a -> B.ByteString -> Either String a+parseAll p bs =+  case parse p bs of+    Left e -> Left e+    Right (r, leftover)+      | B.null (B.dropWhile isSpace_w8 leftover) -> Right r+      | otherwise -> Left $ "leftover: " ++ show leftover++parse :: Parser a -> B.ByteString -> Either String (a, B.ByteString)+parse p bs =+  case AC.parse p bs of+    Fail _ ss s -> Left $ unlines (s:ss)+    Partial k ->+      case k B.empty of+        Fail _ ss s -> Left $ unlines (s:ss)+        Partial _ -> error "impossible"+        Done i r -> Right (r, i)+    Done i r -> Right (r, i)++{-# INLINE skip #-}+skip :: Parser a -> Parser ()+skip p = p >> return ()++{-# INLINE lex #-}+lex :: Parser a -> Parser a+lex p = skipSpace >> p++{-# INLINE lexWord #-}+lexWord :: Parser B.ByteString+lexWord = lex (A.takeWhile1 (not . isSpace_w8))++{-# INLINE lexChar #-}+lexChar :: Char -> Parser ()+lexChar c = lex (char c)++{-# inline lexString #-}+lexString :: B.ByteString -> Parser ()+lexString s = lex (string s)++{-# INLINE char #-}+char :: Char -> Parser ()+char = skip . AC.char++{-# INLINE string #-}+string :: B.ByteString -> Parser ()+string = skip . AC.string++{-# INLINE int #-}+int :: Parser Int+int = lex (signed decimal)++{-# INLINE unsigned #-}+unsigned :: Integral a => Parser a+unsigned = lex decimal++{-# INLINE takeTillChar #-}+takeTillChar :: Char -> Parser B.ByteString+takeTillChar c = takeTill (== c)++{-# INLINE checkConsumes #-}+checkConsumes :: Parser a -> Parser a+checkConsumes parser = do+  (consumed, result) <- match parser+  if B.null consumed+    then empty+    else return result++{-# INLINE linesStartingWith #-}+linesStartingWith :: Char -> Parser [B.ByteString]+linesStartingWith c = many $ do+  char c+  r <- takeTillChar '\n'+  skip (char '\n') <|> endOfInput+  return r++{-# INLINE linesStartingWithEndingWith #-}+linesStartingWithEndingWith :: Char -> Char -> Parser [B.ByteString]+linesStartingWithEndingWith st en = do+  ls <- linesStartingWith st+  char en+  return ls
+ src/Darcs/Util/Path.hs view
@@ -0,0 +1,535 @@+-- Copyright (C) 2007 Eric Kow+-- Copyright (C) 2010 Petr Rockai+--+-- 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+-- SOFTWARE.++{-# LANGUAGE CPP #-}+module Darcs.Util.Path+    ( encodeWhite+    , decodeWhite+    , encodeWhiteName+    , decodeWhiteName+    -- * AbsolutePath+    , AbsolutePath+    , makeAbsolute+    , ioAbsolute+    -- * AbsolutePathOrStd+    , AbsolutePathOrStd+    , makeAbsoluteOrStd+    , ioAbsoluteOrStd+    , useAbsoluteOrStd+    , stdOut+    -- * AbsoluteOrRemotePath+    , AbsoluteOrRemotePath+    , ioAbsoluteOrRemote+    , isRemote+    -- * SubPath+    , SubPath+    , makeSubPathOf+    , simpleSubPath+    , floatSubPath+    , makeRelativeTo+    -- * Miscellaneous+    , FilePathOrURL(..)+    , FilePathLike(toFilePath)+    , getCurrentDirectory+    , setCurrentDirectory+    , getUniquePathName+    -- * Tree filtering.+    , filterPaths+    -- * AnchoredPaths: relative paths within a Tree. All paths are+    -- anchored at a certain root (this is usually the Tree root). They are+    -- represented by a list of Names (these are just strict bytestrings).+    , Name+    , name2fp+    , makeName+    , rawMakeName+    , eqAnycase+    , AnchoredPath(..)+    , anchoredRoot+    , appendPath+    , anchorPath+    , isPrefix+    , movedirfilename+    , parent+    , parents+    , replaceParent+    , catPaths+    , flatten+    , inDarcsdir+    , displayPath+    , realPath+    , isRoot+    , darcsdirName+    , floatPath+    -- * Unsafe AnchoredPath functions.+    , unsafeFloatPath+    ) where++import Darcs.Prelude++import Control.Exception ( bracket_ )+import Control.Monad ( when, (<=<) )+import Darcs.Util.ByteString ( decodeLocale, encodeLocale )+import Data.Binary+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC+import Data.Char ( chr, isSpace, ord, toLower )+import Data.List ( inits, isPrefixOf, isSuffixOf, stripPrefix )+import GHC.Stack ( HasCallStack )+import qualified System.Directory ( setCurrentDirectory )+import System.Directory ( doesDirectoryExist, doesPathExist )+import qualified System.FilePath as NativeFilePath+import qualified System.FilePath.Posix as FilePath+import System.Posix.Files ( fileID, getFileStatus, isDirectory )++import Darcs.Util.Exception ( ifDoesNotExistError )+import Darcs.Util.Global ( darcsdir )+import Darcs.Util.URL ( isAbsolute, isHttpUrl, isRelative, isSshNopath, isSshUrl )+import qualified Darcs.Util.Workaround as Workaround ( getCurrentDirectory )+++-- Utilities for use by command implementations++-- | For displaying paths to the user. It should never be used+-- for on-disk patch storage. This adds the "./" for consistency+-- with how repo paths are displayed by 'showPatch' and friends,+-- except for the root path which is displayed as plain ".".+displayPath :: AnchoredPath -> FilePath+displayPath p+  | isRoot p = "."+  | otherwise = anchorPath "." p++-- | Interpret an 'AnchoredPath' as relative the current working+-- directory. Intended for IO operations in the file system.+-- Use with care!+realPath :: AnchoredPath -> FilePath+realPath = anchorPath ""++-- | 'encodeWhite' translates whitespace in filenames to a darcs-specific+--   format (numerical representation according to 'ord' surrounded by+--   backslashes).  Note that backslashes are also escaped since they are used+--   in the encoding.+--+--   > encodeWhite "hello there" == "hello\32\there"+--   > encodeWhite "hello\there" == "hello\92\there"+encodeWhite :: FilePath -> String+encodeWhite (c:cs) | isSpace c || c == '\\' =+    '\\' : show (ord c) ++ "\\" ++ encodeWhite cs+encodeWhite (c:cs) = c : encodeWhite cs+encodeWhite [] = []++-- | 'decodeWhite' interprets the Darcs-specific \"encoded\" filenames+--   produced by 'encodeWhite'+--+--   > decodeWhite "hello\32\there"  == Right "hello there"+--   > decodeWhite "hello\92\there"  == Right "hello\there"+--   > decodeWhite "hello\there"   == Left "malformed filename"+decodeWhite :: String -> Either String FilePath+decodeWhite cs_ = go cs_ [] False+ where go "" acc True  = Right (reverse acc) -- if there was a replace, use new string+       go "" _   False = Right cs_         -- if not, use input string+       go ('\\':cs) acc _ =+         case break (=='\\') cs of+           (theord, '\\':rest) ->+             go rest (chr (read theord) :acc) True+           _ -> Left $ "malformed filename: " ++ cs_+       go (c:cs) acc modified = go cs (c:acc) modified++class FilePathOrURL a where+  toPath :: a -> String++class FilePathOrURL a => FilePathLike a where+  toFilePath :: a -> FilePath++-- | Paths which are relative to the local darcs repository and normalized.+-- Note: These are understood not to have the dot in front.+newtype SubPath      = SubPath FilePath deriving (Eq, Ord)++newtype AbsolutePath = AbsolutePath FilePath deriving (Eq, Ord)++-- | This is for situations where a string (e.g. a command line argument)+-- may take the value \"-\" to mean stdin or stdout (which one depends on+-- context) instead of a normal file path.+data AbsolutePathOrStd = AP AbsolutePath | APStd deriving (Eq, Ord)+data AbsoluteOrRemotePath = AbsP AbsolutePath | RmtP String deriving (Eq, Ord)++instance FilePathOrURL AbsolutePath where+  toPath (AbsolutePath x) = x+instance FilePathOrURL SubPath where+  toPath (SubPath x) = x+instance FilePathOrURL AbsoluteOrRemotePath where+  toPath (AbsP a) = toPath a+  toPath (RmtP r) = r+instance FilePathOrURL FilePath where+  toPath = id++instance FilePathLike AbsolutePath where+  toFilePath (AbsolutePath x) = x+instance FilePathLike SubPath where+  toFilePath (SubPath x) = x+instance FilePathLike FilePath where+  toFilePath = id++-- | Make the second path relative to the first, if possible.+-- Note that this returns an empty 'SubPath' if the inputs are equal.+makeSubPathOf :: AbsolutePath -> AbsolutePath -> Maybe SubPath+makeSubPathOf (AbsolutePath p1) (AbsolutePath p2) =+ -- The slash prevents "foobar" from being treated as relative to "foo"+ if p1 == p2 || (p1 ++ "/") `isPrefixOf` p2+    then Just $ SubPath $ drop (length p1 + 1) p2+    else Nothing++simpleSubPath :: HasCallStack => FilePath -> Maybe SubPath+simpleSubPath x | null x = error "simpleSubPath called with empty path"+                | isRelative x = Just $ SubPath $ FilePath.normalise $ pathToPosix x+                | otherwise = Nothing++-- | Interpret a possibly relative path wrt the current working directory.+-- This also canonicalizes the path, resolving symbolic links etc.+ioAbsolute :: FilePath -> IO AbsolutePath+ioAbsolute dir =+    do isdir <- doesDirectoryExist dir+       here <- getCurrentDirectory+       if isdir+         then bracket_ (setCurrentDirectory dir)+                       (setCurrentDirectory $ toFilePath here)+                       getCurrentDirectory+         else let super_dir = case NativeFilePath.takeDirectory dir of+                                "" ->  "."+                                d  -> d+                  file = NativeFilePath.takeFileName dir+              in do abs_dir <- if dir == super_dir+                               then return $ AbsolutePath dir+                               else ioAbsolute super_dir+                    return $ makeAbsolute abs_dir file++-- | The first argument must be the absolute path of a @directory@, the second+-- is an arbitrary absolute @path@. Find the longest prefix of @path@ that+-- points to the same @directory@; if there is none, return 'Nothing', else+-- return 'Just' the remainder.+makeRelativeTo :: HasCallStack => AbsolutePath -> AbsolutePath -> IO (Maybe SubPath)+makeRelativeTo (AbsolutePath dir) (AbsolutePath path) = do+  dir_stat <- getFileStatus dir+  let dir_id = fileID dir_stat+  when (not (isDirectory dir_stat)) $+    error $ "makeRelativeTo called with non-dir " ++ dir+  findParent dir_id path []+  where+    findParent dir_id ap acc = do+      map_stat <- ifDoesNotExistError Nothing (Just <$> getFileStatus ap)+      case map_stat of+        Just ap_stat | fileID ap_stat == dir_id -> do+          -- found ancestor that matches dir+          return $ Just $ SubPath $ FilePath.joinPath acc+        _ -> do+          -- recurse+          let (parent_,child) =+                -- splitFileName only does what one expects if there is no+                -- trailing path separator+                NativeFilePath.splitFileName $+                  NativeFilePath.dropTrailingPathSeparator ap+          if null child then+            return Nothing+          else+            findParent dir_id parent_ (child:acc)++-- | Take an absolute path and a string representing a (possibly relative)+-- path and combine them into an absolute path. If the second argument is+-- already absolute, then the first argument gets ignored. This function also+-- takes care that the result is converted to Posix convention and+-- normalized. Also, parent directories (\"..\") at the front of the string+-- argument get canceled out against trailing directory parts of the+-- absolute path argument.+--+-- Regarding the last point, someone more familiar with how these functions+-- are used should verify that this is indeed necessary or at least useful.+makeAbsolute :: AbsolutePath -> FilePath -> AbsolutePath+makeAbsolute a dir = if not (null dir) && isAbsolute dir+                     then AbsolutePath (normSlashes dir')+                     else ma a dir'+  where+    dir' = FilePath.normalise $ pathToPosix dir+    -- Why do we care to reduce ".." here?+    -- Why not do this throughout the whole path, i.e. "x/y/../z" -> "x/z" ?+    ma here ('.':'.':'/':r) = ma (takeDirectory here) r+    ma here ".." = takeDirectory here+    ma here "." = here+    ma here "" = here+    ma here r = here /- ('/':r)++(/-) :: AbsolutePath -> String -> AbsolutePath+x /- ('/':r) = x /- r+(AbsolutePath "/") /- r = AbsolutePath ('/':simpleClean r)+(AbsolutePath x) /- r = AbsolutePath (x++'/':simpleClean r)++-- | Convert to posix, remove trailing slashes, and (under Posix)+-- reduce multiple leading slashes to one.+simpleClean :: String -> String+simpleClean = normSlashes . reverse . dropWhile (=='/') . reverse . pathToPosix++makeAbsoluteOrStd :: AbsolutePath -> String -> AbsolutePathOrStd+makeAbsoluteOrStd _ "-" = APStd+makeAbsoluteOrStd a p = AP $ makeAbsolute a p++stdOut :: AbsolutePathOrStd+stdOut = APStd++ioAbsoluteOrStd :: String -> IO AbsolutePathOrStd+ioAbsoluteOrStd "-" = return APStd+ioAbsoluteOrStd p = AP `fmap` ioAbsolute p++-- | Execute either the first or the second argument action, depending on+-- whether the given path is an 'AbsolutePath' or stdin/stdout.+useAbsoluteOrStd :: (AbsolutePath -> a) -> a -> AbsolutePathOrStd -> a+useAbsoluteOrStd _ f APStd = f+useAbsoluteOrStd f _ (AP x) = f x++ioAbsoluteOrRemote :: String -> IO AbsoluteOrRemotePath+ioAbsoluteOrRemote p = do+  isdir <- doesDirectoryExist p+  if not isdir+     then return $ RmtP $+          case () of _ | isSshNopath p    -> p++"."+                       | "/" `isSuffixOf` p -> init p+                       | otherwise          -> p+     else AbsP `fmap` ioAbsolute p++isRemote :: AbsoluteOrRemotePath -> Bool+isRemote (RmtP _) = True+isRemote _ = False++takeDirectory :: AbsolutePath -> AbsolutePath+takeDirectory (AbsolutePath x) =+    case reverse $ drop 1 $ dropWhile (/='/') $ reverse x of+    "" -> AbsolutePath "/"+    x' -> AbsolutePath x'++instance Show AbsolutePath where+ show = show . toFilePath+instance Show SubPath where+ show = show . toFilePath+instance Show AbsolutePathOrStd where+    show (AP a) = show a+    show APStd = "standard input/output"+instance Show AbsoluteOrRemotePath where+    show (AbsP a) = show a+    show (RmtP r) = show r++-- | Normalize the path separator to Posix style (slash, not backslash).+-- This only affects Windows systems.+pathToPosix :: FilePath -> FilePath+#ifdef WIN32+pathToPosix = map convert where+  convert '\\' = '/'+  convert c = c+#else+pathToPosix = id+#endif++-- | Reduce multiple leading slashes to one. This only affects Posix systems.+normSlashes :: FilePath -> FilePath+#ifndef WIN32+-- multiple slashes in front are ignored under Posix+normSlashes ('/':p) = '/' : dropWhile (== '/') p+#endif+normSlashes p = p++getCurrentDirectory :: IO AbsolutePath+getCurrentDirectory = AbsolutePath `fmap` Workaround.getCurrentDirectory++setCurrentDirectory :: HasCallStack => FilePathLike p => p -> IO ()+setCurrentDirectory path+  | isHttpUrl (toFilePath path) || isSshUrl (toFilePath path) =+    error $ "setCurrentDirectory " ++ toFilePath path+setCurrentDirectory path = System.Directory.setCurrentDirectory (toFilePath path)++-- | Iteratively tries find first non-existing path generated by+-- buildName, it feeds to buildName the number starting with -1.  When+-- it generates non-existing path and it isn't first, it displays the+-- message created with buildMsg. Usually used for generation of the+-- name like <path>_<number> when <path> already exist+-- (e.g. darcs.net_0).+getUniquePathName :: Bool -> (FilePath -> String) -> (Int -> FilePath) -> IO FilePath+getUniquePathName talkative buildMsg buildName = go (-1)+ where+  go :: Int -> IO FilePath+  go i = do+    exists <- doesPathExist thename+    if not exists+       then do when (i /= -1 && talkative) $ putStrLn $ buildMsg thename+               return thename+       else go $ i+1+    where thename = buildName i++-------------------------------+-- AnchoredPath utilities+--++newtype Name = Name { unName :: B.ByteString } deriving (Binary, Eq, Show, Ord)++-- | This is a type of "sane" file paths. These are always canonic in the sense+-- that there are no stray slashes, no ".." components and similar. They are+-- usually used to refer to a location within a Tree, but a relative filesystem+-- path works just as well. These are either constructed from individual name+-- components (using "appendPath", "catPaths" and "makeName"), or converted+-- from a FilePath ("unsafeFloatPath" -- but take care when doing that).+newtype AnchoredPath = AnchoredPath [Name] deriving (Binary, Eq, Show, Ord)++-- | Check whether a path is a prefix of another path.+isPrefix :: AnchoredPath -> AnchoredPath -> Bool+(AnchoredPath a) `isPrefix` (AnchoredPath b) = a `isPrefixOf` b++-- | Append an element to the end of a path.+appendPath :: AnchoredPath -> Name -> AnchoredPath+appendPath (AnchoredPath p) n = AnchoredPath $ p ++ [n]++-- | Catenate two paths together. Not very safe, but sometimes useful+-- (e.g. when you are representing paths relative to a different point than a+-- Tree root).+catPaths :: AnchoredPath -> AnchoredPath -> AnchoredPath+catPaths (AnchoredPath p) (AnchoredPath n) = AnchoredPath (p ++ n)++-- | Get parent (path) of a given path. foo/bar/baz -> foo/bar+parent :: AnchoredPath -> Maybe AnchoredPath+parent (AnchoredPath []) = Nothing+parent (AnchoredPath x) = Just (AnchoredPath (init x))++-- | List all (proper) parents of a given path. foo/bar/baz -> [.,foo, foo/bar]+parents :: AnchoredPath -> [AnchoredPath]+parents (AnchoredPath []) = [] -- root has no parents+parents (AnchoredPath xs) = map AnchoredPath $ inits $ init xs++-- | Take a "root" directory and an anchored path and produce a full+-- 'FilePath'. Moreover, you can use @anchorPath \"\"@ to get a relative+-- 'FilePath'.+anchorPath :: FilePath -> AnchoredPath -> FilePath+anchorPath dir p = dir FilePath.</> decodeLocale (flatten p)+{-# INLINE anchorPath #-}++name2fp :: Name -> FilePath+name2fp (Name ps) = decodeLocale ps++-- FIXME returning "." for the root is wrong+flatten :: AnchoredPath -> BC.ByteString+flatten (AnchoredPath []) = BC.singleton '.'+flatten (AnchoredPath p) = BC.intercalate (BC.singleton '/') [n | (Name n) <- p]++-- | Make a 'Name' from a 'String'. May fail if the input 'String'+-- is invalid, that is, "", ".", "..", or contains a '/'.+makeName :: String -> Either String Name+makeName = rawMakeName . encodeLocale++-- | Take a relative FilePath and turn it into an AnchoredPath. This is a+-- partial function. Basically, by using unsafeFloatPath, you are testifying that the+-- argument is a path relative to some common root -- i.e. the root of the+-- associated "Tree" object. In particular, the input path may not contain any+-- ocurrences of "." or ".." after normalising. You should sanitize any+-- FilePaths before you declare them "good" by converting into AnchoredPath+-- (using this function), especially if the FilePath come from any external+-- source (command line, file, environment, network, etc)+unsafeFloatPath :: HasCallStack => FilePath -> AnchoredPath+unsafeFloatPath = either error id . floatPath++floatPath :: FilePath -> Either String AnchoredPath+floatPath path = do+    r <- mapM makeName (prepare path)+    return (AnchoredPath r)+  where+    sensible s = s `notElem` ["", "."]+    prepare = filter sensible .+      NativeFilePath.splitDirectories . NativeFilePath.normalise .+      NativeFilePath.dropTrailingPathSeparator++anchoredRoot :: AnchoredPath+anchoredRoot = AnchoredPath []++-- | A view on 'AnchoredPath's.+parentChild :: AnchoredPath -> Maybe (AnchoredPath, Name)+parentChild (AnchoredPath []) = Nothing+parentChild (AnchoredPath xs) = Just (AnchoredPath (init xs), last xs)++-- | Replace the second arg's parent with the first arg.+replaceParent :: AnchoredPath -> AnchoredPath -> Maybe AnchoredPath+replaceParent (AnchoredPath xs) p =+  case parentChild p of+    Nothing -> Nothing+    Just (_,x) -> Just (AnchoredPath (xs ++ [x]))++-- | Make a 'Name' from a 'B.ByteString'.+rawMakeName :: B.ByteString -> Either String Name+rawMakeName s+  | isBadName s =+      Left $ "'"++decodeLocale s++"' is not a valid AnchoredPath component name"+  | otherwise = Right (Name s)++isBadName :: B.ByteString -> Bool+isBadName n = hasPathSeparator n || n `elem` forbiddenNames++-- It would be nice if we could add BC.pack "_darcs" to the list, however+-- "_darcs" could be a valid file or dir name if not inside the top level+-- directory.+forbiddenNames :: [B.ByteString]+forbiddenNames = [BC.empty, BC.pack ".", BC.pack ".."]++hasPathSeparator :: B.ByteString -> Bool+hasPathSeparator = BC.elem '/'++eqAnycase :: Name -> Name -> Bool+eqAnycase (Name a) (Name b) = BC.map toLower a == BC.map toLower b++encodeWhiteName :: Name -> B.ByteString+encodeWhiteName = encodeLocale . encodeWhite . decodeLocale . unName++decodeWhiteName :: B.ByteString -> Either String Name+decodeWhiteName =+  rawMakeName . encodeLocale <=< decodeWhite . decodeLocale++-- | The effect of renaming on paths.+-- The first argument is the old path, the second is the new path,+-- and the third is the possibly affected path we are interested in.+movedirfilename :: AnchoredPath -> AnchoredPath -> AnchoredPath -> AnchoredPath+movedirfilename (AnchoredPath old) newp@(AnchoredPath new) orig@(AnchoredPath path) =+  case stripPrefix old path of+    Just [] -> newp -- optimization to avoid allocation in this case+    Just rest -> AnchoredPath (new ++ rest)+    Nothing -> orig -- old is not a prefix => no change++-- | Construct a filter from a list of AnchoredPaths, that will accept any path+-- that is either a parent or a child of any of the listed paths, and discard+-- everything else.+filterPaths :: [AnchoredPath] -> AnchoredPath -> t -> Bool+filterPaths files p _ = any (\x -> x `isPrefix` p || p `isPrefix` x) files++-- | Transform a SubPath into an AnchoredPath.+floatSubPath :: SubPath -> Either String AnchoredPath+floatSubPath = floatPath . toFilePath++-- | Is the given path in (or equal to) the _darcs metadata directory?+inDarcsdir :: AnchoredPath -> Bool+inDarcsdir (AnchoredPath (x:_)) | x == darcsdirName = True+inDarcsdir _ = False++darcsdirName :: Name+darcsdirName = either error id (makeName darcsdir)++isRoot :: AnchoredPath -> Bool+isRoot (AnchoredPath xs) = null xs
+ src/Darcs/Util/Printer.hs view
@@ -0,0 +1,536 @@+-- | Darcs pretty printing library+--+-- The combinator names are taken from 'Text.PrettyPrint.HughesPJ', although+-- the behaviour of the two libraries is slightly different.+--+-- This code was made generic in the element type by Juliusz Chroboczek.+module Darcs.Util.Printer+    (+    -- * 'Doc' type and structural combinators+      Doc(Doc,unDoc)+    , empty, (<>), (<?>), (<+>), ($$), ($+$), vcat, vsep, hcat, hsep+    , minus, newline, plus, space, backslash, lparen, rparen+    , parens, sentence+    -- * Constructing 'Doc's+    , text+    , hiddenText+    , invisibleText+    , wrapText, quoted+    , formatText+    , formatWords+    , pathlist+    , userchunk, packedString+    , prefix+    , hiddenPrefix+    , insertBeforeLastline+    , prefixLines+    , invisiblePS, userchunkPS+    -- * Rendering to 'String'+    , renderString, renderStringWith+    -- * Rendering to 'ByteString'+    , renderPS, renderPSWith+    , renderPSs, renderPSsWith+    -- * Printers+    , Printers+    , Printers'(..)+    , Printer+    , simplePrinters, invisiblePrinter, simplePrinter+    -- * Printables+    , Printable(..)+    , doc+    , printable, invisiblePrintable, hiddenPrintable, userchunkPrintable+    -- * Constructing colored 'Doc's+    , Color(..)+    , blueText, redText, greenText, magentaText, cyanText+    , colorText+    , lineColor+    -- * IO, uses 'Data.ByteString.hPut' for output+    , hPutDoc,     hPutDocLn,     putDoc,     putDocLn+    , hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith+    , hPutDocCompr+    , debugDocLn+    -- * TODO: It is unclear what is unsafe about these constructors+    , unsafeText, unsafeBoth, unsafeBothText, unsafeChar+    , unsafePackedString+    ) where++import Darcs.Prelude++import Data.String ( IsString(..) )+import System.IO ( Handle, stdout )+import qualified Data.ByteString as B ( ByteString, hPut, concat )+import qualified Data.ByteString.Char8 as BC ( singleton )++import Darcs.Util.ByteString ( linesPS, decodeLocale, encodeLocale, gzWriteHandle )+import Darcs.Util.Global ( debugMessage )++-- | A 'Printable' is either a String, a packed string, or a chunk of+-- text with both representations.+data Printable = S !String+               | PS !B.ByteString+               | Both !String !B.ByteString++-- | 'Printable' representation of a space+spaceP :: Printable+spaceP   = Both " "  (BC.singleton ' ')++-- | 'Printable' representation of a newline.+newlineP :: Printable+newlineP = S "\n"++-- | A 'Doc' representing a space (\" \")+space :: Doc+space = unsafeBoth " "  (BC.singleton ' ')++-- | A 'Doc' representing a newline+newline :: Doc+newline = unsafeChar '\n'++-- | A 'Doc' representing a \"-\"+minus :: Doc+minus = unsafeBoth "-"  (BC.singleton '-')++-- | A 'Doc' representing a \"+\"+plus :: Doc+plus = unsafeBoth "+"  (BC.singleton '+')++-- | A 'Doc' representing a \"\\\"+backslash :: Doc+backslash = unsafeBoth "\\" (BC.singleton '\\')++-- | A 'Doc' that represents @\"(\"@+lparen :: Doc+lparen = unsafeBoth  "(" (BC.singleton '(')++-- | A 'Doc' that represents @\")\"@+rparen :: Doc+rparen = unsafeBoth ")" (BC.singleton ')')++-- | prop> parens d = lparen <> d <> rparen+parens :: Doc -> Doc+parens d = lparen <> d <> rparen++-- | Turn a 'Doc' into a sentence. This appends a ".".+sentence :: Doc -> Doc+sentence = (<> text ".")++-- | Format a list of 'FilePath's as quoted text. It deliberately refuses to+-- use English.andClauses but rather separates the quoted strings only with a+-- space, because this makes it usable for copy and paste e.g. as arguments to+-- another shell command.+pathlist :: [FilePath] -> Doc+pathlist paths = hsep (map quoted paths)++-- | 'putDocWith' puts a 'Doc' on stdout using the given printer.+putDocWith :: Printers -> Doc -> IO ()+putDocWith prs = hPutDocWith prs stdout++-- | 'putDocLnWith' puts a 'Doc', followed by a newline on stdout using+-- the given printer.+putDocLnWith :: Printers -> Doc -> IO ()+putDocLnWith prs = hPutDocLnWith prs stdout++-- | 'putDoc' puts a 'Doc' on stdout using the simple printer 'simplePrinters'.+putDoc :: Doc -> IO ()+putDoc = hPutDoc stdout++-- | 'putDocLn' puts a 'Doc', followed by a newline on stdout using+-- 'simplePrinters'+putDocLn :: Doc -> IO ()+putDocLn = hPutDocLn stdout++-- | 'hputDocWith' puts a 'Doc' on the given handle using the given printer.+hPutDocWith :: Printers -> Handle -> Doc -> IO ()+hPutDocWith prs h d = do+  p <- prs h+  hPrintPrintables h (renderWith p d)++-- | 'hputDocLnWith' puts a 'Doc', followed by a newline on the given+-- handle using the given printer.+hPutDocLnWith :: Printers -> Handle -> Doc -> IO ()+hPutDocLnWith prs h d = hPutDocWith prs h (d <?> newline)++-- |'hputDoc' puts a 'Doc' on the given handle using 'simplePrinters'+hPutDoc :: Handle -> Doc -> IO ()+hPutDoc = hPutDocWith simplePrinters++-- | 'hputDocLn' puts a 'Doc', followed by a newline on the given handle using+-- 'simplePrinters'.+hPutDocLn :: Handle -> Doc -> IO ()+hPutDocLn = hPutDocLnWith simplePrinters++-- | like 'hPutDoc' but with compress data before writing+hPutDocCompr :: Handle -> Doc -> IO ()+hPutDocCompr h = gzWriteHandle h . renderPSs++-- | Write a 'Doc' to stderr if debugging is turned on.+debugDocLn :: Doc -> IO ()+debugDocLn = debugMessage . renderString++-- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle @h@+-- It uses binary output of 'ByteString's. If these not available,+-- converts according to locale.+hPrintPrintables :: Handle -> [Printable] -> IO ()+hPrintPrintables h = mapM_ (hPrintPrintable h)++-- | @'hPrintPrintable' h@ prints a 'Printable' to the handle @h@.+hPrintPrintable :: Handle -> Printable -> IO ()+hPrintPrintable h (S ps) = B.hPut h (encodeLocale ps)+hPrintPrintable h (PS ps) = B.hPut h ps+hPrintPrintable h (Both _ ps) = B.hPut h ps++-- | A 'Doc' is a bit of enriched text. 'Doc's are concatenated using+-- '<>' from class 'Monoid', which is right-associative.+newtype Doc = Doc { unDoc :: St -> Document }++-- | Together with the language extension OverloadedStrings, this allows to+-- use string literals where a 'Doc' is expected.+instance IsString Doc where+   fromString = text++-- | The State associated with a 'Doc'. Contains a set of printers for each+-- hanlde, and the current prefix of the document.+data St = St { printers :: !Printers',+               currentPrefix :: !([Printable] -> [Printable]) }+type Printers = Handle -> IO Printers'++-- | A set of printers to print different types of text to a handle.+data Printers' = Printers {colorP :: !(Color -> Printer),+                           invisibleP :: !Printer,+                           hiddenP :: !Printer,+                           userchunkP :: !Printer,+                           defP :: !Printer,+                           lineColorT :: !(Color -> Doc -> Doc),+                           lineColorS :: !([Printable] -> [Printable])+                          }+type Printer = Printable -> St -> Document++data Color = Blue | Red | Green | Cyan | Magenta++-- | 'Document' is a wrapper around '[Printable] -> [Printable]' which allows+-- to handle the special case of an empty 'Document' in a non-uniform manner.+-- The simplest 'Documents' are built from 'String's using 'text'.+data Document = Document ([Printable] -> [Printable])+              | Empty++-- | renders a 'Doc' into a 'String' with control codes for the+-- special features of the 'Doc'.+renderString :: Doc -> String+renderString = renderStringWith simplePrinters'++-- | renders a 'Doc' into a 'String' using a given set of printers.+-- If content is only available as 'ByteString', decode according to+-- the current locale.+renderStringWith :: Printers' -> Doc -> String+renderStringWith prs d = concatMap (toString) $ renderWith prs d+    where toString (S s) = s+          toString (PS ps) = decodeLocale ps+          toString (Both s _) = s++-- | renders a 'Doc' into 'B.ByteString' with control codes for the+-- special features of the Doc. See also 'readerString'.+renderPS :: Doc -> B.ByteString+renderPS = renderPSWith simplePrinters'++-- | renders a 'Doc' into a list of 'PackedStrings', one for each line.+renderPSs :: Doc -> [B.ByteString]+renderPSs = renderPSsWith simplePrinters'++-- | renders a 'Doc' into a 'B.ByteString' using a given set of printers.+renderPSWith :: Printers' -> Doc -> B.ByteString+renderPSWith prs d = B.concat $ renderPSsWith prs d++-- | renders a 'Doc' into a list of 'PackedStrings', one for each+-- chunk of text that was added to the 'Doc', using the given set of+-- printers.+renderPSsWith :: Printers' -> Doc -> [B.ByteString]+renderPSsWith prs d = map toPS $ renderWith prs d+    where toPS (S s)        = encodeLocale s+          toPS (PS ps)      = ps+          toPS (Both _ ps)  = ps++-- | renders a 'Doc' into a list of 'Printables' using a set of+-- printers. Each item of the list corresponds to a string that was+-- added to the 'Doc'.+renderWith :: Printers' -> Doc -> [Printable]+renderWith ps (Doc d) = case d (initState ps) of+                        Empty -> []+                        Document f -> f []++initState :: Printers' -> St+initState prs = St { printers = prs, currentPrefix = id }++prefix :: String -> Doc -> Doc+prefix s (Doc d) = Doc $ \st ->+                   let p = S s+                       st' = st { currentPrefix = currentPrefix st . (p:) } in+                   case d st' of+                     Document d'' -> Document $ (p:) . d''+                     Empty -> Empty++-- TODO try to find another way to do this, it's rather a violation+-- of the Doc abstraction+prefixLines :: Doc -> Doc -> Doc+prefixLines prefixer prefixee =+  vcat $ map (prefixer <+>) $ map packedString $ linesPS $ renderPS prefixee++-- TODO try to find another way to do this, it's rather a violation+-- of the Doc abstraction+insertBeforeLastline :: Doc -> Doc -> Doc+insertBeforeLastline a b =+  case reverse $ map packedString $ linesPS $ renderPS a of+    (ll:ls) -> vcat (reverse ls) $$ b $$ ll+    [] ->+      error "empty Doc given as first argument of Printer.insert_before_last_line"++lineColor :: Color -> Doc -> Doc+lineColor c d = Doc $ \st -> case lineColorT (printers st) c d of+                             Doc d' -> d' st++hiddenPrefix :: String -> Doc -> Doc+hiddenPrefix s (Doc d) =+    Doc $ \st -> let pr = printers st+                     p = S (renderStringWith pr $ hiddenText s)+                     st' = st { currentPrefix = currentPrefix st . (p:) }+                 in case d st' of+                      Document d'' -> Document $ (p:) . d''+                      Empty -> Empty++-- | 'unsafeBoth' builds a Doc from a 'String' and a 'B.ByteString' representing+-- the same text, but does not check that they do.+unsafeBoth :: String -> B.ByteString -> Doc+unsafeBoth s ps = Doc $ simplePrinter (Both s ps)++-- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the+-- Doc as both a String and a 'B.ByteString'.+unsafeBothText :: String -> Doc+unsafeBothText s = Doc $ simplePrinter (Both s (encodeLocale s))++-- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable'+packedString :: B.ByteString -> Doc+packedString = printable . PS++-- | 'unsafePackedString' builds a 'Doc' from a 'B.ByteString' using 'simplePrinter'+unsafePackedString :: B.ByteString -> Doc+unsafePackedString = Doc . simplePrinter . PS++-- | 'invisiblePS' creates a 'Doc' with invisible text from a 'B.ByteString'+invisiblePS :: B.ByteString -> Doc+invisiblePS = invisiblePrintable . PS++-- | Create a 'Doc' representing a user chunk from a 'B.ByteString';+-- see 'userchunk' for details.+userchunkPS :: B.ByteString -> Doc+userchunkPS = userchunkPrintable . PS++-- | 'unsafeChar' creates a Doc containing just one character.+unsafeChar :: Char -> Doc+unsafeChar = unsafeText . (:"")++-- | 'text' creates a 'Doc' from a @String@, using 'printable'.+text :: String -> Doc+text = printable . S++-- | 'unsafeText' creates a 'Doc' from a 'String', using 'simplePrinter' directly+unsafeText :: String -> Doc+unsafeText = Doc . simplePrinter . S++-- | 'invisibleText' creates a 'Doc' containing invisible text from a @String@+invisibleText :: String -> Doc+invisibleText = invisiblePrintable . S++-- | 'hiddenText' creates a 'Doc' containing hidden text from a @String@+hiddenText :: String -> Doc+hiddenText = hiddenPrintable . S++-- | Create a 'Doc' containing a userchunk from a @String@.+--+-- Userchunks are used for printing arbitrary bytes stored in prim patches:+--+--  * old and new preference values in ChangePref prims+--  * tokenChars, old token and new token in TokReplace prims+--  * old and new content lines in Hunk prims+--+-- In colored mode they are printed such that trailing whitespace before the+-- end of a line is made visible by marking the actual line ending with a red+-- '$' char (unless DARCS_DONT_ESCAPE_TRAILING_SPACES or even+-- DARCS_DONT_ESCAPE_ANYTHING are set in the environment).+userchunk :: String -> Doc+userchunk = userchunkPrintable . S++blueText, redText, greenText, magentaText, cyanText :: String -> Doc+blueText = colorText Blue+redText = colorText Red+greenText = colorText Green+magentaText = colorText Magenta+cyanText = colorText Cyan++-- | 'colorText' creates a 'Doc' containing colored text from a @String@+colorText :: Color -> String -> Doc+colorText c = mkColorPrintable c . S++-- | @'wrapText' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters+wrapText :: Int -> String -> Doc+wrapText n s =+    vcat . map text . reverse $ foldl add_to_line [] (words s)+  where add_to_line [] a = [a]+        add_to_line ("":d) a = a:d+        add_to_line (l:ls) new | length l + length new > n = new:l:ls+        add_to_line (l:ls) new = (l ++ " " ++ new):ls++-- | Given a list of 'String's representing the words of a paragraph, format+-- the paragraphs using 'wrapText' and separate them with an empty line.+formatText :: Int -> [String] -> Doc+formatText w = vsep . map (wrapText w)++-- | A variant of 'wrapText' that takes a list of strings as input.+-- Useful when @{-# LANGUAGE CPP #-}@ makes it impossible to use multiline+-- string literals.+formatWords :: [String] -> Doc+formatWords = wrapText 80 . unwords++-- | Creates a 'Doc' from any 'Printable'.+printable :: Printable -> Doc+printable x = Doc $ \st -> defP (printers st) x st++mkColorPrintable :: Color -> Printable -> Doc+mkColorPrintable c x = Doc $ \st -> colorP (printers st) c x st++-- | Creates an invisible 'Doc' from any 'Printable'.+invisiblePrintable :: Printable -> Doc+invisiblePrintable x = Doc $ \st -> invisibleP (printers st) x st++-- | Creates a hidden 'Doc' from any 'Printable'.+hiddenPrintable :: Printable -> Doc+hiddenPrintable x = Doc $ \st -> hiddenP (printers st) x st++-- | Creates a userchunk from any 'Printable'; see 'userchunk' for details.+userchunkPrintable :: Printable -> Doc+userchunkPrintable x = Doc $ \st -> userchunkP (printers st) x st++-- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any+-- handle.+simplePrinters :: Printers+simplePrinters _ = return simplePrinters'++-- | A set of default printers suitable for any handle. Does not use color.+simplePrinters' :: Printers'+simplePrinters'  = Printers { colorP = const simplePrinter,+                              invisibleP = simplePrinter,+                              hiddenP = invisiblePrinter,+                              userchunkP = simplePrinter,+                              defP = simplePrinter,+                              lineColorT = const id,+                              lineColorS = id+                            }++-- | 'simplePrinter' is the simplest 'Printer': it just concatenates together+-- the pieces of the 'Doc'+simplePrinter :: Printer+simplePrinter x = unDoc $ doc (\s -> x:s)++-- | 'invisiblePrinter' is the 'Printer' for hidden text. It just replaces+-- the document with 'empty'.  It's useful to have a printer that doesn't+-- actually do anything because this allows you to have tunable policies,+-- for example, only printing some text if it's to the terminal, but not+-- if it's to a file or vice-versa.+invisiblePrinter :: Printer+invisiblePrinter _ = unDoc empty++infixr 6 `append`+infixr 6 <+>+infixr 5 $+$+infixr 5 $$++-- | The empty 'Doc'+empty :: Doc+empty = Doc $ const Empty++doc :: ([Printable] -> [Printable]) -> Doc+doc f = Doc $ const $ Document f++instance Semigroup Doc where+  (<>) = append++-- | 'mappend' ('<>') is concatenation, 'mempty' is the 'empty' 'Doc'+instance Monoid Doc where+  mempty = empty+  mappend = (<>)++-- | Concatenation of two 'Doc's+append :: Doc -> Doc -> Doc+Doc a `append` Doc b =+   Doc $ \st -> case a st of+                Empty -> b st+                Document af ->+                    Document (\s -> af $ case b st of+                                         Empty -> s+                                         Document bf -> bf s)++-- | @a '<?>' b@ is @a '<>' b@ if @a@ is not empty, else empty+(<?>) :: Doc -> Doc -> Doc+Doc a <?> Doc b =+    Doc $ \st -> case a st of+                 Empty -> Empty+                 Document af -> Document (\s -> af $ case b st of+                                                     Empty -> s+                                                     Document bf -> bf s)++-- | @a '<+>' b@ is @a@ followed by @b@ with a space in between if both are non-empty+(<+>) :: Doc -> Doc -> Doc+Doc a <+> Doc b =+    Doc $ \st -> case a st of+                 Empty -> b st+                 Document af -> Document (\s -> af $ case b st of+                                                     Empty -> s+                                                     Document bf ->+                                                         spaceP:bf s)++-- | @a '$$' b@ is @a@ above @b@+($$) :: Doc -> Doc -> Doc+Doc a $$ Doc b =+   Doc $ \st -> case a st of+                Empty -> b st+                Document af ->+                    Document (\s -> af $ case b st of+                                         Empty -> s+                                         Document bf -> sf (newlineP:pf (bf s)))+                        where pf = currentPrefix st+                              sf = lineColorS $ printers st++-- | @a '$+$' b@ is @a@ above @b@ with an empty line in between if both are non-empty+($+$) :: Doc -> Doc -> Doc+Doc a $+$ Doc b =+   Doc $ \st -> case a st of+                Empty -> b st+                Document af ->+                    Document (\s -> af $ case b st of+                                         Empty -> s+                                         Document bf -> sf (newlineP:newlineP:pf (bf s)))+                        where pf = currentPrefix st+                              sf = lineColorS $ printers st++-- | Pile 'Doc's vertically+vcat :: [Doc] -> Doc+vcat = foldr ($$) empty++-- | Pile 'Doc's vertically, with a blank line in between+vsep :: [Doc] -> Doc+vsep = foldr ($+$) empty++-- | Concatenate 'Doc's horizontally+hcat :: [Doc] -> Doc+hcat = mconcat++-- | Concatenate 'Doc's horizontally with a space as separator+hsep :: [Doc] -> Doc+hsep = foldr (<+>) empty++-- | Quote a string for screen output+quoted :: String -> Doc+quoted s = text "\"" <> text (escape s) <> text "\""+  where+    escape "" = ""+    escape (c:cs) = if c `elem` ['\\', '"']+                       then '\\' : c : escape cs+                       else c : escape cs
+ src/Darcs/Util/Printer/Color.hs view
@@ -0,0 +1,381 @@+{-# LANGUAGE CPP #-}+module Darcs.Util.Printer.Color+    ( unsafeRenderStringColored, traceDoc, fancyPrinters+    , environmentHelpColor, environmentHelpEscape, environmentHelpEscapeWhite+    , ePutDocLn+    ) where++import Darcs.Prelude++import Darcs.Util.Printer+    ( Printer, Printers, Printers'(..), Printable(..), Color(..)+    , invisiblePrinter, (<?>), Doc(Doc,unDoc), unsafeBothText, simplePrinter, hcat+    , unsafeText, unsafePackedString+    , renderStringWith, prefix+    , hPutDocLnWith+    )++import Debug.Trace ( trace )+import Data.Char ( isAscii, isPrint, isSpace, isControl, ord, chr )+import Data.Bits ( bit, xor )+import System.Environment ( lookupEnv )+import qualified Data.ByteString.Char8 as BC (unpack, any, last, spanEnd)+import qualified Data.ByteString       as B (null, init)+import System.IO.Unsafe ( unsafePerformIO )+import System.IO ( stderr, hIsTerminalDevice, Handle )+import Text.Printf ( printf )+#ifdef HAVE_TERMINFO+import System.Console.Terminfo( tiGetNum, setupTermFromEnv, getCapability )+import Data.Maybe ( fromMaybe )+#endif++dollar, cr :: Doc+dollar = unsafeBothText "$"+cr     = unsafeBothText "\r"++-- | 'eputDocLn' puts a 'Doc', followed by a newline to stderr using+-- 'fancyPrinters'. Like putDocLn, it encodes with the user's locale.+-- This function is the recommended way to output messages that should+-- be visible to users on the console, but cannot (or should not) be+-- silenced even when --quiet is in effect.+ePutDocLn :: Doc -> IO ()+ePutDocLn = hPutDocLnWith fancyPrinters stderr++traceDoc :: Doc -> a -> a+traceDoc = trace . unsafeRenderStringColored++unsafeRenderStringColored :: Doc -> String+unsafeRenderStringColored = renderStringWith (unsafePerformIO (fancyPrinters stderr))+++-- | The 'Policy' type is a record containing the variables which control+-- how 'Doc's will be rendered on some output.+data Policy = Policy { poColor :: Bool    -- ^ overall use of color+                     , poEscape :: Bool   -- ^ overall use of escaping+                     , poLineColor :: Bool -- ^ overall use of colored lines (only hunks for now)+                     , poAltColor :: Bool -- ^ alternative to color (bold, inverse)+                     , poIsprint :: Bool  -- ^ don't escape isprints+                     , po8bit  :: Bool    -- ^ don't escape 8-bit chars+                     , poNoEscX :: String   -- ^ extra chars to never escape+                     , poEscX :: String   -- ^ extra chars to always escape+                     , poTrailing :: Bool -- ^ escape trailing spaces+                     , poCR :: Bool       -- ^ ignore \r at end of lines+                     , poSpace :: Bool    -- ^ escape spaces (used with poTrailing)+                     }++-- | 'getPolicy' returns a suitable policy for a given handle.+-- The policy is chosen according to environment variables, and to the+-- type of terminal which the handle represents+getPolicy :: Handle -> IO Policy+getPolicy handle =+ do isTerminal <- hIsTerminalDevice handle+    nColors <- if isTerminal then getTermNColors else return 0++    envDontEscapeAnything  <- getEnvBool "DARCS_DONT_ESCAPE_ANYTHING"+    envDontEscapeIsprint   <- getEnvBool "DARCS_DONT_ESCAPE_ISPRINT"+    envUseIsprint          <- getEnvBool "DARCS_USE_ISPRINT"+    envEscape8bit      <- getEnvBool "DARCS_ESCAPE_8BIT"++    envDontEscapeExtra  <- getEnvString "DARCS_DONT_ESCAPE_EXTRA"+    envEscapeExtra      <- getEnvString "DARCS_ESCAPE_EXTRA"++    envDontEscapeTrailingSpace  <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_SPACES"+    envDontEscapeTrailingCR     <- getEnvBool "DARCS_DONT_ESCAPE_TRAILING_CR"++    envDontColor         <- getEnvBool "DARCS_DONT_COLOR"+    envAlwaysColor       <- getEnvBool "DARCS_ALWAYS_COLOR"+    envAlternativeColor  <- getEnvBool "DARCS_ALTERNATIVE_COLOR"++    let haveColor = envAlwaysColor || (isTerminal && (nColors > 4))+        doColor   = not envDontColor && haveColor++    return Policy { poColor    = doColor,+                    poEscape   = not envDontEscapeAnything,+                    poLineColor= doColor && not envAlternativeColor,+                    poIsprint  = envDontEscapeIsprint || envUseIsprint,+                    po8bit     = not envEscape8bit,+                    poNoEscX   = envDontEscapeExtra,+                    poEscX     = envEscapeExtra,+                    poTrailing = not envDontEscapeTrailingSpace,+                    poCR       = envDontEscapeTrailingCR,+                    poAltColor = haveColor && envAlternativeColor,++                    poSpace = False+                  }+ where+  getEnvBool s = maybe False (/= "0") <$> lookupEnv s+  getEnvString s = maybe "" id <$> lookupEnv s+++{-+  - This function returns number of colors supported by current terminal+  - or -1 if color output not supported or error occured.+  - Terminal type determined by TERM env. variable.+  -}+getTermNColors :: IO Int+#ifdef HAVE_TERMINFO+getTermNColors = do+  t <- setupTermFromEnv+  return . fromMaybe (-1) . getCapability t . tiGetNum $ "colors"+#else+getTermNColors = return (-1)+#endif++++-- printers++-- | @'fancyPrinters' h@ returns a set of printers suitable for outputting+-- to @h@+fancyPrinters :: Printers+fancyPrinters h = do+  policy <- getPolicy h+  return Printers {+    colorP = colorPrinter policy,+    invisibleP = invisiblePrinter,+    hiddenP = colorPrinter policy Green,+    userchunkP = userchunkPrinter policy,+    defP       = escapePrinter policy,+    lineColorT = lineColorTrans policy,+    lineColorS = lineColorSuffix policy+  }++-- | @'lineColorTrans' policy@ tries to color a Doc, according to policy po.+-- That is, if @policy@ has @poLineColor@ set, then colors the line, otherwise+-- does nothing.+lineColorTrans :: Policy -> Color -> Doc -> Doc+lineColorTrans po | poLineColor po = \c d -> prefix (setColor c) d <?> unsafeBothText resetColor+                  | otherwise      = const id++lineColorSuffix :: Policy -> [Printable] -> [Printable]+lineColorSuffix po | poLineColor po = \d -> S resetColor : d+                   | otherwise      = id++colorPrinter :: Policy -> Color -> Printer+colorPrinter po | poColor po = \c -> unDoc . color po c . Doc . escapePrinter po{poColor=False}+                | otherwise  = const $ escapePrinter po++userchunkPrinter :: Policy -> Printer+userchunkPrinter po p+ | not (poEscape po)   = simplePrinter p+ | not (poTrailing po) = escapePrinter po p+ | otherwise           = unDoc $ pr p+ where+  pr (S s)       = prString s+  pr (Both _ ps) = prPS ps+  pr (PS ps)     = prPS ps++  prPS ps = let (leadPS, trailPS) = BC.spanEnd isSpace ps+            in if B.null trailPS+                then Doc $ escapePrinter po p+                else Doc (escapePrinter po (PS leadPS))+                  <> Doc (escapePrinter po{poSpace=True} (PS trailPS))+                  <> markEscape po dollar++  prString s = let (trail',lead') = span isSpace (reverse s)+                   lead = reverse lead'+                   trail = reverse trail'+               in if (not.null) trail+                   then Doc (escapePrinter po (S lead))+                     <> Doc (escapePrinter po{poSpace=True} (S trail))+                     <> markEscape po dollar+                   else Doc (escapePrinter po p)++escapePrinter :: Policy -> Printer+escapePrinter po+ | (not.poEscape) po = simplePrinter+ | otherwise         = unDoc . crepr+ where+  crepr p | poCR po && isEndCR p = epr (initPR p) <> cr+          | otherwise            = epr p++  epr (S s)      = escape po s+  epr (PS ps)    = if BC.any (not.noEscape po) ps+                   then escape po (BC.unpack ps)+                   else unsafePackedString ps+  epr (Both s _) = escape po s++  isEndCR (S s)        = not (null s) && last s == '\r'+  isEndCR (PS ps)      = not (B.null ps) && BC.last ps == '\r'+  isEndCR (Both _ ps)  = not (B.null ps) && BC.last ps == '\r'++  initPR (S s)       = S $ init s+  initPR (PS ps)     = PS $ B.init ps+  initPR (Both s ps) = Both (init s) (B.init ps)+++-- | @'escape' policy string@ escapes @string@ according to the rules+-- defined in 'policy', turning it into a 'Doc'.+escape :: Policy -> String -> Doc+escape _ "" = unsafeText ""+escape po s = hcat $ escape' s+ where+   escape' "" = []+   escape' s'@(c:_) | mundane c =+     let (printables, rest) = span mundane s' in+     unsafeText printables:escape' rest+   escape' (c:rest) = (emph . unsafeText $ quoteChar c):escape' rest+   mundane c = noEscape po c || c == ' '+   emph = markEscape po+++-- | @'noEscape' policy c@ tells wether @c@ will be left as-is+-- when escaping according to @policy@+noEscape :: Policy -> Char -> Bool+noEscape po c | poSpace po && isSpace c = False+noEscape po c | c `elem` poEscX po = False+noEscape po c | c `elem` poNoEscX po = True+noEscape _ '\t' = True  -- tabs will likely be converted to spaces+noEscape _ '\n' = True+noEscape po c = if poIsprint po then isPrint c+                                   else isPrintableAscii c+                 ||  c >= '\x80' && po8bit po++-- | 'isPrintableAscii' tells wether a character is a printable character+-- of the ascii range.+isPrintableAscii :: Char -> Bool+isPrintableAscii c = isAscii c && isPrint c+++-- | 'quoteChar' represents a special character as a string.+--   * @quoteChar '^c'@ (where @^c@ is a control character) is @"^c"@+--   * Otherwise, @quoteChar@ returns "\hex", where 'hex' is the+--     hexadecimal number of the character.+quoteChar :: Char -> String+quoteChar c+ | isControl c && isPrintableAscii cHat = ['^', cHat]+ | otherwise = sHex+ where+  cHat = chr $ (bit 6 `xor`) $ ord c+  sHex = "<U+" ++ printf "%04X" c ++ ">"+++-- make colors and highlightings++-- | @'markEscape' policy doc@ marks @doc@ with the appropriate+-- marking for escaped characters according to @policy@+markEscape :: Policy -> Doc -> Doc+markEscape po  | poAltColor po  = makeInvert+               | poColor po     = makeColor Red+               | otherwise      = makeAsciiart++-- | @'color' policy color doc@ colors @doc@ with color @color@ if+-- @policy@ is not set to use an alternative to color. In that case,+-- it makes the text bold instead.+color :: Policy -> Color -> Doc -> Doc+color po | poAltColor po = \_ -> makeBold+         | otherwise     = makeColor++makeColor, makeColor' :: Color -> Doc -> Doc++makeColor' = withColor . setColor++-- memoized version of makeColor'+makeColor Blue    = makeColor' Blue+makeColor Red     = makeColor' Red+makeColor Green   = makeColor' Green+makeColor Cyan    = makeColor' Cyan+makeColor Magenta = makeColor' Magenta++setColor :: Color -> String+setColor Blue    = "\x1B[01;34m" -- bold blue+setColor Red     = "\x1B[01;31m" -- bold red+setColor Green   = "\x1B[01;32m" -- bold green+setColor Cyan    = "\x1B[36m"    -- light cyan+setColor Magenta = "\x1B[35m"    -- light magenta++-- | @'makeAsciiart' doc@ tries to make @doc@ (usually a+-- single escaped char) stand out with the help of only plain+-- ascii, i.e., no color or font style.+makeAsciiart :: Doc -> Doc+makeAsciiart x = unsafeBothText "[_" <> x <> unsafeBothText "_]"++-- | the string to reset the terminal's color.+resetColor :: String+resetColor = "\x1B[00m"++-- | @'withColor' color doc@ returns a colorized version of @doc@.+-- @color@ is a string that represents a color, given by 'setColor'+withColor :: String -> Doc -> Doc+withColor c =+   let c' = unsafeBothText c+       r' = unsafeBothText resetColor+   in \x -> c' <> x <> r'+++-- | 'makeBold' boldens a doc.+makeBold :: Doc -> Doc+-- | 'makeInvert' returns an invert video version of a doc.+makeInvert :: Doc -> Doc+makeBold   = withColor "\x1B[01m"+makeInvert = withColor "\x1B[07m"++environmentHelpColor :: ([String], [String])+environmentHelpColor = (["DARCS_DONT_COLOR", "DARCS_ALWAYS_COLOR",+                         "DARCS_ALTERNATIVE_COLOR"],[+  "If the terminal understands ANSI color escape sequences, darcs will",+  "highlight certain keywords and delimiters when printing patches, and",+  "also print hunk lines in color according to whether they are removed",+  "or added. This can be turned off by setting the environment variable",+  "DARCS_DONT_COLOR to 1.",+  "If you use a pager that happens to understand ANSI colors, like",+  "`less -R`, darcs can be forced always to highlight the output by setting",+  "DARCS_ALWAYS_COLOR to 1. If you can't see colors you can set",+  "DARCS_ALTERNATIVE_COLOR to 1, and darcs will use ANSI codes for bold",+  "and reverse video instead of colors."])++environmentHelpEscapeWhite :: ([String], [String])+environmentHelpEscapeWhite = ([ "DARCS_DONT_ESCAPE_TRAILING_SPACES",+                                "DARCS_DONT_ESCAPE_TRAILING_CR"],[+  "By default darcs will escape (by highlighting if possible) any kind",+  "of spaces at the end of lines when showing patch contents.",+  "If you don't want this you can turn it off by setting",+  "DARCS_DONT_ESCAPE_TRAILING_SPACES to 1. A special case exists",+  "for only carriage returns: DARCS_DONT_ESCAPE_TRAILING_CR"])++environmentHelpEscape :: ([String], [String])+environmentHelpEscape = (["DARCS_DONT_ESCAPE_ANYTHING",+                          "DARCS_DONT_ESCAPE_EXTRA",+                          "DARCS_ESCAPE_EXTRA",+                          "DARCS_DONT_ESCAPE_ISPRINT",+                          "DARCS_ESCAPE_8BIT"],[+  "Darcs needs to escape certain characters when printing patch contents to",+  "a terminal, depending on the encoding specified in your locale setting.",+  "",+  "By default, darcs assumes that your locale encoding is ASCII compatible.",+  "This includes UTF-8 and some 8-bit encodings like ISO/IEC-8859 (including",+  "its variants). Since ASCII contains control characters like backspace",+  "(which could hide patch content from the user when printed literally to",+  "the terminal), and even ones that may introduce security risks such as",+  "redirecting commands to the shell, darcs needs to escape such characters.",+  "They are printed as `^<control letter>` or `\\<hex code>`. Darcs also uses",+  "special markup for line endings that are preceeded by white space, since",+  "the white space would otherwise not be recognizable.",+  "",+  "If you use an encoding that is not ASCII compatible, things are somewhat",+  "less smooth. Such encodings include UTF-16 and UTF-32, as well as many of",+  "the encodings that became obsolete with unicode. In this case you have two",+  "options: you can set DARCS_DONT_ESCAPE_ANYTHING to 1. Then everything that",+  "doesn't flip code sets should work, and so will all the bells and whistles",+  "in your terminal. This environment variable can also be handy if you pipe",+  "the output to a pager or external filter that knows better than darcs how to",+  "handle your encoding. Note that all escaping, including the special escaping",+  "of any line ending spaces, will be turned off by this setting.",+  "",+  "Another possibility is to explicitly tell darcs to not escape or escape",+  "certain bytes, using DARCS_DONT_ESCAPE_EXTRA and DARCS_ESCAPE_EXTRA. Their",+  "values should be strings consisting of the verbatim bytes in question. The",+  "do-escapes take precedence over the dont-escapes. Space characters are still",+  "escaped at line endings though. The special environment variable",+  "DARCS_DONT_ESCAPE_TRAILING_CR turns off escaping of carriage return last on",+  "the line (DOS style).",+  "",+  "For historical reasons, darcs also supports DARCS_DONT_ESCAPE_ISPRINT and",+  "DARCS_USE_ISPRINT (which are synonyms). These make sense only for 8-bit",+  "encodings like ISO-8859 and are no longer needed since nowadays darcs does",+  "the right thing here by default.",+  "",+  "Finally, if you are in a highly security sensitive situation (or just",+  "paranoid for other reasons), you can set DARCS_ESCAPE_8BIT to 1. This will",+  "cause darcs to escape every non-ASCII byte in addition to ASCII control",+  "characters."])
+ src/Darcs/Util/Progress.hs view
@@ -0,0 +1,266 @@+-- |+-- Module      : Darcs.Util.Progress+-- Copyright   : 2008 David Roundy+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable+--+-- Utility functions for tracking progress of long-running actions.++module Darcs.Util.Progress+    (+      beginTedious+    , endTedious+    , tediousSize+    , withProgress+    , withSizedProgress+    , debugMessage+    , withoutProgress+    , progress+    , progressKeepLatest+    , finishedOne+    , finishedOneIO+    , progressList+    , minlist+    , setProgressMode+    ) where+++import Darcs.Prelude++import Control.Arrow ( second )+import Control.Exception ( bracket )+import Control.Monad ( when, void )+import Control.Concurrent ( forkIO, threadDelay )++import Data.Char ( toLower )+import Data.Map ( Map, empty, adjust, insert, delete, lookup )+import Data.Maybe ( isJust )+import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )++import qualified System.Console.Terminal.Size as TS ( size, width )+import System.IO ( hFlush, stdout )+import System.IO.Unsafe ( unsafePerformIO )++import Darcs.Util.Global ( debugMessage )+++data ProgressData = ProgressData+    { sofar   :: !Int+    , latest  :: !(Maybe String)+    , total   :: !(Maybe Int)+    }++progressRate :: Int+progressRate = 1000000++handleProgress :: IO ()+handleProgress = do+    threadDelay progressRate+    handleMoreProgress "" 0+++handleMoreProgress :: String -> Int -> IO ()+handleMoreProgress k n = withProgressMode $ \m ->+    if m then do s <- getProgressLast+                 mp <- getProgressData s+                 case mp of+                   Nothing -> do+                      threadDelay progressRate+                      handleMoreProgress k n+                   Just p -> do+                      when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p+                      threadDelay progressRate+                      handleMoreProgress s (sofar p)+         else do threadDelay progressRate+                 handleMoreProgress k n+++printProgress :: String+              -> ProgressData+              -> IO ()+printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) =+    putCr (k ++ " ... " ++ show s ++ " done, " ++ show (t - s) ++ " queued. " ++ l)+printProgress k (ProgressData {latest=Just l}) =+    putCr (k ++ " ... " ++ l)+printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s =+    putCr (k ++ " ... " ++ show s ++ " done, " ++ show (t - s) ++ " queued")+printProgress k (ProgressData {sofar=s}) =+    putCr (k ++ " ... " ++ show s)++putCr :: String -> IO ()+putCr = unsafePerformIO mkPutCr+{-# NOINLINE putCr #-}++withProgress :: String -> (String -> IO a) -> IO a+withProgress k = bracket (beginTedious k >> return k) endTedious++withSizedProgress :: String -> Int -> (String -> IO a) -> IO a+withSizedProgress k n =+  bracket (beginTedious k >> tediousSize k n >> return k) endTedious++-- | @beginTedious k@ starts a tedious process and registers it in+-- '_progressData' with the key @k@. A tedious process is one for which we want+-- a progress indicator.+--+-- Wouldn't it be safer if it had type String -> IO ProgressDataKey, so that we+-- can ensure there is no collision? What happens if you call beginTedious twice+-- with the same string, without calling endTedious in the meantime?+beginTedious :: String -> IO ()+beginTedious k = do+    debugMessage $ "Beginning " ++ map toLower k+    setProgressData k ProgressData+                        { sofar = 0+                        , latest = Nothing+                        , total = Nothing+                        }+++-- | @endTedious k@ unregisters the tedious process with key @k@, printing+-- "Done" if such a tedious process exists.+endTedious :: String -> IO ()+endTedious k = whenProgressMode $ do+    p <- getProgressData k+    modifyIORef _progressData (second $ delete k)+    when (isJust p) $ putCr $ k ++ " ... done"+++tediousSize :: String+            -> Int+            -> IO ()+tediousSize k s = updateProgressData k uptot+  where+    uptot p = case total p of+                  Just t -> seq ts $ p { total = Just ts }+                    where ts = t + s+                  Nothing -> p { total = Just s }+++-- | XXX: document this constant+minlist :: Int+minlist = 4+++progressList :: String+             -> [a]+             -> [a]+progressList _ [] = []+progressList k (x:xs) = if l < minlist+                          then x:xs+                          else startit x : pl xs+  where+    l = length (x:xs)++    startit y = unsafePerformIO $ do+        beginTedious k+        tediousSize k l+        return y++    pl [] = []+    pl [y] = unsafePerformIO $ do+        endTedious k+        return [y]+    pl (y:ys) = progress k y : pl ys+++progress :: String+         -> a+         -> a+progress k a = unsafePerformIO $ progressIO k >> return a+++progressIO :: String -> IO ()+progressIO "" = return ()+progressIO k = do+    updateProgressData k $ \p ->+        p { sofar = sofar p + 1, latest = Nothing }++progressKeepLatest :: String+                   -> a+                   -> a+progressKeepLatest k a = unsafePerformIO $ progressKeepLatestIO k >> return a+++progressKeepLatestIO :: String -> IO ()+progressKeepLatestIO "" = return ()+progressKeepLatestIO k = do+    updateProgressData k (\p -> p {sofar = sofar p + 1})++finishedOne :: String -> String -> a -> a+finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a+++finishedOneIO :: String -> String -> IO ()+finishedOneIO "" _ = return ()+finishedOneIO k l = do+    updateProgressData k (\p -> p { sofar = sofar p + 1,+                                    latest = Just l })+++_progressMode :: IORef Bool+_progressMode = unsafePerformIO $ newIORef True+{-# NOINLINE _progressMode #-}++_progressData :: IORef (String, Map String ProgressData)+_progressData = unsafePerformIO $ do+    _ <- forkIO handleProgress+    newIORef ("", empty)+{-# NOINLINE _progressData #-}++mkPutCr :: IO (String -> IO ())+mkPutCr =+  TS.size >>= \case+    Nothing ->+      -- stdout is not a terminal+      return $ \_ -> return ()+    Just window -> do+      let limitToWidth = take (TS.width window - 1)+      return $ \s -> do+        putStr $ '\r':limitToWidth s ++ "\r"+        hFlush stdout+        putStr $ '\r':limitToWidth ((replicate (length s)) ' ') ++ "\r"++setProgressMode :: Bool -> IO ()+setProgressMode = writeIORef _progressMode++withoutProgress :: IO a -> IO a+withoutProgress job = bracket off restore (const job) where+  off = withProgressMode $ \m -> do+    debugMessage "Disabling progress reports..."+    setProgressMode False+    return m+  restore m = do+    if m then debugMessage "Reenabling progress reports."+    else debugMessage "Leaving progress reports off."+    setProgressMode m++updateProgressData :: String+                   -> (ProgressData -> ProgressData)+                   -> IO ()+updateProgressData k f =+    whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m))++setProgressData :: String+                -> ProgressData+                -> IO ()+setProgressData k p =+    whenProgressMode $ modifyIORef _progressData (second $ insert k p)++getProgressData :: String -> IO (Maybe ProgressData)+getProgressData k = withProgressMode $ \p ->+    if p+      then (lookup k . snd) `fmap` readIORef _progressData+      else return Nothing++getProgressLast :: IO String+getProgressLast = withProgressMode $ \p ->+    if p+      then fst `fmap` readIORef _progressData+      else return ""++whenProgressMode :: IO a -> IO ()+whenProgressMode j = withProgressMode $ const $ void j++withProgressMode :: (Bool -> IO a) -> IO a+withProgressMode job = (readIORef _progressMode) >>= job
+ src/Darcs/Util/Prompt.hs view
@@ -0,0 +1,103 @@+module Darcs.Util.Prompt+    (+    -- * User prompts+      askEnter+    , askUser+    , askUserListItem+    , PromptConfig(..)+    , promptYorn+    , promptChar+    ) where+++import Darcs.Prelude++import Control.Monad ( void )+import Control.Monad.Trans ( liftIO )++import Data.Char ( toUpper, toLower, isSpace )++import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,+                                  getInputChar, outputStr, outputStrLn )++import Darcs.Util.Progress ( withoutProgress )++-- | Ask the user for a line of input.+askUser :: String    -- ^ The prompt to display+        -> IO String -- ^ The string the user entered.+askUser prompt = withoutProgress $ runInputT defaultSettings $+                    getInputLine prompt+                        >>= maybe (liftIO $ fail "askUser: unexpected end of input") return++-- | Ask the user to press Enter+askEnter :: String  -- ^ The prompt to display+         -> IO ()+askEnter prompt = void $ askUser prompt++-- | @askUserListItem prompt xs@ enumerates @xs@ on the screen, allowing+--   the user to choose one of the items+askUserListItem :: String+                -> [String]+                -> IO String+askUserListItem prompt xs = withoutProgress $ runInputT defaultSettings $ do+    outputStr . unlines $ zipWith (\n x -> show n ++ ". " ++ x) [1::Int ..] xs+    loop+  where+    loop = do+      answer <- getInputLine prompt+                  >>= maybe (liftIO $ fail "askUser: unexpected end of input") return+      case maybeRead answer of+        Just n | n > 0 && n <= length xs -> return (xs !! (n-1))+        _ -> outputStrLn "Invalid response, try again!" >> loop+++maybeRead :: Read a+          => String+          -> Maybe a+maybeRead s = case reads s of+    [(x, rest)] | all isSpace rest -> Just x+    _         -> Nothing+++data PromptConfig = PromptConfig { pPrompt :: String+                                 , pBasicCharacters :: [Char]+                                 , pAdvancedCharacters :: [Char] -- ^ only shown on help+                                 , pDefault :: Maybe Char+                                 , pHelp    :: [Char]+                                 }+++-- | Prompt the user for a yes or no+promptYorn :: String -> IO Bool+promptYorn p = (== 'y') `fmap` promptChar (PromptConfig p "yn" [] Nothing [])+++-- | Prompt the user for a character, among a list of possible ones.+--   Always returns a lowercase character. This is because the default+--   character (ie, the character shown in uppercase, that is automatically+--   selected when the user presses the space bar) is shown as uppercase,+--   hence users may want to enter it as uppercase.+promptChar :: PromptConfig -> IO Char+promptChar (PromptConfig p basic_chs adv_chs def_ch help_chs) =+  withoutProgress $ runInputT defaultSettings loopChar+ where+ chs = basic_chs ++ adv_chs+ loopChar = do+    let chars = setDefault (basic_chs ++ (if null adv_chs then "" else "..."))+        prompt = p ++ " [" ++ chars ++ "]" ++ helpStr+    a <- getInputChar prompt >>= maybe (liftIO $ fail "promptChar: unexpected end of input") (return . toLower)+    case () of+     _ | a `elem` chs                   -> return a+       | a == ' '                       -> maybe tryAgain return def_ch+       | a `elem` help_chs              -> return a+       | otherwise                      -> tryAgain+ helpStr = case help_chs of+           []                      -> ""+           (h:_) | null adv_chs    -> ", or " ++ (h:" for help: ")+                 | otherwise       -> ", or " ++ (h:" for more options: ")+ tryAgain = do outputStrLn "Invalid response, try again!"+               loopChar+ setDefault s = case def_ch of Nothing -> s+                               Just d  -> map (setUpper d) s+ setUpper d c = if d == c then toUpper c else c+
+ src/Darcs/Util/Ratified.hs view
@@ -0,0 +1,8 @@+-- | XXX: Perhaps a word of explanation here [WL]+module Darcs.Util.Ratified+    (+      readFile+    , hGetContents+    ) where++import System.IO ( hGetContents, readFile )
+ src/Darcs/Util/Regex.hs view
@@ -0,0 +1,85 @@+-- | This module is a subset of the defunct regex-compat-tdfa.+{-# LANGUAGE CPP #-}+module Darcs.Util.Regex+    ( Regex+    , mkRegex+    , mkRegexWithOpts+    , matchRegex+    ) where++import Darcs.Prelude++import Control.Exception ( throw )+#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif+import Text.Regex.Base+    ( RegexContext(matchM)+    , RegexMaker(makeRegexOptsM)+    , defaultCompOpt+    , defaultExecOpt+    )+import Text.Regex.TDFA ( Regex, caseSensitive, multiline, newSyntax )++-- | The "sane" API for regex ('makeRegexOptM') requires 'MonadFail'+-- but we want a pure one for compatibility with e.g. "Darcs.Patch.Match".+newtype RegexFail a = RegexFail { runRegexFail :: Either String a }+  -- The subtlety here is that only in base-4.13.0 the fail method+  -- in class Monad was removed. For earlier versions, regex-tdfa+  -- calls the fail from class Monad, not the one from class MonadFail.+#if MIN_VERSION_base(4,13,0)+  deriving (Functor, Applicative, Monad)+#else+  deriving (Functor, Applicative)++instance Monad RegexFail where+  RegexFail (Left e) >>= _ = RegexFail (Left e)+  RegexFail (Right r) >>= k = k r+  fail = RegexFail . Left+#endif++instance MonadFail RegexFail where+  fail = RegexFail . Left++-- | Makes a regular expression with the default options (multi-line,+-- case-sensitive).  The syntax of regular expressions is+-- otherwise that of @egrep@ (i.e. POSIX \"extended\" regular+-- expressions).+mkRegex :: String -> Regex+mkRegex s = mkRegexInternal opt s+  where+    opt = defaultCompOpt {newSyntax = True, multiline = True}++-- | Makes a regular expression, where the multi-line and+-- case-sensitive options can be changed from the default settings.+mkRegexWithOpts+   :: String  -- ^ The regular expression to compile+   -> Bool    -- ^ 'True' @\<=>@ @\'^\'@ and @\'$\'@ match the beginning and +              -- end of individual lines respectively, and @\'.\'@ does /not/+              -- match the newline character.+   -> Bool    -- ^ 'True' @\<=>@ matching is case-sensitive+   -> Regex   -- ^ Returns: the compiled regular expression+mkRegexWithOpts s single_line case_sensitive+  = let opt = defaultCompOpt+                { multiline    = (if single_line then True else False)+                , caseSensitive = (if case_sensitive then True else False)+                , newSyntax     = True }+    in mkRegexInternal opt s++mkRegexInternal :: RegexMaker p compOpt execOpt String => compOpt -> String -> p+mkRegexInternal opt s =+  case runRegexFail (makeRegexOptsM opt defaultExecOpt s) of+    Left e -> throw (userError ("Invalid regular expression:\n" ++ e))+    Right r -> r++-- | Match a regular expression against a string+matchRegex ::+     Regex -- ^ The regular expression+  -> String -- ^ The string to match against+  -> Maybe [String] -- ^ Returns: @'Just' strs@ if the match succeeded+                      -- (and @strs@ is the list of subexpression matches),+                      -- or 'Nothing' otherwise.+matchRegex p str = fmap go (matchM p str)+  where+    go :: (String, String, String, [String]) -> [String]+    go (_, _, _, ss) = ss
+ src/Darcs/Util/Show.hs view
@@ -0,0 +1,6 @@+module Darcs.Util.Show ( appPrec ) where++import Darcs.Prelude++appPrec :: Int+appPrec = 10
+ src/Darcs/Util/SignalHandler.hs view
@@ -0,0 +1,142 @@+-- Copyright (C) 2003 David Roundy+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++{-# LANGUAGE CPP #-}++module Darcs.Util.SignalHandler+    ( withSignalsHandled, withSignalsBlocked,+      catchInterrupt, catchNonSignal,+      tryNonSignal, stdoutIsAPipe+    ) where++import Darcs.Prelude++import System.IO.Error ( isUserError, ioeGetErrorString, ioeGetFileName )+import System.Exit ( exitWith, ExitCode ( ExitFailure ) )+import Control.Concurrent ( ThreadId, myThreadId )+import Control.Exception+            ( catch, throwIO, throwTo, mask,+              Exception(..), SomeException(..), IOException )+import System.Posix.Files ( getFdStatus, isNamedPipe )+import System.Posix.IO ( stdOutput )+import Data.Typeable ( Typeable, cast )+import Data.List ( isPrefixOf )+import System.IO ( hPutStrLn, stderr )+import Control.Monad ( unless )++import Darcs.Util.Workaround+    ( installHandler, raiseSignal, Handler(..), Signal+    , sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE )+#ifdef WIN32+import Darcs.Util.CtrlC ( withCtrlCHandler )+#endif++stdoutIsAPipe :: IO Bool+stdoutIsAPipe+ = catch+        (do stat <- getFdStatus stdOutput+            return (isNamedPipe stat))+        (\(_ :: IOException) -> return False)++newtype SignalException = SignalException Signal deriving (Show, Typeable)++instance Exception SignalException where+   toException = SomeException+   fromException (SomeException e) = cast e++withSignalsHandled :: IO a -> IO a+withSignalsHandled job = do+    thid <- myThreadId+    mapM_ (ih thid) [sigINT, sigHUP, sigABRT, sigTERM, sigPIPE]+    catchUserErrors (job' thid `catchSignal` defaults)+                    die_with_string+    where defaults s | s == sigINT = ew s "Interrupted!"+                     | s == sigHUP = ew s "HUP"+                     | s == sigABRT = ew s "ABRT"+                     | s == sigTERM = ew s "TERM"+                     | s == sigPIPE = exitWith $ ExitFailure 1+                     | otherwise = ew s "Unhandled signal!"+          ew sig s = do hPutStrLn stderr s+                        resethandler sig+                        raiseSignal sig -- ensure that our caller knows how we died+                        exitWith $ ExitFailure 1+          die_with_string e | "STDOUT" `isPrefixOf` e =+                do is_pipe <- stdoutIsAPipe+                   unless is_pipe $+                        hPutStrLn stderr $ drop 6 e+                   exitWith $ ExitFailure 2+          die_with_string e = do hPutStrLn stderr e+                                 exitWith $ ExitFailure 2+#ifdef WIN32+          job' thid =+             withCtrlCHandler (throwTo thid $ SignalException sigINT) job+#else+          job' _ = job+#endif++resethandler :: Signal -> IO ()+resethandler s = do _ <- installHandler s Default Nothing+                    return ()++ih :: ThreadId -> Signal -> IO ()+ih thid s =+  do _ <- installHandler s (Catch $ throwTo thid $ SignalException s) Nothing+     return ()++catchSignal :: IO a -> (Signal -> IO a) -> IO a+catchSignal job handler =+    job `catch` (\(SignalException sig) -> handler sig)++-- | A drop-in replacement for 'Control.Exception.catch', which allows+-- us to catch anything but a signal.  Useful for situations where we+-- don't want to inhibit ctrl-C.+catchNonSignal :: IO a -> (SomeException -> IO a) -> IO a+catchNonSignal comp handler = catch comp handler'+    where handler' se =+           case fromException se :: Maybe SignalException of+             Nothing -> handler se+             Just _ -> throwIO se++catchInterrupt :: IO a -> IO a -> IO a+catchInterrupt job handler =+    job `catchSignal` h+        where h s | s == sigINT = handler+                  | otherwise   = throwIO (SignalException s)++tryNonSignal :: IO a -> IO (Either SomeException a)+tryNonSignal j = (Right `fmap` j) `catchNonSignal` \e -> return (Left e)++catchUserErrors :: IO a -> (String -> IO a) -> IO a+catchUserErrors comp handler = catch comp handler'+  where handler' ioe+         | isUserError ioe                       = handler (ioeGetErrorString ioe)+         | ioeGetFileName ioe == Just "<stdout>" = handler ("STDOUT" ++ ioeGetErrorString ioe)+         | otherwise                             = throwIO ioe++withSignalsBlocked :: IO a -> IO a+withSignalsBlocked job = mask (\unmask -> job >>= \r ->+                           unmask (return r) `catchSignal` couldnt_do r)+    where couldnt_do r s | s == sigINT = oops "interrupt" r+                         | s ==  sigHUP = oops "HUP" r+                         | s ==  sigABRT = oops "ABRT" r+                         | s ==  sigALRM = oops "ALRM" r+                         | s ==  sigTERM = oops "TERM" r+                         | s ==  sigPIPE = return r+                         | otherwise = oops "unknown signal" r+          oops s r = do hPutStrLn stderr $ "Couldn't handle " ++ s +++                          " since darcs was in a sensitive job."+                        return r
+ src/Darcs/Util/Ssh.hs view
@@ -0,0 +1,357 @@+--+--+-- This program is free software; you can redistribute it and/or modify+-- it under the terms of the GNU General Public License as published by+-- the Free Software Foundation; either version 2, or (at your option)+-- any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+-- GNU General Public License for more details.+--+-- You should have received a copy of the GNU General Public License+-- along with this program; see the file COPYING.  If not, write to+-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+-- Boston, MA 02110-1301, USA.++module Darcs.Util.Ssh+    (+      SshSettings(..)+    , defaultSsh+    , windows+    , copySSH+    , SSHCmd(..)+    , getSSH+    , environmentHelpSsh+    , environmentHelpScp+    , environmentHelpSshPort+    , transferModeHeader+    , resetSshConnections+    ) where++import Darcs.Prelude++import System.Environment ( getEnv )+import System.Exit ( ExitCode(..) )++import Control.Concurrent.MVar ( MVar, newMVar, withMVar, modifyMVar, modifyMVar_ )+import Control.Exception ( throwIO, catch, catchJust, SomeException )+import Control.Monad ( forM_, unless, void, (>=>) )++import qualified Data.ByteString as B (ByteString, hGet, writeFile )++import Data.Map ( Map, empty, insert, lookup )++import System.IO ( Handle, hSetBinaryMode, hPutStrLn, hGetLine, hFlush )+import System.IO.Unsafe ( unsafePerformIO )+import System.Process+    ( ProcessHandle+    , readProcessWithExitCode+    , runInteractiveProcess+    , terminateProcess+    , waitForProcess+    )++import Darcs.Util.SignalHandler ( catchNonSignal )+import Darcs.Util.URL ( SshFilePath, sshFilePathOf, sshUhost, sshRepo, sshFile )+import Darcs.Util.Exception ( prettyException, catchall )+import Darcs.Util.Exec ( readInteractiveProcess, ExecException(..), Redirect(AsIs) )+import Darcs.Util.Progress ( withoutProgress, debugMessage )++import qualified Darcs.Util.Ratified as Ratified ( hGetContents )++import Data.IORef ( IORef, newIORef, readIORef )+import Data.List ( isPrefixOf )+import System.Info ( os )+import System.IO.Error ( ioeGetErrorType, isDoesNotExistErrorType )++import Darcs.Util.Global ( whenDebugMode )++windows :: Bool+windows = "mingw" `isPrefixOf` os++data SshSettings = SshSettings+    { ssh :: String+    , scp :: String+    , sftp :: String+    } deriving (Show, Eq)+++_defaultSsh :: IORef SshSettings+_defaultSsh = unsafePerformIO $ newIORef =<< detectSsh+{-# NOINLINE _defaultSsh #-}++-- | Expected properties:+--+-- * only ever runs once in the lifetime of the program+-- * environment variables override all+-- * tries Putty first on Windows+-- * falls back to plain old ssh+detectSsh :: IO SshSettings+detectSsh = do+    whenDebugMode (putStrLn "Detecting SSH settings")+    vanilla <-  if windows+                  then do+                    plinkStr <- (snd3 <$> readProcessWithExitCode "plink" [] "")+                                  `catch` \(e :: SomeException) -> return (show e)+                    whenDebugMode $ putStrLn $+                        "SSH settings (plink): " +++                        (concat . take 1 . lines $ plinkStr)+                    if "PuTTY" `isPrefixOf` plinkStr+                      then return (SshSettings "plink" "pscp -q" "psftp")+                      else return rawVanilla+                  else return rawVanilla+    settings <- SshSettings <$> fromEnv (ssh vanilla)  "DARCS_SSH"+                            <*> fromEnv (scp vanilla)  "DARCS_SCP"+                            <*> fromEnv (sftp vanilla) "DARCS_SFTP"+    whenDebugMode (putStrLn $ "SSH settings: " ++ show settings)+    return settings+  where+    snd3 (_, x, _) = x+    rawVanilla = SshSettings "ssh" "scp -q" "sftp"+    fromEnv :: String -> String -> IO String+    fromEnv d v = catchJust notFound+                            (getEnv v)+                            (const (return d))+    notFound e =  if isDoesNotExistErrorType (ioeGetErrorType e)+                  then Just ()+                  else Nothing+++defaultSsh :: SshSettings+defaultSsh = unsafePerformIO $ readIORef _defaultSsh+{-# NOINLINE defaultSsh #-}++-- | A re-usable connection to a remote darcs in transfer-mode.+-- It contains the three standard handles.+data Connection = C+    { inp :: !Handle+    , out :: !Handle+    , err :: !Handle+    , proc :: !ProcessHandle+    }++-- | Identifier (key) for a connection.+type RepoId = (String, String) -- (user@host,repodir)++-- | Global mutable variable that contains open connections,+-- identified by the repoid part of the ssh file name.+-- Only one thread can use a connection at a time, which is why+-- we stuff them behind their own 'MVar's.+--+-- We distinguish between a failed connection (represented by a+-- 'Nothing' entry in the map) and one that was never established+-- (the repoid is not in the map). Once a connection fails,+-- either when trying to establish it or during usage, it will not+-- be tried again.+sshConnections :: MVar (Map RepoId (Maybe (MVar Connection)))+sshConnections = unsafePerformIO $ newMVar empty+{-# NOINLINE sshConnections #-}++-- | Wait for an existing connection to become available or, if none+-- is available, try to create a new one and cache it.+getSshConnection :: String                       -- ^ remote darcs command+                 -> SshFilePath                  -- ^ destination+                 -> IO (Maybe (MVar Connection)) -- ^ wrapper for the action+getSshConnection rdarcs sshfp = modifyMVar sshConnections $ \cmap -> do+  let key = repoid sshfp+  case lookup key cmap of+    Nothing -> do+      -- we have not yet tried with this key, do it now+      mc <- newSshConnection rdarcs sshfp+      case mc of+        Nothing ->+          -- failed, remember it, so we don't try again+          return (insert key Nothing cmap, Nothing)+        Just c -> do+          -- success, remember and use+          v <- newMVar c+          return (insert key (Just v) cmap, Just v)+    Just Nothing ->+      -- we have tried to connect before, don't do it again+      return (cmap, Nothing)+    Just (Just v) ->+      -- we do have a connection, return an action that+      -- waits until it is available+      return (cmap, Just v)++-- | Try to create a new ssh connection to a remote darcs that runs the+-- transfer-mode command. This is tried only once per repoid.+newSshConnection :: String -> SshFilePath -> IO (Maybe Connection)+newSshConnection rdarcs sshfp = do+  (sshcmd,sshargs_) <- getSSH SSH+  debugMessage $ "Starting new ssh connection to " ++ sshUhost sshfp+  let sshargs = sshargs_ ++ ["--", sshUhost sshfp, rdarcs,+                             "transfer-mode", "--repodir", sshRepo sshfp]+  debugMessage $ "Exec: " ++ showCommandLine (sshcmd:sshargs)+  (i,o,e,ph) <- runInteractiveProcess sshcmd sshargs Nothing Nothing+  do+    hSetBinaryMode i True+    hSetBinaryMode o True+    l <- hGetLine o+    unless (l == transferModeHeader) $+      fail "Couldn't start darcs transfer-mode on server"+    return $ Just C { inp = i, out = o, err = e, proc = ph }+    `catchNonSignal` \exn -> do+      debugMessage $ "Failed to start ssh connection: " ++ prettyException exn+      debugMessage $ unlines+                    [ "NOTE: the server may be running a version of darcs prior to 2.0.0."+                    , ""+                    , "Installing darcs 2 on the server will speed up ssh-based commands."+                    ]+      return Nothing++-- | Terminate all child processes that run a remote "darcs transfer-mode" and+-- remove them from the 'sshConnections', causing subsequent 'copySSH' calls to+-- start a fresh child.+resetSshConnections :: IO ()+resetSshConnections =+  modifyMVar_ sshConnections $ \cmap -> do+    forM_ cmap $ \case+      Just mvarc -> do+        withMVar mvarc $ \C{ proc = ph } -> do+          terminateProcess ph+          void $ waitForProcess ph+      Nothing -> return ()+    return empty++-- | Mark any connection associated with the given ssh file path+-- as failed, so it won't be tried again.+dropSshConnection :: RepoId -> IO ()+dropSshConnection key = do+  debugMessage $ "Dropping ssh failed connection to " ++ fst key ++ ":" ++ snd key+  modifyMVar_ sshConnections (return . insert key Nothing)++repoid :: SshFilePath -> RepoId+repoid sshfp = (sshUhost sshfp, sshRepo sshfp)++grabSSH :: SshFilePath -> Connection -> IO B.ByteString+grabSSH src c = do+  debugMessage $ "grabSSH src=" ++ sshFilePathOf src+  let failwith e = do dropSshConnection (repoid src)+                        -- hGetContents is ok here because we're+                        -- only grabbing stderr, and we're also+                        -- about to throw the contents.+                      eee <- Ratified.hGetContents (err c)+                      fail $ e ++ " grabbing ssh file " +++                        sshFilePathOf src ++"\n" ++ eee+      file = sshFile src+  hPutStrLn (inp c) $ "get " ++ file+  hFlush (inp c)+  l2 <- hGetLine (out c)+  if l2 == "got "++file+    then do showlen <- hGetLine (out c)+            case reads showlen of+              [(len,"")] -> B.hGet (out c) len+              _ -> failwith "Couldn't get length"+    else if l2 == "error "++file+         then do e <- hGetLine (out c)+                 case reads e of+                   (msg,_):_ -> fail $ "Error reading file remotely:\n"++msg+                   [] -> failwith "An error occurred"+         else failwith "Error"++copySSH :: String -> SshFilePath -> FilePath -> IO ()+copySSH rdarcs src dest = do+  debugMessage $ "copySSH file: " ++ sshFilePathOf src+  -- TODO why do we disable progress reporting here?+  withoutProgress $ do+    mc <- getSshConnection rdarcs src+    case mc of+      Just v -> withMVar v (grabSSH src >=> B.writeFile dest)+      Nothing -> do+        -- remote 'darcs transfer-mode' does not work => use scp+        let u = escape_dollar $ sshFilePathOf src+        (scpcmd, args) <- getSSH SCP+        let scp_args = filter (/="-q") args ++ ["--", u, dest]+        debugMessage $ "Exec: " ++ showCommandLine (scpcmd:scp_args)+        (r, scp_err) <- readInteractiveProcess scpcmd scp_args+        unless (r == ExitSuccess) $+          throwIO $ ExecException scpcmd scp_args (AsIs,AsIs,AsIs) scp_err+  where+    -- '$' in filenames is troublesome for scp, for some reason.+    escape_dollar :: String -> String+    escape_dollar = concatMap tr+      where+        tr '$' = "\\$"+        tr c = [c]++-- | Show a command and its arguments for debug messages.+showCommandLine :: [String] -> String+showCommandLine = unwords . map show++transferModeHeader :: String+transferModeHeader = "Hello user, I am darcs transfer mode"++-- ---------------------------------------------------------------------+-- older ssh helper functions+-- ---------------------------------------------------------------------++data SSHCmd = SSH+            | SCP+            | SFTP+++fromSshCmd :: SshSettings+           -> SSHCmd+           -> String+fromSshCmd s SSH  = ssh s+fromSshCmd s SCP  = scp s+fromSshCmd s SFTP = sftp s++-- | Return the command and arguments needed to run an ssh command+--   First try the appropriate darcs environment variable and SSH_PORT+--   defaulting to "ssh" and no specified port.+getSSH :: SSHCmd+       -> IO (String, [String])+getSSH cmd = do+    port <- (portFlag cmd `fmap` getEnv "SSH_PORT") `catchall` return []+    let (sshcmd, ssh_args) = breakCommand command+    return (sshcmd, ssh_args ++ port)+  where+    command = fromSshCmd defaultSsh cmd+    portFlag SSH  x = ["-p", x]+    portFlag SCP  x = ["-P", x]+    portFlag SFTP x = ["-oPort=" ++ x]+    breakCommand s =+      case words s of+        (arg0:args) -> (arg0, args)+        [] -> (s, [])++environmentHelpSsh :: ([String], [String])+environmentHelpSsh = (["DARCS_SSH"], [+    "Repositories of the form [user@]host:[dir] are taken to be remote",+    "repositories, which Darcs accesses with the external program ssh(1).",+    "",+    "The environment variable $DARCS_SSH can be used to specify an",+    "alternative SSH client.  Arguments may be included, separated by",+    "whitespace.  The value is not interpreted by a shell, so shell",+    "constructs cannot be used; in particular, it is not possible for the",+    "program name to contain whitespace by using quoting or escaping."])+++environmentHelpScp :: ([String], [String])+environmentHelpScp = (["DARCS_SCP", "DARCS_SFTP"], [+    "When reading from a remote repository, Darcs will attempt to run",+    "`darcs transfer-mode` on the remote host.  This will fail if the",+    "remote host only has Darcs 1 installed, doesn't have Darcs installed",+    "at all, or only allows SFTP.",+    "",+    "If transfer-mode fails, Darcs will fall back on scp(1) and sftp(1).",+    "The commands invoked can be customized with the environment variables",+    "$DARCS_SCP and $DARCS_SFTP respectively, which behave like $DARCS_SSH.",+    "If the remote end allows only sftp, try setting DARCS_SCP=sftp.",+    "",+    "scp is also used by `darcs clone` if the destination is a remote ssh",+    "directory. This operation can be made quite a bit faster by setting",+    "DARCS_SCP=rsync."])++environmentHelpSshPort :: ([String], [String])+environmentHelpSshPort = (["SSH_PORT"], [+    "If this environment variable is set, it will be used as the port",+    "number for all SSH calls made by Darcs (when accessing remote",+    "repositories over SSH).  This is useful if your SSH server does not",+    "run on the default port, and your SSH client does not support",+    "ssh_config(5).  OpenSSH users will probably prefer to put something",+    "like `Host *.example.net Port 443` into their ~/.ssh/config file."])
+ src/Darcs/Util/StrictIdentity.hs view
@@ -0,0 +1,94 @@+-- copied (and minimally adapted) from strict-identity-0.1.0.0+-- which apparently has been abandoned+{- |+Module      :  Control.Monad.StrictIdentity+Copyright   :  (c) Carter Schonwald 2013+License     :  BSD3, see license file+ +Maintainer  :  libraries@haskell.org+Stability   :  experimental+Portability :  portable+-}+{-# LANGUAGE BangPatterns #-}+ +module Darcs.Util.StrictIdentity (+    StrictIdentity(..),+    runStrictIdentity)+    where+ +import Darcs.Prelude+import Control.Monad.Fix +++{- | 'StrictIdentity' is a newtype wrapper for a given type 'a' that +satisfies the 'Functor', 'Applicative', and 'Monad' laws  when restricted to+terminating strict computations. ++The typical use case is to provide a light weight strict nested +let notation for code that otherwise must use nested case expressions+as a proxy for a strict let.++the general pattern is to write code of the form++@+foo f h g x y z = runStrictIdentity $! do+    w <- return $! f x y+    j <- return $! h w z+    res <- return $! g w j+    return res+@++An example usage of 'StrictIdentity' that compiles to assembly +comparable to C is the following:++@+(>>) = unsafeShiftR+(<<) = unsafeShiftL+outerShuffle64A :: Word -> Word +outerShuffle64A !x =+    runStrictIdentity $! do+        x <- return $! ((x .&. 0x00000000FFFF0000) << 16 )+            .|. ((x>>16) .&. 0x00000000FFFF0000) .|. (x .&. 0xFFFF00000000FFFF)+        x <-  return $! ((x .&. 0x0000FF000000FF00 ) <<  8 )+            .|. (x >> 8) .&. 0x0000FF000000FF00 .|. (x  .&. 0xFF0000FFFF0000FF)+        x<-  return $! (( x .&. 0x00F000F000F000F0 ) << 4 )+            .|. (x >> 4) .&. 0x00F000F000F000F0 .|. (x .&. 0xF00FF00FF00FF00F )+        x<-   return $!((x .&.  0x0C0C0C0C0C0C0C0C )<< 2 )+            .|. (x >> 2) .&. 0x0C0C0C0C0C0C0C0C .|.( x .&. 0xC3C3C3C3C3C3C3C3)+        x<-   return $! ( (x .&. 0x2222222222222222)  << 1 ) +            .|. (x>> 1) .&. 0x2222222222222222 .|. (x .&. 0x9999999999999999)+        return x+@+++-}+ +newtype StrictIdentity a =  StrictIdentity {runStrictIdentity_ :: a }+ +-- | 'runStrictIdentity' unwraps a value of type  @'StrictIdentity' ty@  into a value of type @ty@,  strictly.+runStrictIdentity :: StrictIdentity a -> a +runStrictIdentity !ma = case runStrictIdentity_ $! ma of +                            !res -> res  +{-# INLINE  runStrictIdentity #-} +++instance Applicative StrictIdentity where+    {-# INLINE pure #-}+    pure !a = StrictIdentity $! a+    {-# INLINE (<*>) #-}+    (<*>) a b = do   f <- a ; v <- b ; return $! (f $! v)+    -- ap a b = liftM2 id a b  =  do  f <- a ; v<- b ; return ((id) )++instance Functor StrictIdentity where+    {-# INLINE fmap  #-}+    fmap !f !m = StrictIdentity $! (f $! (runStrictIdentity m))+ +instance Monad StrictIdentity where+    {-# INLINE return  #-}+    return = pure+    {-# INLINE  (>>=) #-}+    (!m) >>= (!k)  = k $! runStrictIdentity  m    + --StrictIdentity m >>= k  =  k $! m+instance MonadFix StrictIdentity where+    {-# INLINE mfix  #-}+    mfix !f = StrictIdentity $! (fix  (runStrictIdentity . f))
+ src/Darcs/Util/Tree.hs view
@@ -0,0 +1,531 @@+--  Copyright (C) 2009-2011 Petr Rockai+--+--  BSD3+{-# LANGUAGE MultiParamTypeClasses #-}++-- | The abstract representation of a Tree and useful abstract utilities to+-- handle those.+module Darcs.Util.Tree+    ( Tree, Blob(..), TreeItem(..), ItemType(..), Hash+    , makeTree, makeTreeWithHash, emptyTree, emptyBlob, makeBlob, makeBlobBS++    -- * Unfolding stubbed (lazy) Trees.+    --+    -- | By default, Tree obtained by a read function is stubbed: it will+    -- contain Stub items that need to be executed in order to access the+    -- respective subtrees. 'expand' will produce an unstubbed Tree.+    , expandUpdate, expand, expandPath, checkExpand++    -- * Tree access and lookup.+    , items, list, listImmediate, treeHash+    , lookup, find, findFile, findTree, itemHash, itemType+    , zipCommonFiles, zipFiles, zipTrees, diffTrees+    , explodePath, explodePaths, locate, isDir+    , treeHas, treeHasDir, treeHasFile, treeHasAnycase++    -- * Files (Blobs).+    , readBlob++    -- * Filtering trees.+    , FilterTree(..), restrict++    -- * Manipulating trees.+    , modifyTree, updateTree, partiallyUpdateTree, updateSubtrees, overlay+    , addMissingHashes++    -- * Properties+    , prop_explodePath+    ) where++import Darcs.Prelude hiding ( filter )+import qualified Prelude ( filter )++import Control.Exception( catch, IOException )+import Darcs.Util.Path+import Darcs.Util.Hash++import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString as B+import qualified Data.Map as M++import Data.Maybe( catMaybes, isNothing )+import Data.Either( lefts, rights )+import Data.List( union, sort )+import qualified Data.List+import Control.Monad( filterM, join )++--------------------------------+-- Tree, Blob and friends+--++data Blob m = Blob !(m BL.ByteString) !(Maybe Hash)+data TreeItem m = File !(Blob m)+                | SubTree !(Tree m)+                | Stub !(m (Tree m)) !(Maybe Hash)++data ItemType = TreeType | BlobType deriving (Show, Eq, Ord)++-- | Abstraction of a filesystem tree.+-- Please note that the Tree returned by the respective read operations will+-- have TreeStub items in it. To obtain a Tree without such stubs, call+-- expand on it, eg.:+--+-- > tree <- readDarcsPristine "." >>= expand+--+-- When a Tree is expanded, it becomes \"final\". All stubs are forced and the+-- Tree can be traversed purely. Access to actual file contents stays in IO+-- though.+--+-- A Tree may have a Hash associated with it. A pair of Tree's is identical+-- whenever their hashes are (the reverse need not hold, since not all Trees+-- come equipped with a hash).+data Tree m = Tree { items :: M.Map Name (TreeItem m)+                   -- | Get hash of a Tree. This is guaranteed to uniquely+                   -- identify the Tree (including any blob content), as far as+                   -- cryptographic hashes are concerned. Sha256 is recommended.+                   , treeHash :: !(Maybe Hash) }++listImmediate :: Tree m -> [(Name, TreeItem m)]+listImmediate = M.toList . items++-- | Get a hash of a TreeItem. May be Nothing.+itemHash :: TreeItem m -> Maybe Hash+itemHash (File (Blob _ h)) = h+itemHash (SubTree t) = treeHash t+itemHash (Stub _ h) = h++itemType :: TreeItem m -> ItemType+itemType (File _) = BlobType+itemType (SubTree _) = TreeType+itemType (Stub _ _) = TreeType++emptyTree :: Tree m+emptyTree = Tree { items = M.empty+                 , treeHash = Nothing }++emptyBlob :: (Monad m) => Blob m+emptyBlob = Blob (return BL.empty) Nothing++makeBlob :: (Monad m) => BL.ByteString -> Blob m+makeBlob str = Blob (return str) (Just $ sha256 str)++makeBlobBS :: (Monad m) => B.ByteString -> Blob m+makeBlobBS s' = let s = BL.fromChunks [s'] in Blob (return s) (Just $ sha256 s)++makeTree :: [(Name,TreeItem m)] -> Tree m+makeTree l = Tree { items = M.fromList l+                  , treeHash = Nothing }++makeTreeWithHash :: [(Name,TreeItem m)] -> Hash -> Tree m+makeTreeWithHash l h = Tree { items = M.fromList l+                            , treeHash = Just h }++-----------------------------------+-- Tree access and lookup+--++-- | Look up a 'Tree' item (an immediate subtree or blob).+lookup :: Tree m -> Name -> Maybe (TreeItem m)+lookup t n = M.lookup n (items t)++find' :: TreeItem m -> AnchoredPath -> Maybe (TreeItem m)+find' t (AnchoredPath []) = Just t+find' (SubTree t) (AnchoredPath (d : rest)) =+    case lookup t d of+      Just sub -> find' sub (AnchoredPath rest)+      Nothing -> Nothing+find' _ _ = Nothing++-- | Find a 'TreeItem' by its path. Gives 'Nothing' if the path is invalid.+find :: Tree m -> AnchoredPath -> Maybe (TreeItem m)+find = find' . SubTree++-- | Find a 'Blob' by its path. Gives 'Nothing' if the path is invalid, or does+-- not point to a Blob.+findFile :: Tree m -> AnchoredPath -> Maybe (Blob m)+findFile t p = case find t p of+                 Just (File x) -> Just x+                 _ -> Nothing++-- | Find a 'Tree' by its path. Gives 'Nothing' if the path is invalid, or does+-- not point to a Tree.+findTree :: Tree m -> AnchoredPath -> Maybe (Tree m)+findTree t p = case find t p of+                 Just (SubTree x) -> Just x+                 _ -> Nothing++-- | List all contents of a 'Tree'.+list :: Tree m -> [(AnchoredPath, TreeItem m)]+list t_ = paths t_ (AnchoredPath [])+    where paths t p = [ (appendPath p n, i)+                          | (n,i) <- listImmediate t ] +++                    concat [ paths subt (appendPath p subn)+                             | (subn, SubTree subt) <- listImmediate t ]++-- | Like 'find' but monadic and thus able to expand 'Stub's on the way.+locate :: Monad m => Tree m -> AnchoredPath -> m (Maybe (TreeItem m))+locate tree (AnchoredPath names) = go names (SubTree tree)+  where+    go [] i = return (Just i)+    go _ (File _) = return Nothing+    go ns (Stub mkTree _) = mkTree >>= go ns . SubTree+    go (n:ns) (SubTree t) =+      case lookup t n of+        Nothing -> return Nothing+        Just i -> go ns i++isDir :: TreeItem m -> Bool+isDir (File _) = False+isDir _ = True++treeHasAnycase :: Monad m+               => Tree m+               -> AnchoredPath+               -> m Bool+treeHasAnycase tree (AnchoredPath names) = go names (SubTree tree)+  where+    go [] _ = return True+    go ns (Stub mkTree _) = mkTree >>= go ns . SubTree+    go _ (File _) = return False+    go (n:ns) (SubTree t) =+      case Data.List.find (eqAnycase n . fst) (listImmediate t) of+        Nothing -> return False+        Just (_,i) -> go ns i++treeHas :: Monad m => Tree m -> AnchoredPath -> m Bool+treeHas tree path = maybe False (const True) <$> locate tree path++treeHasDir :: Monad m => Tree m -> AnchoredPath -> m Bool+treeHasDir tree path = maybe False isDir <$> locate tree path++treeHasFile :: Monad m => Tree m -> AnchoredPath -> m Bool+treeHasFile tree path = maybe False (not . isDir) <$> locate tree path++-- | Like 'explodePath' but for multiple paths.+explodePaths :: Tree IO -> [AnchoredPath] -> [AnchoredPath]+explodePaths tree paths = concatMap (explodePath tree) paths++-- | All paths in the tree that that have the given path as prefix.+--+-- prop> explodePath t p == Prelude.filter (p `isPrefix`) (map fst (list t))+explodePath :: Tree m -> AnchoredPath -> [AnchoredPath]+explodePath tree path =+  path : maybe [] (map (catPaths path . fst) . list) (findTree tree path)++expandUpdate+  :: (Monad m) => (AnchoredPath -> Tree m -> m (Tree m)) -> Tree m -> m (Tree m)+expandUpdate update = go (AnchoredPath [])+  where+    go path t = do+      let subtree (name, sub) = do+            tree <- go (path `appendPath` name) =<< unstub sub+            return (name, SubTree tree)+      expanded <- mapM subtree [ x | x@(_, item) <- listImmediate t, isDir item ]+      let orig_map     = M.filter (not . isDir) (items t)+          expanded_map = M.fromList expanded+          tree         = t { items = M.union orig_map expanded_map }+      update path tree++-- | Expand a stubbed Tree into a one with no stubs in it. You might want to+-- filter the tree before expanding to save IO. This is the basic+-- implementation, which may be overriden by some Tree instances (this is+-- especially true of the Index case).+expand :: (Monad m) => Tree m -> m (Tree m)+expand = expandUpdate $ const return++-- | Unfold a path in a (stubbed) Tree, such that the leaf node of the path is+-- reachable without crossing any stubs. Moreover, the leaf ought not be a Stub+-- in the resulting Tree. A non-existent path is expanded as far as it can be.+expandPath :: (Monad m) => Tree m -> AnchoredPath -> m (Tree m)+expandPath t (AnchoredPath []) = return t+expandPath t (AnchoredPath (n:rest)) =+  case lookup t n of+    (Just item) | isDir item -> amend t n rest =<< unstub item+    _ -> return t -- fail $ "Descent error in expandPath: " ++ show path_+    where+          amend t' name rest' sub = do+            sub' <- expandPath sub (AnchoredPath rest')+            let tree = t' { items = M.insert name (SubTree sub') (items t') }+            return tree++-- | Check the disk version of a Tree: expands it, and checks each+-- hash. Returns either the expanded tree or a list of AnchoredPaths+-- where there are problems. The first argument is the hashing function+-- used to create the tree.+checkExpand :: (TreeItem IO -> IO Hash) -> Tree IO+            -> IO (Either [(AnchoredPath, Maybe Hash, Maybe Hash)] (Tree IO))+checkExpand hashFunc t = go (AnchoredPath []) t+    where+      go path t_ = do+        let+            subtree (name, sub) =+                do let here = path `appendPath` name+                   sub' <- (Just <$> unstub sub) `catch` \(_ :: IOException) -> return Nothing+                   case sub' of+                     Nothing -> return $ Left [(here, treeHash t_, Nothing)]+                     Just sub'' -> do+                       treeOrTrouble <- go (path `appendPath` name) sub''+                       return $ case treeOrTrouble of+                              Left problems -> Left problems+                              Right tree -> Right (name, SubTree tree)+            badBlob (_, f@(File (Blob _ h))) =+              fmap (/= h) (fmap Just (hashFunc f) `catch` (\(_ :: IOException) -> return Nothing))+            badBlob _ = return False+            render (name, f@(File (Blob _ h))) = do+              h' <- (Just <$> hashFunc f) `catch` \(_ :: IOException) -> return Nothing+              return (path `appendPath` name, h, h')+            render (name, _) = return (path `appendPath` name, Nothing, Nothing)+        subs <- mapM subtree [ x | x@(_, item) <- listImmediate t_, isDir item ]+        badBlobs <- filterM badBlob (listImmediate t) >>= mapM render+        let problems = badBlobs ++ concat (lefts subs)+        if null problems+         then do+           let orig_map = M.filter (not . isDir) (items t)+               expanded_map = M.fromList $ rights subs+               tree = t_ {items = orig_map `M.union` expanded_map}+           h' <- hashFunc (SubTree t_)+           if Just h' `match` treeHash t_+            then return $ Right tree+            else return $ Left [(path, treeHash t_, Just h')]+         else return $ Left problems++class (Monad m) => FilterTree a m where+    -- | Given @pred tree@, produce a 'Tree' that only has items for which+    -- @pred@ returns @True@.+    -- The tree might contain stubs. When expanded, these will be subject to+    -- filtering as well.+    filter :: (AnchoredPath -> TreeItem m -> Bool) -> a m -> a m++instance (Monad m) => FilterTree Tree m where+    filter predicate = filter' (AnchoredPath [])+        where filter' path t = t { items = M.mapMaybeWithKey (wibble path) $ items t }+              wibble path name item =+                  let npath = path `appendPath` name in+                      if predicate npath item+                         then Just $ filterSub npath item+                         else Nothing+              filterSub npath (SubTree t) = SubTree (filter' npath t)+              filterSub npath (Stub stub _) = Stub (filter' npath <$> stub) Nothing+              filterSub _ x = x++-- | Given two Trees, a @guide@ and a @tree@, produces a new Tree that is a+-- identical to @tree@, but only has those items that are present in both+-- @tree@ and @guide@. The @guide@ Tree may not contain any stubs.+restrict :: (FilterTree t m) => Tree n -> t m -> t m+restrict guide tree = filter accept tree+    where accept path item =+              case (find guide path, item) of+                (Just (SubTree _), SubTree _) -> True+                (Just (SubTree _), Stub _ _) -> True+                (Just (File _), File _) -> True+                (Just (Stub _ _), _) ->+                    error "*sulk* Go away, you, you precondition violator!"+                (_, _) -> False++-- | Read a Blob into a Lazy ByteString. Might be backed by an mmap, use with+-- care.+readBlob :: Blob m -> m BL.ByteString+readBlob (Blob r _) = r++-- | For every pair of corresponding blobs from the two supplied trees,+-- evaluate the supplied function and accumulate the results in a list. Hint:+-- to get IO actions through, just use sequence on the resulting list.+-- NB. This won't expand any stubs.+zipCommonFiles :: (AnchoredPath -> Blob m -> Blob m -> a) -> Tree m -> Tree m -> [a]+zipCommonFiles f a b = catMaybes [ flip (f p) x `fmap` findFile a p+                                   | (p, File x) <- list b ]++-- | For each file in each of the two supplied trees, evaluate the supplied+-- function (supplying the corresponding file from the other tree, or Nothing)+-- and accumulate the results in a list. Hint: to get IO actions through, just+-- use sequence on the resulting list.  NB. This won't expand any stubs.+zipFiles :: (AnchoredPath -> Maybe (Blob m) -> Maybe (Blob m) -> a)+         -> Tree m -> Tree m -> [a]+zipFiles f a b = [ f p (findFile a p) (findFile b p)+                   | p <- paths a `sortedUnion` paths b ]+    where paths t = sort [ p | (p, File _) <- list t ]++zipTrees :: (AnchoredPath -> Maybe (TreeItem m) -> Maybe (TreeItem m) -> a)+         -> Tree m -> Tree m -> [a]+zipTrees f a b = [ f p (find a p) (find b p)+                   | p <- reverse (paths a `sortedUnion` paths b) ]+    where paths t = sort [ p | (p, _) <- list t ]++-- | Helper function for taking the union of AnchoredPath lists that+-- are already sorted.  This function does not check the precondition+-- so use it carefully.+sortedUnion :: [AnchoredPath] -> [AnchoredPath] -> [AnchoredPath]+sortedUnion [] ys = ys+sortedUnion xs [] = xs+sortedUnion a@(x:xs) b@(y:ys) = case compare x y of+                                LT -> x : sortedUnion xs b+                                EQ -> x : sortedUnion xs ys+                                GT -> y : sortedUnion a ys++-- | Cautiously extracts differing subtrees from a pair of Trees. It will never+-- do any unneccessary expanding. Tree hashes are used to cut the comparison as+-- high up the Tree branches as possible. The result is a pair of trees that do+-- not share any identical subtrees. They are derived from the first and second+-- parameters respectively and they are always fully expanded. It might be+-- advantageous to feed the result into 'zipFiles' or 'zipTrees'.+diffTrees :: forall m. (Monad m) => Tree m -> Tree m -> m (Tree m, Tree m)+diffTrees left right =+            if treeHash left `match` treeHash right+               then return (emptyTree, emptyTree)+               else diff left right+  where isFile (File _) = True+        isFile _ = False+        notFile = not . isFile+        isEmpty = null . listImmediate+        subtree :: TreeItem m -> m (Tree m)+        subtree (Stub x _) = x+        subtree (SubTree x) = return x+        subtree (File _) = error "diffTrees tried to descend a File as a subtree"+        maybeUnfold (Stub x _) = SubTree `fmap` (x >>= expand)+        maybeUnfold (SubTree x) = SubTree `fmap` expand x+        maybeUnfold i = return i+        immediateN t = [ n | (n, _) <- listImmediate t ]+        diff left' right' = do+          is <- sequence [+                   case (lookup left' n, lookup right' n) of+                     (Just l, Nothing) -> do+                       l' <- maybeUnfold l+                       return (n, Just l', Nothing)+                     (Nothing, Just r) -> do+                       r' <- maybeUnfold r+                       return (n, Nothing, Just r')+                     (Just l, Just r)+                         | itemHash l `match` itemHash r ->+                             return (n, Nothing, Nothing)+                         | notFile l && notFile r ->+                             do x <- subtree l+                                y <- subtree r+                                (x', y') <- diffTrees x y+                                if isEmpty x' && isEmpty y'+                                   then return (n, Nothing, Nothing)+                                   else return (n, Just $ SubTree x', Just $ SubTree y')+                         | isFile l && isFile r ->+                             return (n, Just l, Just r)+                         | otherwise ->+                             do l' <- maybeUnfold l+                                r' <- maybeUnfold r+                                return (n, Just l', Just r')+                     _ -> error "n lookups failed"+                   | n <- immediateN left' `union` immediateN right' ]+          let is_l = [ (n, l) | (n, Just l, _) <- is ]+              is_r = [ (n, r) | (n, _, Just r) <- is ]+          return (makeTree is_l, makeTree is_r)++-- | Modify a Tree (by replacing, or removing or adding items).+modifyTree :: (Monad m) => Tree m -> AnchoredPath -> Maybe (TreeItem m) -> Tree m+modifyTree t_ p_ i_ = snd $ go t_ p_ i_+  where fix t unmod items' = (unmod, t { items = (countmap items':: Int) `seq` items'+                                       , treeHash = if unmod then treeHash t else Nothing })++        go t (AnchoredPath []) (Just (SubTree sub)) = (treeHash t `match` treeHash sub, sub)++        go t (AnchoredPath [n]) (Just item) = fix t unmod items'+            where !items' = M.insert n item (items t)+                  !unmod = itemHash item `match` join (fmap itemHash (lookup t n))++        go t (AnchoredPath [n]) Nothing = fix t unmod items'+            where !items' = M.delete n (items t)+                  !unmod = isNothing $ lookup t n++        go t path@(AnchoredPath (n:r)) item = fix t unmod items'+            where subtree s = go s (AnchoredPath r) item+                  !items' = M.insert n sub (items t)+                  !sub = snd sub'+                  !unmod = fst sub'+                  !sub' = case lookup t n of+                    Just (SubTree s) -> let (mod', sub'') = subtree s in (mod', SubTree sub'')+                    Just (Stub s _) -> (False, Stub (do x <- s+                                                        return $! snd $! subtree x) Nothing)+                    Nothing -> (False, SubTree $! snd $! subtree emptyTree)+                    _ -> error $ "Modify tree at " ++ show path++        go _ (AnchoredPath []) (Just (Stub _ _)) =+            error $ "descending in modifyTree, case = (Just (Stub _ _)), path = " ++ show p_+        go _ (AnchoredPath []) (Just (File _)) =+            error $ "descending in modifyTree, case = (Just (File _)), path = " ++ show p_+        go _ (AnchoredPath []) Nothing =+            error $ "descending in modifyTree, case = Nothing, path = " ++ show p_++countmap :: forall a k. M.Map k a -> Int+countmap = M.foldr (\_ i -> i + 1) 0++updateSubtrees :: (Tree m -> Tree m) -> Tree m -> Tree m+updateSubtrees fun t =+    fun $ t { items = M.mapWithKey (curry $ snd . update) $ items t+            , treeHash = Nothing }+  where update (k, SubTree s) = (k, SubTree $ updateSubtrees fun s)+        update (k, File f) = (k, File f)+        update (_, Stub _ _) = error "Stubs not supported in updateTreePostorder"++-- | Does /not/ expand the tree.+updateTree :: (Monad m) => (TreeItem m -> m (TreeItem m)) -> Tree m -> m (Tree m)+updateTree fun t = partiallyUpdateTree fun (\_ _ -> True) t++-- | Does /not/ expand the tree.+partiallyUpdateTree :: (Monad m) => (TreeItem m -> m (TreeItem m))+                       -> (AnchoredPath -> TreeItem m -> Bool) -> Tree m -> m (Tree m)+partiallyUpdateTree fun predi t' = go (AnchoredPath []) t'+  where go path t = do+          items' <- M.fromList <$> mapM (maybeupdate path) (listImmediate t)+          subtree <- fun . SubTree $ t { items = items'+                                       , treeHash = Nothing }+          case subtree of+            SubTree t'' -> return t''+            _ -> error "function passed to partiallyUpdateTree changed SubTree to something else"+        maybeupdate path (k, item) = if predi (path `appendPath` k) item+          then update (path `appendPath` k) (k, item)+          else return (k, item)+        update path (k, SubTree tree) = (\new -> (k, SubTree new)) <$> go path tree+        update    _ (k, item) = (\new -> (k, new)) <$> fun item++-- | Lay one tree over another. The resulting Tree will look like the base (1st+-- parameter) Tree, although any items also present in the overlay Tree will be+-- taken from the overlay. It is not allowed to overlay a different kind of an+-- object, nor it is allowed for the overlay to add new objects to base.  This+-- means that the overlay Tree should be a subset of the base Tree (although+-- any extraneous items will be ignored by the implementation).+overlay :: Applicative m => Tree m -> Tree m -> Tree m+overlay base over = Tree {items = M.fromList immediate, treeHash = Nothing}+  where+    immediate = [(n, get n) | (n, _) <- listImmediate base]+    get n =+      case (M.lookup n $ items base, M.lookup n $ items over) of+        (Just (File _), Just f@(File _)) -> f+        (Just (SubTree b), Just (SubTree o)) -> SubTree $ overlay b o+        (Just (Stub b _), Just (SubTree o)) -> Stub (overlay <$> b <*> pure o) Nothing+        (Just (SubTree b), Just (Stub o _)) -> Stub (overlay <$> pure b <*> o) Nothing+        (Just (Stub b _), Just (Stub o _)) -> Stub (overlay <$> b <*> o) Nothing+        (Just x, _) -> x+        (_, _) -> error $ "Unexpected case in overlay at get " ++ show n ++ "."++-- | Calculate and insert hashes for all 'TreeItem's contained in a 'Tree',+-- including the argument 'Tree' itself. If necessary, this expands 'Stub's.+addMissingHashes :: (Monad m) => (TreeItem m -> m Hash) -> Tree m -> m (Tree m)+addMissingHashes make = updateTree update+    where update item@(SubTree t) = do+              hash <- make item+              return $ SubTree (t { treeHash = Just hash })+          update item@(File (Blob con Nothing)) = do+              hash <- make item+              return $ File (Blob con (Just hash))+          update (Stub s Nothing) = update . SubTree =<< s+          update x = return x++-- ---- Private utilities shared among multiple functions. --------++unstub :: (Monad m) => TreeItem m -> m (Tree m)+unstub (Stub s _) = s+unstub (SubTree s) = return s+unstub _ = return emptyTree++-- Properties++-- | Specification of 'explodePath'+prop_explodePath :: Tree m -> AnchoredPath -> Bool+prop_explodePath t p =+  explodePath t p == Prelude.filter (isPrefix p) (map fst (list t))
+ src/Darcs/Util/Tree/Hashed.hs view
@@ -0,0 +1,265 @@+--  Copyright (C) 2009-2011 Petr Rockai+--+--  BSD3++-- | A few darcs-specific utility functions. These are used for reading and+-- writing darcs and darcs-compatible hashed trees.+module Darcs.Util.Tree.Hashed+    ( -- * Obtaining Trees.+    --+    -- | Please note that Trees obtained this way will contain Stub+    -- items. These need to be executed (they are IO actions) in order to be+    -- accessed. Use 'expand' to do this. However, many operations are+    -- perfectly fine to be used on a stubbed Tree (and it is often more+    -- efficient to do everything that can be done before expanding a Tree).+      readDarcsHashed+    -- * Writing trees.+    , writeDarcsHashed+    -- * Interact with hashed tree+    , hashedTreeIO+    -- * Other+    , readDarcsHashedNosize+    , darcsAddMissingHashes+    , darcsTreeHash+    , darcsUpdateHashes+    , followPristineHashes+    ) where++import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL++import Data.List ( sortBy )+import Data.Maybe ( fromMaybe )++import Darcs.Prelude++import Darcs.Util.Cache+    ( Cache+    , fetchFileUsingCache+    , writeFileUsingCache+    )+import Darcs.Util.Hash+    ( Hash+    , encodeBase16+    , encodeHash+    , sha256+    , showHash+    )+import Darcs.Util.Parser+import Darcs.Util.Path ( Name, decodeWhiteName, encodeWhiteName )+import Darcs.Util.Progress ( debugMessage, finishedOneIO, withSizedProgress )+import Darcs.Util.Tree+    ( Blob(..)+    , ItemType(..)+    , Tree(..)+    , TreeItem(..)+    , addMissingHashes+    , expand+    , itemHash+    , list+    , listImmediate+    , makeTreeWithHash+    , readBlob+    , updateSubtrees+    , updateTree+    )+import Darcs.Util.Tree.Monad ( TreeIO, runTreeMonad )+import Darcs.Util.ValidHash+    ( PristineHash+    , decodeValidHash+    , encodeValidHash+    , fromHash+    , getHash+    , getSize+    )++----------------------------------------------+-- Darcs directory format.+--++-- Precondition: all (immediate) items in the tree have hashes+darcsFormatDir :: Tree m -> BL.ByteString+darcsFormatDir =+  BL.fromChunks . map formatItem . sortBy cmp . listImmediate+  where+    cmp (a, _) (b, _) = compare a b+    formatItem (name, item) = BC.unlines+      [ case item of+          File _ -> kwFile+          _      -> kwDir+      , encodeWhiteName name+      , case itemHash item of+          Nothing -> error "precondition of darcsFormatDir"+          Just h  -> encodeBase16 h+      ]++darcsParseDir+  :: FilePath -> BC.ByteString -> Either String [(ItemType, Name, PristineHash)]+darcsParseDir path = withPath path . parseAll (many pDir)+  where+    pDir = do+      t <- pHeader+      char '\n'+      n <- pName+      char '\n'+      h <- pHash+      char '\n'+      return (t, n, h)+    pHeader = (BlobType <$ string kwFile) <|> (TreeType <$ string kwDir)+    pName   = do+      name <- takeTillChar '\n'+      either fail return (decodeWhiteName name)+    pHash = do+      hash <- takeTillChar '\n'+      maybe (fail "expected valid hash") return (decodeValidHash (BC.unpack hash))++kwFile, kwDir :: BC.ByteString+kwFile = BC.pack "file:"+kwDir = BC.pack "directory:"++----------------------------------------+-- Utilities.+--++-- | Compute a darcs-compatible hash value for a tree-like structure.+darcsTreeHash :: Tree m -> Hash+darcsTreeHash = sha256 . darcsFormatDir++darcsUpdateDirHashes :: Tree m -> Tree m+darcsUpdateDirHashes = updateSubtrees update+    where update t = t { treeHash = Just (darcsTreeHash t) }++darcsUpdateHashes :: Monad m => Tree m -> m (Tree m)+darcsUpdateHashes = updateTree update+    where update (SubTree t) =+              -- why not recursively ensure that hashes exist here?+              return . SubTree $ t { treeHash = Just (darcsTreeHash t) }+          update (File blob@(Blob con _)) =+              do hash <- sha256 <$> readBlob blob+                 return $ File (Blob con (Just hash))+          update stub = return stub++darcsHash :: Monad m => TreeItem m -> m Hash+darcsHash (SubTree t) = return (darcsTreeHash t)+darcsHash (File blob) = sha256 <$> readBlob blob+darcsHash (Stub unstub _) = darcsTreeHash <$> unstub++darcsAddMissingHashes :: (Monad m) => Tree m -> m (Tree m)+darcsAddMissingHashes = addMissingHashes darcsHash++-------------------------------------------+-- Reading darcs pristine data+--++-- | Read and parse a darcs-style hashed directory listing from a given @cache@+-- and with a given @hash@.+readDarcsHashedDir :: Cache+                   -> PristineHash+                   -> IO [(ItemType, Name, PristineHash)]+readDarcsHashedDir cache ph = do+  debugMessage $ "readDarcsHashedDir: " ++ encodeValidHash ph+  (file, content) <- fsReadHashedFile cache ph+  either fail return $ darcsParseDir file content++-- | Read a darcs-style hashed tree.+readDarcsHashed' :: Bool -> Cache -> PristineHash -> IO (Tree IO)+readDarcsHashed' sizefail cache root = do+  items' <- readDarcsHashedDir cache root+  subs <- sequence [+           do let h = getHash ph+              case getSize ph of+                Just _ | sizefail ->+                  fail ("Unexpectedly encountered size-prefixed hash in " ++ encodeValidHash root)+                _ -> return ()+              case tp of+                BlobType -> return (d, File $+                                       Blob (readBlob' ph) (Just h))+                TreeType ->+                  do let t = readDarcsHashed cache ph+                     return (d, Stub t (Just h))+           | (tp, d, ph) <- items' ]+  return $ makeTreeWithHash subs (getHash root)+    where readBlob' = fmap (BL.fromStrict . snd) . fsReadHashedFile cache++readDarcsHashed :: Cache -> PristineHash -> IO (Tree IO)+readDarcsHashed = readDarcsHashed' False++readDarcsHashedNosize :: Cache -> PristineHash -> IO (Tree IO)+readDarcsHashedNosize = readDarcsHashed' True++----------------------------------------------------+-- Writing darcs-style hashed trees.+--++-- | Write a Tree into a darcs-style hashed directory.+writeDarcsHashed :: Tree IO -> Cache -> IO PristineHash+writeDarcsHashed tree' cache = do+  debugMessage "writeDarcsHashed"+  t <- darcsUpdateDirHashes <$> expand tree'+  let items = list t+  withSizedProgress "Getting pristine" (length items) $ \k -> do+    sequence_ [readAndWriteBlob k b | (_, File b) <- items]+    let dirs = darcsFormatDir t : [darcsFormatDir d | (_, SubTree d) <- items]+    mapM_ (dump k) dirs+  return (fromHash (darcsTreeHash t))+  where+    readAndWriteBlob k b = readBlob b >>= dump k+    dump k x = fsCreateHashedFile cache x >>= finishedOneIO k . encodeValidHash++-- | Create a hashed file from a 'Cache' and file content. In case the file+-- exists it is kept untouched and is assumed to have the right content.+fsCreateHashedFile :: Cache -> BL.ByteString -> IO PristineHash+fsCreateHashedFile cache content =+  writeFileUsingCache cache (BL.toStrict content)++fsReadHashedFile :: Cache -> PristineHash -> IO (FilePath, BC.ByteString)+fsReadHashedFile = fetchFileUsingCache++-- | Run a 'TreeIO' @action@ in a hashed setting. Any changes will be written+-- out to the cache. Please note that actual filesystem files are never removed.+hashedTreeIO :: TreeIO a -- ^ action+             -> Tree IO -- ^ initial+             -> Cache+             -> IO (a, Tree IO)+hashedTreeIO action tree cache = runTreeMonad action tree (const dumpItem)+  where+    dumpItem (File b) = File <$> dumpFile b+    dumpItem (Stub unstub _) = SubTree <$> (unstub >>= dumpTree)+    dumpItem (SubTree s) = SubTree <$> dumpTree s++    -- This code is somewhat tricky. The original Tree may have come from+    -- anywhere e.g. a plain Tree. So when we modify the content of a+    -- file, we not only write a new hashed file, but also modify the+    -- Blob itself, so that the embedded read action read this new hashed+    -- file.+    dumpFile :: Blob IO -> IO (Blob IO)+    dumpFile (Blob getBlob mhash) = do+      content <- getBlob+      let hash = fromMaybe (sha256 content) mhash+      debugMessage $ "hashedTreeIO.dumpFile: old hash=" ++ encodeHash hash+      let getBlob' =+            BL.fromStrict . snd <$>+            fsReadHashedFile cache (fromHash hash)+      nhash <- fsCreateHashedFile cache content+      debugMessage $ "hashedTreeIO.dumpFile: new hash=" ++ encodeValidHash nhash+      return $ Blob getBlob' (Just hash)++    dumpTree :: Tree IO -> IO (Tree IO)+    dumpTree t = do+      debugMessage $ "hashedTreeIO.dumpTree: old hash=" ++ showHash (treeHash t)+      t' <- darcsAddMissingHashes t+      nhash <- fsCreateHashedFile cache (darcsFormatDir t')+      debugMessage $ "hashedTreeIO.dumpTree: new hash=" ++ encodeValidHash nhash+      return t'++-- | Return all 'PristineHash'es reachable from the given root set, which must+-- consist of directory hashes only.+followPristineHashes :: Cache -> [PristineHash] -> IO [PristineHash]+followPristineHashes cache = followAll+  where+    followAll roots = concat <$> mapM followOne roots+    followOne root = do+      x <- readDarcsHashedDir cache root+      let subs   = [ ph | (TreeType, _, ph) <- x ]+          hashes = root : [ ph | (_, _, ph) <- x ]+      (hashes ++) <$> followAll subs
+ src/Darcs/Util/Tree/Monad.hs view
@@ -0,0 +1,302 @@+--  Copyright (C) 2009-2011 Petr Rockai+--+--  BSD3++{- | A monad transformer for 'Tree' mutation. The main idea is to simulate+IO-ish manipulation of real filesystem (that's the state part of the monad),+and to keep memory usage down by reasonably often dumping the intermediate+data to disk and forgetting it.++The implementation is configured by passing a procedure of type 'DumpItem'+to 'runTreeMonad'.++This module provides the pre-configured 'virtualTreeIO' that never+writes any changes, but may trigger filesystem reads as appropriate. -}++module Darcs.Util.Tree.Monad+    ( -- * 'TreeMonad'+      TreeMonad+    , TreeState(tree)+    , runTreeMonad+    , virtualTreeMonad+      -- * Specializing to 'IO'+    , TreeIO+    , virtualTreeIO+      -- * Read actions+    , readFile+    , exists+    , directoryExists+    , fileExists+      -- * Write actions+    , writeFile+    , createDirectory+    , unlink+    , rename+    , copy+      -- * Other actions+    , findM, findFileM, findTreeM+    ) where++import Darcs.Prelude hiding ( readFile, writeFile )++import Darcs.Util.Path ( AnchoredPath, anchoredRoot, displayPath, movedirfilename )+import Darcs.Util.Tree++import Data.List( sortBy )+import Data.Int( Int64 )+import Data.Maybe( isNothing, isJust )++import qualified Data.ByteString.Lazy as BL+import Control.Monad ( forM_, when, unless )+import Control.Monad.Catch ( MonadThrow(..) )+import Control.Monad.RWS.Strict (RWST, runRWST, ask, gets, lift, modify)+import qualified Data.Map as M++import System.IO.Error ( ioeSetErrorString, mkIOError )+import GHC.IO.Exception ( IOErrorType(..) )++-- | Keep track of the size and age of changes to the tree.+type Changed = M.Map AnchoredPath (Int64, Int64) -- size, age++-- | Internal state of the 'TreeMonad'. Keeps track of the current 'Tree'+-- content and unsync'd changes.+data TreeState m = TreeState+  { tree :: !(Tree m)+  , changed :: !Changed+  , changesize :: !Int64+  , maxage :: !Int64+  }++-- | A procedure for dumping a single 'TreeItem' to disk. If the implementation+-- uses item 'Hash'es, it is also responsible to ensure that its 'Hash' is+-- up-to-date. It is not allowed to make any changes to the actual content of+-- the 'TreeItem'.+type DumpItem m = AnchoredPath -> TreeItem m -> m (TreeItem m)++-- | A monad transformer that adds state of type 'TreeState' and an environment+-- of type 'DumpItem'.+type TreeMonad m = RWST (DumpItem m) () (TreeState m) m++-- | 'TreeMonad' specialized to 'IO'+type TreeIO = TreeMonad IO++initialState :: Tree m -> TreeState m+initialState t =+  TreeState {tree = t, changed = M.empty, changesize = 0, maxage = 0}++flush :: Monad m => TreeMonad m ()+flush = do changed' <- map fst . M.toList <$> gets changed+           dirs' <- gets tree >>= \t -> return [ path | (path, SubTree _) <- list t ]+           modify $ \st -> st { changed = M.empty, changesize = 0 }+           forM_ (changed' ++ dirs' ++ [anchoredRoot]) flushItem++runTreeMonad' :: Monad m => TreeMonad m a -> DumpItem m -> TreeState m -> m (a, Tree m)+runTreeMonad' action initEnv initState = do+  (out, final, _) <- runRWST action initEnv initState+  return (out, tree final)++runTreeMonad :: Monad m => TreeMonad m a -> Tree m -> DumpItem m -> m (a, Tree m)+runTreeMonad action t dump = do+  let action' = do x <- action+                   flush+                   return x+  runTreeMonad' action' dump (initialState t)++-- | Run a 'TreeMonad' action without storing any changes. This is useful for+-- running monadic tree mutations for obtaining the resulting 'Tree' (as opposed+-- to their effect of writing a modified tree to disk). The actions can do both+-- read and write -- reads are passed through to the actual filesystem, but the+-- writes are held in memory in the form of a modified 'Tree'.+virtualTreeMonad :: Monad m => TreeMonad m a -> Tree m -> m (a, Tree m)+virtualTreeMonad action t = runTreeMonad action t (const return)++-- | 'virtualTreeMonad' specialized to 'IO'+virtualTreeIO :: TreeIO a -> Tree IO -> IO (a, Tree IO)+virtualTreeIO = virtualTreeMonad++-- | Modifies an item in the current Tree. This action keeps an account of the+-- modified data, in changed and changesize, for subsequent flush+-- operations. Any modifications (as in "modifyTree") are allowed.+modifyItem :: Monad m+            => AnchoredPath -> Maybe (TreeItem m) -> TreeMonad m ()+modifyItem path item = do+  age <- gets maxage+  changed' <- gets changed+  let getsize (Just (File b)) = lift (BL.length <$> readBlob b)+      getsize _ = return 0+  size <- getsize item+  let change = case M.lookup path changed' of+        Nothing -> size+        Just (oldsize, _) -> size - oldsize++  modify $ \st -> st { tree = modifyTree (tree st) path item+                     , changed = M.insert path (size, age) (changed st)+                     , maxage = age + 1+                     , changesize = changesize st + change }++renameChanged :: Monad m+              => AnchoredPath -> AnchoredPath -> TreeMonad m ()+renameChanged from to = modify $ \st -> st {changed = rename' $ changed st}+  where+    rename' = M.mapKeys (movedirfilename from to)++-- | Replace an item with a new version without modifying the content of the+-- tree. This does not do any change tracking. Ought to be only used from a+-- 'sync' implementation for a particular storage format. The presumed use-case+-- is that an existing in-memory Blob is replaced with a one referring to an+-- on-disk file.+replaceItem :: Monad m+            => AnchoredPath -> TreeItem m -> TreeMonad m ()+replaceItem path item = do+  modify $ \st -> st { tree = modifyTree (tree st) path (Just item) }++-- | Flush a single item to disk. This is the only procedure that (directly)+-- uses the Reader part of the environment (the procedure of type @'DumpItem' m@).+flushItem :: forall m . Monad m => AnchoredPath -> TreeMonad m ()+flushItem path = do+  current <- gets tree+  dumpItem <- ask+  case find current path of+    Nothing -> return () -- vanished, do nothing+    Just item -> lift (dumpItem path item) >>= replaceItem path++-- | If buffers are becoming large, sync, otherwise do nothing.+flushSome :: Monad m => TreeMonad m ()+flushSome = do x <- gets changesize+               when (x > megs 100) $ do+                 remaining <- go =<< sortBy age . M.toList <$> gets changed+                 modify $ \s -> s { changed = M.fromList remaining }+  where go [] = return []+        go ((path, (size, _)):chs) = do+          x <- subtract size <$> gets changesize+          flushItem path+          modify $ \s -> s { changesize = x }+          if  x > megs 50  then go chs+                           else return chs+        megs = (* (1024 * 1024))+        age (_, (_, a)) (_, (_, b)) = compare a b++-- read only actions++expandTo :: Monad m => AnchoredPath -> TreeMonad m ()+expandTo p =+    do t <- gets tree+       t' <- lift $ expandPath t p+       modify $ \st -> st { tree = t' }++findItem :: Monad m => AnchoredPath -> TreeMonad m (Maybe (TreeItem m))+findItem path = do+  expandTo path+  tr <- gets tree+  return $ find tr path++-- | Check for existence of a file.+fileExists :: Monad m => AnchoredPath -> TreeMonad m Bool+fileExists p = do+  item <- findItem p+  case item of+    Just (File{}) -> return True+    _ -> return False++-- | Check for existence of a directory.+directoryExists :: Monad m => AnchoredPath -> TreeMonad m Bool+directoryExists p = do+  item <- findItem p+  case item of+    Just (SubTree{}) -> return True+    _ -> return False++-- | Check for existence of a node (file or directory, doesn't matter).+exists :: MonadThrow m => AnchoredPath -> TreeMonad m Bool+exists p = isJust <$> findItem p++-- | Grab content of a file in the current Tree at the given path.+readFile :: MonadThrow m => AnchoredPath -> TreeMonad m BL.ByteString+readFile p = do+  f <- findItem p+  case f of+    Just (File x) -> lift (readBlob x)+    Just _ ->+      throwM $+        flip ioeSetErrorString "is a directory" $+        mkIOError InappropriateType "readFile" Nothing (Just (displayPath p))+    Nothing ->+      throwM $+        mkIOError NoSuchThing "readFile" Nothing (Just (displayPath p))++-- | Change content of a file at a given path. The change will be+-- eventually flushed to disk, but might be buffered for some time.+writeFile :: MonadThrow m => AnchoredPath -> BL.ByteString -> TreeMonad m ()+writeFile p con = do+  item <- findItem p+  case item of+    Just (SubTree _) ->+      throwM $+      flip ioeSetErrorString "is a directory" $+      mkIOError InappropriateType "writeFile" Nothing (Just (displayPath p))+    _ ->+      -- note that writing to a non-existing file is allowed,+      -- in fact there is no primitive for creating a file+      modifyItem p (Just blob)+  flushSome+  where+    blob = File $ Blob (return con) Nothing+    -- we would like to say "sha256 con" here, but due to strictness of Hash in+    -- Blob, this would often lead to unnecessary computation which would then+    -- be discarded anyway; we rely on the sync implementation to fix up any+    -- Nothing occurrences++-- | Create a directory.+createDirectory :: Monad m => AnchoredPath -> TreeMonad m ()+createDirectory p =+    do expandTo p+       modifyItem p $ Just $ SubTree emptyTree++-- | Remove the item at a path.+unlink :: Monad m => AnchoredPath -> TreeMonad m ()+unlink p =+    do expandTo p+       modifyItem p Nothing++-- | Rename the item at a path.+rename :: MonadThrow m => AnchoredPath -> AnchoredPath -> TreeMonad m ()+rename from to = do+  item <- findItem from+  found_to <- findItem to+  unless (isJust item) $+    throwM $+      mkIOError NoSuchThing "rename" Nothing (Just (displayPath from))+  unless (isNothing found_to) $+    throwM $+      mkIOError AlreadyExists "rename" Nothing (Just (displayPath to))+  modifyItem from Nothing+  modifyItem to item+  renameChanged from to++-- | Copy an item from some path to another path.+-- Doing this with a SubTree is weird... it means copy recursively,+-- but with lazy copy-on-write semantics. What happens when we flush that?+-- Seems to work, though, as it is used in Darcs.UI.Commands.Convert.Import+copy :: MonadThrow m => AnchoredPath -> AnchoredPath -> TreeMonad m ()+copy from to = do+  expandTo to+  item <- findItem from+  when (isNothing item) $+    throwM $+    mkIOError NoSuchThing "copy" Nothing (Just (displayPath from))+  modifyItem to item++findM' :: forall m a . Monad m+       => (Tree m -> AnchoredPath -> a) -> Tree m -> AnchoredPath -> m a+findM' what t path = fst <$> virtualTreeMonad (look path) t+  where look :: AnchoredPath -> TreeMonad m a+        look p = expandTo p >> flip what p <$> gets tree++findM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (TreeItem m))+findM = findM' find++findTreeM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (Tree m))+findTreeM = findM' findTree++findFileM :: Monad m => Tree m -> AnchoredPath -> m (Maybe (Blob m))+findFileM = findM' findFile
+ src/Darcs/Util/Tree/Plain.hs view
@@ -0,0 +1,80 @@+--  Copyright (C) 2009-2011 Petr Rockai+--+--  BSD3+-- | The plain format implementation resides in this module. The plain format+-- does not use any hashing and basically just wraps a normal filesystem tree+-- in the hashed-storage API.+--+-- NB. The 'read' function on Blobs coming from a plain tree is susceptible to+-- file content changes. Since we use mmap in 'read', this will break+-- referential transparency and produce unexpected results. Please always make+-- sure that all parallel access to the underlying filesystem tree never+-- mutates files. Unlink + recreate is fine though (in other words, the+-- 'writePlainTree' implemented in this module is safe in this respect).+module Darcs.Util.Tree.Plain+    ( -- * Obtaining Trees.+    --+    -- | Please note that Trees obtained this way will contain Stub+    -- items. These need to be executed (they are IO actions) in order to be+    -- accessed. Use 'expand' to do this. However, many operations are+    -- perfectly fine to be used on a stubbed Tree (and it is often more+    -- efficient to do everything that can be done before expanding a Tree).+      readPlainTree++    -- * Writing trees.+    , writePlainTree+    ) where++import Control.Monad ( forM )+import Data.Maybe( catMaybes )+import qualified Data.ByteString.Lazy as BL+import System.FilePath( (</>) )+import System.Directory+    ( createDirectoryIfMissing+    , listDirectory+    , withCurrentDirectory+    )+import System.Posix.Files+    ( getSymbolicLinkStatus, isDirectory, isRegularFile, FileStatus )++import Darcs.Prelude++import Darcs.Util.Path+import Darcs.Util.ByteString ( readSegment )+import Darcs.Util.Tree( Tree(), TreeItem(..)+                          , Blob(..), makeTree+                          , list, readBlob, expand )++readPlainDir :: FilePath -> IO [(FilePath, FileStatus)]+readPlainDir dir =+  withCurrentDirectory dir $ do+    items <- listDirectory "."+    forM items $ \s -> do+      st <- getSymbolicLinkStatus s+      return (s, st)++readPlainTree :: FilePath -> IO (Tree IO)+readPlainTree dir = do+  items <- readPlainDir dir+  let subs = catMaybes [+       let name = either error id $ makeName name'+        in case status of+             _ | isDirectory status -> Just (name, Stub (readPlainTree (dir </> name')) Nothing)+             _ | isRegularFile status -> Just (name, File $ Blob (readBlob' name') Nothing)+             _ -> Nothing+            | (name', status) <- items ]+  return $ makeTree subs+    where readBlob' name = readSegment (dir </> name, Nothing)++-- | Write out /full/ tree to a plain directory structure. If you instead want+-- to make incremental updates, refer to "Darcs.Util.Tree.Monad".+writePlainTree :: Tree IO -> FilePath -> IO ()+writePlainTree t dir = do+  createDirectoryIfMissing True dir+  expand t >>= mapM_ write . list+    where write (p, File b) = write' p b+          write (p, SubTree _) =+              createDirectoryIfMissing True (anchorPath dir p)+          write _ = return ()+          write' p b = readBlob b >>= BL.writeFile (anchorPath dir p)+
+ src/Darcs/Util/URL.hs view
@@ -0,0 +1,149 @@+{-+Copyright (C) 2004 David Roundy++This program is free software; you can redistribute it and/or modify+it under the terms of the GNU General Public License as published by+the Free Software Foundation; either version 2, or (at your option)+any later version.++This program is distributed in the hope that it will be useful,+but WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+GNU General Public License for more details.++You should have received a copy of the GNU General Public License+along with this program; see the file COPYING.  If not, write to+the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,+Boston, MA 02110-1301, USA.+-}++{-|++  Path resolving:++    * An http URL contains the sequence @\"http(s):\/\/\"@.++    * A local filepath does not contain colons, except+      as second character (windows drives) when this+      filepath is meant to be used as repository name++    * A path that is neither an http URL nor a local file+      is an ssh-path.++  Examples:++  > /usr/repo/foo                 -- local file+  > c:/src/darcs                  -- local file+  > http://darcs.net/             -- URL+  > peter@host:/path              -- ssh+  > droundy@host:                 -- ssh+  > host:/path                    -- ssh++  This means that single-letter hosts in ssh-paths do not work,+  unless a username is provided.++  Perhaps ssh-paths should use @\"ssh:\/\/user\@host\/path\"@-syntax instead?++  TODO: This whole module should be re-written using a regex matching library!+  The way we do this here is error-prone and inefficient.+-}++module Darcs.Util.URL (+    isValidLocalPath, isHttpUrl, isSshUrl, isRelative, isAbsolute,+    isSshNopath, SshFilePath, sshRepo, sshUhost, sshFile, sshFilePathOf, splitSshUrl,+    sshCanonRepo+  ) where++import Darcs.Prelude++import Darcs.Util.Global ( darcsdir )+import Data.List ( isPrefixOf, isInfixOf )+import Data.Char ( isSpace )+import qualified System.FilePath as FP+    ( hasDrive+    , isAbsolute+    , isRelative+    , isValid+    , pathSeparators+    )+import System.FilePath ( (</>) )+import System.FilePath.Posix ( joinPath, splitDirectories )++isRelative :: String -> Bool+isRelative "" = error "Empty filename in isRelative"+isRelative f  = FP.isRelative f++isAbsolute :: String -> Bool+isAbsolute "" = error "isAbsolute called with empty filename"+isAbsolute f = FP.isAbsolute f++isValidLocalPath :: String -> Bool+isValidLocalPath s =+  FP.isValid s &&+  (FP.hasDrive s || not (':' `elem` takeWhile (`notElem` FP.pathSeparators) s))++isHttpUrl :: String -> Bool+isHttpUrl u =+    let u' = dropWhile isSpace u in+            ("http://" `isPrefixOf` u') || ("https://" `isPrefixOf` u')+++isSshUrl :: String -> Bool+isSshUrl s = isu' (dropWhile isSpace s)+    where+      isu' s'+          | "ssh://" `isPrefixOf` s' = True+          | "://" `isInfixOf` s' = False+          | isValidLocalPath s' = False+          | otherwise = ":" `isInfixOf` s'++isSshNopath :: String -> Bool+isSshNopath s = case reverse s of+                  ':':x@(_:_:_) -> ':' `notElem` x+                  _ -> False++-- | Given an ssh URL or file path, split it into+-- user@host, repodir, and the file (with any _darcs/ prefix removed)+splitSshUrl :: String -> SshFilePath+splitSshUrl s | "ssh://" `isPrefixOf` s =+  let s' = drop (length "ssh://") $ dropWhile isSpace s+      (dir, file) = cleanrepodir '/' s'+  in+  SshFP { sshUhost = takeWhile (/= '/') s'+        , sshRepo = dir+        , sshFile = file }+splitSshUrl s =+  let (dir, file) = cleanrepodir ':' s in+  SshFP { sshUhost = dropWhile isSpace $ takeWhile (/= ':') s+        , sshRepo = dir+        , sshFile = file }++cleanrepourl :: String -> (String, String)+cleanrepourl zzz | dd `isPrefixOf` zzz = ([], drop (length dd) zzz)+                 where dd = darcsdir++"/"+cleanrepourl (z:zs) =+  let (repo',file) = cleanrepourl zs in+  (z : repo', file)+cleanrepourl "" = ([],[])++cleanrepodir :: Char -> String -> (String, String)+cleanrepodir sep = cleanrepourl . drop 1 . dropWhile (/= sep)++data SshFilePath = SshFP { sshUhost :: String+                         , sshRepo :: String+                         , sshFile :: String }++sshFilePathOf :: SshFilePath -> String+sshFilePathOf (SshFP uhost dir file) = uhost ++ ":" ++ (dir </> darcsdir </> file)++-- | Return a canonical representation of an SSH repo in the format uhost:path+-- Notably, this means the returned string does not contain:+--   - an "ssh://" prefix+--   - any redundant slashes (including all trailing ones)+sshCanonRepo :: SshFilePath -> String+sshCanonRepo (SshFP uhost repo _) =+  uhost ++ ":" ++ (joinPath $ map canondir $ splitDirectories repo)+  where+    canondir [] = ""+    canondir (x:xs) | x == '/' = "/"+                    | otherwise = (x:xs)
+ src/Darcs/Util/ValidHash.hs view
@@ -0,0 +1,177 @@+module Darcs.Util.ValidHash+    ( ValidHash(..)+    , InventoryHash+    , PatchHash+    , PristineHash+    , HashedDir(..)+    , encodeValidHash+    , decodeValidHash+    , parseValidHash+    , getHash+    , getSize+    , fromHash+    , fromSizeAndHash+    , checkHash+    , okayHash -- only used for garbage collection+    ) where++import qualified Data.ByteString as B+import Data.Maybe ( isJust )+import Text.Read ( readMaybe )++import Prelude ( (^) )+import Darcs.Prelude++import Darcs.Util.Hash ( Hash, decodeBase16, decodeHash, encodeHash, sha256strict )+import qualified Darcs.Util.Parser as P++-- | Semantically, this is the type of hashed objects. Git has a type tag+-- inside the hashed file itself, whereas in Darcs the type is determined+-- by the subdirectory.+data HashedDir+  = HashedPristineDir+  | HashedPatchesDir+  | HashedInventoriesDir+  deriving (Eq)++-- | External API for the various hash types.+class (Eq h, IsSizeHash h) => ValidHash h where+  -- | The 'HashedDir' belonging to this type of hash+  dirofValidHash :: h -> HashedDir+  -- | Compute hash from file content.+  calcValidHash :: B.ByteString -> h+  -- default definitions+  calcValidHash content = fromSizeAndHash (B.length content) (sha256strict content)++newtype InventoryHash = InventoryHash SizeHash+  deriving (Eq, Show, IsSizeHash)++instance ValidHash InventoryHash where+  dirofValidHash _ = HashedInventoriesDir++newtype PatchHash = PatchHash SizeHash+  deriving (Eq, Show, IsSizeHash)++instance ValidHash PatchHash where+  dirofValidHash _ = HashedPatchesDir++newtype PristineHash = PristineHash SizeHash+  deriving (Eq, Show, IsSizeHash)++instance ValidHash PristineHash where+  dirofValidHash _ = HashedPristineDir+  -- note: not the default definition here+  calcValidHash = fromHash . sha256strict++encodeValidHash :: ValidHash h => h -> String+encodeValidHash = encodeSizeHash . getSizeHash++decodeValidHash :: ValidHash h => String -> Maybe h+decodeValidHash = fmap fromSizeHash . decodeSizeHash++parseValidHash :: ValidHash h => P.Parser h+parseValidHash = fromSizeHash <$> parseSizeHash++getHash :: ValidHash h => h -> Hash+getHash sh =+  case getSizeHash sh of+    (NoSize h) -> h+    (WithSize _ h) -> h++getSize :: ValidHash h => h -> Maybe Int+getSize sh =+  case getSizeHash sh of+    (NoSize _) -> Nothing+    (WithSize s _) -> Just s++fromHash :: ValidHash h => Hash -> h+fromHash h = fromSizeHash (NoSize h)++numSizeDigits :: Int+numSizeDigits = 10++sizeLimit :: Int+sizeLimit = 10 ^ numSizeDigits++fromSizeAndHash :: ValidHash h => Int -> Hash -> h+fromSizeAndHash size hash =+  fromSizeHash $ if size < sizeLimit then WithSize size hash else NoSize hash++-- | Check that the given 'String' is an encoding of some 'ValidHash'.+okayHash :: String -> Bool+okayHash = isJust . decodeSizeHash++-- | Verify file content against a given 'ValidHash'.+checkHash :: ValidHash h => h -> B.ByteString -> Bool+checkHash vh content =+  -- It is tempting to simplify this to+  --   vh == calcValidHash content+  -- However, since we need to check old-style (sized) pristine hashes,+  -- this would require a non-standard Eq instance for SizeHash.+  case getSizeHash vh of+    NoSize h -> h == hash+    WithSize s h -> s == size && h == hash+  where+    hash = sha256strict content+    size = B.length content++-- * Internal definitions, not exported++-- | Combined size and hash, where the size is optional.+-- The invariant for a valid @'WithSize' size _@ is that+--+-- > size >=0 and size < 'sizeLimit'+data SizeHash+  = WithSize !Int !Hash+  | NoSize !Hash+  deriving (Eq, Show)++-- | Methods to wrap and unwrap 'ValidHash'es+class IsSizeHash h where+  getSizeHash :: h -> SizeHash+  fromSizeHash :: SizeHash -> h++-- This instance is only there so we can derive the instances above+instance IsSizeHash SizeHash where+  getSizeHash = id+  fromSizeHash = id++{-+-- This non-standard Eq instance would allow us to implement 'checkHash'+-- using equality with a freshly calculated hash.+instance Eq SizeHash where+  NoSize h1 == NoSize h2 = h1 == h2+  WithSize s1 h1 == WithSize s2 h2 = s1 == s2 && h1 == h2+  NoSize h1 == WithSize _ h2 = h1 == h2+  WithSize _ h1 == NoSize h2 = h1 == h2+-}++encodeSizeHash :: SizeHash -> String+encodeSizeHash (NoSize hash) = encodeHash hash+encodeSizeHash (WithSize size hash) =+    padZero (show size) ++ '-' : encodeHash hash+  where padZero s = replicate (numSizeDigits - length s) '0' ++ s++decodeSizeHash :: String -> Maybe SizeHash+decodeSizeHash s =+  case splitAt numSizeDigits s of+    (sizeStr, '-':hashStr)+      | Just size <- decodeSize sizeStr -> WithSize size <$> decodeHash hashStr+    _ -> NoSize <$> decodeHash s+  where+    decodeSize :: String -> Maybe Int+    decodeSize ss =+      case readMaybe ss of+        Just size | size >= 0 && size < sizeLimit -> Just size+        _ -> Nothing++parseSizeHash :: P.Parser SizeHash+parseSizeHash =+    (WithSize <$> pSize <*> pNoSize) P.<|> (NoSize <$> pNoSize)+  where+    pSize = do+      P.lookAhead (P.take numSizeDigits >> P.char '-')+      P.unsigned <* P.char '-'+    pNoSize = do+      x <- P.take 64+      maybe (fail "expecting b16-encoded sha256 hash") return (decodeBase16 x)
+ src/Darcs/Util/Workaround.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE CPP #-}++-- |+-- Module      : Darcs.Util.Workaround+-- Copyright   : 2008 David Roundy <droundy@darcs.net>+-- License     : GPL+-- Maintainer  : darcs-devel@darcs.net+-- Stability   : experimental+-- Portability : portable++module Darcs.Util.Workaround+    ( setExecutable+    , getCurrentDirectory+    , installHandler+    , raiseSignal+    , Handler(..)+    , Signal+    , sigINT+    , sigHUP+    , sigABRT+    , sigALRM+    , sigTERM+    , sigPIPE+    ) where++import Darcs.Prelude++#ifdef WIN32++import qualified System.Directory ( getCurrentDirectory, canonicalizePath )++#else++import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal,+                            sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE)+import System.Directory ( getCurrentDirectory )+import System.Posix.Files (fileMode,getFileStatus, setFileMode,+                           setFileCreationMask,+                           ownerReadMode, ownerWriteMode, ownerExecuteMode,+                           groupReadMode, groupWriteMode, groupExecuteMode,+                           otherReadMode, otherWriteMode, otherExecuteMode)+import Data.Bits ( (.&.), (.|.), complement )++#endif++#ifdef WIN32+-- Dummy implementation of POSIX signals+data Handler = Default+             | Ignore+             | Catch (IO ())++type Signal = Int++installHandler :: Signal+               -> Handler+               -> Maybe ()+               -> IO ()+installHandler _ _ _ = return ()+++raiseSignal :: Signal -> IO ()+raiseSignal _ = return ()+++sigINT :: Signal+sigINT = 0++-- not used: sigKILL = 0++sigHUP :: Signal+sigHUP = 0++-- not used: sigQUIT = 0++sigABRT :: Signal+sigABRT = 0++sigTERM :: Signal+sigTERM = 0++sigPIPE :: Signal+sigPIPE = 0++sigALRM :: Signal+sigALRM = 0+++setExecutable :: FilePath+              -> Bool+              -> IO ()+setExecutable _ _ = return ()+++-- | System.Directory.getCurrentDirectory returns a path with backslashes in it+-- under windows, and some of the code gets confused by that, so we override+-- getCurrentDirectory and translates '\\' to '/'+getCurrentDirectory :: IO FilePath+getCurrentDirectory = do+    d <- System.Directory.getCurrentDirectory >>= System.Directory.canonicalizePath+    return $ map rb d+  where+    rb '\\' = '/'+    rb c = c++#else+++setExecutable :: FilePath+              -> Bool+              -> IO ()+setExecutable f ex = do+    st <- getFileStatus f+    umask <- setFileCreationMask 0+    _ <- setFileCreationMask umask+    let rw = fileMode st .&.+             (ownerReadMode .|. ownerWriteMode .|.+              groupReadMode .|. groupWriteMode .|.+              otherReadMode .|. otherWriteMode)+        total = if ex then rw .|.+                          ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)+                           .&. complement umask)+                      else rw+    setFileMode f total++#endif
− src/Darcs/Utils.hs 
@@ -1,528 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---- |--- Module      : Exec--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable------ Various utility functions that do not belong anywhere else.--module Darcs.Utils-    (-      ortryrunning-    , nubsort-    , breakCommand-    , showHexLen-    , maybeGetEnv-    , formatPath-    -- * Monads-    , firstJustIO-    -- * User prompts-    , askEnter-    , askUser-    , askUserListItem-    , PromptConfig(..)-    , promptYorn-    , promptChar-    -- * Text-    , getViewer-    , editFile-    , runEditor-    , stripCr-    -- * Help-    , environmentHelpEditor-    , environmentHelpPager-    -- * Errors and exceptions-    , catchall-    , clarifyErrors-    , prettyException-    , prettyError-    , addToErrorLoc-    -- * Files and directories-    , getFileStatus-    , withCurrentDirectory-    , withUMask-    --  * Locales-    , setDarcsEncodings-    , getSystemEncoding-    , isUTF8Locale-    -- * Tree filtering.-    , filterFilePaths-    , filterPaths-    -- * Tree lookup.-    , treeHas-    , treeHasDir-    , treeHasFile-    , treeHasAnycase-    ) where---import Prelude hiding ( catch )--import Control.Exception.Extensible-             ( bracket, bracket_, catch, try,-               IOException, SomeException, Exception(fromException) )-import Control.Monad ( when, forM )-import Control.Monad.Error( MonadError )-import Control.Monad.State.Strict( gets )--import qualified Data.ByteString as B ( readFile )-import qualified Data.ByteString.Char8 as BSC--import Data.Char ( toUpper, toLower, isSpace )-import Data.List ( group, sort )-import Data.Maybe ( isJust )--import Foreign.C.String ( CString, withCString, peekCString )-import Foreign.C.Error ( throwErrno )-import Foreign.C.Types ( CInt(..) )--#ifdef FORCE_CHAR8_ENCODING-import GHC.IO.Encoding ( setFileSystemEncoding, setForeignEncoding, char8 )-#endif--import Storage.Hashed.AnchoredPath( AnchoredPath(..), Name(..), isPrefix, floatPath )-import Storage.Hashed.Monad( withDirectory, fileExists, directoryExists-                           , virtualTreeMonad, currentDirectory-                           , TreeMonad )-import qualified Storage.Hashed.Monad as HS ( exists, tree )--import Storage.Hashed.Tree( Tree, listImmediate, findTree )--import System.Console.Haskeline ( runInputT, defaultSettings, getInputLine,-                                  getInputChar, outputStr, outputStrLn )-import System.Directory ( doesFileExist )-import System.Environment ( getEnv )-import System.Exit ( ExitCode(..) )-import System.IO.Error ( annotateIOError, isUserError, ioeGetErrorString-                       , isDoesNotExistError, ioeGetFileName )-import System.Posix.Files( getSymbolicLinkStatus, FileStatus )--import Text.Regex--import Darcs.RepoPath ( FilePathLike, getCurrentDirectory, setCurrentDirectory, toFilePath )-import Darcs.SignalHandler ( catchNonSignal )--import Exec ( execInteractive )-import Numeric ( showHex )-import Progress ( withoutProgress )---showHexLen :: (Integral a, Show a)-           => Int-           -> a-           -> String-showHexLen n x = let s = showHex x ""-                 in replicate (n - length s) ' ' ++ s---addToErrorLoc :: IOException-              -> String-              -> IOException-addToErrorLoc ioe s = annotateIOError ioe s Nothing Nothing---catchall :: IO a-         -> IO a-         -> IO a-a `catchall` b = a `catchNonSignal` (\_ -> b)---maybeGetEnv :: String-            -> IO (Maybe String)-maybeGetEnv s = fmap Just (getEnv s) `catchall` return Nothing -- err can only be isDoesNotExist----- | The firstJustM returns the first Just entry in a list of monadic--- operations. This is close to `listToMaybe `fmap` sequence`, but the sequence--- operator evaluates all monadic members of the list before passing it along--- (i.e. sequence is strict). The firstJustM is lazy in that list member monads--- are only evaluated up to the point where the first Just entry is obtained.-firstJustM :: Monad m-           => [m (Maybe a)]-           -> m (Maybe a)-firstJustM [] = return Nothing-firstJustM (e:es) = e >>= (\v -> if isJust v then return v else firstJustM es)----- | The firstJustIO is a slight modification to firstJustM: the entries in the--- list must be IO monad operations and the firstJustIO will silently turn any--- monad call that throws an exception into Nothing, basically causing it to be--- ignored.-firstJustIO :: [IO (Maybe a)]-            -> IO (Maybe a)-firstJustIO = firstJustM . map (`catchall` return Nothing)---clarifyErrors :: IO a-              -> String-              -> IO a-clarifyErrors a e = a `catch` (\x -> fail $ unlines [prettyException x,e])---prettyException :: SomeException-                -> String-prettyException e | Just ioe <- fromException e, isUserError ioe = ioeGetErrorString ioe-prettyException e | Just ioe <- fromException e, isDoesNotExistError ioe =-  case ioeGetFileName ioe of-    Just f  -> f ++ " does not exist"-    Nothing -> show e-prettyException e = show e---prettyError :: IOError -> String-prettyError e | isUserError e = ioeGetErrorString e-              | otherwise = show e----- | Given two shell commands as arguments, execute the former.  The--- latter is then executed if the former failed because the executable--- wasn't found (code 127), wasn't executable (code 126) or some other--- exception occurred.  Other failures (such as the user holding ^C)--- do not cause the second command to be tried.-ortryrunning :: IO ExitCode-             -> IO ExitCode-             -> IO ExitCode-a `ortryrunning` b = do-  ret <- try a-  case ret of-    (Right (ExitFailure 126)) -> b -- command not executable-    (Right (ExitFailure 127)) -> b -- command not found-#ifdef WIN32-    (Right (ExitFailure 9009)) -> b -- command not found by cmd.exe on Windows-#endif-    (Right x) -> return x          -- legitimate success/failure-    (Left (_ :: SomeException)) -> b  -- an exception---withCurrentDirectory :: FilePathLike p-                     => p-                     -> IO a-                     -> IO a-withCurrentDirectory name m =-    bracket-        (do cwd <- getCurrentDirectory-            when (toFilePath name /= "") (setCurrentDirectory name)-            return cwd)-        (\oldwd -> setCurrentDirectory oldwd `catchall` return ())-        (const m)---foreign import ccall unsafe "umask.h set_umask" set_umask-    :: CString -> IO CInt-foreign import ccall unsafe "umask.h reset_umask" reset_umask-    :: CInt -> IO CInt---withUMask :: String-          -> IO a-          -> IO a-withUMask umask job =-    do rc <- withCString umask set_umask-       when (rc < 0) (throwErrno "Couldn't set umask")-       bracket_-           (return ())-           (reset_umask rc)-           job----- | Ask the user for a line of input.-askUser :: String    -- ^ The prompt to display-        -> IO String -- ^ The string the user entered.-askUser prompt = withoutProgress $ runInputT defaultSettings $-                    getInputLine prompt-                        >>= maybe (error "askUser: unexpected end of input") return---- | Ask the user to press Enter-askEnter :: String  -- ^ The prompt to display-         -> IO ()-askEnter prompt = askUser prompt >> return ()---- | @askUserListItem prompt xs@ enumerates @xs@ on the screen, allowing---   the user to choose one of the items-askUserListItem :: String-                -> [String]-                -> IO String-askUserListItem prompt xs = withoutProgress $ runInputT defaultSettings $ do-    outputStr . unlines $ zipWith (\n x -> show n ++ ". " ++ x) [1::Int ..] xs-    loop-  where-    loop = do-      answer <- getInputLine prompt-                  >>= maybe (error "askUser: unexpected end of input") return-      case maybeRead answer of-        Just n | n > 0 && n <= length xs -> return (xs !! (n-1))-        _ -> outputStrLn "Invalid response, try again!" >> loop---maybeRead :: Read a-          => String-          -> Maybe a-maybeRead s = case reads s of-    [(x, rest)] | all isSpace rest -> Just x-    _         -> Nothing---stripCr :: String-        -> String-stripCr ""     = ""-stripCr "\r"   = ""-stripCr (c:cs) = c : stripCr cs----- | Format a path for screen output, so that the user sees where the path--- begins and ends. Could (should?) also warn about unprintable characters here.-formatPath :: String-           -> String-formatPath path = "\"" ++ quote path ++ "\""-    where quote "" = ""-          quote (c:cs) = if c `elem` ['\\', '"']-                         then '\\':c:quote cs-                         else c:quote cs---breakCommand :: String -> (String, [String])-breakCommand s = case words s of-                   (arg0:args) -> (arg0,args)-                   [] -> (s,[])---nubsort :: Ord a-        => [a]-        -> [a]-nubsort = map head . group . sort----- | @editFile f@ lets the user edit a file which could but does not need to--- already exist. This function returns the exit code from the text editor and a--- flag indicating if the user made any changes.-editFile :: FilePathLike p-         => p-         -> IO (ExitCode, Bool)-editFile ff = do-    old_content <- file_content-    ec <- runEditor f-    new_content <- file_content-    return (ec, new_content /= old_content)-  where-    f = toFilePath ff-    file_content = do-      exists <- doesFileExist f-      if exists then do content <- B.readFile f-                        return $ Just content-                else return Nothing---runEditor :: FilePath-          -> IO ExitCode-runEditor f = do-    ed <- getEditor-    execInteractive ed f-         `ortryrunning` execInteractive "emacs" f-         `ortryrunning` execInteractive "emacs -nw" f-         `ortryrunning` execInteractive "nano" f-#ifdef WIN32-         `ortryrunning` execInteractive "edit" f-#endif---getEditor :: IO String-getEditor = getEnv "DARCS_EDITOR" `catchall`-             getEnv "DARCSEDITOR" `catchall`-             getEnv "VISUAL" `catchall`-             getEnv "EDITOR" `catchall` return "vi"---environmentHelpEditor :: ([String], [String])-environmentHelpEditor = (["DARCS_EDITOR", "DARCSEDITOR", "VISUAL", "EDITOR"],[- "To edit a patch description of email comment, Darcs will invoke an",- "external editor.  Your preferred editor can be set as any of the",- "environment variables $DARCS_EDITOR, $DARCSEDITOR, $VISUAL or $EDITOR.",- "If none of these are set, vi(1) is used.  If vi crashes or is not",- "found in your PATH, emacs, emacs -nw, nano and (on Windows) edit are",- "each tried in turn."])---getViewer :: IO String-getViewer = getEnv "DARCS_PAGER" `catchall`-             getEnv "PAGER" `catchall` return "less"--environmentHelpPager :: ([String], [String])-environmentHelpPager = (["DARCS_PAGER", "PAGER"],[- "Darcs will sometimes invoke a pager if it deems output to be too long",- "to fit onscreen.  Darcs will use the pager specified by $DARCS_PAGER",- "or $PAGER.  If neither are set, `less' will be used."])--data PromptConfig = PromptConfig { pPrompt :: String-                                 , pBasicCharacters :: [Char]-                                 , pAdvancedCharacters :: [Char] -- ^ only shown on help-                                 , pDefault :: Maybe Char-                                 , pHelp    :: [Char]-                                 }----- | Prompt the user for a yes or no-promptYorn :: [Char] -> IO Bool-promptYorn p = (== 'y') `fmap` promptChar (PromptConfig p "yn" [] Nothing [])---promptChar :: PromptConfig -> IO Char-promptChar (PromptConfig p basic_chs adv_chs md help_chs) =-  withoutProgress $ runInputT defaultSettings loopChar- where- chs = basic_chs ++ adv_chs- loopChar = do-    let chars = setDefault (basic_chs ++ (if null adv_chs then "" else "..."))-        prompt = p ++ " [" ++ chars ++ "]" ++ helpStr-    a <- getInputChar prompt >>= maybe (error "promptChar: unexpected end of input")-                                    return-    case () of-     _ | a `elem` chs                   -> return a-       | a == ' '                       -> maybe tryAgain return md-       | a `elem` help_chs              -> return a-       | otherwise                      -> tryAgain- helpStr = case help_chs of-           []                      -> ""-           (h:_) | null adv_chs    -> ", or " ++ (h:" for help: ")-                 | otherwise       -> ", or " ++ (h:" for more options: ")- tryAgain = do outputStrLn "Invalid response, try again!"-               loopChar- setDefault s = case md of Nothing -> s-                           Just d  -> map (setUpper d) s- setUpper d c = if d == c then toUpper c else c----- | Construct a filter from a list of AnchoredPaths, that will accept any path--- that is either a parent or a child of any of the listed paths, and discard--- everything else.-filterPaths :: [AnchoredPath]-            -> AnchoredPath-            -> t-            -> Bool-filterPaths files p _ = any (\x -> x `isPrefix` p || p `isPrefix` x) files----- | Same as 'filterPath', but for ordinary 'FilePath's (as opposed to--- AnchoredPath).-filterFilePaths :: [FilePath]-                -> AnchoredPath-                -> t-                -> Bool-filterFilePaths = filterPaths . map floatPath---getFileStatus :: FilePath-              -> IO (Maybe FileStatus)-getFileStatus f =-  Just `fmap` getSymbolicLinkStatus f `catchall` return Nothing---treeHasAnycase :: (MonadError e m, Functor m, Monad m)-               => Tree m-               -> FilePath-               -> m Bool-treeHasAnycase tree path =-    fst `fmap` virtualTreeMonad (existsAnycase $ floatPath path) tree---existsAnycase :: (MonadError e m, Functor m, Monad m)-              => AnchoredPath-              -> TreeMonad m Bool-existsAnycase (AnchoredPath []) = return True-existsAnycase (AnchoredPath (Name x:xs)) = do-  do wd <- currentDirectory-     Just tree <- gets (flip findTree wd . HS.tree)-     let subs = [ AnchoredPath [Name n] | (Name n, _) <- listImmediate tree,-                                          BSC.map toLower n == BSC.map toLower x ]-     or `fmap` forM subs (\path -> do-       file <- fileExists path-       if file then return True-               else withDirectory path (existsAnycase $ AnchoredPath xs))---treeHas :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool-treeHas tree path = fst `fmap` virtualTreeMonad (HS.exists $ floatPath path) tree--treeHasDir :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool-treeHasDir tree path = fst `fmap` virtualTreeMonad (directoryExists $ floatPath path) tree--treeHasFile :: (MonadError e m, Functor m, Monad m) => Tree m -> FilePath -> m Bool-treeHasFile tree path = fst `fmap` virtualTreeMonad (fileExists $ floatPath path) tree---- | In some environments, darcs requires that certain global GHC library variables that--- control the encoding used in internal translations are set to specific values.------ @setDarcsEncoding@ enforces those settings, and should be called before the--- first time any darcs operation is run, and again if anything else might have--- set those encodings to different values.------ Note that it isn't thread-safe and has a global effect on your program.------ The current behaviour of this function is as follows, though this may--- change in future:------ Encodings are only set on GHC 7.4 and up, on any non-Windows platform.------ Two encodings are set, both to @GHC.IO.Encoding.char8@:--- @GHC.IO.Encoding.setFileSystemEncoding@ and @GHC.IO.Encoding.setForeignEncoding@.----setDarcsEncodings :: IO ()-setDarcsEncodings = do-#ifdef FORCE_CHAR8_ENCODING---- This is needed for appropriate behaviour from getArgs and from general--- filesystem calls (e.g. getDirectoryContents, readFile, ...)-    setFileSystemEncoding char8---- This ensures that foreign calls made by hashed-storage to stat--- filenames returned from getDirectoryContents are translated appropriately-    setForeignEncoding char8--#endif-    return ()---- The following functions are copied from the encoding package (BSD3--- licence, by Henning Günther).---- | @getSystemEncoding@ fetches the current encoding from locale-foreign import ccall "system_encoding.h get_system_encoding"-     get_system_encoding :: IO CString---getSystemEncoding :: IO String-getSystemEncoding = do-    enc <- get_system_encoding-    peekCString enc----- | @isUTF8@ checks if an encoding is UTF-8 (or ascii, since it is a--- subset of UTF-8).-isUTF8Locale :: String -> Bool-isUTF8Locale codeName = case (normalizeEncoding codeName) of-    -- ASCII-    "ascii"              -> True-    "646"                -> True-    "ansi_x3_4_1968"     -> True-    "ansi_x3.4_1986"     -> True-    "cp367"              -> True-    "csascii"            -> True-    "ibm367"             -> True-    "iso646_us"          -> True-    "iso_646.irv_1991"   -> True-    "iso_ir_6"           -> True-    "us"                 -> True-    "us_ascii"           -> True-    -- UTF-8-    "utf_8"              -> True-    "u8"                 -> True-    "utf"                -> True-    "utf8"               -> True-    "utf8_ucs2"          -> True-    "utf8_ucs4"          -> True-    -- Everything else-    _                    -> False-  where-    normalizeEncoding s = map toLower $ subRegex sep s "_"-    sep = mkRegex "[^0-9A-Za-z]+"
− src/Darcs/Witnesses/Eq.hs 
@@ -1,54 +0,0 @@-#include "gadts.h"-module Darcs.Witnesses.Eq (-  EqCheck(..), MyEq(..), isIsEq-) where--import Darcs.Witnesses.Unsafe ( unsafeCoerceP )---- |'EqCheck' is used to pass around evidence (or lack thereof) of--- two witness types being equal.-data EqCheck C(a b) where-    IsEq :: EqCheck C(a a)-    NotEq :: EqCheck C(a b)--instance Eq (EqCheck C(a b)) where-    IsEq == IsEq = True-    NotEq == NotEq = True-    _ == _ = False--instance Show (EqCheck C(a b)) where-    show IsEq = "IsEq"-    show NotEq = "NotEq"---- |An witness aware equality class.--- A minimal definition defines any one of 'unsafeCompare', '=\/=' and '=/\='.-class MyEq p where-    -- |It is unsafe to define a class instance via this method, because-    -- if it returns True then the default implementations of '=\/=' and '=/\='-    -- will coerce the equality of two witnesses.-    ---    -- Calling this method is safe, although '=\/=' or '=/\=' would be better-    -- choices as it is not usually meaningul to compare two patches that-    -- don't share either a starting or an ending context-    unsafeCompare :: p C(a b) -> p C(c d) -> Bool-    unsafeCompare a b = IsEq == (a =/\= unsafeCoerceP b)--    -- |Compare two things with the same starting witness. If the things-    -- compare equal, evidence of the ending witnesses being equal will-    -- be returned.-    (=\/=) :: p C(a b) -> p C(a c) -> EqCheck C(b c)-    a =\/= b | unsafeCompare a b = unsafeCoerceP IsEq-             | otherwise = NotEq--    -- |Compare two things with the same ending witness. If the things-    -- compare equal, evidence of the starting witnesses being equal will-    -- be returned.-    (=/\=) :: p C(a c) -> p C(b c) -> EqCheck C(a b)-    a =/\= b | IsEq == (a =\/= unsafeCoerceP b) = unsafeCoerceP IsEq-             | otherwise = NotEq--infix 4 =\/=, =/\=--isIsEq :: EqCheck C(a b) -> Bool-isIsEq IsEq = True-isIsEq NotEq = False
− src/Darcs/Witnesses/Ordered.hs 
@@ -1,301 +0,0 @@--- Copyright (C) 2007 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"--module Darcs.Witnesses.Ordered ( (:>)(..), (:<)(..), (:\/:)(..), (:/\:)(..), (:||:)(..),-                             FL(..), RL(..),-                             lengthFL, mapFL, mapFL_FL, spanFL, foldlFL, allFL, anyFL,-                             filterFL,-                             splitAtFL, splitAtRL, bunchFL, foldlRL,-                             lengthRL, isShorterThanRL, mapRL, mapRL_RL, zipWithFL,-                             filterFLFL,-                             filterRL,-                             reverseFL, reverseRL, (+>+), (+<+),-                             nullFL, concatFL, concatRL,-                             consRLSealed, nullRL, toFL,-                             dropWhileFL, dropWhileRL,-                             spanFL_M,-                             eqFL, eqFLRev, eqFLUnsafe-                           ) where--#include "impossible.h"-import Darcs.Witnesses.Show-import Darcs.Witnesses.Sealed ( FlippedSeal(..), flipSeal, Sealed(..), FreeLeft, unFreeLeft, Sealed2(..),-                                seal )-import Darcs.Witnesses.Eq ( MyEq(..), EqCheck(..) )--data (a1 :> a2) C(x y) = FORALL(z) (a1 C(x z)) :> (a2 C(z y))-infixr 1 :>-data (a1 :< a2) C(x y) = FORALL(z) (a1 C(z y)) :< (a2 C(x z))-infix 1 :<-infix 1 :/\:, :\/:, :||:-data (a1 :\/: a2) C(x y) = FORALL(z) (a1 C(z x)) :\/: (a2 C(z y))-data (a1 :/\: a2) C(x y) = FORALL(z) (a1 C(x z)) :/\: (a2 C(y z))-data (a1 :||: a2) C(x y) = (a1 C(x y)) :||: (a2 C(x y))--instance (Show2 a, Show2 b) => Show ( (a :> b) C(x y) ) where-    showsPrec d (x :> y) = showOp2 1 ":>" d x y--instance (MyEq a, MyEq b) => MyEq (a :> b) where-    (a1 :> b1) =\/= (a2 :> b2) | IsEq <- a1 =\/= a2 = b1 =\/= b2-                               | otherwise = NotEq--instance (MyEq a, MyEq b) => Eq ((a :> b) C(x y)) where-    (==) = unsafeCompare--instance (MyEq a, MyEq b) => MyEq (a :< b) where-    (a1 :< b1) =\/= (a2 :< b2) | IsEq <- b1 =\/= b2 = a1 =\/= a2-                               | otherwise = NotEq--instance (MyEq a, MyEq b) => Eq ((a :< b) C(x y)) where-    (==) = unsafeCompare--instance (Show2 a, Show2 b) => Show2 (a :> b) where-    showDict2 = ShowDictClass--instance (Show2 a, Show2 b) => Show ( (a :\/: b) C(x y) ) where-    showsPrec d (x :\/: y) = showOp2 9 ":\\/:" d x y--instance (Show2 a, Show2 b) => Show2 (a :\/: b) where-    showDict2 = ShowDictClass--infixr 5 :>:, :<:, +>+, +<+---- forward list-data FL a C(x z) where-    (:>:) :: a C(x y) -> FL a C(y z) -> FL a C(x z)-    NilFL :: FL a C(x x)--instance Show2 a => Show (FL a C(x z)) where-   showsPrec _ NilFL = showString "NilFL"-   showsPrec d (x :>: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .-                            showString " :>: " . showsPrec (prec + 1) xs-       where prec = 5--instance Show2 a => Show1 (FL a C(x)) where-   showDict1 = ShowDictClass--instance Show2 a => Show2 (FL a) where-   showDict2 = ShowDictClass--instance Show2 a => Show (RL a C(x z)) where-   showsPrec _ NilRL = showString "NilRL"-   showsPrec d (x :<: xs) = showParen (d > prec) $ showsPrec2 (prec + 1) x .-                            showString " :<: " . showsPrec (prec + 1) xs-       where prec = 5--instance Show2 a => Show1 (RL a C(x)) where-   showDict1 = ShowDictClass--instance Show2 a => Show2 (RL a) where-   showDict2 = ShowDictClass--instance (Show2 a, Show2 b) => Show1 ((a :> b) C(x)) where-   showDict1 = ShowDictClass---- reverse list-data RL a C(x z) where-    (:<:) :: a C(y z) -> RL a C(x y) -> RL a C(x z)-    NilRL :: RL a C(x x)--nullFL :: FL a C(x z) -> Bool-nullFL NilFL = True-nullFL _ = False--nullRL :: RL a C(x z) -> Bool-nullRL NilRL = True-nullRL _ = False--filterFLFL :: (FORALL(x y) p C(x y) -> EqCheck C(x y)) -> FL p C(w z) -> FL p C(w z)-filterFLFL _ NilFL = NilFL-filterFLFL f (x:>:xs) | IsEq <- f x = filterFLFL f xs-                    | otherwise = x :>: filterFLFL f xs--filterRL :: (FORALL(x y) p C(x y) -> Bool) -> RL p C(a b) ->  [Sealed2 p]-filterRL _ NilRL = []-filterRL f (x :<: xs) | f x = Sealed2 x : (filterRL f xs)-                      | otherwise = filterRL f xs--(+>+) :: FL a C(x y) -> FL a C(y z) -> FL a C(x z)-NilFL +>+ ys = ys-(x:>:xs) +>+ ys = x :>: xs +>+ ys--(+<+) :: RL a C(y z) -> RL a C(x y) -> RL a C(x z)-NilRL +<+ ys = ys-(x:<:xs) +<+ ys = x :<: xs +<+ ys--reverseFL :: FL a C(x z) -> RL a C(x z)-reverseFL xs = r NilRL xs-  where r :: RL a C(l m) -> FL a C(m o) -> RL a C(l o)-        r ls NilFL = ls-        r ls (a:>:as) = r (a:<:ls) as--reverseRL :: RL a C(x z) -> FL a C(x z)-reverseRL xs = r NilFL xs -- r (xs :> NilFL)-  where r :: FL a C(m o) -> RL a C(l m) -> FL a C(l o)-        r ls NilRL = ls-        r ls (a:<:as) = r (a:>:ls) as--concatFL :: FL (FL a) C(x z) -> FL a C(x z)-concatFL NilFL = NilFL-concatFL (a:>:as) = a +>+ concatFL as--concatRL :: RL (RL a) C(x z) -> RL a C(x z)-concatRL NilRL = NilRL-concatRL (a:<:as) = a +<+ concatRL as--spanFL :: (FORALL(w y) a C(w y) -> Bool) -> FL a C(x z) -> (FL a :> FL a) C(x z)-spanFL f (x:>:xs) | f x = case spanFL f xs of-                            ys :> zs -> (x:>:ys) :> zs-spanFL _ xs = NilFL :> xs--spanFL_M :: forall a m C(x z). Monad m =>-            (FORALL(w y) a C(w y) -> m Bool) -> FL a C(x z)-            -> m ((FL a :> FL a) C(x z))-spanFL_M f (x:>:xs) =-    do-      continue <- f x-      if continue-       then do (ys :> zs) <- spanFL_M f xs-               return $ (x :>: ys) :> zs-       else return $ NilFL :> (x :>: xs)--spanFL_M _ (NilFL) = return $ NilFL :> NilFL--splitAtFL :: Int -> FL a C(x z) -> (FL a :> FL a) C(x z)-splitAtFL 0 xs = NilFL :> xs-splitAtFL _ NilFL = NilFL :> NilFL-splitAtFL n (x:>:xs) = case splitAtFL (n-1) xs of-                       (xs':>xs'') -> (x:>:xs' :> xs'')--splitAtRL :: Int -> RL a C(x z) -> (RL a :< RL a) C(x z)-splitAtRL 0 xs = NilRL :< xs-splitAtRL _ NilRL = NilRL :< NilRL-splitAtRL n (x:<:xs) = case splitAtRL (n-1) xs of-                       (xs':<xs'') -> (x:<:xs' :< xs'')---- 'bunchFL n' groups patches into batches of n, except that it always puts--- the first patch in its own group, this being a recognition that the--- first patch is often *very* large.--bunchFL :: Int -> FL a C(x y) -> FL (FL a) C(x y)-bunchFL _ NilFL = NilFL-bunchFL n (x:>:xs) = (x :>: NilFL) :>: bFL xs-    where bFL :: FL a C(x y) -> FL (FL a) C(x y)-          bFL NilFL = NilFL-          bFL bs = case splitAtFL n bs of-                   a :> b -> a :>: bFL b---allFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool-allFL f xs = and $ mapFL f xs--anyFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> Bool-anyFL f xs = or $ mapFL f xs--foldlFL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> FL b C(x z) -> a-foldlFL _ x NilFL = x-foldlFL f x (y:>:ys) = foldlFL f (f x y) ys--foldlRL :: (FORALL(w y) a -> b C(w y) -> a) -> a -> RL b C(x z) -> a-foldlRL _ x NilRL = x-foldlRL f x (y:<:ys) = foldlRL f (f x y) ys--mapFL_FL :: (FORALL(w y) a C(w y) -> b C(w y)) -> FL a C(x z) -> FL b C(x z)-mapFL_FL _ NilFL = NilFL-mapFL_FL f (a:>:as) = f a :>: mapFL_FL f as--zipWithFL :: (FORALL(x y) a -> p C(x y) -> q C(x y))-          -> [a] -> FL p C(w z) -> FL q C(w z)-zipWithFL f (x:xs) (y :>: ys) = f x y :>: zipWithFL f xs ys-zipWithFL _ _ NilFL = NilFL-zipWithFL _ [] (_:>:_) = bug "zipWithFL called with too short a list"--mapRL_RL :: (FORALL(w y) a C(w y) -> b C(w y)) -> RL a C(x z) -> RL b C(x z)-mapRL_RL _ NilRL = NilRL-mapRL_RL f (a:<:as) = f a :<: mapRL_RL f as--mapFL :: (FORALL(w z) a C(w z) -> b) -> FL a C(x y) -> [b]-mapFL _ NilFL = []-mapFL f (a :>: b) = f a : mapFL f b--filterFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(w z) -> [Sealed2 a]-filterFL _ NilFL = []-filterFL f (a :>: b) = if f a-                       then (Sealed2 a):(filterFL f b)-                       else filterFL f b--mapRL :: (FORALL(w z) a C(w z) -> b) -> RL a C(x y) -> [b]-mapRL _ NilRL = []-mapRL f (a :<: b) = f a : mapRL f b--lengthFL :: FL a C(x z) -> Int-lengthFL xs = l xs 0-  where l :: FL a C(x z) -> Int -> Int-        l NilFL n = n-        l (_:>:as) n = l as $! n+1--lengthRL :: RL a C(x z) -> Int-lengthRL xs = l xs 0-  where l :: RL a C(x z) -> Int -> Int-        l NilRL n = n-        l (_:<:as) n = l as $! n+1--isShorterThanRL :: RL a C(x y) -> Int -> Bool-isShorterThanRL _ n | n <= 0 = False-isShorterThanRL NilRL _ = True-isShorterThanRL (_:<:xs) n = isShorterThanRL xs (n-1)--consRLSealed :: a C(y z) -> FlippedSeal (RL a) C(y) -> FlippedSeal (RL a) C(z)-consRLSealed a (FlippedSeal as) = flipSeal $ a :<: as--toFL :: [FreeLeft a] -> Sealed (FL a C(x))-toFL [] = Sealed NilFL-toFL (x:xs) = case unFreeLeft x of Sealed y -> case toFL xs of Sealed ys -> Sealed (y :>: ys)--dropWhileFL :: (FORALL(x y) a C(x y) -> Bool) -> FL a C(r v) -> FlippedSeal (FL a) C(v)-dropWhileFL _ NilFL       = flipSeal NilFL-dropWhileFL p xs@(x:>:xs')-          | p x       = dropWhileFL p xs'-          | otherwise = flipSeal xs--dropWhileRL :: (FORALL(x y) a C(x y) -> Bool) -> RL a C(r v) -> Sealed (RL a C(r))-dropWhileRL _ NilRL = seal NilRL-dropWhileRL p xs@(x:<:xs')-          | p x       = dropWhileRL p xs'-          | otherwise = seal xs---- |Check that two 'FL's are equal element by element.--- This differs from the 'MyEq' instance for 'FL' which--- uses commutation.-eqFL :: MyEq a => FL a C(x y) -> FL a C(x z) -> EqCheck C(y z)-eqFL NilFL NilFL = IsEq-eqFL (x:>:xs) (y:>:ys) | IsEq <- x =\/= y, IsEq <- eqFL xs ys = IsEq-eqFL _ _ = NotEq--eqFLRev :: MyEq a => FL a C(x z) -> FL a C(y z) -> EqCheck C(x y)-eqFLRev NilFL NilFL = IsEq-eqFLRev (x:>:xs) (y:>:ys) | IsEq <- eqFLRev xs ys, IsEq <- x =/\= y = IsEq-eqFLRev _ _ = NotEq--eqFLUnsafe :: MyEq a => FL a C(x y) -> FL a C(z w) -> Bool-eqFLUnsafe NilFL NilFL = True-eqFLUnsafe (x:>:xs) (y:>:ys) = unsafeCompare x y && eqFLUnsafe xs ys-eqFLUnsafe _ _ = False
− src/Darcs/Witnesses/Sealed.hs 
@@ -1,153 +0,0 @@--- Copyright (C) 2007 David Roundy, 2009 Ganesh Sittampalam------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, FlexibleInstances #-}--#include "gadts.h"--module Darcs.Witnesses.Sealed ( Sealed(..), seal, unseal, mapSeal,-                      unsafeUnseal, unsafeUnsealFlipped, unsafeUnseal2,-                      Sealed2(..), seal2, unseal2, mapSeal2,-                      FlippedSeal(..), flipSeal, unsealFlipped, mapFlipped,-                      unsealM, liftSM,-                      Gap(..), FreeLeft, unFreeLeft, FreeRight, unFreeRight-                    ) where-import Darcs.Witnesses.Eq ( MyEq, EqCheck(..) )-import Darcs.Witnesses.Show-import Darcs.Witnesses.Eq ( (=\/=) )-import Darcs.Witnesses.Unsafe ( unsafeCoerceP1, unsafeCoerceP )--data Sealed a where-    Sealed :: a C(x ) -> Sealed a--seal :: a C(x ) -> Sealed a-seal = Sealed--instance MyEq a => Eq (Sealed (a C(x ))) where-    Sealed x == Sealed y | IsEq <- x =\/= y = True-                         | otherwise = False--data Sealed2 a where-    Sealed2 :: !(a C(x y )) -> Sealed2 a--seal2 :: a C(x y ) -> Sealed2 a-seal2 = Sealed2--data FlippedSeal a C(y) where-    FlippedSeal :: !(a C(x y)) -> FlippedSeal a C(y)--flipSeal :: a C(x y) -> FlippedSeal a C(y)-flipSeal = FlippedSeal--unsafeUnseal :: Sealed a -> a C(x)-unsafeUnseal (Sealed a) = unsafeCoerceP1 a--unsafeUnsealFlipped :: FlippedSeal a C(y) -> a C(x y)-unsafeUnsealFlipped (FlippedSeal a) = unsafeCoerceP a--unsafeUnseal2 :: Sealed2 a -> a C(x y)-unsafeUnseal2 (Sealed2 a) = unsafeCoerceP a--unseal :: (FORALL(x) a C(x ) -> b) -> Sealed a -> b-unseal f x = f (unsafeUnseal x)---- laziness property:--- unseal (const True) undefined == True--unsealM :: Monad m => m (Sealed a) -> (FORALL(x) a C(x) -> m b) -> m b-unsealM m1 m2 = do sx <- m1-                   unseal m2 sx--liftSM :: Monad m => (FORALL(x) a C(x) -> b) -> m (Sealed a) -> m b-liftSM f m = do sx <- m-                return (unseal f sx)--mapSeal :: (FORALL(x) a C(x ) -> b C(x )) -> Sealed a -> Sealed b-mapSeal f = unseal (seal . f)--mapFlipped :: (FORALL(x) a C(x y) -> b C(x z)) -> FlippedSeal a C(y) -> FlippedSeal b C(z)-mapFlipped f (FlippedSeal x) = FlippedSeal (f x)--unseal2 :: (FORALL(x y) a C(x y ) -> b) -> Sealed2 a -> b-unseal2 f a = f (unsafeUnseal2 a)--mapSeal2 :: (FORALL(x y) a C(x y ) -> b C(x y )) -> Sealed2 a -> Sealed2 b-mapSeal2 f = unseal2 (seal2 . f)--unsealFlipped :: (FORALL(x y) a C(x y) -> b) -> FlippedSeal a C(z) -> b-unsealFlipped f (FlippedSeal a) = f a--instance Show1 a => Show (Sealed a) where-    showsPrec d (Sealed x) = showParen (d > appPrec) $ showString "Sealed " . showsPrec1 (appPrec + 1) x-instance Show2 a => Show (Sealed2 a) where-    showsPrec d (Sealed2 x) = showParen (d > appPrec) $ showString "Sealed2 " . showsPrec2 (appPrec + 1) x---- |'Poly' is similar to 'Sealed', but the type argument is--- universally quantified instead of being existentially quantified.-newtype Poly a = Poly { unPoly :: FORALL(x) a C(x) }---- |'Stepped' is a type level composition operator.--- For example, 'Stepped Sealed p' is equivalent to 'lambda x . Sealed (p x)'-newtype Stepped (f :: SEALEDPATCHKIND -> *) a C(x) = Stepped { unStepped :: f (a C(x)) }---- |'FreeLeft p' is '\forall x . \exists y . p x y'--- In other words the caller is free to specify the left witness,--- and then the right witness is an existential.--- Note that the order of the type constructors is important for ensuring--- that 'y' is dependent on the 'x' that is supplied.--- This is why 'Stepped' is needed, rather than writing the more obvious--- 'Sealed (Poly p)' which would notionally have the same quantification--- of the type witnesses.-newtype FreeLeft p = FLInternal (Poly (Stepped Sealed p))---- |'FreeLeft p' is '\forall y . \exists x . p x y'--- In other words the caller is free to specify the right witness,--- and then the left witness is an existential.--- Note that the order of the type constructors is important for ensuring--- that 'x' is dependent on the 'y' that is supplied.-newtype FreeRight p = FRInternal (Poly (FlippedSeal p))---- |Unwrap a 'FreeLeft' value-unFreeLeft :: FreeLeft p -> Sealed (p C(x))-unFreeLeft (FLInternal x) = unStepped (unPoly x)---- |Unwrap a 'FreeRight' value-unFreeRight :: FreeRight p -> FlippedSeal p C(x)-unFreeRight (FRInternal x) = unPoly x---- |'Gap' abstracts over 'FreeLeft' and 'FreeRight' for code constructing these values-class Gap w where-  -- |An empty 'Gap', e.g. 'NilFL' or 'NilRL'-  emptyGap :: (FORALL(x) p C(x x)) -> w p-  -- |A 'Gap' constructed from a completely polymorphic value, for example the constructors-  -- for primitive patches-  freeGap :: (FORALL(x y) p C(x y)) -> w p--  -- |Compose two 'Gap' values together in series, e.g. 'joinGap (+>+)' or 'joinGap (:>:)'-  joinGap :: (FORALL(x y z) p C(x y) -> q C(y z) -> r C(x z)) -> w p -> w q -> w r--instance Gap FreeLeft where-  emptyGap e = FLInternal (Poly (Stepped (Sealed e)))-  freeGap e =  FLInternal (Poly (Stepped (Sealed e)))-  joinGap op (FLInternal p) (FLInternal q)-    = FLInternal (Poly (case unPoly p of Stepped (Sealed p') -> case unPoly q of Stepped (Sealed q') -> Stepped (Sealed (p' `op` q'))))--instance Gap FreeRight where-  emptyGap e = FRInternal (Poly (FlippedSeal e))-  freeGap e =  FRInternal (Poly (FlippedSeal e))-  joinGap op (FRInternal p) (FRInternal q)-    = FRInternal (Poly (case unPoly q of FlippedSeal q' -> case unPoly p of FlippedSeal p' -> FlippedSeal (p' `op` q')))
− src/Darcs/Witnesses/Show.hs 
@@ -1,47 +0,0 @@-{-# LANGUAGE CPP #-}--module Darcs.Witnesses.Show(ShowDict(..), showD, showListD, showsPrecD,-                            Show1(..), Show2(..), show1, showsPrec1, show2, showsPrec2, showOp2, appPrec) where--#include "gadts.h"--data ShowDict a where-    ShowDictClass :: Show a => ShowDict a-    ShowDictRecord :: (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> ShowDict a--showsPrecD :: ShowDict a -> Int -> a -> ShowS-showsPrecD ShowDictClass       = showsPrec-showsPrecD (ShowDictRecord showsPrecR _ _) = showsPrecR--showD :: ShowDict a -> a -> String-showD ShowDictClass       = show-showD (ShowDictRecord _ showR _) = showR--showListD :: ShowDict a -> [a] -> ShowS-showListD ShowDictClass       = showList-showListD (ShowDictRecord _ _ showListR) = showListR--class Show1 a where-    showDict1 :: ShowDict (a C(x))--showsPrec1 :: Show1 a => Int -> a C(x) -> ShowS-showsPrec1 = showsPrecD showDict1--show1 :: Show1 a => a C(x) -> String-show1 = showD showDict1--class Show2 a where-    showDict2 :: ShowDict (a C(x y))--showsPrec2 :: Show2 a => Int -> a C(x y) -> ShowS-showsPrec2 = showsPrecD showDict2--show2 :: Show2 a => a C(x y) -> String-show2 = showD showDict2--showOp2 :: (Show2 a, Show2 b) => Int -> String -> Int -> a C(w x) -> b C(y z) -> String -> String-showOp2 prec opstr d x y = showParen (d > prec) $ showsPrec2 (prec + 1) x .-                          showString opstr . showsPrec2 (prec + 1) y--appPrec :: Int-appPrec = 10
− src/Darcs/Witnesses/Unsafe.hs 
@@ -1,24 +0,0 @@-{-# LANGUAGE MagicHash #-}-#include "gadts.h"-module Darcs.Witnesses.Unsafe (-  unsafeCoerceP, unsafeCoercePStart,-  unsafeCoercePEnd, unsafeCoerceP2,-  unsafeCoerceP1-) where--import GHC.Base (unsafeCoerce#)--unsafeCoerceP :: a C(x y) -> a C(b c)-unsafeCoerceP = unsafeCoerce#--unsafeCoercePStart :: a C(x1 y) -> a C(x2 y)-unsafeCoercePStart = unsafeCoerce#--unsafeCoercePEnd :: a C(x y1) -> a C(x y2)-unsafeCoercePEnd = unsafeCoerce#--unsafeCoerceP2 :: t C(w x y z) -> t C(a b c d)-unsafeCoerceP2 = unsafeCoerce#--unsafeCoerceP1 :: a C(x) -> a C(y)-unsafeCoerceP1 = unsafeCoerce#
− src/Darcs/Witnesses/WZipper.hs 
@@ -1,82 +0,0 @@--- Copyright (C) 2009 Florent Becker------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}--#include "gadts.h"-module Darcs.Witnesses.WZipper ( FZipper(..), focus, leftmost, left-                               , rightmost, right, jokers, clowns-                               , flToZipper, lengthFZ, nullFZ-                               , toEnd, toStart-                               )-where-import Darcs.Witnesses.Ordered ( FL(..), RL(..), nullFL, nullRL-                               , lengthFL, lengthRL, (+<+)-                               , reverseFL, reverseRL, (+>+)-                               )-import Darcs.Witnesses.Sealed(Sealed2(..), Sealed(..), FlippedSeal(..))---- forward zipper-data FZipper a C(x z) where-    FZipper :: RL a C(x y) -> FL a C(y z) -> FZipper a C(x z)---- Constructors-flToZipper :: FL a C(x y) -> FZipper a C(x y)-flToZipper l = FZipper NilRL l----destructors-nullFZ :: FZipper a C(x y) -> Bool-nullFZ (FZipper l r) = nullRL l && nullFL r--lengthFZ :: FZipper a C(x y) -> Int-lengthFZ (FZipper l r) = lengthRL l + lengthFL r--focus :: FZipper a C(x y) -> Maybe (Sealed2 a)-focus (FZipper _ (x :>: _)) = Just $ Sealed2 x-focus _ = Nothing---- | \"Clowns to the left of me, jokers to the right.  Here I am, stuck---   in the middle of you\"---   <http://en.wikipedia.org/wiki/Stuck_in_the_Middle>-clowns :: FZipper a C(x y) -> Sealed ((RL a) C(x))-clowns (FZipper l _) = Sealed l---- | See 'clowns'-jokers :: FZipper a C(x y) -> FlippedSeal (FL a) C(y)-jokers (FZipper _ r) = FlippedSeal r--rightmost :: FZipper p C(x y) -> Bool-rightmost (FZipper _ NilFL) = True-rightmost _ = False--right :: FZipper p C(x y) -> FZipper p C(x y)-right (FZipper l (b:>:r)) = FZipper (b :<: l) r-right x@(FZipper _ NilFL) = x--leftmost :: FZipper p C(x y) -> Bool-leftmost (FZipper NilRL _) = True-leftmost _ = False--left :: FZipper p C(x y) -> FZipper p C(x y)-left (FZipper (b :<: l) r) = FZipper l (b :>: r)-left x@(FZipper NilRL _) = x--toEnd :: FZipper p C(x y) -> FZipper p C(x y)-toEnd (FZipper l r) = FZipper (reverseFL r +<+ l) NilFL--toStart :: FZipper p C(x y) -> FZipper p C(x y)-toStart (FZipper l r) = FZipper NilRL ((reverseRL l) +>+ r)
− src/DateMatcher.hs 
@@ -1,188 +0,0 @@--- Copyright (C) 2004 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE ExistentialQuantification #-}---- |--- Module      : DateMatcher--- Copyright   : 2004 David Roundy--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module DateMatcher (-                     parseDateMatcher-                     -- for debugging only-                   , DateMatcher(..)-                   , getMatchers-                   ) where--import Control.Exception.Extensible ( catch, throw )-import Data.Maybe ( isJust )-import Prelude hiding ( catch )--import System.IO.Error ( isUserError, ioeGetErrorString )-import System.Time-import Text.ParserCombinators.Parsec ( eof, parse, ParseError )--import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast,-                 iso8601Interval, resetCalendar, subtractFromMCal, getLocalTz,-                 MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime,-                 unsetTime-               )---- | 'withinDay' @x y@ is true if @x <= y < (x + one_day)@--- Note that this converts the two dates to @ClockTime@ to avoid--- any timezone-related errors-withinDay :: CalendarTime -> CalendarTime -> Bool-withinDay a b = within (Just $ toClockTime a)-                       (Just (addToClockTime day $ toClockTime a))-                       (toClockTime b)-  where-    day = TimeDiff 0 0 1 0 0 0 0---- | 'dateRange' @x1 x2 y@ is true if @x1 <= y < x2@---   Since @x1@ and @x2@ can be underspecified, we simply assume the---   first date that they could stand for.-dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool-dateRange a b = cDateRange (fmap unsafeToCalendarTime a)-                           (fmap unsafeToCalendarTime b)---- | 'cDateRange' @x1 x2 y@ is true if @x1 <= y < x2@-cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool-cDateRange a b c = within (fmap toClockTime a)-                          (fmap toClockTime b) (toClockTime c)---- | 'within' @x1 x2 y@ is true if @x1 <= y < x2@-within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool-within (Just start) (Just end) time = start <= time && time < end-within Nothing (Just end) time = time < end-within (Just start) Nothing time = start <= time-within _ _ _ = undefined---- | 'samePartialDate' @range exact@ is true if @exact@ falls---   within the a range of dates represented by @range@.---   The purpose of this function is to support matching on partially---   specified dates.  That is, if you only specify the date 2007,---   this function should match any dates within that year.  On the---   other hand, if you specify 2007-01, this function will match any---   dates within that month.  This function only matches up to the---   second.-samePartialDate :: MCalendarTime -> CalendarTime -> Bool-samePartialDate a b_ =-    within (Just clockA)-           (Just $ addToClockTime interval clockA)-           (toClockTime calB)-  where-    interval-        | isJust (mctSec a)   = second-        | isJust (mctMin a)   = minute-        | isJust (mctHour a)  = hour-        | isJust (mctYDay a)  = day-        | mctWeek a = maybe week (const day) (mctWDay a)-        | isJust (mctDay a)   = day-        | isJust (mctMonth a) = month-        | otherwise           = year-    year   = TimeDiff 1 0 0 0 0 0 0-    month  = TimeDiff 0 1 0 0 0 0 0-    week   = TimeDiff 0 0 7 0 0 0 0-    day    = TimeDiff 0 0 1 0 0 0 0-    hour   = TimeDiff 0 0 0 1 0 0 0-    minute = TimeDiff 0 0 0 0 1 0 0-    second = TimeDiff 0 0 0 0 0 1 0-    clockA = toClockTime $ unsafeToCalendarTime a-    calB   = resetCalendar b_---- | A 'DateMatcher' combines a potential parse for a date string---   with a "matcher" function that operates on a given date.---   We use an existential type on the matcher to allow---   the date string to either be interpreted as a point in time---   or as an interval.-data DateMatcher = forall d . (Show d) => DM-    String                      --  name-    (Either ParseError d)       --  parser-    (d -> CalendarTime -> Bool) --  matcher---- | 'parseDateMatcher' @s@ return the first  matcher in---    'getMatchers' that can parse 's'-parseDateMatcher :: String -> IO (CalendarTime -> Bool)-parseDateMatcher d = testDateMatcher `catchUserError` handleError-  where-    catchUserError comp handler = catch comp $ \e ->-        if isUserError e then handler (ioeGetErrorString e) else throw e--    -- If the user enters a date > maxint seconds ago, the toClockTime-    -- function cannot work.-    handleError e = if e == "Time.toClockTime: invalid input"-                        then error "Can't handle dates that far back!"-                        else error e--    -- Hack: test the matcher against the current date and discard the results.-    -- We just want to make sure it won't throw any exceptions when we use it-    -- for real.-    testDateMatcher = do-        matcher <- tryMatchers `fmap` getMatchers d-        matcher `fmap` now >>= (`seq` return matcher)---- | 'getMatchers' @d@ returns the list of matchers that will be---   applied on @d@.  If you wish to extend the date parsing code,---   this will likely be the function that you modify to do so.-getMatchers :: String -> IO [DateMatcher]-getMatchers d = do-    rightNow <- now-    let midnightToday = unsetTime rightNow-        mRightNow = toMCalendarTime rightNow-        matchIsoInterval (Left dur) =-            let durAgo = dur `subtractFromMCal` mRightNow in-            dateRange (Just durAgo) (Just mRightNow)-        matchIsoInterval (Right (a,b)) = dateRange (Just a) (Just b)-    tzNow <- getLocalTz-    return-        -- note that the order of these is quite important as some matchers can-        -- match the same date.-        [ DM "from English date"-              (parseDateWith $ englishLast midnightToday)-              (\(a,_) -> cDateRange (Just a) Nothing)-        , DM "specific English date"-              (parseDateWith $ englishDateTime midnightToday)-              withinDay-        , DM "English interval"-              (parseDateWith $ englishInterval rightNow)-              (uncurry cDateRange)-        , DM "ISO 8601 interval"-              (parseDateWith $ iso8601Interval tzNow)-              matchIsoInterval-        , DM "CVS, ISO 8601, or old style date"-              (parseDate tzNow d)-              samePartialDate-        ]-  where-    tillEof p = do { x <- p; eof; return x }-    parseDateWith p = parse (tillEof p) "" d---- | 'tryMatchers' @ms@ returns the first successful match in @ms@---   It is an error if there are no matches-tryMatchers :: [DateMatcher] -> CalendarTime -> Bool-tryMatchers (DM _ parsed matcher : ms) =-    case parsed of-        Left _   -> tryMatchers ms-        Right  d -> matcher d-tryMatchers [] = error "Can't support fancy dates."--now :: IO CalendarTime-now = getClockTime >>= toCalendarTime
− src/Encoding.hs 
@@ -1,46 +0,0 @@--- Copyright 2007-2009, Judah Jacobson.--- All Rights Reserved.---- Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are met:---- - Redistribution of source code must retain the above copyright notice,--- this list of conditions and the following disclaimer.---- - Redistribution in binary form must reproduce the above copyright notice,--- this list of conditions and the following disclaimer in the documentation--- and/or other materials provided with the distribution.---- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE--- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR--- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER--- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,--- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE--- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-{-# LANGUAGE CPP #-}-module Encoding-    ( encode,decode-    ) where--import Data.ByteString ( ByteString )--#ifdef WIN32-import qualified Encoding.Win32 as Backend ( encode, decode )-#else-import qualified Encoding.IConv as Backend ( encode, decode )-#endif---- functions redefined to add haddock (there might well be a better way!)---- | Encode a Unicode 'String' into a 'ByteString' suitable for the current--- console.-encode :: String -> IO ByteString-encode = Backend.encode---- | Convert a 'ByteString' from the console's encoding into a Unicode 'String'.-decode :: ByteString -> IO String-decode = Backend.decode
− src/Encoding/IConv.hsc 
@@ -1,184 +0,0 @@--- Copyright 2007-2009, Judah Jacobson.--- All Rights Reserved.---- Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are met:---- - Redistribution of source code must retain the above copyright notice,--- this list of conditions and the following disclaimer.---- - Redistribution in binary form must reproduce the above copyright notice,--- this list of conditions and the following disclaimer in the documentation--- and/or other materials provided with the distribution.---- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE--- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR--- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER--- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,--- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE--- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-{-# LANGUAGE ForeignFunctionInterface #-}-module Encoding.IConv-    ( encode, decode-    ) where--import Foreign.C-    ( CString, CSize(..), CInt(..)-    , peekCAString, withCAString-    , Errno(..), getErrno, throwErrno, eINVAL, e2BIG-    )-import Foreign-    ( Ptr, castPtr, nullPtr, plusPtr-    , peek, maybePeek-    , with, maybeWith-    , ForeignPtr, withForeignPtr, newForeignPtr-    , FunPtr-    , Int32, Word8-    )-import Control.Exception ( bracket )-import Data.ByteString ( ByteString, useAsCStringLen, append )-import Data.ByteString.Internal ( createAndTrim' )-import qualified Data.ByteString as B-import qualified Data.ByteString.UTF8 as UTF8-import Data.Maybe ( fromMaybe )--#include <locale.h>-#include <langinfo.h>-#include "h_iconv.h"--getLocaleCodeset :: IO String-getLocaleCodeset = bracket (setLocale (Just "")) setLocale (const getCodeset)--encode :: String -> IO ByteString-encode str = getLocaleCodeset >>= \codeset -> openEncoder codeset >>= ($ str)--decode :: ByteString -> IO String-decode str = getLocaleCodeset >>= \codeset -> openDecoder codeset >>= ($ str)--openEncoder :: String -> IO (String -> IO ByteString)-openEncoder codeset = do-    encodeT <- iconvOpen codeset "UTF-8"-    return $ simpleIConv dropUTF8Char encodeT . UTF8.fromString--openDecoder :: String -> IO (ByteString -> IO String)-openDecoder codeset = do-    decodeT <- iconvOpen "UTF-8" codeset-    return $ fmap UTF8.toString . simpleIConv (B.drop 1) decodeT--dropUTF8Char :: ByteString -> ByteString-dropUTF8Char = fromMaybe B.empty . fmap snd . UTF8.uncons--replacement :: Word8-replacement = toEnum (fromEnum '?')---- handle errors by dropping unuseable chars.-simpleIConv :: (ByteString -> ByteString) -> IConvT -> ByteString -> IO ByteString-simpleIConv dropper t bs = do-    (cs,result) <- iconv t bs-    case result of-        Invalid rest    -> continueOnError cs rest-        Incomplete rest -> continueOnError cs rest-        _               -> return cs-  where-    continueOnError cs rest = fmap ((cs `append`) . (replacement `B.cons`))-                                $ simpleIConv dropper t (dropper rest)-------------------------- Setting the locale--foreign import ccall "setlocale" c_setlocale :: CInt -> CString -> IO CString--setLocale :: Maybe String -> IO (Maybe String)-setLocale oldLocale = (maybeWith withCAString) oldLocale $ \loc_p -> do-    c_setlocale (#const LC_CTYPE) loc_p >>= maybePeek peekCAString---------------------- Getting the encoding--type NLItem = #type nl_item--foreign import ccall nl_langinfo :: NLItem -> IO CString--getCodeset :: IO String-getCodeset = do-    str <- nl_langinfo (#const CODESET) >>= peekCAString-    -- check for codesets which may be returned by Solaris, but not understood-    -- by GNU iconv.-    if str `elem` ["","646"]-        then return "ISO-8859-1"-        else return str--------------------- Iconv---- TODO: This may not work on platforms where iconv_t is not a pointer.-type IConvT = ForeignPtr ()-type IConvTPtr = Ptr ()--foreign import ccall "darcs_iconv_open" iconv_open-    :: CString -> CString -> IO IConvTPtr--iconvOpen :: String -> String -> IO IConvT-iconvOpen destName srcName = withCAString destName $ \dest ->-                            withCAString srcName $ \src -> do-                                res <- iconv_open dest src-                                if res == nullPtr `plusPtr` (-1)-                                    then throwErrno $ "iconvOpen "-                                            ++ show (srcName,destName)-                                    -- list the two it couldn't convert between?-                                    else newForeignPtr iconv_close res---- really this returns a CInt, but it's easiest to just ignore that, I think.-foreign import ccall "& darcs_iconv_close" iconv_close :: FunPtr (IConvTPtr -> IO ())--foreign import ccall "darcs_iconv" c_iconv :: IConvTPtr -> Ptr CString -> Ptr CSize-                            -> Ptr CString -> Ptr CSize -> IO CSize--data Result = Successful-            | Invalid ByteString-            | Incomplete ByteString-    deriving Show--iconv :: IConvT -> ByteString -> IO (ByteString,Result)-iconv cd inStr = useAsCStringLen inStr $ \(inPtr, inBuffLen) ->-        with inPtr $ \inBuff ->-        with (toEnum inBuffLen) $ \inBytesLeft -> do-                out <- loop inBuffLen (castPtr inBuff) inBytesLeft-                return out-    where-        -- TODO: maybe a better algorithm for increasing the buffer size?-        -- and also maybe a different starting buffer size?-        biggerBuffer = (+1)-        loop outSize inBuff inBytesLeft = do-            (bs, errno) <- partialIconv cd outSize inBuff inBytesLeft-            inLeft <- fmap fromEnum $ peek inBytesLeft-            let rest = B.drop (B.length inStr - inLeft) inStr-            case errno of-                Nothing -> return (bs,Successful)-                Just err -                    | err == e2BIG  -> do -- output buffer too small-                            (bs',result) <- loop (biggerBuffer outSize) inBuff inBytesLeft-                            -- TODO: is this efficient enough?-                            return (bs `append` bs', result)-                    | err == eINVAL -> return (bs,Incomplete rest)-                    | otherwise     -> return (bs, Invalid rest)--partialIconv :: IConvT -> Int -> Ptr CString -> Ptr CSize -> IO (ByteString, Maybe Errno)-partialIconv cd outSize inBuff inBytesLeft =-    withForeignPtr cd $ \cd_p ->-    createAndTrim' outSize $ \outPtr ->-    with outPtr $ \outBuff ->-    with (toEnum outSize) $ \outBytesLeft -> do-        -- ignore the return value; checking the errno is more reliable.-        _ <- c_iconv cd_p inBuff inBytesLeft (castPtr outBuff) outBytesLeft-        outLeft <- fmap fromEnum $ peek outBytesLeft-        inLeft <- peek inBytesLeft-        errno <- if inLeft > 0-                    then fmap Just getErrno-                    else return Nothing-        return (0,outSize - outLeft,errno)-
− src/Encoding/Win32.hs 
@@ -1,80 +0,0 @@--- Copyright 2007-2009, Judah Jacobson.--- All Rights Reserved.---- Redistribution and use in source and binary forms, with or without--- modification, are permitted provided that the following conditions are met:---- - Redistribution of source code must retain the above copyright notice,--- this list of conditions and the following disclaimer.---- - Redistribution in binary form must reproduce the above copyright notice,--- this list of conditions and the following disclaimer in the documentation--- and/or other materials provided with the distribution.---- THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY--- EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED--- WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE--- DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE--- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL--- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR--- SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER--- CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,--- OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE--- USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.-{-# LANGUAGE ForeignFunctionInterface #-}-module Encoding.Win32-    ( encode, decode-    ) where--import Data.ByteString.Internal ( createAndTrim )-import qualified Data.ByteString as B-    ( ByteString, useAsCStringLen )-import Foreign ( castPtr, allocaArray0 )-import Foreign.C-    ( CInt(..), peekCWStringLen, withCWStringLen )-import System.Win32-    ( CodePage, nullPtr, getConsoleCP, getACP-    , LPCSTR, LPWSTR, LPCWSTR, LPBOOL, DWORD )--encode :: String -> IO B.ByteString-encode str = getCodePage >>= flip unicodeToCodePage str--decode :: B.ByteString -> IO String-decode str = getCodePage >>= flip codePageToUnicode str----------------------------- Multi-byte conversion--foreign import stdcall "WideCharToMultiByte" wideCharToMultiByte-        :: CodePage -> DWORD -> LPCWSTR -> CInt -> LPCSTR -> CInt-                -> LPCSTR -> LPBOOL -> IO CInt--unicodeToCodePage :: CodePage -> String -> IO B.ByteString-unicodeToCodePage cp wideStr = withCWStringLen wideStr $ \(wideBuff, wideLen) -> do-    -- first, ask for the length without filling the buffer.-    outSize <- wideCharToMultiByte cp 0 wideBuff (toEnum wideLen)-                    nullPtr 0 nullPtr nullPtr-    -- then, actually perform the encoding.-    createAndTrim (fromEnum outSize) $ \outBuff ->-        fmap fromEnum $ wideCharToMultiByte cp 0 wideBuff (toEnum wideLen)-                    (castPtr outBuff) outSize nullPtr nullPtr--foreign import stdcall "MultiByteToWideChar" multiByteToWideChar-        :: CodePage -> DWORD -> LPCSTR -> CInt -> LPWSTR -> CInt -> IO CInt--codePageToUnicode :: CodePage -> B.ByteString -> IO String-codePageToUnicode cp bs = B.useAsCStringLen bs $ \(inBuff, inLen) -> do-    -- first ask for the size without filling the buffer.-    outSize <- multiByteToWideChar cp 0 inBuff (toEnum inLen) nullPtr 0-    -- then, actually perform the decoding.-    allocaArray0 (fromEnum outSize) $ \outBuff -> do-    outSize' <- multiByteToWideChar cp 0 inBuff (toEnum inLen) outBuff outSize-    peekCWStringLen (outBuff, fromEnum outSize')--getCodePage :: IO CodePage-getCodePage = do-    conCP <- getConsoleCP-    if conCP > 0-        then return conCP-        else getACP-
− src/English.hs 
@@ -1,98 +0,0 @@--- Copyright (C) 2008 Eric Kow------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- |--- Module      : English--- Copyright   : 2008 Eric Kow--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable------ This modules provides rudimentary natural language generation--- (NLG) utilities.  That is, generating natural language from a--- machine representation.  Initially, only English is supported at--- all.  Representations are implemented for:------  * countable nouns (plurality); and---  * lists of clauses (foo, bar and/or baz).--module English where--import Data.List (isSuffixOf, intercalate)---- | > englishNum 0 (Noun "watch") "" == "watches"---   > englishNum 1 (Noun "watch") "" == "watch"---   > englishNum 2 (Noun "watch") "" == "watches"-englishNum :: Countable n => Int -> n -> ShowS-englishNum x = if x == 1 then singular else plural---- | Things that have a plural and singular spelling-class Countable a where-    plural :: a -> ShowS-    singular :: a -> ShowS---- | This only distinguishes between nouns with a final -ch,---   and nouns which do not.---   More irregular nouns will just need to have their own type------   > plural (Noun "batch") "" == "batches"---   > plural (Noun "bat")   "" == "bats"---   > plural (Noun "mouse") "" == "mouses" -- :-(-newtype Noun = Noun String-data Pronoun = It--instance Countable Noun where-    -- more irregular nouns will just need to have their own type-    plural (Noun s) | "ch" `isSuffixOf` s = showString s .  showString "es"-    plural (Noun s) | "y" `isSuffixOf` s-                      && length s > 1-                      && last (init s) `notElem` "aeiou" =-                            showString (init s) . showString "ies"-    plural (Noun s) = showString s . showChar 's'-    singular (Noun s) =  showString s--instance Countable Pronoun where-    plural It = showString "them"-    singular It = showString "it"---- | > singular This (Noun "batch") "" == "this batch"---   > plural   This (Noun "batch") "" == "these batches"-data This = This Noun--instance Countable This where-    plural (This s)   = showString "these "  . plural s-    singular (This s) = showString "this "   . singular s---- | Given a list of things, combine them thusly:------   > orClauses ["foo", "bar", "baz"] == "foo, bar or baz"-andClauses, orClauses :: [String] -> String-andClauses = intersperseLast ", " " and "-orClauses = intersperseLast ", " " or "---- | As 'intersperse', with a different separator for the last--- | interspersal.-intersperseLast :: String -> String -> [String] -> String-intersperseLast _ _ [] = ""-intersperseLast _ _ [clause] = clause-intersperseLast sep sepLast clauses =-    intercalate sep (init clauses) ++ sepLast ++ last clauses--presentParticiple :: String -> String-presentParticiple v | last v == 'e' = init v ++ "ing"-                     | otherwise = v ++ "ing"
− src/Exec.hs 
@@ -1,215 +0,0 @@--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP, ForeignFunctionInterface, DeriveDataTypeable #-}---- |--- Module      : Exec--- Copyright   : 2003 David Roundy--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Exec (-              exec-            , execInteractive-            , withoutNonBlock-            , Redirects-            , Redirect(..)-            , ExecException(..)-            ) where--#ifndef WIN32-import Control.Exception.Extensible ( bracket )-import System.Posix.Env ( setEnv, getEnv, unsetEnv )-import System.Posix.IO ( queryFdOption, setFdOption, FdOption(..), stdInput )-import System.IO ( stdin )-#else-import Control.Exception.Extensible ( catchJust, IOException )-import Data.List ( isInfixOf )-#endif--#if __GLASGOW_HASKELL__ >= 612-import GHC.IO.Handle ( hDuplicate )-#else-import GHC.Handle ( hDuplicate )-#endif--import Control.Exception.Extensible ( bracketOnError, Exception(..),-                                      SomeException(..) )-import Data.Typeable ( Typeable, cast )-import System.Cmd ( system )-import System.Exit ( ExitCode (..) )-import System.IO ( IOMode(..), openBinaryFile, stdout )-import System.Process   ( runProcess, terminateProcess, waitForProcess )--import Darcs.Global ( whenDebugMode )-import Progress ( withoutProgress )--{--   A redirection is a three-tuple of values (in, out, err).-   The most common values are:--     AsIs    don't change it-     Null    /dev/null on Unix, NUL on Windows-     File    open a file for reading or writing--   There is also the value Stdout, which is only meaningful for-   redirection of errors, and is performed AFTER stdout is-   redirected so that output and errors mix together. StdIn and-   StdErr could be added as well if they are useful.--   NOTE: Lots of care must be taken when redirecting stdin, stdout-   and stderr to one of EACH OTHER, since the ORDER in which they-   are changed have a significant effect on the result.--}--type Redirects = (Redirect, Redirect, Redirect)--data Redirect = AsIs-              | Null-              | File FilePath-              | Stdout-                deriving Show--{--  ExecException is thrown by exec if any system call fails,-  for example because the executable we're trying to run-  doesn't exist.--}---                   ExecException cmd    args     redirecs  errorDesc-data ExecException = ExecException-                        String     -- cmd-                        [String]   -- args-                        Redirects  -- redirects-                        String     -- errorDesc-                     deriving (Typeable,Show)--instance Exception ExecException where-    toException e = SomeException e-    fromException (SomeException e) = cast e--_devNull :: FilePath-#ifdef WIN32-_devNull = "NUL"-#else-_devNull = "/dev/null"-#endif--{--  We use System.Process, which does the necessary quoting-  and redirection for us behind the scenes.--}-exec  :: String -> [String] -> Redirects -> IO ExitCode-exec cmd args (inp,out,err) = withoutProgress $ do-    h_stdin  <- redirect inp ReadMode-    h_stdout <- redirect out WriteMode-    h_stderr <- redirect err WriteMode-    withExit127 $ bracketOnError-      (do doOptionalDebug-          runProcess cmd args Nothing Nothing h_stdin h_stdout h_stderr)-      (terminateProcess)-      (waitForProcess)-  where-    doOptionalDebug = whenDebugMode . putStrLn . unwords $-        cmd : args ++ ["; #"] ++ map show [inp, out, err]-    redirect AsIs               _    = return Nothing-    redirect Null               mode = Just `fmap` openBinaryFile _devNull mode-    redirect (File "/dev/null") mode = redirect Null mode-    redirect (File f)           mode = Just `fmap` openBinaryFile f mode-    -- hDuplicate stdout rather than passing stdout itself,-    -- because runProcess closes the Handles we pass it.-    redirect Stdout             _    = Just `fmap` hDuplicate stdout--execInteractive :: String -> String -> IO ExitCode-#ifndef WIN32-{--This should handle arbitrary commands interpreted by the shell on Unix since-that's what people expect. But we don't want to allow the shell to interpret-the argument in any way, so we set an environment variable and call-cmd "$DARCS_ARGUMENT"--}-execInteractive cmd arg = withoutProgress $ do-    let var = "DARCS_ARGUMENT"-    stdin `seq` return ()-    withoutNonBlock $ bracket-      (do oldval <- getEnv var-          setEnv var arg True-          return oldval)-      (\oldval ->-         case oldval of-              Nothing -> unsetEnv var-              Just val -> setEnv var val True)-      (\_ -> withExit127 $ system $ cmd++" \"$"++var++"\"")--#else--- The `system' function passes commands to execute via cmd.exe (or--- command.com) it's return value is equivalent to the one returned by the--- shell. For regular applications - this works correctly resulting in the--- exit code of the program. However in case of a command/file which can't be--- found - cmd.exe will return 1 instead of propagating the ExitFailure 9009--- which on windows is equivalent to ExitFailure 127 from *nix machines.------ Here we force return the exit code of the last cmd.exe action by appending--- & exit !errorlevel! to the command being executed that way chaining with--- ortryrunning works correctly.------ SETLOCAL EnableDelayedExpansion makes sure that !variable! expansion is done--- correctly on systems where that function is not enabled by default.----execInteractive cmd arg = withoutProgress $ do-  withExit127 $ system $ "SETLOCAL EnableDelayedExpansion & " ++-                          cmd ++ " " ++ arg ++-                          " & exit !errorlevel!"-#endif--withoutNonBlock :: IO a -> IO a-#ifndef WIN32-{--Do IO without NonBlockingRead on stdInput.--This is needed when running unsuspecting external commands with interactive-mode - if read from terminal is non-blocking also write to terminal is-non-blocking.--}-withoutNonBlock x =-    do nb <- queryFdOption stdInput NonBlockingRead-       if nb-          then bracket-                   (setFdOption stdInput NonBlockingRead False)-                   (\_ -> setFdOption stdInput NonBlockingRead True)-                   (\_ -> x)-          else x-#else-withoutNonBlock x = do x-#endif--{--Ensure that we exit 127 if the thing we are trying to run does not exist-(Only needed under Windows)--}-withExit127 :: IO ExitCode -> IO ExitCode-#ifdef WIN32-withExit127 a = catchJust notFoundError a (const $ return $ ExitFailure 127)--notFoundError :: IOException -> Maybe ()-notFoundError e | "runProcess: does not exist" `isInfixOf` show e = Just ()-notFoundError _ = Nothing-#else-withExit127 = id-#endif
− src/IsoDate.hs 
@@ -1,856 +0,0 @@--- Copyright (C) 2003 Peter Simons--- Copyright (C) 2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- |--- Module      : IsoDate--- Copyright   : 2003 Peter Simons---               2003 David Roundy--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module IsoDate ( getIsoDateTime, readLocalDate, readUTCDate,-                 parseDate, getLocalTz,-                 englishDateTime, englishInterval, englishLast,-                 iso8601Interval, iso8601Duration,-                 cleanLocalDate, resetCalendar,-                 MCalendarTime(..), subtractFromMCal, addToMCal,-                 toMCalendarTime, unsafeToCalendarTime,-                 unsetTime, TimeInterval-               ) where--import Text.ParserCombinators.Parsec-import System.Time-import System.IO.Unsafe ( unsafePerformIO )-import Data.Char ( toUpper, isDigit )-import Data.Maybe ( fromMaybe )-import Control.Monad ( liftM, liftM2 )-import qualified Data.ByteString.Char8 as B--type TimeInterval = (Maybe CalendarTime, Maybe CalendarTime)---- | Read/interpret a date string, assuming UTC if timezone---   is not specified in the string (see 'readDate')---   Warning! This errors out if we fail to interpret the---   date-readUTCDate :: String -> CalendarTime-readUTCDate = readDate 0---- | Convert a date string into ISO 8601 format (yyyymmdd variant)---   assuming local timezone if not specified in the string---   Warning! This errors out if we fail to interpret the date-cleanLocalDate :: String -> String-cleanLocalDate = showIsoDateTime . resetCalendar-                 . readDate (unsafePerformIO getLocalTz)---- | Read/interpret a date string, assuming local timezone if not---   specified in the string-readLocalDate :: String -> CalendarTime-readLocalDate = readDate (unsafePerformIO getLocalTz)---- | Return the local timezone offset from UTC in seconds-getLocalTz :: IO Int-getLocalTz = ctTZ `liftM` (getClockTime >>= toCalendarTime)---- | Parse a date string with 'parseDate'---   Warning! This errors out if we fail to interpret the date---   Uses its first argument as the default time zone.-readDate :: Int -> String -> CalendarTime-readDate tz d =-             case parseDate tz d of-             Left e -> error $ "bad date: "++d++" - "++show e-             Right ct -> resetCalendar $ unsafeToCalendarTime ct---- | Parse a date string, assuming a default timezone if---   the date string does not specify one.  The date formats---   understood are those of 'showIsoDateTime' and 'dateTime'-parseDate :: Int -> String -> Either ParseError MCalendarTime-parseDate tz d =-              if length d >= 14 && B.all isDigit bd-              then Right $ toMCalendarTime $-                   CalendarTime (readI $ B.take 4 bd)-                                (toEnum $ (+ (-1)) $ readI $ B.take 2 $ B.drop 4 bd)-                                (readI $ B.take 2 $ B.drop 6 bd) -- Day-                                (readI $ B.take 2 $ B.drop 8 bd) -- Hour-                                (readI $ B.take 2 $ B.drop 10 bd) -- Minute-                                (readI $ B.take 2 $ B.drop 12 bd) -- Second-                                0 Sunday 0 -- Picosecond, weekday and day of year unknown-                                "GMT" 0 False-              else let dt = do { x <- dateTime tz; eof; return x }-                   in parse dt "" d-  where bd = B.pack (take 14 d)-        readI s = fst $ fromMaybe (error "parseDate: invalid date") (B.readInt s)---- | Display a 'CalendarTime' in the ISO 8601 format without any---   separators, e.g. 20080825142503-showIsoDateTime :: CalendarTime -> String-showIsoDateTime ct = concat [ show $ ctYear ct-                            , twoDigit . show . (+1) . fromEnum $ ctMonth ct-                            , twoDigit . show $ ctDay ct-                            , twoDigit . show $ ctHour ct-                            , twoDigit . show $ ctMin ct-                            , twoDigit . show $ ctSec ct-                            ]-    where twoDigit []          = undefined-          twoDigit x@(_:[])    = '0' : x-          twoDigit x@(_:_:[])  = x-          twoDigit _           = undefined---- | The current time in the format returned by 'showIsoDateTime'-getIsoDateTime          :: IO String-getIsoDateTime = (showIsoDateTime . toUTCTime) `liftM` getClockTime------- Parser Combinators ------------------------------------------------- | Case-insensitive variant of Parsec's 'char' function.-caseChar        :: Char -> GenParser Char a Char-caseChar c       = satisfy (\x -> toUpper x == toUpper c)---- | Case-insensitive variant of Parsec's 'string' function.-caseString      :: String -> GenParser Char a ()-caseString cs    = mapM_ caseChar cs <?> cs---- [x,y] => x <|> y-caseStrings :: [String] -> GenParser Char a ()-caseStrings xs = foldl1 (<|>) $ map caseString xs---- | Match a parser at least @n@ times.-manyN           :: Int -> GenParser a b c -> GenParser a b [c]-manyN n p-    | n <= 0     = return []-    | otherwise  = liftM2 (++) (count n p) (many p)---- | Match a parser at least @n@ times, but no more than @m@ times.-manyNtoM        :: Int -> Int -> GenParser a b c -> GenParser a b [c]-manyNtoM n m p-    | n < 0      = return []-    | n > m      = return []-    | n == m     = count n p-    | n == 0     = foldr (<|>) (return []) (map (\x -> try $ count x p) (reverse [1..m]))-    | otherwise  = liftM2 (++) (count n p) (manyNtoM 0 (m-n) p)-------- Date/Time Parser --------------------------------------------------- | Try each of these date parsers in the following order------    (1) 'cvsDateTime'------    (2) 'iso8601DateTime'------    (3) 'oldDateTime-dateTime :: Int -> CharParser a MCalendarTime-dateTime tz =-            choice [try $ toMCalendarTime `fmap` cvsDateTime tz,-                    try $ iso8601DateTime tz,-                    toMCalendarTime `fmap` oldDateTime]---- | CVS-style date/times, e.g.---   2007/08/25 14:25:39 GMT---   Note that time-zones are optional here.-cvsDateTime :: Int -> CharParser a CalendarTime-cvsDateTime tz =-                do y <- year-                   _ <- char '/'-                   mon <- monthNum-                   _ <- char '/'-                   d <- day-                   _ <- mySpaces-                   h <- hour-                   _ <- char ':'-                   m <- minute-                   _ <- char ':'-                   s <- second-                   z <- option tz $ mySpaces >> zone-                   return (CalendarTime y mon d h m s 0 Monday 0 "" z False)---- | \"Old\"-style dates, e.g.---   Tue Jan 3 14:08:07 EST 1999--- darcs-doc: Question (what does the "old" stand for really?)-oldDateTime   :: CharParser a CalendarTime-oldDateTime      = do wd <- dayName-                      _ <- mySpaces-                      mon <- monthName-                      _ <- mySpaces-                      d <- day-                      _ <- mySpaces-                      h <- hour-                      _ <- char ':'-                      m <- minute-                      _ <- char ':'-                      s <- second-                      _ <- mySpaces-                      z <- zone-                      _ <- mySpaces-                      y <- year-                      return (CalendarTime y mon d h m s 0 wd 0 "" z False)---- | ISO 8601 dates and times.  Please note the following flaws:------   I am reluctant to implement:------      * years > 9999------      * truncated representations with implied century (89 for 1989)------   I have not implemented:------      * repeated durations (not relevant)------      * lowest order component fractions in intervals------      * negative dates (BC)------   I have not verified or have left too relaxed:------      * the difference between 24h and 0h------      * allows stuff like 2005-1212; either you use the hyphen all the way---        (2005-12-12) or you don't use it at all (20051212), but you don't use---        it halfway, likewise with time------      * No bounds checking whatsoever on intervals!---        (next action: read iso doc to see if bounds-checking required?) -}-iso8601DateTime   :: Int -> CharParser a MCalendarTime-iso8601DateTime localTz = try $-  do d <- iso8601Date-     t <- option id $ try $ do optional $ oneOf " T"-                               iso8601Time-     return $ t $ d { mctTZ = Just localTz }---- | Three types of ISO 8601 date:------     * calendar date, e.g., 1997-07-17, 1997-07, 199707, 1997------     * week+day in year, e.g.,  1997-W32-4------     * day in year, e.g, 1997-273-iso8601Date :: CharParser a MCalendarTime-iso8601Date =-  do d <- calendar_date <|> week_date <|> ordinal_date-     return $ foldr ($) nullMCalendar d-  where-    calendar_date = -- yyyy-mm-dd-      try $ do d <- optchain year_ [ (dash, month_), (dash, day_) ]-               -- allow other variants to be parsed correctly-               notFollowedBy (digit <|> char 'W')-               return d-    week_date = --yyyy-Www-d-      try $ do yfn <- year_-               optional dash-               _ <- char 'W'-               -- offset human 'week 1' -> computer 'week 0'-               w'  <- (\x -> x-1) `liftM` twoDigits-               mwd  <- option Nothing $ do { optional dash; Just `fmap` nDigits 1 }-               let y = resetCalendar . unsafeToCalendarTime . yfn $ nullMCalendar { mctDay = Just 1 }-                   firstDay = ctWDay y-               -- things that make this complicated-               -- 1. iso8601 weeks start from Monday; Haskell weeks start from Sunday-               -- 2. the first week is the one that contains at least Thursday-               --    if the year starts after Thursday, then some days of the year-               --    will have already passed before the first week-               let afterThursday = firstDay == Sunday || firstDay > Thursday-                   w  = if afterThursday then w'+1 else w'-                   yday = (7 * w) + fromMaybe 1 mwd-                   diff c = c { mctWeek = True-                              , mctWDay = toEnum `fmap` mwd-                              , mctDay  = Just yday }-               return [(diff.yfn)]-    ordinal_date = -- yyyy-ddd-      try $ optchain year_ [ (dash, yearDay_) ]-    ---    year_  = try $ do y <- fourDigits <?> "year (0000-9999)"-                      return $ \c -> c { mctYear = Just y }-    month_ = try $ do m <- twoDigits <?> "month (1 to 12)"-                      return $ \c -> c { mctMonth = Just $ intToMonth m }-    day_   = try $ do d <- twoDigits <?> "day in month (1 to 31)"-                      return $ \c -> c { mctDay = Just d }-    yearDay_ = try $ do d <- nDigits 3 <?> "day in year (001 to 366)"-                        return $ \c -> c { mctDay = Just d-                                         , mctYDay = Just (d - 1) }-    dash = char '-'---- | Note that this returns a function which sets the time on---   another calendar (see 'iso8601DateTime' for a list of---   flaws-iso8601Time :: CharParser a (MCalendarTime -> MCalendarTime)-iso8601Time = try $-  do ts <- optchain hour_ [ (colon     , min_)-                          , (colon     , sec_)-                          , (oneOf ",.", pico_) ]-     z  <- option id $ choice [ zulu , offset ]-     return $ foldr (.) id (z:ts)-  where-    hour_ = do h <- twoDigits-               return $ \c -> c { mctHour = Just h }-    min_  = do m <- twoDigits-               return $ \c -> c { mctMin = Just m }-    sec_  = do s <- twoDigits-               return $ \c -> c { mctSec = Just s }-    pico_ = do digs <- many digit-               let picoExp = 12-                   digsExp = length digs-               let frac | null digs = 0-                        | digsExp > picoExp = read $ take picoExp digs-                        | otherwise = 10 ^ (picoExp - digsExp) * (read digs)-               return $ \c -> c { mctPicosec = Just $ frac }-    zulu   = do { _ <- char 'Z'; return (\c -> c { mctTZ = Just 0 }) }-    offset = do sign <- choice [ char '+' >> return   1-                               , char '-' >> return (-1) ]-                h <- twoDigits-                m <- option 0 $ do { optional colon; twoDigits }-                return $ \c -> c { mctTZ = Just $ sign * 60 * ((h*60)+m) }-    colon = char ':'---- | Intervals in ISO 8601, e.g.,------    * 2008-09/2012-08-17T16:30------    * 2008-09/P2Y11MT16H30M------    * P2Y11MT16H30M/2012-08-17T16:30------   See 'iso8601Duration'-iso8601Interval :: Int -> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime))-iso8601Interval localTz = leftDur <|> rightDur where-  leftDur  =-    do dur <- iso8601Duration-       end <- option Nothing $ do { _ <- char '/'; Just `liftM` isoDt }-       return $ case end of-                Nothing -> Left dur-                Just e  -> Right (dur `subtractFromMCal` e, e)-  rightDur =-    do start <- isoDt-       _ <- char '/'-       durOrEnd <- Left `liftM` iso8601Duration <|> Right `liftM` isoDt-       return $ case durOrEnd of-                Left dur  -> Right (start, dur `addToMCal` start)-                Right end -> Right (start, end)-  isoDt   = iso8601DateTime localTz---- | Durations in ISO 8601, e.g.,------    * P4Y (four years)------    * P5M (five months)------    * P4Y5M (four years and five months)------    * P4YT3H6S (four years, three hours and six seconds)-iso8601Duration :: CharParser a TimeDiff-iso8601Duration =-  do _ <- char 'P'-     y   <- block 0 'Y'-     mon <- block 0 'M'-     d   <- block 0 'D'-     (h,m,s) <- option (0,0,0) $-       do _ <- char 'T'-          h' <- block (-1) 'H'-          m' <- block (-1) 'M'-          s' <- block (-1) 'S'-          let unset = (== (-1))-          if all unset [h',m',s']-             then fail "T should be omitted if time is unspecified"-             else let clear x = if (unset x) then 0 else x-                  in return (clear h', clear m', clear s')-     ---     return $ TimeDiff y mon d h m s 0-  where block d c = option d $ try $-          do n <- many1 digit-             _ <- char c-             return $ read n---- | 'optchain' @p xs@ parses a string with the obligatory---   parser @p@.  If this suceeds, it continues on to the---   rest of the input using the next parsers down the---   chain.  Each part of the chain consists of a parser---   for a separator and for the content itself.  The---   separator is optional.------   A good use of this function is to help in parsing ISO---   ISO 8601 dates and times.  For example, the parser---   @optchain year [(dash, month), (dash, day)]@ accepts---   dates like 2007 (only the year is used), 2007-07 (only---   the year and month), 200707 (only the year and month---   with no separator), 2007-07-19 (year, month and day).-optchain :: CharParser a b -> [(CharParser a c, CharParser a b)] -> CharParser a [b]-optchain p next = try $-  do r1 <- p-     r2 <- case next of-           [] -> return []-           ((sep,p2):next2) -> option [] $ do { optional sep; optchain p2 next2 }-     return (r1:r2)--nDigits :: Int -> CharParser a Int-nDigits n = read `liftM` count n digit--twoDigits, fourDigits :: CharParser a Int-twoDigits = nDigits 2-fourDigits = nDigits 4---- | One or more space.---   WARNING! This only matches on the space character, not on---   whitespace in general-mySpaces :: CharParser a String-mySpaces = manyN 1 $ char ' '---- | English three-letter day abbreviations (e.g. Mon, Tue, Wed)-dayName        :: CharParser a Day-dayName         = choice-                       [ caseString "Mon"       >> return Monday-                       , try (caseString "Tue") >> return Tuesday-                       , caseString "Wed"       >> return Wednesday-                       , caseString "Thu"       >> return Thursday-                       , caseString "Fri"       >> return Friday-                       , try (caseString "Sat") >> return Saturday-                       , caseString "Sun"       >> return Sunday-                       ]---- | Four-digit year-year            :: CharParser a Int-year             = fourDigits---- | One or two digit month (e.g. 3 for March, 11 for November)-monthNum       :: CharParser a Month-monthNum =  do mn <- manyNtoM 1 2 digit-               return $ intToMonth $ (read mn :: Int)---- | January is 1, February is 2, etc-intToMonth :: Int -> Month-intToMonth 1 = January-intToMonth 2 = February-intToMonth 3 = March-intToMonth 4 = April-intToMonth 5 = May-intToMonth 6 = June-intToMonth 7 = July-intToMonth 8 = August-intToMonth 9 = September-intToMonth 10 = October-intToMonth 11 = November-intToMonth 12 = December-intToMonth _  = error "invalid month!"---- | English three-letter month abbreviations (e.g. Jan, Feb, Mar)-monthName      :: CharParser a Month-monthName       = choice-                       [ try (caseString "Jan") >> return January-                       , caseString "Feb"       >> return February-                       , try (caseString "Mar") >> return March-                       , try (caseString "Apr") >> return April-                       , caseString "May"       >> return May-                       , try (caseString "Jun") >> return June-                       , caseString "Jul"       >> return July-                       , caseString "Aug"       >> return August-                       , caseString "Sep"       >> return September-                       , caseString "Oct"       >> return October-                       , caseString "Nov"       >> return November-                       , caseString "Dec"       >> return December-                       ]---- | day in one or two digit notation-day             :: CharParser a Int-day              = do d <- manyNtoM 1 2 digit-                      return (read d :: Int)---- | hour in two-digit notation-hour            :: CharParser a Int-hour             = twoDigits---- | minute in two-digit notation-minute          :: CharParser a Int-minute           = twoDigits---- | second in two-digit notation-second          :: CharParser a Int-second           = twoDigits---- | limited timezone support------   * +HHMM or -HHMM------   * Universal timezones: UTC, UT------   * Zones from GNU coreutils/lib/getdate.y, less half-hour ones -----     sorry Newfies.------   * any sequence of alphabetic characters (WARNING! treated as 0!)-zone            :: CharParser a Int-zone             = choice-                       [ do { _ <- char '+'; h <- hour; m <- minute; return (((h*60)+m)*60) }-                       , do { _ <- char '-'; h <- hour; m <- minute; return (-((h*60)+m)*60) }-                       , mkZone "UTC"  0-                       , mkZone "UT"  0-                       , mkZone "GMT" 0-                       , mkZone "WET" 0-                       , mkZone "WEST" 1-                       , mkZone "BST" 1-                       , mkZone "ART" (-3)-                       , mkZone "BRT" (-3)-                       , mkZone "BRST" (-2)-                       , mkZone "AST" (-4)-                       , mkZone "ADT" (-3)-                       , mkZone "CLT" (-4)-                       , mkZone "CLST" (-3)-                       , mkZone "EST" (-5)-                       , mkZone "EDT" (-4)-                       , mkZone "CST" (-6)-                       , mkZone "CDT" (-5)-                       , mkZone "MST" (-7)-                       , mkZone "MDT" (-6)-                       , mkZone "PST" (-8)-                       , mkZone "PDT" (-7)-                       , mkZone "AKST" (-9)-                       , mkZone "AKDT" (-8)-                       , mkZone "HST" (-10)-                       , mkZone "HAST" (-10)-                       , mkZone "HADT" (-9)-                       , mkZone "SST" (-12)-                       , mkZone "WAT" 1-                       , mkZone "CET" 1-                       , mkZone "CEST" 2-                       , mkZone "MET" 1-                       , mkZone "MEZ" 1-                       , mkZone "MEST" 2-                       , mkZone "MESZ" 2-                       , mkZone "EET" 2-                       , mkZone "EEST" 3-                       , mkZone "CAT" 2-                       , mkZone "SAST" 2-                       , mkZone "EAT" 3-                       , mkZone "MSK" 3-                       , mkZone "MSD" 4-                       , mkZone "SGT" 8-                       , mkZone "KST" 9-                       , mkZone "JST" 9-                       , mkZone "GST" 10-                       , mkZone "NZST" 12-                       , mkZone "NZDT" 13-                         -- if we don't understand it, just give a GMT answer...-                       , do { _ <- manyTill (oneOf $ ['a'..'z']++['A'..'Z']++[' '])-                                       (lookAhead space_digit);-                              return 0 }-                       ]-     where mkZone n o  = try $ do { caseString n; return (o*60*60) }-           space_digit = try $ do { _ <- char ' '; oneOf ['0'..'9'] }------- English dates and intervals --------------------------------------------------- | In English, either a date followed by a time, or vice-versa, e.g,------    * yesterday at noon------    * yesterday tea time------    * 12:00 yesterday------   See 'englishDate' and 'englishTime'---   Uses its first argument as "now", i.e. the time relative to which---   "yesterday", "today" etc are to be interpreted-englishDateTime :: CalendarTime -> CharParser a CalendarTime-englishDateTime now =-  try $ dateMaybeAtTime <|> timeThenDate-  where-   -- yesterday (at) noon-   dateMaybeAtTime = try $-     do ed <- englishDate now-        t  <- option Nothing $ try $-                do { _ <- space; optional $ caseString "at "; Just `liftM` englishTime }-        return $ fromMaybe id t $ ed-   -- tea time 2005-12-04-   timeThenDate = try $-     do t  <- englishTime-        optional $ char ','-        _ <- space-        ed <- englishDate now-        return $ t $ unsetTime $ ed---- | Specific dates in English as specific points of time, e.g,------    * today------    * yesterday------    * last week (i.e. the beginning of that interval)------    * 4 months ago (via 'englishAgo')------   The first argument is "now".-englishDate :: CalendarTime -> CharParser a CalendarTime-englishDate now = try $-      (caseString "today"     >> (return $ resetCalendar now))-  <|> (caseString "yesterday" >> (return $ oneDay `subtractFromCal` now) )-  <|> fst `fmap` englishLast now-  <|> englishAgo now-  where oneDay    = TimeDiff 0 0 1 0 0 0 0---- | English expressions for points in the past, e.g.------    * 4 months ago------    * 1 day ago------    * day before yesterday------   See 'englishDuration'-englishAgo :: CalendarTime -> CharParser a CalendarTime-englishAgo now =-  try $ do p <- englishDuration-           _ <- try space-           (m,ref) <- (try $ caseString "ago" >> return ((-1), now))-                   <|> do m <- beforeMod <|> afterMod-                          _ <- space-                          d <- englishDate now-                               <|> fst `fmap` englishLast now-                               <|> unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now)-                          return (m,d)-           return $ multiplyDiff m p `addToCal` ref-  where-    beforeMod = try $ caseString "before" >> return (-1)-    afterMod  = try $ (caseStrings ["after","since"]) >> return 1---- | English expressions for intervals of time,------    * before tea time (i.e. from the beginning of time)------    * after 14:00 last month (i.e. till now)------    * between last year and last month------    * in the last three months (i.e. from then till now)------    * 4 months ago (i.e. till now; see 'englishAgo')-englishInterval :: CalendarTime -> CharParser a TimeInterval-englishInterval now = twixt <|> before <|> after <|> inTheLast <|> lastetc-  where-   englishDT = (unsafeToCalendarTime `fmap` iso8601DateTime (ctTZ now)-                <|> englishDateTime now)-   before = try $-     do caseString "before"-        _ <- space-        end <- englishDT-        return (Just theBeginning, Just end)-   after = try $-     do caseStrings ["after","since"]-        _ <- space-        start <- englishDT-        return (Just start, Nothing)-   twixt = try $-     do caseString "between"-        _ <- space-        start <- englishDT-        _ <- space-        caseString "and"-        _ <- space-        end <- englishDT-        return (Just start, Just end)-   inTheLast = try $-     do caseString "in the last"-        _ <- space-        dur <- englishDuration-        return (Just $ dur `subtractFromCal` now, Just now)-   lastetc =-     do l <- englishAgo now-        return (Just l, Just now)---- | Durations in English that begin with the word \"last\",---   E.g. \"last 4 months\" is treated as the duration between---   4 months ago and now-englishLast :: CalendarTime -> CharParser a (CalendarTime, CalendarTime)-englishLast now =-    -- last year, last week, last 3 years, etc-    try $ do caseString "last"-             _ <- space-             d <- englishDuration-             return (d `subtractFromCal` now, now)---- | Either an 'iso8601Time' or one of several common---   English time expressions like 'noon' or 'tea time'-englishTime :: CharParser a (CalendarTime->CalendarTime)-englishTime = try $-  choice [ wrapM `fmap` iso8601Time-         , namedTime "noon"            12  0-         , namedTime "midnight"         0  0-         , namedTime "tea time"        16 30-         , namedTime "bed time"         2 30-         , namedTime "proper bed time" 21 30 ]-  where namedTime name h m = try $-          do caseString name-             return $ \c -> c { ctHour = h, ctMin = m }-        wrapM f = unsafeToCalendarTime . f . toMCalendarTime---- | Some English durations, e.g.------    * day------    * 4 score------    * 7 years------    * 12 months------ This is not particularly strict about what it accepts.--- For example, "7 yeares", "4 scores" or "1 days" are--- just fine.-englishDuration :: CharParser a TimeDiff-englishDuration = try $-  do n <- option 1 $ do { x <- many1 digit; _ <- space; (return $ read x) }-     b <- base-     optional (caseStrings ["es","s"])-     let current = multiplyDiff n b-     next <- option noTimeDiff $ try $ do-              { optional space; _ <- char ',' ; optional space ; englishDuration }-     return $ addDiff current next-  where-  base = choice-         [ try $ caseString "score"      >> (return $ TimeDiff 20 0  0 0 0 0 0) -- why not?-         ,       caseString "year"       >> (return $ TimeDiff  1 0  0 0 0 0 0)-         , try $ caseString "month"      >> (return $ TimeDiff  0 1  0 0 0 0 0)-         ,       caseString "fortnight"  >> (return $ TimeDiff  0 0 14 0 0 0 0)-         ,       caseString "week"       >> (return $ TimeDiff  0 0  7 0 0 0 0)-         ,       caseString "day"        >> (return $ TimeDiff  0 0  1 0 0 0 0)-         ,       caseString "hour"       >> (return $ TimeDiff  0 0  0 1 0 0 0)-         ,       caseString "minute"     >> (return $ TimeDiff  0 0  0 0 1 0 0)-         ,       caseString "second"     >> (return $ TimeDiff  0 0  0 0 0 1 0) ]------- Calendar and TimeDiff manipulation ------------------------------------------------- | The very beginning of time, i.e. 1970-01-01-theBeginning :: CalendarTime-theBeginning = unsafePerformIO $ toCalendarTime $ TOD 0 0---- | An 'MCalenderTime' is an underspecified 'CalendarTime'---   It is used for parsing dates.  For example, if you want to parse---   the date '4 January', it may be useful to underspecify the year---   by setting it to 'Nothing'.  This uses almost the same fields as---   'System.Time.CalendarTime', a notable exception being that we---   introduce 'mctWeek' to indicate if a weekday was specified or not-data MCalendarTime = MCalendarTime- { mctYear  :: Maybe Int- , mctMonth :: Maybe Month- , mctDay   :: Maybe Int- , mctHour  :: Maybe Int- , mctMin   :: Maybe Int- , mctSec   :: Maybe Int- , mctPicosec :: Maybe Integer- , mctWDay     :: Maybe Day- , mctYDay     :: Maybe Int- , mctTZName   :: Maybe String- , mctTZ       :: Maybe Int- , mctIsDST    :: Maybe Bool- , mctWeek     :: Bool -- is set or not-} deriving Show---- | Trivially convert a 'CalendarTime' to a fully specified---   'MCalendarTime' (note that this sets the 'mctWeek' flag to---   @False@-toMCalendarTime :: CalendarTime -> MCalendarTime-toMCalendarTime (CalendarTime a b c d e f g h i j k l) =-  MCalendarTime (Just a) (Just b) (Just c) (Just d) (Just e) (Just f)-                (Just g) (Just h) (Just i) (Just j) (Just k) (Just l)-                False---- | Returns the first 'CalendarTime' that falls within a 'MCalendarTime'---   This is only unsafe in the sense that it plugs in default values---   for fields that have not been set, e.g. @January@ for the month---   or @0@ for the seconds field.---   Maybe we should rename it something happier.---   See also 'resetCalendar'-unsafeToCalendarTime :: MCalendarTime -> CalendarTime-unsafeToCalendarTime m =- CalendarTime-  { ctYear = fromMaybe 0 $ mctYear m-  , ctMonth = fromMaybe January $ mctMonth m-  , ctDay = fromMaybe 1 $ mctDay m-  , ctHour = fromMaybe 0 $ mctHour m-  , ctMin = fromMaybe 0 $ mctMin m-  , ctSec = fromMaybe 0 $ mctSec m-  , ctPicosec = fromMaybe 0 $ mctPicosec m-  , ctWDay = fromMaybe Sunday $ mctWDay m-  , ctYDay = fromMaybe 0 $ mctYDay m-  , ctTZName = fromMaybe "" $ mctTZName m-  , ctTZ = fromMaybe 0 $ mctTZ m-  , ctIsDST = fromMaybe False $ mctIsDST m- }--addToCal :: TimeDiff -> CalendarTime -> CalendarTime-addToCal td = toUTCTime . addToClockTime td . toClockTime--subtractFromCal :: TimeDiff -> CalendarTime -> CalendarTime-subtractFromCal = addToCal . multiplyDiff (-1)--addToMCal :: TimeDiff -> MCalendarTime -> MCalendarTime-addToMCal td mc =- copyCalendar (addToCal td $ unsafeToCalendarTime mc) mc--subtractFromMCal :: TimeDiff -> MCalendarTime -> MCalendarTime-subtractFromMCal = addToMCal . multiplyDiff (-1)---- surely there is a more concise way to express these-addDiff :: TimeDiff -> TimeDiff -> TimeDiff-addDiff (TimeDiff a1 a2 a3 a4 a5 a6 a7) (TimeDiff b1 b2 b3 b4 b5 b6 b7) =-  TimeDiff (a1+b1) (a2+b2) (a3+b3) (a4+b4) (a5+b5) (a6+b6) (a7 + b7)---- | 'multiplyDiff' @i d@ multiplies every field in @d@ with @i@------ FIXME; this seems like a terrible idea! it seems like--- we should get rid of it if at all possible, maybe adding an--- invertDiff function-multiplyDiff :: Int -> TimeDiff -> TimeDiff-multiplyDiff m (TimeDiff a1 a2 a3 a4 a5 a6 a7) =-  TimeDiff (a1*m) (a2*m) (a3*m) (a4*m) (a5*m) (a6*m) (a7 * (toInteger m))--nullMCalendar :: MCalendarTime-nullMCalendar = MCalendarTime Nothing Nothing Nothing Nothing Nothing Nothing-                              Nothing Nothing Nothing Nothing Nothing Nothing-                              False---- | Set a calendar to UTC time any eliminate any inconsistencies within---   (for example, where the weekday is given as @Thursday@, but this does not---   match what the numerical date would lead one to expect)-resetCalendar :: CalendarTime -> CalendarTime-resetCalendar = toUTCTime . toClockTime---- | 'copyCalendar' @c mc@ replaces any field which is---   specified in @mc@ with the equivalent field in @c@---   @copyCalendar c nullMCalendar == nullMCalendar@-copyCalendar :: CalendarTime -> MCalendarTime -> MCalendarTime-copyCalendar c mc = mc-  { mctYear  = mctYear mc  >> Just (ctYear c)-  , mctMonth = mctMonth mc >> Just (ctMonth c)-  , mctDay   = mctDay mc   >> Just (ctDay c)-  , mctHour  = mctHour mc  >> Just (ctHour c)-  , mctMin   = mctMin mc   >> Just (ctMin c)-  , mctSec   = mctSec mc   >> Just (ctSec c)-  , mctPicosec = mctPicosec mc >> Just (ctPicosec c)-  , mctWDay = mctWDay mc   >> Just (ctWDay c)-  , mctYDay = mctYDay mc   >> Just (ctYDay c)-  , mctTZName = mctTZName mc >> Just (ctTZName c)-  , mctTZ     = mctTZ mc    >> Just (ctTZ c)-  , mctIsDST  = mctIsDST mc >> Just (ctIsDST c)-  }---- | Zero the time fields of a 'CalendarTime'-unsetTime :: CalendarTime -> CalendarTime-unsetTime mc = mc-  { ctHour  = 0-  , ctMin   = 0-  , ctSec   = 0-  , ctPicosec = 0-  }
− src/Lcs.hs 
@@ -1,484 +0,0 @@--- Copyright (C) 2002 David Roundy--- Copyright (C) 2005 Benedikt Schmidt------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}---- |--- Module      : Lcs--- Copyright   : 2003 David Roundy---               2005 Benedikt Schmidt--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable------ LCS stands for Longest Common Subsequence, and it is a relatively--- challenging problem to find an LCS efficiently.  This module implements--- the algorithm described in:------   "An O(ND) Difference Algorithm and its Variations", Eugene Myers,---   Algorithmica Vol. 1 No. 2, 1986, pp. 251-266;---   especially the variation described in section 4.2 and most refinements---   implemented in GNU diff (D is the edit-distance).------ There is currently no heuristic to reduce the running time and produce--- suboptimal output for large inputs with many differences. It behaves like--- GNU diff with the -d option in this regard.------ In the first step, a hash value for every line is calculated and collisions--- are marked with a special value. This reduces a string comparison to an--- int comparison for line tuples where at least one of the hash values is--- not equal to the special value. After that, lines which only exists in one--- of the files are removed and marked as changed which reduces the running--- time of the following difference algorithm. GNU diff additionally removes--- lines that appear very often in the other file in some cases.--- The last step tries to create longer changed regions and line up deletions--- in the first file to insertions in the second by shifting changed lines--- forward and backward.--module Lcs ( getChanges,-             shiftBoundaries ) where--import Control.Monad-import Data.Int-import Control.Monad.ST-import Data.Maybe-import ByteStringUtils (hashPS)-import qualified Data.ByteString as B (empty, ByteString)-import Data.Array.Base-import Data.Array.Unboxed-import qualified Data.Map as Map ( lookup, empty, insertWith )-#include "impossible.h"---- | create a list of changes between a and b, each change has the form---   (starta, lima, startb, limb) which means that a[starta, lima)---   has to be replaced by b[startb, limb)-getChanges ::  [B.ByteString] -> [B.ByteString]-           -> [(Int,[B.ByteString],[B.ByteString])]-getChanges a b = dropStart (initP a) (initP b) 1--dropStart ::  PArray -> PArray -> Int-           -> [(Int,[B.ByteString],[B.ByteString])]-dropStart a b off-  | off > aLen a = [(off - 1, [], getSlice b off (aLen b))]-  | off > aLen b = [(off - 1, getSlice a off (aLen a), [])]-  | a!off == b!off = dropStart a b (off + 1)-  | otherwise      = dropEnd a b off 0--dropEnd ::  PArray -> PArray -> Int -> Int-        -> [(Int,[B.ByteString],[B.ByteString])]-dropEnd a b off end-    | off > alast        = [(off - 1, [], getSlice b off blast)]-    | off > blast        = [(off - 1, getSlice a off alast, [])]-    | a!alast == b!blast = dropEnd a b off (end + 1)-    | otherwise          = getChanges' (a, (off, alast)) (b, (off, blast))-  where alast = aLen a - end-        blast = aLen b - end--getSlice :: PArray -> Int -> Int -> [B.ByteString]-getSlice a from to-  | from > to = []-  | otherwise = (a ! from) : (getSlice a (from + 1) to)--getChanges' :: (PArray, (Int, Int)) -> (PArray, (Int, Int))-            -> [(Int,[B.ByteString],[B.ByteString])]-getChanges' (a, abounds) (b, bbounds) =-    map (convertPatch 0 a b) $ createPatch c_a c_b-  where-        -- If the last few characters of two lines are the same, the lines are-        -- probably the same. The choice of 20 is plucked out of the air.-        toHash x bnds = listArray bnds [ hashPS $ x!i | i <- range bnds]-        ah = toHash a abounds :: HArray-        mkAMap m (i:is) =-            let ins (_,_,_,new) (collision,_,_,old) =-                    (collision || (new /= old), True, False, old)-                m' = Map.insertWith ins (ah!i) (False, True, False, a!i) m-            in mkAMap m' is-        mkAMap m _ = m-        hm_a = mkAMap Map.empty (range abounds)-        ---        bh = toHash b bbounds :: HArray-        mkBMap m (i:is) =-            let ins (_,_,_,new) (collision,in_a,_,old) =-                    (collision || (new /= old), in_a, True, old)-                m' = Map.insertWith ins (bh!i) (False, False, True, b!i) m-            in mkBMap m' is-        mkBMap m _ = m-        hm = mkBMap hm_a (range bbounds)-        -- take care of collisions, if there are different lines with the-        -- same hash in both files, then set the hash to markColl,-        -- PackedStrings are compared for two lines with the hash markColl-        get (i, h) = case Map.lookup h hm of-                      Just (_,False,_,_) -> Nothing-                      Just (_,_,False,_) -> Nothing-                      Just (False,True,True,_) -> Just (i, h)-                      Just (True,True,True,_) -> Just (i, markColl)-                      Nothing -> impossible--        a' = mapMaybe get [(i, ah!i) | i <- range (bounds ah)]-        b' = mapMaybe get [(i, bh!i) | i <- range (bounds bh)]--        (c_a, c_b) = diffArr a' b' (a, abounds) (b, bbounds)---- | mark hash value where collision occured-markColl :: Int32-markColl = 2345677---- | return arrays with changes in a and b (1 indexed), offsets start with 0-diffArr :: [(Int,Int32)] -> [(Int,Int32)]-        -> (PArray, (Int, Int)) -> (PArray, (Int, Int))-        -> (BArray, BArray)-diffArr a b (p_a, (off_a, l_a)) (p_b, (off_b, l_b)) = runST (-  do let h_a = initH (map snd a)-         h_b = initH (map snd b)-         m_a = initM (map fst a)-         m_b = initM (map fst b)-         end_a = (aLen p_a)-         end_b = (aLen p_b)-     c_a <- initVChanged end_a-     c_b <- initVChanged end_b-     mapM_ (\ (l,_) -> writeArray c_a l False) a-     mapM_ (\ (l,_) -> writeArray c_b l False) b-     _ <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b 0 0 (aLen h_a) (aLen h_b)-     let unchanged ar = do {xs <- getElems ar; return $ length (filter not xs) -1}-     err <- liftM2 (/=) (unchanged c_a) (unchanged c_b)-     when err impossible-     -- Mark common lines at beginning and end-     mapM_ (\ i -> writeArray c_a i False ) [1..(off_a - 1)]-     mapM_ (\ i -> writeArray c_b i False ) [1..(off_b - 1)]-     mapM_ (\ i -> writeArray c_a i False ) [(l_a + 1) .. end_a]-     mapM_ (\ i -> writeArray c_b i False ) [(l_b + 1) .. end_b]-     shiftBoundaries c_a c_b p_a 1 1-     shiftBoundaries c_b c_a p_b 1 1-     err1 <- liftM2 (/=) (unchanged c_a) (unchanged c_b)-     when err1 impossible-     c_a' <- unsafeFreeze c_a-     c_b' <- unsafeFreeze c_b-     return (c_a', c_b'))---- | set changes array for a and b and return number of changed lines-cmpseq :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray-       -> BSTArray s -> BSTArray s -> Int -> Int -> Int -> Int -> ST s Int-cmpseq _ _ _ _ _ _ _ _ _ _ 0 0 = return 0-cmpseq h_a h_b p_a p_b m_a m_b c_a c_b off_a off_b l_a l_b = do-  let lim_a = off_a+l_a-      lim_b = off_b+l_b-      off_a' = findSnake h_a h_b p_a p_b m_a m_b off_a off_b l_a l_b off_a off_b-      off_b' = off_b+off_a'-off_a-      lim_a' = findSnakeRev h_a h_b p_a p_b m_a m_b lim_a lim_b off_a' off_b'-      lim_b' = lim_b+lim_a'-lim_a-      l_a' = lim_a'-off_a'-      l_b' = lim_b'-off_b'-  if l_a' == 0 || l_b' == 0-     then if l_a' == 0-             then do when (l_b' > 0) $-                          mapM_ (\i -> writeArray c_b (m_b!i) True)-                                [(off_b' + 1) .. lim_b']-                     return l_b'-             else do when (l_a' > 0) $-                          mapM_ (\i -> writeArray c_a (m_a!i) True)-                                [(off_a' + 1) .. lim_a']-                     return l_a'-     else do let m = l_a' + l_b'-                 del = l_a' - l_b'-                 dodd = odd del-             v <- initV m-             vrev <- initVRev m l_a'-             writeArray vrev 0 l_a'-             writeArray v 0 0-             (xmid, ymid, _) <- findDiag 1 h_a h_b p_a p_b m_a m_b v vrev-                                off_a' off_b' l_a' l_b' del dodd-             when ((xmid == 0 && ymid == 0) || (xmid == l_a' && ymid == l_b')-                   || (xmid < 0 || ymid < 0 || xmid > l_a' || ymid > l_b'))-                     impossible-             c1 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b-                          off_a' off_b' xmid ymid-             c2 <- cmpseq h_a h_b p_a p_b m_a m_b c_a c_b-                          (off_a' + xmid) (off_b' + ymid)-                          (l_a' - xmid) (l_b' - ymid)-             return $ c1 + c2---- | return (xmid, ymid, cost) for the two substrings---   a[off_a+1..off_a+1+l_a] and b-findDiag :: Int -> HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray-         -> VSTArray s -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> Bool-         -> ST s (Int, Int, Int)-findDiag c h_a h_b p_a p_b m_a m_b v vrev off_a off_b l_a l_b del dodd = do-  when (c > l_a + l_b) $ error "findDiag failed"-  r <- findF-  case r of-    Just (xmid, ymid) -> return (xmid, ymid, (c*2 - 1))-    Nothing ->-      do r' <- findR-         case r' of-           Just (xmid, ymid) -> return (xmid, ymid, c*2)-           Nothing -> findDiag (c + 1) h_a h_b p_a p_b m_a m_b v vrev-                      off_a off_b l_a l_b del dodd- where fdmax = if c <= l_a then c else l_a - ((l_a + c) `mod` 2)-       rdmax = if c <= l_b then c else l_b - ((l_b + c) `mod` 2)-       lastrdmax = if (c-1) <= l_b then c-1 else l_b-(l_b + (c-1) `mod` 2)-       lastrdmin = -(if (c-1) <= l_a then c-1 else l_a-((l_a + (c-1)) `mod` 2))-       fdmin = -rdmax-       rdmin = -fdmax-       findF = findF' fdmax-       findR = findR' rdmax-       findF' d = do x <- findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b-                     if dodd && d - del >= lastrdmin && d - del <= lastrdmax-                        then do xr <- readArray vrev (d - del)-                                if xr <= x then return $ Just (x, x - d)-                                           else if d <= fdmin then return Nothing-                                                              else findF' (d-2)-                        else if d <= fdmin then return Nothing else findF' (d-2)-       findR' d = do x <- findOneRev h_a h_b p_a p_b m_a m_b vrev d del off_a off_b-                     if not dodd && (d + del >= fdmin) && (d + del <= fdmax)-                        then do xf <- readArray v (d + del)-                                if x <= xf then return $ Just (x,x-del-d)-                                           else if d <= rdmin then return Nothing-                                                              else findR' (d-2)-                        else if d <= rdmin then return Nothing else findR' (d-2)---- | find position on diag d with one more insert/delete going forward-findOne  :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray-         -> VSTArray s -> Int -> Int -> Int -> Int -> Int -> ST s Int-findOne h_a h_b p_a p_b m_a m_b v d off_a off_b l_a l_b = do-  x0 <- do xbelow <- readArray v (d - 1)-           xover <- readArray v (d + 1)-           return $ if xover > xbelow then xover else xbelow + 1-  let y0 = x0 - d-      x = findSnake h_a h_b p_a p_b  m_a m_b (x0+off_a) (y0+off_b)-            l_a l_b off_a off_b-  writeArray v d (x - off_a)-  return (x-off_a)---- | follow snake from northwest to southeast, x and y are absolute positions-findSnake :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray-          -> Int -> Int -> Int -> Int -> Int -> Int -> Int-findSnake h_a h_b p_a p_b  m_a m_b x y l_a l_b off_a off_b =-  if x < l_a + off_a && y < l_b + off_b && h_a!(x+1) == h_b!(y+1)-       && (h_a!(x+1) /= markColl || p_a!(m_a!(x+1)) == p_b!(m_b!(y+1)))-     then findSnake h_a h_b p_a p_b m_a m_b (x + 1) (y + 1) l_a l_b off_a off_b-     else x---- | find position on diag d with one more insert/delete going backward-findOneRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray-           -> VSTArray s -> Int -> Int -> Int -> Int -> ST s Int-findOneRev h_a h_b p_a p_b m_a m_b v d del off_a off_b = do-  x0 <- do xbelow <- readArray v (d - 1)-           xover <- readArray v (d + 1)-           return $ if xbelow < xover then xbelow else xover-1-  let y0 = x0 - del - d-      x = findSnakeRev h_a h_b p_a p_b m_a m_b (x0+off_a) (y0+off_b)-            off_a off_b-  writeArray v d (x-off_a)-  return (x-off_a)---- | follow snake from southeast to northwest, x and y are absolute positions-findSnakeRev :: HArray -> HArray -> PArray -> PArray -> MapArray -> MapArray-             -> Int -> Int -> Int -> Int -> Int-findSnakeRev h_a h_b p_a p_b m_a m_b x y off_a off_b =-  if x > off_a && y > off_b && h_a!x == h_b!y-       && (h_a!x /= markColl || p_a!(m_a!x) == p_b!(m_b!y))-     then findSnakeRev h_a h_b p_a p_b m_a m_b (x - 1) (y - 1) off_a off_b-     else x---- | try to create nicer diffs by shifting around regions of changed lines-shiftBoundaries :: BSTArray s -> BSTArray s -> PArray -> Int -> Int -> ST s ()-shiftBoundaries c_a c_b p_a i_ j_ =-  do x <- nextChanged c_a i_-     case x of-       Just start ->-             do let skipped = start - i_-                j1 <- nextUnchangedN c_b skipped j_-                end <- nextUnchanged c_a start-                j2 <- nextUnchanged c_b j1-                (i3,j3) <- expand start end j2-                shiftBoundaries c_a c_b p_a i3 j3-       Nothing -> return () -- no change up to end of file- where noline = (aLen p_a) + 1-       expand start i j =-         do let len = i - start-            (start0,i0,j0) <- shiftBackward start i j-            b <- if j0 > 1 then readArray c_b (j0-1) else return False-            let corr = if b then i0 else noline-            let blank = if p_a!(i0-1) == B.empty then i0-                                               else noline-            (start1,i1,j1,corr1,blank1) <- shiftForward start0 i0 j0 corr blank-            -- prefer corresponding to ending with blank line-            let newi = if corr1 == noline then blank1-                                          else corr1-            (start2,i2,j2) <- moveCorr start1 i1 j1 newi-            if len /= i2 - start2-                then expand start2 i2 j2-                else return (i2, j2)-       shiftBackward start i j =-         if start > 1 && p_a!(i-1) == p_a!(start-1)-            then do when (i == start) impossible-                    b1 <- readArray c_a (i-1)-                    b2 <- readArray c_a (start-1)-                    when (not b1 || b2) impossible-                    writeArray c_a (i-1) False-                    writeArray c_a (start-1) True-                    b <- if start > 2 then readArray c_a (start-2)-                                      else return False-                    start' <- if b then liftM (1+) (prevUnchanged c_a (start-2))-                                   else return (start-1)-                    j' <- prevUnchanged c_b (j-1)-                    shiftBackward start' (i-1) j'-            else return (start,i,j)-       shiftForward start i j corr blank =-         if i <= aLen p_a && p_a!i == p_a!start &&-             -- B.empty at the end of file marks empty line after final newline-             not ((i == aLen p_a) && (p_a!i == B.empty))-            then do when (i == start) impossible-                    b1 <- readArray c_a i-                    b2 <- readArray c_a start-                    when (not b2 ||  b1) impossible-                    writeArray c_a i True-                    writeArray c_a start False-                    i0 <- nextUnchanged c_a (i+1)-                    j0 <- nextUnchanged c_b (j+1)-                    let corr0 = if i0 > (i+1) then noline-                                              else if j0-j > 2 then i0 else corr-                    let blank0 = if i0 > i+1 then noline-                                 else if p_a!(i0-1) == B.empty then i0-                                                             else blank-                    shiftForward (start+1) i0 j0 corr0 blank0-            else return (start,i,j,corr,blank)-       moveCorr start i j corr =-         if corr >= i-            then return (start,i,j)-            else do b1 <- readArray c_a (i-1)-                    b2 <- readArray c_a (start-1)-                    when (not b1 || b2) impossible-                    when (p_a!(i-1) /= p_a!(start-1)) impossible-                    writeArray c_a (i-1) False-                    writeArray c_a (start-1) True-                    j' <- prevUnchanged c_b (j-1)-                    moveCorr (start-1) (i-1) j' corr---- | goto next unchanged line, return the given line if unchanged-nextUnchanged :: BSTArray s -> Int -> ST s Int-nextUnchanged c i = do-  len <- aLenM c-  if i == len + 1 then return i-     else do b <- readArray c i-             if b then nextUnchanged c (i+1)-                  else return i---- | skip at least one unchanged line, if there is none advance---   behind the last line-skipOneUnChanged :: BSTArray s -> Int -> ST s Int-skipOneUnChanged c i = do-  len <- aLenM c-  if i == len + 1-     then return i-     else do b <- readArray c i-             if not b then return (i+1)-                      else skipOneUnChanged c (i+1)---- | goto n-th next unchanged line-nextUnchangedN :: BSTArray s -> Int -> Int -> ST s Int-nextUnchangedN c n i =-  if n == 0 then return i-            else do i' <- skipOneUnChanged c i-                    nextUnchangedN c (n-1) i'---- | goto next changed line, return the given line if changed-nextChanged :: BSTArray s -> Int -> ST s (Maybe Int)-nextChanged c i = do-  len <- aLenM c-  if i <= len-    then do b <- readArray c i-            if not b then nextChanged c (i+1)-                     else return $ Just i-    else return Nothing---- | goto previous unchanged line, return the given line if unchanged-prevUnchanged :: BSTArray s -> Int -> ST s Int-prevUnchanged c i = do-  b <- readArray c i-  if b then prevUnchanged c (i-1)-       else return i--type HArray = UArray Int Int32-type BArray = UArray Int Bool-type PArray = Array Int B.ByteString-type MapArray = UArray Int Int-type VSTArray s = STUArray s Int Int-type BSTArray s = STUArray s Int Bool--initV :: Int -> ST s (VSTArray s)-initV dmax = newArray (-(dmax + 1), dmax + 1) (-1)--initVRev :: Int -> Int -> ST s (VSTArray s)-initVRev dmax xmax = newArray (-(dmax + 1), dmax + 1) (xmax + 1)---- 1 indexed, v[0] is used as a guard element-initVChanged :: Int -> ST s (BSTArray s)-initVChanged l = do-  a <- newArray (0, l) True-  writeArray a 0 False-  return a-  -- set to false for all lines which have a mapping later-  -- other lines are only present in one of the files--initH :: [Int32] -> HArray-initH a = listArray (0, length a) (0:a)--initM :: [Int] -> MapArray-initM a = listArray (0, length a) (0:a)--initP :: [B.ByteString] -> PArray-initP a = listArray (0, length a) (B.empty:a)--aLen :: (IArray a e) => a Int e -> Int-aLen a = snd $ bounds a-aLenM :: (MArray a e m) => a Int e -> m Int-aLenM a = getBounds a >>= return . snd--convertPatch :: Int -> PArray -> PArray -> (Int, Int, Int, Int)-             -> (Int,[B.ByteString],[B.ByteString])-convertPatch off a b (a0,a1,b0,b1)- | b0 == b1 = (b0+off,getDelete a a0 a1,[])- | a0 == a1 = (b0+off,[],getInsert b b0 b1)- | otherwise = (b0+off,getDelete a a0 a1,getInsert b b0 b1)--getInsert :: PArray -> Int -> Int -> [B.ByteString]-getInsert b from to-  | from >= to = []-  | otherwise = (b!(from+1)):(getInsert b (from+1) to)-getDelete :: PArray -> Int -> Int -> [B.ByteString]-getDelete a from to-  | from >= to = []-  | otherwise = (a!(from+1)):(getDelete a (from+1) to)--createPatch :: BArray -> BArray -> [(Int, Int, Int, Int)]-createPatch c_a c_b =-  reverse $ createP c_a c_b (aLen c_a) (aLen c_b)--createP :: BArray -> BArray -> Int -> Int -> [(Int, Int, Int, Int)]-createP _ _ 0 0 = []-createP c_a c_b ia ib =-  if c_a!ia || c_b!ib-     then let ia' = skipChangedRev c_a ia-              ib' = skipChangedRev c_b ib-          in (ia',ia,ib',ib):(createP c_a c_b ia' ib')-     else createP c_a c_b (ia-1) (ib-1)--skipChangedRev :: BArray -> Int -> Int-skipChangedRev c i = if i >= 0 && c!i then skipChangedRev c (i-1) else i
− src/Preproc.hs 
@@ -1,187 +0,0 @@--- | This program mangles a pseudo-LaTeX document into actual LaTeX.--- There are three key changes to the input:------   * \\input{foo} is replaced by the contents of the file foo (after---     it, too, is mangled).  Note that this is relative to the---     working directory, *not* relative to the file being parsed.------   * Anything between \\begin{code} and \\end{code} is deleted.---     Note that this is quite unlike normal literate documentation---     (for which we use Haddock, not LaTeX).------   * Some nonstandard pseudo-LaTeX commands are expanded into actual---     LaTeX text.  In particular, \\darcsCommand{foo} is replaced by---     LaTeX markup describing the command @foo@.-module Preproc ( preprocMain ) where-import qualified Ratified( readFile )-import System.FilePath ( (</>) )-import System.Environment ( getArgs )-import System.Exit ( exitWith, ExitCode(..) )-import Control.Monad ( when )-import Data.List ( stripPrefix )-import Text.Regex ( matchRegex, mkRegex )-import Darcs.Commands ( DarcsCommand(SuperCommand,-                        commandSubCommands, commandName,-                        commandExtraArgHelp, commandBasicOptions,-                        commandAdvancedOptions, commandHelp,-                        commandDescription),-                        extractCommands )-import Darcs.Arguments ( optionsLatex )-import Darcs.Commands.Help ( commandControlList, environmentHelp )-import English ( andClauses )-import Version ( version )--theCommands :: [DarcsCommand]-theCommands = extractCommands commandControlList---- | The entry point for this program.  The path to the TeX master--- file is supplied as the first argument.  Bootstrapping into--- 'preproc' then happens by passing it a pseudo-document that--- contains a single input (include) line.-preprocMain :: [String] -> IO ()-preprocMain args = do-  when (length args < 1) $ exitWith $ ExitFailure 1-  putStrLn "%% This file was automatically generated by preproc."-  c <- preproc ["\\input{"++head args++"}"]-  mapM_ putStrLn c---- | Depending on whether pdflatex or htlatex is to be used, the LaTeX--- output of this program must vary subtly.  This procedure returns--- true iff the command-line arguments contain @--html@.-amHtml :: IO Bool-amHtml = do args <- getArgs-            return $ elem "--html" args---- | Given a list of input lines in pseudo-LaTeX, return the same--- document in LaTeX.  The pseudo-LaTeX lines are replaced, other--- lines are used unmodified.-preproc :: [String] -> IO [String]-preproc [] = return []              -- Empty input, empty output.-preproc ("\\usepackage{html}":ss) = -- only use html package with latex2html-    do rest <- preproc ss-       ah <- amHtml-       return $ if ah-                then "\\usepackage{html}" : rest-                else "\\usepackage{hyperref}" : rest-preproc ("\\begin{code}":ss) = ignore ss-    where ignore :: [String] -> IO [String]-          ignore ("\\end{code}":ss') = preproc ss'-          ignore (_:ss') = ignore ss'-          ignore [] = return []-preproc ("\\begin{options}":ss) =-    do rest <- preproc ss-       ah <- amHtml-       return $ if ah-                then "\\begin{rawhtml}" : "<div class=\"cmd-opt-hdr\">" : rest-                else ("\\begin{Verbatim}[frame=lines,xleftmargin=1cm," ++-                            "xrightmargin=1cm]") : rest-preproc ("\\end{options}":ss) =-    do rest <- preproc ss-       ah <- amHtml-       return $ if ah-                then "</div>" : "\\end{rawhtml}" : rest-                else "\\end{Verbatim}" : rest-preproc ("\\darcsVersion":ss) = do-  rest <- preproc ss-  return $ version:rest-preproc (s:ss) = do-  rest <- preproc ss-  let rx = mkRegex "^\\\\(input|darcsCommand|darcsEnv)\\{(.+)\\}$"-  case matchRegex rx s of-    Just ["input", path] ->-        do cs <- Ratified.readFile $ "doc" </> "src" </> path -- not part of normal darcs operation-           this <- preproc $ lines cs-           return $ this ++ rest-    Just ["darcsCommand", command] ->-        return $ latexCommandHelp command : rest-    Just ["darcsEnv", variable] ->-        return $ envHelp variable : rest-    -- The base case for the whole preproc function.  Nothing to-    -- mangle, so this is an ordinary line of TeX, and we append it to-    -- the result unmodified.-    _ -> return $ s : rest--latexCommandHelp :: String -> String-latexCommandHelp command = section ++ "{darcs " ++ command ++ "}\n" ++-                      "\\label{" ++ command ++ "}\n" ++-                      gh ++ getOptions command ++ "\n" ++ gd-    where-      section = if ' ' `elem` command then "\\subsubsection" else "\\subsection"-      -- | Given a Darcs command name as a string, return that command's (multi-line) help string.-      gh :: String-      gh =  escapeLatexSpecials $ commandProperty commandHelp theCommands command-      -- | Given a Darcs command name as a string, return that command's (one-line) description string.-      gd :: String-      gd = commandProperty commandDescription theCommands command--getOptions :: String -> String-getOptions comm = getComOptions $ getC names theCommands-    where names = words comm--getC :: [String] -> [DarcsCommand] -> [DarcsCommand]-getC (name:ns) commands =-    case ns of-    [] -> [get name commands]-    _ -> case get name commands of-         c@SuperCommand { } ->-             c : getC ns (extractCommands $ commandSubCommands c)-         _ ->-             error $ "Not a supercommand: " ++ name-    where get n (c:cs) | commandName c == n = c-                       | otherwise = get n cs-          get n [] = error $ "No such command:  "++n-getC [] _ = error "no command specified"--getComOptions :: [DarcsCommand] -> String-getComOptions c =-    "\\par\\verb!Usage: darcs " ++ cmd ++ " [OPTION]... " ++-    args ++ "!\n\n" ++ "Options:\n\n" ++ optionsLatex opts1 ++-    (if null opts2 then "" else "\n\n" ++ "Advanced options:\n\n" ++ optionsLatex opts2)-    where cmd = unwords $ map commandName c-          args = unwords $ commandExtraArgHelp $ last c-          opts1 = commandBasicOptions $ last c-          opts2 = commandAdvancedOptions $ last c--commandProperty :: (DarcsCommand -> String) -> [DarcsCommand] -> String-                 -> String-commandProperty property commands name =-    property $ last c-    where names = words name-          c = getC names commands----envHelp :: String -> String-envHelp var = unlines $ render $ entry environmentHelp-    where render (ks, ds) =-              ("\\paragraph{" ++ escapeLatexSpecials (andClauses ks) ++ "}") :-              ("\\label{env:" ++ var ++ "}") :-              map escapeLatexSpecials ds-          entry [] = undefined-          entry (x:xs) | elem var $ fst x = x-                       | otherwise = entry xs---- | LaTeX treats a number of characters or sequences specially.--- Therefore when including ordinary help text in a LaTeX document, it--- is necessary to escape these characters in the way LaTeX expects.-escapeLatexSpecials :: String -> String--- Order is important-escapeLatexSpecials =-  bs2 . amp . percent . carrot . dollar . underscore . rbrace . lbrace . bs1-  where-    amp        = replace "&"  "\\&"-    bs1        = replace "\\" "\001"-    bs2        = replace "\001" "$\\backslash$"-    carrot     = replace "^"  "\\^{}"-    dollar     = replace "$"  "\\$"-    lbrace     = replace "{"  "\\{"-    percent    = replace "%"  "\\%"-    rbrace     = replace "}"  "\\}"-    underscore = replace "_"  "\\_"--    replace :: Eq a => [a] -> [a] -> [a] -> [a]-    replace _ _ [] = []-    replace find repl s =-        case stripPrefix find s of-            Just rest -> repl ++ replace find repl rest-            Nothing -> head s : replace find repl (tail s)
− src/Printer.lhs 
@@ -1,425 +0,0 @@--A Document is at heart ShowS from the prelude-\htmladdnormallink{http://www.haskell.org/onlinereport/standard-prelude.html#\$tShowS}--Essentially, if you give a Doc a string it'll print out whatever it-wants followed by that string. So \verb!(text "foo")! makes the Doc that-prints \verb!"foo"! followed by its argument. The combinator names are taken-from Text.PrettyPrint.HughesPJ, although the behaviour of the two libraries is-slightly different.--The advantage of Printer over simple string appending/concatenating is-that the appends end up associating to the right, e.g.:--\begin{verbatim}-  (text "foo" <> text "bar") <> (text "baz" <> text "quux") ""-= \s -> (text "foo" <> text "bar") ((text "baz" <> text "quux") s) ""-= (text "foo" <> text "bar") ((text "baz" <> text "quux") "")-= (\s -> (text "foo") (text "bar" s)) ((text "baz" <> text "quux") "")-= text "foo" (text "bar" ((text "baz" <> text "quux") ""))-= (\s -> "foo" ++ s) (text "bar" ((text "baz" <> text "quux") ""))-= "foo" ++ (text "bar" ((text "baz" <> text "quux") ""))-= "foo" ++ ("bar" ++ ((text "baz" <> text "quux") ""))-= "foo" ++ ("bar" ++ ((\s -> text "baz" (text "quux" s)) ""))-= "foo" ++ ("bar" ++ (text "baz" (text "quux" "")))-= "foo" ++ ("bar" ++ ("baz" ++ (text "quux" "")))-= "foo" ++ ("bar" ++ ("baz" ++ ("quux" ++ "")))-\end{verbatim}--The Empty alternative comes in because you want-\begin{verbatim}-    text "a" $$ vcat xs $$ text "b"-\end{verbatim}-(\verb!$$! means ``above'', vcat is the list version of \verb!$$!) to be-\verb!"a\nb"! when \verb!xs!  is \verb![]!, but without the concept of an-Empty Document each \verb!$$! would add a \verb!'\n'! and you'd end up with-\verb!"a\n\nb"!. Note that \verb!Empty /= text ""! (the latter would cause two-\verb!'\n'!s).--This code was made generic in the element type by Juliusz Chroboczek.-\begin{code}-module Printer (Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..),-                hPutDoc,     hPutDocLn,     putDoc,     putDocLn,-                hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith,-                renderString, renderStringWith, renderPS, renderPSWith,-                renderPSs, renderPSsWith, lineColor,-                prefix, insertBeforeLastline, colorText, invisibleText,-                hiddenText, hiddenPrefix, userchunk, text,-                printable, wrapText,-                blueText, redText, greenText, magentaText, cyanText,-                unsafeText, unsafeBoth, unsafeBothText, unsafeChar,-                invisiblePS, packedString, unsafePackedString, userchunkPS,-                simplePrinters, invisiblePrinter, simplePrinter,-                doc, empty, (<>), (<?>), (<+>), ($$), vcat, vsep, hcat,-                minus, newline, plus, space, backslash, lparen, rparen,-                parens,-                errorDoc,-               ) where--import Data.List (intersperse)-import System.IO (Handle, stdout, hPutStr)-import ByteStringUtils ( linesPS )-import qualified Data.ByteString as B (ByteString, hPut, concat)-import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton)---- | A 'Printable' is either a String, a packed string, or a chunk of--- text with both representations.-data Printable = S !String-               | PS !B.ByteString-               | Both !String !B.ByteString---- | 'spaceP' is the 'Printable' representation of a space.-spaceP :: Printable-spaceP   = Both " "  (BC.singleton ' ')---- | 'newlineP' is the 'Printable' representation of a newline.-newlineP :: Printable-newlineP = S "\n"---- | Minimal 'Doc's representing the common characters 'space', 'newline'--- 'minus', 'plus', and 'backslash'.-space, newline, plus, minus, backslash :: Doc-space     = unsafeBoth " "  (BC.singleton ' ')-newline   = unsafeChar '\n'-minus     = unsafeBoth "-"  (BC.singleton '-')-plus      = unsafeBoth "+"  (BC.singleton '+')-backslash = unsafeBoth "\\" (BC.singleton '\\')---- | 'lparen' is the 'Doc' that represents @\"(\"@-lparen :: Doc-lparen = unsafeBoth  "(" (BC.singleton '(')---- | 'rparen' is the 'Doc' that represents @\")\"@-rparen :: Doc-rparen = unsafeBoth ")" (BC.singleton ')')---- | @'parens' doc@ returns a 'Doc' with the content of @doc@ put within--- a pair of parenthesis.-parens :: Doc -> Doc-parens d = lparen <> d <> rparen--errorDoc :: Doc -> a-errorDoc = error . renderStringWith simplePrinters'----- | 'putDocWith' puts a doc on stdout using the given printer.-putDocWith :: Printers -> Doc -> IO ()-putDocWith prs = hPutDocWith prs stdout---- | 'putDocLnWith' puts a doc, followed by a newline on stdout using--- the given printer.-putDocLnWith :: Printers -> Doc -> IO ()-putDocLnWith prs = hPutDocLnWith prs stdout----- | 'putDoc' puts a doc on stdout using the simple printer 'simplePrinters'.-putDoc :: Doc -> IO ()--- | 'putDocLn' puts a doc, followed by a newline on stdout using--- 'simplePrinters'-putDocLn :: Doc -> IO ()-putDoc = hPutDoc stdout-putDocLn = hPutDocLn stdout---- | 'hputDocWith' puts a doc on the given handle using the given printer.-hPutDocWith :: Printers -> Handle -> Doc -> IO ()--- | 'hputDocLnWith' puts a doc, followed by a newline on the given--- handle using the given printer.-hPutDocLnWith :: Printers -> Handle -> Doc -> IO ()--hPutDocWith prs h d = hPrintPrintables h (renderWith (prs h) d)-hPutDocLnWith prs h d = hPutDocWith prs h (d <?> newline)---- |'hputDoc' puts a doc on the given handle using 'simplePrinters'-hPutDoc :: Handle -> Doc -> IO ()--- 'hputDocLn' puts a doc, followed by a newline on the given handle using--- 'simplePrinters'.-hPutDocLn :: Handle -> Doc -> IO ()-hPutDoc = hPutDocWith simplePrinters-hPutDocLn = hPutDocLnWith simplePrinters---- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle h-hPrintPrintables :: Handle -> [Printable] -> IO ()-hPrintPrintables h = mapM_ (hPrintPrintable h)---- | @hPrintPrintable h@ prints a 'Printable' to the handle h.-hPrintPrintable :: Handle -> Printable -> IO ()-hPrintPrintable h (S ps) = hPutStr h ps-hPrintPrintable h (PS ps) = B.hPut h ps-hPrintPrintable h (Both _ ps) = B.hPut h ps---- | a 'Doc' is a bit of enriched text. 'Doc's get concatanated using--- '<>', which is right-associative.-newtype Doc = Doc { unDoc :: St -> Document }---- | The State associated with a doc. Contains a set of printers for each--- hanlde, and the current prefix of the document.-data St = St { printers :: !Printers',-               currentPrefix :: !([Printable] -> [Printable]) }-type Printers = Handle -> Printers'---- | A set of printers to print different types of text to a handle.-data Printers' = Printers {colorP :: !(Color -> Printer),-                           invisibleP :: !Printer,-                           hiddenP :: !Printer,-                           userchunkP :: !Printer,-                           defP :: !Printer,-                           lineColorT :: !(Color -> Doc -> Doc),-                           lineColorS :: !([Printable] -> [Printable])-                          }-type Printer = Printable -> St -> Document--data Color = Blue | Red | Green | Cyan | Magenta---- | 'Document' is a wrapper around '[Printable] -> [Printable]' which allows--- for empty Documents. The simplest 'Documents' are built from 'String's--- using 'text'.-data Document = Document ([Printable] -> [Printable])-              | Empty---- | renders a 'Doc' into a 'String' with control codes for the--- special features of the doc.-renderString :: Doc -> String-renderString = renderStringWith simplePrinters'---- | renders a 'Doc' into a 'String' using a given set of printers.-renderStringWith :: Printers' -> Doc -> String-renderStringWith prs d = concatMap toString $ renderWith prs d-    where toString (S s) = s-          toString (PS ps) = BC.unpack ps-          toString (Both s _) = s---- | renders a 'Doc' into 'B.ByteString' with control codes for the--- special features of the Doc. See also 'readerString'.-renderPS :: Doc -> B.ByteString-renderPS = renderPSWith simplePrinters'---- | renders a 'Doc' into a list of 'PackedStrings', one for each line.-renderPSs :: Doc -> [B.ByteString]-renderPSs = renderPSsWith simplePrinters'---- | renders a doc into a 'B.ByteString' using a given set of printers.-renderPSWith :: Printers' -> Doc -> B.ByteString-renderPSWith prs d = B.concat $ renderPSsWith prs d---- | renders a 'Doc' into a list of 'PackedStrings', one for each--- chunk of text that was added to the doc, using the given set of--- printers.-renderPSsWith :: Printers' -> Doc -> [B.ByteString]-renderPSsWith prs d = map toPS $ renderWith prs d-    where toPS (S s)        = BC.pack s-          toPS (PS ps)      = ps-          toPS (Both _ ps)  = ps---- | renders a 'Doc' into a list of 'Printables' using a set of--- printers. Each item of the list corresponds to a string that was--- added to the doc.-renderWith :: Printers' -> Doc -> [Printable]-renderWith ps (Doc d) = case d (initState ps) of-                        Empty -> []-                        Document f -> f []--initState :: Printers' -> St-initState prs = St { printers = prs, currentPrefix = id }--prefix :: String -> Doc -> Doc-prefix s (Doc d) = Doc $ \st ->-                   let p = S s-                       st' = st { currentPrefix = currentPrefix st . (p:) } in-                   case d st' of-                     Document d'' -> Document $ (p:) . d''-                     Empty -> Empty---insertBeforeLastline :: Doc -> Doc -> Doc-insertBeforeLastline a b =-   case reverse $ map packedString $ linesPS $ renderPS a of-   (ll:ls) -> vcat (reverse ls) $$ b $$ ll-   [] -> error "empty Doc given as first argument of Printer.insert_before_last_line"---lineColor :: Color -> Doc -> Doc-lineColor c d = Doc $ \st -> case lineColorT (printers st) c d of-                             Doc d' -> d' st--hiddenPrefix :: String -> Doc -> Doc-hiddenPrefix s (Doc d) =-    Doc $ \st -> let pr = printers st-                     p = S (renderStringWith pr $ hiddenText s)-                     st' = st { currentPrefix = currentPrefix st . (p:) }-                 in case d st' of-                      Document d'' -> Document $ (p:) . d''-                      Empty -> Empty---- | 'unsafeBoth' builds a Doc from a 'String' and a 'B.ByteString' representing--- the same text, but does not check that they do.-unsafeBoth :: String -> B.ByteString -> Doc-unsafeBoth s ps = Doc $ simplePrinter (Both s ps)---- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the--- Doc as both a String and a 'B.ByteString'.-unsafeBothText :: String -> Doc-unsafeBothText s = Doc $ simplePrinter (Both s (BC.pack s))---- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable'-packedString :: B.ByteString -> Doc--- | 'unsafePackedString' builds a 'Doc' from a 'B.ByteString' using 'simplePrinter'-unsafePackedString :: B.ByteString -> Doc--- | 'invisiblePS' creates a 'Doc' with invisible text from a 'B.ByteString'-invisiblePS :: B.ByteString -> Doc--- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'.-userchunkPS :: B.ByteString -> Doc-packedString = printable . PS-unsafePackedString = Doc . simplePrinter . PS-invisiblePS = invisiblePrintable . PS-userchunkPS = userchunkPrintable . PS---- | 'unsafeChar' creates a Doc containing just one character.-unsafeChar :: Char -> Doc-unsafeChar = unsafeText . (:"")---- | 'text' creates a 'Doc' from a @String@, using 'printable'.-text :: String -> Doc--- | 'unsafeText' creates a 'Doc' from a 'String', using 'simplePrinter' directly-unsafeText :: String -> Doc--- | 'invisibleText' creates a 'Doc' containing invisible text from a @String@-invisibleText :: String -> Doc--- | 'hiddenText' creates a 'Doc' containing hidden text from a @String@-hiddenText :: String -> Doc--- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@-userchunk :: String -> Doc--- | 'blueText' creates a 'Doc' containing blue text from a @String@-blueText, redText, greenText, magentaText, cyanText :: String -> Doc-text = printable . S-unsafeText = Doc . simplePrinter . S-invisibleText = invisiblePrintable . S-hiddenText = hiddenPrintable . S-userchunk = userchunkPrintable . S-blueText = colorText Blue-redText = colorText Red-greenText = colorText Green-magentaText = colorText Magenta-cyanText = colorText Cyan---- | 'colorText' creates a 'Doc' containing colored text from a @String@-colorText :: Color -> String -> Doc-colorText c = mkColorPrintable c . S---- | @'wrapText' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters-wrapText :: Int -> String -> Doc-wrapText n s =-    vcat $ map text $ reverse $ "": (foldl add_to_line [] $ words s)-  where add_to_line [] a = [a]-        add_to_line ("":d) a = (a:d)-        add_to_line (l:ls) new | length l + length new > n = new:l:ls-        add_to_line (l:ls) new = (l ++ " " ++ new):ls---- | 'printable x' creates a 'Doc' from any 'Printable'.-printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc-printable x = Doc $ \st -> defP (printers st) x st--mkColorPrintable :: Color -> Printable -> Doc-mkColorPrintable c x = Doc $ \st -> colorP (printers st) c x st-invisiblePrintable x = Doc $ \st -> invisibleP (printers st) x st-hiddenPrintable x = Doc $ \st -> hiddenP (printers st) x st-userchunkPrintable x = Doc $ \st -> userchunkP (printers st) x st---- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any--- handle.-simplePrinters :: Printers-simplePrinters _ = simplePrinters'---- | A set of default printers suitable for any handle. Does not use color.-simplePrinters' :: Printers'-simplePrinters'  = Printers { colorP = const simplePrinter,-                              invisibleP = simplePrinter,-                              hiddenP = invisiblePrinter,-                              userchunkP = simplePrinter,-                              defP = simplePrinter,-                              lineColorT = const id,-                              lineColorS = id-                            }---- | 'simplePrinter' is the simplest 'Printer': it just concatenates together--- the pieces of the 'Doc'-simplePrinter :: Printer--- | 'invisiblePrinter' is the 'Printer' for hidden text. It just replaces--- the document with 'empty'.  It's useful to have a printer that doesn't--- actually do anything because this allows you to have tunable policies,--- for example, only printing some text if it's to the terminal, but not--- if it's to a file or vice-versa.-invisiblePrinter :: Printer-simplePrinter x = unDoc $ doc (\s -> x:s)-invisiblePrinter _ = unDoc empty--infixr 6 <>-infixr 6 <+>-infixr 5 $$---- | The empty 'Doc'.-empty :: Doc-empty = Doc $ const Empty-doc :: ([Printable] -> [Printable]) -> Doc-doc f = Doc $ const $ Document f---- | '(<>)' is the concatenation operator for 'Doc's-(<>) :: Doc -> Doc -> Doc--- | @a '<?>' b@ is @a <> b@ if @a@ is not empty, else empty.-(<?>) :: Doc -> Doc -> Doc--- | @a '<+>' b@ is @a@ followed by a space, then @b@.-(<+>) :: Doc -> Doc -> Doc--- | @a '$$' b@ is @a@ above @b@.-($$) :: Doc -> Doc -> Doc--- a then b-Doc a <> Doc b =-   Doc $ \st -> case a st of-                Empty -> b st-                Document af ->-                    Document (\s -> af $ case b st of-                                         Empty -> s-                                         Document bf -> bf s)---- empty if a empty, else a then b-Doc a <?> Doc b =-    Doc $ \st -> case a st of-                 Empty -> Empty-                 Document af -> Document (\s -> af $ case b st of-                                                     Empty -> s-                                                     Document bf -> bf s)---- a then space then b-Doc a <+> Doc b =-    Doc $ \st -> case a st of-                 Empty -> b st-                 Document af -> Document (\s -> af $ case b st of-                                                     Empty -> s-                                                     Document bf ->-                                                         spaceP:bf s)---- a above b-Doc a $$ Doc b =-   Doc $ \st -> case a st of-                Empty -> b st-                Document af ->-                    Document (\s -> af $ case b st of-                                         Empty -> s-                                         Document bf -> sf (newlineP:pf (bf s)))-                        where pf = currentPrefix st-                              sf = lineColorS $ printers st---- | 'vcat' piles vertically a list of 'Doc's.-vcat :: [Doc] -> Doc-vcat [] = empty-vcat ds = foldr1 ($$) ds---- | 'vsep' piles vertically a list of 'Doc's leaving a blank line between each.-vsep :: [Doc] -> Doc-vsep [] = empty-vsep ds = foldr1 ($$) $ intersperse (text "") ds---- | 'hcat' concatenates (horizontally) a list of 'Doc's-hcat :: [Doc] -> Doc-hcat [] = empty-hcat ds = foldr1 (<>) ds--\end{code}-
− src/Progress.hs 
@@ -1,305 +0,0 @@-{-# LANGUAGE CPP #-}--#include "gadts.h"---- |--- Module      : Progress--- Copyright   : 2008 David Roundy--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable------ Utility functions for tracking progress of long-running actions.--module Progress-    (-      beginTedious-    , endTedious-    , tediousSize-    , debugMessage-    , debugFail-    , withoutProgress-    , progress-    , progressKeepLatest-    , finishedOne-    , finishedOneIO-    , progressList-    , minlist-    , setProgressMode-    ) where---import Prelude hiding (lookup)--import Control.Exception.Extensible ( onException )-import Control.Monad ( when )-import Control.Concurrent ( forkIO, threadDelay )--import Data.Char ( toLower )-import Data.Map ( Map, empty, adjust, insert, delete, lookup )-import Data.Maybe ( isJust )-import Data.IORef ( IORef, newIORef, readIORef, writeIORef, modifyIORef )--import System.IO ( stdout, stderr, hFlush, hPutStr, hPutStrLn,-                   hSetBuffering, hIsTerminalDevice,-                   Handle, BufferMode(LineBuffering) )-import System.IO.Unsafe ( unsafePerformIO )--import Darcs.Global ( withDebugMode, debugMessage, putTiming, debugFail )---data ProgressData = ProgressData-    { sofar   :: !Int-    , latest  :: !(Maybe String)-    , total   :: !(Maybe Int)-    }--handleProgress :: IO ()-handleProgress = do-    threadDelay 1000000-    handleMoreProgress "" 0---handleMoreProgress :: String -> Int -> IO ()-handleMoreProgress k n = withProgressMode $ \m ->-    if m then do s <- getProgressLast-                 mp <- getProgressData s-                 case mp of-                   Nothing -> do-                      threadDelay 1000000-                      handleMoreProgress k n-                   Just p -> do-                      when (k /= s || n < sofar p) $ whenProgressMode $ printProgress s p-                      threadDelay 1000000-                      handleMoreProgress s (sofar p)-         else do threadDelay 1000000-                 handleMoreProgress k n---printProgress :: String-              -> ProgressData-              -> IO ()-printProgress k (ProgressData {sofar=s, total=Just t, latest=Just l}) =-    myput output output-  where-    output = k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued. " ++ l-printProgress k (ProgressData {latest=Just l}) =-    myput (k ++ " " ++ l) k-printProgress k (ProgressData {sofar=s, total=Just t}) | t >= s =-    myput (k ++ " " ++ show s ++ " done, " ++ show (t - s) ++ " queued")-          (k ++ " " ++ show s)-printProgress k (ProgressData {sofar=s}) =-    myput (k ++ " " ++ show s) k---myput :: String -> String -> IO ()-myput l s = withDebugMode $ \debugMode ->-    if debugMode-      then putTiming >> hPutStrLn stderr l-      else-        if '\n' `elem` l-          then myput (takeWhile (/= '\n') l) s-          else putTiming >> if length l < 80-                              then simpleput l-                              else simpleput (take 80 s)---simpleput :: String -> IO ()-simpleput = unsafePerformIO $ mkhPutCr stderr-{-# NOINLINE simpleput #-}----- | @beginTedious k@ starts a tedious process and registers it in--- '_progressData' with the key @k@. A tedious process is one for which we want--- a progress indicator.------ Wouldn't it be safer if it had type String -> IO ProgressDataKey, so that we--- can ensure there is no collision? What happens if you call beginTedious twice--- with the same string, without calling endTedious in the meantime?-beginTedious :: String -> IO ()-beginTedious k = do-    debugMessage $ "Beginning " ++ map toLower k-    setProgressData k $ ProgressData-                          { sofar = 0-                          , latest = Nothing-                          , total = Nothing-                          }----- | @endTedious k@ unregisters the tedious process with key @k@, printing--- "Done" if such a tedious process exists.-endTedious :: String -> IO ()-endTedious k = whenProgressMode $ do-    p <- getProgressData k-    modifyIORef _progressData (\(a,m) -> (a,delete k m))-    when (isJust p) $ debugMessage $ "Done " ++-         (map toLower k)---tediousSize :: String-            -> Int-            -> IO ()-tediousSize k s = updateProgressData k uptot-  where-    uptot p = case total p of-                  Just t -> seq ts $ p { total = Just ts }-                    where ts = t + s-                  Nothing -> p { total = Just s }----- | XXX: document this constant-minlist :: Int-minlist = 4---progressList :: String-             -> [a]-             -> [a]-progressList _ [] = []-progressList k (x:xs) = if l < minlist-                          then x:xs-                          else startit x : pl xs-  where-    l = length (x:xs)--    startit y = unsafePerformIO $ do-        beginTedious k-        tediousSize k l-        return y--    pl [] = []-    pl [y] = unsafePerformIO $ do-        endTedious k-        return [y]-    pl (y:ys) = progress k y : pl ys---progress :: String-         -> a-         -> a-progress k a = unsafePerformIO $ progressIO k >> return a---progressIO :: String -> IO ()-progressIO "" = return ()-progressIO k = do-    updateProgressData k $ \p ->-        p { sofar = sofar p + 1, latest = Nothing }-    putDebug k ""---progressKeepLatest :: String-                   -> a-                   -> a-progressKeepLatest k a = unsafePerformIO $ progressKeepLatestIO k >> return a---progressKeepLatestIO :: String -> IO ()-progressKeepLatestIO "" = return ()-progressKeepLatestIO k = do-    updateProgressData k (\p -> p {sofar = sofar p + 1})-    putDebug k ""---finishedOne :: String -> String -> a -> a-finishedOne k l a = unsafePerformIO $ finishedOneIO k l >> return a---finishedOneIO :: String -> String -> IO ()-finishedOneIO "" _ = return ()-finishedOneIO k l = do-    updateProgressData k (\p -> p { sofar = sofar p + 1,-                                    latest = Just l })-    putDebug k l---putDebug :: String-         -> String-         -> IO ()-putDebug _ _ = return ()---putDebug k "" = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k---putDebug k l = when (False && debugMode) $ hPutStrLn stderr $ "P: "++k++" : "++l---_progressMode :: IORef Bool-_progressMode = unsafePerformIO $ do-    hSetBuffering stderr LineBuffering-    newIORef True-{-# NOINLINE _progressMode #-}--_progressData :: IORef (String, Map String ProgressData)-_progressData = unsafePerformIO $ do-    _ <- forkIO handleProgress-    newIORef ("", empty)-{-# NOINLINE _progressData #-}---mkhPutCr :: Handle-         -> IO (String -> IO ())-mkhPutCr fe = do-    isTerm <- hIsTerminalDevice fe-    stdoutIsTerm <- hIsTerminalDevice stdout-    return $-        if isTerm-          then \s -> do-              hPutStr fe $ '\r':s ++ "\r"-              hFlush fe-              let spaces = '\r':replicate (length s) ' ' ++ "\r"-              hPutStr fe spaces-              when stdoutIsTerm $ hPutStr stdout spaces-          else \s -> when (not $ null s) $ do hPutStrLn fe s-                                              hFlush fe---setProgressMode :: Bool -> IO ()-setProgressMode m = writeIORef _progressMode m---withoutProgress :: IO a -> IO a-withoutProgress j = withProgressMode $ \m -> do-    debugMessage "Disabling progress reports..."-    setProgressMode False-    a <- j `onException` setProgressMode m-    if m then debugMessage "Reenabling progress reports."-         else debugMessage "Leaving progress reports off."-    setProgressMode m-    return a---updateProgressData :: String-                   -> (ProgressData -> ProgressData)-                   -> IO ()-updateProgressData k f =-    whenProgressMode $ modifyIORef _progressData (\(_,m) -> (k,adjust f k m))---setProgressData :: String-                -> ProgressData-                -> IO ()-setProgressData k p =-    whenProgressMode $ modifyIORef _progressData (\(a,m) -> (a,insert k p m))---getProgressData :: String -> IO (Maybe ProgressData)-getProgressData k = withProgressMode $ \p ->-    if p-      then (lookup k . snd) `fmap` readIORef _progressData-      else return Nothing---getProgressLast :: IO String-getProgressLast = withProgressMode $ \p ->-    if p-      then fst `fmap` readIORef _progressData-      else return ""---whenProgressMode :: IO a -> IO ()-whenProgressMode j = withProgressMode $ const $ j >> return ()---withProgressMode :: (Bool -> IO a) -> IO a-withProgressMode j = readIORef _progressMode >>= j--
− src/Ratified.hs 
@@ -1,8 +0,0 @@--- | XXX: Perhaps a word of explanation here [WL]-module Ratified-    (-      readFile-    , hGetContents-    ) where--import System.IO( hGetContents )
− src/SHA1.hs 
@@ -1,212 +0,0 @@--- Copyright (C) 2001, 2004 Ian Lynagh <igloo@earth.li>------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.---- name shadowing disabled because a,b,c,d,e are shadowed loads in step 4-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}--{-# LANGUAGE CPP #-}---- |--- Module      : SHA1--- Copyright   : 2001, 2004 Ian Lynagh <igloo@earth.li>--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module SHA1 (sha1PS) where--import ByteStringUtils (unsafeWithInternals)-import qualified Data.ByteString as B (ByteString, pack, length, concat)--import Data.Char (intToDigit)-import Data.Bits (xor, (.&.), (.|.), complement, rotateL, shiftL, shiftR)-import Data.Word (Word8, Word32)-import Foreign.Ptr (Ptr, castPtr)-import Foreign.Marshal.Array (advancePtr)-import Foreign.Storable (peek, poke)-import System.IO.Unsafe (unsafePerformIO)--data ABCDE = ABCDE !Word32 !Word32 !Word32 !Word32 !Word32-data XYZ = XYZ !Word32 !Word32 !Word32--sha1PS :: B.ByteString -> String-sha1PS s = s5- where s1_2 = sha1Step12PadLength s-       abcde = sha1Step3Init-       abcde' = unsafePerformIO-              $ unsafeWithInternals s1_2 (\ptr len ->-                    do let ptr' = castPtr ptr-#ifndef BIGENDIAN-                       fiddleEndianness ptr' len-#endif-                       sha1Step4Main abcde ptr' len)-       s5 = sha1Step5Display abcde'--fiddleEndianness :: Ptr Word32 -> Int -> IO ()-fiddleEndianness p 0 = p `seq` return ()-fiddleEndianness p n- = do x <- peek p-      poke p $ shiftL x 24-           .|. shiftL (x .&. 0xff00) 8-           .|. (shiftR x 8 .&. 0xff00)-           .|. shiftR x 24-      fiddleEndianness (p `advancePtr` 1) (n - 4)---- sha1Step12PadLength assumes the length is at most 2^61.--- This seems reasonable as the Int used to represent it is normally 32bit,--- but obviously could go wrong with large inputs on 64bit machines.--- The B.ByteString library should probably move to Word64s if this is an--- issue, though.--sha1Step12PadLength :: B.ByteString -> B.ByteString-sha1Step12PadLength s- = let len = B.length s-       num_nuls = (55 - len) `mod` 64-       padding = 128:replicate num_nuls 0-       len_w8s = reverse $ sizeSplit 8 (fromIntegral len*8)-   in B.concat [s, B.pack padding, B.pack len_w8s]--sizeSplit :: Int -> Integer -> [Word8]-sizeSplit 0 _ = []-sizeSplit p n = fromIntegral d:sizeSplit (p-1) n'- where (n', d) = divMod n 256--sha1Step3Init :: ABCDE-sha1Step3Init = ABCDE 0x67452301 0xefcdab89 0x98badcfe 0x10325476 0xc3d2e1f0--sha1Step4Main :: ABCDE -> Ptr Word32 -> Int -> IO ABCDE-sha1Step4Main abcde _ 0 = return $! abcde-sha1Step4Main (ABCDE a0@a b0@b c0@c d0@d e0@e) s len-    = do-         (e, b) <- doit f1 0x5a827999 (x 0) a b c d e-         (d, a) <- doit f1 0x5a827999 (x 1) e a b c d-         (c, e) <- doit f1 0x5a827999 (x 2) d e a b c-         (b, d) <- doit f1 0x5a827999 (x 3) c d e a b-         (a, c) <- doit f1 0x5a827999 (x 4) b c d e a-         (e, b) <- doit f1 0x5a827999 (x 5) a b c d e-         (d, a) <- doit f1 0x5a827999 (x 6) e a b c d-         (c, e) <- doit f1 0x5a827999 (x 7) d e a b c-         (b, d) <- doit f1 0x5a827999 (x 8) c d e a b-         (a, c) <- doit f1 0x5a827999 (x 9) b c d e a-         (e, b) <- doit f1 0x5a827999 (x 10) a b c d e-         (d, a) <- doit f1 0x5a827999 (x 11) e a b c d-         (c, e) <- doit f1 0x5a827999 (x 12) d e a b c-         (b, d) <- doit f1 0x5a827999 (x 13) c d e a b-         (a, c) <- doit f1 0x5a827999 (x 14) b c d e a-         (e, b) <- doit f1 0x5a827999 (x 15) a b c d e-         (d, a) <- doit f1 0x5a827999 (m 16) e a b c d-         (c, e) <- doit f1 0x5a827999 (m 17) d e a b c-         (b, d) <- doit f1 0x5a827999 (m 18) c d e a b-         (a, c) <- doit f1 0x5a827999 (m 19) b c d e a-         (e, b) <- doit f2 0x6ed9eba1 (m 20) a b c d e-         (d, a) <- doit f2 0x6ed9eba1 (m 21) e a b c d-         (c, e) <- doit f2 0x6ed9eba1 (m 22) d e a b c-         (b, d) <- doit f2 0x6ed9eba1 (m 23) c d e a b-         (a, c) <- doit f2 0x6ed9eba1 (m 24) b c d e a-         (e, b) <- doit f2 0x6ed9eba1 (m 25) a b c d e-         (d, a) <- doit f2 0x6ed9eba1 (m 26) e a b c d-         (c, e) <- doit f2 0x6ed9eba1 (m 27) d e a b c-         (b, d) <- doit f2 0x6ed9eba1 (m 28) c d e a b-         (a, c) <- doit f2 0x6ed9eba1 (m 29) b c d e a-         (e, b) <- doit f2 0x6ed9eba1 (m 30) a b c d e-         (d, a) <- doit f2 0x6ed9eba1 (m 31) e a b c d-         (c, e) <- doit f2 0x6ed9eba1 (m 32) d e a b c-         (b, d) <- doit f2 0x6ed9eba1 (m 33) c d e a b-         (a, c) <- doit f2 0x6ed9eba1 (m 34) b c d e a-         (e, b) <- doit f2 0x6ed9eba1 (m 35) a b c d e-         (d, a) <- doit f2 0x6ed9eba1 (m 36) e a b c d-         (c, e) <- doit f2 0x6ed9eba1 (m 37) d e a b c-         (b, d) <- doit f2 0x6ed9eba1 (m 38) c d e a b-         (a, c) <- doit f2 0x6ed9eba1 (m 39) b c d e a-         (e, b) <- doit f3 0x8f1bbcdc (m 40) a b c d e-         (d, a) <- doit f3 0x8f1bbcdc (m 41) e a b c d-         (c, e) <- doit f3 0x8f1bbcdc (m 42) d e a b c-         (b, d) <- doit f3 0x8f1bbcdc (m 43) c d e a b-         (a, c) <- doit f3 0x8f1bbcdc (m 44) b c d e a-         (e, b) <- doit f3 0x8f1bbcdc (m 45) a b c d e-         (d, a) <- doit f3 0x8f1bbcdc (m 46) e a b c d-         (c, e) <- doit f3 0x8f1bbcdc (m 47) d e a b c-         (b, d) <- doit f3 0x8f1bbcdc (m 48) c d e a b-         (a, c) <- doit f3 0x8f1bbcdc (m 49) b c d e a-         (e, b) <- doit f3 0x8f1bbcdc (m 50) a b c d e-         (d, a) <- doit f3 0x8f1bbcdc (m 51) e a b c d-         (c, e) <- doit f3 0x8f1bbcdc (m 52) d e a b c-         (b, d) <- doit f3 0x8f1bbcdc (m 53) c d e a b-         (a, c) <- doit f3 0x8f1bbcdc (m 54) b c d e a-         (e, b) <- doit f3 0x8f1bbcdc (m 55) a b c d e-         (d, a) <- doit f3 0x8f1bbcdc (m 56) e a b c d-         (c, e) <- doit f3 0x8f1bbcdc (m 57) d e a b c-         (b, d) <- doit f3 0x8f1bbcdc (m 58) c d e a b-         (a, c) <- doit f3 0x8f1bbcdc (m 59) b c d e a-         (e, b) <- doit f2 0xca62c1d6 (m 60) a b c d e-         (d, a) <- doit f2 0xca62c1d6 (m 61) e a b c d-         (c, e) <- doit f2 0xca62c1d6 (m 62) d e a b c-         (b, d) <- doit f2 0xca62c1d6 (m 63) c d e a b-         (a, c) <- doit f2 0xca62c1d6 (m 64) b c d e a-         (e, b) <- doit f2 0xca62c1d6 (m 65) a b c d e-         (d, a) <- doit f2 0xca62c1d6 (m 66) e a b c d-         (c, e) <- doit f2 0xca62c1d6 (m 67) d e a b c-         (b, d) <- doit f2 0xca62c1d6 (m 68) c d e a b-         (a, c) <- doit f2 0xca62c1d6 (m 69) b c d e a-         (e, b) <- doit f2 0xca62c1d6 (m 70) a b c d e-         (d, a) <- doit f2 0xca62c1d6 (m 71) e a b c d-         (c, e) <- doit f2 0xca62c1d6 (m 72) d e a b c-         (b, d) <- doit f2 0xca62c1d6 (m 73) c d e a b-         (a, c) <- doit f2 0xca62c1d6 (m 74) b c d e a-         (e, b) <- doit f2 0xca62c1d6 (m 75) a b c d e-         (d, a) <- doit f2 0xca62c1d6 (m 76) e a b c d-         (c, e) <- doit f2 0xca62c1d6 (m 77) d e a b c-         (b, d) <- doit f2 0xca62c1d6 (m 78) c d e a b-         (a, c) <- doit f2 0xca62c1d6 (m 79) b c d e a-         let abcde' = ABCDE (a0 + a) (b0 + b) (c0 + c) (d0 + d) (e0 + e)-         sha1Step4Main abcde' (s `advancePtr` 16) (len - 64)- where {-# INLINE f1 #-}-       f1 (XYZ x y z) = (x .&. y) .|. ((complement x) .&. z)-       {-# INLINE f2 #-}-       f2 (XYZ x y z) = x `xor` y `xor` z-       {-# INLINE f3 #-}-       f3 (XYZ x y z) = (x .&. y) .|. (x .&. z) .|. (y .&. z)-       {-# INLINE x #-}-       x n = peek (s `advancePtr` n)-       {-# INLINE m #-}-       m n = do let base = s `advancePtr` (n .&. 15)-                x0 <- peek base-                x1 <- peek (s `advancePtr` ((n - 14) .&. 15))-                x2 <- peek (s `advancePtr` ((n - 8) .&. 15))-                x3 <- peek (s `advancePtr` ((n - 3) .&. 15))-                let res = rotateL (x0 `xor` x1 `xor` x2 `xor` x3) 1-                poke base res-                return res-       {-# INLINE doit #-}-       doit f k i a b c d e = a `seq` c `seq`-           do i' <- i-              return (rotateL a 5 + f (XYZ b c d) + e + i' + k,-                      rotateL b 30)--sha1Step5Display :: ABCDE -> String-sha1Step5Display (ABCDE a b c d e)- = concatMap showAsHex [a, b, c, d, e]--showAsHex :: Word32 -> String-showAsHex n = showIt 8 n ""-   where-    showIt :: Int -> Word32 -> String -> String-    showIt 0 _ r = r-    showIt i x r = case quotRem x 16 of-                       (y, z) -> let c = intToDigit (fromIntegral z)-                                 in c `seq` showIt (i-1) y (c:r)
− src/URL.hs 
@@ -1,332 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}---- |--- Module      : URL--- Copyright   : 2008 Dmitry Kurochkin <dmitry.kurochkin@gmail.com>--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module URL ( copyUrl, copyUrlFirst, setDebugHTTP,-             disableHTTPPipelining, maxPipelineLength,-             waitUrl, Cachable(Cachable, Uncachable, MaxAge),-             environmentHelpProxy, environmentHelpProxyPassword,-             ConnectionError(..),-           ) where--import Data.IORef ( newIORef, readIORef, writeIORef, IORef )-import Data.Map ( Map )-import qualified Data.Map as Map-import System.Directory ( copyFile )-import System.IO.Unsafe ( unsafePerformIO )-import Control.Concurrent ( forkIO )-import Control.Concurrent.Chan ( isEmptyChan, newChan, readChan, writeChan, Chan )-import Control.Concurrent.MVar ( isEmptyMVar, modifyMVar_, modifyMVar, newEmptyMVar, newMVar, putMVar, readMVar, withMVar, MVar )-import Control.Monad ( unless, when )-import Control.Monad.Trans ( liftIO )-import Control.Monad.State ( evalStateT, get, modify, put, StateT )--import Workaround ( renameFile )-import Darcs.Global ( atexit )-import Progress ( debugMessage )-import Darcs.Lock ( removeFileMayNotExist )--import Numeric ( showHex )-import System.Random ( randomRIO )-import URL.Request--#ifdef HAVE_CURL-import qualified URL.Curl as Curl-#elif defined(HAVE_HTTP)-import qualified URL.HTTP as HTTP -#else-import Progress ( debugFail )-import qualified HTTP ( requestUrl, waitNextUrl )-#endif-#include "impossible.h"--{-# NOINLINE maxPipelineLengthRef #-}-maxPipelineLengthRef :: IORef Int-maxPipelineLengthRef = unsafePerformIO $ do-  enabled <- pipeliningEnabled-#ifdef HAVE_CURL-  when (not enabled) (debugMessage $-                      "Warning: pipelining is disabled, because libcurl "++-                      "version darcs was compiled with is too old (< 7.19.1)")-#endif-  newIORef $ if enabled then 100 else 1--maxPipelineLength :: IO Int-maxPipelineLength = readIORef maxPipelineLengthRef--{-# NOINLINE urlNotifications #-}-urlNotifications :: MVar (Map String (MVar String))-urlNotifications = unsafePerformIO $ newMVar Map.empty--{-# NOINLINE urlChan #-}-urlChan :: Chan UrlRequest-urlChan = unsafePerformIO $ do-  ch <- newChan--- Warning:  A do-notation statement discarded a result of type GHC.Conc.ThreadId.-  _ <- forkIO (urlThread ch)-  return ch---- ------------------------------------------------------------------------- urlThread--- ------------------------------------------------------------------------type UrlM a = StateT UrlState IO a--urlThread :: Chan UrlRequest -> IO ()-urlThread ch = do junk <- flip showHex "" `fmap` randomRIO rrange-                  evalStateT (urlThread' ch) (UrlState Map.empty emptyQ 0 junk)-    where rrange = (0, 2^(128 :: Integer) :: Integer)---- | Internal to urlThread-urlThread' :: Chan UrlRequest -> UrlM ()-urlThread' ch = do-            empty <- liftIO $ isEmptyChan ch-            st <- get-            let l = pipeLength st-                w = waitToStart st-            reqs <- if not empty || (nullQ w && l == 0)-                    then liftIO (readAllRequests ch)-                    else return []-            mapM_ addReq reqs-            checkWaitToStart-            waitNextUrl-            urlThread' ch---- | Internal to urlThread-readAllRequests :: Chan UrlRequest -> IO [UrlRequest]-readAllRequests ch = do-            r <- readChan ch-            debugMessage $ "URL.urlThread ("++url r++"\n"++-                           "            -> "++file r++")"-            empty <- isEmptyChan ch-            reqs <- if not empty-                    then readAllRequests ch-                    else return []-            return (r:reqs)---- | Internal to urlThread-addReq :: UrlRequest -> UrlM ()-addReq r = do-  d <- liftIO (alreadyDownloaded u)-  if d-     then dbg "Ignoring UrlRequest of URL that is already downloaded."-     else reallyAdd- where-   f = file r-   c = cachable r-   u = url r-   reallyAdd = do-                 st <- get-                 let p = inProgress st-                     w = waitToStart st-                     e = (f, [], c)-                     new_w = case priority r of-                               High -> pushQ u w-                               Low  -> insertQ u w-                     new_st = st { inProgress = Map.insert u e p-                                 , waitToStart = new_w }-                 case Map.lookup u p of-                   Just (f', fs', c') -> do-                     let new_c = minCachable c c'-                     when (c /= c') $ let new_p = Map.insert u (f', fs', new_c) p-                                      in do modify (\s -> s { inProgress = new_p })-                                            dbg $ "Changing "++u++" request cachability from "++show c++" to "++show new_c-                     when (u `elemQ` w && priority r == High) $ do-                       modify (\s -> s { waitToStart = pushQ u (deleteQ u w) })-                       dbg $ "Moving "++u++" to head of download queue."-                     if f `notElem` (f':fs')-                        then let new_p = Map.insert u (f', f:fs', new_c) p-                             in do modify (\s -> s { inProgress = new_p })-                                   dbg "Adding new file to existing UrlRequest."-                        else dbg "Ignoring UrlRequest of file that's already queued."-                   _ -> put new_st----- | Internal to urlThread-alreadyDownloaded :: String -> IO Bool-alreadyDownloaded u = do-            n <- withMVar urlNotifications (return . (Map.lookup u))-            case n of-              Just v  -> not `fmap` isEmptyMVar v-              Nothing -> return True---- ------------------------------------------------------------------------checkWaitToStart :: StateT UrlState IO ()-checkWaitToStart = do-  st <- get-  let l = pipeLength st-  mpl <- liftIO maxPipelineLength-  when (l < mpl) $ do-    let w = waitToStart st-    case readQ w of-      Just (u,rest) -> do-        case Map.lookup u (inProgress st) of-          Just (f, _, c) -> do-            dbg ("URL.requestUrl ("++u++"\n"++-                 "              -> "++f++")")-            let f_new = f++"-new_"++randomJunk st-            err <- liftIO $ requestUrl u f_new c-            if null err-               then do liftIO $ atexit (removeFileMayNotExist f_new)-                       put $ st { waitToStart = rest-                                , pipeLength = l + 1 }-               else do dbg $ "Failed to start download URL "++u++": "++err-                       liftIO $ do removeFileMayNotExist f_new-                                   downloadComplete u err-                       put $ st { waitToStart = rest }-          _              -> bug $ "Possible bug in URL.checkWaitToStart "++u-        checkWaitToStart-      _ -> return ()--copyUrlFirst :: String -> FilePath -> Cachable -> IO ()-copyUrlFirst = copyUrlWithPriority High--copyUrl :: String -> FilePath -> Cachable -> IO ()-copyUrl = copyUrlWithPriority Low--copyUrlWithPriority :: Priority -> String -> String -> Cachable -> IO ()-copyUrlWithPriority p u f c = do-  debugMessage ("URL.copyUrlWithPriority ("++u++"\n"++-                "                      -> "++f++")")-  v <- newEmptyMVar-  old_mv <- modifyMVar urlNotifications (return . (\(a, b) -> (b, a)) . Map.insertLookupWithKey (\_k _n old -> old) u v)-  case old_mv of-      Nothing -> writeChan urlChan $ UrlRequest u f c p -- ok, new URL-      Just _  -> debugMessage $ "URL.copyUrlWithPriority already in progress, skip (" ++ u ++ "\n" ++ "-> " ++ f ++ ")"--waitNextUrl :: StateT UrlState IO ()-waitNextUrl = do-  st <- get-  let l = pipeLength st-  when (l > 0) $ do-                dbg "URL.waitNextUrl start"-                (u, e, ce) <- liftIO $ waitNextUrl'-                let p = inProgress st-                    new_st = st { inProgress = Map.delete u p-                                , pipeLength = l - 1 }-                liftIO $ if null e-                         then case Map.lookup u p of-                                Just (f, fs, _) -> do-                                  renameFile (f++"-new_"++randomJunk st) f-                                  mapM_ (safeCopyFile st f) fs-                                  downloadComplete u e-                                  debugMessage $ "URL.waitNextUrl succeeded: "++u++" "++f-                                Nothing -> bug $ "Possible bug in URL.waitNextUrl: "++u-                         else case Map.lookup u p of-                                Just (f, _, _) -> do-                                  removeFileMayNotExist (f++"-new_"++randomJunk st)-                                  case ce of-                                    Just httpError -> downloadComplete u (show httpError)-                                    Nothing        -> downloadComplete u e-                                  debugMessage $ "URL.waitNextUrl failed: "++-                                               u++" "++f++" "++e-                                Nothing -> bug $ "Another possible bug in URL.waitNextUrl: "++u++" "++e-                unless (null u) $ put new_st-    where safeCopyFile st f t = let new_t = t++"-new_"++randomJunk st-                                in do copyFile f new_t-                                      renameFile new_t t--downloadComplete :: String -> String -> IO ()-downloadComplete u e = do-  r <- withMVar urlNotifications (return . (Map.lookup u))-  case r of-    Just notifyVar -> putMVar notifyVar e-    Nothing -> debugMessage $ "downloadComplete URL '"++u++"' downloaded several times"--waitUrl :: String -> IO ()-waitUrl u = do debugMessage $ "URL.waitUrl "++u-               r <- withMVar urlNotifications (return . (Map.lookup u))-               case r of-                 Just var -> do-                        e <- readMVar var-                        modifyMVar_ urlNotifications (return . (Map.delete u))-                        unless (null e) $ do-                          debugMessage $ "Failed to download URL "++u++": "++e-                          fail e-                 Nothing  -> return () -- file was already downloaded--dbg :: String -> StateT a IO ()-dbg = liftIO . debugMessage--minCachable :: Cachable -> Cachable -> Cachable-minCachable Uncachable _          = Uncachable-minCachable _          Uncachable = Uncachable-minCachable (MaxAge a) (MaxAge b) = MaxAge $ min a b-minCachable (MaxAge a) _          = MaxAge a-minCachable _          (MaxAge b) = MaxAge b-minCachable _          _          = Cachable--disableHTTPPipelining :: IO ()-disableHTTPPipelining = writeIORef maxPipelineLengthRef 1--setDebugHTTP :: IO ()-requestUrl :: String -> FilePath -> Cachable -> IO String-waitNextUrl' :: IO (String, String, Maybe ConnectionError)-pipeliningEnabled :: IO Bool--#ifdef HAVE_CURL--setDebugHTTP = Curl.setDebugHTTP-requestUrl = Curl.requestUrl-waitNextUrl' = Curl.waitNextUrl-pipeliningEnabled = Curl.pipeliningEnabled--#elif defined(HAVE_HTTP)--setDebugHTTP = return ()-requestUrl = HTTP.requestUrl-waitNextUrl' = HTTP.waitNextUrl-pipeliningEnabled = return False--#else--setDebugHTTP = debugMessage "URL.setDebugHttp works only with libcurl"-requestUrl _ _ _ = debugFail "URL.requestUrl: there is no libcurl!"-waitNextUrl' = debugFail "URL.waitNextUrl': there is no libcurl!"-pipeliningEnabled = return False--#endif---- Usage of these environment variables happens in C code, so the--- closest to "literate" user documentation is here, where the--- offending function 'curl_request_url' is imported.-environmentHelpProxy :: ([String], [String])-environmentHelpProxy = (["HTTP_PROXY", "HTTPS_PROXY", "FTP_PROXY",-                         "ALL_PROXY", "NO_PROXY"], [- "If Darcs was built with libcurl, the environment variables HTTP_PROXY,",- "HTTPS_PROXY and FTP_PROXY can be set to the URL of a proxy in the form",- "",- "  [protocol://]<host>[:port]",- "",- "In which case libcurl will use the proxy for the associated protocol",- "(HTTP, HTTPS and FTP).  The environment variable ALL_PROXY can be used",- "to set a single proxy for all libcurl requests.",- "",- "If the environment variable NO_PROXY is a comma-separated list of host",- "names, access to those hosts will bypass proxies defined by the above",- "variables.  For example, it is quite common to avoid proxying requests",- "to machines on the local network with",- "",- "  NO_PROXY=localhost,*.localdomain",- "",- "For compatibility with lynx et al, lowercase equivalents of these",- "environment variables (e.g. $http_proxy) are also understood and are",- "used in preference to the uppercase versions.",- "",- "If Darcs was not built with libcurl, all these environment variables",- "are silently ignored, and there is no way to use a web proxy."])--environmentHelpProxyPassword :: ([String], [String])-environmentHelpProxyPassword = (["DARCS_PROXYUSERPWD"], [- "If Darcs was built with libcurl, and you are using a web proxy that",- "requires authentication, you can set the $DARCS_PROXYUSERPWD",- "environment variable to the username and password expected by the",- "proxy, separated by a colon.  This environment variable is silently",- "ignored if Darcs was not built with libcurl."])
− src/URL/Curl.hs 
@@ -1,80 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE CPP, ForeignFunctionInterface #-}--module URL.Curl where--#ifdef HAVE_CURL--import Control.Exception.Extensible ( bracket )-import Control.Monad ( when )-import Foreign.C.Types ( CLong(..), CInt(..) )--import Progress ( debugMessage )--import URL.Request--import Foreign.C.String ( withCString, peekCString, CString )-import Foreign.Ptr-import Foreign.Marshal.Alloc-import Foreign.Storable--setDebugHTTP :: IO ()-setDebugHTTP = curl_enable_debug--requestUrl :: String -> FilePath -> Cachable -> IO String-requestUrl u f cache =-    withCString u $ \ustr ->-    withCString f $ \fstr -> do-      err <- curl_request_url ustr fstr (cachableToInt cache) >>= peekCString-      return err--waitNextUrl :: IO (String, String, Maybe ConnectionError)-waitNextUrl =-  bracket malloc free $ \ errorPointer ->-  bracket malloc free $ \ httpErrorPointer -> do-    e <- curl_wait_next_url errorPointer httpErrorPointer >>= peekCString-    ce <- do-           errorNum <- peek errorPointer-           if not (null e)-             then return $-              case errorNum of-                6  -> Just CouldNotResolveHost-                7  -> Just CouldNotConnectToServer-                28 -> Just OperationTimeout-                _  -> Nothing-             else do-              when (errorNum == 90 ) $ debugMessage "The environment variable DARCS_CONNECTION_TIMEOUT is not a number"-              return Nothing-    u <- curl_last_url >>= peekCString-    httpErrorCode <- peek httpErrorPointer-    let detailedErrorMessage = if httpErrorCode > 0-                               then e ++ " " ++ show httpErrorCode-                               else e-    return (u, detailedErrorMessage, ce)--pipeliningEnabled :: IO Bool-pipeliningEnabled = do-  r <- curl_pipelining_enabled-  return $ r /= 0--cachableToInt :: Cachable -> CInt-cachableToInt Cachable = -1-cachableToInt Uncachable = 0-cachableToInt (MaxAge n) = n--foreign import ccall "hscurl.h curl_request_url"-  curl_request_url :: CString -> CString -> CInt -> IO CString--foreign import ccall "hscurl.h curl_wait_next_url"-  curl_wait_next_url :: Ptr CInt -> Ptr CLong-> IO CString--foreign import ccall "hscurl.h curl_last_url"-  curl_last_url :: IO CString--foreign import ccall "hscurl.h curl_enable_debug"-  curl_enable_debug :: IO ()--foreign import ccall "hscurl.h curl_pipelining_enabled"-  curl_pipelining_enabled :: IO CInt--#endif
− src/URL/HTTP.hs 
@@ -1,111 +0,0 @@-{-# LANGUAGE CPP #-}--module URL.HTTP( fetchUrl, postUrl, requestUrl, waitNextUrl ) where--import Prelude hiding ( catch )--import Darcs.Global ( debugFail )-import Version ( version )--import URL.Request ( ConnectionError(..) )--#ifdef HAVE_HTTP-import Control.Exception ( catch, IOException )-import Data.IORef ( newIORef, readIORef, writeIORef, IORef )-import Network.HTTP-import Network.Browser ( browse, request, setCheckForProxy, setErrHandler, setOutHandler )-import Network.URI-import System.IO.Error ( ioeGetErrorString )-import System.IO.Unsafe ( unsafePerformIO )-import Darcs.Global ( debugMessage )-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-#endif--fetchUrl :: String -> IO String-postUrl-    :: String     -- ^ url-    -> String     -- ^ body-    -> String     -- ^ mime type-    -> IO ()  -- ^ result--requestUrl :: String -> FilePath -> a -> IO String-waitNextUrl :: IO (String, String, Maybe ConnectionError)--#ifdef HAVE_HTTP--headers :: [Header]-headers =  [Header HdrUserAgent $ "darcs-HTTP/" ++ version]--fetchUrl url = case parseURI url of-    Nothing -> fail $ "Invalid URI: " ++ url-    Just uri -> do debugMessage $ "Fetching over HTTP:  "++url-                   resp <- catch (browse $ do-                     setCheckForProxy True-                     setOutHandler debugMessage-                     setErrHandler debugMessage-                     request Request { rqURI = uri,-                                       rqMethod = GET,-                                       rqHeaders = headers,-                                       rqBody = "" })-                     (\(err :: IOException) -> debugFail $ show err)-                   case resp of-                     (_, res@Response { rspCode = (2,0,0) }) -> return (rspBody res)-                     (_, Response { rspCode = (x,y,z) }) ->-                         debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error getting " ++ show uri--postUrl url body mime = case parseURI url of-    Nothing -> fail $ "Invalid URI: " ++ url-    Just uri -> do debugMessage $ "Posting to HTTP:  "++url-                   resp <- catch (browse $ do-                     setCheckForProxy True-                     setOutHandler debugMessage-                     setErrHandler debugMessage-                     request Request { rqURI = uri,-                                       rqMethod = POST,-                                       rqHeaders = headers ++ [Header HdrContentType mime,-                                                               Header HdrAccept "text/plain",-                                                               Header HdrContentLength-                                                                        (show $ length body) ],-                                       rqBody = body })-                     (\(err :: IOException) -> debugFail $ show err)-                   case resp of-                     (_, res@Response { rspCode = (2,y,z) }) -> do-                        putStrLn $ "Success 2" ++ show y ++ show z-                        putStrLn (rspBody res)-                        return ()-                     (_, res@Response { rspCode = (x,y,z) }) -> do-                        putStrLn $ rspBody res-                        debugFail $ "HTTP " ++ show x ++ show y ++ show z ++ " error posting to " ++ show uri--requestedUrl :: IORef (String, FilePath)-requestedUrl = unsafePerformIO $ newIORef ("", "")--requestUrl u f _ = do-  (u', _) <- readIORef requestedUrl-  if null u'-     then do writeIORef requestedUrl (u, f)-             return ""-     else return "URL already requested"--waitNextUrl = do-  (u, f) <- readIORef requestedUrl-  if null u-     then return ("", "No URL requested", Nothing)-     else do writeIORef requestedUrl ("", "")-             e <- (fetchUrl u >>= \s -> B.writeFile f (BC.pack s) >> return "") `catch` h-             let ce = case e of-                       "timeout" -> Just OperationTimeout-                       _         -> Nothing-             return (u, e, ce)-    where h = return . ioeGetErrorString--#else--fetchUrl _ = debugFail "Network.HTTP does not exist"-postUrl _ _ _ = debugFail "Cannot use http POST because darcs was not compiled with Network.HTTP."--requestUrl _ _ _ = debugFail "Network.HTTP does not exist"-waitNextUrl = debugFail "Network.HTTP does not exist"--#endif
− src/URL/Request.hs 
@@ -1,59 +0,0 @@-module URL.Request where--import Data.Map ( Map )-import Data.List ( delete )-import Foreign.C.Types ( CInt )--data UrlRequest = UrlRequest { url :: String-                             , file :: FilePath-                             , cachable :: Cachable-                             , priority :: Priority }--data Cachable = Cachable | Uncachable | MaxAge !CInt-                deriving (Show, Eq)--data UrlState = UrlState { inProgress :: Map String ( FilePath-                                                    , [FilePath]-                                                    , Cachable )-                         , waitToStart :: Q String-                         , pipeLength :: Int-                         , randomJunk :: String }--data Q a = Q [a] [a]--readQ :: Q a -> Maybe (a, Q a)-readQ (Q (x:xs) ys) = Just (x, Q xs ys)-readQ (Q [] ys) = do x:xs <- Just $ reverse ys-                     Just (x, Q xs [])--insertQ :: a -> Q a -> Q a-insertQ y (Q xs ys) = Q xs (y:ys)--pushQ :: a -> Q a -> Q a-pushQ x (Q xs ys) = Q (x:xs) ys--deleteQ :: Eq a => a -> Q a -> Q a-deleteQ x (Q xs ys) = Q (delete x xs) (delete x ys)--elemQ :: Eq a => a -> Q a -> Bool-elemQ x (Q xs ys) = x `elem` xs || x `elem` ys--emptyQ :: Q a-emptyQ = Q [] []--nullQ :: Q a -> Bool-nullQ (Q [] []) = True-nullQ _         = False--data Priority = High | Low deriving Eq---- | Data type to represent a connection error.--- The following are the codes from libcurl--- which map to each of the constructors:--- * 6  -> CouldNotResolveHost : The remote host was not resolved.--- * 7  -> CouldNotConnectToServer : Failed to connect() to host or proxy.--- * 28 -> OperationTimeout: the specified time-out period was reached.-data ConnectionError = CouldNotResolveHost     |-                       CouldNotConnectToServer |-                       OperationTimeout-               deriving (Eq, Read, Show)
− src/Workaround.hs 
@@ -1,148 +0,0 @@-{-# LANGUAGE CPP #-}---- |--- Module      : Workaround--- Copyright   : 2008 David Roundy <droundy@darcs.net>--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Workaround-    (-      renameFile-    , setExecutable-    , getCurrentDirectory-    , installHandler-    , raiseSignal-    , Handler(..)-    , Signal-    , sigINT-    , sigHUP-    , sigABRT-    , sigALRM-    , sigTERM-    , sigPIPE-    ) where--import Prelude hiding ( catch )--#ifdef WIN32--import qualified System.Directory ( renameFile, getCurrentDirectory, removeFile )-import Control.Exception ( catch, IOException )-import qualified Control.Exception ( mask )-import qualified System.IO.Error ( isDoesNotExistError, ioError )--#else--import System.Posix.Signals(installHandler, raiseSignal, Handler(..), Signal,-                            sigINT, sigHUP, sigABRT, sigALRM, sigTERM, sigPIPE)-import System.Directory ( renameFile, getCurrentDirectory )-import System.Posix.Files (fileMode,getFileStatus, setFileMode,-                           setFileCreationMask,-                           ownerReadMode, ownerWriteMode, ownerExecuteMode,-                           groupReadMode, groupWriteMode, groupExecuteMode,-                           otherReadMode, otherWriteMode, otherExecuteMode)-import Data.Bits ( (.&.), (.|.), complement )--#endif--#ifdef WIN32--- Dummy implementation of POSIX signals-data Handler = Default-             | Ignore-             | Catch (IO ())--type Signal = Int--installHandler :: Signal-               -> Handler-               -> Maybe ()-               -> IO ()-installHandler _ _ _ = return ()---raiseSignal :: Signal -> IO ()-raiseSignal _ = return ()---sigINT :: Signal-sigINT = 0---- not used: sigKILL = 0--sigHUP :: Signal-sigHUP = 0---- not used: sigQUIT = 0--sigABRT :: Signal-sigABRT = 0--sigTERM :: Signal-sigTERM = 0--sigPIPE :: Signal-sigPIPE = 0--sigALRM :: Signal-sigALRM = 0----- | System.Directory.renameFile incorrectly fails when the new file already--- exists.  This code works around that bug at the cost of losing atomic--- writes.-renameFile :: FilePath-           -> FilePath-           -> IO ()-renameFile old new = Control.Exception.mask $ \_ ->-   System.Directory.renameFile old new-   `catch` \(_ :: IOException) ->-   do System.Directory.removeFile new-        `catch`-         (\e -> if System.IO.Error.isDoesNotExistError e-                   then return ()-                   else System.IO.Error.ioError e)-      System.Directory.renameFile old new---setExecutable :: FilePath-              -> Bool-              -> IO ()-setExecutable _ _ = return ()----- | System.Directory.getCurrentDirectory returns a path with backslashes in it--- under windows, and some of the code gets confused by that, so we override--- getCurrentDirectory and translates '\\' to '/'-getCurrentDirectory :: IO FilePath-getCurrentDirectory = do-    d <- System.Directory.getCurrentDirectory-    return $ map rb d-  where-    rb '\\' = '/'-    rb c = c--#else---setExecutable :: FilePath-              -> Bool-              -> IO ()-setExecutable f ex = do-    st <- getFileStatus f-    umask <- setFileCreationMask 0--- Warning:  A do-notation statement discarded a result of type System.Posix.Types.FileMode.-    _ <- setFileCreationMask umask-    let rw = fileMode st .&.-             (ownerReadMode .|. ownerWriteMode .|.-              groupReadMode .|. groupWriteMode .|.-              otherReadMode .|. otherWriteMode)-        total = if ex then rw .|.-                          ((ownerExecuteMode .|. groupExecuteMode .|. otherExecuteMode)-                           .&. complement umask)-                      else rw-    setFileMode f total--#endif
src/atomic_create.c view
@@ -125,11 +125,12 @@     rc = link(filename, p);     if(rc >= 0)         goto success;-    else if(errno == EPERM || errno == EOPNOTSUPP) {+    else if(errno == EPERM || errno == EOPNOTSUPP || errno == ENOSYS) {         /* Linux returns EPERM when making hard links on filesystems            that don't support them. */         /* It seems that MacOS returns EOPNOTSUPP on filesystems that            don't support hard links. */+        /* Linux using SSHFS returns ENOSYS for link(). */         unlink(filename);         free(filename);         return sloppy_atomic_create(p);
− src/darcs.hs 
@@ -1,88 +0,0 @@--- Copyright (C) 2002-2003 David Roundy------ This program is free software; you can redistribute it and/or modify--- it under the terms of the GNU General Public License as published by--- the Free Software Foundation; either version 2, or (at your option)--- any later version.------ This program is distributed in the hope that it will be useful,--- but WITHOUT ANY WARRANTY; without even the implied warranty of--- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the--- GNU General Public License for more details.------ You should have received a copy of the GNU General Public License--- along with this program; see the file COPYING.  If not, write to--- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,--- Boston, MA 02110-1301, USA.--{-# LANGUAGE CPP #-}---- |--- Module      : Main--- Copyright   : 2002-2003 David Roundy--- License     : GPL--- Maintainer  : darcs-devel@darcs.net--- Stability   : experimental--- Portability : portable--module Main ( main ) where--import Control.Exception.Extensible ( AssertionFailed(..), handle )-import Control.Monad ( forM_ )-import System.IO ( stdin, stdout, stderr, hSetBinaryMode )-import System.Exit ( exitWith, ExitCode(..) )-import System.Environment ( getArgs )--import Darcs.Commands.Help ( helpCmd, listAvailableCommands, printVersion,-                             commandControlList )-import Darcs.Flags ( DarcsFlag(Verbose) )-import Darcs.Global ( withAtexit, atexit )-import Darcs.Repository( reportBadSources )-import Darcs.RunCommand ( runTheCommand )-import Darcs.SignalHandler ( withSignalsHandled )--import Darcs.Utils ( setDarcsEncodings )-import Exec ( ExecException(..) )-import Preproc( preprocMain )-import Version ( version, context, builddeps )--#include "impossible.h"--execExceptionHandler :: ExecException -> IO a-execExceptionHandler (ExecException cmd args redirects reason) = do-    putStrLn . unlines $-        [ "Failed to execute external command: " ++ unwords (cmd:args)-        , "Lowlevel error: " ++ reason-        , "Redirects: " ++ show redirects-        ]-    exitWith $ ExitFailure 3--main :: IO ()-main = withAtexit . withSignalsHandled . handleExecFail . handleAssertFail $ do-    atexit reportBadSources-    setDarcsEncodings-    argv <- getArgs-    -- Explicitly handle no-args and special "help" arguments.-    case argv of-        [] -> printVersion >> runHelpCmd-        ["-h"] -> runHelpCmd-        ["--help"] -> runHelpCmd-        ["--overview"] -> helpCmd [Verbose] []-        ["--commands"] -> listAvailableCommands-        ["-v"] -> putStrLn version-        ["--version"] -> putStrLn version-        ["--exact-version"] -> printExactVersion-        ("--preprocess-manual" : rest) -> preprocMain rest-        _ -> do-            forM_ [stdout, stdin, stderr] $ \h -> hSetBinaryMode h True-            runTheCommand commandControlList (head argv) (tail argv)-  where-    handleExecFail = handle execExceptionHandler-    handleAssertFail = handle $ \(AssertionFailed e) -> bug e-    runHelpCmd = helpCmd [] []-    printExactVersion =  do-        putStrLn $ "darcs compiled on " ++ __DATE__ ++ ", at " ++ __TIME__-        putStrLn context-        putStrLn "Compiled with:\n"-        putStr builddeps-
− src/fpstring.c 
@@ -1,69 +0,0 @@-/*- * Copyright (C) 2003 David Roundy- * Most of the UTF code is Copyright (C) 1999-2001 Free Software Foundation, Inc.- * This file is part of darcs.- *- * Darcs is free software; you can redistribute it and/or modify it under- * the terms of the GNU Library General Public License as published by the- * Free Software Foundation; either version 2 of the License, or (at your- * option) any later version.- *- * You should have received a copy of the GNU Library General Public- * License along with the GNU LIBICONV Library; see the file COPYING.LIB.- * If not, write to the Free Software Foundation, Inc., 51 Franklin Street,- * Fifth Floor, Boston, MA 02110-1301, USA.- *- */-#include "fpstring.h"--#include <stdlib.h>-#include <string.h>-#include <stdio.h>---#ifdef _WIN32-#include <windows.h>-#else-#include <sys/mman.h>-#endif--int has_funky_char(const char *s, int len)-{-  // We check first for the more likely \0 so we can break out of-  // memchr that much sooner.-  return !!(memchr(s, 0, len) || memchr(s, 26, len));--}--/* Conversion to and from hex */--void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars)-{-    static char hex[] = "0123456789abcdef";-    unsigned char *end;--    for (end = from + num_chars; from < end; from++) {-        *dest++ = hex[*from >> 4];-        *dest++ = hex[*from & 0xf];-    }--    return;-}--#define NYBBLE_TO_INT(c) \-    ((c) - ((c) >= 'a' ? 'a' - 10 : '0'))--void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars)-{-    unsigned char *end;-    unsigned char c;--    end = dest + num_chars;-    while (dest < end) {-        c = NYBBLE_TO_INT(*from) << 4, from++;-        *dest++ = c | NYBBLE_TO_INT(*from), from++;-    }--    return;-}-
− src/fpstring.h 
@@ -1,7 +0,0 @@-#include <HsFFI.h>-#include <sys/types.h>--int has_funky_char(const char *s, int len);--void conv_to_hex(unsigned char *dest, unsigned char *from, int num_chars);-void conv_from_hex(unsigned char *dest, unsigned char *from, int num_chars);
− src/gadts.h 
@@ -1,15 +0,0 @@-#ifdef GADT_WITNESSES--#define C(contexts) contexts-#define FORALL(types) forall types.-#define PATCHKIND (* -> * -> *)-#define SEALEDPATCHKIND (* -> *)--#else--#define C(contexts)-#define FORALL(types)-#define PATCHKIND *-#define SEALEDPATCHKIND *--#endif
− src/h_iconv.c 
@@ -1,18 +0,0 @@-#include "h_iconv.h"--// Wrapper functions, since iconv_open et al are macros in libiconv.-iconv_t darcs_iconv_open(const char *tocode, const char *fromcode) {-    return iconv_open(tocode, fromcode);-}--void darcs_iconv_close(iconv_t cd) {-    iconv_close(cd);-}--size_t darcs_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft,-                char **outbuf, size_t *outbytesleft) {-    // Cast inbuf to (void*) so that it works both on Solaris, which expects-    // a (const char**), and on other platforms (e.g. Linux), which expect-    // a (char **).-    return iconv(cd, (void*)inbuf, inbytesleft, outbuf, outbytesleft);-}
− src/h_iconv.h 
@@ -1,9 +0,0 @@-#include <iconv.h>--iconv_t darcs_iconv_open(const char *tocode, const char *fromcode);--void darcs_iconv_close(iconv_t cd);--size_t darcs_iconv(iconv_t cd, char **inbuf, size_t *inbytesleft,-                char **outbuf, size_t *outbytesleft);-
− src/hscurl.c 
@@ -1,355 +0,0 @@-#include "hscurl.h"--#include <curl/curl.h>-#include <errno.h>-#include <stdio.h>-#include <stdlib.h>-#include <string.h>--#if LIBCURL_VERSION_NUM >= 0x071301-/* enable pipelining for libcurl >= 7.19.1 */-#define ENABLE_PIPELINING-#endif--enum RESULT_CODES-  {-    RESULT_OK = 0,-    RESULT_MALLOC_FAIL,-    RESULT_SELECT_FAIL,-    RESULT_MULTI_INIT_FAIL,-    RESULT_EASY_INIT_FAIL,-    RESULT_SLIST_APPEND_FAIL,-    RESULT_MULTI_INFO_READ_FAIL,-    RESULT_UNKNOWN_MESSAGE,-    RESULT_FILE_OPEN_FAIL-  };--static const char *error_strings[] =-  {-    "",-    "malloc() failed",-    "select() failed",-    "curl_multi_init() failed",-    "curl_easy_init() failed",-    "curl_slist_append() failed",-    "curl_multi_info_read() failed",-    "curl_multi_info_read() returned unknown message",-    "fopen() failed"-  };--struct UrlData-{-  char *url;-  FILE *file;-  struct curl_slist *headers;-};--static int debug = 0;-#ifndef _WIN32-static const char user_agent[] =-  "darcs/" PACKAGE_VERSION " libcurl/" LIBCURL_VERSION;-#else-static const char user_agent[] =-  "darcs/unknown libcurl/" LIBCURL_VERSION;-#endif--static const char *proxypass;-static int init_done = 0;-static CURLM *multi = NULL;-static int msgs_in_queue = 0;-static char *last_url = NULL;--static const char *perform()-{-  int error;-  int running_handles, running_handles_last;-  fd_set fd_read, fd_write, fd_except;-  int max_fd;-  long timeout;-  struct timeval tval;--  error = curl_multi_perform(multi, &running_handles);-  if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-    return curl_multi_strerror(error);--  running_handles_last = running_handles;-  while (running_handles_last > 0)-    {-      while (error == CURLM_CALL_MULTI_PERFORM)-        error = curl_multi_perform(multi, &running_handles);--      if (error != CURLM_OK)-        return curl_multi_strerror(error);--      if (running_handles < running_handles_last)-        break;--      FD_ZERO(&fd_read);-      FD_ZERO(&fd_write);-      FD_ZERO(&fd_except);--      error = curl_multi_fdset(multi, &fd_read, &fd_write, &fd_except, &max_fd);-      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-        return curl_multi_strerror(error);--#ifdef CURL_MULTI_TIMEOUT-      error = curl_multi_timeout(multi, &timeout);-      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-        return curl_multi_strerror(error);--      if (timeout == -1)-#endif-        timeout = 100;--      tval.tv_sec = timeout / 1000;-      tval.tv_usec = timeout % 1000 * 1000;--      while (select(max_fd + 1, &fd_read, &fd_write, &fd_except, &tval) < 0)-        if (errno != EINTR)-          {-            if (debug)-              perror(error_strings[RESULT_SELECT_FAIL]);-            return error_strings[RESULT_SELECT_FAIL];-          }--      error = CURLM_CALL_MULTI_PERFORM;-    }--  return NULL;-}--const char *curl_request_url(const char *url,-                             const char *filename,-                             int cache_time)-{-  int error;--  if (init_done == 0)-    {-      error = curl_global_init(CURL_GLOBAL_ALL);-      if (error != CURLE_OK)-        return curl_easy_strerror(error);-      proxypass = getenv("DARCS_PROXYUSERPWD");-      init_done = 1;-    }--  if (multi == NULL)-    {-      multi = curl_multi_init();-      if (multi == NULL)-        return error_strings[RESULT_MULTI_INIT_FAIL];-#ifdef ENABLE_PIPELINING-      error = curl_multi_setopt(multi, CURLMOPT_PIPELINING, 1);-      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-        return curl_multi_strerror(error);-#endif-    }--  CURL *easy = curl_easy_init();-  if (easy == NULL)-    return error_strings[RESULT_EASY_INIT_FAIL];--  if (debug)-    {-      error = curl_easy_setopt(easy, CURLOPT_VERBOSE, 1);-      if (error != CURLE_OK)-        return curl_easy_strerror(error);-    }--  struct UrlData *url_data = malloc(sizeof(struct UrlData));-  if (url_data == NULL)-    return error_strings[RESULT_MALLOC_FAIL];--  url_data->url = strdup(url);-  if (url_data->url == NULL)-    return error_strings[RESULT_MALLOC_FAIL];--  url_data->file = fopen(filename,"wb");-  if (url_data->file == NULL)-    {-      if (debug)-        perror(error_strings[RESULT_FILE_OPEN_FAIL]);-      return error_strings[RESULT_FILE_OPEN_FAIL];-    }--  error = curl_easy_setopt(easy, CURLOPT_PRIVATE, url_data);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_URL, url_data->url);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--#ifdef CURLOPT_WRITEDATA-  error = curl_easy_setopt(easy, CURLOPT_WRITEDATA, url_data->file);-#else-  error = curl_easy_setopt(easy, CURLOPT_FILE, url_data->file);-#endif-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_USERAGENT, user_agent);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_FOLLOWLOCATION, 1);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_FAILONERROR, 1);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  error = curl_easy_setopt(easy, CURLOPT_HTTPAUTH, CURLAUTH_ANY);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  /* libcurl currently always sends Pragma: no-cache, but never-     Cache-Control, which is contradictory.  We override both, just to-     be sure. */-  url_data->headers = curl_slist_append(NULL, "Accept: */*");-  if(cache_time == 0)-    {-      url_data->headers =-        curl_slist_append(url_data->headers, "Pragma: no-cache");-      url_data->headers =-        curl_slist_append(url_data->headers, "Cache-Control: no-cache");-    }-  else if(cache_time > 0)-    {-      /* This won't work well with HTTP/1.0 proxies. */-      char buf[40];-      snprintf(buf, sizeof(buf), "Cache-Control: max-age=%d", cache_time);-      buf[sizeof(buf) - 1] = '\n';-      url_data->headers = curl_slist_append(url_data->headers, "Pragma:");-      url_data->headers = curl_slist_append(url_data->headers, buf);-    }-  else-    {-      url_data->headers = curl_slist_append(url_data->headers, "Pragma:");-      url_data->headers = curl_slist_append(url_data->headers, "Cache-Control:");-    }-  if (url_data->headers == NULL)-    return error_strings[RESULT_SLIST_APPEND_FAIL];--  error = curl_easy_setopt(easy, CURLOPT_HTTPHEADER, url_data->headers);-  if (error != CURLE_OK)-    return curl_easy_strerror(error);--  if (proxypass && *proxypass)-    {-      error = curl_easy_setopt(easy, CURLOPT_PROXYUSERPWD, proxypass);-      if (error != CURLE_OK)-        return curl_easy_strerror(error);-    }--  error = curl_multi_add_handle(multi, easy);-  if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-    return curl_multi_strerror(error);--  return error_strings[RESULT_OK];-}--const char *curl_wait_next_url(int* errorCode, long* httpErrorCode)-{-  *errorCode = -1;-  *httpErrorCode = -1;--  if (last_url != NULL)-    {-      free(last_url);-      last_url = NULL;-    }--  if (msgs_in_queue == 0)-    {-      const char *error = perform();-      if (error != NULL)-        return error;-    }--  CURLMsg *msg = curl_multi_info_read(multi, &msgs_in_queue);-  if (msg == NULL)-    return error_strings[RESULT_MULTI_INFO_READ_FAIL];--  if (msg->msg == CURLMSG_DONE)-    {-      CURL *easy = msg->easy_handle;-      CURLcode result = msg->data.result;-      struct UrlData *url_data;--      int error = set_time_out(easy, errorCode);-      if (error != CURLE_OK ){-        *errorCode = error;-        return curl_easy_strerror(error);-      }--      error = curl_easy_getinfo(easy, CURLINFO_PRIVATE, (char **)&url_data);-      if (error != CURLE_OK){-        *errorCode = error;-        return curl_easy_strerror(error);-      }--      last_url = url_data->url;-      fclose(url_data->file);-      curl_slist_free_all(url_data->headers);-      free(url_data);--      error = curl_multi_remove_handle(multi, easy);-      if (error != CURLM_OK && error != CURLM_CALL_MULTI_PERFORM)-        return curl_multi_strerror(error);-      curl_easy_cleanup(easy);--      if (result != CURLE_OK){-        *errorCode = result;--        if (result == CURLE_HTTP_RETURNED_ERROR)-		  curl_easy_getinfo(easy, CURLINFO_RESPONSE_CODE, httpErrorCode);--        return curl_easy_strerror(result);-      }-    }-  else-    return error_strings[RESULT_UNKNOWN_MESSAGE];--  return error_strings[RESULT_OK];-}--const char *curl_last_url()-{-  return last_url != NULL ? last_url : "";-}--void curl_enable_debug()-{-  debug = 1;-}--int curl_pipelining_enabled()-{-#ifdef ENABLE_PIPELINING-  return 1;-#else-  return 0;-#endif-}--int set_time_out(CURL *handle, int* errorCode)-{-  int error;-  long time_out = DEFAULT_CONNECTION_TIMEOUT;-  const char *stime_out;--  stime_out = getenv("DARCS_CONNECTION_TIMEOUT");-  if (stime_out != NULL){-    long result = atol (stime_out);-    if ( result > 0 )-      time_out = result;-    else-      *errorCode = 90 ;-  }--  error = curl_easy_setopt(handle, CURLOPT_TIMEOUT, time_out);--  return error;-}
− src/hscurl.h 
@@ -1,15 +0,0 @@-#define DEFAULT_CONNECTION_TIMEOUT 30--const char *curl_request_url(const char *url,-                             const char *filename,-                             int cache_time);--const char *curl_wait_next_url(int *errorCode, long* httpErrorCode);--const char *curl_last_url();--void curl_enable_debug();--int curl_pipelining_enabled();--int set_time_out();
− src/impossible.h 
@@ -1,8 +0,0 @@-import qualified Darcs.Bug as Bug_--#define darcsBug (\imp_funny_name -> imp_funny_name (__FILE__,__LINE__,__TIME__,__DATE__))--#define bug        (darcsBug Bug_._bug)-#define impossible (darcsBug Bug_._impossible)-#define fromJust   (darcsBug Bug_._fromJust)-#define bugDoc     (darcsBug Bug_._bugDoc)
− src/system_encoding.c 
@@ -1,10 +0,0 @@-#include "system_encoding.h"--char* get_system_encoding() {-#ifdef WIN32-  return "utf8";-#else-  setlocale(LC_ALL,"");-  return nl_langinfo(CODESET);-#endif-}
− src/system_encoding.h 
@@ -1,11 +0,0 @@-#ifndef __SYSTEM_ENCODING__-#define __SYSTEM_ENCODING__--#ifndef WIN32-#include <langinfo.h>-#include <locale.h>-#endif--char* get_system_encoding();--#endif
− src/test.hs 
@@ -1,206 +0,0 @@-{-# LANGUAGE CPP, MultiParamTypeClasses, DeriveDataTypeable #-}-module Main ( main ) where--import qualified Darcs.Test.Misc-import qualified Darcs.Test.Patch-import qualified Darcs.Test.Email--import Control.Monad (when, filterM)-import Data.List ( isPrefixOf, isSuffixOf, sort )-import qualified Data.ByteString.Char8 as B-import System.Console.CmdLib-import System.Directory ( doesFileExist )-import System.Environment.FindBin ( getProgPath )-import System.FilePath( takeDirectory, takeBaseName, isAbsolute )-import System.IO( hSetBinaryMode, hSetBuffering, BufferMode( NoBuffering ), stdin, stdout, stderr )-import Test.Framework.Providers.API-import Test.Framework-import Shellish hiding ( liftIO, run )-import qualified Shellish--doUnit :: IO [Test]-doUnit = return unitTests---- | This is the big list of tests that will be run using testrunner.-unitTests :: [Test]-unitTests =-  [ Darcs.Test.Email.testSuite-  , Darcs.Test.Misc.testSuite-  ] ++ Darcs.Test.Patch.testSuite---- ------------------------------------------------------------------------- shell tests--- ------------------------------------------------------------------------data Format = Hashed | Darcs2 deriving Show-data Running = Running deriving Show-data Result = Success | Skipped | Failed String--instance Show Result where-  show Success = "Success"-  show Skipped = "Skipped"-  show (Failed f) = unlines (map ("| " ++) $ lines f)--instance TestResultlike Running Result where-  testSucceeded Success = True-  testSucceeded Skipped = True-  testSucceeded _ = False--data ShellTest = ShellTest { format :: Format-                           , testfile :: FilePath-                           , testdir  :: Maybe FilePath -- ^ only if you want to set it explicitly-                           , _darcspath :: FilePath-                           }-                 deriving Typeable--runtest' :: ShellTest -> FilePath -> ShIO Result-runtest' (ShellTest fmt _ _ dp) srcdir =-  do wd <- pwd-     setenv "HOME" wd-     setenv "TESTDATA" (srcdir </> "tests" </> "data")-     setenv "TESTBIN" (srcdir </> "tests" </> "bin")-     setenv "DARCS_TESTING_PREFS_DIR" $ wd </> ".darcs"-     setenv "EMAIL" "tester"-     setenv "DARCS_DONT_COLOR" "1"-     setenv "DARCS_DONT_ESCAPE_ANYTHING" "1"-     getenv "PATH" >>= setenv "PATH" . ((takeDirectory dp ++ pathVarSeparator) ++)-     setenv "DARCS" dp-     mkdir ".darcs"-     writefile ".darcs/defaults" defaults--- Warning:  A do-notation statement discarded a result of type String.-     _ <- Shellish.run "bash" [ "test" ]-     return Success-   `catch_sh` \e -> case e of-      RunFailed _ 200 _ -> return Skipped-      RunFailed _ _   _ -> Failed <$> B.unpack <$> lastOutput-  where defaults = unlines ["ALL " ++ fmtstr, "send no-edit-description", "ALL ignore-times"]-        fmtstr = case fmt of-                  Darcs2 -> "darcs-2"-                  Hashed -> "hashed"-#ifdef WIN32-        pathVarSeparator = ";"-#else-        pathVarSeparator = ":"-#endif--runtest :: ShellTest -> ShIO Result-runtest t =- withTmp $ \dir -> do-  cp "tests/lib" dir-  cp ("tests" </> testfile t) (dir </> "test")-  srcdir <- pwd-  silently $ sub $ cd dir >> runtest' t srcdir- where-  withTmp =-   case testdir t of-     Just dir -> \job -> do-       let d = (dir </> show (format t) </> takeBaseName (testfile t))-       mkdir_p d-       job d-     Nothing  -> withTmpDir--instance Testlike Running Result ShellTest where-  testTypeName _ = "Shell"-  runTest _ test = runImprovingIO $ do yieldImprovement Running-                                       liftIO (shellish $ runtest test)--shellTest :: FilePath -> Format -> Maybe FilePath -> String -> Test-shellTest dp fmt tdir file = Test (file ++ " (" ++ show fmt ++ ")") $ ShellTest fmt file tdir dp--findShell :: FilePath -> Maybe FilePath -> Bool -> ShIO [Test]-findShell dp tdir isFailing =-  do files <- sort <$> grep relevant <$> grep (".sh" `isSuffixOf`) <$> ls "tests"-     return [ shellTest dp fmt tdir file-            | fmt <- [ Darcs2, Hashed ]-            , file <- files ]-  where relevant = (if isFailing then id else not) . ("failing-" `isPrefixOf`)--findNetwork :: FilePath -> Maybe FilePath -> ShIO [Test]-findNetwork dp tdir =-  do files <- sort <$> grep (".sh" `isSuffixOf`) <$> ls "tests/network"-     return [ shellTest dp Darcs2 tdir ("network" </> file) | file <- files ]---- ------------------------------------------------------------------------- harness--- ------------------------------------------------------------------------data Config = Config { failing :: Bool-                     , shell :: Bool-                     , network :: Bool-                     , unit :: Bool-                     , darcs :: String-                     , tests :: [String]-                     , testDir :: Maybe FilePath-                     , plain :: Bool-                     , hideSuccesses :: Bool-                     , threads :: Int }-            deriving (Data, Typeable, Eq)--instance Attributes Config where-  attributes _ = group "Options"-    [ failing %> Help "Run the failing (shell) tests."-    , shell %> Help "Run the passing, non-network shell tests." %+ Default True-    , network %> Help "Run the network shell tests."-    , unit %> Help "Run the unit tests." %+ Default True-    , tests %> Help "Pattern to limit the tests to run." %+ short 't'-    , testDir %> Help "Directory to run tests in" %+ Default (Nothing :: Maybe FilePath)-    , plain %> Help "Use plain-text output."-    , hideSuccesses %> Help "Hide successes."-    , threads %> Default (1 :: Int) %+ short 'j' ]--data DarcsTest = DarcsTest deriving Typeable-instance Command DarcsTest (Record Config) where-  run _ conf _ = do-    let args = [ "-j", show $ threads conf ] -             ++ concat [ ["-t", x ] | x <- tests conf ]-             ++ [ "--plain" | True <- [plain conf] ]-             ++ [ "--hide-successes" | True <- [hideSuccesses conf] ]-             ++ [ "--maximum-unsuitable-generated-tests", "700" ]-    case testDir conf of-       Nothing -> return ()-       Just d  -> do e <- shellish (test_e d)-                     when e $ fail ("Directory " ++ d ++ " already exists. Cowardly exiting")-    darcsBin <--        case darcs conf of-            "" -> do-                path <- getProgPath-                let candidates =-                      -- if darcs-test lives in foo/something, look for foo/darcs[.exe]-                      -- for example if we've done cabal install -ftest, there'll be a darcs-test and darcs in the cabal-                      -- installation folder-                      [path </> "darcs" ++ exeSuffix] ++-                      -- if darcs-test lives in foo/darcs-test/something, look for foo/darcs/darcs[.exe]-                      -- for example after cabal build we can run dist/build/darcs-test/darcs-test and it'll find-                      -- the darcs in dist/build/darcs/darcs-                      [takeDirectory path </> "darcs" </> "darcs" ++ exeSuffix | takeBaseName path == "darcs-test" ]-                availableCandidates <- filterM doesFileExist candidates-                case availableCandidates of-                     (darcsBin:_) -> do-                         putStrLn $ "Using darcs executable in " ++ darcsBin-                         return darcsBin-                     [] -> fail ("No darcs specified or found nearby. Perhaps --darcs `pwd`/dist/build/darcs/darcs" ++ exeSuffix ++ "?")-            v -> return v-    when (shell conf || network conf || failing conf) $ do-      when (not (isAbsolute $ darcsBin)) $-        fail ("Argument to --darcs should be an absolute path")-      when (not (exeSuffix `isSuffixOf` darcsBin)) $-        putStrLn $ "Warning: --darcs flag does not end with " ++ exeSuffix ++ " - some tests may fail (case does matter)"-    ftests <- shellish $ if failing conf then findShell darcsBin (testDir conf) True else return []-    stests <- shellish $ if shell conf then findShell darcsBin (testDir conf) False else return []-    utests <- if unit conf then doUnit else return []-    ntests <- shellish $ if network conf then findNetwork (darcs conf) (testDir conf) else return []-    defaultMainWithArgs (ftests ++ stests ++ utests ++ ntests) args-       where-          exeSuffix :: String-#ifdef WIN32-          exeSuffix = ".exe"-#else-          exeSuffix = ""-#endif--main :: IO ()-main = do hSetBinaryMode stdout True-          hSetBuffering stdout NoBuffering-          hSetBinaryMode stderr True-          hSetBinaryMode stdin True-          getArgs >>= execute DarcsTest
− src/win32/CtrlC.hs 
@@ -1,21 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}--module CtrlC (withCtrlCHandler) where--import Data.Word ( Word32 )-import Foreign.Ptr ( FunPtr )-import Control.Exception ( bracket )--type Handler = Word32 -> IO Int--foreign import ccall "wrapper" wrap :: Handler -> IO (FunPtr Handler)-foreign import stdcall "SetConsoleCtrlHandler" setConsoleCtrlHandler :: FunPtr Handler -> Int -> IO ()---withCtrlCHandler :: IO () -> IO a -> IO a-withCtrlCHandler handler m = do-    fp <- wrap (\_ctrlType -> handler >> return 1)-    bracket (setConsoleCtrlHandler fp 1) (const $ setConsoleCtrlHandler fp 0) (const m)---
+ src/win32/Darcs/Util/CtrlC.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module Darcs.Util.CtrlC ( withCtrlCHandler ) where++import Darcs.Prelude++import Data.Word ( Word32 )+import Foreign.Ptr ( FunPtr )+import Control.Exception ( bracket_ )++#include <windows_cconv.h>++type Handler = Word32 -> IO Int++foreign import WINDOWS_CCONV "wrapper" wrap :: Handler -> IO (FunPtr Handler)+foreign import WINDOWS_CCONV "SetConsoleCtrlHandler" setConsoleCtrlHandler :: FunPtr Handler -> Int -> IO ()+++withCtrlCHandler :: IO () -> IO a -> IO a+withCtrlCHandler handler m = do+    fp <- wrap (\_ctrlType -> handler >> return 1)+    bracket_ (setConsoleCtrlHandler fp 1) (setConsoleCtrlHandler fp 0) m+++
src/win32/System/Posix.hs view
@@ -1,11 +1,14 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP, ForeignFunctionInterface #-}  module System.Posix ( sleep ) where +import Darcs.Prelude+ import Foreign.C.Types ( CInt(..), CUInt(..), CULong(..) ) -foreign import stdcall "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt+#include <windows_cconv.h>++foreign import WINDOWS_CCONV "winbase.h SleepEx" c_SleepEx :: CULong -> CUInt -> IO CInt  sleep :: Integer -> IO CInt sleep n = c_SleepEx (1000 * fromIntegral n) 1
+ src/win32/System/Posix/Files.hs view
@@ -0,0 +1,15 @@+module System.Posix.Files+    ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink+    , getFdStatus, getFileStatus, getSymbolicLinkStatus+    , modificationTimeHiRes, setFileMode, fileSize, fileMode, fileOwner+    , stdFileMode, FileStatus, fileID+    , linkCount, createLink, ownerModes+    ) where++import System.PosixCompat.Files+    ( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink+    , getFdStatus, getFileStatus, getSymbolicLinkStatus+    , modificationTimeHiRes, setFileMode, fileSize, fileMode, fileOwner+    , stdFileMode, FileStatus, fileID+    , linkCount, createLink, ownerModes+    )
− src/win32/System/Posix/Files.hsc 
@@ -1,29 +0,0 @@-{-# OPTIONS_GHC -fno-warn-dodgy-imports #-} -- needed for GHC 7.0/7.2-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-module System.Posix.Files( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink-                               , getFdStatus, getFileStatus, getSymbolicLinkStatus-                               , modificationTime, setFileMode, fileSize, fileMode-                               , stdFileMode, linkCount, createLink-                               , FileStatus-                         ) where--import System.PosixCompat.Files( isNamedPipe, isDirectory, isRegularFile, isSymbolicLink-                               , getFdStatus, getFileStatus, getSymbolicLinkStatus-                               , modificationTime, setFileMode, fileSize, fileMode-                               , stdFileMode, FileStatus )--import Foreign.C.String( CWString, withCWString )-import Foreign.C.Error( throwErrnoPathIf_ )-import Foreign.Ptr( Ptr, nullPtr )-import Foreign.C( CInt(..) )--linkCount :: FileStatus -> Int-linkCount _ = 1--#define _WIN32_WINNT 0x0500-foreign import stdcall "winbase.h CreateHardLinkW" c_CreateHardLink :: CWString -> CWString -> Ptr a -> IO CInt--createLink :: FilePath -> FilePath -> IO ()-createLink old new = withCWString old $ \c_old -> withCWString new $ \c_new ->-        throwErrnoPathIf_ (==0) "createLink" new $-                c_CreateHardLink c_new c_old nullPtr
src/win32/System/Posix/IO.hsc view
@@ -1,7 +1,9 @@ {-# LANGUAGE ForeignFunctionInterface #-} module System.Posix.IO where -#if mingw32_HOST_OS && __GLASGOW_HASKELL__ >= 612+import Darcs.Prelude++#if mingw32_HOST_OS import Foreign.C.String( withCWString ) #else import Foreign.C.String ( withCString )@@ -9,11 +11,8 @@  import Foreign.C.Error ( throwErrnoIfMinus1, throwErrnoIfMinus1_ ) -import GHC.IO.Handle.FD ( fdToHandle )--import System.Posix.Internals ( c_open, c_close, c_dup2 )+import System.Posix.Internals ( c_open, c_close ) import System.Posix.Types ( Fd(..), FileMode )-import System.IO ( Handle )  import Data.Bits ( (.|.) ) @@ -30,16 +29,17 @@   exclusive :: Bool,   noctty :: Bool,   nonBlock :: Bool,-  trunc :: Bool+  trunc :: Bool,+  creat :: Maybe FileMode  }   -- Adapted from System.Posix.IO in ghc #include <fcntl.h> -openFd :: FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd-openFd name how maybe_mode off = do-#if mingw32_HOST_OS && __GLASGOW_HASKELL__ >= 612+openFd :: FilePath -> OpenMode -> OpenFileFlags -> IO Fd+openFd name how off = do+#if mingw32_HOST_OS   withCWString name $ \s -> do #else   withCString name $ \s -> do@@ -47,13 +47,13 @@    fd <- throwErrnoIfMinus1 "openFd" (c_open s all_flags mode_w)    return (Fd fd)  where-   all_flags = binary .|. creat .|. flags .|. open_mode+   all_flags = binary .|. creat_ .|. flags .|. open_mode    flags =     (if append off    then (#const O_APPEND)   else 0) .|.     (if exclusive off then (#const O_EXCL)     else 0) .|.     (if trunc off     then (#const O_TRUNC)    else 0)    binary = (#const O_BINARY)-   (creat, mode_w) = maybe (0,0) (\x->((#const O_CREAT),x)) maybe_mode+   (creat_, mode_w) = maybe (0,0) (\x->((#const O_CREAT),x)) (creat off)    open_mode = case how of                 ReadOnly  -> (#const O_RDONLY)                 WriteOnly -> (#const O_WRONLY)@@ -62,18 +62,9 @@ closeFd :: Fd -> IO () closeFd (Fd fd) = throwErrnoIfMinus1_ "closeFd" (c_close fd) --fdToHandle :: Fd -> IO Handle-fdToHandle fd = GHC.IO.Handle.FD.fdToHandle (fromIntegral fd)--dupTo :: Fd -> Fd -> IO Fd-dupTo (Fd fd1) (Fd fd2) = do-  r <- throwErrnoIfMinus1 "dupTo" (c_dup2 fd1 fd2)-  return (Fd r)- data OpenMode = ReadOnly | WriteOnly | ReadWrite  defaultFileFlags :: OpenFileFlags-defaultFileFlags = OpenFileFlags False False False False False+defaultFileFlags = OpenFileFlags False False False False False Nothing
src/win32/send_email.c view
@@ -130,7 +130,7 @@             else if(send_res== MAPI_E_TEXT_TOO_LARGE)       fprintf(stderr, "MAPI error: Text too large.\n");             else if(send_res== MAPI_E_INVALID_SESSION)      fprintf(stderr, "MAPI error: Invalid session.\n");             else if(send_res== MAPI_E_TYPE_NOT_SUPPORTED)   fprintf(stderr, "MAPI error: Type not supported.\n");-            else if(send_res== MAPI_E_AMBIGUOUS_RECIP)      fprintf(stderr, "MAPI error: Ambigious recipient.\n");+            else if(send_res== MAPI_E_AMBIGUOUS_RECIPIENT)      fprintf(stderr, "MAPI error: Ambigious recipient.\n");             else if(send_res== MAPI_E_MESSAGE_IN_USE)       fprintf(stderr, "MAPI error: Messag in use.\n");             else if(send_res== MAPI_E_NETWORK_FAILURE)      fprintf(stderr, "MAPI error: Network failure.\n");             else if(send_res== MAPI_E_INVALID_EDITFIELDS)   fprintf(stderr, "MAPI error: Invalid editfields\n");
− src/win32/sys/mman.h 
@@ -1,7 +0,0 @@--#include <sys/types.h>--void *mmap(void *start, size_t length, int prot, int flags, int fd, off_t offset);-int munmap(void *start, size_t length);--
tests/EXAMPLE.sh view
@@ -24,19 +24,26 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.-darcs init      --repo S+# every test script MUST source lib+. lib +# every test script should remove directories before creating them+rm -rf R S+darcs init R+darcs init S+ cd R-mkdir d e                       # Change the working tree.+# change the working tree+mkdir d e echo 'Example content.' > d/f-darcs record -lam 'Add d/f and e.'+darcs record -lam 'Add d/f and e.' --debug 2>../RLOG darcs mv d/f e/ darcs record -am 'Move d/f to e/f.'-darcs push ../S -a	        # Try to push patches between repos.+# push patches from R to S+darcs push ../S -a cd ..  cd S+# push patches back from S to R darcs push ../R -a cd ..
tests/README.test_maintainers.txt view
@@ -1,112 +1,1 @@--The following is provided as a reference for those interested in understanding-how the test suite works, and how to add and maintain tests.--Overview of types of tests-==========================--Darcs has tests in two formats.  Unit tests that directly test Haskell-functions are written in Haskell and live in modules under src/Darcs/Test.-Functional tests that test the darcs binary are written in Shell and live in-tests/.--Haskell tests-----------------------------These are QuickCheck and HUnit tests primarily testing the Darcs core. The-Haskell modules containing these tests are under Darcs.Test in the module-hierarchy. They are called from src/unit.lhs using the test-framework package-from Hackage.--More about the Haskell tests can be found on http://wiki.darcs.net/Development/UnitTests.--Shell tests------------------------------Shell tests are useful because they are easy to create from a copy/paste-of actual shell commands executed. They are considered successful if no-bad exit codes are returned from the commands in the script. If the name of the-script file starts with 'failing-' however, the script is expected to return-a bad exit code. If such a script returns a bad exit code, this will not be-treated as a test suite failure. This is useful to document bugs and to-do-items.--How to run tests-=============================--To build the unit tests, pass the "-ftest" flag to "cabal configure" and then-do "cabal build". To run them, do "dist/build/unit/unit". They take a while.-Output like "[OK]" and "[OK, passed 100 tests]" is good. Output like-"Arguments exhausted after 33 tests" is a shortage of QuickCheck test-cases, not a test failure.--"runghc Setup.lhs test" causes all the functional tests in "tests/" to be run-against repositories in the old, hashed, and darcs2 formats.--Because "runghc Setup.lhs test" can take a long time to run, it's useful to run-fewer tests at once.  To help with that, 'runghc Setup.lhs test' accepts-arguments to run only a specific group of test scripts, or only named test-scripts:--  runghc Setup.lhs test tests       # all tests, excluding bugs or network tests-  runghc Setup.lhs test bugs        # all bugs (the 'failing-' scripts)-  runghc Setup.lhs test network     # the network tests--  # and this one runs tests/issue279_get_extra.sh and tests/repair_corrupt.sh-  runghc Setup.lhs test issue279_get_extra repair-corrupt--Tips for writing (and reading) tests-====================================--- Avoid including a repo format type to "darcs init"-  This insures that all three repo formats will be tested.-  However, if you know that the test only passes under some-  repo formats, *do* explicitly include a format option to "darcs init".---Tips for writing tests-------------------------- Copy EXAMPLE.sh as a template to start from (don't forget to customise-  the headers!).--- Simply call darcs using "darcs" as you would in the shell.  It is the-  responsibility of the test harness to ensure that the darcs we are-  testing is first in the path.--- Always use Bash explicitly - this improves the portability of our tests.--- Always add this near the top of the script:--   set -ev--  The "v" causes the contents of the script to be printed as part of the run,-  which is helpful for debugging.  The "e" causes the script to exit as soon as-  there is an error.--- Try to avoid defining functions where possible.  This makes them-  harder to run and generally harder to use.  There are certainly cases-  where it is appropriate to define a function, but please do not do-  this just to avoid a little duplication.--- Also try to be careful using certain utilities; 'yes' is prohibited since-  it can cause infinite loops on Mac OS X; 'find' can be very useful, but-  options and behavior can differ from GNU find to the BSD finds to Solaris's-  find and so on. In general, stick to POSIX flags and functionality.--- There is a utility script intended for factoring out common calls and-  functions, called 'lib'. It can be invoked by adding a line like '. lib' to-  your shell script. lib provides 'set -ev', a common definition of 'not', and-  'abort_windows' for use in scripts which shouldn't run under Windows.-  You don't have to use lib if you don't want to, or if it causes problems.--- If you need to skip a test for any reason, the darcs-specific-  convention is to "exit 200".  This alerts the shell harness that the-  test was explicitly skipped and not passed.--- You can use the trap feature from bash to make ensure that darcs executes-  some command even if the test fails. Trapping ERR lets you have your-  last word just before a test fails. Trapping EXIT lets you do the-  same before any sort of explicit exit (such as the explicit 'exit 1'-  in the 'not' helper function).  For more details, see the bash man-  page or just grep trap in the test suite.+Please consult <http://darcs.net/Development/RegressionTests>.
− tests/add-formerly-pl.sh 
@@ -1,58 +0,0 @@-#!/usr/bin/env bash--# Some tests for 'darcs add'--. lib--rm -rf temp1 temp2--# set up the repository-mkdir temp1-cd temp1-darcs init--# Make sure that messages about directories call them directories-mkdir foo.d-mkdir oof.d-darcs add foo.d-darcs add oof.d-not darcs add foo.d 2>&1 | grep -i directory-# Try adding the same directory when it's already in the repo-not darcs add foo.d oof.d 2>&1 | grep -i directories--# Make sure that messages about files call them files-touch bar-touch baz-darcs add bar-darcs add baz-not darcs add bar 2>&1 | grep -i "following file is"-not darcs add bar baz 2>&1 | grep -i "following files are"--# Make sure that messages about both files and directories say so-not darcs add bar foo.d 2>&1 | grep -i 'files and directories'---# Make sure that parent directories are added for files-mkdir -p a.d/aa.d/aaa.d-mkdir -p b.d/bb.d-touch a.d/aa.d/aaa.d/baz-touch a.d/aa.d/aaa.d/bar-darcs add a.d/aa.d/aaa.d/bar a.d/aa.d/aaa.d/baz b.d/bb.d 2> log-test ! -s log # no output--# Make sure that darcs doesn\'t complains about duplicate adds when adding parent dirs.-mkdir c.d-touch c.d/baz-darcs add c.d/baz c.d 2> log-test ! -s log # no output--# Make sure that add output looks good when adding files in subdir-mkdir d.d-touch d.d/foo-darcs add -rv d.d | grep 'd.d/foo'--# 'adding a non-existent dir and file gives the expected message-not darcs add notadir/notafile 2>&1 | grep -i 'does not exist'--cd ..-rm -rf temp1
tests/add.sh view
@@ -1,10 +1,9 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1-mkdir temp1+darcs init temp1 cd temp1-darcs init touch foo bar darcs add foo bar @@ -17,3 +16,104 @@  rm -rf temp1 +# add in subdir++darcs init temp1+cd temp1++mkdir dir+echo zig > dir/foo+darcs add dir dir/foo+darcs record -am add_foo+cd ..+rm -rf temp1++# addrm++darcs init temp1+cd temp1+touch foo+darcs add foo+darcs record -a -m add_foo -A x+darcs remove foo+darcs record -a -m del_foo -A x+cd ..+rm -rf temp1++# issue1162: add nonexistent slash++rm -rf temp1+darcs init temp1+cd temp1+not darcs add a/ 2> err+cat err+grep 'does not exist' err+cd ..+rm -rf temp1++# issue184: recording files in directories that haven't explicity been added++darcs init temp1+cd temp1++mkdir new+mkdir new/dir+touch new/dir/t.t+darcs add new/dir/t.t+darcs record -am test new/dir/t.t > log+not grep "don't want to record" log+cd ..++rm -rf temp1++# Make sure that parent directories are added for files+darcs init temp1+cd temp1++mkdir -p a.d/aa.d/aaa.d+mkdir -p b.d/bb.d+touch a.d/aa.d/aaa.d/baz+touch a.d/aa.d/aaa.d/bar+darcs add -v a.d/aa.d/aaa.d/bar a.d/aa.d/aaa.d/baz b.d/bb.d 2> log+not grep -F ".d" log++# Make sure that darcs doesn't complain about duplicate adds when adding parent dirs.+mkdir c.d+touch c.d/baz+darcs add -v c.d/baz c.d 2> log+not grep -F ".d" log++# Make sure that add output looks good when adding files in subdir+mkdir d.d+touch d.d/foo+darcs add -rv d.d | grep 'd.d/foo'++# 'adding a non-existent dir and file gives the expected message+not darcs add -v notadir/notafile 2>&1 | grep -i 'does not exist'++cd ..+rm -rf temp1++#  test for darcs add behaviour on missing files.++darcs init temp1+cd temp1++rm -f foo+not darcs add foo >stdout 2>stderr+not grep foo stdout+grep foo stderr # error message about foo not existing++touch foo+darcs add foo >stdout 2>stderr+grep foo stdout  # confirmation message of added file+not grep foo stderr++not darcs add foo 2>stderr+grep 'not added' stderr # error message about some files not being added++rm foo+not darcs add foo 2>stderr+grep 'not added' stderr # error message about some files not being added++cd ..
− tests/add_in_subdir.sh 
@@ -1,22 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-mkdir dir-echo zig > dir/foo-darcs add dir dir/foo-darcs record -a -m add_foo-# Create second repo inside the first-darcs init --repodir=temp2-cd  temp2-darcs pull -a ../../temp1-darcs changes -s | grep "A ./dir/foo"-# no differences-diff ../../temp1/dir/foo dir/foo-cd ..--rm -rf temp1
tests/add_permissions.sh view
@@ -27,6 +27,9 @@ . lib  abort_windows                   # does not work on Windows.++trap "chmod a+r $PWD/temp1/unreadable $PWD/temp1/d" EXIT+ mkdir temp1 cd temp1 darcs initialize@@ -34,9 +37,7 @@ chmod a-r unreadable      # Make the file unreadable. not darcs add unreadable 2> log fgrep -i 'permission denied' log-# Testing by hand with a directory works, but darcs-test gets-# stuck by having an unreadable subdir.-#mkdir d-#chmod a-r d-#not darcs add --debug --verbose d-#fgrep -i 'permission denied' log+mkdir d+chmod a-r d+not darcs add --debug --verbose d+fgrep -i 'permission denied' log
− tests/addexitval.sh 
@@ -1,33 +0,0 @@-#!/usr/bin/env bash--set -ev--rm -rf tmp-mkdir tmp-cd tmp-darcs init--empty='test ! -s'-nonempty='test -s'--rm -f foo-darcs add foo >stdout 2>stderr && exit 1 || true-$empty stdout-$nonempty stderr-->foo-darcs add foo >stdout 2>stderr-$empty stdout-$empty stderr--darcs add foo >stdout 2>stderr && exit 1 || true-$empty stdout-$nonempty stderr--rm foo-darcs add foo >stdout 2>stderr && exit 1 || true-$empty stdout-$nonempty stderr--cd ..-rm -rf tmp
− tests/addmv.sh 
@@ -1,20 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1 temp2-mkdir temp1 temp2-cd temp1-darcs init-touch foo bar-darcs add foo bar-darcs record -a -m add_foo_bar -A x-darcs mv foo zig-darcs mv bar foo-darcs mv zig bar-darcs record -a -m swap_foo_bar -A x-cd ../temp2-darcs init-darcs pull -v -a ../temp1-cd ..-rm -rf temp1 temp2-
− tests/addrace.sh 
@@ -1,18 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1 temp2-mkdir temp1 temp2-cd temp1-darcs init-echo zig > foo-darcs add foo-#sleep 1-darcs record -a -m add_foo -A x-cd ../temp2-darcs init-darcs pull -a ../temp1-cd ..-cmp temp1/foo temp2/foo-rm -rf temp1 temp2-
− tests/addrm.sh 
@@ -1,18 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1 temp2-mkdir temp1 temp2-cd temp1-darcs init-touch foo-darcs add foo-darcs record -a -m add_foo -A x-darcs remove foo-darcs record -a -m del_foo -A x-cd ../temp2-darcs init-darcs pull --all ../temp1-cd ..-rm -rf temp1 temp2-
− tests/amend-cancelling.sh 
@@ -1,19 +0,0 @@-#!/usr/bin/env bash-set -ev--# This checks for a possible bug in patch selection where the no available-# patches case is hit.--rm -rf temp1-mkdir temp1-cd temp1-darcs init-touch A-darcs add A-darcs record -am A-echo 'l1' >> A-darcs record -am l1-darcs amend-record -a --patch 'A'--cd ..-rm -rf temp1
− tests/amend-record-back-up.sh 
@@ -1,39 +0,0 @@-#!/usr/bin/env bash-## Copyright (C) 2011 Ganesh Sittampalam <ganesh@earth.li>-##-## 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-## SOFTWARE.----. lib                           # Load some portability helpers.-darcs init      --repo amend--cd amend-echo 'file1' > file1-darcs record -lam 'file1'--echo 'file2' > file2-darcs record -lam 'file2'--echo 'file2:amended' > file2-echo 'nkya' | darcs amend-record--darcs changes -p 'file2' -v | grep amended
− tests/amend-record.sh 
@@ -1,78 +0,0 @@-#!/usr/bin/env bash--# Testing amend-record.--. lib--rm -rf temp1-# set up the repository-mkdir temp1-cd temp1-darcs init-cd ..--# do some work here-cd temp1-# Plain amend-record-touch foo-darcs add foo-darcs record -a -m add_foo-echo 'another line' > foo-echo y | darcs amend -a foo | grep -i 'amending changes'-darcs changes -v | grep 'another line'-# amend-record of removed file-touch bar1-touch bar2-cat > bar1 << FOO-a line-b line-FOO-darcs add bar1 bar2-darcs record -a -m add_bars-rm -f bar2-echo y | darcs amend -a | grep -i 'finished amending'-# Special case: patch is empty after amend-cp foo foo.old-echo 'another line' >> foo-darcs record -a -m add_line foo | grep -i 'finished recording'-mv foo.old foo-echo y | darcs amend -a foo | grep -i 'amending changes'-# Amend --author, -m, etc-echo "another line" >> foo-echo y | darcs amend -a -m new_name foo | grep -i 'amending changes'-darcs changes --last=1 | grep new_name-echo "another line" >> foo-echo y | darcs amend -a -m new_name -A new_author foo | grep -i 'amending changes'-darcs changes --last=1 | grep new_author--# check that normally the date changes when we amend-echo "another line" >> foo-darcs changes --last=1 | head -n 1 > old_date-sleep 1-echo y | darcs amend -a foo -A new_author | grep -i 'amending changes'-darcs changes --last=1 | head -n 1 > new_date-not cmp old_date new_date--# check that --keep-date works-echo "another line" >> foo-darcs changes --last=1 | head -n 1 > old_date-sleep 1-echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes'-darcs changes --last=1 | head -n 1 > new_date-cmp old_date new_date--cd ..--# check that the identity changes with --keep-date-darcs get temp1 temp2-cd temp2--echo "another line" >> foo-darcs changes --last=1 | head -n 1 > old_date-echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes'-darcs pull ../temp1 -a --skip-conflicts | grep -i "Skipping some"--cd ..---rm -rf temp1 temp2
− tests/amend-unrecord.sh 
@@ -1,57 +0,0 @@-#!/usr/bin/env bash-## Test for amend-record --unrecord-##-## Copyright (C) 2012  Ganesh Sittampalam-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-darcs init      --repo R        # Create our test repo.--cd R--(echo x ; echo y) > foo-darcs add foo-darcs rec -am "add foo"--(echo 1 ; echo x ; echo y ; echo 2) > foo-darcs rec -am "insert 1 and 2"--(echo yyn) | darcs amend-record --unrecord-(echo x ; echo y ; echo 2) > foo.expected-darcs show contents foo | diff -q foo.expected ---(echo yeny) | DARCS_EDITOR="sed -i -e s/2/2j/" darcs amend-record --unrecord-(echo x ; echo y ; echo 2j) > foo.expected-darcs show contents foo | diff -q foo.expected ---echo 'ugh' > bar-darcs add bar-# use amend to check it's still a short form for amend-record-# if we make amend-unrecord visible rather than hidden that would change-echo y | darcs amend -a-darcs show contents bar | diff -q bar ---# test that amend-unrecord alias exists, and --all and specifying files works-echo y | darcs amend-unrecord -a foo-(echo x ; echo y) > foo.expected-darcs show contents foo | diff -q foo.expected --darcs show contents bar | diff -q bar -
+ tests/amend.sh view
@@ -0,0 +1,145 @@+#!/usr/bin/env bash++# Testing amend++. lib++rm -rf temp1+# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++# do some work here+cd temp1+# Plain amend+touch foo+darcs add foo+darcs record -a -m add_foo+echo 'another line' > foo+echo y | darcs amend -a foo | grep -i 'amending changes'+darcs changes -v | grep 'another line'+# amend of removed file+touch bar1+touch bar2+cat > bar1 << FOO+a line+b line+FOO+darcs add bar1 bar2+darcs record -a -m add_bars+rm -f bar2+echo y | darcs amend -a | grep -i 'finished amending'+# Special case: patch is empty after amend+cp foo foo.old+echo 'another line' >> foo+darcs record -a -m add_line foo | grep -i 'finished recording'+mv foo.old foo+echo y | darcs amend -a foo | grep -i 'amending changes'+# Amend --author, -m, etc+echo "another line" >> foo+echo y | darcs amend -a -m new_name foo | grep -i 'amending changes'+darcs changes --last=1 | grep new_name+echo "another line" >> foo+echo y | darcs amend -a -m new_name -A new_author foo | grep -i 'amending changes'+darcs changes --last=1 | grep new_author++# check that normally the date changes when we amend+echo "another line" >> foo+darcs changes --last=1 | head -n 1 > old_date+echo y | darcs amend -a foo -A new_author | grep -i 'amending changes'+darcs changes --last=1 | head -n 1 > new_date+not cmp old_date new_date++# check that --keep-date works+echo "another line" >> foo+darcs changes --last=1 | head -n 3 | grep Date > old_date+sleep 1+echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes'+darcs changes --last=1 | head -n 3 | grep Date > new_date+cmp old_date new_date++cd ..++# check that the identity changes with --keep-date+darcs get temp1 temp2+cd temp2++echo "another line" >> foo+darcs changes --last=1 | head -n 1 > old_date+echo y | darcs amend -a foo -A new_author --keep-date | grep -i 'amending changes'+darcs pull ../temp1 -a --skip-conflicts | grep -i "Skipping some"++cd ..++rm -rf temp1 temp2+++# This checks for a possible bug in patch selection where the no available+# patches case is hit.++darcs init temp1+cd temp1+touch A+darcs record -lam A+echo 'l1' >> A+darcs record -am l1+darcs amend -a --patch 'A'++cd ..+rm -rf temp1++## Copyright (C) 2011 Ganesh Sittampalam <ganesh@earth.li>++darcs init temp1+cd temp1++echo 'file1' > file1+darcs record -lam 'file1'++echo 'file2' > file2+darcs record -lam 'file2'++echo 'file2:amended' > file2+echo 'nkya' | darcs amend++darcs log -p 'file2' -v | grep amended+cd ..+rm -rf temp1++## Test for amend --unrecord+## Copyright (C) 2012  Ganesh Sittampalam++darcs init temp1+cd temp1++echo -e "x\ny" > foo+darcs rec -lam "add foo"++echo -e "1\nx\ny\n2" > foo+darcs rec -am "insert 1 and 2"++echo yyny | darcs amend --unrecord+echo -e "x\ny\n2" > foo.expected+darcs show contents foo | diff -q foo.expected -++echo yenyy | DARCS_EDITOR="sed -i -e s/2/2j/" darcs amend --unrecord+echo -e "x\ny\n2j" > foo.expected+darcs show contents foo | diff -q foo.expected -++echo 'ugh' > bar+darcs add bar+# use amend to check it's still a short form for amend-record+# if we make amend-unrecord visible rather than hidden that would change+echo y | darcs amend -a+darcs show contents bar | diff -q bar -++# test that amend --unrecord --all and specifying files works+echo y | darcs amend --unrecord -a foo+echo -e "x\ny" > foo.expected+darcs show contents foo | diff -q foo.expected -+darcs show contents bar | diff -q bar -++cd ..+rm -rf temp1
tests/annotate.sh view
@@ -1,16 +1,64 @@ #!/usr/bin/env bash . lib -darcs init+rm -rf temp1+darcs init temp1+cd temp1 mkdir a b touch a/a b/b-darcs add --rec .-darcs record -a -m ab -A test+darcs record -lam ab darcs annotate a/a echo x > c-darcs add c-darcs record -a -m foo -A 'Mark Stosberg <a@b.com>'+darcs record -lam foo -A 'Mark Stosberg <a@b.com>' darcs annotate c darcs annotate c | grep "a@b.com" cd ..-rm -rf temp++# issue1473 annotate repodir+rm -rf temp1+mkdir temp1+cd temp1+darcs init+mkdir a b+touch a/a b/b+darcs add --rec .+darcs record -a -m ab -A test+darcs annotate a/a+darcs annotate . > inner+# annotate --repodir=something '.' should work+cd ..+darcs annotate --repodir temp1 '.' > temp1/outer+cd temp1+diff inner outer++cd ..++# issue2207 : annotate on directories+rm -rf temp1+darcs init temp1+cd temp1+mkdir d+touch d/f+darcs record -lam 'p1'+darcs annotate d | grep 'p1'+cd ..++# issue1473 - check that annotate works with and without+# repodir and with "." argument.  It should fail with the empty string as+# a single argument and without any arguments.++rm -rf temp1+darcs init temp1+cd temp1+echo 'Example content.' > f+darcs record -lam 'Added f.'+darcs annotate .+darcs annotate f+not darcs annotate+not darcs annotate ''++cd ..+darcs annotate --repodir=temp1 .+darcs annotate --repodir=temp1 f+not darcs annotate --repodir=temp1+not darcs annotate --repodir=temp1 ''
− tests/apply-hunks.sh 
@@ -1,63 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp0 temp1 temp2--# step 1-mkdir temp0-cd temp0-darcs init --darcs-2-echo m1 > foo-darcs add foo-darcs record -a -m m1 -A moi --ignore-times-cd ..--# step 2-darcs get temp0 temp1-cd temp1-echo a1 > foo-darcs record foo -a -m a1 -A moi --ignore-times-cd ..---# step 3-cd temp0-echo m2 > foo-darcs record -a -m m2 -A moi --ignore-times-cd ..---# step 4-cd temp1-darcs pull -a-echo m2-a1 > foo-darcs record -a -m 'Fix conflict m2-a1' -A moi --ignore-times-cd ..--#step 5-cd temp0-echo m3 > foo-darcs record -a -m m3 -A moi --ignore-times-cd ..--#step 6-darcs get temp0 temp2-cd temp2-echo b1 > foo-darcs record -a -m b1 -A moi --ignore-times-cd ..--#step 7-cd temp0-echo m4 > foo-darcs record -a -m m4 -A moi --ignore-times-cd ..--#step 8-cd temp1-darcs pull -a-echo m2-a1-m4 > foo-echo y | darcs mark-conflicts-cd ..--rm -rf temp0 temp1 temp2
+ tests/apply-reorder.sh view
@@ -0,0 +1,64 @@+#!/usr/bin/env bash++## Test that apply --reorder moves to the top the uncommon set of patches between+## the current repository and the set of patches we are applying.++. lib                  # Load some portability helpers.++check_patches_order () {+    darcs log | tr -d "\n" | grep $1.*$2.*$3+}++test_init () {+    rm -rf R1 R2+    +    darcs init "R1"+    cd R1++    touch "r1_0"+    darcs record -lam "Adding r1_0"++    cd ..++    darcs clone "R1" "R2"++    cd R2++    touch "r2_0"+    darcs record -lam "Adding r2_0"+    darcs send --no-minimize -a --no-edit-description -o ../R1/P ++    cd ..++    cd R1++    touch "r1_1"+    darcs record -lam "Adding r1_1"+    +    cd ..+}+++test_init++cd R1++darcs apply P+# Without reorder the expected order is r2_0, r1_1, r1_0 .+check_patches_order r2_0 r1_1 r1_0++# Test that apply --reorder reorders even if there is nothing to apply.+darcs apply --reorder P+check_patches_order r1_1 r2_0 r1_0++cd ..++test_init++cd R1++darcs apply --reorder P+# With reorder the expected order is r1_1, r2_0, r1_0 .+check_patches_order r1_1 r2_0 r1_0++cd ..
+ tests/apply-unclean-tag.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash++## Test that darcs can apply a patch bundle where the tag in the+## context of the bundle is unclean in the current repository.++. lib++rm -rf R S T++darcs init R+cd R+# so that we have something to tag, a tag of an empty repo+# seems to be ignored+echo 'initial content' > initial+darcs rec -lam "initial content"+darcs tag initial++echo A > A+darcs rec -lam "change A"+echo B > B+darcs rec -lam "change B"++cd ..++darcs init S+cd S+# pull the tag + A, but not B+darcs pull ../R -a --tag=initial+darcs pull ../R -a -p 'change A'++cd ../R+# create b.dpatch+darcs send -a -O --no-edit-description ../S++cd ..+mkdir T+cd T+darcs init+# pull the first patch + A, but not the tag or B+darcs pull ../R -a -p 'initial content'+darcs pull ../R -a -p 'change A'+# pull the tag, so now it's unclean+darcs pull ../R -a --tag 'initial'++darcs apply ../R/change-b.dpatch
+ tests/apply.sh view
@@ -0,0 +1,236 @@+#!/usr/bin/env bash+##+## Copyright (C) 2010 Eric Kow+## Copyright (C) 2012 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+## SOFTWARE.++. lib                           # Load some portability helpers.++# issue1427: apply gzipped bundles++rm -rf temp1 temp2+darcs init temp1+darcs init temp2++cd temp1+touch foo bar+darcs record -lam add_foo_bar+darcs mv foo zig+darcs mv bar foo+darcs mv zig bar+darcs record -lam swap_foo_bar+darcs send --output=funpatch --dont-sign -a ../temp2++gzip funpatch++cd ../temp2+darcs apply ../temp1/funpatch.gz+cd ..+cmp temp1/bar temp2/bar++rm -rf temp2+darcs init temp2+cd temp2+darcs apply ../temp1/funpatch.gz+## Also test that "darcs apply" can accept a patch on stdin.+darcs obl -a+darcs apply < ../temp1/funpatch.gz+cd ..+cmp temp1/bar temp2/bar++## issue2017 - apply should gracefully handle tag missing+## from context (complain, not crash)++rm -rf R* S* T*+darcs init R+cd R+echo 'Example content.' > f+darcs record -lam 'Add f'+cd ..++# variant 0 - this passes trivially+darcs clone R R0+darcs clone R0 S0+darcs tag 's' --repo S0+darcs clone S0 T0+cd T0+echo 'More content.' > f+darcs record -lam 'Modify f'+darcs send -o foo.dpatch -a+cd ..+not darcs apply --repo R0 T0/foo.dpatch > log 2>&1+not grep bug log+grep "Cannot find tag" log++# variant 1 - tag in shared context+darcs clone R R1+darcs tag '1' --repo R1+darcs clone R1 S1+darcs tag 's1' --repo S1+darcs clone S1 T1+cd T1+echo 'More content.' > f+darcs record -lam 'Modify f'+darcs send -o foo.dpatch -a+cd ..+# sanity check: should be able to cherry pick+darcs clone R1 R1b+cd R1b+[ `darcs log --count` -eq 2 ]+darcs pull ../T1 --match 'touch f' --all+[ `darcs log --count` -eq 3 ]+cd ..+# the test: can't apply this due to incorrect context+not darcs apply --repo R1 T1/foo.dpatch > log 2>&1+not grep 'bug' log+grep "Cannot find tag" log++# variant 2 - tag created after the fact+darcs clone R  R2+darcs clone R2 S2+darcs tag 's2' --repo S2+darcs clone S2 T2+cd T2+echo 'More content.' > f+darcs record -lam 'Modify f'+darcs send -o foo.dpatch -a+cd ..+darcs tag '2'  --repo R2  # only tag after+not darcs apply --repo R2 T2/foo.dpatch > log 2>&1+not grep 'bug' log+grep "Cannot find tag" log++# issue1921+# Attempting to apply a patch which depends on a missing tag should not cause+# darcs to die.++rm -rf R* S* T*+darcs init R+cd R++# Setup a repo with a tagged patch, and another patch ontop, so we have a split+# inventory+touch file1+darcs rec -alm 'Add file1'+darcs tag -m 'file1 tag'+touch file2+darcs rec -alm 'Add file2'++# Take a copy of the repo at this point+darcs clone . ../S++# Add the tag which we will fail on+darcs tag -m 'file2 tag'++# Take a copy with the tag+darcs clone . ../T++# Add our patch which will depend only on the last tag.+echo 'file1' > file1+darcs rec -am 'file1 content'++# Create a patch bundle with the new patch (by sending against the repo we+# copied, with the last tag)+darcs send ../T -a -o ../patch.dpatch --no-edit-description++cd ../S++# Try to apply to the patch which depends on the missing tag (we expect darcs+# to fail gracefully here)+not darcs apply ../patch.dpatch &> apply_output.txt++# A best-attempt at ensuring darcs warns about the missing tag:+grep "Cannot find tag file2" apply_output.txt+cd ..+rm -rf R S++## issue1873 - apply should complain about the right+## patches if it says some are missing++rm -rf R S+darcs init R+cd R+echo a > a+darcs rec -lam a+echo b > a+darcs rec -lam b+echo x > x+darcs rec -lam x+echo c > a+darcs rec -lam c+echo y > y+darcs rec -lam y+echo d > a+darcs rec -lam d+cd ..++darcs clone R S+darcs unpull -p x -a --repo R+darcs send   --no-minimize -p x -a --repo S -o R/x.dpatch+darcs unpull -p y -a --repo R+not darcs apply --repo R R/x.dpatch 2>&1 | tee log++not grep '^  \* d' log # does not complain about an unrelated patch+    grep '^  \* y' log # complains about the offending one instead++## Test that apply --skip-conflicts filters the conflicts+## appropriately.++rm -rf R S+darcs init R+cd R+echo 'foo' > foo+echo 'bar' > bar+darcs rec -lam 'Add foo and bar'+darcs clone . ../S+echo 'foo2' > foo+darcs rec -lam 'Change foo (2)'+echo 'bar2' > bar+darcs rec -lam 'Change bar (2)'+cd ../S+echo 'foo3' > foo+darcs rec -lam 'Change foo (3)'+cd ../R+darcs send -a ../S -o ../S/applyme.dpatch+cd ../S+darcs apply --skip-conflicts applyme.dpatch+test `darcs log --count` -eq 3+cd ..++# issue2193 - "darcs apply --test runs the test twice.++rm -rf R S+darcs init R+darcs clone R S++# Create a patch bundle+cd R+echo 'Example content.' >file1+darcs rec -lam patch1+darcs send --dont-edit-description --output=./patch1 -a ../S++# Setup a test that prints a unique string, apply the patch set,+# check that the unique string occurs in the output once.+cd ../S+darcs setpref test 'echo 2a427e65f322be754dce67c829e5f8a3'+darcs apply --test ../R/patch1 > log 2>&1+[ `fgrep -c 2a427e65f322be754dce67c829e5f8a3 log` -eq 1 ]
+ tests/argument_parsing.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash++## test that we cleanly fail with malformed numbers+## and ranges for --max-count, --last, and --index++. ./lib++check_arg_parse_error() {+  not darcs log $1 2>LOG 1>&2+  not grep -i bug LOG+  grep -i "cannot parse" LOG+}++darcs init R+cd R+check_arg_parse_error --max-count=-1+check_arg_parse_error --max-count=x+check_arg_parse_error --last=-1+check_arg_parse_error --last=x+# note zero is not a valid index+check_arg_parse_error --index=-1+check_arg_parse_error --index=0+check_arg_parse_error --index=x+check_arg_parse_error --index=-1-2+check_arg_parse_error --index=1--2+check_arg_parse_error --index=0-1+check_arg_parse_error --index=1-0+check_arg_parse_error --index=x-y+# but indexes and counts may exceed number of patches+darcs log --max-count=1+darcs log --last=1+darcs log --index=1+darcs log --index=1-2+cd ..
tests/ask_deps.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp mkdir temp@@ -8,7 +8,6 @@ darcs init cat > _darcs/prefs/defaults <<. ALL author test-ALL ignore-times ALL ask-deps . @@ -18,13 +17,13 @@ touch a darcs add a echo q | darcs rec -am a0-darcs ann -p a0+darcs log -p a0 -v --machine | cat echo 1 > a echo q | darcs rec -am a1-darcs ann -p a1+darcs log -p a1 -v --machine | cat echo 2 > a echo q | darcs rec -am a2-darcs ann -p a2+darcs log -p a2 -v --machine | cat  # add some patches for file 'b' # expect no dependency questions for file 'b',@@ -35,20 +34,22 @@ touch b darcs add b # test 0-echo n/n/n/q | tr / \\012 | darcs rec -am b0-darcs ann -p b0+echo nnnY | tr '[A-Z]' '[a-z]' | darcs rec -am b0+darcs log -p b0 -v --machine | cat # test 1 echo 1 > b-echo n/n/y/q | tr / \\012 | darcs rec -am b1-darcs ann -p b1 | grep '^\[a0'+echo nnyY | tr '[A-Z]' '[a-z]' | darcs rec -am b1+darcs log -p b1 -v --machine | cat+darcs log -p b1 -v --machine | grep '\[a0' # test 2 echo 2 > b-echo n/y/q | tr / \\012 | darcs rec -am b2-darcs ann -p b2 | grep '^\[a1'+echo nyY | tr '[A-Z]' '[a-z]' | darcs rec -am b2+darcs log -p b2 -v --machine | grep '\[a1' # test 3 echo 3 > b-echo y/q | tr / \\012 | darcs rec -am b3-darcs ann -p b3 | grep '^\[a2'+echo yY | tr '[A-Z]' '[a-z]' | darcs rec -am b3+darcs log -p b3 -v --machine | cat+darcs log -p b3 -v --machine | grep '\[a2'  cd .. rm -rf temp
tests/bad-format.sh view
@@ -4,7 +4,7 @@  rm -rf temp1 temp2 -gunzip -c  $TESTDATA/many-files--old-fashioned-inventory.tgz | tar xf -+unpack_testdata many-files--old-fashioned-inventory mv many-files--old-fashioned-inventory temp1  echo '<UGLY HTML-LIKE GARBAGE RETURNED BY BAD HTTP SERVER>' > temp1/_darcs/format@@ -20,12 +20,10 @@  cat temp2/_darcs/format -rm -rf temp1+rm -rf temp3 -not darcs get temp2 temp1 2> err+not darcs get temp2 temp3 2> err  cat err grep intentional-error err-grep 'understand repository format' err--rm -rf temp1 temp2+grep -i "read repository.*unknown format" err
− tests/bad-match-pattern.sh 
@@ -1,38 +0,0 @@-#!/usr/bin/env bash--# This is a test for issue761, which pointed out that we didn't check the-# syntax of --match patterns until after having spent considerable time-# doing considerable work.  So here we construct a very invalid repository,-# and check that darcs fails *before* it notices that it's pulling from a-# bad repository.  Thus we verify that we aren't doing any work prior to-# checking the flags.--set -ev--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-touch foo bar-darcs add foo bar-darcs record -a -m 'add two files'-darcs tag -m tag-rm foo bar-darcs record -a -m 'rm two files'-darcs tag -m tag2--rm -rf _darcs/inventories/*-rm -rf _darcs/patches/*--cd ..--mkdir temp2-cd temp2-darcs init-! darcs pull --match 'foobar' ../temp1 2> error-cat error--grep foobar error--rm -rf temp1 temp2-
− tests/bad_pending_after_pull.sh 
@@ -1,51 +0,0 @@-#!/usr/bin/env bash--set -ev--rm -fr temp1 temp2--mkdir temp1-cd temp1-darcs init--echo abc > A-darcs add A-echo def > B1-darcs add B1-# darcs record -all --name patch1 # this way it doesn't trigger the bug-for i in 1 2 3 4 5 6 7 8 9 11; do echo y; done | darcs record --name patch1--darcs mv B1 B2-darcs record --all --name patch2-cd ..--mkdir temp2-cd temp2-darcs init-darcs pull --all ../temp1-darcs whatsnew | grep 'No changes'-cd ..--rm -fr temp1 temp2--# issue494: note that in this test, we deliberately select filenames-# with a backwards sorting order-mkdir temp1-cd temp1-darcs init-echo abc > b-darcs add b-darcs record --all -m patch1-darcs mv b a-echo def > a-darcs record --all -m patch2-cd ..--mkdir temp2-cd temp2-darcs init-darcs pull --all ../temp1-darcs whatsnew | grep 'No changes'-cd ..--rm -fr temp1 temp2
+ tests/bin/renameHelper.hs view
@@ -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 <check>"+    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) -> d</>s++-- 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
+ tests/bin/sendmail.hs view
@@ -0,0 +1,16 @@+import System.Environment++main = do+  args <- getArgs+  let filename = args !! 5+  input <- getContents+  filecontent <- readFile filename+  writeFile "saved.out" $+    unlines $+    [ "arg["++show i++"] = "++v | (i,v) <- zip [1..] args ]+    +++    [ "input contains:"+    , input+    , filename++" contains:"+    , filecontent+    ]
tests/bin/trackdown-bisect-helper.hs view
@@ -1,7 +1,7 @@ {- -Tool for construction of testing repository for trackdown testing-with bisect option. Written by Matthias Fischmann.+Tool for construction of testing repository for test --bisect.+Written by Matthias Fischmann.  Usage: @@ -24,9 +24,8 @@  stamp i j = system ("echo " ++ show i ++ " > ./i") >>             system ("echo " ++ show j ++ " > ./j") >>-            -- system ("sleep 1") >>             hFlush stdout >>-            system ("darcs record --ignore-times -am '" ++ show i ++ "'")+            system ("darcs record -am '" ++ show i ++ "'")  generate :: [Int] -> IO () generate = mapM_ (uncurry stamp) . zip [1..]
tests/binary.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ve+. ./lib binary=example_binary.png function checkbinary(){   cmp $binary ../temp1/$binary
+ tests/boring-files.sh view
@@ -0,0 +1,35 @@+#!/usr/bin/env bash++#######+## Check that _darcs/ptefs/boring file is ALWAYS used+#+rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch test.txt++echo > _darcs/prefs/boring+darcs wh -l | grep test.txt # Empty boring file - new file is reported.++echo test.txt > _darcs/prefs/boring+darcs wh -l | grep -v test.txt # Pattern in the repository private boring file is used.++touch .boring+darcs setpref boringfile .boring+darcs record -am"setpref boringfile"+darcs wh -l | grep -v test.txt # Pattern in the repository private boring file is used+                               # despite the fact that there is an explicitly defined+                               # boringfile.++echo > _darcs/prefs/boring+echo test.txt > .boring+darcs wh -l | grep -v test.txt # Explicitly defined boringfile is used++echo > _darcs/prefs/boring+echo > .boring+darcs wh -l | grep test.txt # Both explicitly defined boringfile and repository private+                            # boring file are empty and do not mask new file.+++rm -rf temp1
+ tests/broken_move.sh view
@@ -0,0 +1,117 @@+#!/usr/bin/env bash+# This tests that even if broken move patches (caused by issue2674)+# are present in a repo, we can safely eliminate them because no further+# patches can depend on the target of the move. In fact, applying such a+# bad move is a no-op.++. lib++# We could create three different archives for darcs-1, darcs-2, and darcs-3+# but since this problem concerns only the Prim.V1 layer this seems excessive.+only-format darcs-2++# Script to create the test repo. It is no longer used now that issue2674 has+# been fixed and we use the tar ball. Its only remaining purpose is to+# document what patches the broken_move repository consists of.+cat >create_broken_moves.sh <<EOF+  #!/usr/bin/env bash+  . lib++  rm -rf broken_move+  darcs init broken_move+  cd broken_move++  mkdir d1+  darcs record -l d1 -am 'add d1'++  touch f1 f2+  echo text > f1+  darcs move f1 f2 d1+  darcs record -am 'bad first move'++  # this commutes with the two bad moves+  darcs move d1 d2+  darcs record -am 'move d1 to d2'++  darcs move d2/f1 d2/f2 .+  darcs record -am 'bad second move'++  mkdir d3 d4+  darcs move d3 d4 d2+  darcs record -am 'bad third move'++  cd ..++  tar zcf broken_move.tgz broken_move+EOF++chmod +x create_broken_moves.sh++# if create_broken_moves.sh fails, then issue2674 has been fixed,+# so instead we unpack the repo from an archive instead+if ! ./create_broken_moves.sh; then+  unpack_testdata broken_move+fi++cd broken_move++# test that commutes either work or we can repair+echo y | darcs amend -a -p 'move d1 to d2' -m 'edited move d1 to d2'+if ! (echo y | darcs amend -a -p 'bad second move' -m 'edited bad second move' 2> LOG); then+  grep -i "Cannot apply" LOG+  # but then we should be able to repair it+  not darcs check | grep 'Dropping move patch with non-existing source'+  rm -rf ../repaired+  darcs clone . ../repaired+  darcs repair --repodir=../repaired+fi+darcs obliterate -a -p 'move d1 to d2'+if ! (darcs obliterate -a -p 'bad second move' 2>LOG); then+  grep -i "Cannot apply" LOG+  # but then we should be able to repair it+  not darcs check | grep 'Dropping move patch with non-existing source'+  rm -rf ../repaired+  darcs clone . ../repaired+  darcs repair --repodir=../repaired+fi+# test that unapplying patches either works or we can repair the repo+rm -rf ../S+if ! (darcs clone . ../S --to-patch 'add d1' 2>LOG); then+  grep -i "Cannot apply" LOG+  # but then we should be able to repair it+  not darcs check | grep 'Dropping move patch with non-existing source'+  rm -rf ../repaired+  darcs clone . ../repaired+  darcs repair --repodir=../repaired+fi++# test that we cannot record a change that depends on the target path+# nor the source path (because both are unadded)+echo text > f1+not darcs record f1 -am impossible+echo text > d1/f1+not darcs record d1/f1 -am impossible++# same with a bad move of a directory+touch d1/d3/f+# this will ask us to add d1/d3, too, so we have to say no first+echo ny | darcs record -l d1/d3/f -m impossible >LOG+grep "you don't want to record anything" LOG++cd ..++# make a clone to get a fresh working tree equal to the pristine tree+rm -rf R+darcs clone broken_move R+cd R++# check that only d1 exists in pristine, i.e. the bad moves are ignored+cat <<EOF > log.expected+.+./d1+EOF+# the tr hack is to make the test work on Windows+darcs show files | tr -d $'\r' > log+diff log.expected log >&2++cd ..
+ tests/broken_pending.sh view
@@ -0,0 +1,73 @@+#!/usr/bin/env bash++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init++date > date.t+date > date_moved.t++write_buggy_pending () {+cat > _darcs/patches/pending <<EOF+{+addfile ./date.t+addfile ./date.t+addfile ./date_moved.t+move ./date.t ./date_moved.t+}+EOF+}++write_buggy_pending++# darcs log should be unaffected by pending, even with -v+darcs log -v >/dev/null++write_buggy_pending++# darcs check should detect a broken pending+not darcs check 2>&1 | tee out+grep -i 'broken pending' out++write_buggy_pending++# darcs whatsnew should fail+not darcs whatsnew 2>&1 | tee out+grep -i 'cannot apply pending' out+# and issue a recommendation about repair+grep -i 'darcs repair' out++# darcs revert should fail+not darcs revert -a 2>&1 | tee out+grep -i 'cannot apply pending' out+# and issue a recommendation about repair+grep -i 'darcs repair' out++# darcs revert should fail+not darcs record -a -m foo 2>&1 | tee out+grep -i 'cannot apply pending' out+# and issue a recommendation about repair+grep -i 'darcs repair' out++write_buggy_pending++# we should be able to successfully repair pending+darcs repair -v 2>&1 | tee out+grep -i 'repaired pending' out++darcs whatsnew+darcs check++write_buggy_pending++# final repair, quiet+darcs repair -q 2>&1 | not grep .++darcs check+darcs record -a -m foo+darcs check++cd ..
− tests/changes.sh 
@@ -1,71 +0,0 @@-#!/usr/bin/env bash-set -ev--# Some tests for 'darcs changes'--rm -rf temp1-mkdir temp1-cd temp1-darcs init--date >> date.t-darcs add date.t--darcs record -A 'Mark Stosberg <a@b.com>' -a -m foo date.t--####--darcs changes date.t > out # trivial case first-cat out-grep foo out--darcs changes --last=1 date.t > out-cat out-grep foo out--darcs changes --last 1 --summary date.t > out-cat out-grep foo out--darcs changes --last=1 --xml > out-cat out-grep '&lt;a@b.com&gt;' out # check that --xml encodes < and >--###--# Add 6 records and try again-for i in 0 1 2 3 4 5; do-    date >> date.t-    darcs record -a -m "foo record num $i" date.t-done--darcs changes date.t > out-cat out-grep foo out--darcs changes --last=1 date.t > out-cat out-grep foo out--darcs changes --last 1 --summary date.t > out-cat out-grep foo out--###--darcs changes --context --from-patch='num 1' --to-patch 'num 4' > out-cat out-grep 'num 4' out-grep 'num 3' out-grep 'num 2' out-grep 'num 1' out--###--date >> second_file.t-darcs add second_file.t--darcs record -a -m adding_second_file second_file.t--cd ..-rm -rf temp1
− tests/changes_send_context.sh 
@@ -1,18 +0,0 @@-#!/usr/bin/env bash-set -ev--# RT#544 using context created with 8-bit chars;-rm -rf temp1--mkdir temp1--cd temp1-darcs init-touch foo-darcs record -la -m 'add\212 foo' | grep 'Finished record'-darcs changes --context >context-date > foo-darcs record -a -m 'date foo' | grep 'Finished record'-darcs send -a -o patch --context context . | grep 'Wrote patch to'-cd ..-rm -rf temp1
− tests/changes_with_move.sh 
@@ -1,34 +0,0 @@-#!/usr/bin/env bash--# Some tests for the output of changes when combined with move.--. lib--darcs init-date > foo-darcs add foo-darcs record -m 'add foo' -a-mkdir d-darcs add d-darcs record -m 'add d' -a-darcs mv foo d-darcs record -m 'mv foo to d' -a-darcs mv d directory-darcs record -m 'mv d to directory' -a-echo 'How beauteous mankind is' > directory/foo-darcs record -m 'modify directory/foo' -a-darcs changes directory/foo > log-grep 'add foo' log-grep 'mv foo to d' log-echo 'O brave new world' > directory/foo-# darcs should also take unrecorded moves into account-darcs mv directory/foo directory/bar-darcs changes directory/foo > log-grep 'mv foo to d' log-echo 'That has such people in it' > directory/foo-darcs add directory/foo-darcs record -m 'mv foo then add new foo' -a-darcs annotate directory/bar | tee log-grep 'O brave new world' log-grep "mv foo then add new foo" log-not grep "unknown" log
− tests/check-read-only.sh 
@@ -1,38 +0,0 @@-#!/usr/bin/env bash-## Test for issue2001: check is not read-only -##-## Copyright (C) 2011 Florent Becker-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.--cd R-mkdir d e                       # Change the working tree.-echo 'Example content.' > d/f-darcs record -lam 'Add d/f and e.'-darcs mv d/f e/-darcs record -am 'Move d/f to e/f.'-rm _darcs/pristine.hashed/*     # Make the repository bogus-cp -r _darcs archive-not darcs check-diff -r _darcs archive
− tests/check.sh 
@@ -1,42 +0,0 @@-#!/usr/bin/env bash-## Ensure that "darcs check --test" succeeds when run in a complete-## repository with a dummy test that always succeeds.-##-## Copyright (C) 2008  David Roundy-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R-darcs setpref   --repo R test 'grep hello f'-not darcs record    --repo R -am 'true test' --test-darcs record    --repo R -am 'true test' --no-test--touch R/f-darcs record    --repo R -lam 'added foo' --no-test-darcs tag       --repo R -m 'got f?'--echo hello > R/f-darcs record    --repo R -lam 'hellofoo' --test-darcs chec      --repo R --test--rm -rf R                        # Clean up after ourselves.
+ tests/clean-command.sh view
@@ -0,0 +1,66 @@+#!/usr/bin/env bash+# Tests for the clean / revert -l command++. lib++rm -rf R+darcs init R+cd R++create_stuff () {+  rm -rf unadded unadded-dir unadded-dir-with-boring boring.o CVS++  # non-boring stuff+  echo content > unadded+  mkdir unadded-dir+  echo content > unadded-dir/unadded+  mkdir unadded-dir-with-boring+  echo content > unadded-dir-with-boring/unadded++  # boring stuff+  echo content > boring.o+  mkdir CVS+  echo content > CVS/also-considered-boring+  echo content > CVS/boring.o+  echo content > unadded-dir-with-boring/boring.o+}++test_nonboring () {+  # test that non-boring stuff is gone+  not ls unadded+  not ls unadded-dir+  not ls unadded-dir-with-boring/unadded+  # non-boring file under boring dir is still considered non-boring+  not ls CVS/unadded++  # test that boring stuff is unchanged+  diff unadded-dir-with-boring/boring.o <(echo content)+  diff boring.o <(echo content)+  diff CVS/boring.o <(echo content)+}++test_boring () {+  not ls unadded+  not ls unadded-dir+  not ls unadded-dir-with-boring+  not ls boring.o+  not ls CVS+}++create_stuff+darcs clean -a+test_nonboring++create_stuff+darcs revert -l -a+test_nonboring++create_stuff+darcs clean --boring -a+test_boring++create_stuff+# error: conflicting options+not darcs revert -l --boring -a++cd ..
+ tests/clone.sh view
@@ -0,0 +1,200 @@+#!/usr/bin/env bash++. lib++rm -rf temp1 temp2+darcs init temp1+cd temp1+touch t.t+darcs record -lam "initial add"+darcs log --context > my_context+DIR=`pwd`+abs_to_context="${DIR}/my_context"+cd ..++darcs clone temp1 --context="${abs_to_context}" temp2+darcs log --context --repo temp2 > repo2_context+diff -u "${abs_to_context}" repo2_context++# trailing slash in the target dir should not change the result+rm -rf temp2+darcs clone temp1 --context="${abs_to_context}" temp2/+darcs log --context --repo temp2 > repo2_context+diff -u "${abs_to_context}" repo2_context++# clone should fail if the target dir already exists+rm -rf temp2+mkdir temp2+not darcs clone temp1 temp2+not ls temp2/* temp2/.[^.]*++# same, with target dir containing a trailing slash+rm -rf temp2+mkdir temp2+not darcs clone temp1 temp2/+not ls temp2/* temp2/.[^.]*++# issue1865: cover interaction of clone --context with tags++rm -rf temp1 temp2+darcs init temp1+cd temp1+touch t.t+darcs record -lam "initial add"+darcs tag -m tt+echo x > x+darcs rec -lam "x"+darcs log --context > my_context+abs_to_context="$(pwd)/my_context"+cd ..++darcs clone temp1 --context="${abs_to_context}" temp2+darcs log --context --repo temp2 > repo2_context+diff -u "${abs_to_context}" repo2_context++# issue1041++rm -rf temp1 temp2+# should fail, since temp1 doesn't exist+not darcs clone temp1 temp2+# verify that temp2 wasn't created+not cd temp2++# issue2199 "darcs clone --tag" gets too much if tag is dirty++rm -rf temp1 temp2 temp3+darcs init temp1+cd temp1+echo 'wibble' > file+darcs rec -lam 'wibble'+echo 'wobble' > file+darcs rec -lam 'wobble'+cd ..++darcs clone temp1 temp2++cd temp2+darcs unpull --patch 'wobble' -a+darcs tag 'wibble'+cd ..++cd temp1+darcs pull ../temp2 -a+cd ..++darcs clone --tag wibble temp1 temp3+cd temp3+darcs log | not grep wobble+cd ..++# issue885: darcs clone --to-match++rm -rf temp1 temp2 temp3+darcs init temp1+cd temp1+echo first > a+darcs record -lam 'first'+firsthash=`darcs log --xml | grep 'hash=' | sed -e "s/.*hash='//" -e "s/'>//"`+echo second > b+darcs record -lam 'second'+cd ..++darcs clone --to-match "hash $firsthash" temp1 temp2+test $(darcs log --count --repodir temp2) -eq 1++darcs clone --to-hash $firsthash temp1 temp3+test $(darcs log --count --repodir temp3) -eq 1++# various tests for clone --tag++rm -rf temp1 temp2+darcs init temp1+cd temp1+echo A > foo+darcs record -lam AA+echo B > foo+darcs record -am BB+echo C > foo+darcs record -am CC+darcs tag -m 1.0+cp foo foo_version_1.0+echo D > foo+darcs record -am DD+echo E > foo+darcs record -am EE+echo F > foo+darcs record -am FF+cd ..++darcs clone --tag 1.0 --repo-name temp2 temp1+cmp temp2/foo temp1/foo_version_1.0++# clone --tag with commuted patches++rm -rf temp1 temp2 temp3+darcs init temp1+cd temp1+cat > file <<EOF+1+2+3+4+EOF+darcs rec -alm 'Add file'+cat > file <<EOF+2+3+4+EOF+darcs rec -alm 'Remove line 1'+cat > file <<EOF+2+4+EOF+darcs rec -alm 'Remove line 3'+cd ..++darcs init temp2+cd temp2+echo ynyy | darcs pull ../temp1+darcs tag -m Tag+darcs push -a ../temp1+cd ..++darcs clone --tag=Tag temp1 temp3+cd temp3+darcs check+cd ..++# clone --tag : check that pending looks ok++rm -rf temp1 temp2+darcs init temp1+cd temp1+mkdir d+darcs rec -lam 'add d'+darcs tag t+rmdir d+darcs rec -am 'rm d'+cd ..++darcs clone --tag t temp1 temp2+cd temp2+if [ -f _darcs/patches/pending ]; then+	if grep -v '^[{}]$' _darcs/patches/pending >/dev/null; then+		cat _darcs/patches/pending+		exit 1+	fi+fi+cd ..++# issue2230 - darcs clone --context checks the validity of the context+# file too late.++rm -rf temp1 temp2+darcs init temp1+touch fake_context.txt+not darcs clone --context fake_context.txt temp1 temp2++# The clone should fail, so we shouldn't have an temp2 repo+[[ ! -e temp2 ]]
+ tests/conflict-chain-resolution.sh view
@@ -0,0 +1,165 @@+#!/usr/bin/env bash++# Test of conflict resolution for a "chain" of conflicts+# i.e. where (only) the adjacent patches conflict.++. lib++# Note that this test fails for darcs-2 format.+skip-formats darcs-2++# Establish our baseline:++rm -rf C+darcs init C+cd C+cat <<EOF > f+a+b+c+d+e+f+EOF+darcs record -lam "base"+cd ..++# Record hunk patches p1..p5 in separate repos,+# such that (only) adjacent patches conflict++rm -rf R1+darcs clone -q C R1+cd R1+sed -i -e 's/[ab]/&1/' f+darcs record -am 'p1'+cd ..++rm -rf R2+darcs clone -q C R2+cd R2+sed -i -e 's/[bc]/&2/' f+darcs record -am 'p2'+cd ..++rm -rf R3+darcs clone -q C R3+cd R3+sed -i -e 's/[cd]/&3/' f+darcs record -am 'p3'+cd ..++rm -rf R4+darcs clone -q C R4+cd R4+sed -i -e 's/[de]/&4/' f+darcs record -am 'p4'+cd ..++rm -rf R5+darcs clone -q C R5+cd R5+sed -i -e 's/[ef]/&5/' f+darcs record -am 'p5'+cd ..++# Pull them all into the common context++cd C+darcs pull -a ../R*++# For darcs-3 patches we do not merge non-conflicting+# alternatives.++cat <<EOF > f.darcs-3+v v v v v v v+a+b+c+d+e+f+=============+a+b+c+d+e5+f5+*************+a+b+c+d4+e4+f+*************+a+b+c3+d3+e+f+*************+a+b2+c2+d+e+f+*************+a1+b1+c+d+e+f+^ ^ ^ ^ ^ ^ ^+EOF++# The maximal non-conflicting subsets are:+#  {p1, p3, p5}, {p1, p4}, {p2, p4} {p2, p5}+# They are what darcs displays as alternatives to the baseline+# for darcs-1 patches.++cat <<EOF > f.darcs-1+v v v v v v v+a+b+c+d+e+f+=============+a+b2+c2+d+e5+f5+*************+a+b2+c2+d4+e4+f+*************+a1+b1+c+d4+e4+f+*************+a1+b1+c3+d3+e5+f5+^ ^ ^ ^ ^ ^ ^+EOF++diff f f.$format >&2++cd ..
+ tests/conflict-depends-resolution.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash++# The simplest example of a conflict with dependencies:+# we merge A;B with C, where B depends on A, and C conflicts with A+# and thus also with B. The conflict resolution should not show A+# explicitly as an alternative, but merely show A;B versus C.++. lib++rm -rf base AB C++darcs init base+cd base+touch f+darcs record -lam base+cd ..++darcs clone base AB+cd AB+echo A > f+darcs record -am A+echo B > f+darcs record -am B+cd ..++darcs clone base C+cd C+echo C > f+darcs record -lam C+darcs pull --mark-conflicts -a ../AB+cd ..++cd AB+darcs pull --mark-conflicts -a ../C+cd ..++cat <<EOF > f.expected+v v v v v v v+=============+B+*************+C+^ ^ ^ ^ ^ ^ ^+EOF+diff C/f f.expected >&2+diff AB/f f.expected >&2
tests/conflict-doppleganger.sh view
@@ -10,9 +10,9 @@ check_conflict() { cat out if test "$format" = darcs-2; then-    not grep 'conflict' out+    not grep 'conflicts' out else-    grep 'conflict' out+    grep 'conflicts' out fi } @@ -24,7 +24,7 @@  touch a.txt darcs add a.txt-darcs record -A base -am 'adding a.txt'+darcs record -am 'adding a.txt' cd ..  darcs get tmp_dopple tmp_ganger@@ -39,7 +39,7 @@  # Now that the conflict has been set up, try pull one patch from the other. cd tmp_ganger-darcs pull -a ../tmp_dopple > out+darcs pull -a ../tmp_dopple 2> out check_conflict cd .. @@ -48,6 +48,8 @@ mkdir temp0 cd temp0 darcs init+touch a.txt+darcs record -la a.txt -m init cd ..  # Create a conflict@@ -55,14 +57,12 @@ cd temp1 darcs show repo echo temp1 > a.txt-darcs add a.txt-darcs record  -A base -am 'adding temp1 a.txt'+darcs record -am temp1 cd .. darcs get temp0 temp2 cd temp2 echo temp2 > a.txt-darcs add a.txt-darcs record  -A base -am 'adding temp2 a.txt'+darcs record -am temp2 cd ..  # Resolve the conflict the same way on both sides@@ -78,5 +78,5 @@  # Now that the conflict has been set up, try pull one patch from the other. cd tmp_ganger-darcs pull -a ../tmp_dopple > out+darcs pull -a ../tmp_dopple 2> out check_conflict
tests/conflict-fight-failure.sh view
@@ -1,4 +1,4 @@-#!/bin/env bash+#!/usr/bin/env bash # # Test darcs conflict fight scenario. #@@ -9,10 +9,16 @@ # Author: Pekka Pessi # -set -ev+. ./lib -record="record --ignore-time --all --author X"+# test fails for these obsolete formats:+skip-formats darcs-1 darcs-2 +# skip if time executable is not found+/usr/bin/env time --help 2> /dev/null || exit 200++num_conflicts=40+ rm -rf RA RB mkdir RA @@ -20,7 +26,7 @@ echo 0 > file darcs init darcs add file-darcs $record -m0 file+darcs record -am0 file cd ..  darcs get RA RB@@ -28,27 +34,31 @@ # Create conflict in RB cd RB echo let it b > file-darcs $record -m B+darcs record -am B cd .. -for i in 1 2 3 4 5 # 6 7 8 9 10 11 12+for i in $(seq 1 $num_conflicts) do-  echo Create new patch A$i in RA   cd RA+  echo Create new patch A$i in RA   echo a$i > file-  darcs $record -m A$i+  darcs record -am A$i   cd .. -  echo Pull patch A$i from RA and get a conflict   cd RB-  time darcs pull ../RA --verbose --all --patch "^A$i\$"-  cd ..+  echo Pull patch A$i from RA and get a conflict +  /usr/bin/env time -f %e -o ../elapsed darcs pull ../RA --quiet --all --patch "^A$i\$" --allow-conflicts+  if (( $i == 1 )); then+    start=$(cat ../elapsed)+  else+    elapsed=$(cat ../elapsed)+    # check that the runtime is not more than quadratic in i+    (( $(echo "$elapsed < 1.5 * $i * $i * $start" | bc) ))+  fi+   echo Resolve conflict and start fighting by recording B$i-  cd RB   echo let it b > file-  darcs $record -m B$i+  darcs record -am B$i   cd .. done--rm -rf RA RB
tests/conflict-fight.sh view
@@ -1,32 +1,28 @@ #!/usr/bin/env bash -set -ev--rm -rf temp0 temp1 temp2+. ./lib  # step 1 mkdir temp0 cd temp0-darcs init --darcs-2-echo temp0 > _darcs/prefs/author+darcs init echo m1 > foo darcs add foo-darcs record -a -m m1 --ignore-times+darcs record -a -m m1 cd ..  # step 2 darcs get temp0 temp1 cd temp1-echo temp1 > _darcs/prefs/author echo a1 > foo-darcs record foo -a -m a1 --ignore-times+darcs record foo -a -m a1 cd ..   # step 3 cd temp0 echo m2 > foo-darcs record -a -m m2 --ignore-times+darcs record -a -m m2 cd ..  @@ -34,15 +30,15 @@ cd temp1 darcs pull -a echo m2-a1 > foo-darcs record -a -m 'Fix conflict m2-a1' --ignore-times+darcs record -a -m 'Fix conflict m2-a1' echo a2 > foo-darcs record -a -m a2 --ignore-times+darcs record -a -m a2 cd ..  #step 5 cd temp0 echo m3 > foo-darcs record -a -m m3 --ignore-times+darcs record -a -m m3 cd ..  #step 6@@ -50,29 +46,26 @@ cd temp2 echo temp2 > _darcs/prefs/author echo b1 > foo-darcs record -a -m b1 --ignore-times+darcs record -a -m b1  cd ..  #step 7 cd temp0 echo m4 > foo-darcs record -a -m m4 --ignore-times+darcs record -a -m m4 cd ..  #step 8 cd temp1 darcs pull -a echo m2-a1-m4 > foo-darcs record -a -m 'Fix three-way m2/m2-a1/m4' --ignore-times+darcs record -a -m 'Fix three-way m2/m2-a1/m4' echo a3 > foo-darcs record -a -m a3 --ignore-times+darcs record -a -m a3 cd ..  #step 9 cd temp1 darcs pull -av ../temp2 cd ..--rm -rf temp0 temp1 temp2-
+ tests/conflict-reporting.sh view
@@ -0,0 +1,94 @@+#!/bin/sh -e+##+## General tests for the conflict UI:+##  - conflict reporting on pull etc ("We have conflicts in the following files:")+##  - conflict reporting in summaries of changes ("M! foo.txt")+##  - conflict marking in files+##+## Copyright (C) 2016 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++mkdir R1+cd R1+darcs init+cat > file1 <<EOF+line1+EOF+darcs add file1+cat > file2 <<EOF+line1+line2+line3+EOF+darcs add file2+darcs rec -am "initial patch"++cd ..+darcs get R1 R2+cd R2++cat > file1 <<EOF+line1A+EOF+cat > file2 <<EOF+line1A+line2+line3+EOF++darcs rec -am "patch 1"++cd ../R1++cat > file1 <<EOF+line1B+EOF+cat > file2 <<EOF+line1+line2+line3B+EOF++darcs rec -am "patch 2"+darcs pull -a ../R2 2> pull-output+grep "conflicts" pull-output+grep "file1" pull-output+not grep "file2" pull-output++cat > file1-expected <<EOF+v v v v v v v+line1+=============+line1A+*************+line1B+^ ^ ^ ^ ^ ^ ^+EOF++diff -u file1-expected file1++darcs changes --summary -p "patch 1" > changes-output+grep "M! ./file1 -1 +1" changes-output+grep "M ./file2 -1 +1" changes-output+
+ tests/convert-darcs2.sh view
@@ -0,0 +1,66 @@+#!/usr/bin/env bash++## Tests for convert command based on previously checked results+## to generate new test material for this test,+## see bin/convert-writer.sh+##+## Copyright (C) 2009 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++only-format darcs-2++runtest() {+    opt=$1+    name=$2+    rm -rf $opt/$name+    mkdir -p $opt/$name+    cd $opt/$name++    mkdir repo+    cd repo+    darcs init --darcs-1+    darcs apply --allow-conflicts $TESTDATA/convert/darcs1/$name.dpatch+    cd ..+    echo 'yes' | darcs convert darcs-2 repo repo2 --$opt+    mkdir empty-darcs2+    cd empty-darcs2+    darcs init --darcs-2+    cd ..+    cd repo2+    darcs send --no-minimize -a -o ../$name-darcs2.dpatch ../empty-darcs2+    cd ..+    compare_bundles $TESTDATA/convert/darcs2/$name.dpatch $name-darcs2.dpatch++    cd ../..+}++for opt in no-working-dir with-working-dir; do+    runtest $opt simple+    runtest $opt twowayconflict+    runtest $opt threewayconflict+    runtest $opt threewayanddep+    runtest $opt threewayandmultideps+    runtest $opt resolution+    runtest $opt tworesolutions+done
+ tests/convert-import-export-non-ascii.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash++. lib++# The git repo here deliberately contains file names with+# unusual characters in them (e.g. newline);+# the test therefore makes sense only on Posix systems,+# since Windows does not even allow to create such files.+abort_windows++git --version || exit 200 # no git installed => skip test++rm -rf gitrepo gitrepo2 darcsrepo+unpack_testdata gitrepo+cd gitrepo+git fast-export HEAD > ../git-export+git log >../git-log1+cd ..+darcs convert import darcsrepo <git-export+diff -r gitrepo/src darcsrepo/src++cd darcsrepo+darcs convert export >../darcs-export+cd ..+mkdir gitrepo2+cd gitrepo2+git init+git fast-import < ../darcs-export+git checkout master+git log > ../git-log2+cd ..+diff -I 'commit' -I 'Date:' git-log1 git-log2+diff -r gitrepo/src gitrepo2/src
− tests/convert.sh 
@@ -1,60 +0,0 @@-#!/usr/bin/env bash--## Tests for convert command based on previously checked results-## to generate new test material for this test,-## see bin/convert-writer.sh-##-## Copyright (C) 2009 Ganesh Sittampalam-##-## 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-## SOFTWARE.--. lib--grep old-fashioned $HOME/.darcs/defaults || grep hashed $HOME/.darcs/defaults || exit 200--runtest() {-    rm -rf temp-    mkdir temp-    cd temp--    mkdir repo-    cd repo-    darcs init-    darcs apply --allow-conflicts $TESTDATA/convert/darcs1/$1.dpatch-    cd ..-    echo 'I understand the consequences of my action' | darcs convert repo repo2-    mkdir empty-darcs2-    cd empty-darcs2-    darcs init --darcs-2-    cd ..-    cd repo2-    darcs send -a -o ../$1-darcs2.dpatch ../empty-darcs2-    cd ..-    diff -I'1 patch for repository ' -I'patches for repository ' -I'Oct 1' -u $TESTDATA/convert/darcs2/$1.dpatch $1-darcs2.dpatch-}--runtest simple-runtest twowayconflict-runtest threewayconflict-runtest threewayanddep-runtest threewayandmultideps-runtest resolution-runtest tworesolutions
+ tests/convert_export.sh view
@@ -0,0 +1,58 @@+#!/usr/bin/env bash+## test incremental fast-export to git+##+## Copyright (C) 2014 Guillaume Hoffmann+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++# only run if git present+git --version | grep -i "git version"   || exit 200++darcs init      --repo R        # Create our test repos.+cd R+mkdir d e                       # Change the working tree.+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'++# one more change, this time with non-ASCII file name, comment, and content+# as well as a space in the file name+# see http://bugs.darcs.net/issue2359+echo 'Liebe Grüße' > e/'Liebe Grüße'+darcs record -lam 'Add file e/"Liebe Grüße"'++git init gitmirror++darcs convert export --write-marks darcs-to-git.marks > fex+(cd gitmirror && git fast-import --export-marks=git.marks < ../fex)++darcs mv d/f e/+darcs record -am 'Move d/f to e/f.'++darcs convert export --read-marks darcs-to-git.marks --write-marks darcs-to-git.marks > fex2+(cd gitmirror && git fast-import --import-marks=git.marks --export-marks=git.marks < ../fex2)++# restore the git working tree by making a clone+git clone gitmirror gitmirror-clone++diff e/f gitmirror-clone/e/f+diff e/"Liebe Grüße" gitmirror-clone/e/"Liebe Grüße"
+ tests/data/broken_move.tgz view

binary file changed (absent → 6840 bytes)

tests/data/context-v1.dpatch view
@@ -1,9 +1,13 @@ 2 patches for repository /home/ganesh/darcs-comp/temp/empty: -Thu Oct 21 18:28:18 BST 2010  Ganesh Sittampalam <ganesh@earth.li>+patch 573defe88544e8f75a18e530e3aeaf6608951aa1+Author: Ganesh Sittampalam <ganesh@earth.li>+Date:   Thu Oct 21 18:28:18 BST 2010   * init -Thu Oct 21 18:28:31 BST 2010  Ganesh Sittampalam <ganesh@earth.li>+patch c8ec7c8b2df55720ba2c3a21adb80790363f421e+Author: Ganesh Sittampalam <ganesh@earth.li>+Date:   Thu Oct 21 18:28:31 BST 2010   * ABC  New patches:
tests/data/context-v2.dpatch view
@@ -1,9 +1,13 @@ 2 patches for repository /home/ganesh/darcs-comp/temp/empty: -Thu Oct 21 18:28:18 BST 2010  Ganesh Sittampalam <ganesh@earth.li>+patch 573defe88544e8f75a18e530e3aeaf6608951aa1+Author: Ganesh Sittampalam <ganesh@earth.li>+Date:   Thu Oct 21 18:28:18 BST 2010   * init -Thu Oct 21 18:28:31 BST 2010  Ganesh Sittampalam <ganesh@earth.li>+patch c8ec7c8b2df55720ba2c3a21adb80790363f421e+Author: Ganesh Sittampalam <ganesh@earth.li>+Date:   Thu Oct 21 18:28:31 BST 2010   * ABC  New patches:
tests/data/convert/darcs2/resolution.dpatch view
@@ -1,18 +1,28 @@ 5 patches for repository /tmp/tmp6648/temp/empty-darcs2: -Sat Oct 16 23:32:07 BST 2010  tester+patch c88a093ab344f21fc3af74eee6741db45df22498+Author: tester+Date:   Sat Oct 16 23:32:07 BST 2010   * wibble -Sat Oct 16 23:32:07 BST 2010  tester+patch 9d61f1de5ae27b8f1678735b4741abe4a869d899+Author: tester+Date:   Sat Oct 16 23:32:07 BST 2010   * A -Sat Oct 16 23:32:07 BST 2010  tester+patch 3b3282935c87c2aede246a42f5c0a926fae2be35+Author: tester+Date:   Sat Oct 16 23:32:07 BST 2010   * B -Sat Oct 16 23:32:07 BST 2010  tester+patch bc42df597aa06b720f03367499e3dffe36baa9a4+Author: tester+Date:   Sat Oct 16 23:32:07 BST 2010   * AB -Sat Oct 16 23:32:07 BST 2010  tester+patch 8efe5b608a6236bd136ead946ef26369207ca5ac+Author: tester+Date:   Sat Oct 16 23:32:07 BST 2010   * C  New patches:
tests/data/convert/darcs2/simple.dpatch view
@@ -1,6 +1,8 @@ 1 patch for repository /tmp/tmp5746/temp/empty-darcs2: -Sat Oct 16 23:28:30 BST 2010  tester+patch 62068c47f23550e3a32aaf652d1e14e53598ba98+Author: tester+Date:   Sat Oct 16 23:28:30 BST 2010   * wibble  New patches:
tests/data/convert/darcs2/threewayanddep.dpatch view
@@ -1,18 +1,28 @@-5 patches for repository /tmp/tmp5530/temp/empty-darcs2:+5 patches for repository /tmp/convert-darcs2/Darcs2/PatienceDiff/convert-darcs2/no-working-dir/threewayanddep/empty-darcs2: -Sat Oct 16 23:27:54 BST 2010  tester+patch 349a0bab437265867f9af955d72127bac4cea1a6+Author: tester+Date:   Sun Oct 17 00:27:54 CEST 2010   * wibble -Sat Oct 16 23:27:54 BST 2010  tester+patch 650955997f5fac7fa2e14127a25ea5ac70f4dab0+Author: tester+Date:   Sun Oct 17 00:27:54 CEST 2010   * A1 -Sat Oct 16 23:27:54 BST 2010  tester+patch 476d8520cfc9be9b44299e6f4753de6adca83bcf+Author: tester+Date:   Sun Oct 17 00:27:54 CEST 2010   * A2 -Sat Oct 16 23:27:54 BST 2010  tester+patch 4d2a18f739f8f4c384b5653a5ad03d5e77724efe+Author: tester+Date:   Sun Oct 17 00:27:54 CEST 2010   * B -Sat Oct 16 23:27:54 BST 2010  tester+patch 81ba98134cf0d725e827318ca2753be4148568b7+Author: tester+Date:   Sun Oct 17 00:27:54 CEST 2010   * C  New patches:@@ -42,6 +52,7 @@ ] conflictor [ hunk ./wibble 2 +A1+hunk ./wibble 3 +A2 ] :@@ -51,12 +62,16 @@ tester**20101016222754  Ignore-this: 295e8a851b7a936b3d08b0ce7eaaf2ac ] conflictor {{-: hunk ./wibble 2 +A1+:+hunk ./wibble 3 +A2 : hunk ./wibble 2++A1+:+hunk ./wibble 2 +B }} [] :@@ -66,4 +81,4 @@ Context:  Patch bundle hash:-f9974a2fdbdea580b1be0eaba951e6285f9bfb5d+5d566c305f4017424a6b05e87bfc5971e95e877d
tests/data/convert/darcs2/threewayandmultideps.dpatch view
@@ -1,24 +1,38 @@-7 patches for repository /tmp/tmp5411/temp/empty-darcs2:+7 patches for repository /tmp/convert-darcs2/Darcs2/PatienceDiff/convert-darcs2/no-working-dir/threewayandmultideps/empty-darcs2: -Sat Oct 16 23:27:21 BST 2010  tester+patch fd370912c8a92d249e00e7c91856ed9530d6c914+Author: tester+Date:   Sun Oct 17 00:27:21 CEST 2010   * wibble -Sat Oct 16 23:27:21 BST 2010  tester+patch ac7df6a4761de10b4c440a9adb39c4f0236cb519+Author: tester+Date:   Sun Oct 17 00:27:21 CEST 2010   * A1 -Sat Oct 16 23:27:21 BST 2010  tester+patch 121d6130551316a64fa7a061cfc44f5946213f85+Author: tester+Date:   Sun Oct 17 00:27:21 CEST 2010   * A2 -Sat Oct 16 23:27:21 BST 2010  tester+patch 513848985dfc5b5ea1533d56b597daa7317f35bc+Author: tester+Date:   Sun Oct 17 00:27:21 CEST 2010   * B1 -Sat Oct 16 23:27:21 BST 2010  tester+patch 84edd5450901a4d31f1b49a9a6da4563a6ed73fe+Author: tester+Date:   Sun Oct 17 00:27:21 CEST 2010   * B2 -Sat Oct 16 23:27:21 BST 2010  tester+patch bec254c63929d83d13929eec63f2e5e5a8aabbb4+Author: tester+Date:   Sun Oct 17 00:27:21 CEST 2010   * C1 -Sat Oct 16 23:27:21 BST 2010  tester+patch 0e08cbe9489dfc7f21e9528b4c6a7d06f4fec25a+Author: tester+Date:   Sun Oct 17 00:27:21 CEST 2010   * C2  New patches:@@ -48,6 +62,7 @@ ] conflictor [ hunk ./wibble 2 +A1+hunk ./wibble 3 +A2 ] :@@ -56,18 +71,43 @@ [B2 tester**20101016222721  Ignore-this: 1d60b6c0ba913fff4d1e32ad26ae07bb-] +] conflictor {{+hunk ./wibble 2++A1+:+hunk ./wibble 3++A2+:+hunk ./wibble 2++A1+:+hunk ./wibble 2++B1+}} []+hunk ./wibble 2++B1+:+hunk ./wibble 3++B2 [C1 tester**20101016222721  Ignore-this: 25b6a6959d19980ad16983a542c6825 ] conflictor {{-: hunk ./wibble 2 +A1+:+hunk ./wibble 3 +A2 : hunk ./wibble 2++A1+:+hunk ./wibble 2 +B1+hunk ./wibble 2++B1+:+hunk ./wibble 3 +B2 }} [] :@@ -77,21 +117,33 @@ tester**20101016222721  Ignore-this: c16d607216c36d5f7727c64d2ec103d4 ] conflictor {{-: hunk ./wibble 2 +A1+:+hunk ./wibble 3 +A2 : hunk ./wibble 2++A1+hunk ./wibble 2 +B1+:+hunk ./wibble 3 +B2-}} [] : hunk ./wibble 2++B1+:+hunk ./wibble 2 +C1+}} []+hunk ./wibble 2++C1+:+hunk ./wibble 3 +C2  Context:  Patch bundle hash:-7f2bd6324e6e1f2d4efe67f98696ca0ead048fe5+8eb9adf3347935c847172e49b6597d14239d217f
tests/data/convert/darcs2/threewayconflict.dpatch view
@@ -1,15 +1,23 @@ 4 patches for repository /tmp/tmp5605/temp/empty-darcs2: -Sat Oct 16 23:28:14 BST 2010  tester+patch 8d6bfafe7ac2a628340563d92917da9639a8d509+Author: tester+Date:   Sat Oct 16 23:28:14 BST 2010   * wibble -Sat Oct 16 23:28:14 BST 2010  tester+patch c0a55ca9dedb993d05d2779ca4f72984e87083cd+Author: tester+Date:   Sat Oct 16 23:28:14 BST 2010   * A -Sat Oct 16 23:28:14 BST 2010  tester+patch fb027d809948379ca6357d654a6ce8cf45235dfa+Author: tester+Date:   Sat Oct 16 23:28:14 BST 2010   * B -Sat Oct 16 23:28:14 BST 2010  tester+patch 7eeb8289feadd843a19485f493235566a2c48bea+Author: tester+Date:   Sat Oct 16 23:28:14 BST 2010   * C  New patches:
tests/data/convert/darcs2/tworesolutions.dpatch view
@@ -1,24 +1,38 @@ 7 patches for repository /tmp/tmp6805/temp/empty-darcs2: -Sat Oct 16 23:34:33 BST 2010  tester+patch d1638af339ea13cf23df131015309be1915ae247+Author: tester+Date:   Sat Oct 16 23:34:33 BST 2010   * wibble -Sat Oct 16 23:34:33 BST 2010  tester+patch 687f568b2fa78eea4431b49c76524fd75cce06bf+Author: tester+Date:   Sat Oct 16 23:34:33 BST 2010   * A -Sat Oct 16 23:34:33 BST 2010  tester+patch f1859e4ecd30f209ad08440964b3fa7b7bb8318d+Author: tester+Date:   Sat Oct 16 23:34:33 BST 2010   * B -Sat Oct 16 23:34:33 BST 2010  tester+patch bb4b77fc72cf19af130db16c173f73341d847271+Author: tester+Date:   Sat Oct 16 23:34:33 BST 2010   * AB -Sat Oct 16 23:34:33 BST 2010  tester+patch fe0a5a17610dbffc90b421d3b40a9ee30ff7e484+Author: tester+Date:   Sat Oct 16 23:34:33 BST 2010   * C -Sat Oct 16 23:34:33 BST 2010  tester+patch 4ecd0a21ee5b7150e567a83c150810656ad76006+Author: tester+Date:   Sat Oct 16 23:34:33 BST 2010   * ABC -Sat Oct 16 23:34:33 BST 2010  tester+patch 756f4b3ac209102b5804ad71e54852b74a7281c1+Author: tester+Date:   Sat Oct 16 23:34:33 BST 2010   * D  New patches:
tests/data/convert/darcs2/twowayconflict.dpatch view
@@ -1,12 +1,18 @@ 3 patches for repository /tmp/tmp5677/temp/empty-darcs2: -Sat Oct 16 23:28:22 BST 2010  tester+patch 8b8ee8c8e9bae5fe01abfd8c991071091241aa1f+Date:   Sat Oct 16 23:28:22 BST 2010+Author: tester   * wibble -Sat Oct 16 23:28:22 BST 2010  tester+patch 23373e39b77dbce4de67f7631221f2d873ae21df+Author: tester+Date:   Sat Oct 16 23:28:22 BST 2010   * A -Sat Oct 16 23:28:22 BST 2010  tester+patch 0058ef88cdd3606a9fbcfa00fb8b7d494db77481+Author: tester+Date:   Sat Oct 16 23:28:22 BST 2010   * B  New patches:
+ tests/data/cyrillic_import_stream view
@@ -0,0 +1,14 @@+blob+mark :1+data 160+Широкая электрификация южных губерний даст мощный толчок подъёму сельского хозяйства++reset refs/heads/master+commit refs/heads/master+mark :2+author Andrey Korobkov <alster@vinterdalen.se> 1593449594 +0400+committer Andrey Korobkov <alster@vinterdalen.se> 1593454486 +0400+data 99+Южноэфиопский грач увёл мышь за хобот на съезд ящериц+M 100644 :1 "\320\237\320\260\320\275\320\263\321\200\320\260\320\274\320\274\320\260.txt"+
+ tests/data/empty-old.tgz view

binary file changed (absent → 3487 bytes)

+ tests/data/gitrepo.tgz view

binary file changed (absent → 12010 bytes)

+ tests/data/laziness-complete.tgz view

binary file changed (absent → 5338 bytes)

+ tests/data/laziness-cut.tgz view

binary file changed (absent → 4352 bytes)

− tests/data/many-files--darcs-2.tgz

binary file changed (250790 → absent bytes)

− tests/data/many-files--hashed.tgz

binary file changed (169112 → absent bytes)

+ tests/data/old-style-rebase-conflict.tgz view

binary file changed (absent → 6809 bytes)

+ tests/data/old-style-rebase-not-head.tgz view

binary file changed (absent → 7498 bytes)

+ tests/data/old-style-rebase.tgz view

binary file changed (absent → 6478 bytes)

− tests/data/old-with-checkpoint.tgz

binary file changed (3053 → absent bytes)

+ tests/data/patch-index-v2.tgz view

binary file changed (absent → 4686 bytes)

+ tests/data/rebase-0.0-conflict.tgz view

binary file changed (absent → 5822 bytes)

+ tests/data/rebase-0.0.tgz view

binary file changed (absent → 5666 bytes)

+ tests/data/rebase-0.2.tgz view

binary file changed (absent → 6179 bytes)

tests/data/simple-v1.dpatch view
@@ -1,6 +1,8 @@ 1 patch for repository /home/ganesh/darcs-comp/temp/empty: -Wed Oct 20 07:12:31 BST 2010  Ganesh Sittampalam <ganesh@earth.li>+patch 060052b3182f512c548d15dc6789228178cd9a4e+Author: Ganesh Sittampalam <ganesh@earth.li>+Date:   Wed Oct 20 07:12:31 BST 2010   * wibble  New patches:
tests/data/simple-v2.dpatch view
@@ -1,6 +1,8 @@ 1 patch for repository /home/ganesh/darcs-comp/temp/empty: -Wed Oct 20 07:12:31 BST 2010  Ganesh Sittampalam <ganesh@earth.li>+patch 060052b3182f512c548d15dc6789228178cd9a4e+Author: Ganesh Sittampalam <ganesh@earth.li>+Date:   Wed Oct 20 07:12:31 BST 2010   * wibble  New patches:
− tests/data/split--old-fashioned-inventory.tgz

binary file changed (2827 → absent bytes)

+ tests/data/tabular.tgz view

binary file changed (absent → 65337 bytes)

+ tests/data/undo.tgz view

binary file changed (absent → 4023 bytes)

+ tests/decoalesce-add-remove.sh view
@@ -0,0 +1,31 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R++touch f+touch g+darcs add f+darcs add g+rm g++grep "addfile ./g" _darcs/patches/pending++# record only f+darcs record -a -m 'add f'+# check that we did not record anything about g+darcs log -v | tee log >&2+not grep -F ./g log++# check that we still have a pending "addfile g"+# even if on the fly we coalesced it with the rm+# in the working tree to NilFL++grep "addfile ./g" _darcs/patches/pending+touch g+darcs whatsnew | grep "addfile ./g"++cd ..
+ tests/decoalesce-move.sh view
@@ -0,0 +1,181 @@+#!/usr/bin/env bash+##+## Checking what happens when we need to remove an add from pending+## after doing a move.+##+## Copyright (C) 2018 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init++echo 'foo' > a+echo 'bar' > b++darcs add a b++mv a c++darcs rec --look-for-moves c -a -m"added c via a"++darcs whatsnew > got+cat >want <<EOF+addfile ./b+hunk ./b 1++bar+EOF++diff -u want got >&2++cd ..+++rm -rf temp2+mkdir temp2+cd temp2+darcs init++echo 'foo' > a+echo 'bar' > b++darcs add a b++mv b c++darcs rec --look-for-moves c -a -m"added c via b"++darcs whatsnew > got+cat >want <<EOF+addfile ./a+hunk ./a 1++foo+EOF++diff -u want got >&2++cd ..++# Now test what happens if we do /not/ select the coalesced add+move++rm -rf temp3+mkdir temp3+cd temp3+darcs init++echo 'foo' > a+echo 'bar' > b++darcs add a b++mv b c++darcs whatsnew --look-for-moves > got+cat >want <<EOF+addfile ./a+hunk ./a 1++foo+addfile ./c+hunk ./c 1++bar+EOF++echo yyny | darcs rec --look-for-moves -m"added a (but not c via b)"++# make sure we recorded only changes to ./a+darcs log -v | grep -vF ./b | grep -vF ./c++# check pending still has the addfile ./b+grep -F 'addfile ./b' _darcs/patches/pending+# but not the detected move+grep -v move _darcs/patches/pending++# The tests below are disable because --look-for-moves does not detect+# the move in this case. It is currently (2022-07-21) unclear to me why.++if false; then+darcs whatsnew --look-for-moves > got+cat >want <<EOF+addfile ./c+hunk ./c 1++bar+EOF++diff -u want got >&2++darcs whatsnew > got+cat >want <<EOF+addfile ./c+hunk ./c 1++bar+EOF++diff -u want got >&2+fi++cd ..++# The same thing backwards, that is, we first `darcs move`,+# then remove the target w/o telling darcs+# then record only the (forced) hunk and not the+# coalesced move+rmfile.+# The expectation is that pending still contains+# the move, but not the coalesced "rmfile ./a".++rm -rf temp4+mkdir temp4+cd temp4+darcs init++echo 'foo' > a++darcs add a+darcs record -am 'add a with content'++darcs move a b+rm b++# remember the pending patch+cp _darcs/patches/pending pending.before++darcs whatsnew > dwh+# coalescing means dwh should be:+cat >dwh.expected <<EOF+hunk ./a 1+-foo+rmfile ./a+EOF+# check that+diff -u dwh.expected dwh >&2++# record only the hunk+echo yny | darcs rec -m"only the hunk"++# The actual test:+# Since whatsnew always "looks for removes" we can't use it here;+# instead check that _darcs/patches/pending hasn't changed:+diff -u pending.before _darcs/patches/pending >&2++cd ..
+ tests/decoalesce-replace.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R++touch f+darcs record -lam 'add f'++touch g+darcs add g+darcs replace one two f+rm f++echo nyy | darcs record -m 'add g'++# make sure we recorded the addfile ./g but nothing about f:+darcs log --last=1 -v > log+grep -F 'addfile ./g' log+grep -v -F './f' log++# test that pending still contains the replace that was eliminated+# (in memory) by coalescing it with the detected rm+cat >pending.want <<EOF+replace ./f [A-Za-z_0-9] one two+EOF++diff -u pending.want _darcs/patches/pending >&2++cd ..
+ tests/decoalesce-rmdir.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R++mkdir d+mkdir e+touch d/f+touch e/g+darcs add d/f+darcs add e/g+rm -r e++grep "addfile ./e/g" _darcs/patches/pending++# record only d/f+darcs record -a -m 'add d/f'+# check that we did not record anything about g+darcs log -v | tee log >&2+not grep -F ./g log++# check that we still have a pending "addfile g"+# even if on the fly we coalesced it with the rm+# in the working tree to NilFL++grep "addfile ./e/g" _darcs/patches/pending+mkdir e+touch e/g+darcs whatsnew | grep "addfile ./e/g"++cd ..
+ tests/decoalesce-split.sh view
@@ -0,0 +1,64 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R++echo 'version1' > file+darcs record -lam "version1"++# force replace so we have a hunk in pending that we can split+# but no (additional) changes detected in the working tree+darcs replace -f version2 version1 file++echo eyd | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5" >&2++# test that we correctly removed the recorded hunk which we split off from+# the forced hunk in pending:++cat > expected <<EOF+hunk ./file 1+-version1.5++version2+replace ./file [A-Za-z_0-9] version2 version1+EOF++darcs whatsnew | diff -u expected - >&2++cd ..++# same test as above but now *with* additional changes in working++rm -rf R+darcs init R+cd R++echo 'version1' > file+touch file2+darcs record -lam "version1"++# force replace so we have a hunk in pending that we can split+darcs replace -f version2 version1 file+darcs move file2 file3+echo text > file3++echo neyd | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5" >&2++# test that we correctly removed the recorded hunk which we split off from+# the forced hunk in pending:++cat > expected <<EOF+move ./file2 ./file3+hunk ./file 1+-version1.5++version2+replace ./file [A-Za-z_0-9] version2 version1+hunk ./file3 1++text+EOF++darcs whatsnew | diff -u expected - >&2++cd ..
tests/diff.sh view
@@ -1,18 +1,152 @@ #!/usr/bin/env bash-set -ev+. ./lib -rm -rf temp-$$-mkdir temp-$$-cd temp-$$-set -e-darcs initialize+export DARCS_TMPDIR=`pwd`/tmp+rm -rf tmp+mkdir tmp++rm -rf temp1+darcs init temp1+cd temp1+ echo text > afile.txt-darcs add afile.txt-darcs record --author me --all --no-test --name init+darcs record -lam init darcs diff darcs diff --no-unified -p . --store-in-mem > diffinmem darcs diff --no-unified -p . --no-store-in-mem > diffondisk diff diffinmem diffondisk++echo text >> afile.txt+darcs diff | sed 's/afile\.txt.*//'> diffnoarg+darcs diff . | sed 's/afile\.txt.*//' > diffdot+diff diffnoarg diffdot+ cd ..+rm -rf temp1 -rm -rf temp-$$++# issue966++darcs init temp1+cd temp1+echo "aaa diff" > file+darcs record -lam "aaa"+echo "bbb diff" >> file+darcs record -a -m "bbb"++darcs diff --patch "aaa" | grep "aaa diff"+darcs diff --patch "bbb" | grep "bbb diff"++darcs tag release-1+darcs optimize clean++echo "ccc diff" >> file+darcs record -a -m "ccc"+darcs diff --patch "ccc" | grep "ccc diff"++# here is where we have a problem+darcs diff --patch "aaa" | grep "aaa diff"+darcs diff --patch "bbb" | grep "bbb diff"+cd ..+rm -rf temp1++# issue1139 diff last++darcs init temp1+cd temp1++echo text > foo+darcs rec -lam 'add foo'++echo newtext > foo+darcs record -am 'modify foo'++darcs diff --no-unified --store-in-mem --last=1 > out1+grep text out1+grep foo out1++darcs diff --no-unified --last=1 > out+grep text out+grep foo out++diff -u out1 out++cd ..+rm -rf temp1++# issue 1139 diff with no args+darcs init temp1+cd temp1++echo text > foo+darcs record -lam 'add foo'+echo newtext > foo+darcs diff --no-unified --store > out1+grep text out1+grep foo out1++darcs diff --no-unified > out+grep text out+grep foo out+diff out out1+cd ..+rm -rf temp1++# issue1290 - darcs diff --index+darcs init temp1+cd temp1++echo '1' > f+darcs record -lam 'one'+echo '2' > f+darcs record -lam 'two'+echo '3' > f+darcs record -lam 'three'+echo '4' > f+darcs record -lam 'four'+# in the following outputs of `darcs diff`, we delete the+# lines "diff -rN old-... new-..." since they can be different+# if tests are run in parallel+darcs diff --no-unified --from-patch one --to-patch two | sed /^diff/d > d1+darcs diff --no-unified --index=3-4 |sed /^diff/d > d2 # the numbers go backwards+diff -q d1 d2+cd ..+rm -rf temp1+++# issue2052 - Ensure we use unified Diff by default.++darcs init temp1+cd temp1+touch a+darcs record -lam 'Add a'+echo testing > a+test `darcs diff | grep -c "diff -rN -u"` -eq 1+test `darcs diff --no-unified | grep -c "diff -rN -u"` -eq 0+test `darcs diff --no-unified | grep -c "diff -rN"` -eq 1+cd ..+rm -rf temp1++# issue2067: inexistant files result in empty lines in darcs++darcs init temp1+cd temp1+darcs diff a b c d 2> /dev/null | wc -l | grep "^ *0$"+cd ..+rm -rf temp1++# issue2179 - darcs diff on a dir should diff everything in and below+# that directory++darcs init temp1+cd temp1+mkdir dir+touch dir/file+darcs rec -alm 'Add dir/file'+echo testing > dir/file+darcs wh | grep testing+darcs diff | grep testing+darcs diff dir/file | grep testing+darcs diff dir | grep testing+cd ..+rm -rf temp1
− tests/directory_confusion.sh 
@@ -1,23 +0,0 @@-#!/usr/bin/env bash-set -ev--T=temp-rm -rf "$T"-mkdir "$T"-echo "$T"-cd "$T"-set -e-darcs initialize-echo text > afile.txt-darcs add afile.txt-darcs record --author me --all --no-test --name init-mkdir d-darcs add d-mkdir d/e-darcs add d/e-darcs mv afile.txt d/e/afile.txt-echo altered_text > d/e/afile.txt-darcs record --author me --all --no-test --name confusion-test ! -f _darcs/pristine/afile.txt-echo y/d/y | tr / \\012 | darcs unrecord-rm -rf "$T"
tests/disable.sh view
@@ -1,20 +1,37 @@ #!/usr/bin/env bash . lib -# Some tests for 'darcs whatsnew '- rm -rf temp1 mkdir temp1 cd temp1 darcs init-touch look_summary.txt-# --disable works on command line-not darcs whatsnew -sl --disable 2> log-grep -i disable log-# --disable works from defaults-echo 'whatsnew --disable' > _darcs/prefs/defaults-not darcs whatsnew -sl 2> log-grep -i disable log-cd ..+all_commands=$(darcs --commands | grep -v -- --) +for cmd in $all_commands; do+  # --disable works on command line+  not darcs $cmd --disable 2> log+  grep disable log+  rm log+  # --disable works from defaults+  sub_commands="$(darcs $cmd --list-options | grep -v -- -- | cut -f ';' -f 1 || true)"+  # disabling super commands in the defaults file is broken+  if test -z "$sub_commands"; then+    echo "$cmd --disable" > _darcs/prefs/defaults+    not darcs $cmd 2> log+    rm _darcs/prefs/defaults+    grep disable log+    rm log+  elif test $cmd != "setpref" -a $cmd != "help"; then+    # setpref and help are not proper super commands+    for scmd in $sub_commands; do+      echo "$cmd $scmd --disable" > _darcs/prefs/defaults+      not darcs $cmd 2> log+      rm _darcs/prefs/defaults+      grep disable log+      rm log+    done+  fi+done++cd .. rm -rf temp1
− tests/dist-v.sh 
@@ -1,18 +0,0 @@-#!/usr/bin/env bash-set -ev--# tests for "darcs dist"--not () { "$@" && exit 1 || :; }--rm -rf temp1-mkdir temp1-cd temp1-darcs init-# needs fixed on FreeBSD-darcs dist -v 2> log-not grep error log-cd ..--rm -rf temp1-
tests/dist.sh view
@@ -20,8 +20,10 @@  darcs record -a -m add_foo | grep -i "finished recording" darcs dist+darcs dist --zip  mv temp1.tar.gz  ..+mv temp1.zip  ..  cd .. @@ -32,4 +34,14 @@  diff -r temp_orig temp1 -rm -rf temp_orig temp1+rm -rf temp1++# Only do following if unzip is present+unzip >& /dev/null &&+(+unzip temp1.zip+diff -r temp_orig temp1+rm -rf temp1+)++rm -rf temp_orig
− tests/double-unrevert.sh 
@@ -1,29 +0,0 @@-#!/usr/bin/env bash-set -ev--# This demonstrates a bug that happens if you revert followed by-# a partial unrevert and a full unrevert.  It requires that-# the second unrevert is working with patches who's contents need-# to be modified by the commute in the first unrevert.--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo line1 >> A-echo line2 >> A-echo line3 >> A-echo line4 >> A-echo line5 >> A-echo line6 >> A-darcs add A-darcs record -am A-sed 's/line2/Line2/' A  > A1; rm A; mv A1 A-sed '4d' A > A1; rm A; mv A1 A-sed 's/line6/Line6/' A > A1; rm A; mv A1 A-darcs revert -a-echo nyn | darcs unrev-darcs unrev -a--cd ..-rm -rf temp1
tests/emailformat.sh view
@@ -1,8 +1,7 @@ #!/usr/bin/env bash -. lib+. ./lib -set -ev switch_to_latin9_locale rm -rf temp1 rm -rf temp2@@ -25,7 +24,8 @@ cd ../temp1  # long email adress: check that email adresses of <= 77 chars don't get split up-darcs send --from="Kjålt Überström $seventysevenaddy" \+darcs send --mail\+           --from="Kjålt Überström $seventysevenaddy" \            --subject "Un patch pour le répositoire" \            --to="Un garçon français <garcon@francais.fr>" \            --sendmail-command='tee mail_as_file %<' \@@ -43,10 +43,6 @@ main = getContents >>= print . not . any (> Data.Char.chr 127) EOF -ghc --make is_ascii.hs -o is_ascii-./is_ascii < ../temp1/mail_as_file | grep '^True$'+runghc is_ascii < ../temp1/mail_as_file | grep True  cd ..-rm -rf temp1-rm -rf temp2-rm -rf temp3
+ tests/empty_inventory.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash++# This tests that a minor change to the format of inventory files introduced+# in darcs-2.17.2 is compatible with previous releases. The situation is when+# a tag is recorded in an empty repository. This now creates and refers to an+# empty inventory, whereas previously it did not.++. lib++# forward compatibility++rm -rf empty-old empty-new+darcs init empty-new+cd empty-new+darcs tag XX+# we have not (semantically) changed the functions that read+# inventories so this suffices for testing forward compatibility+test $(darcs log --count) = "1"+cd ..++# backward compatibility++unpack_testdata empty-old+cd empty-old+# read+test $(darcs log --count) = "1"+# write+darcs tag YY+echo y | darcs obliterate -a+cd ..
tests/failed-amend-should-not-break-repo.sh view
@@ -25,8 +25,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -. lib-set -ev+. ./lib rm -rf R mkdir R cd R@@ -45,14 +44,13 @@ # amending 'move' results in commuting 'move' patch # to the end for removal. The commute changes the "add content" # patch to modify A instead of B. But the amend is interrupted-# because of test failure. Check the consitency after the operation.+# because of test failure. Check consistency after the operation. darcs setpref test false-echo yy | not darcs amend -p move --test+darcs log > ../before+echo yyyn | not darcs amend -p move --test darcs check--# Note: Amend-record in case of test failure is broken as described in issue1406,-# though when trying to fix it I almost managed to break darcs even more.-# This test is to guard against such regressions in the future.+darcs log > ../after+# check that nothing gets unrecorded by the aborted amend (issue1406)+diff ../before ../after  cd ..-rm -rf R
− tests/failing-haskell_policy.sh 
@@ -1,41 +0,0 @@-#!/usr/bin/env bash-## This is a pseudo-test that runs tweaked hlint on the source code.-##-## Copyright (C) 2009 Petr Rockai-##-## 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-## SOFTWARE.--. lib--explain() {-    echo >&2-    echo "## It seems that hlint has found errors. This usually means that you" >&2-    echo "## have used a forbidden function. See contrib/darcs-errors.hlint for" >&2-    echo "## explanation. Please also disregard any possible parse errors." >&2-}--trap explain ERR--hlint >& /dev/null || exit 200 # skip if there's no hlint--wd="`pwd`"-cd ..-hlint --hint=contrib/darcs-errors.hlint src
tests/failing-index-argument.sh view
@@ -36,11 +36,10 @@ darcs add a echo "test" >> a darcs record -a -m "record a" a-darcs annotate --index 1 darcs changes --index 1 darcs diff --index 1+darcs dist --index 1 darcs show contents --index 1 a  #### failing tests darcs show files --index 1 a-darcs dist --index 1
− tests/failing-issue1013_either_dependency.sh 
@@ -1,53 +0,0 @@-#!/usr/bin/env bash-set -ev-export DARCS_EMAIL=test-rm -rf tmp_d1 tmp_d2 tmp_d-# Preparations:-# Set up two repos, each with a patch (d1 and d2 respectively) with both-# an individual change and a change that is identical in both repos,-# and thus auto-merge, i.e., they don't conflict in darcs2.  Pull them-# together and record a patch (problem) on top of the auto-merged change,-# so that it depends on EITHER of two patches.--mkdir tmp_d1; cd tmp_d1-darcs init --darcs-2-echo a > a-echo b > b-echo c > c-darcs rec -alm init-echo a-independent > a-echo c-common > c-darcs rec -am d1-cd ..-darcs get --to-patch init tmp_d1 tmp_d2-cd tmp_d2-echo b-independent > b-echo c-common > c-darcs rec -am d2-darcs pull -a ../tmp_d1-# no conflicts -- c-common is identical-echo c-problem > c-darcs rec -am problem-cd ..--# I want to pull the 'problem' patch, but expect darcs to get confused-# because it doesn't know how to select one of the two dependent patches.--darcs get --to-patch init tmp_d2 tmp_d-cd tmp_d-echo n/n/y |tr / \\012 |darcs pull ../tmp_d2-darcs cha--# This is weird, we got d2 though we said No.  I would have expected-# darcs to skip the 'problem' patch in this case.--# Try to pull d1 and unpull d2.--darcs pull -a ../tmp_d1-exit 1 # darcs hangs here (2.0.2+77)!-echo n/y/d |tr / \\012 |darcs obl -p d2--# The obliterate fails with: patches to commute_to_end does not commutex (1)--cd ..-rm -rf tmp_d1 tmp_d2 tmp_d
− tests/failing-issue1014_identical_patches.sh 
@@ -1,62 +0,0 @@-#!/usr/bin/env bash-set -ev--# Set up a base repo. Our experiment will start from this point-mkdir base-cd base-darcs init --darcs-2-printf "Line1\nLine2\nLine3\n" > foo-darcs rec -alm Base-cd ..--# Now we want to record patch A, which will turn "Line2" into "Hello"-darcs get base a-cd a-printf "Line1\nHello\nLine3\n" > foo-darcs rec --ignore-times -am A-cd ..--# Make B the same as A-darcs get base b-cd b-printf "Line1\nHello\nLine3\n" > foo-darcs rec --ignore-times -am B-cd ..--# Now we make a patch C that depends on A-darcs get a ac-cd ac-printf "Line1\nWorld\nLine3\n" > foo-darcs rec --ignore-times -am C-cd ..--# Merge A and B-darcs get a ab-cd ab-darcs pull -a ../b-darcs revert -a-cd ..--# And merge in C too-darcs get ab abc-cd abc-darcs pull -a ../ac-darcs revert -a-cd ..--# Now we can pull just B and C into base-darcs get base bc-cd bc-darcs pull ../abc -ap 'B|C'-cd ..--# Now we have base, B and C in a repository.  At this point we're correct.--# Let's try merging AC with BC now, here we discover a bug.--darcs get ac abc2-cd abc2-darcs pull -a ../bc-darcs changes--test `darcs changes | fgrep -c '* C'` -eq 1
− tests/failing-issue1196_whatsnew_falsely_lists_all_changes.sh 
@@ -1,21 +0,0 @@-#!/usr/bin/env bash-set -ev--not () { "$@" && exit 1 || :; }--rm -rf temp1-mkdir temp1-cd temp1--darcs init-touch aargh-darcs add aargh-echo utrecht > aargh--darcs wh foo foo/../foo/. > out-cat out-not grep utrecht out--cd ..-rm -rf temp1-
− tests/failing-issue1266_init_inside_a_repo.sh 
@@ -1,33 +0,0 @@-#!/usr/bin/env bash-## Test for issue1266 - attempting to initialize a repository inside-## another repository should cause a warning, because while perfectly-## legitimate, it is likely to be accidental.-##-## Copyright (C) 2009  Trent W. Buck-##-## 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-## SOFTWARE.--. lib--rm -rf temp1 out                # Another script may have left a mess.-darcs init --repodir temp1-darcs init --repodir temp1/temp2 2>&1 | tee out-grep -i WARNING out             # A warning should be printed.
− tests/failing-issue1325_pending_minimisation.sh 
@@ -1,55 +0,0 @@-#!/usr/bin/env bash-## Test for issue1325 - hunk patches interfere with pending patch-## minimisation-##-## Copyright (C) 2009 Marco Túlio Gontijo e Silva, Eric Kow-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.-darcs init   --repo=R-darcs init   --repo=S--# this is expected to pass regardless of issue1325-# and is here to provide contrast-cd R-touch file-darcs add file-darcs record -am ' file'-mkdir b-darcs add b-darcs mv  file b-rm -r b-darcs whatsnew | not grep adddir-cd ..--# this is/was the failing part of issue1325-cd S-echo file > file                # we need a hunk to make this interesting-darcs add file-darcs record -am ' file'-mkdir b-darcs add b-darcs mv  file b-rm -r b-darcs whatsnew | not grep adddir-cd ..
− tests/failing-issue1327.sh 
@@ -1,27 +0,0 @@-#!/usr/bin/env bash-set -ev--# See issue1327.-# results in the error:-# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452---rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-echo fileA version 1 > fileA-echo fileB version 1 > fileB-darcs add fileA fileB-darcs record --author foo@bar --ignore-times --all -m "Add fileA and fileB"-echo fileA version 2 > fileA-darcs record --author foo@bar --ignore-times --all -m "Modify fileA"-cd ..-darcs get temp1 temp2-cd temp2-darcs obliterate -p "Modify fileA" --all-darcs unrecord -p "Add fileA and fileB" --all-darcs record --author foo@bar --ignore-times --all fileA -m "Add just fileA"-cd ../temp1-darcs pull --all ../temp2-echo y | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB"
− tests/failing-issue1363-mark-conflicts.sh 
@@ -1,62 +0,0 @@-#!/usr/bin/env bash-## Test for issue1363 - mark-conflicts should report that there is a-## conflict to mark if apply/push say there are-##-## Copyright (C) 2010 Eric Kow-## Copyright (C) 2009 Thorkil Naur-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R S T                    # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.-darcs init      --repo S-darcs init      --repo T--cd R- touch f.txt- darcs add f.txt- darcs record -am "Empty f.txt"- echo f.txt contents >> f.txt- darcs record -am "Contents of f.txt"-cd ..--cd S- echo yn | darcs pull ../R- rm f.txt- darcs record -am 'Remove f.txt in S'-cd ..--cd T- echo ynn | darcs pull ../R- rm f.txt- darcs record -am 'Remove f.txt in T'- not darcs push -a ../R > log # should fail because of conflict- grep "There are conflicts" log-cd ..--cd R-  darcs pull -a ../S-  darcs revert -a-  darcs pull -a ../T-  echo y | darcs mark-conflicts > log-  not grep "No conflicts" log-cd ..
tests/failing-issue1396_changepref-conflict.sh view
@@ -1,7 +1,5 @@ #!/usr/bin/env bash-set -ev--. lib+. ./lib  rm -rf temp1 temp1a temp1b
− tests/failing-issue1401_bug_in_get_extra.sh 
@@ -1,44 +0,0 @@-#!/usr/bin/env bash-## Test for issue1401 - when two repos share a HUNK patch, but that-## patch's ADDFILE dependency is met by different patches in each-## repo, it becomes impossible to pull between the two repos.-##-## Copyright (C) 2009  Trent W. Buck-##-## 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-## SOFTWARE.--. lib--## This bug only affects darcs-2 repositories.-fgrep darcs-2 ~/.darcs/defaults &>/dev/null || exit 0--rm -rf d e                      # Another script may have left a mess.-darcs initialize --repodir d/-darcs initialize --repodir e/-touch d/f d/g e/f-darcs record     --repodir d/ -lam 'Add f and g'-darcs record     --repodir e/ -lam 'Add f'-echo >d/f-darcs record     --repodir d/ -am 'Change f'-darcs pull       --repodir e/ -a d/-darcs obliterate --repodir e/ -ap 'Add f and g'-darcs pull       --repodir e/ -a d/-rm -rf d/ e/                    # Clean up after ourselves.
tests/failing-issue1406.sh view
@@ -37,9 +37,7 @@ darcs push      --repo S R rm -rf R/ S/                    # Clean up after ourselves. #!/bin/sh-set -ev--. lib+. ./lib  rm -rf temp1 darcs init --repodir temp1@@ -53,7 +51,7 @@ echo "y" | not darcs amend-record --all --patch=p1  # There should be one patch in the repo-test 1 -eq `darcs changes --count` || exit 1+test 1 -eq `darcs changes -a --count` || exit 1  # Another check: there should be nothing new after a is restored echo "a" > a@@ -62,24 +60,3 @@ cd .. rm -rf test1 -# the following section of the test does not create a new repo,-# it oprates on an existing old-fashioned repo; no need to run it 3 times-if grep 'old-fashioned' .darcs/defaults; then--    # check that we do the operations on checkpoints tentatively-    rm -rf old-with-checkpoint-    gunzip -c $TESTDATA/old-with-checkpoint.tgz | tar xf ---    echo "test exit 1" > old-with-checkpoint/_darcs/prefs/prefs--    # this amend will fail-    echo 'y' | not darcs amend --repo old-with-checkpoint -m 'no longer a checkpoint :P' -p "checkpoint here"--    # check that the patch has not been removed from-    # the checkpoints inventory-    grep "checkpoint here" old-with-checkpoint/_darcs/checkpoints/inventory-    #NOTE: checking the file is a rather white box way of testing it, but-    #      I could not think of any other way at the time, please improve--    rm -rf old-with-checkpint-fi
− tests/failing-issue1442_encoding_round-trip.sh 
@@ -1,50 +0,0 @@-#!/usr/bin/env bash-## -*- coding: utf-8 -*--## Test for issue1442 - if we disable Darcs escaping and don't change-## our encoding, the bytes in a filename should be the same bytes that-## "darcs changes -v" prints to the right of "addfile" and "hunk".-##-## Copyright (C) 2009  Trent W. Buck-##-## 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-## SOFTWARE.--. lib--rm -rf R                        # Another script may have left a mess.--## Use the first UTF-8 locale we can find.-export LC_ALL=$(locale -a | egrep 'utf8|UTF-8' | head -1)-export DARCS_DONT_ESCAPE_ANYTHING=True--## If LC_ALL is the empty string, this system doesn't support UTF-8.-if test -z "$LC_ALL"-then exit 1-fi--darcs init      --repo R-echo '首頁 = א₀' >R/'首頁 = א₀'-darcs record    --repo R -lam '首頁 = א₀' '首頁 = א₀'-darcs changes   --repo R -v '首頁 = א₀' >R/log-#cat R/log                      # Show the humans what the output was.-grep -c '首頁 = א₀' R/log >R/count-echo 5 >R/expected-count-cmp R/count R/expected-count    # Both count files should contain "5\n".-rm -rf R                        # Clean up after ourselves.
tests/failing-issue1461_case_folding.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash ## Test for issue1461 - patches to files whose names only differ by-## case can be wrongly applied to the same file in the working directory.+## case can be wrongly applied to the same file in the working tree. ## ## Copyright (C) 2009 Eric Kow ##@@ -26,9 +26,6 @@  . lib                  # Load some portability helpers. -touch casetest-test -e CASETEST || exit 200- rm -rf lower upper joint        # Another script may have left a mess. mkdir lower upper @@ -80,8 +77,10 @@ cd joint darcs pull ../lower -a darcs pull ../upper -a-grep one a && not grep three a-grep three A && not grep one A+grep one a+not grep three a+grep three A+not grep one A cd .. # clean up after ourselves rm -rf lower upper joint
− tests/failing-issue1522_trailing_slash_borkage.sh 
@@ -1,35 +0,0 @@-#!/usr/bin/env bash-## Test for issue1522 - Trailing slash borkage-##-## Copyright (C) 2012 Andreas Brandt-##-## 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-## SOFTWARE.--. lib-rm -rf R-mkdir R--cd R-darcs init --repo R-touch R/d-darcs record --repo R -lam Yow! d/--cd ..
+ tests/failing-issue1577-revert-deletes-new-files.sh view
@@ -0,0 +1,34 @@+#!/usr/bin/env bash+## Test for issue1577 - revert deletes unadded files.+##+## Copyright (C) 2013 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+## SOFTWARE.++. lib                           # Load some portability helpers.+rm -rf R+darcs init      --repo R        # Create our test repos.++cd R+echo 'Example content.' > f+darcs add f+darcs rev -a+[[ -e f ]]
− tests/failing-issue1609_ot_convergence.sh 
@@ -1,104 +0,0 @@-#!/usr/bin/env bash-## Test for issue1609 - standard test for the TP2 property-## in the Operational Transformation literature.-##-## According to Wikipedia:-## For every three concurrent operations op1,op2 and op3 defined on the same-## document state, the transformation function T satisfies CP2/TP2 property-## if and only if:-## T(op_3, op_1 \circ T(op_2,op_1)) = T(op_3, op_2 \circ T(op_1,op_2)).-##-## Copyright (C) 2009 Eric Kow <kowey@darcs.net>-## Copyright (C) 2009 Pascal Molli <momo54@gmail.com>-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf S1  S2  S3               # Another script may have left a mess.-darcs init      --repo S1       # Create our test repos.--cd S1-cat > f << END-1-2-3-4-5-END-darcs add f-darcs record -am init-cd ..--darcs get S1 S2-darcs get S1 S3--cd S1-cat > f << END-1-2-X-3-4-5-END-darcs record -am 'insert X before line 3'-cd ..--cd S2-cat > f << END-1-2-4-5-END-darcs record -am 'delete line 3'-cd ..--cd S3-cat > f << END-1-2-3-Y-4-5-END-darcs record -am 'insert Y after line 3'-cd ..--darcs pull --allow-conflicts -a --repo S1 S2-darcs pull --allow-conflicts -a --repo S2 S1--darcs pull --allow-conflicts -a --repo S1 S3-darcs pull --allow-conflicts -a --repo S2 S3--darcs pull --allow-conflicts -a --repo S3 S1--# TP2 is just fine for conflict resolution itself...-diff S1/f S2/f # no difference-diff S2/f S3/f # no difference--# But what about the conflict marking?-darcs mark-conflicts --repo S1-darcs mark-conflicts --repo S2-darcs mark-conflicts --repo S3-diff S1/f S2/f # no difference-diff S2/f S3/f # no difference
tests/failing-issue1610_get_extra.sh view
@@ -27,8 +27,7 @@  . lib                  # Load some portability helpers. -# this test is not relevant for darcs 2 repositories-(not grep darcs-2 $HOME/.darcs/defaults) || exit 200+# this test fails only for darcs-1 patch format  rm -rf S1  S2  S3               # Another script may have left a mess. darcs init      --repo S1       # Create our test repos.
− tests/failing-issue1632_changes_nonexisting.sh 
@@ -1,40 +0,0 @@-#!/usr/bin/env bash-## Test for issue1632 - 'darcs changes d/f' should not list any changes,-## where d is part of the repo and f is a non-existent file.-##-## Copyright (C) 2009   Ben Franksen-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--cd R-mkdir d-darcs record -lam 'added directory d'-# darcs should not list any changes here:-darcs changes non-existent-file > log-not grep 'added directory d' log-# ...and neither here:-darcs changes d/non-existent-file > log-not grep 'added directory d' log-cd ..
@@ -1,6 +1,6 @@ #!/usr/bin/env bash ## Test for issue1702 - an optimize --relink does not relink the files-## in ~/.darcs/cache.+## in ~/.cache/darcs. ## ## Copyright (C) 2009  Trent W. Buck ##@@ -24,10 +24,11 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -. lib                  # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.+. lib +rm -rf R S+darcs init R+ ## Create a patch. echo 'Example content.' > R/f darcs record -lam 'Add f.' --repodir R@@ -35,25 +36,40 @@ ## Get a hard link into the cache. darcs get R S +inode() {+  stat -c %i $1+}++# number of hard links+links() {+  stat -c %h $1+}++same_inode () {+  test $(inode $1) = $(inode $2)+}+ ## Are hard links available?-x=(R/_darcs/patches/*-*)-x=${x#R/_darcs/patches/}-if [[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]]-then+rm -f x y+touch x+if ! (ln x y && same_inode x y && test $(links x) = 2 && test $(links y) = 2); then     echo This test requires filesystem support for hard links.-    echo This test requires the hashed (or darcs-2) repo format.     exit 200 fi -## IMPORTANT!  In bash [[ ]] is neither a builtin nor a command; it is-## a keyword.  This means it can fail without tripping ./lib's set -e.-## This is why all invocations below have the form [[ ... ]] || false.+inR=(R/_darcs/patches/*-*)+inS=(S/_darcs/patches/*-*)+patch=$(basename $inR)+inC=$(find $HOME/.cache/darcs/patches -name $patch)  ## Confirm that all three are hard linked.-ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging-[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false+same_inode $inR $inS+same_inode $inS $inC+same_inode $inC $inR+# double check+test $(links $inR) = 3+test $(links $inS) = 3+test $(links $inC) = 3  ## Break all hard links. rm -rf S@@ -62,16 +78,22 @@ cp -r S R  ## Confirm that there are no hard links.-ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging-[[ ! R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ ! S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ ! R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false+not same_inode $inR $inS+not same_inode $inS $inC+not same_inode $inC $inR+# double check+test $(links $inR) = 1+test $(links $inS) = 1+test $(links $inC) = 1  ## Optimize *should* hard-link all three together.-darcs optimize --relink --repodir R --sibling S+darcs optimize relink --repodir R --sibling S  ## Confirm that all three are hard linked.-ls -lids {~/.darcs/cache,[RS]/_darcs}/patches/$x # debugging-[[ R/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ S/_darcs/patches/$x -ef ~/.darcs/cache/patches/$x ]] || false-[[ R/_darcs/patches/$x -ef S/_darcs/patches/$x ]] || false+same_inode $inR $inS+same_inode $inS $inC+same_inode $inC $inR+# double check+test $(links $inR) = 3+test $(links $inS) = 3+test $(links $inC) = 3
− tests/failing-issue1819-pull-dont-allow-conflicts.sh 
@@ -1,38 +0,0 @@-#!/usr/bin/env bash-## Test for issue1819 - pull --dont-allow-conflicts doesn't work-##-## Dave Love <fx@gnu.org>, Public domain--. lib-rm -rf R S-for repo in R S; do-    darcs init --repo $repo-    cd $repo-    echo 'Example content.' >x-    darcs add x-    darcs record -lam 'Add x'-    echo $repo >x-    darcs record -lam 'Change x'-    cd ..-done--darcs get S S0-cd S0-# the 'echo |' is for the external merge prompt 'hit return to continue' prompt-echo | darcs pull --all --allow-conflicts --external-merge 'cp %2 %o' ../R-cd ..--darcs get S S0b-cd S0b-echo | not darcs pull --all --dont-allow-conflicts ../R-cd ..--darcs get S S1-cd S1-echo | not darcs pull --all --external-merge 'cp %2 %o' --dont-allow-conflicts ../R-cd ..--darcs get S S2-cd S2-echo | not darcs pull --all --dont-allow-conflicts --external-merge 'cp %2 %o' ../R-cd ..
tests/failing-issue1829-inconsistent-conflictor.sh view
@@ -26,8 +26,9 @@ ## SOFTWARE. . lib -rm -rf r1 r2+grep darcs-2 $HOME/.darcs/defaults || exit 200 +rm -rf r1 r2 mkdir r1 cd r1 darcs init
− tests/failing-issue1845-paths-working-copy.sh 
@@ -1,37 +0,0 @@-#!/usr/bin/env bash-## Test for issue1845 - darcs wants file paths from root of working copy-##-## Copyright (C) 2010 Guillaume Hoffmann-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.-cd R-mkdir subdir-touch subdir/subfile-darcs add subdir subdir/subfile-darcs record -am"add subdir and subfile"-cd subdir-rm subfile-darcs record subfile -am"delete file in subdirectory" # fails because darcs wants subdir/subfile -
tests/failing-issue1926_amend-record_ignores_--index.sh view
@@ -33,7 +33,7 @@ darcs record -lam 'Add file f' echo 'Example content 2.' > g darcs record -lam 'Add file g'-darcs put ../S                  # S as a copy of R+darcs get . ../S                  # S as a copy of R echo "y" | darcs amend-record --index=2 -m 'A new file f'   # Since --index is ignored this command works in                                                             # interactive mode, and the amended patch is the one                                                             # with index 1.
− tests/failing-issue1928-file-dir-replace.sh 
@@ -1,36 +0,0 @@-#!/usr/bin/env bash-## Test for issue1913 - test for directory diffing-##-## Copyright (C) 2010 Ganesh Sittampalam-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--cd R-touch foo-darcs rec -l -a -m "foo file patch"-rm foo-mkdir foo-darcs rec -l -a -m "foo dir patch"-cd ..
− tests/failing-issue1932-colon-breaks-add.sh 
@@ -1,77 +0,0 @@-#!/usr/bin/env bash-## Test for issue1932 - "darcs add -qr ." should not break on files with colons-##-## Copyright(C) 2010 Dmitry Astapov-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-mkdir -p R                      # Create our test repo.--cd R-darcs init-darcs --version--# Colons could be in repo names and in file name.-# Colon in repo name is an indication of special case - remote repo.-# Colon in the file could be there under unix and requires no special treatment.--# Repo name with ':' is either scp repo or http repo.-# Let's check scp repo first.-( darcs get user@host:path || true ) > log 2>&1-[ -n "$(fgrep  '(scp) failed to fetch' log)" ]--# HTTP repo-( darcs get http://www.bogus.domain.so.it.will.surely.fail.com || true ) > log 2>&1-[ -n "$(fgrep  'CouldNotResolveHost' log)" ]--# All following files should not be added unless "--reserved-ok" is specified,-# but should be added with "--reserved-ok" just fine-mkdir funny-touch funny/0401:19d2-touch funny/c:src-touch funny/c:\\src-touch funny/user@host:path -touch funny/droundy@host:    -touch funny/host:path--# Try to add those files. None should be added, darcs should not fail-darcs add -qr funny-darcs wh -l > log 2>&1--# Check that darcs didn't drop dead as 2.4.4 does-[ -z "$(fgrep 'fromJust: Nothing' log)" ]--# Check that no funny files were added-[ -z "$(grep  '^A \./funny/.' log)" ]--# Now let's allow colons and add those files-darcs add --reserved-ok -qr funny -darcs wh -l > log 2>&1--# This should add all those files-[ -n "$(grep  '^A \./funny/0401:19d2' log)" ]-[ -n "$(grep  '^A \./funny/c:src' log)" ]-[ -n "$(grep  '^A \./funny/c:\\src' log)" ]-[ -n "$(grep  '^A \./funny/user@host:path' log)" ]-[ -n "$(grep  '^A \./funny/droundy@host:' log)" ]-[ -n "$(grep  '^A \./funny/host:path' log)" ]
− tests/failing-issue2017-missing-tag.sh 
@@ -1,85 +0,0 @@-#!/usr/bin/env bash-## Test for issue2017 - apply should gracefully handle tag missing-## from context (complain, not crash)-##-## Copyright (C) 2010 Eric Kow-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.--cd R-echo 'Example content.' > f-darcs record -lam 'Add f'-cd ..--# variant 0 - this passes trivially-darcs get R R0-darcs get R0 S0-darcs tag 's' --repo S0-darcs get S0 T0-cd T0-echo 'More content.' > f-darcs record -lam 'Modify f'-darcs send -o foo.dpatch -a-cd ..-not darcs apply --repo R0 T0/foo.dpatch > log 2>&1-not grep bug log-grep missing log--# variant 1 - tag in shared context-darcs get R R1-darcs tag '1' --repo R1-darcs get R1 S1-darcs tag 's1' --repo S1-darcs get S1 T1-cd T1-echo 'More content.' > f-darcs record -lam 'Modify f'-darcs send -o foo.dpatch -a-cd ..-# sanity check: should be able to cherry pick-darcs get R1 R1b-cd R1b-[ `darcs changes --count` -eq 2 ]-darcs pull ../T1 --match 'touch f' --all-[ `darcs changes --count` -eq 3 ]-cd ..-# the test: can't apply this due to incorrect context-not darcs apply --repo R1 T1/foo.dpatch > log 2>&1-not grep 'bug' log-grep missing log--# variant 2 - tag created after the fact-darcs get R  R2-darcs get R2 S2-darcs tag 's2' --repo S2-darcs get S2 T2-cd T2-echo 'More content.' > f-darcs record -lam 'Modify f'-darcs send -o foo.dpatch -a-cd ..-darcs tag '2'  --repo R2  # only tag after-not darcs apply --repo R2 T2/foo.dpatch > log 2>&1-not grep 'bug' log-grep missing log
− tests/failing-issue2066_add_and_remove.sh 
@@ -1,41 +0,0 @@-#!/usr/bin/env bash-## Test for issue2066 - darcs record fails when deleted file and added file are specified on the command line-##-## Copyright (C) 2011  David Caldwell <david@porkrind.org>-##-## 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-## SOFTWARE.--. lib-rm -rf R-mkdir R--cd R-darcs init-echo a > a-darcs add a-darcs record --all -m "a"-rm -f a-echo b > b-darcs add b-darcs record --all -m "-a+b" a b-darcs changes -v | grep 'rmfile ./a' # the remove doesn't get recorded even though we told it to.--cd ..
− tests/failing-issue2086-index-permissions.sh 
@@ -1,38 +0,0 @@-#!/usr/bin/env bash-## Test for issue2086 - _darcs/index permissions are not preserved-##-## Copyright (C) 2011 Eric Kow-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.--cd R-echo 'Example content.' > f-darcs record -lam 'Add f' --umask 022-ls -l _darcs/index | grep '^.rw..--...'-chmod g+w _darcs/index-ls -l _darcs/index | grep '^.rw.rw....'-echo 'Example content 2.' > f-darcs record -lam 'Tweak f'-ls -l _darcs/index | grep '^.rw.rw....'-cd ..
tests/failing-issue2100-add-failures.sh view
@@ -31,9 +31,9 @@ echo 'Example content.' > d/f not darcs add d/non-existent not darcs whatsnew-not darcs add d/non-existent d/f+not darcs add d/non-existent d/f  > log1 2>&1 darcs whatsnew > log2 2>&1-grep "./d/non-existent does not exist" log2+grep "./d/non-existent does not exist" log1 not grep "addfile ./d/non-existent" log2 grep "adddir ./d" log2 grep "addfile ./d/f" log2
+ tests/failing-issue2138-whatsnew-s.sh view
@@ -0,0 +1,59 @@+#!/usr/bin/env bash+## Test for issue2138 - whatsnew --summary does not show conflicts+##+## Copyright (C) 2012 Lele Gaifax+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++rm -rf R S++darcs init --repo R++cd R+echo 'Example content.' > f+darcs record -lam 'Add f'+cd ..++darcs get R S++# Create a deliberate conflict+cd R+echo "Conflict on side R" >> f+darcs record -am 'CR'++cd ../S+echo "Conflict on side S" >> f+darcs record -am 'CS'++darcs pull -a ../R++darcs whatsnew > out+cat out+grep "side R" out | wc -l | grep 1+grep "side S" out | wc -l | grep 1++darcs whatsnew --summary > out+grep "^M!" out | wc -l | grep 1++cd ..+rm -rf R S
+ tests/failing-issue2186-apply--reply-conflict.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+## Test for issue2186 - If a patch fails (e.g. because of a conflict), +## "apply --reply" does not email a status report.+##+## Copyright (C) 2012 Ilya Perminov+##+## 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+## SOFTWARE.++. lib++# Create a script that will be used instead of sendmail. It simply saves its +# input to file "message".+echo "#!/usr/bin/env bash" >dummy-sendmail+echo "cat >message" >>dummy-sendmail+chmod a+x dummy-sendmail++darcs init --repo R+darcs get R S++# Create an email message with a patch+cd R+echo 'Example content.' >file1+darcs add file1+darcs rec -a --name patch1+darcs send --dont-edit-description --to noreply@example.net --mail --sendmail-command '../dummy-sendmail %<' -a ../S+mv message patch-set1++# Create the same file in the target repository to trigger a conflict.+cd ../S+echo 'Some text.' >file1+darcs add file1+darcs rec -a --name patch2++# Apply the patch set. darcs should email a report. If it does our dummy-sendmail script will +# create file "message".+darcs apply --reply noreply@example.net --mail --sendmail-command '../dummy-sendmail %<' ../R/patch-set1 || true;+test -f ./message
+ tests/failing-issue2186-apply--reply-ok.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+## Test for issue2186 - If patchs are applied successfully, +## "apply --reply" does not email a status report.+##+## Copyright (C) 2012 Ilya Perminov+##+## 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+## SOFTWARE.++. lib++# Create a script that will be used instead of sendmail. It simply saves its +# input to file "message".+echo "#!/usr/bin/env bash" >dummy-sendmail+echo "cat >message" >>dummy-sendmail+chmod a+x dummy-sendmail++darcs init --repo R+darcs get R S++# Create an email message with a patch+cd R+echo 'Example content.' >file1+darcs add file1+darcs rec -a --name patch1+darcs send --dont-edit-description --to noreply@example.net --mail --sendmail-command '../dummy-sendmail %<' -a ../S+mv message patch-set1++# Apply the patch set. darcs should email a report. If it does our dummy-sendmail script will +# create file "message".+cd ../S+darcs apply --reply noreply@example.net --mail --sendmail-command '../dummy-sendmail %<' ../R/patch-set1+test -f ./message
+ tests/failing-issue2187-apply--test-non-interactive.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2187 - "darcs apply --test <patch-set" crashes if +## the test fails.+##+## Copyright (C) 2012 Ilya Perminov+##+## 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+## SOFTWARE.++. lib++darcs init --repo R+darcs get R S++# Create a patch bundle+cd R+echo 'Example content.' >file1+darcs add file1+darcs rec -a --name patch1+darcs send --dont-edit-description --output=./patch1 -a ../S++# Setup a test that fails, apply the patch set, check for an unhandled exception.+cd ../S +darcs setpref test false+not darcs apply --test <../R/patch1 > log 2>&1+not fgrep -q "illegal operation" log
+ tests/failing-issue2203-only-list-toplevel-deleted-dirs.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2203 - darcs should only list toplevel deleted directories+##+## Copyright (C) 2012 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+## SOFTWARE.++. ./lib++rm -rf R+darcs init --repo R+cd R++mkdir -p dir1/dir2++touch dir1/file1+touch dir1/dir2/file2++darcs rec -alm 'Add dirs/files'++rm -r dir1++# Darcs should only report that the top-level dir has been removed, rather than+# each dir/file (i.e 4 changes in this case, not 1).+[[ $(darcs wh | grep '^rm' | wc -l) -eq 1 ]]
+ tests/failing-issue2213-lastregrets-dependencies.sh view
@@ -0,0 +1,41 @@+#!/usr/bin/env bash+## Test for issue2213 - last regrets should respect patch dependencies when+## going back through patches+##+## Copyright (C) 2012 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+## SOFTWARE.++. lib++rm -rf R S+darcs init --repo R+darcs init --repo S+cd R++echo 'a' > file+darcs rec -alm a++echo 'b' > file+darcs rec -alm b++# Darcs shouldn't ask about b before asking about a.+echo nkd | darcs push ../S | not grep b
+ tests/failing-issue2219-no-working.sh view
@@ -0,0 +1,70 @@+#!/usr/bin/env bash+## Test for issue2219 - the --no-working-dir flag+##+### Copyright (C) 2011 Eric Kow +##+## Permission is hereby granted, free of charge, to any person o+## 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+## SOFTWARE.++. lib++# getting a --no-working-dir repo should not create any of the wd files+mkdir R1+cd R1+darcs init+echo "howdy" > a+darcs add a+darcs record -a -m 'a file' a+cd ..+darcs get --no-working-dir R1 R2+test   -e R1/a+test ! -e R2/a++# absence of a working dir should not result in a pull conflict+# or a diff for that matter+## 2011-12-27: darcs failed:  error opening _darcs/pristine.hashed/7cb4df6851fc86f51ee33ff490a85c9f4f5cc31f7c7d9977c50942453a1a94a9+darcs get R1 R1b+cd R1b+echo "more stuff" > a+darcs record -a -m 'modify a'+cd ../R2+darcs pull ../R1b -a+# NB: not sure if this test expresses what I really intend+DIFFCOUNT=$(darcs diff | wc -l)+test $DIFFCOUNT -eq 0++# add should not work+mkdir S1+cd S1+darcs init --no-working-dir+echo "bonjour" > a+not darcs add a+cd ..++# move and remove should not work+darcs clone R1 R1m --no-working-dir+cd R1m+not darcs remove a+not darcs move a b++# --no-working-dir --working-dir flags should trump each other in the+# same fashion as the rest of darcs+not darcs clone --no-working-dir --with-working-dir R1 R3+not darcs clone --with-working-dir --no-working-dir R1 R4
+ tests/failing-issue2234-rollback-under-tag-with-filename.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash+## Test for issue2234 - darcs doesn't ignore tags when rolling back, so tagged+## patches can't be selected. +##+## Copyright (C) 2012 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+## SOFTWARE.++. lib ++darcs init --repo R++cd R++echo -e "line1\nline2" > f1+cp f1 f2++darcs rec -alm 'Add files'++# Make a couple of changes to two files+sed -i -e 's/1/a/' f1+sed -i -e 's/2/b/' f2++darcs rec -am 'change 1'++# Make another change to one file+sed -i -e 's/1/A/' f2+darcs rec -am 'change 2'++darcs tag footag++# we'd like to cut down the presented patches, by giving a filename should ask+# us about the changes in the first patch+darcs rollback -p '1' f1 | not grep -i 'no patches selected'
+ tests/failing-issue2256-diff-empty-argument.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2256 - Passing an empty string as an argument to darcs diff+## causes a failiure in updateIndex.+## Copyright (C) 2013 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+## SOFTWARE.++. lib++rm -rf R++darcs init --repo R++cd R++echo foo > foo+darcs rec -alm 'add foo'++echo bar >> foo++# This should not do anything.+darcs diff '' 2>&1 > output++# We don't want any output.+[[ ! -s output ]]
+ tests/failing-issue2272-rebase-unsuspend-copes-with-unrecorded-changes.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash+## Test for issue2272 - darcs rebase unsuspend should cope with unrecorded changes.+##+## Copyright (C) 2013 Mark Stosberg+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++darcs init      --repo R        # Create our test repos.+cd R+touch t.txt+darcs add t.txt+darcs record -am 'initial record' t.txt++echo 'original line' > t.txt+darcs record -am 'adding original line' t.txt++# Now make an unrecorded change that's unrelated.+touch 2.txt+darcs add 2.txt++# Suspend the initial patch+darcs rebase suspend -a -p 'adding original line'++# Now, unsuspend that patch. It should succeed despite unrecorded changes being present.+darcs rebase unsuspend -a++# Additional case: An unrecorded change that conflicts with the suspended patch+# This should succeed, but leave conflict markers.+echo 'modified line' >t.txt+darcs rebase unsuspend -a++cd ../
+ tests/failing-issue2303-diagnostic-for-bad-patch-index-permissions.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2303 - diagnostics for patch index should be clear there's a permission problem+##+## Copyright (C) 2013 Mark Stosberg+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++darcs init      --repo R        # Create our test repos.+cd R+touch t.txt+darcs add t.txt+darcs record -am 'initial record' t.txt+darcs optimize enable-patch-index++chmod -w _darcs/patch_index++# We expect this command to fail because the patch index isn't writable+# and give a reasonable diagnostic that explains this. It should mention that+# the permission problem is the _darcs/patch_index directory.+not darcs oblit -a | grep '_darcs/patch_index';+++cd ../
+ tests/failing-issue2383-hunk-edit-fails.sh view
@@ -0,0 +1,76 @@+#!/usr/bin/env bash+## Test for issue2383 hunk-edit/last-regrets being able to put darcs into a+## state that it can't apply the recorded patch+##+## Copyright (C) 2013  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+## SOFTWARE.++. lib                           # Load some portability helpers.++rm -rf R+darcs init --repo R++cd R++cat << EOF > file+-- a comment++data D = C Int+       deriving (Eq, Show)+EOF++darcs rec -alm 'Add file'+++cat << EOF > file+-- another comment++-- a comment++data D = C !Int+       deriving (Eq)+EOF++# Massive hack!+cat << EOF > change+========================== BEFORE (reference) ==========================+data D = C Int+       deriving (Eq, Show)+============================= AFTER (edit) =============================+data D = C !Int+       deriving (Eq, Show)+============================= (edit above) =============================+EOF++# Shell script "editor" that makes the change+cat << EOF > foo+#!/bin/bash+cp change darcs-patch-edit-0+EOF+chmod +x foo++export DARCS_EDITOR='./foo'++# Don't pick the first comment, do initially pick the data type change, then at+# last regrets, go back (k) and edit the hunk (e), before accepting (y) the new+# hunk change (keeping the Show instance).+echo nykeyy | darcs rec -m 'Add strictness annotation to C Int'
+ tests/failing-issue2386-no-trailing-EOL.sh view
@@ -0,0 +1,56 @@+#!/usr/bin/env bash+## Test for issue2386 - no trailing EOF produces spurious diff output+##+## 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+## SOFTWARE.++. lib+darcs init --repo R+cd R++# foo will contain "1\n2\n3"+echo '0: 310a 320a 33' | xxd -r > foo++darcs add foo++# Bad output looked like:+#+# addfile ./foo+# hunk ./foo 1+# -+# +1+# +2+# +3+darcs wh | not grep '^-$'++darcs rec -am 'Add foo'++rm foo++# Bad output looked like:+# hunk ./foo 1+# -1+# -2+# -3+# ++# rmfile ./foo+darcs wh | not grep '^+$'
+ tests/failing-issue2443-timestamp_index_keeps_unrecorded_addfile.sh view
@@ -0,0 +1,35 @@+#!/usr/bin/env bash+## Test for issue2443 -  timestamp index keeps information about files+## added by unrecorded patches+##+## Copyright (C) 2017 Guillaume Hoffmann+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+darcs init R                    # Create our test repos.+cd R+touch a b c                   # add some files+darcs record -lam "Add a b c"+touch d+darcs record -lam "Add d"     # add another file+echo yd | darcs unrecord+not darcs whatsnew            # d is not supposed to be tracked
+ tests/failing-issue2640.sh view
@@ -0,0 +1,17 @@+# issue 2640 - rollback with filename may fail to select any patches++. lib++rm -rf R+darcs init R+cd R+echo text > file1+echo text > file2+darcs record -lam file1and2+echo othertext > file2+darcs record -am onlyfile2+darcs rollback -a file1 | tee LOG+not grep -i 'No patches' LOG+darcs whatsnew | tee LOG+grep text LOG+cd ..
tests/failing-issue390_whatsnew.sh view
@@ -1,8 +1,8 @@ #!/usr/bin/env bash -# For issue390: darcs whatsnew somefile" lstats every file in the working copy and pristine/ directory+# For issue390: darcs whatsnew somefile" lstats every file in the working tree and pristine/ directory -set -ev+. ./lib  if ! test -x "$(which strace)" then echo skipping test since strace was not found
− tests/failing-issue612_repo_not_writable.sh 
@@ -1,39 +0,0 @@-#!/usr/bin/env bash--# Test that darcs fails appropriately when the target repo inventory file is not writable.-# See issue612--. lib--abort_windows--if grep old-fashioned .darcs/defaults; then-  exit 200-fi--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-touch t.t-darcs add t.t-darcs record -am "initial add"-if [ -e _darcs/inventories ]; then-  chmod 0555 _darcs/inventories/*-  chmod 0555 _darcs/inventories-fi-if [ -e _darcs/inventory ]; then-  chmod 0555 _darcs/inventory-fi-cd ..--darcs get temp1 temp2-cd temp2-# this block may fail so we'd better make sure we clean up after-# ourselves to avoid a permissions mess for other tests-trap "cd ..; chmod -R 0755 temp1; rm -rf temp1 temp2" EXIT-echo new >> t.t-darcs record -am "new patch"-not darcs push -a ../temp1 2> log-grep failed log-
− tests/failing-issue68_broken_pipe.sh 
@@ -1,27 +0,0 @@-#!/usr/bin/env bash--# For issue68, 'don't report "resource vanished" when stdout pipe is broken.'--set -ev--rm -rf temp1 # Another script may have left a mess.--darcs init --repodir temp1--cd temp1--date > f-darcs add f-darcs rec -am firstp-for (( i=0 ; i < 500; i=i+1 )); do-  echo $i >> f;-  darcs rec -am p$i-done--darcs changes 2> err | head--touch correcterr--diff correcterr err--cd ..
tests/failing-merging_newlines.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  # Note that this is fixed, the lines marked # BUG HERE # should be moved back into merging_newlines.sh@@ -33,8 +33,7 @@ echo "in tmp2" >> one.txt darcs whatsnew -s | grep M darcs record -A bar -am "add extra line"-darcs annotate -p . -u-darcs push -av > log+darcs push -av 2> log cat log not grep -i conflicts log # BUG HERE
tests/failing-newlines.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 temp2 @@ -20,7 +20,7 @@ cd temp2 echo "in tmp2" >> one.txt darcs record -A bar -am "add extra line"-lines_added=`darcs changes -v --last=1 | grep '\+' | wc -l`+lines_added=`darcs changes -a -v --last=1 | grep '\+' | wc -l` echo $lines_added test $lines_added -eq 1 cd ..
tests/failing-nice-resolutions.sh view
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib  mkdir temp1 cd temp1
tests/failing-pristine-problems.sh view
@@ -25,8 +25,6 @@  . lib                           # Load some portability helpers. -if grep old-fashioned .darcs/defaults; then exit 200; fi- rm -rf foo mkdir foo cd foo
+ tests/failing-rebase-conflicting.sh view
@@ -0,0 +1,26 @@+#!/usr/bin/env bash++. lib++rm -rf R S++darcs init R+cd R+echo R > f+darcs record -l f -a -m 'add f in R'+cd ..+darcs init S+cd S+echo S > f+darcs record -l f -a -m 'add f in S'+cd ../R+darcs pull -a --allow-conflicts ../S+echo X > f+darcs record -l f -a -m 'resolve conflict'+darcs push -a ../S+darcs log -v > ../before_rebase+darcs rebase suspend -a+darcs rebase unsuspend -a+darcs log -v > ../after_rebase+cd ..+diff R/f S/f
tests/failing-record-scaling.sh view
@@ -26,12 +26,15 @@ . lib                  # Load some portability helpers. which strace || exit 200        # This test requires strace(1). +# This test is bogus. Record does indeed access _darcs/inventories,+# namely to store the tentative version of hashed_inventory. This does+# not mean it accesses any other old inventory (it does not).+ rm -rf R                        # Another script may have left a mess. darcs init      --repo R        # Create our test repo. touch R/a-unique-filename-strace -eopen -oR/trace \-  darcs record  --repo R -lam 'A unique commit message.'+strace -eopenat -oR/trace \+  darcs record  --repo R -l a-unique-filename -am 'A unique commit message.' grep a-unique-filename R/trace grep _darcs/hashed_inventory R/trace not grep _darcs/inventories/ R/trace-rm -rf R                        # Clean up after ourselves.
+ tests/filename_with_spaces.sh view
@@ -0,0 +1,10 @@+. lib++darcs init R+cd R++filename="file with spaces in its name"+echo xxx > "$filename"+darcs record -lam "comment"+darcs log -s | grep -c "$filename" | grep -w 1+darcs log -v | grep -c "$filename" | grep -w 2
tests/filepath.sh view
@@ -23,10 +23,8 @@ # local vs remote filepaths # ---------------------------------------------------------------------- -# trick: OS-detection (if needed)-if echo $OS | grep -i windows; then-  echo This test does not work on Windows-else+# Windows does not allow ':' in file names+if ! os_is_windows; then   darcs get temp1 temp2   cd temp2   mkdir -p dir@@ -50,11 +48,11 @@ rm -rf non-darcs  # get accepts --repodir.-darcs get --repodir=temp2 temp1 | grep -i "Finished getting"+darcs get --repodir=temp2 temp1 | grep -i "Finished cloning" test -d temp2/_darcs rm -rf temp2 # get accepts absolute --repodir.-darcs get --repodir="${DIR}/temp2" temp1 | grep -i "Finished getting"+darcs get --repodir="${DIR}/temp2" temp1 | grep -i "Finished cloning" test -d temp2/_darcs  # changes accepts --repodir.@@ -70,19 +68,19 @@ darcs dist --repodir=temp1 | grep -i "Created dist"  # optimize accepts --repodir.-darcs optimize --reorder-patches --repodir=temp1 | grep -i "done optimizing"+darcs optimize reorder --repodir=temp1 | grep -i "done"  # repair accepts --repodir. darcs repair --repodir=temp1 | grep -i "already consistent"  # replace accepts --repodir.-darcs replace --repodir=temp1 foo bar+darcs replace --repodir=temp1 foo bar baz  # setpref accepts --repodir. darcs setpref --repodir=temp1 test echo | grep -i "Changing value of test" -# trackdown accepts --repodir.-darcs trackdown --repodir=temp1 | grep -i "Success!"+# test --linear accepts --repodir.+darcs test --linear --repodir=temp1 | grep -i "Test does not fail on head"  # ---------------------------------------------------------------------- # converting between absolute and relative paths
− tests/get-http-packed-detect.sh 
@@ -1,41 +0,0 @@-#!/usr/bin/env bash-# 2011, by Petr Rockai, Guillaume Hoffmann, public domain--# Tets that darcs get --verbose reports getting a pack when there is one,-# and does not report when there is none or when --no-packs is passed.--. lib--rm -rf R S && mkdir R-cd R-darcs init--darcs show repo > repo-grep "Format: hashed" repo || exit 200 # not supported with oldfashioned repos--for f in `seq 1 200`; do-    echo $f > $f-    darcs rec -lam $f-done--darcs optimize # FIXME the pristine.hashed in the basic tarball has extra files-               # without this step--darcs optimize --http-test -e _darcs/packs/basic.tar.gz-test -e _darcs/packs/patches.tar.gz-cd ..--serve_http # sets baseurl--# check that default behaviour is to get packs-darcs get $baseurl/R S --verbose |grep "Getting packed repository"--# check that it does really not get packs when --no-packs is passed-rm -rf S-darcs get $baseurl/R S --no-packs --verbose |not grep "Getting packed repository"--# check that it does not clam getting packs when there are not-rm -rf S-rm -rf R/_darcs/packs/-darcs get $baseurl/R S --verbose |not grep "Getting packed repository"
− tests/get-http-packed.sh 
@@ -1,30 +0,0 @@-#!/usr/bin/env bash-# Written in 2010 by Petr Rockai, placed in public domain--. lib--rm -rf R S && mkdir R-cd R-darcs init--darcs show repo > repo-grep "Format: hashed" repo || exit 200 # not supported with oldfashioned repos--for f in `seq 1 200`; do-    echo $f > $f-    darcs rec -lam $f-done--darcs optimize # FIXME the pristine.hashed in the basic tarball has extra files-               # without this step--darcs optimize --http-test -e _darcs/packs/basic.tar.gz-test -e _darcs/packs/patches.tar.gz-cd ..--serve_http # sets baseurl-darcs get --packs $baseurl/R S-cd S-rm _darcs/prefs/sources # avoid any further contact with the original repository-darcs check
− tests/get-http.sh 
@@ -1,41 +0,0 @@-#!/usr/bin/env bash-# Written in 2010 by Petr Rockai, placed in public domain--# This file is included as part of the Darcs test distribution,-# which is licensed to you under the following terms:-##-## 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-## SOFTWARE.--. lib--rm -rf R S && mkdir R-cd R-darcs init-echo a > a-darcs rec -lam a-cd ..--serve_http # sets baseurl-darcs get $baseurl/R S-cd S-darcs pull ../R | tee log-grep "No remote changes" log-darcs check
− tests/get.sh 
@@ -1,19 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init-touch t.t-darcs add t.t-darcs record -am "initial add"-darcs changes --context > my_context-DIR=`pwd`-abs_to_context="${DIR}/my_context"-cd ..-rm -rf temp2-darcs get temp1 --context="${abs_to_context}" temp2-darcs changes --context --repo temp2 > repo2_context-diff -u "${abs_to_context}" repo2_context
− tests/get_tag.sh 
@@ -1,87 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs initialize-echo ALL ignore-times >> _darcs/prefs/defaults-echo A > foo-darcs add foo-darcs record -a -m AA -A x-echo B > foo-darcs record -a -m BB -A x-echo C > foo-darcs record -a -m CC -A x-darcs tag -m 1.0 -A x-cp foo foo_version_1.0-echo D > foo-darcs record -a -m DD -A x-echo E > foo-darcs record -a -m EE -A x-echo F > foo-darcs record -a -m FF -A x---# Check that get store commuted patches-cd ..-darcs get --tag 1.0 --repo-name temp2 temp1-cmp temp2/foo temp1/foo_version_1.0-rm -rf temp1 temp2 temp3--mkdir temp1-cd temp1-darcs init-cat > file <<EOF-1-2-3-4-EOF-darcs rec -Ax -alm 'Add file'-cat > file <<EOF-2-3-4-EOF-darcs rec -Ax -alm 'Remove line 1'-cat > file <<EOF-2-4-EOF-darcs rec -Ax -alm 'Remove line 3'-cd ..-mkdir temp2-cd temp2-darcs init-echo y/n/y | tr / \\012 | darcs pull ../temp1-darcs tag -Ax -m Tag-darcs push -a ../temp1-cd ..-darcs get --tag=Tag temp1 temp3-cd temp3-darcs check-cd ..-rm -rf temp1 temp2 temp3--# Check that pending looks ok-mkdir temp1-cd temp1-darcs init-mkdir d-darcs add d-darcs rec -Ax -am 'add d'-darcs tag -Ax t-rmdir d-darcs rec -Ax -am 'rm d'-cd ..-darcs get --tag t temp1 temp2-cd temp2-if [ -f _darcs/patches/pending ]; then-	if grep -v '^[{}]$' _darcs/patches/pending >/dev/null; then-		cat _darcs/patches/pending-		exit 1-	fi-fi-cd ..-rm -rf temp1 temp2
+ tests/git_import_delete_empty_directories.sh view
@@ -0,0 +1,145 @@+#!/usr/bin/env bash+## ensure empty directories get deleted when importing from git+##+## Copyright (C) 2014 Owen Stephens+##               2016 Guillaume Hoffmann+##+## 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+## SOFTWARE.++. lib++rm -rf R1 R2++! read -r -d '' DATA <<'EOF'+blob+mark :1+data 0++reset refs/heads/master+commit refs/heads/master+mark :2+author test <test@example.org> 1500000000 +0000+committer test <test@example.org> 1500000000 +0000+data 19+Add files and dirs+M 100644 :1 file+M 100644 :1 foodir/foo1+M 100644 :1 foodir/foo2++commit refs/heads/master+mark :3+author test <test@example.org> 1500000000 +0000+committer test <test@example.org> 1500000000 +0000+data 12+remove foo2+from :2+D foodir/foo2++commit refs/heads/master+mark :4+author test <test@example.org> 1500000000 +0000+committer test <test@example.org> 1500000000 +0000+data 21+Delete foo1 and file+from :3+D foodir/foo1+D file++EOF++echo "$DATA" | darcs convert import R1++darcs init --repo R2+cd R2++echo yydy | darcs pull ../R1++# Ensure we delete the file (but not the directory!)+[[ -d foodir && ! -e foodir/foo2 ]]++darcs pull -a ../R1++# Make sure the folder is now deleted.+[[ ! -d foodir ]]++cd ..++# only continue if git present+git --version | grep -i "git version"   || exit 200++git init gitsource+cd gitsource+mkdir -p dir1/dir2/dir3+echo "i am so deep" > dir1/dir2/dir3/f+mkdir dir4+echo "blabla" > dir4/g+echo "some other file" > h+git add .+git commit -m "blabla"+rm dir1/dir2/dir3/f+git add --all .+git commit -m "deleted f"+rm dir4/g+git add --all .+git commit -m "deleted g"+git clean -fd  # delete dir1 and dir4+cd ..+(cd gitsource  && git fast-export --all) | darcs convert import darcsmirror++function wcDiff() {+   diff --exclude=_darcs --exclude=.git "$1" "$2"+}++wcDiff gitsource darcsmirror+darcs check --repodir=darcsmirror # ensure repo is consistent++# ensure dir is deleted after a file move out of it (a common case)+# and that a dir is created when moving to it (also a common case)++git init gitsource2+cd gitsource2+mkdir -p dir1/+echo "i want to move" > dir1/f+echo "me too!!" > g+echo "12345" > h+echo "67890" > i+git add .+git commit -m "initial commit"+mv dir1/f f+git add --all .+git commit -m "move dir1/f to f"+mkdir dir2+mv g dir2/g+git add --all .+git commit -m "move g to dir2/"+# the following commit could be problematic with darcs import,+# with the addfile hunk ending up between both move hunks.+mkdir dir3+mv h dir3/h+mv i dir3/i+git add --all .+git commit -m "move h and i to dir2/"+git clean -fd+cd ..+(cd gitsource2  && git fast-export --all -M) | darcs convert import darcsmirror2    # -M to generate file moves data++wcDiff gitsource2 darcsmirror2+darcs check --repodir=darcsmirror2 # ensure repo is consistent
+ tests/git_quoted_filenames.sh view
@@ -0,0 +1,92 @@+#!/usr/bin/env bash+## Test for issue2489 - convert import/export with spaces in paths+##+## Copyright (C) 2014 Owen Stephens+##               2016 Guillaume Hoffmann+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++# test http://bugs.darcs.net/issue2489 :+# correctly import quoted paths++function createFiles () {+    mkdir "i have spaces"+    echo "some contents" > "i have spaces/me too"+    echo "other contents" > "more spaces please"+    newline=$(echo -e 'a\nb')+    quoted='"quoted'+    echo testing1 > "$newline"+    echo testing2 > $quoted+}++function wcDiff() {+   diff --exclude=_darcs --exclude=.git "$1" "$2"+}++commitMsg="some files and dirs that need quoting"++# Filenames containing double quotes are forbidden in Windows 10+# Although they can be written using raw NTFS APIs, it's probably+# not worth trying to support them. IO operations in the standard+# Haskell library don't support them either.+# https://msdn.microsoft.com/en-us/library/windows/desktop/aa365247%28v=vs.85%29.aspx+abort_windows++# only run if git present+git --version | grep -i "git version"   || exit 200++rm -rf gitsource gitmirror darcssource darcsmirror++git init gitsource+cd gitsource++createFiles+git add .+git commit -m "$commitMsg"++cd ..++(cd gitsource && git fast-export --all) > gitexport+darcs convert import darcsmirror < gitexport++# working copies should be the same+wcDiff gitsource darcsmirror++# darcs to git direction++darcs init darcssource+cd darcssource+createFiles++# TODO: check this for testing on windows.+darcs add --reserved-ok $quoted++darcs rec -lam "$commitMsg"++git init ../gitmirror+darcs convert export > ../darcsexport+(cd ../gitmirror && git fast-import && git checkout) < ../darcsexport+cd ..++# working copies should be the same+wcDiff darcssource gitmirror
+ tests/git_rename_and_copy_files.sh view
@@ -0,0 +1,63 @@+#!/usr/bin/env bash+## ensure empty directories get deleted when importing from git+##+## Copyright (C) 2014 Owen Stephens+##               2016 Guillaume Hoffmann+##+## 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+## SOFTWARE.++. lib++! read -r -d '' DATA <<'EOF'+blob+mark :1+data 8+testing++reset refs/heads/master+commit refs/heads/master+mark :2+author CommiterName <me@example.org> 1307452813 +0100+committer CommiterName <me@example.org> 1307452813 +0100+data 6+add a+M 100644 :1 a++commit refs/heads/master+mark :3+author CommiterName <me@example.org> 1307452821 +0100+committer CommiterName <me@example.org> 1307452821 +0100+data 19+Copy, rename, copy+from :2+C "a" "c"+R "a" "b"+C b d+C b a path/with spaces++EOF++rm -rf R+echo "$DATA" | darcs convert import R+cd R++[[ -e c && -e b && -e d && ! -e a && -e "a path/with spaces" ]]+[[ $(darcs log --count) -eq 2 ]]
+ tests/git_rename_dir.sh view
@@ -0,0 +1,62 @@+#!/usr/bin/env bash+## ensure empty directories get deleted when importing from git+##+## Copyright (C) 2014 Owen Stephens+##               2016 Guillaume Hoffmann+##+## 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+## SOFTWARE.++. lib++! read -r -d '' DATA <<'EOF'+blob+mark :1+data 8+testing++reset refs/heads/master+commit refs/heads/master+mark :2+author CommiterName <me@example.org> 1307452813 +0100+committer CommiterName <me@example.org> 1307452813 +0100+data 10+add dir/a+M 100644 :1 dir/a++commit refs/heads/master+mark :3+author CommiterName <me@example.org> 1307452821 +0100+committer CommiterName <me@example.org> 1307452821 +0100+data 24+copy, rename, copy dirs+from :2+C "dir" "dir2"+R "dir" "dir3/dir4"+C "dir3/dir4" "dir4"++EOF++rm -rf R+echo "$DATA" | darcs convert import R+cd R+[[ -e dir2 && -e dir3 && -e dir4 && (! -e dir) && -e dir2/a && -e dir3/dir4/a+  && -e dir4/a ]]+[[ $(darcs log --count) -eq 2 ]]
tests/gzcrcs.sh view
@@ -30,7 +30,7 @@  . lib                  # Load some portability helpers. rm -rf maybench-crc-gunzip -c $TESTDATA/maybench-crc.tgz | tar xf -+unpack_testdata maybench-crc cd maybench-crc not darcs gzcrcs --check darcs gzcrcs --repair
tests/harness.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -vex+. ./lib  # Print some stuff out for debugging if something goes wrong: echo $HOME
tests/hashed_inventory.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib  # We'd just use `diff -x _darcs -r' if -x was portable. diffx () {@@ -28,13 +28,14 @@ }  +rm -rf temp1 temp2 temp3 temp4 temp5  mkdir temp1 cd temp1-darcs init --hashed+darcs init touch foo darcs add foo-darcs rec -m t1 -a -A tester+darcs rec -m t1 -a echo 1 >> foo darcs what -s | grep -v No\ changes darcs what -l | grep -v No\ changes@@ -52,7 +53,7 @@ cd temp3 darcs changes cp _darcs/hashed_inventory inv-darcs optimize+darcs optimize clean diff -c inv _darcs/hashed_inventory rm inv makepristine@@ -64,7 +65,7 @@ diff -rc temp2/pristine temp3/pristine  cd temp1-darcs record -a -A tester -m t2+darcs record -a -m t2 darcs push ../temp2 -a darcs push ../temp3 -a makepristine@@ -83,7 +84,7 @@  cd temp1 date > foo-darcs record -a -A tester -m t3+darcs record -a -m t3 makepristine cd ../temp2 darcs pull -a@@ -99,7 +100,7 @@ diff -rc temp2/pristine temp3/pristine  cd temp1-darcs put ../temp4+darcs get . ../temp4 cd .. cd temp4 makepristine@@ -111,7 +112,7 @@ cd temp1 darcs tag -A tagger -m atag darcs check-darcs optimize+darcs optimize clean darcs check darcs changes | grep t1 cd ..@@ -121,11 +122,11 @@ darcs add foobarpatch darcs record -a -A silly -m foobarpatch darcs check-darcs optimize+darcs optimize clean darcs check darcs pull -a ../temp1 darcs check-darcs optimize --reorder-patches+darcs optimize reorder darcs check grep 'Starting with inventory' _darcs/hashed_inventory cd ..@@ -139,7 +140,7 @@ cd temp4 darcs pull -p foobarpatch -a ../temp3 darcs pull -a ../temp1-darcs optimize --reorder+darcs optimize reorder darcs check darcs push ../temp1 cd ..
tests/hidden_conflict.sh view
@@ -1,11 +1,13 @@ #!/bin/sh -set -ev+. ./lib -rm -rf temp1 temp2+# this test fails for darcs-1 repos+skip-formats darcs-1+ mkdir temp1 cd temp1-darcs init --darcs-2+darcs init echo first > a darcs add a darcs record -am 'first'@@ -25,8 +27,6 @@ cd ..  cd temp1-darcs pull -a ../temp2 | grep conflict+darcs pull -a ../temp2 2>&1 | grep conflict grep third a cd ..--rm -rf temp1 temp2
tests/hidden_conflict2.sh view
@@ -1,17 +1,11 @@ #!/usr/bin/env bash-set -ev+. ./lib  # A test for a missed resolution, inspired by bug #10 in RT  rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-cd ..-mkdir temp2-cd temp2-darcs init-cd ..+darcs init temp1+darcs init temp2  # set up temp1 cd temp1@@ -66,5 +60,3 @@ # now mark-conflicts shouldn't find any unmarked conflicts darcs mark-conflicts | grep "No conflicts to mark" cd ..--rm -rf temp1 temp2
+ tests/hijack.sh view
@@ -0,0 +1,112 @@+#!/usr/bin/env bash++# Testing patch hijack interactions++. lib++rm -rf temp1+# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++# create some simple patches by somebody else+cd temp1+touch 1 2 3 4 5+darcs add *+darcs record -a --author you 1 -m 'patch1a'+darcs record -a --author you 2 -m 'patch2a'+darcs record -a --author you 3 -m 'patch3a'+darcs record -a --author you 4 -m 'patch4a'+darcs record -a --author you 5 -m 'patch5a'+cd ..++# try amending a patch+cd temp1+echo yn | darcs amend -p patch5 -m 'patch5b' | grep "Amend anyway"+darcs log | grep patch5+darcs log | not grep patch5b+echo yy | darcs amend -p patch5 -m 'patch5b' | grep "Amend anyway"+darcs log | grep patch5b+cd ..++# try some unsuspending+cd temp1+# ...hijack one+# abort everywhere: need selectchanges for smarter behaviour+echo yyn  | darcs rebase suspend   --all+darcs log | grep 'patch1a'  # nothing suspended+darcs log | grep 'patch5b'  # nothing suspended+not darcs rebase unsuspend --all # not in progress+# ...hijack all+echo ya   | darcs rebase suspend   --all+darcs log | not grep 'patch1a'+darcs log | not grep 'patch5b'+darcs rebase unsuspend --all+darcs log |     grep 'patch1a'+darcs log |     grep 'patch5b'+cd ..++# make some conflicting patches in another repo+mkdir temp2+cd temp2+darcs init+touch 1 2 3 4 5+darcs add *+darcs record -a --author thirdperson 1 -m 'patch1c'+darcs record -a --author thirdperson 2 -m 'patch2c'+darcs record -a --author thirdperson 3 -m 'patch3c'+darcs record -a --author thirdperson 4 -m 'patch4c'+darcs record -a --author thirdperson 5 -m 'patch5c'+cd ..++# try suspending via rebase pull+cd temp1+# first 'y' is for a "repositories seem to be unrelated" prompt+echo yayyn | darcs rebase pull ../temp2 --all+darcs log | grep 'patch1a'  # nothing suspended or pulled+darcs log | grep 'patch5b'  # nothing suspended or pulled+not darcs rebase unsuspend --all # not in progress++echo yayyyyyy | darcs rebase pull ../temp2 --all+darcs log | not grep 'patch1a'+darcs log | not grep 'patch5b'++darcs obliterate -a -p 'patch1c'+darcs obliterate -a -p 'patch2c'+darcs obliterate -a -p 'patch3c'+darcs obliterate -a -p 'patch4c'+darcs obliterate -a -p 'patch5c'++darcs rebase unsuspend --all+darcs log |     grep 'patch1a'+darcs log |     grep 'patch5b'+cd ..++# try suspending via rebase apply++cd temp2+darcs obliterate -a -o c.dpatch+cd ..++cd temp1+echo ayyn | darcs rebase apply ../temp2/c.dpatch --all+darcs log | grep 'patch1a'  # nothing suspended or pulled+darcs log | grep 'patch5b'  # nothing suspended or pulled+not darcs rebase unsuspend --all # not in progress++echo ayyyyyy | darcs rebase apply ../temp2/c.dpatch --all+darcs log | not grep 'patch1a'+darcs log | not grep 'patch5b'++darcs obliterate -a -p 'patch1c'+darcs obliterate -a -p 'patch2c'+darcs obliterate -a -p 'patch3c'+darcs obliterate -a -p 'patch4c'+darcs obliterate -a -p 'patch5c'++darcs rebase unsuspend --all+darcs log |     grep 'patch1a'+darcs log |     grep 'patch5b'+cd ..
tests/hunk-editor.sh view
@@ -34,7 +34,7 @@ darcs record -lam "version1"  echo 'version2' > file-(echo e ; echo y ; echo n) | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5"+echo eyny | DARCS_EDITOR="sed -i -e s/version2/version1.5/" darcs record -m "version1.5"  cat > expected <<EOF hunk ./file 1
tests/ignoretimes.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib  rm -rf temp1 @@ -11,17 +11,16 @@ darcs rec -Ax -alm p1 echo -e 'foo\nbar\nwibble' > f darcs rec -Ax -alm p2-sleep 1 # ensure the timestamps would differ after this change alone echo -e 'baz\nbar\nwibble' > f -# check that wh (without --ignore-times) sees the change now+# check that wh (without --ignore-times) sees the change darcs wh > whatsnew grep 'foo' whatsnew -# the problematic unpull-darcs unpull --last 1 -a --ignore-times+# the (once) problematic unpull+darcs unpull --last 1 -a -# whatsnew will now think there are no changes without --ignore-times+# whatsnew no longer thinks there are no changes without --ignore-times darcs wh > whatsnew grep 'foo' whatsnew
− tests/illegal_mv.sh 
@@ -1,21 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp-mkdir temp-cd temp--darcs initialize-echo text > afile.txt-darcs add afile.txt-darcs record --author me --all --no-test --name init-mkdir d-echo The following mv should fail, since d isnt in the repo.-if darcs mv afile.txt d/afile.txt; then-false-fi--# Now clean up.-cd ..-rm -rf temp-
− tests/impossible_unrevert.sh 
@@ -1,33 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp-mkdir temp-cd temp-darcs init-echo ALL ignore-times > _darcs/prefs/defaults-echo a > foo-darcs add foo-darcs record -a -m aa -A test-echo b > foo-echo y | darcs revert -a-echo y/d/y | tr / \\012 | darcs unrecord-# since the unrevert is impossible, we should fail if it succeeds...-echo y | darcs unrevert && exit 1 || true--# now let's try a possible unrevert, just for fun...-echo b >> foo-darcs record -a -m bb -A test-echo f/b | tr / \\012 > foo-darcs record -a -m 'aaa becomes f' -A test-date >> foo-echo y | darcs revert -a-echo y/d/y | tr / \\012 | darcs unpull-# Now add the date back on at the end:-echo y | darcs unrevert-echo 'M ./foo +1' > correct_summary-darcs whatsnew --dont-look-for-adds --summary > actual_summary-diff -c correct_summary actual_summary--cd ..-rm -rf temp
+ tests/inherit-default.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for inherit-default mechanism++. lib+rm -rf U V R1 R2 R3 S++echo 'ALL inherit-default' >> .darcs/defaults++# upstream repos+darcs init U+darcs init V++# branches of U+darcs clone U R1+darcs clone R1 R2+darcs clone R2 R3++# branches of V+darcs clone V S++not test -e U/_darcs/prefs/defaultrepo+not test -e V/_darcs/prefs/defaultrepo+test U = $(cat R1/_darcs/prefs/defaultrepo | xargs basename)+test U = $(cat R2/_darcs/prefs/defaultrepo | xargs basename)+test U = $(cat R3/_darcs/prefs/defaultrepo | xargs basename)+test V = $(cat S/_darcs/prefs/defaultrepo | xargs basename)++cd R3+for cmd in pull push send; do+  # set-default works by setting the defaultrepo of the remote repo+  darcs $cmd ../S --set-default+  test V = $(cat _darcs/prefs/defaultrepo | xargs basename)+  # but not if remote repo has no defaultrepo+  darcs $cmd ../U --set-default+  test U = $(cat _darcs/prefs/defaultrepo | xargs basename)+done+cd ..
tests/init.sh view
@@ -16,4 +16,20 @@ darcs init --repodir temp2 test -d temp2/_darcs -rm -rf temp1 temp2+# Checking that `darcs init x` works++not darcs init x y            # refuse when 2 arguments are given+not darcs init x --repodir y  # refuse for the same reason+darcs init x++rm -rf temp1 temp2 x++## issue1266 - attempting to initialize a repository inside+## another repository should cause a warning, because while perfectly+## legitimate, it is likely to be accidental.++rm -rf out+darcs init --repodir temp1+darcs init --repodir temp1/temp2 2>&1 | tee out+grep -i WARNING out   # A warning should be printed.+rm -rf temp1 out
tests/invalid_pending_after_mv_to_self.sh view
@@ -2,7 +2,7 @@  # A regression test for issue567 -set -ev+. ./lib  rm -rf temp mkdir temp
− tests/issue1012_unrecord_remove.sh 
@@ -1,18 +0,0 @@-#!/usr/bin/env bash-set -ev-rm -rf temp1-mkdir temp1-cd temp1-darcs --version-darcs init-echo temp1 >File.hs-darcs add File.hs-darcs record File.hs -a -m "add File"-rm File.hs-darcs record -a -m "rm File"-darcs cha-darcs unrecord -p "rm File" -a-darcs cha-darcs record -a -m "re-rm File"-cd ..-rm -rf temp1
+ tests/issue1014_identical_patches.sh view
@@ -0,0 +1,67 @@+#!/usr/bin/env bash++. ./lib++# test fails for these obsolete formats:+skip-formats darcs-1 darcs-2++rm -rf a ab abc ac b bc acb base++# Set up a base repo. Our experiment will start from this point+mkdir base+cd base+darcs init+printf "Line1\nLine2\nLine3\n" > foo+darcs rec -alm Base+cd ..++# Now we want to record patch A, which will turn "Line2" into "Hello"+darcs get base a+cd a+printf "Line1\nHello\nLine3\n" > foo+darcs rec -am A+cd ..++# Make B the same as A+darcs get base b+cd b+printf "Line1\nHello\nLine3\n" > foo+darcs rec -am B+cd ..++# Now we make a patch C that depends on A+darcs get a ac+cd ac+printf "Line1\nWorld\nLine3\n" > foo+darcs rec -am C+cd ..++# Merge A and B+darcs get a ab+cd ab+darcs pull -a ../b --allow-conflicts+cd ..++# And merge in C too+darcs get ab abc+cd abc+darcs revert -a+darcs pull -a ../ac --allow-conflicts+cd ..++# Now we can pull just B and C into base+darcs get base bc+cd bc+darcs pull ../abc -ap 'B|C' --allow-conflicts+cd ..++# Now we have base, B and C in a repository.  At this point we're correct.++# Let's try merging AC with BC now, here we discover a bug.++darcs get ac acb+cd acb+darcs pull -a ../bc+darcs changes+test `darcs changes | fgrep -c '* C'` -eq 1+cd ..
tests/issue1017_whatsnew_stack.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 mkdir temp1
tests/issue1039.sh view
@@ -60,9 +60,9 @@     darcs record -a -m "change b $i" done -echo no | darcs send --all --to=random@random --sendmail-command=false ../temp1-echo yes | not darcs send --all --to=random@random --sendmail-command=false ../temp1-not darcs send --all --to=random@random --sendmail-command=false --allow-unrelated-repos ../temp1+echo no | darcs send --mail --all --to=random@random --sendmail-command=false ../temp1+echo yes | not darcs send --mail --all --to=random@random --sendmail-command=false ../temp1+not darcs send --mail --all --to=random@random --sendmail-command=false --allow-unrelated-repos ../temp1 cd ..  rm -rf temp1 temp2
− tests/issue1041.sh 
@@ -1,13 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1 temp2--# this should fail, since temp1 doesn't exist...-not darcs get temp1 temp2--# verify that temp2 wasn't created-not cd temp2--rm -rf temp1 temp2
tests/issue1043_geteff_a.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp1 temp2  # creating the fork point
tests/issue1043_geteff_b.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib rm -rf temp1 temp2  # creating the fork point
+ tests/issue1057-pull-from-current-repo-via-symlink.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash+## Test for issue1057 - when pulling from a symlink to the current+## repository, Darcs should detect that it *is* the current repo.+##+## Copyright (C) 2008  Thorkil Naur+##+## 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+## SOFTWARE.++. lib++rm -rf repo srepo+darcs init repo+ln -s repo srepo+DIR=`pwd`+cd srepo+not darcs pull -a "$DIR/repo" 2>&1 | tee err >&2+grep 'Can.t pull from current repository' err+not darcs pull -a "$DIR/srepo" 2>&1 | tee err >&2+grep 'Can.t pull from current repository' err+cd ..
− tests/issue1057.sh 
@@ -1,48 +0,0 @@-#!/usr/bin/env bash-## Test for issue1057 - when pulling from a symlink to the current-## repository, Darcs should detect that it *is* the current repo.-##-## Copyright (C) 2008  Thorkil Naur-##-## 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-## SOFTWARE.--. lib--rm -rf temp-mkdir temp-cd temp--mkdir repo-cd repo-darcs init-cd ..--ln -s repo srepo-cd srepo-DIR=`pwd`-echo $DIR-not darcs pull --debug -a "$DIR" 2> out-cat out-grep 'Can.t pull from current repository' out-cd ..--cd ..-rm -rf temp
tests/issue1078_symlink.sh view
@@ -2,20 +2,26 @@  . lib -if echo $OS | grep -i windows; then-    echo this test does not work on windows because-    echo windows does not have symlinks-    exit 0-fi- rm -rf temp1 temp2 mkdir temp1 ln -s temp1 temp2+DIR1="$(pwd)/temp1"+DIR2="$(pwd)/temp2"+ cd temp2 darcs init-touch a b-DIR=`pwd`-darcs add "${DIR}/../temp1/a" # should work, just to contrast with the case below-darcs add "${DIR}/b"          # this is the case we are testing for+touch a b c d e f g h i j+darcs add "$DIR1/../temp1/a"+darcs add "$DIR1/../temp2/b"+darcs add "$DIR1/c"+darcs add "$DIR2/../temp1/d"+darcs add "$DIR2/../temp2/e"+darcs add "$DIR2/f"+darcs add "../temp1/g"+darcs add "../temp2/h"+# This should definitely work:+darcs add "i"+# ... as should this one:+mkdir dir+darcs add dir/../j cd ..-rm -rf temp1 temp2
tests/issue1101.sh view
@@ -1,9 +1,6 @@ #!/usr/bin/env bash-set -ev -DARCS_EDITOR=echo-export DARCS_EDITOR-export SENDMAIL=`which true`+. ./lib  rm -rf temp1 temp2 mkdir temp1 temp2@@ -19,10 +16,13 @@ darcs record -a -m add_foo_bar -A x  # Test that --cc is also printed as recipient in case of success-darcs send --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com+export SENDMAIL=true+darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 >out+grep 'foo@example.com' out  # Test that --cc is also printed as recipient in case of error-darcs send --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>&1|grep -i foo@example.com+export SENDMAIL=false+not darcs send --mail --author=me -a --to=random@random --cc=foo@example.com ../temp2 2>err+grep 'foo@example.com' err  cd ..-rm -rf temp1 temp2
tests/issue1105.sh view
@@ -1,4 +1,5 @@ #!/usr/bin/env bash+#issue1105: defaults file silently rejects abbreviations  . lib @@ -8,30 +9,42 @@ darcs init darcs changes +# note: extra argument for an option is just a warning echo changes summary > _darcs/prefs/defaults darcs changes echo changes summary arg > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'takes no argument' LOG echo ALL summary > _darcs/prefs/defaults darcs changes echo ALL summary arg > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'takes no argument' LOG +# note: missing required option argument is an error echo changes last 10 > _darcs/prefs/defaults darcs changes echo changes last > _darcs/prefs/defaults-not darcs changes+not darcs changes 2> LOG+grep 'requires an argument' LOG echo ALL last 10 > _darcs/prefs/defaults darcs changes echo ALL last > _darcs/prefs/defaults-not darcs changes+not darcs changes 2> LOG+grep 'requires an argument' LOG +# note: unknown option is just a warning echo changes author me > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'has no option' LOG+echo changes author me > _darcs/prefs/defaults+darcs changes 2> LOG+grep 'has no option' LOG echo ALL author me > _darcs/prefs/defaults darcs changes echo ALL unknown > _darcs/prefs/defaults-not darcs changes+darcs changes 2> LOG+grep 'has no option' LOG  cd .. rm -rf temp
− tests/issue1110_get_hashed.sh 
@@ -1,10 +0,0 @@-#!/usr/bin/env bash-set -ev-rm -rf temp1 temp1-h--gunzip -c $TESTDATA/many-files--old-fashioned-inventory.tgz | tar xf --mv many-files--old-fashioned-inventory temp1--darcs get temp1 temp1-h-test -e temp1-h/_darcs/hashed_inventory-rm -rf temp1 temp1-h
− tests/issue1111-pull-intersection.sh 
@@ -1,66 +0,0 @@-#!/usr/bin/env bash-# This file is included as part of the Darcs test distribution,-# which is licensed to you under the following terms:-#-## 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-## SOFTWARE.--. lib-# This test script is in the public domain.-# This file is included as part of the Darcs test distribution,-# which is licensed to you under the following terms:-#---rm -rf temp1 temp2 temp3--mkdir temp1-cd temp1-darcs initialize-echo A > A-darcs add A-darcs record -a -m Aismyname-echo B > B-darcs add B-darcs record -a -m Bismyname--cd ..-darcs get temp1 temp2--cd temp2-darcs obliterate --last 1 -a-echo C > C-darcs add C-darcs record -a -m Cismyname-cd ..--mkdir temp3-cd temp3-darcs init-darcs pull -a -v --intersection ../temp1 ../temp2--darcs changes > out-cat out-grep Aismyname out-not grep Bismyname out-not grep Cismyname out-cd ..--rm -rf temp1 temp2 temp3
− tests/issue1139-diff-last.sh 
@@ -1,31 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp-$$-mkdir temp-$$-cd temp-$$-set -e-darcs initialize-echo text > foo-darcs add foo-darcs rec -am 'add foo'-darcs annotate -p .--echo newtext > foo-darcs record -am 'modify foo'--darcs diff --no-unified --store-in-mem --last=1 > out1-cat out1-grep text out1-grep foo out1--darcs diff --no-unified --last=1 > out-cat out-grep text out-grep foo out--diff -u out1 out--cd ..--rm -rf temp-$$
− tests/issue1139-diff-with-no-args.sh 
@@ -1,29 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp-$$-mkdir temp-$$-cd temp-$$-set -e-darcs initialize-echo text > foo-darcs add foo-darcs record -am 'add foo'-echo newtext > foo-darcs wh--darcs diff --no-unified --store > out1-cat out1-grep text out1-grep foo out1--darcs diff --no-unified > out-cat out-grep text out-grep foo out--diff out out1--cd ..--rm -rf temp-$$
− tests/issue1162_add_nonexistent_slash.sh 
@@ -1,16 +0,0 @@-#!/bin/sh--set -ev--not () { "$@" && exit 1 || :; }--rm -rf temp-mkdir temp-cd temp-darcs init-not darcs add a/ 2> err-cat err-grep 'File a does not exist!' err-cd ..--rm -rf temp
+ tests/issue1196_whatsnew_falsely_lists_all_changes.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash+. ./lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo utrecht > aargh+darcs add aargh++not darcs wh foo foo/../foo/.++cd ..+rm -rf temp1+
+ tests/issue121-amend-ask-deps.sh view
@@ -0,0 +1,72 @@+#!/usr/bin/env bash+## Test for issue121 - amend-record --ask-deps+##+## Copyright (C) 2009 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.+rm -rf R+darcs init      --repo R        # Create our test repos.++cd R+touch a+darcs add a+darcs rec -am 'add a'+(echo '1' ; echo '1' ; echo '1') > a+darcs rec -am 'patch X'+(echo '2' ; echo '1' ; echo '1') > a+darcs rec -am 'patch Y'+(echo '2' ; echo '1' ; echo '2') > a+darcs rec -am 'patch Z'++darcs obliterate --dry-run --patch 'patch Y' | not grep 'patch Z'++# add explicit dependency on 'patch Z'+echo 'yyd' | darcs amend --ask-deps++darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z'++# remove the explicit dependency; note that it shouldn't ask+# us about the one we dropped+echo 'yyd' | darcs amend --ask-deps++darcs obliterate --dry-run --patch 'patch Y' | not grep 'patch Z'++# add another independent patch+touch b+darcs rec -lam 'patch B'++# add explicit dependency on 'patch B' and 'patch Y'+echo 'yyyd' | darcs amend --patch 'patch Z' --ask-deps++darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z'+darcs obliterate --dry-run --patch 'patch B' | grep 'patch Z'++# remove the one on 'patch B', keep that on 'patch Y';+# note that we aren't offered to re-add 'patch B'++echo 'yyd' | darcs amend --patch 'patch Z' --ask-deps++darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z'+darcs obliterate --dry-run --patch 'patch B' | not grep 'patch Z'++cd ..
− tests/issue121.sh 
@@ -1,45 +0,0 @@-#!/usr/bin/env bash-## Test for issue121 - amend-record --ask-deps-##-## Copyright (C) 2009 Ganesh Sittampalam-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R-darcs init      --repo R        # Create our test repos.--cd R-touch a-darcs add a-darcs rec --ignore-times -am 'add a'-(echo '1' ; echo '1' ; echo '1') > a-darcs rec --ignore-times -am 'patch X'-(echo '2' ; echo '1' ; echo '1') > a-darcs rec --ignore-times -am 'patch Y'-(echo '2' ; echo '1' ; echo '2') > a-darcs rec --ignore-times -am 'patch Z'--darcs obliterate --dry-run --patch 'patch Y' | not grep 'patch Z'--echo 'yy' | darcs amend-rec --ask-deps--darcs obliterate --dry-run --patch 'patch Y' | grep 'patch Z'
tests/issue1210-no-global-cache-in-sources.sh view
@@ -23,11 +23,9 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev--. lib+. ./lib -cacheDir=$HOME/.darcs/cache+cacheDir=$HOME/.cache/darcs  rm -rf R S darcs init  --repo R
tests/issue1224_convert-darcs2-repository.sh view
@@ -25,7 +25,7 @@ ## SOFTWARE.  # this test is not relevant for other than darcs 2 repositories-grep darcs-2 $HOME/.darcs/defaults || exit 200+only-format darcs-2  . lib @@ -37,7 +37,7 @@ darcs record --name=add_file.txt --author=me --no-test -a --repodir R  # This should fail with repository already in darcs-2 format.-echo "I understand the consequences of my action" > ack+echo "yes" > ack not darcs convert temp/repo-2 temp/repo-2-converted < ack  rm -rf R
− tests/issue1248.sh 
@@ -1,12 +0,0 @@-#!/usr/bin/env bash-## Test for issue1248 - darcs doesn't handle darcs 1 repos with compressed-## inventories-##-## Placed into the public domain by Ganesh Sittampalam, 2009--. lib--gunzip -c  $TESTDATA/oldfashioned-compressed.tgz | tar xf --cd oldfashioned-compressed-darcs optimize --upgrade-darcs check
tests/issue1269_setpref_predist.sh view
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib  not () { "$@" && exit 1 || :; }
tests/issue1277-repo-format.sh view
@@ -33,14 +33,14 @@  echo impossible >> _darcs/format  echo 'Example content.' > f  not darcs add f > log 2>&1- grep "Can't understand repository format" log+ grep -i "read repository.*unknown format" log  not darcs whatsnew > log 2>&1- grep "Can't understand repository format" log+ grep -i "read repository.*unknown format" log  not darcs init > log 2>&1  grep "You may not run this command in a repository" log- grep "Can't understand repository format" log+ grep -i "read repository.*unknown format" log  cd ..  not darcs whatsnew --repodir R2 > log 2>&1  grep "R2 looks like a repository directory," log- grep "Can't understand repository format" log+ grep -i "read repository.*unknown format" log cd ..
− tests/issue1290-diff-index.sh 
@@ -1,42 +0,0 @@-#!/usr/bin/env bash-## Test for issue1290 - darcs diff --index-##-## Copyright (C) 2010 Eric Kow-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--cd R- echo '1' > f- darcs record -lam 'one'- echo '2' > f- darcs record -lam 'two'- echo '3' > f- darcs record -lam 'three'- echo '4' > f- darcs record -lam 'four'- darcs diff --no-unified --from-patch one --to-patch two > d1- darcs diff --no-unified --index=3-4 > d2 # the numbers go backwards- diff -q d1 d2-cd ..
+ tests/issue1316-2.sh view
@@ -0,0 +1,51 @@+#!/usr/bin/env bash+## Test for issue1316 - junk left in pending+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++# this test is a slightly more complicated variant on failing-issue1316+# it also uses darcs commands to test rather than grepping pending.++. lib                           # Load some portability helpers.++rm -rf R+darcs init      --repo R        # Create our test repos.++cd R++touch X+darcs rec -lam 'X'++darcs mv X Y+darcs rec -am 'Y'++rm Y+echo 'y' | darcs amend -a++# the bug is that addfile Y shows up in pending+# if pending is empty as it should be, then since+# whatsnew doesn't have -l, it shouldn't report anything+# even after we touch Y.+touch Y+not darcs whatsnew+
+ tests/issue1316.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+## Test for issue1316 - Removing a directory+##+## Copyright (C) 2009 Nathan Gray, Eric Kow+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++rm -rf R+darcs init      --repo R        # Create our test repos.++cd R+mkdir d                         # Change the working tree.+darcs record -lam 'Add a directory'+rm -rf d+echo y | darcs amend-record -m 'initial' --all+not grep adddir _darcs/patches/pending
+ tests/issue1325_pending_minimisation.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+## Test for issue1325 - hunk patches interfere with pending patch+## minimisation+##+## Copyright (C) 2009 Marco Túlio Gontijo e Silva, Eric Kow+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.+darcs init   --repo=R+darcs init   --repo=S++# this is expected to pass regardless of issue1325+# and is here to provide contrast+cd R+touch file+darcs add file+darcs record -am ' file'+mkdir b+darcs add b+darcs mv  file b+rm -r b+darcs whatsnew | not grep adddir+cd ..++# this is/was the failing part of issue1325+cd S+echo file > file                # we need a hunk to make this interesting+darcs add file+darcs record -am ' file'+mkdir b+darcs add b+darcs mv  file b+rm -r b+darcs whatsnew | not grep adddir+cd ..
+ tests/issue1327.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash+. ./lib++# test fails for these obsolete formats:+skip-formats darcs-1 darcs-2++# See issue1327.+# results in the error:+# patches to commute_to_end does not commutex (1) at src/Darcs/Patch/Depends.hs:452+++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+echo fileA version 1 > fileA+echo fileB version 1 > fileB+darcs add fileA fileB+darcs record --author foo@bar --all -m "Add fileA and fileB"+echo fileA version 2 > fileA+darcs record --author foo@bar --all -m "Modify fileA"+cd ..+darcs get temp1 temp2+cd temp2+darcs obliterate -p "Modify fileA" --all+darcs unrecord -p "Add fileA and fileB" --all+darcs record --author foo@bar --all fileA -m "Add just fileA"+cd ../temp1+darcs pull --all ../temp2+echo yy | darcs obliterate --dont-prompt-for-dependencies -p "Add fileA and fileB"
tests/issue1332_add_r_boring.sh view
@@ -36,10 +36,10 @@ grep 'addfile ./f' log grep 'addfile ./core' log rm _darcs/patches/pending+touch _darcs/index_invalid+ # this fails for issue1332 darcs add -r --boring . darcs whatsnew > log grep 'addfile ./f' log grep 'addfile ./core' log-rm _darcs/patches/pending-cd ..
− tests/issue1337_darcs_changes_false_positives.sh 
@@ -1,37 +0,0 @@-#!/usr/bin/env bash-## Test for issue1337 - darcs changes shows unrelated patches-## Asking "darcs changes" about an unrecorded file d/f will list the-## patch that creates the parent directory d/ (instead of no patches).-##-## Copyright (C) 2009  Trent W. Buck-##-## 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-## SOFTWARE.--. lib--rm -rf temp1-darcs init --repodir temp1-cd temp1-mkdir d-darcs record -lam d d-# We use --match 'touch d/f' instead of simply d/f because the latter-# prints "Changes to d/f:\n" before the count.-test 0 -eq "$(darcs changes --count --match 'touch d/f')"
tests/issue1344_abort_early_cant_send.sh view
@@ -24,12 +24,11 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev--. lib+. ./lib -# The mail sending code on Windows uses the MAPI API unconditionally-# so this test fails.+# The mail sending code on Windows uses the MAPI API if there is no+# sendmail-command configured using either option or environment+# variable. # If it's possible to discover in advance whether mail sending would work, # the code and this test could be improved to do that. abort_windows@@ -45,9 +44,6 @@   exit 200 fi -DARCS_EDITOR=echo-export DARCS_EDITOR- mkdir temp1 temp2  cd temp2@@ -60,14 +56,15 @@ darcs add foo bar darcs record -a -m add_foo_bar -A x -# If --sendmail-command is provided, no warning-darcs send --author=me -a --to=random@random --sendmail-command='true' ../temp2-# If --dry-run is provided, no warning-darcs send --author=me -a --to=random@random --dry-run ../temp2-# If -o or -O is provided, no warning+# If --mail and --sendmail-command is provided, no warning+darcs send --mail --author=me -a --to=random@random --sendmail-command='true' ../temp2+# If --mail and --dry-run is provided, no warning+darcs send --mail --author=me -a --to=random@random --dry-run ../temp2+# If --mail is not provided, no warning darcs send --author=me -a --to=random@random -O ../temp2 darcs send --author=me -a --to=random@random -o test.patch ../temp2 # Otherwise, fail early-darcs send --author=me -a --to=random@random ../temp2 | grep "No working sendmail"+not darcs send --mail --author=me -a --to=random@random ../temp2 2>log+grep "Cannot find the 'sendmail' program" log  cd ..
+ tests/issue1401_bug_in_get_extra.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash+## Test for issue1401 - when two repos share a HUNK patch, but that+## patch's ADDFILE dependency is met by different patches in each+## repo, it becomes impossible to pull between the two repos.+##+## Copyright (C) 2009  Trent W. Buck+##+## 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+## SOFTWARE.++. lib++# this test fails for darcs-1 and darcs-2 repos and we cannot fix it+skip-formats darcs-1 darcs-2++darcs initialize --repodir d/+darcs initialize --repodir e/+touch d/f d/g e/f+darcs record     --repodir d/ -lam 'Add f and g'+darcs record     --repodir e/ -lam 'Add f'+echo >d/f+darcs record     --repodir d/ -am 'Change f'+darcs pull       --repodir e/ -a d/ --allow-conflicts #no conflict mark-up+echo y | darcs obliterate --repodir e/ -ap 'Add f and g'+darcs pull       --repodir e/ -a d/
− tests/issue1427_apply_gz.sh 
@@ -1,41 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1 temp2-mkdir temp1 temp2--cd temp2-darcs init--cd ../temp1-darcs init-touch foo bar-darcs add foo bar-darcs record -a -m add_foo_bar -A x-darcs mv foo zig-darcs mv bar foo-darcs mv zig bar-darcs record -a -m swap_foo_bar -A x-darcs send --author=me --output=funpatch --dont-sign -a ../temp2--gzip funpatch--cd ../temp2-darcs apply ../temp1/funpatch.gz-cd ..-cmp temp1/bar temp2/bar-rm -rf temp2--mkdir temp2-cd temp2-darcs init-darcs apply ../temp1/funpatch.gz-## Also test that "darcs apply" can accept a patch on stdin.-darcs obl -a-darcs apply < ../temp1/funpatch.gz-cd ..-cmp temp1/bar temp2/bar---rm -rf temp1 temp2-
− tests/issue142_record-log.sh 
@@ -1,34 +0,0 @@-#!/usr/bin/env bash-## Test for issue142 - darcs record --logfile foo should not-## let you record a patch even when 'foo' is a missing file-##-## Copyright (C) 2009 Eric Kow-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.-cd R-touch f g-touch log-darcs     record -alm f --logfile log     f-not darcs record -alm g --logfile missing g
+ tests/issue1442_encoding_round-trip.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash+## -*- coding: utf-8 -*-+## Test for issue1442 - if we disable Darcs escaping and don't change+## our encoding, the bytes in a filename should be the same bytes that+## "darcs changes -v" prints to the right of "addfile" and "hunk".+##+## Copyright (C) 2009  Trent W. Buck+##+## 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+## SOFTWARE.++. lib++abort_windows # doesn't work there at present, not sure why++rm -rf R                        # Another script may have left a mess.++## Use the first UTF-8 locale we can find.+export LC_ALL=$(locale -a | egrep --text 'utf8|UTF-8' | head -1)+export DARCS_DONT_ESCAPE_ANYTHING=True++## If LC_ALL is the empty string, this system doesn't support UTF-8.+if test -z "$LC_ALL"+then exit 1+fi++darcs init      --repo R+echo '首頁 = א₀' >R/'首頁 = א₀'+darcs record    --repo R -lam '首頁 = א₀' '首頁 = א₀'+darcs changes   --repo R -v '首頁 = א₀' >R/log+#cat R/log                      # Show the humans what the output was.+grep -c '首頁 = א₀' R/log >R/count+echo 5 >R/expected-count+cmp R/count R/expected-count    # Both count files should contain "5\n".+rm -rf R                        # Clean up after ourselves.
tests/issue1465_ortryrunning.sh view
@@ -25,34 +25,34 @@ ## SOFTWARE.  . lib                  # Load some portability helpers.++rm -rf R darcs init      --repo R        # Create our test repo. +# work around issue2720 (MacOS)+if test -x /usr/bin/security; then+  ln -s /usr/bin/security .+fi+ FAKE_EDITOR_HOME=`pwd` cat <<FAKE > editor-good.hs import System.Environment import System.IO main = getArgs >>= \[name] -> writeFile name "fake" FAKE-ghc -o editor-good --make editor-good.hs+ghc $GHC_FLAGS -o editor-good --make editor-good.hs  cat <<FAKE > editor-bad.hs import System.Exit main = exitWith (ExitFailure 127) FAKE-ghc -o editor-bad --make editor-bad.hs+ghc $GHC_FLAGS -o editor-bad --make editor-bad.hs  cat <<FAKE > editor-gave-up.hs import System.Exit main = exitWith (ExitFailure 1) FAKE-ghc -o editor-gave-up --make editor-gave-up.hs--cat <<VI > vi.hs-import System.Environment-import System.IO-main = getArgs >>= \[name] -> writeFile name "vi"-VI-ghc -o vi --make vi.hs+ghc $GHC_FLAGS -o editor-gave-up --make editor-gave-up.hs  cd R mkdir d@@ -67,12 +67,15 @@ grep fake changes-1  # Bad editor: fall through to the next choice+# Note that the record succeeds, even though none of the fallback editors+# are found, leaving the message we passed on the command line intact. DARCS_EDITOR=$FAKE_EDITOR_HOME/editor-bad \-PATH=.:$DARCSDIR \+PATH=..:$DARCSDIR \ darcs record    -lam 'Initial commit.' --edit </dev/null &> log-2 darcs changes   > changes-2 darcs unrecord  -a grep "Initial" changes-2+# check for error messages about fallback editors not found egrep -i 'vi|emacs|nano|edit' log-2  # Normal failure (eg. user hit ^-C)
− tests/issue1472_read_too_much.sh 
@@ -1,37 +0,0 @@-#!/usr/bin/env bash-## Test for issue1472 - running "darcs record ./foo" shouldn't even-## TRY to read ./bar.-##-## Copyright (C) 2009  Trent W. Buck-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repo.-mkdir R/d/                      # Change the working tree.-echo 'Example content.' >R/f-echo 'Similar content.' >R/d/f-chmod 0 R/f                     # Make R/f unreadable, so that-                                # attempting to read it will result in-                                # an error.-darcs record    --repo R -lam 'Only changes to R/d/.' d-rm -rf R/                       # Clean up after ourselves.
− tests/issue1473.sh 
@@ -1,42 +0,0 @@-#!/usr/bin/env bash-## Test for issue1473 - check that darcs annotate works with and without-## repodir and with "." argument.  It should fail with the empty string as-## a single argument and without any arguments.-##-## 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-## SOFTWARE.-. lib                           # Load some portability helpers.--rm -rf R S                      # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--cd R-echo 'Example content.' > f-darcs record -lam 'Added f.'-darcs annotate .-darcs annotate f-not darcs annotate-not darcs annotate ''--cd ..-darcs annotate --repodir=R .-darcs annotate --repodir=R f-not darcs annotate --repodir=R-not darcs annotate --repodir=R ''
− tests/issue1473_annotate_repodir.sh 
@@ -1,23 +0,0 @@-#!/usr/bin/env bash-set -ev--. lib-rm -rf temp-mkdir temp-cd temp-darcs init-mkdir a b-touch a/a b/b-darcs add --rec .-darcs record -a -m ab -A test-darcs annotate a/a-darcs annotate . > inner-# annotate --repodir=something '.' should work-cd ..-darcs annotate --repodir temp '.' > temp/outer-cd temp-diff inner outer--cd ..-rm -rf temp-
+ tests/issue1514-send-minimize.sh view
@@ -0,0 +1,59 @@+#!/usr/bin/env bash+## Test for issue1514: send --minimize+##+## Copyright (C) 2014 G. Hoffmann+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+darcs init      --repo SCREENED       # Create our test repos.++cd SCREENED+touch a+darcs rec -lam a+touch b+darcs rec -lam b+cd ..++darcs clone SCREENED LOCAL+darcs clone SCREENED REVIEWED++cd LOCAL+touch c+darcs rec -lam c+darcs push --all # so SCREENED has c++# now create a patch we'll send as bundle with full context+touch d+darcs rec -lam d+darcs send --all -o bundle --no-minimize++# check it cannot be applied to REVIEWED (which lacks patch c)+not darcs apply bundle --all --repodir=../REVIEWED++# now create bundle with minimal context (default option)+darcs send --all -o bundle.min++# this one lacks c in its context so it can be applied to REVIEWED+darcs apply bundle.min --all --repodir=../REVIEWED++cd ..+
+ tests/issue1522_trailing_slash_borkage.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue1522 - Trailing slash borkage+##+## Copyright (C) 2012 Andreas Brandt+##+## 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+## SOFTWARE.++. lib++rm -rf R+darcs init R+cd R+# recording a file with trailing slash should fail+touch f+not darcs record -lam fails f/+# recording a directory with trailing slash is okay+mkdir d+darcs record -lam works d/+cd ..
tests/issue154_pull_dir_not_empty.sh view
@@ -26,23 +26,27 @@  . lib -rm -rf temp1-mkdir temp1-cd temp1-darcs init+rm -rf R S+darcs init R+cd R mkdir d darcs add d darcs record -a -m "Added directory d"-darcs get ./ puller-cd puller+darcs get . ../S+cd ../S touch d/moo darcs add d/moo-cd ..+cd ../R rm -rf d darcs record -a -m "Remove directory d"-cd puller-echo y | darcs pull -a .. > log+cd ../S+echo y | darcs pull -a ../R 2>&1 > log grep -i "backing up" log grep -i "finished pulling" log+# check that moo is not lost (it will be in a backup of d)+find . -name moo+# ideally we would preserve the pending 'addfile ./d/moo',+# but we currently do not+#darcs whatsnew | grep 'addfile ./d/moo'+darcs whatsnew | grep 'adddir ./d' cd ..-rm -rf temp1
+ tests/issue1579_diff_opts.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash+## Test for issue1579 - the diff-opts parameter with multiple parameters +## separated by space are passed like an one parameter to diff.+##+## Copyright (C) 2013 dixiecko+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++darcs init      --repo R        # Create our test repos.++cd R+echo 'Example content line 1.' > f+darcs record -lam 'Add f.'+echo 'Example content line 2.' >> f++# Darcs passes the parameters to diff like [ "-wpurNd -U 999" ]+# instead of [ "-wpurNd","-U","999" ]+darcs diff --diff-opts '-wpurNd -U 999' > result++# Darcs doesn't indicate the error in return error code,+# when diff command didn't work the result is empty.++if [ -z "$(cat result)" ]; then +   exit 2+fi
− tests/issue157_rollback_conflict.sh 
@@ -1,44 +0,0 @@-#!/usr/bin/env bash--# issue157: A test for how rollback handles dependencies and conflicts.--. lib--rm -rf temp1 temp2--# set up the repository-mkdir temp1-cd temp1-darcs init --darcs-2-cd ..--# do some work here-cd temp1-echo a > foo-# Create three patches-darcs record -lam AA-echo b > foo-darcs record  -lam BB-echo c > foo-darcs record  -lam CC-# Rollback the last one-darcs rollback -a -p CC -m 'rollback CC'-grep b foo # reality check-cd ..--# Now get just the first two patches into a new repo...ignoring the third patch and the rollback.-darcs get --to-patch BB temp1 temp2-cd temp2-# Now in the second repo, rollback the second patch.-darcs rollback -a -p BB -m 'rollback BB'-grep a foo # reality check-# Finally, pull the third patch and the rollback of it.-# Because the two patches should cancel each other other, there should be no change here.-darcs pull -a ../temp1-# expect a conflict between the contents being 'a' or 'b'-grep "v v v" foo-grep a foo-grep b foo-cd ..--rm -rf temp1 temp2
− tests/issue1584_optimize_upgrade.sh 
@@ -1,36 +0,0 @@-#!/usr/bin/env bash-## Test for issue1584 - darcs optimize --upgrade-##-## Copyright (C) 2009 Eric Kow <kowey@darcs.net>-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-gunzip -c $TESTDATA/many-files--old-fashioned-inventory.tgz | tar xf --mv many-files--old-fashioned-inventory R--echo x > R/foo # Unrecorded change-darcs optimize  --repo R --upgrade-darcs check     --repo R-grep hashed R/_darcs/format-not grep darcs-2 R/_darcs/format-darcs whatsnew  --repo R | grep 'hunk ./foo 1'
− tests/issue1599-automatically-expire-unused-caches.sh 
@@ -1,57 +0,0 @@-#!/usr/bin/env bash-## Test for issue1599 - 'Automatically expire unused caches'-##-## Copyright (C) 2010  Adolfo Builes-##-## 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-## SOFTWARE.-. lib--skip-formats old-fashioned--rm -rf R S log && mkdir R-cd R-darcs init-echo a > a-darcs rec -lam a-echo b > b-darcs rec -lam b-echo c > c-darcs rec -lam c-cd ..--serve_http # sets baseurl-darcs get --lazy $baseurl/R S-rm S/_darcs/prefs/sources-if [ -z "$http_proxy" ]; then-  echo "repo:http://10.1.2.3/S" >> S/_darcs/prefs/sources-fi-echo "repo:$baseurl/dummyRepo" >> S/_darcs/prefs/sources-echo "repo:~/test1599/S" >> S/_darcs/prefs/sources-echo "repo:$baseurl/R" >> S/_darcs/prefs/sources-darcs changes --repo S --debug --verbose --no-cache 2>&1 | tee log-if [ -z "$http_proxy" ]; then-  c=`grep -c "URL.waitUrl http://10.1.2.3/S" log`-  [ $c  -eq 1 ]-fi-c1=`grep -c "URL.waitUrl $baseurl/dummyRepo" log`-[ $c1 -eq 2 ]-c2=`grep -c "~/test1599/S" log`-[ $c2 -eq 1 ]
+ tests/issue1609-conflict-markup-depends-on-patch-order.sh view
@@ -0,0 +1,36 @@+#!/bin/sh+rm -rf darcs.tp2+mkdir darcs.tp2+cd darcs.tp2+mkdir s1+mkdir s2+mkdir s3+cd s1; darcs init+echo -e '1\n2\n3\n4\n5\n' > foo.txt+darcs add foo.txt+darcs record --patch-name=init --author momo --skip-long-comment --all+cd ../s2; darcs init+darcs pull ../s1 --all+cd ../s3; darcs init+darcs pull ../s1 --all+cd ../s1;+echo -e "3i\nX\n.\nw\nq\n" | ed foo.txt+darcs record --patch-name=op1 --author momo --skip-long-comment --all+cd ../s2+echo -e "3d\nw\nq\n" | ed foo.txt+darcs record --patch-name=op2 --author momo --skip-long-comment --all+cd ../s3+echo -e "4i\nY\n.\nw\nq\n" | ed foo.txt+darcs record --patch-name=op3 --author momo --skip-long-comment --all+cd ../s1+darcs pull ../s2 --all+cd ../s2+darcs pull ../s1 --all+cd ../s1+darcs pull ../s3 --all+cd ../s2+darcs pull ../s3 --all+cd ../s3+darcs pull ../s1 --all+if diff ../s1/foo.txt ../s2/foo.txt; then echo 'TP2 ok S1 S2';  else echo 'TP2 ko'; fi+if diff ../s2/foo.txt ../s3/foo.txt; then echo 'TP2 ok S2 S3';  else echo 'TP2 ko'; fi
tests/issue1618-amend-preserve-logfile.sh view
@@ -24,8 +24,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev-. lib+. ./lib rm -rf R; mkdir R; cd R  darcs init
tests/issue1620-record-lies-about-leaving-logfile.sh view
@@ -24,8 +24,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev-. lib+. ./lib rm -rf R; mkdir R; cd R export DARCS_EDITOR="echo 'a log' > " darcs init
+ tests/issue1640_apply_stdin.sh view
@@ -0,0 +1,56 @@+#!/usr/bin/env bash+## Test for issue1640 - <SYNOPSIS: darcs Issue 1640 darcs apply+## with no file args should mention stdin>+##+## Copyright (C) 2011  Radoslav Dorcik <dixiecko@gmail.com>+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++#######################################################+# Test preparation +#######################################################++# Create repository+rm -rf S T T2+darcs init      --repo S+darcs init      --repo T+darcs init      --repo T2+cd S+touch foo bar+darcs add foo bar+darcs record -a -m add_foo_bar -A x+darcs send --output=funpatch -a ../T+++#######################################################+# Apply from stdin and check message+#######################################################++cd ../T+darcs apply < ../S/funpatch | tee output.txt+grep "reading patch bundle from stdin..." output.txt++cd ../T2+darcs apply --quiet < ../S/funpatch | tee output.txt+not grep "reading patch bundle from stdin..." output.txt+cd ..
− tests/issue1640_verbose_stdin.sh 
@@ -1,58 +0,0 @@-#!/usr/bin/env bash-## Test for issue1640 - <SYNOPSIS: darcs Issue 1640 darcs apply-## --verbose with no file args should mention stdin>-##-## Copyright (C) 2011  Radoslav Dorcik <dixiecko@gmail.com>-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.--#######################################################-# Test preparation -#######################################################--# Create repository-darcs init      --repo S-darcs init      --repo T-darcs init      --repo T2-cd S-touch foo bar-darcs add foo bar-darcs record -a -m add_foo_bar -A x-darcs send --author=me --output=funpatch -a ../T---#######################################################-# Apply from stdin and check message-#######################################################--# Message when --verbose-cd ../T-darcs apply --verbose < ../S/funpatch | tee output.txt-grep "reading patch bundle from stdin..." output.txt || exit 1---# No message when no --verbose-cd ../T2-darcs apply < ../S/funpatch | tee output.txt-grep "reading patch bundle from stdin..." output.txt && exit 1-exit 0;
@@ -32,6 +32,7 @@ ## SOFTWARE.  . lib                           # Load some portability helpers.+ rm -rf R S                      # Another script may have left a mess. darcs init      --repo R        # Create our test repos. darcs init      --repo S@@ -45,8 +46,6 @@ touch log add_to_boring '^log$' -unset pwd # Since this test is pretty much linux-specific, hspwd.hs is not needed- # Skip the case-folding tests on systems that don't support it touch cs-test ln -s cs-test cs-Test || exit 200@@ -57,16 +56,16 @@ touch non-recorded-file2 ln -s ./non-recorded-file2 ./Non-Recorded-File2 ln -s "`pwd`"/non-recorded-file2 ./Non-ReCoRdEd-File2-darcs w -l >log 2>&1                                             # should report only "non-recorded-file"-darcs rec -alm "added ./non-recorded-file2" >>log 2>&1            # should add only file, not symlink-darcs changes -s --patch="added ./non-recorded-file2" >>log 2>&1  # should report only file, not symlink-not grep -vE "(^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file2)" log+darcs w -l >log                                                  # should report only "non-recorded-file"+darcs rec -alm "added ./non-recorded-file2" >>log                 # should add only file, not symlink+darcs changes -s --patches="added ./non-recorded-file2" >>log       # should report only file, not symlink+not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file2)" log rm Non-Recorded-File2 ./Non-ReCoRdEd-File2  # Case 16: case-folding link to recorded file ln -s ./recorded-file ./Recorded-File ln -s "`pwd`"/recorded-file ./ReCorded-File-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm Recorded-File ReCorded-File
tests/issue1645-ignore-symlinks.sh view
@@ -32,12 +32,11 @@ ## SOFTWARE.  . lib                           # Load some portability helpers.+ rm -rf R S                      # Another script may have left a mess. darcs init      --repo R        # Create our test repos. darcs init      --repo S -darcs --version- add_to_boring() {   echo "$1" >> _darcs/prefs/boring }@@ -47,17 +46,14 @@ touch log add_to_boring '^log$' -unset pwd # Since this test is pretty much linux-specific, hspwd.hs is not needed-abort_windows # and skip if we are on win32...- # Case 1: looping symlink to non-recorded non-boring dir mkdir non-recorded-dir ln -s ../non-recorded-dir ./non-recorded-dir/loop               # relative symlink ln -s "`pwd`"/non-recorded-dir ./non-recorded-dir/loop2           # absolute symlink-darcs w -l >log 2>&1                                            # should not loop-darcs rec -alm "added ./non-recorded-dir" >>log 2>&1            # should not loop-darcs changes -s --patch="added ./non-recorded-dir" >>log 2>&1  # should report only dir, not symlink-not grep -vE "(^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir)" log+darcs w -l >log                                                 # should not loop+darcs rec -alm "added ./non-recorded-dir" >>log                 # should not loop+darcs changes -s --patches="added ./non-recorded-dir" >>log       # should report only dir, not symlink+not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir)" log  # Case 2: looping symlink to recorded dir mkdir recorded-dir@@ -65,50 +61,50 @@ darcs rec -am "added recorded-dir" ln -s ../recorded-dir ./recorded-dir/loop      # relative symlink ln -s "`pwd`"/recorded-dir ./recorded-dir/loop2  # absolute symlink-not darcs w -l >log 2>&1                       # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1  # expecting "No changes!" as well+not darcs w -l >log                            # expecting "No changes!"+not darcs rec -alm "should not happen" >>log       # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log  # Case 3: looping symlink to boring dir mkdir boring-dir-add_to_boring '^boring-dir$'+add_to_boring '^boring-dir/$' ln -s ../boring-dir ./boring-dir/loop ln -s "`pwd`"/boting-dir ./boring-dir/loop2-not darcs w -l >log 2>&1                      # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1 # expecting "No changes!" as well+not darcs w -l >log                           # expecting "No changes!"+not darcs rec -alm "should not happen" >>log      # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log  # Case 4: non-looping symlink to non-recorded non-boring dir mkdir non-recorded-dir2 ln -s ./non-recorded-dir2 link ln -s "`pwd`"/non-recorded-dir2 ./link2-darcs w -l >log 2>&1                                             # should report only "non-recorded-dir2"-darcs rec -alm "added ./non-recorded-dir2" >>log 2>&1            # should add only dir, not symlink-darcs changes -s --patch="added ./non-recorded-dir2" >>log 2>&1  # should report only dir, not symlink-not grep -vE "(^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir2)" log+darcs w -l >log                                                  # should report only "non-recorded-dir2"+darcs rec -alm "added ./non-recorded-dir2" >>log                 # should add only dir, not symlink+darcs changes -s --patches="added ./non-recorded-dir2" >>log       # should report only dir, not symlink+not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-dir2)" log rm link link2  # Case 5: non-looping symlink to recorded dir ln -s ./recorded-dir ./link ln -s "`pwd`"/recorded-dir ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 6: non-looping symlink to boring dir ln -s ./boring-dir ./link ln -s "`pwd`"/boring-dir ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 7: symlink pointing outside the repo ln -s ../S link (cd ..; ln -s "`pwd`"/S ./R/link2)-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2 @@ -116,10 +112,10 @@ touch non-recorded-file ln -s ./non-recorded-file ./link ln -s "`pwd`"/non-recorded-file ./link2-darcs w -l >log 2>&1                                             # should report only "non-recorded-file"-darcs rec -alm "added ./non-recorded-file" >>log 2>&1            # should add only file, not symlink-darcs changes -s --patch="added ./non-recorded-file" >>log 2>&1  # should report only file, not symlink-not grep -vE "(^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file)" log+darcs w -l >log                                                  # should report only "non-recorded-file"+darcs rec -alm "added ./non-recorded-file" >>log                 # should add only file, not symlink+darcs changes -s --patches="added ./non-recorded-file" >>log       # should report only file, not symlink+not grep -vE "(^patch|^Author|^ *$|^\+|[0-9]:[0-9][0-9]:[0-9]|./non-recorded-file)" log rm link link2  # Case 9: symlink to recorded file@@ -128,47 +124,49 @@ darcs rec -am "added recorded-file" recorded-file ln -s ./recorded-file ./link ln -s "`pwd`"/recorded-file ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 10: symlink to boring file ln -s ./log ./link ln -s "`pwd`"/log ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 11: dangling symlink ln -s /completely/bogus/path ./link ln -s ../../../../not/exist ./link2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm link link2  # Case 12: self-referencing link ln -s l l ln -s "`pwd`"/l2 ./l2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm l l2  # Case 13: link to device file outside the repo ln -s /dev/zero l-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well+not darcs w -l >log                                              # expecting "No changes!"+not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well not grep -vE "(^ *$|^\+|No changes!)" log rm l  # Case 14: link to fifo-mkfifo f-ln -s f l-ln -s "`pwd`"/f ./l2-not darcs w -l >log 2>&1                                         # expecting "No changes!"-not darcs rec -alm "should not happen" >>log 2>&1                # expecting "No changes!" as well-not grep -vE "(^ *$|^\+|No changes!)" log-rm f l l2+if ! os_is_windows; then+  mkfifo f+  ln -s f l+  ln -s "`pwd`"/f ./l2+  not darcs w -l >log                                              # expecting "No changes!"+  not darcs rec -alm "should not happen" >>log                     # expecting "No changes!" as well+  not grep -vE "(^ *$|^\+|No changes!)" log+  rm f l l2+fi
− tests/issue1705-show-contents-index.sh 
@@ -1,35 +0,0 @@-#!/usr/bin/env bash-## Test for issue1705 - <darcs show contents --index=1     => darcs failed:  Pattern not specified in get_nonrange_match>-##-## Copyright (C) 2009  Thomas Hartman-##-## 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-## SOFTWARE.--. ../tests/lib                  # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.-cd R-echo 111 > 1-darcs add 1-darcs record --author="whoever" -am'add file 1'-darcs show contents --index=1 1-cd ..-rm -rf R
tests/issue1726_darcs_always-boring.sh view
@@ -37,7 +37,7 @@ function bad_add {     filename="$1"     touch "$filename"-    not darcs whatsnew -ls --boring+    not darcs whatsnew -s --boring     not darcs whatsnew -ls     not darcs add --boring "$filename" }@@ -62,7 +62,7 @@  # Passing --boring should definitely succeed. touch _darcsfoo-darcs whatsnew -ls --boring+darcs whatsnew -s --boring darcs add --boring _darcsfoo darcs record -am 'add _darcsfoo' _darcsfoo
tests/issue1739-escape-multibyte-chars-correctly.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-## Test for issue1739 - "Char.intToDigit: not a digit" in darcs changes +## Test for issue1739 - "Char.intToDigit: not a digit" in darcs changes ## ## Copyright (C) 2010  Reinier Lamers ##@@ -25,6 +25,11 @@  . lib +# TODO: get this working on Windows+# Seems to be a real bug - darcs doesn't record a patch with the+# right characters.+abort_windows+ # First, try to see if character set is UTF-8. If we can't find out or if it # isn't, we skip this test. if ! which locale ; then@@ -45,6 +50,9 @@  # we want escaping, otherwise output of non-ASCII characters is unreliable export DARCS_DONT_ESCAPE_ANYTHING=0+# note default changed, DARCS_DONT_ESCAPE_8BIT is no longer recognized+export DARCS_ESCAPE_8BIT=1+export DARCS_DONT_ESCAPE_ISPRINT=0  rm -rf R mkdir R@@ -54,7 +62,7 @@ echo garbelbolf > aargh darcs add aargh echo -e '\xe2\x80\x9e\x54\x61\x20\x4d\xc3\xa8\x72\x65\xe2\x80\x9d' > message.txt-darcs record --logfile=message.txt -A 'Petra Testa van der Test <test@example.com>' -a > rec.txt+darcs record --logfile=message.txt -a > rec.txt darcs changes > log.txt cat log.txt grep '<U+201E>' log.txt
− tests/issue1749-rmdir.sh 
@@ -1,42 +0,0 @@-#!/usr/bin/env bash-## Test for issueXXX - darcs remove <dir> corrupts the patch sequence-##-## Copyright (C) 2009 Eric Kow <kowey@darcs.net>-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init   --repo R-cd R--mkdir dir-touch dir/file--darcs add dir/file              # adds dir too (which is fine)-darcs rec -a -m"add dir and file"--darcs remove dir-# removed dir but not file - should be nothing to add-not darcs rec -a -m"remove dir"--darcs obliterate -a --patch "remove dir" | grep 'No patches selected!'-darcs check
tests/issue1756_moves_index.sh view
@@ -34,7 +34,7 @@ echo 'c' > e/c darcs record -lam '.' darcs mv d/a e/-darcs check --no-ignore-times+darcs check cd .. rm -rf R @@ -45,6 +45,6 @@ echo 'b' > e/b darcs record -lam '.' darcs mv d/a e/-darcs check --no-ignore-times+darcs check cd .. rm -rf R
− tests/issue1765_recursive-remove-on-root.sh 
@@ -1,36 +0,0 @@-#!/usr/bin/env bash-## Test for issueNNNN - <SYNOPSIS: WHAT IS THE BUG?  THIS SYNOPSIS-## SHOULD BE ONE OR TWO SENTENCES.>-##-## Copyright (C) YEAR  AUTHOR-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.-darcs init      --repo S--cd R-mkdir d e                       # Change the working tree.-echo 'Example content.' > d/f-darcs record -lam 'Add d/f and e.'-darcs remove * -r
+ tests/issue1819-pull-dont-allow-conflicts.sh view
@@ -0,0 +1,47 @@+#!/usr/bin/env bash+## Test for issue1819 - pull --dont-allow-conflicts doesn't work+##+## Dave Love <fx@gnu.org>, Public domain++. lib+rm -rf R S+for repo in R S; do+    darcs init --repo $repo+    cd $repo+    echo 'Example content.' >x+    darcs add x+    darcs record -lam 'Add x'+    echo $repo >x+    darcs record -lam 'Change x'+    cd ..+done++rm -rf S0+darcs get S S0+cd S0+darcs pull --no-pause-for-gui --all --external-merge 'cp %2 %o' ../R+cd ..++rm -rf S0b+darcs get S S0b+cd S0b+not darcs pull --no-pause-for-gui --all --dont-allow-conflicts ../R+cd ..++# --external-merge is now in the same set of mutually exclusive options+# as the --{[no-]allow,mark}-conflicts, so passing two of them+# should result in an error.++rm -rf S1+darcs get S S1+cd S1+not darcs pull --no-pause-for-gui --all --external-merge 'cp %2 %o' --dont-allow-conflicts ../R 2>log+grep -i 'conflicting options' log+cd ..++rm -rf S2+darcs get S S2+cd S2+not darcs pull --no-pause-for-gui --all --dont-allow-conflicts --external-merge 'cp %2 %o' ../R 2>log+grep -i 'conflicting options' log+cd ..
tests/issue1825-remove-pending.sh view
@@ -35,9 +35,5 @@ darcs add -r a darcs rec -am "add a/b" rm -r a-darcs add                      # NB. not darcs add per se, but any operation which-                               # causes the pending patch to be detected (eg. remove,-                               # record + unrecord)--# We have a legitimate pending patch so far.  Now what?+not darcs remove blahblah darcs revert -a a/b
+ tests/issue1845-paths-working-copy.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue1845 - darcs wants file paths from root of working tree+##+## Copyright (C) 2010 Guillaume Hoffmann+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+rm -rf R S                      # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.+cd R+mkdir subdir+touch subdir/subfile+darcs add subdir subdir/subfile+darcs record -am"add subdir and subfile"+cd subdir+rm subfile+darcs record subfile -am"delete file in subdirectory" # fails because darcs wants subdir/subfile +
− tests/issue1845-record-removed.sh 
@@ -1,16 +0,0 @@-#!/usr/bin/env bash-## Test for issue1871 - darcs record f, for f a removed file should work-##-## Public domain - 2010 Petr Rockai--. lib                           # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--cd R-echo 'Example content.' > f-darcs rec -lam "first"-rm -f f-echo n | darcs record f 2>&1 | tee log-not grep "None of the files" log-cd ..
− tests/issue1848-rollback-p.sh 
@@ -1,36 +0,0 @@-#!/usr/bin/env bash-## Test for issue1848 - interactive selection of primitive patches-## should still work with rollback -p-##-## Copyright (C) 2010 Eric Kow-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--cd R-echo 'f' > f-echo 'g' > g-darcs record -lam 'Add f and g'-echo ynq | darcs rollback -p 'f and g'-cd ..
− tests/issue184_add.sh 
@@ -1,19 +0,0 @@-#!/usr/bin/env bash--. lib--# For issue184: recording files in directories that haven't explicity been added.--rm -rf temp1-mkdir temp1-cd temp1-darcs init-mkdir new-mkdir new/dir-touch new/dir/t.t-darcs add new/dir/t.t-darcs record -am test new/dir/t.t > log-not grep "don't want to record" log-cd ..--rm -rf temp1
tests/issue1857-pristine-conversion.sh view
@@ -26,12 +26,20 @@  . lib                           # Load some portability helpers. rm -rf minimal-darcs-2.4-tar zx < $TESTDATA/minimal-darcs-2_4.tgz+unpack_testdata minimal-darcs-2_4  cd minimal-darcs-2.4 darcs check-darcs setpref test false+# we used to do+#  darcs setpref test false+# here but that will now do the pristine conversion itself+# (during revertRepositoryChanges), so we have to fake it:+echo 'test false' >> _darcs/prefs/prefs echo 'hi' > README-not darcs record -a -m argh --test+not darcs record -a -m argh --test 2> errlog 1> outlog+# check that we are really doing the pristine conversion...+grep -i 'converting pristine' errlog+# ...and not fail for some other reason+grep "Test failed" outlog darcs check cd ..
− tests/issue1865-get-context.sh 
@@ -1,20 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-touch t.t-darcs add t.t-darcs record -am "initial add"-darcs tag -m tt-echo x > x-darcs rec -lam "x" x-darcs changes --context > my_context-abs_to_context="$(pwd)/my_context"-cd ..-darcs get temp1 --context="${abs_to_context}" temp2-darcs changes --context --repo temp2 > repo2_context-diff -u "${abs_to_context}" repo2_context
− tests/issue1871-record-dot.sh 
@@ -1,39 +0,0 @@-#!/usr/bin/env bash-## Test for issue1871 - darcs record . should work for tracked changes-## in a subdirectory even if the subdirectory itself is not known yet.-##-## Copyright (C) 2010 Eric Kow-##-## 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-## SOFTWARE.---. lib                           # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--cd R-mkdir d                         # Change the working tree.-echo 'Example content.' > d/f-darcs add d/f-echo n | darcs record-echo n | darcs record . > log-not grep "None of the files" log-cd ..
− tests/issue1873-apply-failed-to-read-patch.sh 
@@ -1,55 +0,0 @@-#!/usr/bin/env bash-## Test for issue1873 - apply should complain about the right-## patches if it says some are missing-##-## Copyright (C) 2010 Petr Rockai-##-## 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-## SOFTWARE.--. lib--rm -rf R S-mkdir R-darcs init --repo R--cd R-echo a > a-darcs rec -lam a-echo b > a-darcs rec -lam b-echo x > x-darcs rec -lam x-echo c > a-darcs rec -lam c-echo y > y-darcs rec -lam y-echo d > a-darcs rec -lam d-cd ..--darcs get R S-darcs unpull -p x -a --repo R-darcs send   -p x -a --repo S -o R/x.dpatch-darcs unpull -p y -a --repo R-not darcs apply --repo R R/x.dpatch 2>&1 | tee log--not grep '^  \* d' log # does not complain about an unrelated patch-    grep '^  \* y' log # complains about the offending one instead
tests/issue1879-same-patchinfo-uncommon.sh view
@@ -34,5 +34,12 @@ cd ..  cd R-not darcs pull -a ../S 2>&1 | tee log+# The issue calls for darcs to detect this and fail, which it does,+# though not in a regular way but by calling 'error'. Since the 'not'+# function now regards that as test failure we cannot use it here.+# This is only a temporary work-around: Darcs should never call error+# unless it is really a bug in darcs.+if darcs pull -a ../S 2>&1 | tee log; then+  exit 1+fi cd ..
− tests/issue1888-changes-context.sh 
@@ -1,43 +0,0 @@-#!/usr/bin/env bash-## Test for issue1888 - changes --context is broken when topmost patch is a-## clean tag.--## Copyright (C) 2010 Petr Rockai-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--cd R--echo a > a ; darcs rec -lam "patch_a"-darcs changes --context | grep patch_a--darcs tag -m "tag_a"-darcs changes --context | not grep patch_a-darcs changes --context | grep tag_a--echo b > a; darcs rec -lam "patch_b"-darcs changes --context | not grep patch_a-darcs changes --context | grep tag_a-darcs changes --context | grep patch_b
+ tests/issue189-external-merge-move.sh view
@@ -0,0 +1,52 @@+#!/usr/bin/env bash++. lib++rm -rf jhc lhc++# Set up repository to represent JHC's situation -- all sources in the root+mkdir jhc+cd jhc+darcs init+echo content > Foo+darcs rec -alm Base+cd ..++# Now create another one to represent LHC -- sources in src/ dir+darcs get jhc lhc+cd lhc+mkdir src/+darcs add src/+darcs mv Foo src/Foo+darcs rec -am "Move sources into src/"+# ... and change something+echo content1 > src/Foo+darcs rec -am "content1"+cd ..++# change something different in JHC+cd jhc+echo content2 > Foo+darcs rec -am "content2"+cd ..++# our external merge tool checks that the arguments+# exist and have the expected content+cat > external_merge.hs <<EOF+import Control.Monad+import System.Environment+import System.Exit+main = do+  [ca,c1,c2,co] <- getArgs >>= mapM readFile+  when (ca /= "content\n") exitFailure+  when (c1 /= "content1\n") exitFailure+  when (c2 /= "content2\n") exitFailure+  when (co /= "content\n") exitFailure+EOF+ghc $GHC_FLAGS --make external_merge.hs+merge_tool=$(pwd)/external_merge++# try to merge them with our external_merge script+cd lhc+darcs pull -a ../jhc --no-pause-for-gui --external-merge="$merge_tool %a %1 %2 %o"+cd ..
tests/issue1898-set-default-notification.sh view
@@ -34,21 +34,18 @@ cd S # default to no-set-default darcs push ../R1 > log-grep '/R0$' _darcs/prefs/defaultrepo+test R0 = $(cat _darcs/prefs/defaultrepo | xargs basename) # notification when using no-set-default-grep "set-default" log+grep -- "--set-default" log+# ...but not when --inherit-default is active+darcs push ../R1 --inherit-default > log+not grep -- "--set-default" log # set-default works darcs push ../R1 --set-default > log-grep '/R1$' _darcs/prefs/defaultrepo+test R1 = $(cat _darcs/prefs/defaultrepo | xargs basename) # no notification when already using --set-default-not grep "set-default" log+not grep -- "--set-default" log # no notification when already pushing to the default repo darcs push > log-not grep "set-default" log-# no notification when it's just the --remote-repo-darcs push --remote-repo ../R1 > log-not grep "set-default" log-# but... notification still works in presence of remote-repo-darcs push --remote-repo ../R1 ../R2 > log-grep "set-default" log+not grep -- "--set-default" log cd ..
tests/issue1909-unrecord-O-misses-tag.sh view
@@ -7,14 +7,14 @@ mkdir R darcs init --repo R echo a > R/a-darcs rec -lam a --repo R --ignore-times+darcs rec -lam a --repo R darcs tag -m T --repo R echo b > R/a-darcs rec -lam b --repo R --ignore-times+darcs rec -lam b --repo R echo c > R/a-darcs rec -lam c --repo R --ignore-times+darcs rec -lam c --repo R -darcs unpull -p c -a --repo R -O+darcs unpull -p c -a --repo R -O --no-minimize cat c.dpatch grep '^\[b' c.dpatch grep TAG c.dpatch
tests/issue1922-obliterate-o-context.sh view
@@ -43,5 +43,5 @@ rm -f foo.dpatch darcs unpull -a -o foo.dpatch --match 'name a2' --repo x --last 3 cat foo.dpatch-darcs chan --context --repo x+darcs changes --context --repo x darcs apply foo.dpatch --repo x
− tests/issue1923-cache-warning.sh 
@@ -1,55 +0,0 @@-#!/usr/bin/env bash-## Test for issue1599 - 'Automatically expire unused caches'-##-## Copyright (C) 2010  Adolfo Builes-##-## 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-## SOFTWARE.-. lib--skip-formats old-fashioned--darcs init --repo R-cd R-echo a > a-darcs rec -lam a-cd ..--serve_http-cat <<SOURCES > fake-sources-repo:$baseurl/dummyRepo-repo:/some/bogus/local/path-repo:$baseurl/R-SOURCES-darcs get --lazy R S1 && cp fake-sources S1/_darcs/prefs/sources-darcs get --lazy R S2 && cp fake-sources S2/_darcs/prefs/sources--# make sure we do warn about things that are under your control-darcs changes --verbose --repo S1 --no-cache 2>&1 | tee log-local-c1=`grep -c "$baseurl/dummyRepo" log-local`-[ $c1 -eq 1 ]-c2=`grep -c "/some/bogus/local/path" log-local`-[ $c2 -eq 1 ]--# now what about things that aren't?-darcs changes --verbose --repo $baseurl/S2 --no-cache 2>&1 | tee log-remote-c1=`grep -c "$baseurl/dummyRepo" log-remote`-[ $c1 -eq 1 ] # always under your control-not grep -c "/some/bogus/local/path" log-remote
+ tests/issue1928-file-dir-replace.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+## Test for issue1928 - removing a file and adding a directory with the same name+##+## Copyright (C) 2010 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.++cd R+touch foo+darcs rec -l -a -m "foo file patch"+rm foo+mkdir foo+darcs rec -l -a -m "foo dir patch"+cd ..
+ tests/issue1932-colon-breaks-add.sh view
@@ -0,0 +1,73 @@+#!/usr/bin/env bash+## Test for issue1932 - "darcs add -qr ." should not break on files with colons+##+## Copyright(C) 2010 Dmitry Astapov+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++abort_windows                   # Windows doesn't support ':' in filenames at all++rm -rf R                        # Another script may have left a mess.+mkdir -p R                      # Create our test repo.++cd R+darcs init+darcs --version++# Colons could be in repo names and in file name.+# Colon in repo name is an indication of special case - remote repo.+# Colon in the file could be there under unix and requires no special treatment.++# remote repos are tested by tests/network/issue1932-remote.sh++# All following files should not be added unless "--reserved-ok" is specified,+# but should be added with "--reserved-ok" just fine+mkdir funny+touch funny/0401:19d2+touch funny/c:src+touch funny/c:\\src+touch funny/user@invalid:path +touch funny/droundy@invalid:    +touch funny/invalid:path++# Try to add those files. None should be added, darcs should fail+not darcs add -qr funny+darcs wh -l > log 2>&1++# Check that darcs didn't drop dead as 2.4.4 does+[ -z "$(fgrep 'fromJust: Nothing' log)" ]++# Check that no funny files were added+[ -z "$(grep  '^A \./funny/.' log)" ]++# Now let's allow colons and add those files+darcs add --reserved-ok -qr funny +darcs wh -l > log 2>&1++# This should add all those files+[ -n "$(grep  '^A \./funny/0401:19d2' log)" ]+[ -n "$(grep  '^A \./funny/c:src' log)" ]+[ -n "$(grep  '^A \./funny/c:\\src' log)" ]+[ -n "$(grep  '^A \./funny/user@invalid:path' log)" ]+[ -n "$(grep  '^A \./funny/droundy@invalid:' log)" ]+[ -n "$(grep  '^A \./funny/invalid:path' log)" ]
tests/issue194.sh view
@@ -1,4 +1,4 @@-set -ev+. ./lib  rm -rf temp1 temp2
+ tests/issue1956.sh view
@@ -0,0 +1,35 @@+## Test for issue1956++# copied almost verbatim from igloo's+# http://bugs.darcs.net/file1862/darcs_bug_with_touch.sh++. lib++rm -rf a+rm -rf b++mkdir a+cd a+darcs init --darcs-2+echo A > file+darcs add file+darcs rec -a -m A+cd ..++darcs get a b++cd a+echo BB > file+darcs rec -a -m B+cd ..++cd b+touch ts+echo R > file+touch file --reference=ts+darcs rec -a -m R+echo S > file+touch file --reference=ts+# darcs rec -a -m S+echo y| darcs pull ../a -ap B+cd ..
+ tests/issue1959-unwritable-darcsdir.sh view
@@ -0,0 +1,101 @@+#!/usr/bin/env bash+## Test for issue1959 - if the index becomes unwritable,+## read-only commands such as 'darcs whatsnew' should not die.+## Commands that modify the repo should fail with an appropriate+## error message.+##+## Copyright (C) 2012 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+## SOFTWARE.++. lib++rm -rf R S+darcs init R+cd R++echo foo > foo+darcs rec -alm 'testing'+echo change > foo++trap "chmod -R +w ." EXIT++chmod -R -w .++# commands that don't take a lock should not+# access the index at all if passed --ignore-times++darcs check --ignore-times+darcs diff --last=1 --ignore-times+#would work if we could tell it to create the file elsewhere:+#darcs dist+darcs log --ignore-times+darcs init ../S --ignore-times+darcs send ../S -a -o ../patch --ignore-times+darcs show authors --ignore-times+darcs show contents foo --ignore-times+darcs show files --ignore-times+darcs show tags --ignore-times+darcs whatsnew --ignore-times++# ...and output a warning message otherwise++darcs check --no-ignore-times 2>../log+grep "Warning, cannot access the index" ../log+darcs diff --last=1 --no-ignore-times 2>../log+grep "Warning, cannot access the index" ../log+darcs whatsnew --no-ignore-times 2>../log+grep "Warning, cannot access the index" ../log++# made it writable again+chmod -R +w .++# check that we get a decent error message+# for commands that modify the repo+test_cannot_write_index () {+  not darcs record -l foo -am foo 2>record+  grep "Cannot write index" record+  not darcs obliterate 2>record+  grep "Cannot write index" record+  not darcs unrecord 2>unrecord+  grep "Cannot write index" unrecord+  not darcs move foo bar 2>move+  grep "Cannot write index" move+  echo bla > foo+  not darcs add foo 2>add+  grep "Cannot write index" add+  not darcs remove foo 2>remove+  grep "Cannot write index" remove+  not darcs replace x y foo 2>remove+  grep "Cannot write index" remove+  not darcs repair 2>repair+  grep "Cannot write index" repair+}++# ...if the index iself isn't writable (but _darcs is)+chmod -R -w _darcs/index++test_cannot_write_index++# made it writable again+chmod -R +w .++cd ..
− tests/issue1977-darcs-repair.sh 
@@ -1,12 +0,0 @@-#!/usr/bin/env bash--# Issue1977 darcs repair complains when there is no pristine.hashed directory-set -ev-mkdir temp1-cd temp1-darcs init-echo "a" > a-darcs add a-darcs rec -am a-rm -rf _darcs/pristine.hashed/-darcs repair
tests/issue1978.sh view
@@ -8,21 +8,10 @@ touch titi darcs add titi darcs record -am titi-cat > _darcs/format <<EOF-hashed|gobbledygook-darcs-2-EOF+sed -i 's/hashed/hashed\|gobbledygook/' _darcs/format cat _darcs/format cd .. -if grep 'old-fashioned' .darcs/defaults; then-    exit 200-fi--if grep hashed .darcs/defaults; then-    exit 200-fi- # get future repo: should be ok darcs get future temp1 cd temp1@@ -31,5 +20,3 @@ darcs add toto darcs record -am 'blah' cd ..-rm -rf temp1 future-
+ tests/issue1981-missing-pristine.sh view
@@ -0,0 +1,12 @@+. lib++# note: we enforce --no-cache otherwise this is hard to reproduce++rm -rf R S+darcs init R+cd R+echo x > x+darcs record --no-cache x -lam add_x+rm -f _darcs/pristine.hashed/*+cd ..+not darcs clone  --no-cache R S 2>&1 | grep repair
+ tests/issue1987.sh view
@@ -0,0 +1,245 @@+#!/usr/bin/env bash+## Test for issue1987 - Garbage collection for inventories and patches+##+## Copyright (C) 2014  Marcio Diaz+##+## 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+## SOFTWARE.++# This script test that 'darcs optimize' cleans+# the directories _darcs/patches/ and _darcs/inventories/+# from unnecesary files.++. lib++# The script will read the following directories:+PATCHES_DIR='_darcs/patches/'+INV_DIR='_darcs/inventories/'+PRISTINE_DIR='_darcs/pristine.hashed/'++#################################################+# Testing garbage collection on _darcs/patches/ #+#################################################++rm -rf R++darcs init --repo R+cd R++touch f+darcs add f++# In the next line, 'ls -1' list files in a single column,+# so that $PENDING_FILES should looks like:+# pending+# pending.tentative+PENDING_FILES=$(ls -1 $PATCHES_DIR)+darcs record -am 'Add f.'++# After doing 'record', the contents of $PATCHES_DIR+# should looks like (the hash will be different):+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84+# pending+# pending.tentative+PATCHES_DIR_AFTER_RECORD=$(ls -1 $PATCHES_DIR)++# The following line gets the names of files added to $INV_DIR after doing+# record, i.e., the name of the new patch.+# Then $PATCH should looks like:+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84+PATCH=`comm -13 <(echo "$PENDING_FILES") <(echo "$PATCHES_DIR_AFTER_RECORD")`++touch g+darcs add g+echo y | darcs amend-record -a++# $PATCHES_DIR_AFTER_AMEND should looks like:+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84+# 0000000132-23ee2a79b097dd4a134c50d196c6f7ecd5c85655ad44d34f6c1732f4b491ca35+# pending+# pending.tentative+PATCHES_DIR_AFTER_AMEND=$(ls -1 $PATCHES_DIR)++# This is one of the important parts of the script. If issue1987 is+# correctly solved, 'darcs optimize' should delete the patch:+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84+darcs optimize clean++# Then $PATCHES_DIR_AFTER_OPTIMIZE should looks like:+# 0000000132-23ee2a79b097dd4a134c50d196c6f7ecd5c85655ad44d34f6c1732f4b491ca35+# pending+# pending.tentative+PATCHES_DIR_AFTER_OPTIMIZE=$(ls -1 $PATCHES_DIR)++# If issue1987 is solved $REMOVED_PATCH should looks like:+# 0000000120-8462241e685a983cff956f05a6a32f3ff6b27a485e67d19b84b2b5fef31fab84,+# i.e., must be equal to $PATCH.+# Otherwise $REMOVED_PATCH == '', and then $REMOVED_PATCH != $PATCH.+REMOVED_PATCH=`comm -13 <(echo "$PATCHES_DIR_AFTER_OPTIMIZE") \+						<(echo "$PATCHES_DIR_AFTER_AMEND")`++[ "$PATCH" == "$REMOVED_PATCH" ]++cd ..++#####################################################+# Testing garbage collection on _darcs/inventories/ #+#####################################################++rm -rf R++darcs init --repo R+cd R++touch f+darcs add f+darcs record -am 'Add f.'++# $INV_DIR_AFTER_RECORD should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+# 0000000192-3863012ed1377e2d80e0f97bccbad0260d9e186bc28080549563f22d8b968e33+INV_DIR_AFTER_RECORD=$(ls -1 $INV_DIR)++touch g+darcs add g+darcs record -am 'Add g.'++# $INV_DIR_AFTER_SND_RECORD should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+# 0000000192-3863012ed1377e2d80e0f97bccbad0260d9e186bc28080549563f22d8b968e33+# 0000000384-e5683733407c4aae642604adf29d582a8fbbb6c50a96d6e8bba20058f7892b68+INV_DIR_AFTER_SND_RECORD=$(ls -1 $INV_DIR)++# $SND_PATCH should looks like:+# 0000000384-e5683733407c4aae642604adf29d582a8fbbb6c50a96d6e8bba20058f7892b68+SND_PATCH=`comm -13 <(echo "$INV_DIR_AFTER_RECORD") \+					<(echo "$INV_DIR_AFTER_SND_RECORD")`++# We don't need any of the files in $INV_DIR (since we have not done+# 'darcs tag', all the information is in _darcs/hashed_inventory),+# therefore 'darcs optimize' can delete all the files in $INV_DIR.+darcs optimize clean++# $INV_DIR_AFTER_OPTIMIZE should be equal to ''.+INV_DIR_AFTER_OPTIMIZE=$(ls -1 $INV_DIR)++[ "$INV_DIR_AFTER_OPTIMIZE" == "" ]++cd ..++#####################################################+# Testing garbage collection on _darcs/inventories/ #+# (this time using 'darcs tag')+#####################################################++rm -rf R++darcs init --repo R+cd R++touch f+darcs add f+darcs record -am 'Add f.'++# $INV_DIR_AFTER_RECORD should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+# 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018+INV_DIR_AFTER_RECORD=$(ls -1 $INV_DIR)++darcs tag -m 'Add f.'++# $INV_DIR_AFTER_FST_TAG should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+# 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018+# 0000000297-eed3c68ee2d145f499f00d8367ec09a2cebdf79de7341e873e7bc68088236fc6+INV_DIR_AFTER_TAG=$(ls -1 $INV_DIR)++# $SND_PATCH should looks like:+# 0000000297-eed3c68ee2d145f499f00d8367ec09a2cebdf79de7341e873e7bc68088236fc6+SND_PATCH=`comm -13 <(echo "$INV_DIR_AFTER_RECORD") \+					<(echo "$INV_DIR_AFTER_TAG")`++touch g+darcs add g+darcs record -am 'Add g.'++# $INV_DIR_AFTER_SND_RECORD should looks like:+# 0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+# 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018+# 0000000297-eed3c68ee2d145f499f00d8367ec09a2cebdf79de7341e873e7bc68088236fc6+# 0000000489-6892c56cd7ec4381ad7d8bbcf10ed5a3366d3ac40f2a569d9bf7d2e5633fe32a+# The last file contains the data of the second so that the second file is+# useless.+# The latest file points to the first, so that 'optimize' should not delete+# the first file.+# The content of the last file is in _darcs/hashed_inventory+# so it can be deleted.+INV_DIR_AFTER_SND_RECORD=$(ls -1 $INV_DIR)++darcs optimize clean++# $INV_DIR_AFTER_OPTIMIZE should looks like:+# 0000000192-3208a6a8d8b0a12f9f99c5c89529f9bf773553cd5e985cee7dd0221b8cfe5018+INV_DIR_AFTER_OPTIMIZE=$(ls -1 $INV_DIR)++# comm -3 is the symmetric difference i.e. union \\ intersection,+# the extra echo gets rid of the whitespace+NULL_INV=$(echo $(comm -3 <(echo "$INV_DIR_AFTER_OPTIMIZE") \+					<(echo "$INV_DIR_AFTER_RECORD")))++[ "$NULL_INV" = "0000000000-e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" ]++cd ..++#########################################################+# Testing garbage collection on _darcs/pristine.hashed/ #+# (this should work even before issue1987)              #+#########################################################++rm -rf R+darcs init --repo R+cd R++# $PRISTINE_DIR_AFTER_INIT should looks like:+# e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+PRISTINE_DIR_AFTER_INIT=$(ls -1 $PRISTINE_DIR)++echo "Hello darcs" > f+darcs add f+darcs record -am 'Hello darcs.'++# $PRISTINE_DIR_AFTER_RECORD should looks like:+# 34e7e68e2ba4d79facc7ddffdab700608d4abceebbc8ff98d77479b8a5127820+# a8c49fa16eaed0a0a601834c98132a32c24f078e58fcba4d9e036fadb92ca91d+# e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855+# The third file represents the empty working tree and is no longer+# needed. Therefore 'optimize' must remove it.+PRISTINE_DIR_AFTER_RECORD=$(ls -1 $PRISTINE_DIR)++EXPECTED_PRISTINE_AFTER_OPTIMIZE=`comm -13 <(echo "$PRISTINE_DIR_AFTER_INIT") \+										   <(echo "$PRISTINE_DIR_AFTER_RECORD")`+darcs optimize clean++PRISTINE_DIR_AFTER_OPTIMIZE=$(ls -1 $PRISTINE_DIR)++[ "$PRISTINE_DIR_AFTER_OPTIMIZE" == "$EXPECTED_PRISTINE_AFTER_OPTIMIZE" ]++cd ..+rm -rf R
tests/issue2012_send_output_no_address.sh view
@@ -24,12 +24,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev--. lib--DARCS_EDITOR=echo-export DARCS_EDITOR+. ./lib  mkdir temp1 temp2
tests/issue2013_send_to_context.sh view
@@ -23,13 +23,9 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev--. lib--DARCS_EDITOR=echo-export DARCS_EDITOR+. ./lib +rm -rf temp2 mkdir temp2  cd temp2@@ -39,6 +35,7 @@  # setup test cd ..+rm -rf temp1 darcs get temp2 temp1  cd temp1@@ -48,10 +45,10 @@ darcs record -alm add_foo_bar -A x  # Test that --to works with send --context-darcs send --author=me -a --to=random@random --sendmail-command='grep "^To: random@random$" %<' --context context+darcs send --mail --author=me -a --to=random@random --sendmail-command='grep "^To: random@random$" %<' --context context  # Test that a default preference will NOT be used when no --to value is specified echo "default@email" > ../temp2/_darcs/prefs/email-not darcs send --author=me -a --sendmail-command='grep "^To: default@email$" %<' --context context+not darcs send --mail --author=me -a --sendmail-command='grep "^To: default@email$" %<' --context context  cd ..
tests/issue2035-malicious-subpath.sh view
@@ -24,5 +24,5 @@ ## SOFTWARE.  . lib                  # Load some portability helpers.-gunzip -c $TESTDATA/badrepo.tgz | tar xf -+unpack_testdata badrepo not darcs get badrepo
tests/issue2041_dont_add_symlinks.sh view
@@ -29,12 +29,7 @@ rm -rf R                        # Another script may have left a mess. darcs init      --repo R        # Create our test repo. -darcs --version- cd R--unset pwd # Since this test is pretty much linux-specific, hspwd.hs is not needed-abort_windows # and skip if we are on win32...  # test for file touch test-file
+ tests/issue2047_duplicate_conflictor_recommute_fail.sh view
@@ -0,0 +1,132 @@+#!/usr/bin/env bash+## Test that shows failing commute of conflictors/duplicates.+##+## Copyright (C) 2012 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+## SOFTWARE.++# We want to create this situation:+#+# Context: [adddir "./dir1", addfile "./file1.txt"]+#+# (ParTree+#     (ParTree (DP "./dir1" RmDir)+#              (Move "./file1.txt" "./dir1/file3.txt")+#     (SeqTree (DP "./dir1" RmDir) (Move "./file1.txt" "./file2.txt")))+#+# And then create the merged tree consisting of merging the second "branch" of+# a par tree into the first, depth-first.+#+# Finally, we show that commute is broken for certain combinations of+# conflictors/duplicates, since we can commute out one way, but not the+# other. We do so, by creating both orderings of the final two patches, and+# show that only in one case can we obliterate the penultimate patch alone (due+# to non-commutation).+#+# See issue2047 on the BTS for more information.++. ./lib++# test fails for these obsolete formats:+skip-formats darcs-1 darcs-2++rm -rf R1* R2 R3*++darcs init --repo R1+cd R1++mkdir dir1+touch file1.txt++darcs rec -alm 'Init'++darcs get . ../R2+darcs get . ../R3++rmdir dir1+darcs rec -am 'Remove dir1'++cd ../R2+darcs mv file1.txt dir1/file3.txt+darcs rec -am 'Move 1 -> 3'++# Create the first merged ParTree.+cd ../R1+darcs pull -a ../R2++# Revert conflict-markup+darcs rev -a++# Create a copy of R1, so we can show the effect of commuting out the final two+# patches, when we create a different ordered R3...+darcs get . ../R1_OTHER++cd ../R3++# Copy R3, so we can create the other ordering for its patches.+darcs get . ../R3_OTHER++#### In R3 we do rmdir; move file+rmdir dir1+darcs rec -alm 'Rmdir'++cd ../R1+darcs pull -a ../R3+darcs rev -a++cd ../R3+darcs mv file1.txt file2.txt+darcs rec -alm 'Move 1 -> 2'++cd ../R1+darcs pull -a ../R3+darcs rev -a++#### In R3_OTHER we do move file; rmdir+cd ../R3_OTHER+darcs mv file1.txt file2.txt+darcs rec -alm 'Move 1 -> 2'++cd ../R1_OTHER+darcs pull -a ../R3_OTHER+darcs rev -a++cd ../R3_OTHER+rmdir dir1+darcs rec -alm 'Rmdir'++cd ../R1_OTHER+darcs pull -a ../R3_OTHER+darcs rev -a++# Now, to show the bug, we can ob the penultimate patch from R1, but not+# R1_OTHER+cd ../R1+darcs ob -p 'Rmdir' -a++[[ $(darcs changes --count) -eq 4 ]]++cd ../R1_OTHER+echo y | darcs ob -p 'Move 1 -> 2' -a++# There should be 4 changes remaining, but due to the failure to commute, we'll+# actually obliterate 2 patches, leaving 3.+[[ $(darcs changes --count) -eq 4 ]]
− tests/issue2052-default-unified-diff.sh 
@@ -1,40 +0,0 @@-#!/usr/bin/env bash-## Test for issue2052 - Ensure we use unified Diff by default.-##-## Copyright (C) 2011  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-## SOFTWARE.--set -ev-. lib                           # Load some portability helpers.--rm -rf R-darcs init --repo R-cd R-touch a-darcs add a-darcs record -am 'Add a'--echo testing > a--test `darcs diff | grep -c "diff -rN -u"` -eq 1-test `darcs diff --no-unified | grep -c "diff -rN -u"` -eq 0-test `darcs diff --no-unified | grep -c "diff -rN"` -eq 1
− tests/issue2066-record-file-not-exist.sh 
@@ -1,13 +0,0 @@-set -ev--rm -rf temp-mkdir -p temp-cd temp--darcs init-touch a b-darcs add a-darcs record -a -m "record a" a-rm a-darcs add b-darcs record -a -m "record a" a
+ tests/issue2066_add_and_remove.sh view
@@ -0,0 +1,41 @@+#!/usr/bin/env bash+## Test for issue2066 - darcs record fails when deleted file and added file are specified on the command line+##+## Copyright (C) 2011  David Caldwell <david@porkrind.org>+##+## 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+## SOFTWARE.++. lib+rm -rf R+mkdir R++cd R+darcs init+echo a > a+darcs add a+darcs record --all -m "a"+rm -f a+echo b > b+darcs add b+darcs record --all -m "-a+b" a b+darcs changes -v | grep 'rmfile ./a' # the remove doesn't get recorded even though we told it to.++cd ..
− tests/issue2067-diff-blanklines.sh 
@@ -1,30 +0,0 @@-#!/usr/bin/env bash-## Test for 2067: inexistant files result in empty lines in darcs-##diff-##-## Copyright (C) YEAR  AUTHOR-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.-cd R-darcs diff a b c d 2> /dev/null | wc -l | grep "^ *0$"
+ tests/issue2072-coalesce-move.sh view
@@ -0,0 +1,51 @@+. lib++rm -rf R+darcs init R+cd R++touch x1 y1+darcs rec -lam "adds"++darcs mv x1 x2+darcs mv y1 y2++rm x2 y2+darcs whatsnew > out+cat out >&2+not grep move out++# coalescing should result in 2 changes plus 1 last regrets prompt+echo yyy | darcs record -m "rms"+darcs log -v --last=1 > log+not grep move log++cd ..++# same situation but record only one of the coalesced changes++rm -rf R+darcs init R+cd R++touch x1 y1+darcs rec -lam "adds"++darcs mv x1 x2+rm x2++darcs whatsnew > whx++darcs mv y1 y2+rm y2++# record only the 'rmfile ./y1'+echo nyy | darcs record -m "rms"+darcs log -v --last=1 > log+not grep move log+grep -F 'rmfile ./y1' log+grep move _darcs/patches/pending+darcs whatsnew > whx_after+diff -u whx whx_after >&2++cd ..
+ tests/issue2074.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash++. lib++darcs init R+cd R+touch a+darcs rec -l a -am 'a'+echo "line1" > a+darcs rev -a+# the "n" cancels obliterate after the+# "this will make unrevert impossible" question+# which is not a failure+echo "yyn" | darcs ob+cd ..
+ tests/issue2086-index-permissions.sh view
@@ -0,0 +1,40 @@+#!/usr/bin/env bash+## Test for issue2086 - _darcs/index permissions are not preserved+##+## Copyright (C) 2011 Eric Kow+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+darcs init      --repo R        # Create our test repos.++abort_windows # umasks don't really work there++cd R+echo 'Example content.' > f+darcs record -lam 'Add f' --umask 022+ls -l _darcs/index | grep '^.rw..--...'+chmod g+w _darcs/index+ls -l _darcs/index | grep '^.rw.rw....'+echo 'Example content 2.' > f+darcs record -lam 'Tweak f' --umask 002+ls -l _darcs/index | grep '^.rw.rw....'+cd ..
+ tests/issue2125-always-warn-forced-replace.sh view
@@ -0,0 +1,75 @@+#!/usr/bin/env bash+## Test for issue2125 - darcs should not warn about forced replaces, if nothing+## needed to be forced.+##+## Copyright (C) 2012 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+## SOFTWARE.++. lib++rm -rf R+darcs init --repo R++cd R++echo -e 'first line of file\nsecond line of file' > file+darcs rec -alm 'Add file'++# No occurences of 'entry' - shouldn't warn.+darcs replace line entry file | not grep surprised++# We have an occurrence of 'second' - should fail, but not change anything (no+# --force)+noForce=$(darcs replace first second file)+echo "$noForce" | grep 'Skipping file'+echo "$noForce" | not grep 'surprised'++# Make sure nothing changed...+whatsnew=$(darcs wh)+echo "$whatsnew" | grep 'replace \./file \[A-Za-z_0-9\] line entry'+[[ $(echo "$whatsnew" | wc -l) -eq 1 ]]++force=$(darcs replace --force first second file) +echo "$force" | grep 'surprised'+darcs wh++! read -r -d '' EXPECTED <<'EOF'+hunk ./file 2+-second line of file++first line of file+replace ./file [A-Za-z_0-9] first second+replace ./file [A-Za-z_0-9] line entry++EOF++echo "$EXPECTED" > expected_whatsnew.txt+darcs wh > actual_whatsnew.txt++# Ensure we have the right changes in working/pending.+diff expected_whatsnew.txt actual_whatsnew.txt++darcs rev -a++# Test that unrecorded changes require --force, too.+echo 'third line of file' >> file+workingChangeNoForce=$(darcs replace second third file)+echo "$workingChangeNoForce" | grep 'Skipping file'
− tests/issue2136-changes_created_as_for_multiple_files.sh 
@@ -1,86 +0,0 @@-#!/usr/bin/env bash--## Ensure changes --xml reports correct original filenames for multiple files.-##-## Copyright (C) 2012 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-## SOFTWARE.--. lib--rm -rf R--darcs init --repo R--cd R--mkdir tldir--touch tldir/f1-darcs rec -alm 'Add tldir/f1'-echo foo >> tldir/f1-darcs rec -am 'Modify tldir/f1'-darcs move tldir/f1 tldir/f2-darcs rec -am 'Move tldir/f1 -> tldir/f2'--touch f3-darcs rec -alm 'Add f3'-darcs move f3 f4-darcs rec -am 'Move f3 -> f4'-darcs move f4 f5-darcs rec -am 'Move f4 -> f5'-touch f6-darcs rec -alm 'Add non-changing file f6'--mkdir tldir/d1-darcs rec -alm 'Add tldir/d1'-darcs move tldir/d1 tldir/d2-darcs rec -am 'Move tldir/d1 -> tldir/d2'--mkdir d3-darcs rec -alm 'Add d3'-darcs move d3 d4-darcs rec -am 'Move d3 -> d4'-darcs move d4 d5-darcs rec -am 'Move d4 -> d5'--# Ensure all original names are reported, both forwards, and reversed.-xmlChanges=$(darcs cha --xml tldir/f2 f5 tldir/d2 d5 f6)-xmlChangesRev=$(darcs cha --reverse --xml tldir/f2 f5 tldir/d2 d5 f6)--# xmlChanges needs to be quoted everywhere, otherwise this hack to retrieve the-# 2 following lines won't work.-checkRename () {-    echo "$1" | grep "<created_as current_name='\./$2' original_name='\./$3'>" -C2 | tail -1 | grep "<name>$4</name>"-}--checkInXML () {-    checkRename "$1" "d5" "d3" "Add d3"-    checkRename "$1" "f5" "f3" "Add f3"-    checkRename "$1" "tldir/d2" "tldir/d1" "Add tldir/d1"-    checkRename "$1" "tldir/f2" "tldir/f1" "Add tldir/f1"-}--checkInXML "$xmlChanges"-checkInXML "$xmlChangesRev"--# But don't mention unchanged files.-echo "$xmlChanges" | not grep "<created_as[^>]*'\./f6'"
+ tests/issue2136-log_created_as_for_multiple_files.sh view
@@ -0,0 +1,86 @@+#!/usr/bin/env bash++## Ensure log --xml reports correct original filenames for multiple files.+##+## Copyright (C) 2012 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+## SOFTWARE.++. lib++rm -rf R++darcs init --repo R++cd R++mkdir tldir++touch tldir/f1+darcs rec -alm 'Add tldir/f1'+echo foo >> tldir/f1+darcs rec -am 'Modify tldir/f1'+darcs move tldir/f1 tldir/f2+darcs rec -am 'Move tldir/f1 -> tldir/f2'++touch f3+darcs rec -alm 'Add f3'+darcs move f3 f4+darcs rec -am 'Move f3 -> f4'+darcs move f4 f5+darcs rec -am 'Move f4 -> f5'+touch f6+darcs rec -alm 'Add non-changing file f6'++mkdir tldir/d1+darcs rec -alm 'Add tldir/d1'+darcs move tldir/d1 tldir/d2+darcs rec -am 'Move tldir/d1 -> tldir/d2'++mkdir d3+darcs rec -alm 'Add d3'+darcs move d3 d4+darcs rec -am 'Move d3 -> d4'+darcs move d4 d5+darcs rec -am 'Move d4 -> d5'++# Ensure all original names are reported, both forwards, and reversed.+xmlLog=$(darcs log --xml tldir/f2 f5 tldir/d2 d5 f6)+xmlLogRev=$(darcs log --reverse --xml tldir/f2 f5 tldir/d2 d5 f6)++# xmlLog needs to be quoted everywhere, otherwise this hack to retrieve the+# 2 following lines won't work.+checkRename () {+    echo "$1" | grep "<created_as current_name='\./$2' original_name='\./$3'>" -C2 | tail -1 | grep "<name>$4</name>"+}++checkInXML () {+    checkRename "$1" "d5" "d3" "Add d3"+    checkRename "$1" "f5" "f3" "Add f3"+    checkRename "$1" "tldir/d2" "tldir/d1" "Add tldir/d1"+    checkRename "$1" "tldir/f2" "tldir/f1" "Add tldir/f1"+}++checkInXML "$xmlLog"+checkInXML "$xmlLogRev"++# But don't mention unchanged files.+echo "$xmlLog" | not grep "<created_as[^>]*'\./f6'"
− tests/issue2139-mv-to-dir.sh 
@@ -1,54 +0,0 @@-#!/usr/bin/env bash-## Test for issue2139 - darcs should accept to mv to the-## current working directory-##-## Copyright (C) 2012 Eric Kow-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.--darcs init      --repo R        # Create our test repos.--cd R--# move dir to root-mkdir a a/a2 a/a3-darcs record -lam 'Some directories (a)'-darcs mv a/a2 .-test -d a2 -cd a-darcs mv a3 ..-not test -d a3-cd ..-test -d a3--# move dir to non-root dir-mkdir b b2 b3-darcs record -lam 'Some directories (b)'-darcs mv b2 b-test -d b/b2-cd b-darcs mv ../b3 .-test -d b3-cd ..--cd ..
+ tests/issue2153-allow-skipping-backwards-through-depended_upon-patches.sh view
@@ -0,0 +1,35 @@+#!/usr/bin/env bash++# Testing amend++. lib++rm -rf temp1+# set up the repository+mkdir temp1+cd temp1+darcs init+cd ..++# do some work here+cd temp1++touch foo+darcs add foo+echo -e 'line1\nline2\nline3' > foo+darcs record -a -m add_lines+echo -e 'line1ch\nline2\nline3' > foo+darcs record -a -m changedline1+echo -e 'line1ch\nline2changed\nline3' > foo+darcs record -a -m changed_line2+echo -e 'line1ch\nline2changedagain\nline3' > foo+darcs record -a -m changed_line2again++echo successmarker >> foo+echo jkya | darcs amend+echo FOOOOOO+darcs changes -v --patch "changed_line2again"|grep successmarker++cd ..++rm -rf temp1 temp2
+ tests/issue2160_wrong_line_number_when_appending_empty_line.sh view
@@ -0,0 +1,19 @@+# Off-by-one error when reporting patches that append an empty line to a file.+# An affected darcs would report 'hunk ./f 3' in the provided tests.+. lib++darcs init R+cd R+echo 'first line' > f+darcs record -lam 'first line'+echo '' >> f+darcs whatsnew > wh+darcs record -am 'appended empty line'+darcs log -v --last=1 > log+darcs annotate f > ann++# these currently all fail:+grep 'hunk ./f 2' wh+grep 'hunk ./f 2' log+not grep unknown ann+grep '#2' ann
− tests/issue2199-get-dirty-tag.sh 
@@ -1,50 +0,0 @@-#!/usr/bin/env bash-## Test for issue2199 - "darcs get --tag" gets too much if the tag is dirty.-##-## Copyright (C) 2012 Ganesh Sittampalam-##-## 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-## SOFTWARE.--. lib--darcs init --repo R--cd R-echo 'wibble' > file-darcs rec -lam 'wibble'-echo 'wobble' > file-darcs rec -lam 'wobble'-cd ..--darcs get R R-temp--cd R-temp-darcs unpull --patch 'wobble' -a-darcs tag 'wibble'-cd ..--cd R-darcs pull ../R-temp -a-cd ..--darcs get --tag wibble R R-tag-cd R-tag-darcs changes | not grep wobble
+ tests/issue2200-darcs-replace-no-paths.sh view
@@ -0,0 +1,44 @@+#!/usr/bin/env bash+## Test for issue2200 - darcs should warn if no paths are given to replace+##+## Copyright (C) 2012 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+## SOFTWARE.++. lib++rm -rf R+darcs init --repo R++cd R++touch file++darcs rec -alm 'Add file'++# Missing tokens+not darcs replace+not darcs replace foo++# No files to replace in+not darcs replace foo bar &> output.txt++grep 'You need to supply a list of files to replace in!' output.txt
+ tests/issue2204-send-mail.sh view
@@ -0,0 +1,64 @@+#!/usr/bin/env bash+## Test for issue2204 - darcs send --mail vs --output+##+## Copyright (C) 2012 Eric Kow+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+darcs init      --repo R        # Create our test repos.++# copied from issue2186+# Create a script that will be used instead of sendmail. It simply saves its+# input to file "message".+cat <<FAKE > dummy-sendmail.hs+import System.IO+main = hGetContents stdin >>= writeFile "message"+FAKE+ghc $GHC_FLAGS -o dummy-sendmail --make dummy-sendmail.hs++cd R+echo 'foo@example.com' > _darcs/prefs/email+cd ..++darcs get R S+cd S+echo 'send sendmail-command ../dummy-sendmail' > _darcs/prefs/defaults+echo 'Example content.' > f+darcs add f+darcs record -lam p++# no options (should generate a bundle)+darcs send -a+[ ! -e message ]+[ -e p.dpatch ]++# just --mail+darcs send -a --mail+[ -e message ]+rm message++# both mail and output+darcs send -a --mail -O+[ ! -e message ]+[ -e p.dpatch ]++cd ..
+ tests/issue2208-replace-fails-with-resolving-unrecorded-change.sh view
@@ -0,0 +1,56 @@+#!/usr/bin/env bash+## Test for issue2208 - darcs shouldn't fail to replace if unrecorded changes+## would make the replace succeed+##+## Copyright (C) 2012 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+## SOFTWARE.++. lib++rm -rf R++darcs init --repo R++cd R++echo -e 'foo\nbar' > testing++darcs rec -alm 'Add testing file'++echo -e 'baz\nbar' > testing++# Darcs will complain here, since we've not recorded the fact that we've+# removed the occurrence of foo+darcs replace bar foo testing | not grep Skipping++cat <<EOF > ../expected+hunk ./testing 1+-foo++baz+replace ./testing [A-Za-z_0-9] bar foo+EOF++darcs whatsnew > ../actual++cd ..++diff actual expected
+ tests/issue2209-look_for_replaces.sh view
@@ -0,0 +1,373 @@+#!/usr/bin/env bash+## Test for issue2209 - Automatically detect replace patch.+##+## Copyright (C) 2013 Jose Neder+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R++# simple full complete replace (record)+darcs init+echo "foo" > file+darcs record -al -m "add file"+echo "bar_longer" > file          # replace by token of different length+echo yy | darcs record --look-for-replaces -m "replace foo bar_longer file"+darcs changes --last 1 -v 2>&1 | tail -n +4  > log+cat > log.expected <<EOF+  * replace foo bar_longer file+    replace ./file [A-Za-z_0-9] foo bar_longer+EOF+diff -u log log.expected+rm -rf *++# simple full complete replace (amend-record)+darcs init+echo "foo" > file+darcs record -al -m "add file"+echo "bar" > file+echo yyy | darcs amend-record --look-for-replaces+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^    {\|    }$" > log+cat > log.expected <<EOF+  * add file+    addfile ./file+    hunk ./file 1+    +foo+    replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# simple full complete replace (whatsnew)+darcs init+echo "foo" > file+darcs record -al -m "add file"+echo "bar" > file+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# partial replace (only some of the words/chunks replaced) (record)+darcs init+echo "foo foo" > file+darcs record -al -m "add file"+echo "bar foo" > file+echo yyy | darcs record --look-for-replaces -m "replace foo bar file"+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^    {\|    }$" > log+cat > log.expected <<EOF+  * replace foo bar file+    replace ./file [A-Za-z_0-9] foo bar+    hunk ./file 1+    -bar bar+    +bar foo+EOF+diff -u log log.expected+rm -rf *++# partial replace (only some of the words/chunks replaced) (amend-record)+# note that coalescing simplifies+#     hunk ./file 1+#     +foo foo+#     replace ./file [A-Za-z_0-9] foo bar+#     hunk ./file 1+#     -bar bar+#     +bar foo+# to+#     hunk ./file 1+#     +bar foo+darcs init+echo "foo foo" > file+darcs record -al -m "add file"+echo "bar foo" > file+echo yyyy | darcs amend-record --look-for-replaces+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^    {\|    }$" > log+cat > log.expected <<EOF+  * add file+    addfile ./file+    hunk ./file 1+    +bar foo+EOF+diff -u log log.expected+rm -rf *++# partial replace (only some of the words/chunks replaced) (whatsnew)+darcs init+echo "foo foo" > file+darcs record -al -m "add file"+echo "bar foo" > file+darcs whatsnew --look-for-replaces > log+cat > log.expected <<EOF+replace ./file [A-Za-z_0-9] foo bar+hunk ./file 1+-bar bar++bar foo+EOF+diff -u log log.expected+rm -rf *++# forced replace (the word is in the file) (record)+darcs init+cat > file <<EOF+foo+foo+bar+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar+bar+bar+EOF+echo yyy | darcs record --look-for-replaces -m "replace foo bar file"+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^    {\|    }$" > log+cat > log.expected <<EOF+  * replace foo bar file+    hunk ./file 3+    -bar+    +foo+    replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# forced replace (the word is in the file) (amend-record)+darcs init+cat > file <<EOF+foo+foo+bar+EOF+darcs record -al -m "add file"+cat > file <<EOF+foo+bar+bar+EOF+darcs record -a -m "change file"+cat > file <<EOF+bar+bar+bar+EOF+echo yyyy | darcs amend-record --look-for-replaces+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^    {\|    }$" > log+cat > log.expected <<EOF+  * change file+    hunk ./file 3+    -bar+    +foo+    replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# forced replace (the word is in the file) (whatsnew)+darcs init+cat > file <<EOF+foo+foo+bar+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar+bar+bar+EOF+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+hunk ./file 3+-bar++foo+replace ./file [A-Za-z_0-9] foo bar+EOF+diff -u log log.expected+rm -rf *++# multiple replaces (record)+darcs init+cat > file <<EOF+foo+bar+ser+EOF+darcs record -al -m "add file"+cat > file <<EOF+ter+rur+kee+EOF+echo yyyy | darcs record --look-for-replaces -m "multiple replaces"+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^    {\|    }$" > log+cat > log.expected <<EOF+  * multiple replaces+    replace ./file [A-Za-z_0-9] bar rur+    replace ./file [A-Za-z_0-9] foo ter+    replace ./file [A-Za-z_0-9] ser kee+EOF+diff -u log log.expected+rm -rf *++# multiple replaces (amend-record)+darcs init+cat > file <<EOF+foo+bar+ser+EOF+darcs record -al -m "add file"+cat > file <<EOF+ter+rur+kee+EOF+echo yyyyy | darcs amend-record --look-for-replaces+darcs changes --last 1 -v 2>&1 | tail -n +4 | grep -v "^    {\|    }$" > log+cat > log.expected <<EOF+  * add file+    addfile ./file+    hunk ./file 1+    +foo+    +bar+    +ser+    replace ./file [A-Za-z_0-9] bar rur+    replace ./file [A-Za-z_0-9] foo ter+    replace ./file [A-Za-z_0-9] ser kee+EOF+diff -u log log.expected+rm -rf *++# multiple replaces (whatsnew)+darcs init+cat > file <<EOF+foo+bar+ser+EOF+darcs record -al -m "add file"+cat > file <<EOF+ter+rur+kee+EOF+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+replace ./file [A-Za-z_0-9] bar rur+replace ./file [A-Za-z_0-9] foo ter+replace ./file [A-Za-z_0-9] ser kee+EOF+diff -u log log.expected+rm -rf *++# conflicting replaces (whatsnew)+darcs init+cat > file <<EOF+foo+foo+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar+ber+EOF+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+hunk ./file 1+-foo+-foo++bar++ber+EOF+diff -u log log.expected+rm -rf *++# same line replaces+darcs init+cat > file <<EOF+foo foo2 foo3+fee fee2 fee3+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar bar2 bar3+bor bor2 bor3+EOF+darcs whatsnew --look-for-replaces 2>&1 > log+cat > log.expected <<EOF+replace ./file [A-Za-z_0-9] fee bor+replace ./file [A-Za-z_0-9] fee2 bor2+replace ./file [A-Za-z_0-9] fee3 bor3+replace ./file [A-Za-z_0-9] foo bar+replace ./file [A-Za-z_0-9] foo2 bar2+replace ./file [A-Za-z_0-9] foo3 bar3+EOF+diff -u log log.expected+rm -rf *++# 2++darcs init+echo 'Example content' > f+echo 'This is golden content , super interesting content' >> f++echo 'Example content' > g+echo 'This is golden content , super interesting content' >> g+darcs record -lam 'Add f, g'++sed -i "s/content/matter/g" f+sed -i "s/content/topic/g" g+darcs whatsnew --look-for-replace | grep replace+# replace same token differently in different files is OK+rm -rf *++# 3++darcs init+echo 'Example content' > f+echo 'This is golden content , super interesting content' >> f++cp f g+cp f e++darcs record -lam 'Add e, f, g'++# change the file in the middle++echo 'Example issue' > f+echo 'This is golden matter , super interesting matter' >> f # create inconsistent replace in f++sed -i "s/content/stuff/g" e  # consistent replace in e+sed -i "s/content/topic/g" g  # consistent replace in g++darcs whatsnew --look-for-replace > out++grep "^replace ./e" out  # 1 replace in e+not grep "^replace ./f" out  # 0 replace in f+grep "^replace ./g" out  # 1 replace in g++cd ..
+ tests/issue2212-add-changes-pending-for-other-files.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+## Test for issue2212 - darcs updates pending when add is called for a distinct+## file.+##+## Copyright (C) 2012 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+## SOFTWARE.++. lib++rm -rf R+darcs init --repo R++cd R++touch a b++darcs add a+darcs rec -am 'Add a'++rm a+darcs add b++# Darcs shouldn't have updated anything to do with (despite the fact that it+# has indeed been deleted.)+cat _darcs/patches/pending | not grep 'rmfile \./a'++# The same should be true for other commands that have to recompute pending+# from the working tree+darcs revert -a+touch b+darcs add b+rm a+darcs revert b -a+cat _darcs/patches/pending | not grep 'rmfile \./a'
+ tests/issue2225-obliterate-not-in.sh view
@@ -0,0 +1,58 @@+#!/usr/bin/env bash+##+## Obliterate patches not in other repo(s)+##+## 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+## SOFTWARE.++. lib++for i in {1..4}+do+    rm -rf R$i+    darcs init --repo R$i+done++recFile() {+touch $1+darcs rec -lam "add $1"+}++cd R1++recFile file1+recFile file2+recFile file3+recFile file4+recFile file5++# Should fail, we haven't specified a repo, and we don't have a default repo+not darcs ob -a --not-in-remote++darcs push -a -p file2 --set-default ../R2+darcs push -a -p file3 ../R3+darcs push -a -p file4 ../R4++darcs ob -a --not-in-remote=../R3 --not-in-remote=../R4 --not-in-remote++# Confirm that the only patches that were deleted were file1 and file5+[[ -f file2 && -f file3 && -f file4 && ! -f file1 && ! -f file5 ]]
+ tests/issue2227-rebase-amend-record.sh view
@@ -0,0 +1,49 @@+#!/bin/sh -e+##+## amend-record needs to pull the rebase patch to the head+## of the repo so that 'withManualRebaseUpdate' can work+##+## Copyright (C) 2013 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R++mkdir R+cd R++darcs init++touch file1+darcs rec -lam "add file1"++touch file2+darcs rec -lam "add file2"++echo ydy | darcs rebase suspend++touch file3+darcs rec -lam "add file3"++echo 'contents' > file1+echo nyyy | darcs amend
+ tests/issue2243-unknown-patch-annotating-empty-first-line.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash+## Test for issue2243 - annotating a file with a blank first gives an "unknown"+## patch.+##+## Copyright (C) 2012 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+## SOFTWARE.++. lib ++darcs init --repo R++cd R++echo -e "\nline2" > file++darcs rec -alm 'Add file'++darcs annotate file | not grep unknown
+ tests/issue2248-rebase-zero-suspended.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash+## Test for issue2248 - can get into state of "0 suspended patches"+##+## Copyright (C) 2012 Owen Stephens, Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+darcs init --repo R++cd R+touch foo+darcs rec -lam "add foo"+echo foo > foo+darcs rec -am "change foo"+echo bar > foo+echo yd | not darcs rebase suspend++darcs whatsnew | not grep suspended++echo d | darcs rebase suspend+darcs whatsnew | not grep suspended++echo q | darcs rebase suspend+darcs whatsnew | not grep suspended
+ tests/issue2257-impossible-obliterate-subset.sh view
@@ -0,0 +1,68 @@+#!/usr/bin/env bash+## Test for issue2257 - impossible case encountered when obliterating a subset+## of patches+## Copyright (C) 2012 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+## SOFTWARE.++. lib++# this test fails (only) for darcs-2 repos+# and we'll never be able to fix it+skip-formats darcs-2++rm -rf issue2257+mkdir issue2257+cd issue2257++darcs init --repo single-patch+darcs init --repo duplicate-patch++cd single-patch++mkdir dir+touch dir/file1+darcs record -alm 'dir and file1'++touch dir/file2+darcs record -alm 'addfile file2'++cd ../duplicate-patch++# Split the dir/file patch into the dir add, and then the file add.+darcs pull -a ../single-patch -p 'dir and file'+darcs unrecord -a++# Only record 'adddir ./dir'+echo yny | darcs record -m 'adddir dir' +# Now record the addfile in a separate patch.+darcs record -am 'addfile file1'++# Pull in the other patches we don't have (which will include the original +# "add dir/file1" patch again since we've amended it to no longer exist, and+# the "addfile file2" patch)+darcs pull -a ../single-patch++# Attempt to obliterate 'addir dir' (but not 'addfile file1'). This seems to be+# a problem with the patch selection, since without -p, we aren't able to+# obliterate 'adddir dir', if we say no to 'addfile file1' (which is+# sensible!).+echo nyy | darcs obliterate -p 'adddir dir'
+ tests/issue2262-display_of_meta_data.sh view
@@ -0,0 +1,10 @@+#!/usr/bin/env bash++. lib++abort_windows # issue2590++darcs init R+cd R+touch äöüßÄÖÜ+darcs whatsnew -l | grep './äöüßÄÖÜ'
+ tests/issue2270-log-interactive-only-to-files.sh view
@@ -0,0 +1,139 @@+#!/usr/bin/env bash+## Test for issue2270 - +##          darcs log should only show changes to relevant files+##+## Copyright (C) 2013 Sebastian Fischer+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++rm -rf R+mkdir R+cd R+darcs init++echo irrelevant > irrelevant+darcs add irrelevant+darcs record -am "recorded irrelevant file"++echo relevant-initial > relevant+echo other > other+darcs add relevant other+darcs record -am "recorded relevant and other file"+++# --interactive --only-to-files should only show relevant+(echo y | darcs log -i --only-to-files relevant > out) || true+cat out+not grep "addfile ./irrelevant" out+grep "addfile ./relevant" out+not grep "addfile ./other" out++# --verbose --only-to-files should only show relevant+(darcs log -v --only-to-files relevant > out) || true+cat out+not grep "addfile ./irrelevant" out+grep "addfile ./relevant" out+not grep "addfile ./other" out++# --interactive should only show relevant and other+(echo yy | darcs log -i relevant > out) || true+cat out+not grep "addfile ./irrelevant" out+grep "addfile ./relevant" out+grep "addfile ./other" out++# --verbose should only show relevant and other+(darcs log -v relevant > out) || true+cat out+not grep "addfile ./irrelevant" out+grep "addfile ./relevant" out+grep "addfile ./other" out++# --interactive --only-to-files should show old name of moved+darcs move relevant renamed-relevant+darcs record -am "renamed relevant file"++(echo yy | darcs log -i --only-to-files renamed-relevant > out) || true+cat out+grep "addfile ./relevant" out+not grep "addfile ./irrelevant" out+not grep "addfile ./other" out++# --verbose --only-to-files should show old name of moved+(darcs log -v --only-to-files renamed-relevant > out) || true+cat out+grep "addfile ./relevant" out+not grep "addfile ./irrelevant" out+not grep "addfile ./other" out++# --interactive should show old name of moved+(echo yy | darcs log -i renamed-relevant > out) || true+cat out+grep "addfile ./relevant" out+not grep "addfile ./irrelevant" out+grep "addfile ./other" out++# --verbose should show old name of moved+(darcs log -v renamed-relevant > out) || true+cat out+grep "addfile ./relevant" out+not grep "addfile ./irrelevant" out+grep "addfile ./other" out++# adding a new file called 'relevant' :+# changes should now relate to that file and not to the original one+echo relevant-new > relevant+darcs add relevant+echo other-new > other+darcs record -am "recorded new add of relevant"++(echo yy | darcs log -i --only-to-files relevant > out) || true+cat out+grep "addfile ./relevant" out+grep 'relevant-new' out+not grep 'other-new' out+not grep 'relevant-initial' out++(echo yy | darcs log -v --only-to-files relevant > out) || true+cat out+grep "addfile ./relevant" out+grep 'relevant-new' out+not grep 'other-new' out+not grep 'relevant-initial' out++(echo yy | darcs log -i relevant > out) || true+cat out+grep "addfile ./relevant" out+grep 'relevant-new' out+grep 'other-new' out+not grep 'relevant-initial' out++(echo yy | darcs log -v relevant > out) || true+cat out+grep "addfile ./relevant" out+grep 'relevant-new' out+grep 'other-new' out+not grep 'relevant-initial' out++cd ..+rm -rf R
+ tests/issue2271-disable-patch-index.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash+## Test for issue2271 - --disable-patch-index should really work+##+## Copyright (C) 2013 Mark Stosberg+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++rm -rf R+darcs init      --repo R        # Create our test repos.++trap "chmod +w $PWD/R/_darcs/patch_index" EXIT++cd R+touch t.txt+darcs add t.txt+darcs record -am 'initial record' t.txt+darcs optimize enable-patch-index++chmod -w _darcs/patch_index++not darcs optimize disable-patch-index 2>&1 | tee LOG+grep 'Could not delete patch index' LOG++# cleanup+cd ../
+ tests/issue2275_follows-symlinks.sh view
@@ -0,0 +1,147 @@+#!/usr/bin/env bash+## Test for issue2275 - darcs follows symbolic links instead of properly+## ignoring them.+## When substituting a recorded file with a symbolic link, darcs becomes+## confused and associates the filename label to the content of the file+## pointed by the link.+##+## Copyright (C) 2017 Gian Piero Carrubba+##+## 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+## SOFTWARE.++. lib++rm -rf R+darcs init R+cd R+touch g+echo 'This line should not appear in g.' > f+darcs record -lam 'Add f and g.'+rm -f g                         # Remove g and create a link with the+ln -s f g                       # same name ponting to f+darcs diff g | not grep -F '+This line should not appear in g.'+cd ..++# extended test extracted from the bug report++rm -rf R log+mkdir log++# initialize the repository+darcs init R++cd R+echo ImmutableFile > file+darcs rec -lam init++# add a test file and record the patch+echo TemporaryFile > maybeFile+darcs rec -lam 'Add maybeFile'++# remove the just added file and check that darcs recognizes the+# removal+rm maybeFile+darcs wh -s > ../log/before-ln-wh-s+darcs wh -ls > ../log/before-ln-wh-ls++diff -u ../log/before-ln-wh-s ../log/before-ln-wh-ls++# create a symbolic link with the same name of the just removed+# file pointing to an existent file (does not need to be in the+# repodir)+ln -s file maybeFile++# now you get different opinions about what changed depending on+# the use of the '--look-for-adds' option. In both case 'maybeFile'+# is wrongly reported as changed (the current content of 'maybeFile'+# is assumed to be the one of the file the link points to), anyway+# using the '-l' option you also get the right information that+# 'maybeFile' has been removed.+darcs wh -s > ../log/after-ln-wh-s+darcs wh -ls > ../log/after-ln-wh-ls++diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s+diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls++# trying to record the changes without the use of '-l' leads to+# the wrong patch being recorded+darcs rec -am 'Maybe remove maybeFile'+darcs log --last 1 -s | not grep 'M ./maybeFile'++# unrecord the wrong patch+darcs unrec --last 1 -a++# passing '-l' to the record command leads to the right patch+# being  recorded.+darcs rec -lam 'Remove maybeFile'+darcs log --last 1 -s | grep -F './maybeFile' > ../log/after-record-l++diff -u -w ../log/after-record-l ../log/after-ln-wh-ls++# now if you unrecord the last patch the `-l' option does not+# make a difference anymore+darcs unrec --last 1 -a+darcs wh -s > ../log/after-unrec-wh-s+darcs wh -ls > ../log/after-unrec-wh-ls++# use -w to ignore different indentation+diff -u -w ../log/after-record-l ../log/after-unrec-wh-s+diff -u -w ../log/after-record-l ../log/after-unrec-wh-ls++# create again the issue, this time giving the file the same+# content as the file referenced by the link+echo ImmutableFile > maybeFileThree+darcs rec -lam 'Add maybeFileThree'+rm maybeFileThree++darcs wh -s > ../log/before-ln-wh-s+darcs wh -ls > ../log/before-ln-wh-ls++ln -s file maybeFileThree++darcs wh -s > ../log/after-ln-wh-s+darcs wh -ls > ../log/after-ln-wh-ls++diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s+diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls++darcs rec -lam 'Remove maybeFileThree'++# create again the problem, pointing the symbolic link to a+# not-existent file+echo JustAnotherTemporaryFile > maybeFileFour+darcs rec -lam 'Add maybeFileFour'+rm maybeFileFour++darcs wh -s > ../log/before-ln-wh-s+darcs wh -ls > ../log/before-ln-wh-ls++ln -s not-existent maybeFileFour++darcs wh -s > ../log/after-ln-wh-s+darcs wh -ls > ../log/after-ln-wh-ls++diff -u ../log/before-ln-wh-s ../log/after-ln-wh-s+diff -u ../log/before-ln-wh-ls ../log/after-ln-wh-ls++darcs rec -lam 'Remove maybeFileFour'++cd ..
tests/issue2286-metadata-encoding.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-## Test for issue2286 - darcs cha fails when reading non-UTF8 encoded+## Test for issue2286 - darcs changes fails when reading non-UTF8 encoded ## metadata ## ## Copyright (C) 2012 Ganesh Sittampalam@@ -26,9 +26,22 @@  . lib +unpack_testdata metadata-encoding+cd metadata-encoding++darcs log -v+ switch_to_utf8_locale+darcs log -v+darcs clone . ../utf8-clone+darcs log -v --repodir ../utf8-clone -gunzip -c $TESTDATA/metadata-encoding.tgz | tar xf -+switch_to_latin9_locale+darcs log -v+darcs clone . ../latin-clone+darcs log -v --repodir ../latin-clone -cd metadata-encoding-darcs changes+LC_ALL=C+darcs log -v+darcs clone . ../c-clone+darcs log -v --repodir ../c-clone
+ tests/issue2287_obliterate_overwrite.sh view
@@ -0,0 +1,59 @@+#!/usr/bin/env bash+## Test for issue2287 - Obliterate overwrites the existing file +## when the parameter -O is used.+##+## Copyright (C) YEAR  AUTHOR+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+darcs init      --repo R        # Create our test repos.++cd R+echo 'Example content 1.' > f+darcs record -lam 'Add f.'+echo 'Example content for obliterate.' >> f+darcs record -am 'content obliterate'++# Create 'existing useful dpatch'+p='content-obliterate.dpatch'+p1='content-obliterate_0.dpatch'+touch $p++# This command should finish with error, since file already exists.+not darcs obliterate -a -p 'content obliterate' -o $p++if [ ! -z "$(cat $p)" ]; then+   exit 2+fi++# This command create autogenerate non-conflict file+darcs obliterate -a -p 'content obliterate' -O++# Assert file was not overwritten+if [ ! -z "$(cat $p)" ]; then+   exit 2+fi++# Assert new file was created+if [ ! -f $p1 ]; then+   exit 2+fi
+ tests/issue2293-laziness.sh view
@@ -0,0 +1,69 @@+#!/bin/sh -e+##+## Test that commands don't read too much of the repository+##+## Copyright (C) 2013 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf repo+unpack_testdata laziness-cut++cd repo++# log+darcs log --last=1+# amend+echo 'baz' > bar+# note: the last 'y' here is for the hijack prompt+echo yyyy | darcs amend+darcs log --last=1+# amend --ask-deps, deselect the only offered patch (i.e. the tag)+echo yny | darcs amend --ask-deps+# amend --ask-deps, select the tag+# note: the last 'y' here is for the hijack prompt+echo yyyy | darcs amend --ask-deps+# unrecord+echo yd | darcs unrecord+# log --context+darcs log --context > ctx+# record+darcs record -am xxx+darcs log --last=1+# send+echo ydy | darcs send -o xxx.dpatch --context ctx .+# obliterate+echo yd | darcs obliterate -o yyy.dpatch --no-minimize+tail -n +7 xxx.dpatch > zzz.dpatch+diff yyy.dpatch zzz.dpatch+# apply+darcs apply xxx.dpatch --debug+darcs log --last=1+# clean up xxx+echo yd | darcs obliterate+# record --ask-deps, deselect the only offered patch (i.e. the tag)+echo n | darcs record -m emptynodeps --ask-deps # does not record anything+# record --ask-deps, select the tag+echo yy | darcs record -m emptywithdeps --ask-deps++cd ..
+ tests/issue2310-rollback-doesnt-readd.sh view
@@ -0,0 +1,43 @@+## Test for issue2310 - darcs rollback of rmfile doesn't add to pending+##+## Copyright (C) 2013 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+## SOFTWARE.++. lib                           # Load some portability helpers.++rm -rf R++darcs init --repo R++cd R++echo foo > foo +darcs rec -alm 'add foo'++rm foo+darcs rec -am 'remove foo'++echo ynya | darcs rollback++# If the file hasn't been re-added in pending, this line will be missing from+# the output of whatsnew+darcs wh | grep -F 'addfile ./foo'
+ tests/issue2311_posthook_for_get_should_run_in_created_repo.sh view
@@ -0,0 +1,48 @@+#!/usr/bin/env bash+## Test for issue2311 - +##          posthook for 'get' should run in created repo+##+## Copyright (C) 2013 Sebastian Fischer+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++rm -rf repos+mkdir repos+cd repos+mkdir origin+cd origin+darcs init+cd ..++# The output of the posthook `pwd` should include "branch"+# if "branch" is passed as repo name+darcs get origin branch --posthook=pwd > out+head -n 1 out | grep branch++# The output of the posthook `pwd` should include "origin_0"+# if no name for the created repo is passed+darcs get origin --posthook=pwd > out+head -n 1 out | grep origin_0++cd ..+rm -rf repos
+ tests/issue2312_posthooks_for_record_and_amend-record_should_receive_DARCS_PATCHES.sh view
@@ -0,0 +1,75 @@+#!/usr/bin/env bash+## Test for issue2312 - +##     posthooks for 'record' and 'amend-record' should receive DARCS_PATCHES+##+## Copyright (C) 2013 Sebastian Fischer+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init++touch some.file+darcs add some.file++# posthook for darcs record should receive DARCS_PATCHES with correct change+darcs record -am msg1 --posthook="printenv DARCS_PATCHES" > out+cat out+grep msg1 out+grep "A ./some.file" out++# posthook for amend-record should receive DARCS_PATCHES with correct change+echo contents > some.file+echo y | darcs amend-record -a --posthook="printenv DARCS_PATCHES" > out+cat out+grep msg1 out+grep "A ./some.file" out++# newly added file should appear after amend+echo more contents >> some.file+touch new.file+darcs record -am msg2 --posthook="printenv DARCS_PATCHES" > out+cat out+grep msg2 out+grep "M ./some.file" out+not grep "A ./new.file" out+darcs add new.file+echo y | darcs amend-record -a --posthook="printenv DARCS_PATCHES" > out+cat out+not grep msg1 out+grep msg2 out+grep "M ./some.file" out+grep "A ./new.file" out++# no change should appear if it is not recorded+echo > out      # clear out file, in case posthook is not called+echo contents >> new.file+echo ny | darcs record -m msg3 --posthook="printenv DARCS_PATCHES" > out+not grep msg1 out+not grep msg2 out+not grep msg3 out+not grep "M ./new.file" out++cd ..
+ tests/issue2313-trailing-newlines-stack-overflow.sh view
@@ -0,0 +1,17 @@+#!/usr/bin/env bash+. lib++rm -rf temp && mkdir temp++cd temp+darcs init+echo "one line" > test_file.txt+for i in {1..18}+	do cat test_file.txt test_file.txt > test_file2.txt && mv -f test_file2.txt test_file.txt+done+echo -n "last line without newline" >> test_file.txt++darcs add test_file.txt+darcs wh -l | grep "A ./test_file.txt"++cd .. && rm -rf temp
+ tests/issue2333.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+## Test for issue2333 - <SYNOPSIS: Error message when pushing and darcs not in path.>++. lib                           # Load some portability helpers.++require_ghc 706++# work around issue2720 (MacOS)+if test -x /usr/bin/security; then+  ln -s /usr/bin/security .+fi++darcs init      --repo R        # Create our test repos.+darcs init      --repo S++cd R+echo 'Example content.' > f+darcs record -lam 'Add f.'+thedarcs=$(type -P darcs)+PATH='..' $thedarcs push ../S -a	        # Try to push patches between repos.+cd ..
+ tests/issue2343.sh view
@@ -0,0 +1,65 @@+#!/usr/bin/env bash+## Test for issue2343 - 'darcs amend-record does not record my change'+##+## Copyright (C) 2013  José Neder+##+## 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+## SOFTWARE.++. ./lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+cat > file << FOO+{+    foo(foovar);++}++FOO+# The issue happens when the last line not common was a "boring" line. The diff+# algorithm was wrongly checking one line above and therefore it wasn't working+# right.+darcs record -m 'add' --all --look-for-adds+cat > file << FOO+{+    foo(foovar2);+}++FOO+# Here the last line in common is "}". The empty line between "foo(foovar;)""+# and "}" is checked and since it is a "boring" line the last line number is+# incremented, but the line "foo(foovar2);" isn't so the last line number in+# the "newfile" is not incremented and so it makes a bad diff later.+# is important to make a different line from the top+# "foo(foobar);" -> "foo(foovar2);" because if not it will only be an deleted+# line and the algorithm will skip the check of boring lines.+darcs wh >log+cat > log.expected <<EOF+hunk ./file 2+-    foo(foovar);+-++    foo(foovar2);+EOF+diff -u log log.expected+cd ..+rm -rf temp1
+ tests/issue2353.sh view
@@ -0,0 +1,16 @@+## issue2353: darcs does not show old changes of moved files++#!/usr/bin/env bash+. ./lib++rm -rf test+mkdir test+cd test+darcs init+echo 'hello world' > file+darcs add file+darcs record -am 'patch 1' --skip-long+darcs mv file new_file+darcs record -am 'file -> new_file' --skip-long+darcs diff -p 'patch 1' | grep -F "+hello world"+cd ..
+ tests/issue2365-whatsnew-fails-get-no-working-dir.sh view
@@ -0,0 +1,44 @@+#!/usr/bin/env bash+## Test for issue2365 - whatsnew fails in repos made with get --no-working-dir+##+## Copyright (C) 2014 Guillaume Hoffmann+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+darcs init      --repo R        # Create our test repos.++cd R+touch file+darcs rec -lam addfile++cd ..++darcs get R S --no-working-dir++# rename the source repo to trigger the bug, since we are+# now using caches for pristine+mv R X++cd S+not darcs whatsnew | grep "No changes"++cd ..
+ tests/issue2378-moving-directory-to-file.sh view
@@ -0,0 +1,14 @@+darcs initialize +mkdir d+darcs add d+echo sometext > d/f+darcs add d/f+darcs record -am'added d/f' --skip-long-comment+darcs move d/f .+darcs record -am'moved d/f to .' --skip-long-comment+rmdir d+darcs record -am'removed d' --skip-long-comment+darcs move f d+darcs record -am'moved f to d' --skip-long-comment+darcs obliterate --last=3 --all+darcs whatsnew -l
+ tests/issue2380-rename-to-deleted-file.sh view
@@ -0,0 +1,47 @@+#!/usr/bin/env bash+## Test for issue2380 - darcs won't rename a file to a file that has been+## deleted in the working dir.+##+## 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+rm -rf R && darcs init --repo R++. lib++cd R+echo foostuff > foo+echo otherstuff > other+darcs rec -alm 'Add foo and other'++rm foo+darcs mv other foo++# foo should exist, with the correct contents, and other should not+[[ -e foo && ! -e other && $(<foo) == "otherstuff" ]]++echo -e 'hunk ./foo 1\n-foostuff\nrmfile ./foo\nmove ./other ./foo' > expected+darcs wh > actual++diff expected actual++darcs rev -a++[[ -e foo && -e other && $(<foo) == "foostuff" && $(<other) == "otherstuff" ]]
+ tests/issue2382-mv-dir-to-file-confuses-darcs.sh view
@@ -0,0 +1,180 @@+#!/usr/bin/env bash+## Test for issue2382 - we can confuse darcs by moving a directory to where a+## file previously was.+##+## 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+## SOFTWARE.++function getRecordedChanges () {+darcs rec -am 1+# Ignore patch details and unindent - we should have the same contents as wh+darcs changes --last 1 -v | tail -n+5 | sed -e 's/^\s\+//' | grep -v '^[{}]$' > $1+darcs unrecord --last 1 -a+}++function rmOutputFiles () {+    rm recoutput* expected* whoutput*+}++. lib+rm -rf R+darcs init --repo R+cd R++# foo is recorded as a file+echo foo > foo+darcs rec -alm 'Add foo'++rm foo++darcs wh++# foo is now a dir in working, with a file within+mkdir foo+touch foo/bar++darcs wh > whoutput1+cat << EOF > expected1+hunk ./foo 1+-foo+rmfile ./foo+EOF++diff whoutput1 expected1++# Ensure recording everything isn't any different to asking whatsnew+getRecordedChanges recoutput1+diff recoutput1 expected1+rmOutputFiles++# To avoid the output file appearing in the output of wh -l+whl=$(darcs wh -l)+echo "$whl" > whoutput2+cat << EOF > expected2+R ./foo+a ./foo/+a ./foo/bar+EOF++diff whoutput2 expected2++darcs add foo++darcs wh > whoutput3+cat << EOF > expected3+hunk ./foo 1+-foo+rmfile ./foo+adddir ./foo+EOF++diff whoutput3 expected3+getRecordedChanges recoutput3+diff recoutput3 expected3+rmOutputFiles++darcs add foo/bar++darcs wh > whoutput4+cat << EOF > expected4+hunk ./foo 1+-foo+rmfile ./foo+adddir ./foo+addfile ./foo/bar+EOF++diff whoutput4 expected4+getRecordedChanges recoutput4+diff recoutput4 expected4++# Make sure we can remove the directory, without modifying working+darcs remove foo/bar+darcs remove foo++darcs add -r foo+darcs wh > whoutput4a+getRecordedChanges recoutput4a++diff whoutput4a expected4+diff recoutput4a expected4+rmOutputFiles++# Make sure foo is now recorded as a directory+darcs rec -alm 'Make foo a dir'++# Evil. Poor darcs, having to work all this out. We've made foo back into a+# file in working+rm -r foo+touch foo++darcs wh > whoutput5+cat << EOF > expected5+rmfile ./foo/bar+rmdir ./foo+EOF++diff whoutput5 expected5+getRecordedChanges recoutput5+diff recoutput5 expected5+rmOutputFiles++darcs rev -a++mkdir bar+darcs rec -alm 'Add bar dir'+rmdir bar++touch bar++darcs wh > whoutput6+cat << EOF > expected6+rmdir ./bar+EOF++diff whoutput6 expected6+getRecordedChanges recoutput6+diff recoutput6 expected6+rmOutputFiles++whl=$(darcs wh -l)+echo "$whl" > whoutput7++cat << EOF > expected7+R ./bar/+a ./bar+EOF++diff whoutput7 expected7++darcs add bar++darcs wh > whoutput8+cat << EOF > expected8+rmdir ./bar+addfile ./bar+EOF++diff whoutput8 expected8+getRecordedChanges recoutput8+diff recoutput8 expected8+rmOutputFiles
+ tests/issue2432-pull-reorder-commute.sh view
@@ -0,0 +1,47 @@+#!/usr/bin/env bash+## Test for issue2432 - pull --reorder fails to commute patches+##+## Copyright (C) 2015 G. Hoffmann+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+darcs init      --repo R        # Create our test repos.++cd R+echo X > x+darcs record -lam 'Add x with one line'++darcs clone . ../S++sed -i "1iNEW FIRST LINE" x+darcs record -am 'insert line at beginning'++cd ../S++echo "NEW LAST LINE" >> x+darcs record -am 'insert line at the end'++darcs log -p "insert line at the end"  --last 1 -v |grep "hunk ./x 2"++# darcs pull --all+darcs pull --all --reorder+darcs check
− tests/issue244_changes.sh 
@@ -1,18 +0,0 @@-#!/usr/bin/env bash-set -ev--# Issue244-# darcs changes should be able to pull up the history for a file-#   using its moved and not-yet recorded new name--rm -rf temp1-mkdir temp1-cd temp1-darcs init-touch b-darcs add b-darcs record -am 11-darcs mv b c-darcs changes c | grep 11-cd ..-rm -rf temp1
+ tests/issue2479-mv-list-files.sh view
@@ -0,0 +1,14 @@+#!/usr/bin/env bash+## Test for issueNNNN - Bad error message in 'darcs move' if the repo root dir (".")+##                      is given among multiple sources for the move.++. lib                           # Load some portability helpers.++mkdir R+cd R+darcs init+echo "test" > b+darcs add b+darcs record -a -m 'added b'+mkdir a+not darcs move . ./b a 2>&1 | not grep -i bug
+ tests/issue2480-display-unicode-in-patch-content.sh view
@@ -0,0 +1,9 @@+#!/usr/bin/env bash++. lib+darcs init R+cd R+echo 'äöüßÄÖÜ' > file+darcs whatsnew -l --no-summary | grep '+äöüßÄÖÜ'+darcs record -lam'added file'+darcs log -v | grep '+äöüßÄÖÜ'
+ tests/issue2494-output-of-record-with-file-arguments.sh view
@@ -0,0 +1,79 @@+#!/usr/bin/env bash++# Load some portability helpers+. lib++echo added          >> ../all_paths+echo not-added      >> ../all_paths+echo recorded       >> ../all_paths+echo removed        >> ../all_paths+echo not-existing   >> ../all_paths+echo /not-repo-path >> ../all_paths++check_report() {+  yes="$1"+  log="$2"+  pre="$3"+  shift+  shift+  shift+  paths="$@"+  for arg in "$@"; do+    grep $yes "$pre.\+$arg" "$log"+  done+}++check_report_yes() {+  check_report '' "$@"+}++check_report_no() {+  check_report '-v' "$@"+}++# Create and populate test repo+darcs init --repo R+cd R+touch recorded removed+darcs add recorded removed+darcs record -am'two files'+touch added not-added+rm removed+darcs add added++# Now do the tests+echo q | darcs record added not-added recorded removed not-existing /not-repo-path > ../record.out 2>&1++check_report_yes ../record.out 'invalid repository path' /not-repo-path+check_report_no ../record.out 'invalid repository path' added not-added recorded removed not-existing++check_report_yes ../record.out 'non-existing' not-added not-existing+check_report_no ../record.out 'non-existing' added recorded removed /not-repo-path++check_report_yes ../record.out 'not.\+in.\+repository' added+check_report_no ../record.out 'not.\+in.\+repository' not-added recorded removed not-existing /not-repo-path++check_report_yes ../record.out 'Recording' added recorded removed+check_report_no ../record.out 'Recording' not-added not-existing /not-repo-path++echo q | darcs record -l added not-added recorded removed not-existing /not-repo-path > ../record-l.out 2>&1++check_report_yes ../record-l.out 'invalid repository path' /not-repo-path+check_report_no ../record-l.out 'invalid repository path' added not-added recorded removed not-existing++check_report_yes ../record-l.out 'non-existing' not-existing+check_report_no ../record-l.out 'non-existing' added not-added recorded removed /not-repo-path++check_report_no ../record-l.out 'not.\+in.\+repository' added not-added recorded removed not-existing /not-repo-path++check_report_yes ../record-l.out 'Recording' added not-added recorded removed+check_report_no ../record-l.out 'Recording' not-existing /not-repo-path++echo q | darcs record -l -q added not-added recorded removed not-existing /not-repo-path > ../record-l-q.stdout++not grep 'paths' ../record-l-q.stdout+check_report_no ../record-l-q.stdout 'Recording' added not-added recorded removed not-existing /not-repo-path++echo q | darcs record -q -a -m'patchname' added not-added recorded removed not-existing /not-repo-path > ../record-q-a.stdout++not grep '.' ../record-q-a.stdout
+ tests/issue2496-output-of-whatsnew-with-file-arguments.sh view
@@ -0,0 +1,72 @@+#!/usr/bin/env bash++# Load some portability helpers+. lib++echo added          >> ../all_paths+echo not-added      >> ../all_paths+echo recorded       >> ../all_paths+echo removed        >> ../all_paths+echo not-existing   >> ../all_paths+echo /not-repo-path >> ../all_paths++check_report() {+  yes="$1"+  log="$2"+  pre="$3"+  shift+  shift+  shift+  paths="$@"+  for arg in "$@"; do+    grep $yes "$pre.\+$arg" "$log"+  done+}++check_report_yes() {+  check_report '' "$@"+}++check_report_no() {+  check_report '-v' "$@"+}++# Create and populate test repo+darcs init --repo R+cd R+touch recorded removed+darcs add recorded removed+darcs record -am'two files'+touch added not-added+rm removed+darcs add added++# Now do the tests+darcs whatsnew added not-added recorded removed not-existing /not-repo-path > ../whatsnew.out 2>&1++check_report_yes ../whatsnew.out 'invalid repository path' /not-repo-path+check_report_no ../whatsnew.out 'invalid repository path' added not-added recorded removed not-existing++check_report_yes ../whatsnew.out 'non-existing' not-added not-existing+check_report_no ../whatsnew.out 'non-existing' added recorded removed /not-repo-path++check_report_yes ../whatsnew.out "What's new" added recorded removed+check_report_no ../whatsnew.out "What's new" not-added not-existing /not-repo-path++darcs whatsnew -l added not-added recorded removed not-existing /not-repo-path > ../whatsnew-l.out 2>&1++check_report_yes ../whatsnew-l.out 'invalid repository path' /not-repo-path+check_report_no ../whatsnew-l.out 'invalid repository path' added not-added recorded removed not-existing++check_report_yes ../whatsnew-l.out 'non-existing' not-existing+check_report_no ../whatsnew-l.out 'non-existing' added not-added recorded removed /not-repo-path++check_report_no ../whatsnew-l.out 'not.\+in.\+repository' added not-added recorded removed not-existing /not-repo-path++check_report_yes ../whatsnew-l.out "What's new" added not-added recorded removed+check_report_no ../whatsnew-l.out "What's new" not-existing /not-repo-path++darcs whatsnew -l -q added not-added recorded removed not-existing /not-repo-path > ../whatsnew-l-q.stdout++not grep 'paths' ../whatsnew-l-q.stdout+check_report_no ../whatsnew-l-q.stdout "What's new" added not-added recorded removed not-existing /not-repo-path
+ tests/issue2512-multiple-authors-clobbered-in-global-conf.sh view
@@ -0,0 +1,46 @@+#!/usr/bin/env bash+## Test for issue2512 - Multiple authors in global config get overwritten++. lib++# helper+function fail {+	echo "ERROR: $1"+	exit 1+}++# add multiple author IDs to global preferences+cat >"$HOME/.darcs/author" <<-EOF+	AUTHOR_1, this one will be chosen when prompted for an author+	AUTHOR_2, this one should still be there in the end+EOF++# create a repo+rm -rf repo+mkdir repo+cd repo+darcs init++# make a change so that we have something to commit+touch changed+darcs add changed++# darcs will find multiple authors in global preferences,+# so darcs will ask for the author and we pick the first one+darcs record -am 'testing' <<-EOF+	1+EOF+echo++# check the configuration after the commit (primary test for this issue)+if ! grep -q 'AUTHOR_2' "$HOME/.darcs/author"; then+	fail "'\$HOME/.darcs/author' with multiple authors was clobbered."+fi++# in addition, confirm that the author was properly added to the repository+if ! [[ -f _darcs/prefs/author ]]; then+	fail "The author was not recorded in the repository."+fi+if ! grep -q 'AUTHOR_1' _darcs/prefs/author; then+	fail "An 'author' file was created in the repository, but does not contain the chosen author."+fi
+ tests/issue2526-whatsnew-boring.sh view
@@ -0,0 +1,19 @@+#!/usr/bin/env bash++. lib++# test that 'whatsnew --boring' actually lists boring files++rm -rf R+darcs init R+cd R++echo xxx > boring+darcs setpref boringfile boring+darcs record -lam'added boring and set as boringile'+touch xxx+darcs whatsnew --boring | grep xxx+darcs whatsnew --boring | grep -v 'No changes'++cd ..+rm -rf R
+ tests/issue2536-show-files--no-files.sh view
@@ -0,0 +1,7 @@+. lib+rm -rf R+darcs init R+cd R+touch foo bar+darcs rec -lam'add foo and bar'+darcs show files --no-files
+ tests/issue2548-inconsistent-pending.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash++. lib++# add a file, turn it into a directory in the working tree,+# then let darcs figure out how to handle that++rm -rf R+darcs init R+cd R+touch f+darcs add f+rm f+mkdir f+darcs whatsnew -l --no-summary | tee ../before+darcs record -lam 'patchname'+darcs log -v | tee ../after+for log in ../before ../after; do+  grep 'adddir ./f' $log+  not grep 'addfile ./f$' $log+done+cd ..++# same with dir and file swapped++rm -rf R+darcs init R+cd R+mkdir f+# for good measure add a file to the directory+touch f/g+darcs add -r f+rm -rf f+touch f+darcs whatsnew -l --no-summary | tee ../before+darcs record -vlam 'patchname'+darcs log -v | tee ../after+for log in ../before ../after; do+  grep 'addfile ./f' $log+  not grep 'adddir ./f' $log+done+cd ..
+ tests/issue2549-trailing-slash-in-patch-bundle.sh view
@@ -0,0 +1,28 @@+. lib++rm -rf R S N W++mkdir R S+darcs init R+darcs init S+cd R+mkdir directory+darcs add directory+darcs record -am 'add directory'+darcs send -a -o orig.dpatch ../S+sed -e s'#adddir ./directory#adddir ./directory/#'\+ -e '/Patch bundle hash:/,+2d' orig.dpatch > tweaked.dpatch+cd ../S+darcs apply ../R/tweaked.dpatch+rm -rf directory+darcs record -am 'rm directory'+cd ..+# Now, try pulling these patches.+darcs init --no-patch-index N+cd N+darcs pull -a ../S+cd ..+darcs init --with-patch-index W+cd W+darcs pull -a ../S+cd ..
+ tests/issue2567-darcs-whatsnew-unified.sh view
@@ -0,0 +1,41 @@+#!/usr/bin/env bash++# check that darcs whatsnew --unified outputs correct context lines++. lib++cat > before << EOF+1+2+3+4+5+EOF++cat > after << EOF+1+3+4a+4b+5+EOF++cat > exp << EOF+hunk ./file 2+ 1+-2+ 3+hunk ./file 3+-4++4a++4b+ 5+EOF++darcs init R+cd R+cp ../before file+darcs record -lam 'add file'+cp ../after file+darcs whatsnew --unified > ../got+diff ../exp ../got
+ tests/issue2575-revert_during_rebase.sh view
@@ -0,0 +1,11 @@+. lib++darcs init R+cd R+touch f+darcs record -l f -am'add f'+darcs rebase suspend -a --last 1+echo bla > g+darcs add g+darcs revert -a+not grep 'DO NOT TOUCH' _darcs/patches/unrevert
+ tests/issue2581-rebase_pull_reorder_updates_format.sh view
@@ -0,0 +1,16 @@+. lib++darcs init R+cd R+touch f+darcs record -l f -am "add f in R"+cd ..++darcs init S+cd S+touch f+darcs record -l f -am "add f in S"++# first y is for the "repos are unrelated" prompt+echo yaa | darcs rebase pull ../R --reorder-patches+darcs rebase log
+ tests/issue2592-pending-look-for.sh view
@@ -0,0 +1,60 @@+#!/usr/bin/env bash+. ./lib++# darcs add a file and then rename without telling darcs++rm -rf test1+darcs init test1+cd test1+touch f+darcs add f+mv f g+# plain darcs whatsnew differs from pending+# because it sees that the file is no longer there+# (because removals are always detected implicitly)+grep 'addfile ./f' _darcs/patches/pending+not darcs whatsnew # No changes+darcs whatsnew --look-for-moves | grep 'addfile ./g'+darcs record -am 'addfile f + move f g = addfile g' --look-for-moves+# make sure pending is now empty+not darcs whatsnew+cd ..++# add and record a file, darcs move it and then rename it back+# without telling darcs about it++rm -rf test2+darcs init test2+cd test2+touch f+darcs add f+darcs record -lam 'addfile f' f+# make sure pending is empty+not darcs whatsnew+darcs move f g+darcs whatsnew | grep 'move ./f ./g'+mv g f+# plain darcs whatsnew differs from pending+# because it sees that the file is no longer there+# (because removals are always detected implicitly)+grep 'move ./f ./g' _darcs/patches/pending+darcs whatsnew | grep 'rmfile ./f'+# but with --look-for-moves pending and working cancel each other+not darcs whatsnew --look-for-moves # No changes++# so recording with --look-for-moves sees no changes+darcs record -a --look-for-moves | grep -i "you don't want to record anything"++# the record did nothing, so same checks as above should succeed+darcs whatsnew | grep 'rmfile ./f'+grep 'move ./f ./g' _darcs/patches/pending+not darcs whatsnew --look-for-moves # No changes++# # darcs add has no option --look-for-moves/replaces yet+# # so we have no way to "fix" pending+# darcs add --look-for-moves+# # pending should now be empty+# diff ../empty_pending _darcs/patches/pending+# darcs whatsnew | grep 'rmfile ./f'+# not darcs whatsnew --look-for-moves+cd ..
+ tests/issue2594-darcs-show-index-breaks-replace.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash+## Test for issue2594 - (originally issue2208) darcs show index+## crashes replace with unrecorded force hunk+##+## Copyright (C) 2012 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+## SOFTWARE.++. lib++rm -rf R++darcs init --repo R++cd R++echo -e 'foo\nbar' > testing++darcs rec -alm 'Add testing file'++darcs show index++echo -e 'baz\nbar' > testing++darcs replace bar foo testing
+ tests/issue2603-clone-repo-with-unresolved-conflicts.sh view
@@ -0,0 +1,24 @@+#!/usr/bin/env bash++# issue2603: clone of a repo with unresolved conflicts gives no warning+# and no applies no conflict markup++. lib++rm -rf R+darcs init R+cd R+echo foo > f+darcs record -lam foo+cd ..++rm -rf S+darcs init S+cd S+echo bar > f+darcs record -lam bar+darcs pull ../R -a --allow-conflicts+cd ..++rm -rf T+darcs clone S T 2>&1 | grep conflicts
+ tests/issue2605-duplicates.sh view
@@ -0,0 +1,43 @@+#!/usr/bin/env bash++# This is the scenario described in Appendix B of the camp paper+# to motivate giving identities (there called "names") to prim patches.+# We make the same change A1 and A2 independently in two separate repos,+# then record B that depends on A1. But it doesn't, not really. What it+# depends on is the /change/ made by A1, and since A2 makes the identical+# change we can arrange things so that we replace dependency A1 with the+# alternative dependency A2.++. lib++# this test fails for darcs-1 and darcs-2 repos and we cannot fix it+skip-formats darcs-1 darcs-2++rm -rf R1 R2++darcs init R1+cd R1+echo A > f+darcs record -lam A1 f+echo B > f+darcs record -lam B f+cd ..++darcs init R2+cd R2+echo A > f+darcs record -lam A2 f+darcs pull ../R1 -a --allow-conflicts+# this should fail according to Ian...+darcs obliterate -a -p A1+cd ..++cd R1+# ...instead of this crashing+darcs pull ../R2 -a --allow-conflicts+cd ..++cd R2+# ...or this+darcs pull ../R1 -a --allow-conflicts+cd ..
+ tests/issue2614-clone-unclean-tag.sh view
@@ -0,0 +1,23 @@+. lib++rm -rf R S T+darcs init R+cd R+echo apply allow-conflicts >> _darcs/prefs/defaults+echo bla > foo+darcs record -lam 'bla R'+darcs tag one+cd ..++darcs init S+cd S+echo bla > foo+darcs record -lam 'bla S'+darcs tag one+echo blub > foo+darcs record -lam 'blub S'+darcs tag two+darcs push ../R -a+cd ..++darcs clone R T --tag two
+ tests/issue2618-ask-deps-too-many.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+# Test that --ask-deps adds no more than the specified explicit dependencies+# and not indirect (implicit) dependencies.++. ./lib++rm -rf R+darcs init R+cd R+echo text > file+darcs record -lam 'one'+echo othertext > file+darcs record -am 'two'+echo text > other_file+echo yd | darcs record -lam 'three' --ask-deps+darcs log -s --last=1 | tee LOG+# should depend on patch named 'two'+grep two LOG+# but not on patch named 'one'+not grep one LOG+cd ..
+ tests/issue2634-rebase-conflicted-patches.sh view
@@ -0,0 +1,103 @@+#!/usr/bin/env bash++# Test for issue2634: suspending and unsuspending conflicted patches++. ./lib++# prepare: make two conflicting patches one and two and merge them+rm -rf R S T1 T2+darcs init R+cd R+touch file+darcs record -l file -am 'base'+echo one > file+darcs record file -am 'one'+darcs clone . ../S+echo two > file+echo y|darcs amend -am 'two' -p one+echo y|darcs pull ../S -a --allow-conflicts --reorder-patches+# patch order should be init; one; two+cd ..++# test1: suspend both 'one' and 'two', rebase obliterate 'one', then unsuspend+rm -rf T1+darcs clone R T1+cd T1+# get rid of conflict markup+darcs revert -a+echo yydyy | darcs rebase suspend+echo yd|darcs rebase obliterate+darcs rebase unsuspend -p two -a+cat file >&2+not grep one file+grep two file+cd ..++# test2: suspend 'two' and obliterate 'one', then unsuspend+rm -rf T2+darcs clone R T2+cd T2+# get rid of conflict markup+darcs revert -a+echo ydy | darcs rebase suspend+echo y|darcs obliterate -p one -a+darcs rebase unsuspend -p two -a+cat file >&2+not grep one file+grep two file+cd ..++# prepare: three-way conflict+rm -rf U+darcs clone S U+cd U+echo three > file+echo y|darcs amend -am 'three' -p one+echo y|darcs pull ../R -a --allow-conflicts --reorder-patches+# patch order should be init; one; two; three+cd ..++# test3: suspend 'three', obliterate 'two', then unsuspend+rm -rf T3+darcs clone U T3+cd T3+# get rid of conflict markup+darcs revert -a+echo ydy | darcs rebase suspend+echo y|darcs obliterate -p two -a+darcs rebase unsuspend -p three -a+cat file >&2+grep one file+not grep two file+grep three file+cd ..++# test4: suspend all, rebase obliterate 'one', then unsuspend+rm -rf T4+darcs clone U T4+cd T4+# get rid of conflict markup+darcs revert -a+echo yyydyyy | darcs rebase suspend+echo yd|darcs rebase obliterate+darcs rebase unsuspend -a+cat file >&2+not grep one file+grep two file+grep three file+cd ..++# test5: suspend all, rebase obliterate 'one' and 'two', then unsuspend+rm -rf T5+darcs clone U T5+cd T5+# get rid of conflict markup+darcs revert -a+echo yyydyyy | darcs rebase suspend+echo yyd|darcs rebase obliterate+darcs rebase unsuspend -a+cat file >&2+not grep one file+not grep two file+grep three file+cd ..
+ tests/issue2639-diff-crashes-with-last-and-file.sh view
@@ -0,0 +1,20 @@+# test for issue2639: darcs diff crashes with --last=1 and file name++. lib++darcs init R+cd R+echo a > f+cp f g+darcs record -lam 'a'+echo b > f+cp f g+darcs diff f --last=1+# issue2639: this crashed with+# ### Error applying:+# hunk ./g 1+# -a+# ### to file g:+# b+# ### Reason: Hunk wants to remove content that isn't there+cd ..
+ tests/issue2648_darcs_convert_import_double_encodes_cyrillic.sh view
@@ -0,0 +1,40 @@+#!/bin/sh -e+##+## Test for issue2648 - `darcs convert import` double-encodes cyrillic characters in UTF-8 input stream+##+## Copyright (C) 2020  Andrey Korobkov <alster@vinterdalen.se>+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.++switch_to_utf8_locale++# Import stream into Darcs repo+cat $TESTDATA/cyrillic_import_stream | darcs convert import R++cd R++# Test patch name+darcs log | grep 'Южноэфиопский грач увёл мышь за хобот на съезд ящериц'++# Test filename and patch data+darcs annotate 'Панграмма.txt' | grep 'Широкая электрификация южных губерний даст мощный толчок подъёму сельского хозяйства'
+ tests/issue2659-show-dependencies.sh view
@@ -0,0 +1,25 @@+#!/usr/bin/env bash++# test that 'darcs show dependencies' shows only the direct dependencies++. lib++rm -rf R+darcs init R+cd R++# 4 patches, each depending on the previous one+echo a > f+darcs record -lam a+echo b > f+darcs record -lam a+echo c > f+darcs record -lam a+echo d > f+darcs record -lam d++# the number of edges in the dependency graph should be exactly 3+darcs show dependencies > graph.dot+test "3" = $(grep -wF -- '->' graph.dot | wc -l)++cd ..
+ tests/issue2668-create-directory-permission.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+# issue2668 is actually two separate issues:+# * patch index does not work with repos whose parent dir is read-only+# * failure to create or update patch index should not make other commands fail++. lib++readonly_path=$(/bin/pwd)/readonly+trap "chmod -R +w $readonly_path" EXIT++rm -rf readonly+mkdir readonly++darcs init R++darcs init S+darcs optimize enable-patch-index --repo=S++mv R S readonly+chmod -w readonly++# 1st problem+cd readonly/R+darcs optimize disable-patch-index+darcs optimize enable-patch-index+cd ../..++# 2nd problem+cd readonly/S+# provoke failure when we try to update the patch index+# even if 1st problem is no longer an issue+chmod -w _darcs/patch_index+echo text > file+darcs record -l file -am 'file'+darcs unrecord -a -p 'file'+cd ../..
+ tests/issue2674-moving-unadded-files.sh view
@@ -0,0 +1,20 @@+. lib++rm -rf R+darcs init R+cd R+echo added >added.txt+echo unadded >unadded.txt+mkdir newdir+darcs add added.txt newdir/+not darcs mv added.txt unadded.txt newdir/ > LOG+not grep unadded LOG+# i.e. not this:+#Finished moving: ./added.txt ./unadded.txt to: ./newdir+darcs whatsnew -s > LOG+not grep unadded LOG+# i.e. not this:+# A ./newdir/+#  ./unadded.txt -> ./newdir/unadded.txt+# A ./newdir/added.txt+cd ..
+ tests/issue2682.sh view
@@ -0,0 +1,72 @@+#!/usr/bin/env bash+# test for issue2682: conflict not marked if tag pulled at the same time++. lib++rm -rf R S+darcs init R+cd R+echo initial>file+darcs add file+darcs record -am initial+darcs clone . ../S++# Record a change in R+echo one > file+darcs record -am one+cd ../S++# Record a conflicting change in S+echo two > file+darcs record -am two+cd ..++tag() {+  name=T$1+  rm -rf $name+  darcs clone $1 $name+  cd $name+  darcs tag $name+  cd ..+}++depend() {+  name=D$1+  rm -rf $name+  darcs clone $1 $name+  cd $name+  echo yd | darcs record --ask-deps -m $name+  cd ..+}++runtest() {+  cd $2+  # Pull from R to S+  # Darcs should say there's a conflict and+  # mark it, but instead the pull silently succeeds.+  darcs pull ../$1 -a 2>&1 | tee LOG+  grep -i conflicts LOG+  darcs whatsnew++  # undo the pull+  darcs revert -a+  echo y | darcs obliterate -a --last=2+  # again, this time with --reorder-patches+  darcs pull ../$1 -a --reorder-patches 2>&1 | tee LOG+  grep -i conflicts LOG+  darcs whatsnew+  cd ..+}++# test all 4 combinations of tag/depend+tag R+depend R++tag S+runtest TR TS+depend S+runtest TR DS+tag S+runtest DR TS+depend S+runtest DR DS
+ tests/issue2697-amend-unrecord.sh view
@@ -0,0 +1,17 @@+#!/usr/bin/env bash++# amend --unrecord should move unrecorded changes to pending++. lib++rm -rf R+darcs init R+cd R++echo bla > bla+darcs record -lam 'bla'+echo yyy | darcs amend --unrecord -a bla+darcs whatsnew > new+grep 'addfile ./bla' new++cd ..
+ tests/issue2699-obliterate-rebase-suspend-pending.sh view
@@ -0,0 +1,30 @@+# test for issue2699++. lib+rm -rf R S+darcs init R+cd R++mkdir d+darcs record -lam add-d+darcs move d e+darcs record -am move-d-e++darcs clone . ../S++touch e/f+darcs add e/f+echo yy | darcs obliterate -p move-d-e+cat >../pending_expected <<EOF+addfile ./d/f+EOF+diff _darcs/patches/pending ../pending_expected >&2++cd ../S++touch e/f+darcs add e/f+echo yy | darcs rebase suspend -p move-d-e+diff _darcs/patches/pending ../pending_expected >&2++cd ..
tests/issue27.sh view
@@ -1,6 +1,6 @@ #!/bin/sh -set -ev+. ./lib  rm -rf temp1 temp2 mkdir temp1 temp2
+ tests/issue2702-invalid-regex.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash++. lib++darcs init R+cd R+# need to have at least one patch as long as we throw the error+# only when we actually try to match+touch f+darcs rec -lam 'dummy'+# test that using an invalid regex is not treated as bug in darcs+not darcs log -p '' >&2+not darcs log -p '[' >&2+not darcs log -p '*x' >&2+cd ..
+ tests/issue2714-cannot-remove-recursively.sh view
@@ -0,0 +1,9 @@+. lib++darcs init R+cd R+mkdir -p src/System/Foo/Bar+darcs record -lam "add directories"+# darcs show files >&2+darcs remove --recursive src/+cd ..
tests/issue279_get_extra.sh view
@@ -5,38 +5,39 @@  . lib -rm -rf temp1 temp_a temp_b temp_c temp_d+# this test fails for darcs-1 repos+skip-formats darcs-1++rm -rf temp1 mkdir temp1 cd temp1-darcs init --darcs-2+darcs init echo 0 > f darcs add f darcs record -am 00 cd ..  for r in a b c d; do-  darcs put --repodir temp1 temp_$r-  cd temp_$r;+  rm -rf temp_$r+  darcs get temp1 temp_$r+  cd temp_$r   echo $r > f-  darcs record -am "patch:$r";+  darcs record -am "patch:$r"   cd .. done  cd temp_d-darcs pull -a ../temp_a-darcs pull -a ../temp_b-darcs pull -a ../temp_c+darcs pull -a ../temp_a --allow-conflicts+darcs pull -a ../temp_b --allow-conflicts+darcs pull -a ../temp_c --allow-conflicts cd .. cd temp_c-darcs pull -a ../temp_a-darcs pull -a ../temp_b+darcs pull -a ../temp_a --allow-conflicts+darcs pull -a ../temp_b --allow-conflicts echo rc > f darcs record -a -m rc cd .. cd temp_d darcs pull -a ../temp_c > log-not grep -i "no remote changes" log-not grep -i get_extra log+not grep -i "Failed to commute common patches" log cd ..--rm -rf temp1 temp_a temp_b temp_c temp_d log
tests/issue381.sh view
@@ -1,11 +1,8 @@ #!/usr/bin/env bash-set -ev+. ./lib  # for issue381: "darcs send -o message --edit-description doesn't work" -DARCS_EDITOR=echo-export DARCS_EDITOR- rm -rf temp1 temp2 mkdir temp1 temp2 @@ -47,4 +44,3 @@ IFS=' ' darcs send --author=me -a --subject="it works" --to user@place.org --sendmail-command='grep "^Subject: it works$" %<' ../temp2  cd ..-rm -rf temp1 temp2
tests/issue436.sh view
@@ -1,30 +1,27 @@ #!/usr/bin/env bash-set -ev -rm -rf temp1 temp2+. ./lib+ mkdir temp1 cd temp1-# this test fails in the darcs 1 format-darcs init --darcs-2+darcs init echo A > f darcs add f-darcs record --ignore-times -a -m A+darcs record -a -m A cd ..  darcs get temp1 temp2  cd temp1 echo C > f-darcs record --ignore-times -a -m A-C+darcs record -a -m A-C cd ..  cd temp2 echo B > f-darcs record --ignore-times -a -m A-B+darcs record -a -m A-B echo A > f-darcs record --ignore-times -a -m B-A+darcs record -a -m B-A (darcs push -a || :) 2> push-result grep "Refusing to apply" push-result cd ..--rm -rf temp1 temp2
tests/issue458.sh view
@@ -1,14 +1,12 @@ #!/usr/bin/env bash ### http://bugs.darcs.net/issue458 ### darcs get --set-scripts-executable ignores umask-set -ev--## Windows doesn't support proper permissions.+. ./lib -if echo $OS | grep -i windows; then-    echo Windows does not support posix permissions-    exit 0-fi+# We can set and clear permission bits with bash on Windows but that+# has not the expected effect on programs. So even though this test+# actually succeeds on Windows, it makes no sense to run it.+abort_windows  rm -rf temp mkdir temp@@ -26,4 +24,3 @@ diff -u desired-mode mode  cd ..-rm -rf temp
+ tests/issue494-pending-sort.sh view
@@ -0,0 +1,41 @@+#!/usr/bin/env bash+## Test for issue494: pending patch when files are renamed+##+## Copyright (C) 2007 Eric Kow+##+## 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+## SOFTWARE.++mkdir R+cd R+darcs init+echo abc > b+darcs add b+darcs record --all -m patch1 -A moi+darcs mv b a+echo def > a+darcs record --all -m patch2 -A moi+cd ..++mkdir S+cd S+darcs init+darcs pull --all ../R+darcs whatsnew | grep 'No changes'
tests/issue525_amend_duplicates.sh view
@@ -1,9 +1,6 @@ #!/bin/sh -set -ev--## I would use the builtin !, but that has the wrong semantics.-not () { "$@" && exit 1 || :; }+. ./lib  rm -rf temp1 mkdir temp1@@ -21,4 +18,3 @@ cat output not grep first output cd ..-rm -rf temp1
tests/issue538.sh view
@@ -1,8 +1,8 @@-#!/bin/env bash+#!/usr/bin/env bash # A test for issue 538 - that an executable test script will run successfully if # it is recorded with --set-scripts-executable. -set -ev+. ./lib  if echo $OS | grep -i windows; then     echo I do not know how to run a test program under windows@@ -70,10 +70,10 @@ fi cd .. -# trackdown with --set-scripts-executable+# test --linear with --set-scripts-executable rm -rf temp1 make_repo_with_test-if darcs trackdown --set-scripts-executable | grep 'Success!' ; then+if darcs test --linear --set-scripts-executable | grep 'Test does not fail on head' ; then     echo "ok 5" else     echo "not ok 5 tracking down with --set-scripts-executable failed (because test failed?)"@@ -81,10 +81,10 @@ fi cd .. -# trackdown without --set-scripts-executable+# test --linear without --set-scripts-executable rm -rf temp1 make_repo_with_test-if darcs trackdown --dont-set-scripts-executable | grep 'Noone passed the test!' ; then+if darcs test --linear --dont-set-scripts-executable | grep 'Noone passed the test!' ; then     echo "ok 6" else     echo "not ok 6 tracking down did not find failure even though --dont-set-scripts-executable was given"@@ -92,7 +92,7 @@ fi cd .. -# check trackdown with files that become scripts during trackdown+# check test --linear with files that become scripts during trackdown rm -rf temp1 mkdir temp1 ; cd temp1 ; darcs init echo "#!/bin/sh" > test.sh@@ -105,11 +105,11 @@ echo 'this is definitely not a valid script' > helper.sh darcs record -am 'invalid helper' -A test darcs setpref test './test.sh'-darcs trackdown --set-scripts-executable > trackdown-out-if grep 'Test failed!' trackdown-out && grep 'Success!' trackdown-out ; then+darcs test --linear --set-scripts-executable > trackdown-out+if grep 'Test failed!' trackdown-out && grep 'Last recent patch' trackdown-out ; then     echo "ok 7" else -    echo "not ok 7 either no failure or no success (both should occur)"+    echo "not ok 7 either no failure or no report of problem patch (both should occur)"     exit 1 fi cd ..
tests/issue588.sh view
@@ -2,7 +2,7 @@  # For issue588, "amend-record --look-for-adds end up with two "addfile" entries" -set -ev+. ./lib  rm -rf temp1 darcs init --repodir temp1@@ -27,6 +27,6 @@  darcs changes --repodir temp1 --last 1 -v -darcs check --repodir temp1 --no-test+darcs check --repodir temp1  rm -rf temp1
tests/issue595_get_permissions.sh view
@@ -15,36 +15,24 @@  abort_windows -rm -rf temp1 temp2+rm -rf tmp_remote tmp_restrictive  # Set up a "remote" repo-mkdir tmp_remote-cd tmp_remote-darcs 'init'-cd ..+darcs init tmp_remote -DIR=`pwd`+DIR=`/bin/pwd`+trap "chmod +wx $PWD/tmp_restrictive" EXIT+ # Set up a directory with restrictive permissions mkdir -p tmp_restrictive/liberal cd tmp_restrictive/liberal-chmod 0111 ../../tmp_restrictive+chmod a-wx ../../tmp_restrictive+# sanity check that we can not cd ..+not cd .. # sanity check that we can cd out and back-cd ../..; cd tmp_restrictive/liberal-# TODO: we avoid this test on Solaris because it seems we can't create-# anything in tmp_restrictive/liberal-touch can_touch-if [ -e can_touch ]; then-  if hwpwd; then-    darcs get "$DIR/tmp_remote" 2> log-    not grep -i 'permission denied' log-  else-    echo "Apparently I can't do `basename $0` on this platform"-  fi-else-  echo "Can't do `basename $0` on this platform"-fi-cd "$DIR"-# We have to fix the permissions, just so we can delete it.-chmod 0755 tmp_restrictive--rm -rf tmp_remote tmp_restrictive+(cd ../.. && cd tmp_restrictive/liberal) || exit 200+(touch can_touch && test -e can_touch) || exit 200+# now run the real test+darcs get "$DIR/tmp_remote" 2>&1 >log+not grep -i 'permission denied' log+cd ../..
+ tests/issue612_repo_not_writable.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash++# Test that darcs fails appropriately when the target repo inventory file is+# not writable. See issue612++. lib++# We can set and clear permission bits with bash on Windows but that+# has not the expected effect on programs.+abort_windows++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+touch t.t+darcs add t.t+darcs record -am "initial add"+trap "chmod -R +w $(pwd)/_darcs/inventories" EXIT+chmod -R a-w _darcs/inventories+cd ..++darcs get temp1 temp2+cd temp2+echo new >> t.t+darcs record -am "new patch"+not darcs push -a ../temp1+cd ..
+ tests/issue68_broken_pipe.sh view
@@ -0,0 +1,25 @@+#!/usr/bin/env bash++# For issue68, 'don't report "resource vanished" when stdout pipe is broken.'++. ./lib++rm -rf temp1 # Another script may have left a mess.++darcs init --repodir temp1++cd temp1++for i in {1..500}+do+    echo $i >> f+done++darcs changes 2> err | head+darcs rec -alm 'Add big f'++# We recorded a big file add, so asking for the first n lines of the patch+# would trigger this bug.+darcs changes -v 2> err | head++[[ ! -s err ]]
tests/issue691.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp mkdir temp
+ tests/issue701.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+. ./lib+++# issue701++# step 1+rm -rf temp0+darcs init temp0+cd temp0+echo m1 > foo+darcs record -lam m1+cd ..++# step 2+rm -rf temp1+darcs clone temp0 temp1+cd temp1+echo a1 > foo+darcs record foo -a -m a1+cd ..+++# step 3+cd temp0+echo m2 > foo+darcs record -a -m m2+cd ..+++# step 4+cd temp1+darcs pull -a+echo m2-a1 > foo+darcs record -a -m 'Fix conflict m2-a1'+cd ..++# step 5+cd temp0+echo m3 > foo+darcs record -a -m m3+cd ..++# step 6+cd temp0+echo m4 > foo+darcs record -a -m m4+cd ..++# step 7+cd temp1+darcs pull -a+echo m2-a1-m4 > foo+echo y | darcs mark-conflicts+cd ..
tests/issue706.sh view
@@ -1,10 +1,7 @@ #!/usr/bin/env bash-set -ev+. ./lib  # for issue706: "Filenames with spaces issue"--DARCS_EDITOR=echo-export DARCS_EDITOR  rm -rf temp mkdir temp
tests/issue709_pending_look-for-adds.sh view
@@ -1,7 +1,5 @@ #!/bin/sh-set -ve--. lib+. ./lib  rm -rf temp1 mkdir temp1@@ -27,7 +25,7 @@  echo bar > bar darcs add bar-echo yyd | darcs record -mbar+darcs record -mbar -a bar  cat _darcs/patches/pending @@ -44,7 +42,7 @@ # remove any files added by profiling or hpc... rm -f darcs.tix darcs.prof -echo yyd | darcs record --look-for-adds -mfoo+darcs record --look-for-adds -mfoo -a foo  cat _darcs/patches/pending
+ tests/issue761-fail-early-bad-pull-match.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash++# This is a test for issue761, which pointed out that we didn't check the+# syntax of --match patterns until after having spent considerable time+# doing considerable work.  So here we construct a very invalid repository,+# and check that darcs fails *before* it notices that it's pulling from a+# bad repository.  Thus we verify that we aren't doing any work prior to+# checking the flags.++. ./lib++rm -rf temp1 temp2+mkdir temp1+cd temp1+darcs init+touch foo bar+darcs add foo bar+darcs record -a -m 'add two files'+darcs tag -m tag+rm foo bar+darcs record -a -m 'rm two files'+darcs tag -m tag2++rm -rf _darcs/inventories/*+rm -rf _darcs/patches/*++cd ..++mkdir temp2+cd temp2+darcs init+! darcs pull --match 'foobar' ../temp1 2> error+cat error++grep foobar error++rm -rf temp1 temp2+
tests/issue844_gzip_crc.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib rm -rf temp1 temp2 mkdir temp1 cd temp1@@ -13,7 +13,7 @@ cd temp2 darcs init darcs pull ../temp1 -a-darcs optimize --compress+darcs optimize compress for f in _darcs/patches/*-*; do 	gzip -t < "$f" done
− tests/issue864_replace_in_moved.sh 
@@ -1,57 +0,0 @@-#!/usr/bin/env bash--# Issue 864--# darcs mv file1 file2-# edit file2-# darcs replace fails if new token includes some existing edits--# Regression in darcs2 - it works in darcs1 1.0.9--set -ev--rm -rf temp-mkdir temp-cd temp-darcs init-cat <<EOF > file1-aa-bb-cc-aa-bb-cc-EOF-darcs add file1-darcs record -a -m "0" --author X--cat <<EOF > file1-aaaa-bb-cc-aa-bb-cc-EOF--darcs replace aa aaaa file1 > out-cat out-grep 'Skipping file' out && exit 1--darcs mv file1 file2--cat <<EOF > file2-aaaa-beebee-cc-aa-bb-cc-EOF--darcs replace bb beebee file2 > out-cat out-grep 'Skipping file' out && exit 1--cd ..-rm -rf temp
− tests/issue885_get_to_match.sh 
@@ -1,34 +0,0 @@-#!/bin/sh--# Issue885: Regression: "darcs get --to-match" does not work anymore under 2.0---. lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo first > a-darcs add a-darcs record -am 'first'-firsthash=`darcs changes --xml | grep 'hash=' | sed -e "s/.*hash='//" -e "s/'>//"`-echo second > b-darcs add b-darcs record -am 'second'--# Pulling that patch works ok-cd ..-rm -rf temp2-mkdir temp2-cd temp2-darcs init-echo darcs pull -v -a --match "hash $firsthash" ../temp1-darcs pull -v -a --match "hash $firsthash" ../temp1--# Getting up-to that patch does not-cd ..-rm -rf temp3-echo darcs get -v --to-match "hash $firsthash" temp1 temp3-darcs get -v --to-match "hash $firsthash" temp1 temp3-
− tests/issue966_diff.sh 
@@ -1,25 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp-mkdir temp; cd temp-darcs init-echo "aaa diff" > file-darcs add file-darcs record -a -m "aaa"-echo "bbb diff" >> file-darcs record -a -m "bbb"--darcs diff --patch "aaa" | grep "aaa diff"-darcs diff --patch "bbb" | grep "bbb diff"--darcs tag release-1-darcs optimize--echo "ccc diff" >> file-darcs record -a -m "ccc"-darcs diff --patch "ccc" | grep "ccc diff"--# here is where we have a problem-darcs diff --patch "aaa" | grep "aaa diff"-darcs diff --patch "bbb" | grep "bbb diff"
− tests/justrm.sh 
@@ -1,15 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init-touch foo-darcs add foo-darcs record -a -m add_foo -A x-rm foo-darcs whatsnew-cd ..-rm -rf temp1-
+ tests/latin9-input.sh view
@@ -0,0 +1,202 @@+#!/usr/bin/env bash+## Test for issue64 - Should store patch metadata in UTF-8+##+## Copyright (C) 2009  Reinier Lamers+##+## 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+## SOFTWARE.++. lib ++# Helper function: do a darcs changes --xml and grep the result for the first+# argument. If it is not found, exit with status 1. Otherwise, continue. The+# second argument is a text that describes what we're grepping for.+# If a third argument is given, it is used as the value for a --last option for+# darcs changes.+grep_changes () {+    switch_to_utf8_locale+    if [ -z "$3" ]; then+            last=""+    else+            last="--last $3"+    fi++    darcs changes $last --xml > changes.xml+    if grep "$1" changes.xml ; then+        echo "$2 OK"+    else+        cat changes.xml+        echo "$2 not UTF-8-encoded!"+        exit 1+    fi+    switch_to_latin9_locale+}+++# This file is encoded in ISO-8859-15 aka latin9. It was crafted with a hex editor.+# Please leave it this way :-)+switch_to_latin9_locale++rm -rf temp1+mkdir temp1+cd temp1++darcs init++# Test recording non-UTF-8-encoded non-latin1 ("funny") metadata from+# interactive input++echo 'Selbstverständlich überraschend' > something.txt+darcs add something.txt++echo 'l33tking¸0r@example.org' > interaction_script.txt+echo y >> interaction_script.txt+echo y >> interaction_script.txt+echo y >> interaction_script.txt+echo '¤uroh4xx0rz' >> interaction_script.txt+echo n >> interaction_script.txt++unset DARCSEMAIL+unset EMAIL+set+darcs record -i --skip-long-comment < interaction_script.txt+grep_changes 'l33tkingž0r@example.org' 'patch author from interactive prompt'+grep_changes '€uroh4xx0rz' 'patch name from interactive prompt'++# Test recording funny metadata from command line ++echo 'Sogar überraschender' >> something.txt++darcs record -a -A 'Jérôme Leb½uf' -m 'that will be ¤ 15, sir'++if echo $OS | not grep -i windows; then # issue2591+    grep_changes 'that will be € 15, sir' 'patch name from command line'+    grep_changes 'Jérôme Lebœuf' 'patch author from command line'+fi++# Test recording funny metadata from a log file++echo 'Am allerüberraschendsten' >> something.txt++echo 'darcs is soms wat naïef aangaande tekstcodering' > log.txt+echo 'en zulke naïviteit is tegenwoordig passé, aldus ´i¸ek' >> log.txt+darcs record -a -A 'Jérôme Leb½uf' --logfile=log.txt++grep_changes 'darcs is soms wat naïef aangaande tekstcodering' 'patch name from log file'+grep_changes 'en zulke naïviteit is tegenwoordig passé, aldus Žižek' 'patch log from log file'++# Test recording funny metadata from environment, +export EMAIL='Slavoj ´i¸ek <zizek@example.edu>'+rm $HOME/.darcs/author+echo 'La la la, the more lines the better!' >> something.txt+darcs record -a -m 'Patch names are overrated'++if echo $OS | not grep -i windows; then # issue2591+    grep_changes 'Slavoj Žižek' 'author name from environment'+fi++# Test recording funny metadata from prefs files+echo '´ed is dead' > _darcs/prefs/author+echo '483 bottles of beer on the wall' >> something.txt+darcs record -a -m 'Patch by ´ed'++grep_changes 'Žed is dead' 'author name from prefs file'++# Test amend-recording funny metadata+echo 'No, it is really 484' >> something.txt+echo y | darcs amend-record -p 'Patch by ' -A '´ed is even deader' -a+if echo $OS | not grep -i windows; then # issue2591+    grep_changes 'Žed is even deader' 'author name from amend-record command line flag'+fi++cat <<FAKE > editor.hs # create an 'editor' that writes latin9+import System.Environment+import qualified Data.ByteString as B+str = B.pack [65,108,108,32,109,121,32,164,115,32,97,114,101,32,103,111,110,101]+main = getArgs >>= \[x] -> B.writeFile x str+FAKE+ghc $GHC_FLAGS --make -o editor editor.hs+export DARCS_EDITOR="`pwd`/editor"+if echo $OS | not grep -i windows; then # issue2591+    printf "y\ny\n" | darcs amend --edit -p 'Patch by '+    grep_changes 'All my €s are gone' 'description edited from amend-record'+    grep_changes 'Žed is even deader' 'author name taken from draft in amend'+fi++# Test tag recording funny metadata+rm _darcs/prefs/author # Make tag be taken from EMAIL env variable+if echo $OS | not grep -i windows; then # issue2591+    darcs tag -m '´ is my favorite letter'+    grep_changes 'Slavoj Žižek' 'author name from environment with tag command' 1+    grep_changes 'Ž is my favorite letter' 'Tag name from command line'+fi++unset EMAIL+printf "´ors\ninitialcomment\n" | darcs tag --edit-long-comment+grep_changes Žors 'Author name from interactive prompt from tag command'+grep_changes 'All my €s are gone' 'Tag name from editor from tag command' 1++if grep ´ors $HOME/.darcs/author ; then+    echo 'Author name stored locale-encoded in prefs file after tag command, OK'+else+    echo 'No locale-encoded author in prefs file after tag command!'+    exit 1+fi+rm $HOME/.darcs/author++if echo $OS | not grep -i windows; then # issue2591+    darcs tag -A Ad¸e -m 'La¸t call'+    grep_changes Adže 'Author name from tag command line' 1+    grep_changes 'Lažt call' 'Tag name from tag command line (take 2)' 1+fi++cd ..++# test that UTF-8 metadata doesn't get mangled on get+rm -rf temp2+darcs get temp1 temp2+darcs changes --repodir temp1 --xml > temp1/changes.xml+darcs changes --repodir temp2 --xml > temp2/changes.xml+diff temp1/changes.xml temp2/changes.xml++# and that it doesn't get mangled on push+rm -rf temp2+mkdir temp2; darcs init --repodir temp2+darcs push --repodir temp1 -a temp2 --set-default+darcs changes --repodir temp1 --xml > temp1/changes.xml+darcs changes --repodir temp2 --xml > temp2/changes.xml+diff temp1/changes.xml temp2/changes.xml++# and that it doesn't get mangled on pull+rm -rf temp2+mkdir temp2; darcs init --repodir temp2+darcs pull --repodir temp2 -a temp1+darcs changes --repodir temp1 --xml > temp1/changes.xml+darcs changes --repodir temp2 --xml > temp2/changes.xml+diff temp1/changes.xml temp2/changes.xml++# and that it doesn't get mangled on send+rm -rf temp2+mkdir temp2; darcs init --repodir temp2+darcs send --repodir temp1 -a -o temp2/patch.dpatch+darcs apply --repodir temp2 -a temp2/patch.dpatch+darcs changes --repodir temp1 --xml > temp1/changes.xml+darcs changes --repodir temp2 --xml > temp2/changes.xml+diff temp1/changes.xml temp2/changes.xml
+ tests/lazy-conflict-resolution.sh view
@@ -0,0 +1,19 @@+# this tests that when we resolve conflicts, we don't access+# patches in the context if they are not needed.++. lib++rm -rf R S+darcs init R+cd R+touch file+darcs record -l file -a -m add+darcs tag mytag+rm _darcs/patches/*+echo xxx > file+darcs record -l file -a -m edit1+darcs clone --lazy . ../S+echo yyy > file+echo y | darcs amend -a -m edit2+darcs pull -a ../S+cd ..
tests/lazy-optimize-reorder.sh view
@@ -5,10 +5,10 @@ rm -rf temp1 temp2 temp3 mkdir temp1 cd temp1-darcs init+darcs init --no-patch-index  # this test only applies to hashed formats-if cat _darcs/inventory; then exit 0; fi+if cat _darcs/inventory; then exit 200; fi  date > f1 darcs add f1@@ -21,20 +21,20 @@ darcs record -am 'add f2' cd .. -darcs get --lazy temp1 temp2+darcs get --lazy temp1 temp2 --no-cache -darcs get --lazy temp2 temp3+darcs get --lazy temp2 temp3 --no-cache  cd temp2  # Run darcs changes so we pull in the inventories (but no the patches)-darcs changes+darcs changes --no-cache  # Remove original repository, so we have no references to changes f1 and f2. rm -rf ../temp1  # Now we should be unable to read some of the history-darcs changes -s > out+darcs changes -s --no-cache > out cat out grep unavailable out @@ -54,11 +54,9 @@ # Here's the point of this test: we should be able to optimize # --reorder without being able to read all the patches in the # repository.-darcs optimize --reorder+darcs optimize reorder  # Just a double-check: we shouldn't be able to check in this case.-not darcs check+not darcs check --no-cache  cd ..--rm -rf temp1 temp2 temp3 temp4
+ tests/legacy-inverted.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash++# Test that repositories that contain legacy "UNDO" patches, i.e. ones with+# an inverted PatchInfo, are still handled correctly by darcs. These+# patches were written by darcs rollback until the behaviour of rollback+# was changed in 2008; one example of a repo containing them is darcs itself.++. ./lib++rm -rf undo++# undo is a repository containing a legacy "UNDO" patch,+# i.e. one with an inverted PatchInfo.+#+# As darcs hasn't created these  patches for many years, it's not easy to+# build such a repo. This one was created using rebase on the actual darcs+# repo. As a result the UNDO patch isn't actually an inverse of the original+# patch, as its PatchInfo got rewritten during unsuspend. This shouldn't+# matter in practice for this test.++unpack_testdata undo++cd undo++darcs changes | grep "UNDO"+darcs changes --xml | grep "inverted='True'"++echo "empty" > Patch.lhs++echo yy | darcs amend -a -p "get rid of"++darcs changes | not grep "UNDO"+darcs changes --xml | not grep "inverted='True'"
tests/lib view
@@ -1,19 +1,46 @@ # This is a -*- sh -*- library. -## I would use the builtin !, but that has the wrong semantics.-not () { "$@" && exit 1 || :; }+. ./env +# I would use the builtin !, but that has the wrong semantics+not () {+  set +x+  if "$@" || test $? = "4"; then+    # fail the test if command succeeds or returns 4+    exit 1+  fi+  set -x+}+ # trick: OS-detection (if needed)+os_is_windows() {+  echo $OS | grep -i windows+}+ abort_windows () {-if echo $OS | grep -i windows; then+if os_is_windows; then   echo This test does not work on Windows   exit 200 fi } -pwd() {-    ghc --make -o hspwd "$TESTBIN/hspwd.hs" > /dev/null-    "./hspwd"+if os_is_windows; then+  # some installations of bash on Windows do not include \r by default+  # which breaks a lot of tests+  IFS=$' \t\n\r'+  # this is for the github CI: we need to make sure that our test data (e.g.+  # patch bundles) is not converted to CRLF style by git when we checkout a+  # snapshot of our repo+  git config --global core.autocrlf input+fi++# tests now work on windows with this or with the bash pwd:+# pwd() {+#     runghc "$TESTBIN/hspwd.hs"+# }++which() {+    type -P "$@" }  # switch locale to one supporting the latin-9 (ISO 8859-15) character set if possible, otherwise skip test@@ -24,7 +51,7 @@ }  switch_to_latin9_locale () {-    if echo $OS | grep -i windows; then+    if os_is_windows; then         chcp.com 28605     else         if ! which locale ; then@@ -33,7 +60,7 @@         fi          # look for a ISO 8859-15 locale. locale -a shows iso885915, on ubuntu at least-        latin9_locale=`locale -a | egrep -i iso8859-?15 | head -n 1` || (no_latin9_locale_warning; exit 200)+        latin9_locale=`locale -a | egrep --text -i iso8859-?15 | head -n 1` || (no_latin9_locale_warning; exit 200)         test -n "$latin9_locale" || (no_latin9_locale_warning; exit 200)          echo "Using locale $latin9_locale"@@ -45,7 +72,7 @@ # switch locale to utf8 if supported if there's a locale command, skip test # otherwise switch_to_utf8_locale () {-    if echo $OS | grep -i windows; then+    if os_is_windows; then         chcp.com 65001     else         if ! which locale ; then@@ -53,7 +80,7 @@             exit 200 # skip test         fi -        utf8_locale=`locale -a | grep .utf8 | head -n 1` || exit 200+        utf8_locale=`locale -a | grep --text .utf8 | head -n 1` || exit 200         test -n "$utf8_locale" || exit 200          echo "Using locale $utf8_locale"@@ -62,29 +89,49 @@     fi } -serve_http() {-    cat > light.conf <<EOF-    server.document-root       = "$PWD"-    server.errorlog            = "/dev/null"-    server.port                = 23032 ## FIXME-    server.bind                = "localhost"-    server.pid-file            = "$PWD/light.pid"-EOF-    trap "finish_http \"$PWD\"" EXIT-    lighttpd -f light.conf || exit 200-    ps `cat light.pid` > /dev/null 2>&1 || exit 200-    baseurl="http://localhost:23032"+# check that the specified string appears precisely once in the output+grep-once() {+    grep -c "$@" | grep -w 1 } -finish_http() {-    test -e "$1/light.pid" && kill `cat "$1/light.pid"` || true+require_ghc() {+    test $GHC_VERSION -ge $1 || exit 200 }  skip-formats() {-    for f in "$@"; do grep $f $HOME/.darcs/defaults && exit 200 || true; done+    for f in "$@"; do grep -q $f $HOME/.darcs/defaults && exit 200 || true; done } +only-format() {+    grep -q $1 $HOME/.darcs/defaults || exit 200+}++unpack_testdata() {+   # Historically we used to have to use 'gunzip -c archive | tar xf -'+   # because the test harness was sometimes run with a tar that didn't support -z.+   # That isn't the case now so we just use -f directly.+   # Note that piping the archive on stdin without a -f flag doesn't work reliably+   # because the default device might not be stdin, e.g. on Windows/msys the default+   # could be a tape device //./tape0, even if that doesn't exist.+   tar -xzf $TESTDATA/$1.tgz+}++# comparing patch bundles requires we filter out some (irrelevant) lines+filter_bundle() {+  cat $1 | grep -v '^Date: ' | grep -v 'patch\(es\)\? for repository '+}+compare_bundles() {+  diff <(filter_bundle $1) <(filter_bundle $2) >&2+}++grep -q darcs-3 .darcs/defaults && format=darcs-3 grep -q darcs-2 .darcs/defaults && format=darcs-2-grep -q hashed .darcs/defaults && format=hashed+grep -q darcs-1 .darcs/defaults && format=darcs-1++# To test if darcs works correctly in case hard-linking fails because the+# cache is in a different file system. This assumes that /run/darcs-test is+# writable and on a separate filesystem (e.g. tmpfs).+#+# export XDG_CACHE_HOME=`mktemp -d -p /run/darcs-test`  set -vex -o pipefail
+ tests/list-options.sh view
@@ -0,0 +1,21 @@+#!/usr/bin/env bash+# some tests for the --list-options option++. lib++rm -rf R+darcs init R+cd R+echo aboringfile > _darcs/prefs/boring+touch anunaddedfile+touch aboringfile+darcs record --list-options | not grep -w anunaddedfile+darcs record -l --list-options | grep -w anunaddedfile+darcs record -l --list-options | not grep -w aboringfile+darcs record --boring --list-options | grep -w anunaddedfile+darcs record --boring --list-options | grep -w aboringfile+darcs add --list-options | grep -w anunaddedfile+darcs add --list-options | not grep -w aboringfile+darcs add --boring --list-options | grep -w anunaddedfile+darcs add --boring --list-options | grep -w aboringfile+cd ..
+ tests/log-duplicate.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash+## Copyright (C) 2012  BSRK Aditya+##+## 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+## SOFTWARE.++. lib++# this tests a property of darcs-2 repos+only-format darcs-2++darcs init --repo R+darcs init --repo S++cd R+touch f+darcs record -lam 'p1'++cd ../S+touch f+darcs record -lam 'p2'+darcs send -ao p2.dpatch ../R++cd ../R+darcs apply -a ../S/p2.dpatch +darcs log --verbose+darcs log --verbose | grep -q 'duplicate'+darcs log f --verbose | not grep -q 'duplicate'
+ tests/log.sh view
@@ -0,0 +1,172 @@+#!/usr/bin/env bash+. ./lib++# Some tests for 'darcs log -a'++rm -rf temp1+darcs init temp1+cd temp1++date >> date.t+darcs record -A 'Mark Stosberg <a@b.com>' -lam foo++####++darcs log date.t > out # trivial case first+cat out+grep foo out++darcs log --last=1 date.t > out+cat out+grep foo out++darcs log --last 1 --summary date.t > out+cat out+grep foo out++darcs log --last=1 --xml > out+cat out+grep '&lt;a@b.com&gt;' out # check that --xml encodes < and >++###++# Add 6 records and try again+for i in 0 1 2 3 4 5; do+    date >> date.t+    darcs record -a -m "foo record num $i" date.t+done++darcs log date.t > out+cat out+grep foo out++darcs log --last=1 date.t > out+cat out+grep foo out++darcs log --last 1 --summary date.t > out+cat out+grep foo out++###++darcs log --context --from-patch='num 1' --to-patch 'num 4' > out+cat out+grep 'num 4' out+grep 'num 3' out+grep 'num 2' out+grep 'num 1' out++cd ..+++# Some tests for the output of log when combined with move.++rm -rf temp2+darcs init temp2+cd temp2+date > foo+darcs record -lam 'add foo'+mkdir d+darcs record -lam 'add d'+darcs mv foo d+darcs record -m 'mv foo to d' -a+darcs mv d directory+darcs record -m 'mv d to directory' -a+echo 'How beauteous mankind is' > directory/foo+darcs record -m 'modify directory/foo' -a+darcs log directory/foo > log+grep 'add foo' log+grep 'mv foo to d' log+echo 'O brave new world' > directory/foo+# darcs should also take unrecorded moves into account+darcs mv directory/foo directory/bar+darcs log directory/foo > log+grep 'mv foo to d' log+echo 'That has such people in it' > directory/foo+darcs add directory/foo+darcs record -m 'mv foo then add new foo' -a+darcs annotate directory/bar | tee log+grep 'O brave new world' log+grep "mv foo then add new foo" log+not grep "unknown" log+cd ..++# Issue244+# darcs changes should be able to pull up the history for a file+#   using its moved and not-yet recorded new name++rm -rf temp3+darcs init temp3+cd temp3+touch b+darcs record -lam 11+darcs mv b c+darcs log c | grep 11+cd ..++## issue1337 - darcs log shows unrelated patches+## Asking "darcs log" about an unrecorded file d/f will list the+## patch that creates the parent directory d/ (instead of no patches).++rm -rf temp4+darcs init temp4+cd temp4+mkdir d+darcs record -lam d d+# We use --match 'touch d/f' instead of simply d/f because the latter+# prints "Changes to d/f:\n" before the count.+test 0 -eq "$(darcs log --count --match 'touch d/f')"++cd ..++## issue1632 - 'darcs changes d/f' should not list any changes,+## where d is part of the repo and f is a non-existent file.++rm -rf temp5+darcs init temp5+cd temp5++mkdir d+darcs record -lam 'added directory d'+# darcs should not list any changes here:+darcs changes non-existent-file > log+not grep 'added directory d' log+# ...and neither here:+darcs changes d/non-existent-file > log+not grep 'added directory d' log+cd ..++## issue1888 - changes --context is broken when topmost patch+## is a clean tag.++rm -rf temp6+darcs init temp6+cd temp6++echo a > a ; darcs rec -lam "patch_a"+darcs log --context | grep patch_a++darcs tag -m "tag_a"+darcs log --context | not grep patch_a+darcs log --context | grep tag_a++echo b > a; darcs rec -lam "patch_b"+darcs log --context | not grep patch_a+darcs log --context | grep tag_a+darcs log --context | grep patch_b+cd ..++## log --index=N-M++# re-use the temp6 directory with 3 patches+cd temp6+count=$(darcs log --count)+for N in $(seq 1 $count); do+  for M in $(seq 1 $count); do+    darcs log --index=$N-$M --count | tee LOG+    expected=$(($N <= $M ? $M - $N + 1 : 0))+    grep -w $expected LOG+  done+done+cd ..
+ tests/log_send_context.sh view
@@ -0,0 +1,20 @@+#!/usr/bin/env bash+. ./lib++# RT#544 using context created with 8-bit chars;++rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch foo+darcs record -la -m 'add\212 foo' | grep 'Finished record'+darcs log --context >context+date > foo+darcs record -a -m 'date foo' | grep 'Finished record'+darcs send -a -o patch --context context . | grep 'Wrote patch to'+# again with an absolute path for the context file, see issue1240+# note we must not mix \\ and / so we use /bin/pwd here+cwd=$(/bin/pwd)+darcs send -a -o patch --context "$cwd/context" . | grep 'Wrote patch to'+cd ..
tests/look_for_add.sh view
@@ -1,17 +1,6 @@ #!/usr/bin/env bash -cat > empty_pending <<EOF-{-}-EOF-check_empty_pending() {-  echo ================ pending ==================-  cat _darcs/patches/pending-  echo ================ pending ==================-  [ -z _darcs/patches/pending ] || cmp _darcs/patches/pending ../empty_pending-}--set -ev+. ./lib  rm -rf temp1 temp2 mkdir temp1 temp2@@ -19,13 +8,13 @@ darcs init mkdir dir darcs record -a -m add_dir -A x --look-for-adds-check_empty_pending+not darcs whatsnew echo zig > dir/foo echo zag > foo mkdir dir2 echo hi > dir2/foo2 darcs record -a -m add_foo -A x --look-for-adds-check_empty_pending+not darcs whatsnew cd ../temp2 darcs init darcs pull -a ../temp1
+ tests/look_for_moves.sh view
@@ -0,0 +1,192 @@+#!/usr/bin/env bash++. ./lib++rm -rf temp1+mkdir temp1+cd temp1++# simple add and move++darcs init+touch foo+darcs record -lam add_file+mv foo foo2+darcs wh --summary --look-for-moves >log+cat > log.expected <<EOF+ ./foo -> ./foo2+EOF+diff -u log log.expected >&2+rm log log.expected+darcs record -am move_file --look-for-moves+darcs wh --look-for-moves --look-for-adds  >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# simple add and move dir++darcs init+mkdir foo+darcs record -lam add_dir+mv foo foo2+darcs wh --summary --look-for-moves >log+cat > log.expected <<EOF+ ./foo -> ./foo2+EOF+diff -u log log.expected+rm log log.expected+darcs record -am move_dir --look-for-moves+darcs wh --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# add, move and add same name++darcs init+touch foo+darcs record -lam add_file+mv foo foo2+touch foo+darcs wh --summary --look-for-moves >log+cat > log.expected <<EOF+ ./foo -> ./foo2+EOF+diff -u log log.expected+rm log log.expected+darcs wh --summary --look-for-moves --look-for-adds >log 2>&1+cat > log.expected <<EOF+ ./foo -> ./foo2+a ./foo+EOF+darcs record -am move_file_add_file --look-for-moves --look-for-adds+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# amend-record++darcs init+touch foo+darcs record -lam add_file+mv foo foo2+echo 'yyy' | darcs amend-record -p add_file --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+darcs log -v --machine -p add_file >log 2>&1+# 'darcs log --machine' internally calls 'showPatch ForStorage'+# which is why we need to distinguish between darcs-3 and earlier here.+# This behavior of 'darcs log' is questionable at best.+if test "$format" = darcs-3; then+  grep -A1 "] hash 1 " log | grep "addfile ./foo2"+else+  grep "] addfile ./foo2" log+fi+rm -rf *++# add, move, add same name and amend-record++darcs init+touch foo+darcs record -lam add_file+mv foo foo2+touch foo+echo 'yyyy' | darcs amend-record -p add_file --look-for-moves --look-for-adds+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+darcs log -v --patch add_file >log 2>&1+grep "addfile ./foo" log+grep "addfile ./foo2" log+rm -rf *++# add, move, amend-record, move, amend-record++darcs init+touch foo+darcs record -lam add_file+mv foo foo2+echo 'yyy' | darcs amend-record -p add_file --look-for-moves+mv foo2 foo+echo 'yyy' | darcs amend-record -p add_file --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# move dir with content++darcs init+touch foo # created before dir to get a lower inode+mkdir dir+mv foo dir+darcs record -lam add_files+mv dir dir2+darcs wh --summary --look-for-moves > log+cat > log.expected <<EOF+ ./dir -> ./dir2+EOF+diff -u log log.expected+rm log log.expected+darcs record -am move_dir --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# name swapping -- unsupported thus ignored++darcs init+touch foo foo2+darcs record -lam add_file+mv foo foo.tmp+mv foo2 foo+mv foo.tmp foo2+not darcs wh --look-for-moves+rm -rf *++# dir swapping -- dir moves are ignored but inner files moves are considered++darcs init+mkdir dir dir2+touch dir/foo dir2/foo2+darcs record -lam add_files_and_dirs+mv dir dir.tmp+mv dir2 dir+mv dir.tmp dir2+darcs wh --summary --look-for-moves > log+cat > log.expected <<EOF+ ./dir/foo -> ./dir2/foo+ ./dir2/foo2 -> ./dir/foo2+EOF+diff -u log log.expected+rm -rf *++# darcs mv before a plain mv++darcs init+touch foo+darcs record -lam add_files_and_dirs+darcs mv foo foo2+mv foo2 foo3+darcs wh --summary --look-for-moves > log+cat > log.expected <<EOF+ ./foo -> ./foo3+EOF+diff -u log log.expected+rm log log.expected+darcs record -a -m move_dirs --look-for-moves+darcs wh --look-for-moves --look-for-adds >log 2>&1+grep -vE "(^ *$|^\+|No changes!)" log+rm -rf *++# mv to a boring filename++darcs init+touch foo+darcs record -lam add_files_and_dirs+mv foo foo~+darcs wh --summary --look-for-moves > log+cat > log.expected <<EOF+R ./foo+EOF+diff -u log log.expected+rm -rf *++cd ..+rm -rf temp1
+ tests/look_for_moves_and_replaces.sh view
@@ -0,0 +1,68 @@+#!/usr/bin/env bash++. ./lib++# detect move of a file and then a replace in that file++test_setup() {+  num=$1+  shift+  paths=$@++  rm -rf R$num+  darcs init R$num+  cd R$num++  echo foo > old+  echo foo >> old+  echo bar >> old++  darcs record -lam 'added old'+  mv old new++  echo bar > new +  echo bar >> new+  echo bar >> new++  darcs whatsnew --look-for-moves --look-for-replaces $paths > ../out.actual+  cd ..+}++cat <<EOF > out.expected+move ./old ./new+hunk ./new 3+-bar++foo+replace ./new [A-Za-z_0-9] foo bar+EOF++test_setup 1 ""+diff out.actual out.expected++# same but only for old++test_setup 2 old+# remove the line about What's new in: old+sed -i '1d' out.actual+diff out.actual out.expected++# same but only for new++test_setup 3 new+# remove the line about What's new in: new+sed -i '1d' out.actual+diff out.actual out.expected++# same but only for old and new++test_setup 4 old new+# remove the line about What's new in: old new+sed -i '1d' out.actual+diff out.actual out.expected++# same but only for old and new and non-existing++test_setup 5 old new non-existing+# remove the line about What's new in: old new, and the one that reports non-existing+sed -i '1,2d' out.actual+diff out.actual out.expected
+ tests/look_for_moves_with_args.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash++# test that --look-for-moves properly handles file arguments++. ./lib++darcs init R+cd R++touch old1+touch old2+touch old3+darcs record -lam 'added files'+mv old1 new1+mv old2 new2+cd ..++runtest () {+  darcs whatsnew --repodir R --look-for-moves $* | grep move > out+}++num_lines () {+  test $(wc -l < $2) = $1+}++move1='move \./old1 \./new1'+move2='move \./old2 \./new2'++runtest ""+grep "$move1" out+grep "$move2" out+num_lines 2 out++runtest old1+# we expect to see only move1+grep "$move1" out+not grep "$move2" out+num_lines 1 out++runtest old1 old2+# we expect to see both moves+grep "$move1" out+grep "$move2" out+num_lines 2 out++runtest old2 old3+# we expect to see only move2+grep "$move2" out+not grep "$move1" out+num_lines 1 out
+ tests/look_for_replaces1.sh view
@@ -0,0 +1,49 @@+#!/usr/bin/env bash+## Failing test for --look-for-replaces+##+## Copyright (C) 2013 Jose Neder+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R++# forced replace (the word is in the file) (amend-record)+# amending an addfile patch with a forced replace fails+darcs init+cat > file <<EOF+foo+foo+bar+EOF+darcs record -al -m "add file"+cat > file <<EOF+bar+bar+bar+EOF+echo y | darcs amend-record --look-for-replaces -a+cd ..+rm -rf R+
tests/mark-conflicts.sh view
@@ -1,10 +1,10 @@ #!/usr/bin/env bash -# Automated tests for "darcs mark-conflicts".+# tests for "darcs mark-conflicts" -# The builtin ! has the wrong semantics for not.-not () { "$@" && exit 1 || :; }+. lib +rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs init@@ -25,14 +25,25 @@ cd ..  cd temp1-darcs pull -a ../temp2 > log+darcs pull -a ../temp2 >log 2>&1 grep conflict log-grep finished log+grep -i finished log grep 'v v' child_of_conflict darcs revert -a not grep 'v v' child_of_conflict darcs mark-conflicts grep 'v v' child_of_conflict-cd .. -rm -rf temp1 temp2+# test that a change depending on both parts counts as resolution,+# so that mark-conflicts doesn't see any conflicts to mark+darcs revert  -a+echo "Conflict, Part 3." > child_of_conflict+# it should count as resolution regardless of whether unrecorded...+darcs mark-conflicts | grep -i 'No conflicts'+not grep 'v v' child_of_conflict+# ...or recorded+darcs record -am 'Conflict resolution'+darcs mark-conflicts | grep -i 'No conflicts'+not grep 'v v' child_of_conflict++cd ..
tests/match-date.sh view
@@ -28,12 +28,12 @@  create_entry () {   echo $1 >> bar-  echo "$1/tester/a///" | tr / \\012 | darcs record -m "" --pipe bar+  echo "$1/tester/a///" | tr / \\012 | darcs record -m "does not matter" --pipe bar }  create_entry_now () {   echo today >> bar-  darcs record -m "" bar -a -A tester+  darcs record -m "does not matter" bar -a -A tester }  # parse_date just checks for parsing, while match_date checks for an actual match.
tests/match.sh view
@@ -92,6 +92,16 @@ grep author1 log not grep author2 log grep author3 log++# an empty pattern should just match all patches+[[ $(darcs changes --match '' --count) -eq 3 ]]++# check the error message for an invalid matcher+not darcs changes --match invalid_matcher > log 2>&1+grep "unexpected 'i'" log+grep 'expecting valid expressions over' log+grep 'for more help, see `darcs help patterns`' log+ cd ..  rm -rf temp1
tests/merge_three_patches.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf tempOld tempA tempB mkdir tempOld tempA@@ -8,7 +8,6 @@ echo record author me > _darcs/prefs/defaults echo ALL all >> _darcs/prefs/defaults #echo ALL verbose >> _darcs/prefs/defaults-echo ALL ignore-times >> _darcs/prefs/defaults echo A > foo echo B >> foo echo C >> foo@@ -42,8 +41,8 @@  cd tempA darcs pull ../tempB-darcs annotate -p B-darcs annotate -p resolution+darcs log -v --max-count 1 -p B | cat+darcs log -v --max-count 1 -p resolution | cat cd ..  cmp tempA/foo tempB/foo
tests/mergeresolved.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf fooOld tempA tempB mkdir fooOld tempA tempB@@ -8,7 +8,6 @@ echo record author me > _darcs/prefs/defaults echo ALL all >> _darcs/prefs/defaults #echo ALL verbose >> _darcs/prefs/defaults-echo ALL ignore-times >> _darcs/prefs/defaults echo Old > foo darcs add foo darcs record -m Old
tests/merging_newlines.sh view
@@ -5,36 +5,23 @@  # A test for darcs detecting a conflict, inspired by bug #152 in RT -rm -rf temp1 temp2- # set up the repository-mkdir temp1-cd temp1-darcs init-cd ..+darcs init temp1  cd temp1 echo "apply allow-conflicts" > _darcs/prefs/defaults-# note: to make this pass, change echo to echo -n-# is that right? echo "from temp1" > one.txt darcs add one.txt-darcs record -A bar -am "add one.txt"+darcs record -am "add one.txt" echo >> one.txt darcs wh -u cd ..  darcs get temp1 temp2 cd temp2-# reality check-darcs show files | grep one.txt-echo "in tmp2" >> one.txt+echo "from temp2" >> one.txt darcs whatsnew -s | grep M-darcs record -A bar -am "add extra line"-darcs annotate -p . -u-darcs push -av > log-cat log-not grep -i conflicts log+darcs record -am "append non-empty line"+darcs push -av 2> log+grep -i conflicts log cd ..--rm -rf temp1 temp2
− tests/mv-formerly-pl.sh 
@@ -1,123 +0,0 @@-#!/usr/bin/env bash--# Some tests for 'darcs mv'--. lib--rm -rf temp-mkdir temp-cd temp-darcs init--###--echo adding a directory with more than one .. in it should work.-mkdir foo.d-mkdir foo.d/second-mkdir foo.d/second/third-mkdir foo.d/other---touch ./foo.d/other/date.t-darcs add -r foo.d--cd foo.d/second/third--darcs mv ../../other/date.t ../../other/date_moved.t--cd ../../..-echo darcs refuses to move to an existing file-touch ping-touch pong-darcs add ping pong--not darcs mv ping pong 2>&1 | grep "already exists"--# case sensitivity series-# ------------------------# these are tests designed to check out darcs behave wrt to renames-# where the case of the file becomes important--# are we on a case sensitive file system?-touch is_it_cs-rm -f IS_IT_CS--if test -e is_it_cs; then-  echo This is a case-sensitive file system.-else-  echo This is NOT a case-sensitive file system.-fi--# if the new file already exists - we don't allow it-# basically the same test as mv ping pong, except we do mv ping PING-# and both ping and PING exist on the filesystem-echo "case sensitivity - simply don't allow mv if new file exists"-touch 'cs-n-1'; touch 'CS-N-1';-touch 'cs-y-1'; touch 'CS-Y-1';-darcs add cs-n-1 cs-y-1--if test -e is_it_cs; then-  # regardless of case-ok, we do NOT want this mv at all-  not darcs mv cs-n-1 CS-Y-1 2>&1 | grep "already exists"--  not darcs mv --case-ok cs-n-1 CS-Y-1 2>&1 | grep "already exists"-fi--# if the new file does not already exist - we allow it-echo "case sensitivity - the new file does *not* exist"-touch 'cs-n-2';-touch 'cs-y-2';-darcs add cs-n-2 cs-y-2-# these mv's should be allowed regardless of flag or filesystem-darcs mv cs-n-2 CS-N-2-darcs mv --case-ok cs-y-2 CS-Y-2--# parasites - do not accidentally overwrite a file just because it has a-# similar name and points to the same inode.  We want to check if a file if the-# same NAME already exists - we shouldn't care about what the actual file is!-echo "case sensitivity - inode check";-touch 'cs-n-3';-touch 'cs-y-3';-darcs add cs-n-3 cs-y-3--if ln cs-n-3 CS-N-3; then # checking if we support hard links-  ln cs-y-3 CS-Y-3-  # regardless of case-ok, we do NOT want this mv at all-  not darcs mv cs-n-3 CS-N-3 2>&1 | grep "already exists"--  not darcs mv --case-ok cs-y-3 CS-Y-3 2>&1 | grep "already exists"-fi--# parasites - we don't allow weird stuff like mv foo bar/foo just because-# we opened up some crazy exception based on foo's name-echo 'refuses to move to an existing file with same name, different path'-touch 'cs-n-4'; touch 'foo.d/cs-n-4';-touch 'cs-y-4'; touch 'foo.d/cs-y-4';-darcs add cs-n-4-# regardless of case-ok, we do NOT want this mv at all-not darcs mv cs-n-4 foo.d/cs-n-4 2>&1 | grep "already exists"--not darcs mv --case-ok cs-y-4 foo.d/cs-y-4 2>&1 | grep "unadded"--# ----------------------------# end case sensitivity series--touch abs_path.t-darcs add abs_path.t-REPO_ABS=`pwd`-darcs mv "$REPO_ABS/abs_path.t" abs_path_new.t-darcs mv abs_path_new.t "$REPO_ABS/abs_path.t"---# issue608--   touch 'gonna_be_deleted';-   darcs add gonna_be_deleted-   darcs record -am 'added doomed file'-   rm gonna_be_deleted-   darcs record -am 'deleted file'-   touch 'new_file';-   darcs add new_file-   darcs mv new_file gonna_be_deleted--
− tests/mv-test-suite.sh 
@@ -1,28 +0,0 @@-#!/usr/bin/env bash--set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init--date > foo-darcs record -a -m add_foo -A x --look-for-adds--# add a test file-echo 'test ! -e foo' > test.sh-darcs add test.sh-darcs record -a -m add_test--darcs setpref test 'ls && bash test.sh'-darcs record -a -m settest -A x --no-test--darcs mv foo bar-darcs record --debug -a -m mvfoo -A x--darcs check--cd ..-rm -rf temp1-
tests/mv.sh view
@@ -1,10 +1,9 @@ #!/usr/bin/env bash-set -ev+. ./lib -rm -rf temp-mkdir temp-cd temp-darcs init+darcs init temp1+cd temp1+ echo hi world > temp.c darcs add temp.c darcs record --all -A test --name=hi@@ -32,22 +31,282 @@ grep 'Cannot rename a file or directory onto itself' stderr  cd ..+rm -rf temp1 -rm -rf temp-mkdir temp-cd temp-darcs init+darcs init temp1+cd temp1+ echo hi world > a-darcs add a-darcs record --all -m lower+darcs record -lam lower cd ..-darcs get temp temp1-cd temp+darcs clone temp1 temp2+cd temp1 darcs mv a A echo goodbye > A darcs record --all -m 'to upper'-cd ../temp1+cd ../temp2 darcs pull -a  cd ..-rm -rf temp temp1+rm -rf temp1 temp2++# Part 2++darcs init temp1+cd temp1++echo adding a directory with more than one .. in it should work.+mkdir foo.d+mkdir foo.d/second+mkdir foo.d/second/third+mkdir foo.d/other++touch ./foo.d/other/date.t+darcs add -r foo.d++cd foo.d/second/third++darcs mv ../../other/date.t ../../other/date_moved.t++cd ../../..+echo darcs refuses to move to an existing file+touch ping pong+darcs add ping pong++not darcs mv ping pong 2>&1 | grep "already exists"++# case sensitivity series+# -----------------------+# these are tests designed to check out darcs behave wrt to renames+# where the case of the file becomes important++# are we on a case sensitive file system?+touch is_it_cs+rm -f IS_IT_CS++if test -e is_it_cs; then+  echo This is a case-sensitive file system.+else+  echo This is NOT a case-sensitive file system.+fi++# if the new file already exists - we don't allow it+# basically the same test as mv ping pong, except we do mv ping PING+# and both ping and PING exist on the filesystem+echo "case sensitivity - simply don't allow mv if new file exists"+touch 'cs-n-1'; touch 'CS-N-1';+touch 'cs-y-1'; touch 'CS-Y-1';+darcs add cs-n-1 cs-y-1++if test -e is_it_cs; then+  # regardless of case-ok, we do NOT want this mv at all+  not darcs mv cs-n-1 CS-Y-1 2>&1 | grep "already exists"++  not darcs mv --case-ok cs-n-1 CS-Y-1 2>&1 | grep "already exists"+fi++# if the new file does not already exist - we allow it+echo "case sensitivity - the new file does *not* exist"+touch 'cs-n-2';+touch 'cs-y-2';+darcs add cs-n-2 cs-y-2+# these mv's should be allowed regardless of flag or filesystem+darcs mv cs-n-2 CS-N-2+darcs mv --case-ok cs-y-2 CS-Y-2++# parasites - do not accidentally overwrite a file just because it has a+# similar name and points to the same inode.  We want to check if a file if the+# same NAME already exists - we shouldn't care about what the actual file is!+echo "case sensitivity - inode check";+touch 'cs-n-3';+touch 'cs-y-3';+darcs add cs-n-3 cs-y-3++if ln cs-n-3 CS-N-3; then # checking if we support hard links+  ln cs-y-3 CS-Y-3+  # regardless of case-ok, we do NOT want this mv at all+  not darcs mv cs-n-3 CS-N-3 2>&1 | grep "already exists"++  not darcs mv --case-ok cs-y-3 CS-Y-3 2>&1 | grep "already exists"+fi++# parasites - we don't allow weird stuff like mv foo bar/foo just because+# we opened up some crazy exception based on foo's name+echo 'refuses to move to an existing file with same name, different path'+touch 'cs-n-4'; touch 'foo.d/cs-n-4';+touch 'cs-y-4'; touch 'foo.d/cs-y-4';+darcs add cs-n-4+# regardless of case-ok, we do NOT want this mv at all+not darcs mv cs-n-4 foo.d/cs-n-4 2>&1 | grep "already exists"++not darcs mv --case-ok cs-y-4 foo.d/cs-y-4 2>&1 | grep "unadded"++# ---------------------------+# end case sensitivity series++touch abs_path.t+darcs add abs_path.t+REPO_ABS=`pwd`+darcs mv "$REPO_ABS/abs_path.t" abs_path_new.t+darcs mv abs_path_new.t "$REPO_ABS/abs_path.t"++# issue608++touch 'gonna_be_deleted';+darcs add gonna_be_deleted+darcs record -am 'added doomed file'+rm gonna_be_deleted+darcs record -am 'deleted file'+touch 'new_file';+darcs add new_file+darcs mv new_file gonna_be_deleted++cd ..+rm -rf temp1++# mv and test suite++darcs init temp1+cd temp1++date > foo+darcs record -lam add_foo++echo 'test ! -e foo' > test.sh # "foo should not exist"+darcs record -lam add_test++darcs setpref test 'ls && bash test.sh'+darcs record -a -m settest --no-test++darcs mv foo bar+darcs record --debug -a -m mvfoo++cd ..+rm -rf temp1++# mv then ad++darcs init temp1+cd temp1++touch fee fi fo fum+darcs record -lam add+darcs mv fee foo+touch fee+darcs add fee+darcs record -a -m newfee+darcs mv fi fib+darcs record -a -m mvfi+date > fi+darcs add fi +darcs record -a -m newfi++cd ..+rm -rf temp1++# illegal mv++darcs init temp1+cd temp1++echo text > afile.txt+darcs record -lam init+mkdir d+not darcs mv afile.txt d/afile.txt # should fail, since d not in repo++cd ..+rm -rf temp1++# swapping files++darcs init temp1+cd temp1++touch foo bar+darcs record -lam add_foo_bar+darcs mv foo zig+darcs mv bar foo+darcs mv zig bar+darcs record -a -m swap_foo_bar+cd ..+rm -rf temp1+++## issue2139 - darcs should accept to mv to the current working directory+## Copyright (C) 2012 Eric Kow++darcs init temp1+cd temp1++# move dir to root+mkdir a a/a2 a/a3+darcs record -lam 'Some directories (a)'+darcs mv a/a2 .+test -d a2 +cd a+darcs mv a3 ..+not test -d a3+cd ..+test -d a3++# move dir to non-root dir+mkdir b b2 b3+darcs record -lam 'Some directories (b)'+darcs mv b2 b+test -d b/b2+cd b+darcs mv ../b3 .+test -d b3+cd ..++cd ..+rm -rf temp1++# issue1740 - darcs mv on directories should work after the fact++darcs init temp1+cd temp1++mkdir d+echo 'Example content.' > d/f+darcs record -lam 'Add d/f'+mv d d2+darcs mv d d2 # oops, I meant to darcs mv that+darcs what | grep "move ./d ./d2"+cd ..+rm -rf temp1++# it should not crash when given invalid paths+# instead issue a proper error message++rm -rf R+darcs init R+cd R+touch f+darcs record -lam 'add f' f+# 2 path arguments+# target does not exist: OK+darcs move f g+darcs revert -a+# source does not exist: Fail+not darcs move g f >LOG 2>&1+not grep -i bug LOG+grep -i 'does not exist' LOG+# 2nd is un-added existing directory+mkdir d+not darcs move f d >LOG 2>&1+not grep -i bug LOG+grep -i 'not known' LOG+# 3 path arguments+touch g+darcs record -lam 'add g' g+# 3rd arg is un-added existing dir+not darcs move f g d >LOG 2>&1+not grep -i bug LOG+grep -i "isn't known" LOG+# 3rd argument does not exist+rm -rf d+not darcs move f g d >LOG 2>&1+not grep -i bug LOG+grep -i "isn't known" LOG+cd ..
tests/mv_and_remove_tests.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp mkdir temp
− tests/mv_then_add.sh 
@@ -1,25 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp-mkdir temp-cd temp--darcs init-touch fee fi fo fum-darcs add f*-darcs record --author me --all --no-test --name add-darcs mv fee foo-touch fee-darcs add fee-darcs record --author me --all --no-test --name newfee-darcs mv fi fib-darcs record --author me --all --no-test --name mvfi-date > fi-darcs add fi -darcs record --author me --all --no-test --name newfi--cd ..--rm -rf temp-
− tests/network/changes.sh 
@@ -1,5 +0,0 @@-#!/usr/bin/env bash-set -ev--# Demonstrates issue385-darcs changes --repo=http://darcs.net GNUmakefile --last 300
+ tests/network/clone-http-packed-detect.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash+# 2011, by Petr Rockai, Guillaume Hoffmann, public domain++# Tests that darcs clone --verbose reports getting a pack when there is one,+# and does not report when there is none or when --no-packs is passed.++. lib+. httplib++only-format darcs-2 # compressed repo is darcs-2++gunzip -c $TESTDATA/laziness-complete.tgz | tar xf -++cd repo++darcs optimize http+test -e _darcs/packs/basic.tar.gz+test -e _darcs/packs/patches.tar.gz+cd ..++serve_http # sets baseurl++# check that default behaviour is to get packs+rm -rf S+darcs clone $baseurl/repo S --verbose |grep "Cloning packed basic repository"++# check that it does really not get packs when --no-packs is passed+rm -rf S+darcs clone $baseurl/repo S --no-packs --verbose  |not grep "Cloning packed basic repository"++# check that it does not claim getting packs when there are not+rm -rf S+rm -rf repo/_darcs/packs/+# sleep for a second to avoid spurious false positives on MacOS:+sleep 1+darcs clone $baseurl/repo S --verbose |not grep "Cloning packed basic repository"
+ tests/network/clone-http-packed.sh view
@@ -0,0 +1,23 @@+#!/usr/bin/env bash+# Written in 2010 by Petr Rockai, placed in public domain++. lib+. httplib++only-format darcs-2 # compressed repo is darcs-2++gunzip -c $TESTDATA/laziness-complete.tgz | tar xf -++cd repo++darcs optimize http+test -e _darcs/packs/basic.tar.gz+test -e _darcs/packs/patches.tar.gz+cd ..++serve_http # sets baseurl+rm -rf S+darcs clone --packs $baseurl/repo S+cd S+rm _darcs/prefs/sources # avoid any further contact with the original repository+darcs check
+ tests/network/clone-http.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash+# Written in 2010 by Petr Rockai, placed in public domain++# This file is included as part of the Darcs test distribution,+# which is licensed to you under the following terms:+##+## 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+## SOFTWARE.++. lib+. httplib++rm -rf R S && mkdir R+cd R+darcs init+echo a > a+darcs rec -lam a+cd ..++serve_http # sets baseurl+darcs clone $baseurl/R S+cd S+darcs pull ../R | tee log+grep "No remote" log+darcs check
+ tests/network/clone.sh view
@@ -0,0 +1,24 @@+#!/usr/bin/env bash++. lib+. httplib++# this should all work without a cache+if ! grep no-cache $HOME/.darcs/defaults; then+  echo ALL no-cache >> $HOME/.darcs/defaults+fi++rm -rf tabular+unpack_testdata tabular+serve_http # sets baseurl++rm -rf temp2 temp3+darcs clone --lazy $baseurl/tabular temp2+darcs clone --lazy --tag . $baseurl/tabular temp3++cd temp2+darcs obliterate --from-tag . -a+darcs pull --tag . -a+cd ..++diff -u temp2/_darcs/hashed_inventory temp3/_darcs/hashed_inventory
tests/network/external.sh view
@@ -4,34 +4,28 @@  . lib -rm -rf temp1+rm -rf foo temp1 temp2+rm -f fakessh -touch_fakessh='./touch-fakessh'-if echo $OS | grep -i windows; then-  touch_fakessh="touch_fakessh.bat"-fi-export DARCS_SSH=$touch_fakessh-export DARCS_SCP=$touch_fakessh-export DARCS_SFTP=$touch_fakessh-rm -rf 'fakessh'-rm -rf 'touch-fakessh'+fakessh=$(pwd)/fakessh+cat >$fakessh.hs <<EOF+main = writeFile "touchedby_fakessh" "hello\n"+EOF+ghc $GHC_FLAGS --make $fakessh.hs -# make our ssh command one word only-echo 'echo hello > fakessh' > $touch_fakessh-chmod u+x $touch_fakessh+export DARCS_SSH=$fakessh+export DARCS_SCP=$fakessh+export DARCS_SFTP=$fakessh+ # first test the DARCS_SSH environment variable-not darcs get example.com:foo-grep hello fakessh-rm -f fakessh+rm -f touchedby_fakessh+darcs clone example.com:foo+grep hello touchedby_fakessh  # now make sure that we don't launch ssh for nothing-mkdir temp1-cd temp1-darcs init-cd ..-darcs get temp1 > log-not grep fakessh log-not darcs get http://darcs.net/nonexistent-not grep fakessh log-cd ..-rm -rf temp1+rm -f touchedby_fakessh+darcs init temp1+darcs clone temp1 temp2 > log+not grep touchedby_fakessh log+not darcs clone http://darcs.net/nonexistent+not grep touchedby_fakessh log
− tests/network/get.sh 
@@ -1,19 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp temp2 temp3--#"$DARCS" get http://darcs.net temp--darcs get --lazy http://darcs.net temp2--darcs get --lazy --tag . http://darcs.net temp3--cd temp2-darcs obliterate --from-tag . -a-darcs pull --tag . -a-cd ..--diff -u temp2/_darcs/hashed_inventory temp3/_darcs/hashed_inventory--rm -rf temp temp2 temp3
+ tests/network/httplib view
@@ -0,0 +1,27 @@+serve_http() {+    lightpid=$((10000 + $$ % 30000))+    cat > light.conf <<EOF+    server.document-root       = "$PWD"+    server.errorlog            = "$PWD/error.log"+    server.port                = $lightpid+    server.bind                = "localhost"+    server.pid-file            = "$PWD/light.pid"+    index-file.names           = ()+EOF+    trap "finish_http \"$PWD\"" EXIT+    PATH=${PATH}:/sbin:/usr/sbin+    lighttpd -f light.conf || exit 200+    ps `cat light.pid` > /dev/null 2>&1 || exit 200+    baseurl="http://localhost:$lightpid"+}++finish_http() {+    (test -e "$1/light.pid" && kill `cat "$1/light.pid"`) || true+}++check_remote_http() {+  if ! curl -fI "$1"; then+    echo Cannot reach "$1"+    exit 200+  fi+}
tests/network/issue1503_prefer_local_caches_to_remote_one.sh view
@@ -24,10 +24,13 @@ ## SOFTWARE.  . lib+. httplib +check_remote_http https://darcs.net/testing/repo1+ rm -rf S T-darcs get --lazy http://darcs.net/testing/repo1 S+darcs clone --lazy https://darcs.net/testing/repo1 S darcs tag --repo S -m 2-darcs get --lazy http://darcs.net/testing/repo1 T+darcs clone --lazy https://darcs.net/testing/repo1 T darcs pull --repo T S -a --debug --verbose 2>&1 | tee log not grep repo1 log
+ tests/network/issue1599-automatically-expire-unused-caches.sh view
@@ -0,0 +1,57 @@+#!/usr/bin/env bash+## Test for issue1599 - 'Automatically expire unused caches'+##+## Copyright (C) 2010  Adolfo Builes+##+## 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+## SOFTWARE.++. lib+. httplib++rm -rf R S log && mkdir R+cd R+darcs init+echo a > a+darcs rec -lam a+echo b > b+darcs rec -lam b+echo c > c+darcs rec -lam c+darcs tag bla # so that the clone really is lazy+cd ..++serve_http # sets baseurl+darcs clone --lazy $baseurl/R S+rm S/_darcs/prefs/sources+if [ -z "$http_proxy" ]; then+  echo "repo:http://10.1.2.3/S" >> S/_darcs/prefs/sources+fi+echo "repo:$baseurl/dummyRepo" >> S/_darcs/prefs/sources+echo "repo:/does/not/exist" >> S/_darcs/prefs/sources+echo "repo:$baseurl/R" >> S/_darcs/prefs/sources+DARCS_CONNECTION_TIMEOUT=1 darcs log --repo S --debug --no-cache 2>&1 | tee log+grep "could not reach the following locations" log+# the count is two, once for the file we want, and once to test+# for reachability using _darcs/hashed_inventory+if test -z "$http_proxy"; then+  test `grep -c "copyRemote: http://10.1.2.3/S" log` = 2+fi+test `grep -c "copyRemote: $baseurl/dummyRepo" log` = 2
+ tests/network/issue1923-cache-warning.sh view
@@ -0,0 +1,58 @@+#!/usr/bin/env bash+## Test for issue1599 - 'Automatically expire unused caches'+##+## Copyright (C) 2010  Adolfo Builes+##+## 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+## SOFTWARE.++. lib+. httplib++rm -rf R+darcs init --repo R+cd R+echo a > a+darcs rec -lam a+darcs tag x+cd ..++serve_http+cat <<SOURCES > fake-sources+repo:$baseurl/dummyRepo+repo:/some/bogus/local/path+repo:$baseurl/R+SOURCES+rm -rf S1 S2+darcs clone --lazy R S1 && cp fake-sources S1/_darcs/prefs/sources+darcs clone --lazy R S2 && cp fake-sources S2/_darcs/prefs/sources++# make sure we do warn about things that are under your control+darcs log --verbose --repo S1 --no-cache 2>&1 | tee log-local+c1=`grep -c "$baseurl/dummyRepo" log-local`+[ $c1 -eq 1 ]+c2=`grep -c "/some/bogus/local/path" log-local`+[ $c2 -eq 1 ]++# now what about things that aren't?+darcs log --verbose --repo $baseurl/S2 --no-cache 2>&1 | tee log-remote+c1=`grep -c "$baseurl/dummyRepo" log-remote`+[ $c1 -eq 1 ] # always under your control+not grep -c "/some/bogus/local/path" log-remote
+ tests/network/issue1932-remote.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash+## Test for issue1932 - "darcs add -qr ." should not break on files with colons+##+## Copyright(C) 2010 Dmitry Astapov+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+. sshlib++# Colons could be in repo names and in file name.+# Colon in repo name is an indication of special case - remote repo.+# Colon in the file could be there under unix and requires no special treatment.++# Repo name with ':' is either scp repo or http repo.+# Let's check scp repo first.+( darcs clone user@ssh.bogus.domain.so.it.will.surely.fail.example.org.:path || true ) >log 2>&1+fgrep 'ssh: Could not resolve host' log++# HTTP repo+( http_proxy= darcs clone http://www.bogus.domain.so.it.will.surely.fail.example.org. || true ) >log 2>&1+egrep 'CouldNotResolveHost|host lookup failure|Name or service not known' log++# local repos are tested by tests/issue1932-colon-breaks-add.sh
tests/network/issue2090-transfer-mode.sh view
@@ -23,11 +23,14 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -echo 'Comment this line out and run the script by hand'; exit 200+# echo 'Comment this line out and run the script by hand'; exit 200 -. $(dirname $0)/../lib-. $(dirname $0)/sshlib+# . $(dirname $0)/../lib+# . $(dirname $0)/sshlib +. lib+. sshlib+ # Clean up after previous remote runs ${SSH} ${REMOTE} "\ rm -rf ${REMOTE_DIR}; \@@ -35,17 +38,17 @@ "  # Set up a repo to test+rm -rf R darcs init --repo R cd R touch f g darcs add f g darcs record f g -a --ignore-times -m 'add some files' -A moi-darcs put $REMOTE:$REMOTE_DIR/R+darcs clone . $REMOTE:$REMOTE_DIR/R cd .. -# Now try darcs get-darcs get $REMOTE:$REMOTE_DIR/R S --debug > log 2>&1-COUNT=$(grep -c 'darcs transfer-mode' log)+rm -rf S+darcs clone $REMOTE:$REMOTE_DIR/R S --debug > log 2>&1+COUNT=$(grep -c '^Exec: "ssh" .* "darcs" "transfer-mode"' log) # with issue2090, this was 6! test $COUNT -eq 1-cleanup
+ tests/network/issue2545_command-execution-via-ssh-uri-local.sh view
@@ -0,0 +1,55 @@+#!/usr/bin/env bash+## Test for issue2545 - Argument smuggling in SSH repository URLs+## Darcs allows (almost) arbitrary command execution via a crafted ssh URI.+##+## Copyright (C) 2017  Gian Piero Carrubba+##+## 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+## SOFTWARE.++# This part of the tests for issue2545 doesn't actually try to connect+# remotely, but is still kept in the network folder as it uses a+# network-based command, allowing developers that have problems with+# those commands to exclude it with --network=no:+# https://lists.osuosl.org/pipermail/darcs-devel/2020-July/021363.html++. lib                           # Load some portability helpers.+darcs init      --repo R        # Create our test repos.+cd R++DARCS_SCP=sftp darcs pull -a ssh://-oProxyCommand='touch FAIL' \+    2>/dev/null || true+not ls FAIL >/dev/null++DARCS_SCP=sftp darcs pull -a -- -oProxyCommand='touch FAIL':dir \+    2>/dev/null || true+not ls FAIL >/dev/null++# Executing the same tests with `clone' instead of `pull'. The results shoud+# be the same, but better safe than sorry.+DARCS_SCP=sftp darcs clone ssh://-oProxyCommand='touch FAIL' S \+    2>/dev/null || true+not ls FAIL >/dev/null++DARCS_SCP=sftp darcs clone -- -oProxyCommand='touch FAIL':dir T \+    2>/dev/null || true+not ls FAIL >/dev/null++cd ..
+ tests/network/issue2545_command-execution-via-ssh-uri.sh view
@@ -0,0 +1,45 @@+#!/usr/bin/env bash+## Test for issue2545 - Argument smuggling in SSH repository URLs+##+## Darcs allows (almost) arbitrary command execution via a crafted ssh+## URI.+## When pushing to a remote repo, darcs is invoked on the remote server+## via ssh. This use of ssh is different from the ones tested by the+## not-networked test. Also, I'm not sure how (if) it can be exploited,+## so I'm just checking for the debug message. Pretty lame test, I know.+##+## Copyright (C) 2017  Gian Piero Carrubba+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+. sshlib                        # Load ssh helpers.++init_remote_repo R              # Create our test repos.+darcs init      --repo R        #+cd R++echo "text" > file              # Modify the working dir+darcs record -lam "First Patch" # Record the changes++check="\"${SSH}\" \"--\" \"${REMOTE}\" \"darcs apply --all --repodir '${REMOTE_DIR}/R' --debug\""+darcs push -a --debug "${REMOTE}":"${REMOTE_DIR}"/R 2>&1 >/dev/null | \+    fgrep "$check"
+ tests/network/issue2608-clone-http-packed-outdated.sh view
@@ -0,0 +1,29 @@+#!/usr/bin/env bash+# test that cloning a repo with not up-to-date packs still gets us all the patches++. lib+. httplib++rm -rf R+darcs init R+cd R+echo foo > foo+darcs record -lam foo+darcs tag foo+echo bar > bar+darcs record -lam bar+darcs optimize http+darcs tag "not packed"+echo qux > qux+darcs record -lam qux+cd ..++serve_http # sets baseurl++rm -rf S+darcs clone $baseurl/R S++cd S+darcs log | grep "not packed"+darcs log | grep "qux"+cd ..
+ tests/network/lazy-clone.sh view
@@ -0,0 +1,37 @@+#!/usr/bin/env bash++. lib+. httplib++rm -rf tabular+unpack_testdata tabular+serve_http # sets baseurl++rm -rf temp temp2+darcs clone --lazy $baseurl/tabular temp+darcs clone --lazy temp temp2++cd temp2+test ! -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2+darcs log -p 'Initial version' -v | cat+test -f _darcs/patches/0000005705-178beaf653578703e32346b4d68c8ee2f84aeef548633b2dafe3a5974d763bf2+cd ..++# test if we can unapply patches after a tag+rm -rf temp4+darcs clone --lazy $baseurl/tabular temp4 --tag '^0.1$'+darcs log --repo=temp4 # to get all inventories+darcs log --repo=temp # to get all inventories+finish_http $PWD+# and that the log -v output is correct+darcs log -v --repo=temp4 > LOG+if grep no-cache $HOME/.darcs/defaults; then+  expected_unavailable=33+else+  # With cache, the patch 'initial version' is available+  # because of the darcs log command in temp2 above.+  expected_unavailable=32+fi+test $(grep -c 'this patch is unavailable' LOG) = $expected_unavailable++darcs log -v --repo=temp
− tests/network/lazy-get.sh 
@@ -1,22 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp temp2 temp3--darcs get --lazy http://darcs.net/repos/franchise temp--darcs get --lazy temp temp2--rm -rf temp--cd temp2--test ! -f _darcs/patches/0000003700-fb09ec6a61b35ac7aa77e65388b1a0c182fddca9a908f1a08d0bc5653f2f2d2a--darcs annotate -p 'initial minimal version'--test -f _darcs/patches/0000003700-fb09ec6a61b35ac7aa77e65388b1a0c182fddca9a908f1a08d0bc5653f2f2d2a--cd ..--rm -rf temp temp2 temp3
+ tests/network/log.sh view
@@ -0,0 +1,27 @@+#!/usr/bin/env bash++. lib+. httplib++check_remote_http https://hub.darcs.net/darcs/darcs-screened++# Demonstrates issue385 and others+darcs log --repo=https://hub.darcs.net/darcs/darcs-screened GNUmakefile --last 30++# Test things mentioned in issue2461:++# no _darcs should remain+test ! -d _darcs++# go to a directory where we have no write access+trap "chmod u+w $PWD/ro" EXIT+mkdir ro+chmod a-w ro+cd ro+# and try again (with less patches to fetch)+darcs log --repo=https://hub.darcs.net/darcs/darcs-screened GNUmakefile --last 3+# an absolute path should give an error+not darcs log --repo=https://hub.darcs.net/darcs/darcs-screened /GNUmakefile --last 3+# also test that it works without any filename arguments+darcs log --repo=https://hub.darcs.net/darcs/darcs-screened --last 1+cd ..
+ tests/network/show_tags-remote.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+## Test for show tags --repo+##+## Copyright (C) 2010 Eric Kow+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+. httplib++rm -rf R S++darcs init      --repo R        # Create our test repos.+darcs init      --repo S++cd R+echo 'Example content.' > f+darcs record -lam 'Add f'+darcs tag 't0'+darcs tag 't1'+darcs show tags | grep t0+cd ..+serve_http # sets baseurl++cd S+darcs log --repo ../R+darcs show tags --repo ../R | grep t0+darcs show tags --repo $baseurl/R | grep t0+cd ..++darcs show tags --repo R | grep t0+darcs show tags --repo $baseurl/R | grep t0
tests/network/ssh.sh view
@@ -1,41 +1,50 @@-#!/bin/bash-echo 'Comment this line out and run the script by hand'; exit 200+#!/usr/bin/env bash+# echo 'Comment this line out and run the script by hand'; exit 200 -. $(dirname $0)/../lib-. $(dirname $0)/sshlib+# . $(dirname $0)/../lib+# . $(dirname $0)/sshlib +. lib+. sshlib++REMOTE_DARCS=$(which darcs)+ # ================ Setting up remote repositories ===============-${SSH} ${REMOTE} "\-rm -rf ${REMOTE_DIR}; \-mkdir ${REMOTE_DIR}; \-cd ${REMOTE_DIR}; \-\-mkdir testrepo; cd testrepo; \-darcs init; \-echo moi > _darcs/prefs/author; \-touch a; darcs add a; darcs record a --ignore-times -am 'add file a'; \-echo 'first line' > a; darcs record a --ignore-times -am 'add first line to a'; \-cd ..; \-\-darcs get testrepo testrepo-pull; \-cd testrepo-pull; \-echo moi > _darcs/prefs/author; \-touch b; darcs add b; darcs record b --ignore-times -am 'add file b'; \-echo 'other line' > b; darcs record b --ignore-times -am 'add other line to b'; \-cd ..; \-\-darcs get testrepo testrepo-push; \-darcs get testrepo testrepo-send; \-"+${SSH} ${REMOTE} /bin/sh <<EOF+rm -rf ${REMOTE_DIR}+mkdir ${REMOTE_DIR}+cd ${REMOTE_DIR} +PATH=$(dirname $REMOTE_DARCS):$PATH++mkdir testrepo; cd testrepo+darcs init+echo moi > _darcs/prefs/author+touch a; darcs add a+darcs record --skip-long-comment a --ignore-times -am 'add file a'+echo 'first line' > a+darcs record --skip-long-comment a --ignore-times -am 'add first line to a'+cd ..++darcs clone testrepo testrepo-pull+cd testrepo-pull+echo moi > _darcs/prefs/author+touch b; darcs add b; darcs record --skip-long-comment b --ignore-times -am 'add file b'+echo 'other line' > b; darcs record --skip-long-comment b --ignore-times -am 'add other line to b'+cd ..++darcs clone testrepo testrepo-push+darcs clone testrepo testrepo-send+EOF+ # ================ Settings =============== echo ${DARCS_SSH_FLAGS} echo ${DARCS_SSH} echo ${DARCS_SCP} echo ${DARCS_SFTP} -# ================ Checking darcs get ==================-darcs get ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo ${DARCS_SSH_FLAGS}+# ================ Checking darcs clone ==================+darcs clone ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo ${DARCS_SSH_FLAGS} # check that the test repo made it over [ -d testrepo ] [ -d testrepo/_darcs ]@@ -51,50 +60,88 @@ fi  # ================ Checking darcs pull =================-darcs get ${DARCS_SSH_FLAGS} testrepo testrepo-pull+darcs clone ${DARCS_SSH_FLAGS} testrepo testrepo-pull cd testrepo-pull-echo yyy | darcs pull ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-pull+darcs pull -a ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-pull # see if the changes got pulled over grep "other line" b  cd ..  # ================ Checking darcs push and send ================="-darcs get ${DARCS_SSH_FLAGS} testrepo testrepo-push+darcs clone ${DARCS_SSH_FLAGS} testrepo testrepo-push cd testrepo-push echo moi > _darcs/prefs/author-echo "second line" >> a; darcs record a --ignore-times -am "add second line to a"+echo "second line" >> a+darcs record --skip-long-comment a --ignore-times -am "add second line to a" touch c; darcs add c-darcs record --ignore-times -am "add file c" c-echo yyy | darcs push ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-push+darcs record --skip-long-comment --ignore-times -am "add file c" c+darcs push -a  --remote-darcs=$REMOTE_DARCS ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-push # check that the file c got pushed over ${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-push/c ]"-echo yyy | darcs send --no-edit-description ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-send -o mybundle.dpatch+darcs send -a --no-edit-description ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-send -o mybundle.dpatch # check that the bundle was created grep "add file c" mybundle.dpatch cd .. -# ================ Checking darcs put =================="+# ================ Checking darcs clone to ssh destination ==================" cd testrepo-darcs put ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-put-# check that the put was successful-${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/testrepo-put/_darcs ]"-${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-put/a ]"++darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-clone+# check that the clone was successful+${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/testrepo-clone/_darcs ]"+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/testrepo-clone/a ]"+# check that it fails with proper error message of target exists+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/testrepo-clone 2> errlog+grep "Cannot create remote directory" errlog++# now with nested target directories+darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/x/y/testrepo-clone+# check that the clone was successful+${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/x/y/testrepo-clone/_darcs ]"+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/x/y/testrepo-clone/a ]"+# check that it fails with proper error message if remote dir exists+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/x/y 2> errlog+grep "Cannot create remote directory" errlog+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/x/y/testrepo-clone 2> errlog+grep "Cannot create remote directory" errlog++# now with trailing slash in target+darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/foo/testrepo-clone/+# check that the clone was successful+${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/foo/testrepo-clone/_darcs ]"+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/foo/testrepo-clone/a ]"+# check that it fails with proper error message if remote dir exists+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/foo/ 2> errlog+grep "Cannot create remote directory" errlog+not darcs clone . ${DARCS_SSH_FLAGS} ${REMOTE}:${REMOTE_DIR}/foo/testrepo-clone/ 2> errlog+grep "Cannot create remote directory" errlog++# now with ssh:// URI+darcs clone . ${DARCS_SSH_FLAGS} ssh://${REMOTE}/${REMOTE_DIR}/bar/testrepo-clone/+# check that the clone was successful+${SSH} ${REMOTE} "[ -d ${REMOTE_DIR}/bar/testrepo-clone/_darcs ]"+${SSH} ${REMOTE} "[ -f ${REMOTE_DIR}/bar/testrepo-clone/a ]"+# check that it fails with proper error message if remote dir exists+not darcs clone . ${DARCS_SSH_FLAGS} ssh://${REMOTE}/${REMOTE_DIR}/bar/ 2> errlog+grep "Cannot create remote directory" errlog+not darcs clone . ${DARCS_SSH_FLAGS} ssh://${REMOTE}/${REMOTE_DIR}/bar/testrepo-clone/ 2> errlog+grep "Cannot create remote directory" errlog+ cd ..  # ======== Checking push over ssh with a conflict ========="-${SSH} ${REMOTE} "echo apply no-allow-conflicts >> ${REMOTE_DIR}/testrepo-put/_darcs/prefs/defaults"+${SSH} ${REMOTE} "echo apply no-allow-conflicts >> ${REMOTE_DIR}/testrepo-clone/_darcs/prefs/defaults"  cd testrepo  echo moi > _darcs/prefs/author echo 'change for remote' > a-darcs record --ignore-times -am 'change for remote'-darcs push -a+darcs record --skip-long-comment --ignore-times -am 'change for remote'+darcs push -a --remote-darcs=$REMOTE_DARCS darcs ob --last 1 -a echo 'change for local' > a-darcs record --ignore-times -am 'change for local'-darcs push -a > log 2>&1 || :+darcs record --skip-long-comment --ignore-times -am 'change for local'+darcs push -a --remote-darcs=$REMOTE_DARCS > log 2>&1 || : grep -q 'conflicts options to apply' log  cd ..-cleanup
+ tests/network/sshlib view
@@ -0,0 +1,45 @@+# Note: we are connecting via ssh to the local machine, so the REMOTE_DIR is+# actually a local path. This requires that the user running the tests has ssh+# installed (client and server) and that they have a valid key pair and an ssh+# agent running, so they can do 'ssh localhost' w/o getting prompted for their+# passphrase every time.++REMOTE_DIR="$(pwd)/remote_dir"++if [ x"${USE_PUTTY}" != x ]; then+  DARCS_SSH=plink+  export DARCS_SSH+  DARCS_SCP=pscp+  export DARCS_SCP+  DARCS_SFTP=psftp+  export DARCS_SFTP+fi++if [ x"${USE_CONTROL_MASTER}" != x ]; then+  DARCS_SSH_FLAGS="--ssh-cm"+  export DARCS_SSH_FLAGS+fi++if [ x"${DARCS_SSH}" = x ]; then+  SSH=ssh+else+  SSH=${DARCS_SSH}+fi++if [ x${REMOTE} = x ]; then+  REMOTE=$(whoami)@localhost.+fi++init_remote_repo() {+    repodir="${1:-R}"++    ${SSH} ${REMOTE} \+        "rm -rf '${REMOTE_DIR}' && mkdir '${REMOTE_DIR}' && \+            cd '${REMOTE_DIR}' && darcs init --repo '$repodir' --$format" \+        || exit 200+}++# test if we can connect via ssh, otherwise skip test+${SSH} -x -o=NumberofPasswordPrompts=0 ${REMOTE} true || exit 200++# vim: syntax=sh:
− tests/nfs-failure.sh 
@@ -1,35 +0,0 @@-#!/bin/sh--set -ev--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-echo first > a-darcs add a-darcs record --pipe --all --name=first <<EOF-Thu Sep 18 22:37:06 MSD 2008-author-EOF--echo first > b-darcs add b-darcs record --pipe --all --name=first <<EOF-Thu Sep 18 22:37:06 MSD 2008-author-EOF--# it seems that somehow the following occasionally fails on an nfs-# filesystem when darcs is compiled with ghc 6.6.--darcs get . ../temp2--# it fails with something like:--# darcs: ./_darcs/patches/20080918223706-f64cd-6b512400a8108808b7ba7057f0eac2adf473b3ae.gz: copyFile: resource busy (file is locked)---cd ..--rm -rf temp1 temp2
+ tests/no-prefs-template.sh view
@@ -0,0 +1,87 @@+#!/usr/bin/env bash+#+# Tests for `--[with|no]-prefs-template` options+#++. lib++has_template() {+  grep -v '^#' "$1" | grep -v '^\s*$'+}+++#########+## Tests for `init` command+#++rm -rf temp1+mkdir temp1+cd temp1+darcs init+test -f _darcs/prefs/boring+has_template _darcs/prefs/boring # by default boring file is filled with template+test -f _darcs/prefs/binaries+has_template _darcs/prefs/binaries # by default binaries file is filled with template+cd ..++rm -rf temp1+mkdir temp1+cd temp1+darcs init --with-prefs-template+test -f _darcs/prefs/boring+has_template _darcs/prefs/boring # boring file is filled with template+test -f _darcs/prefs/binaries+has_template _darcs/prefs/binaries # binaries file is filled with template+cd ..++rm -rf temp1+mkdir temp1+cd temp1+darcs init --no-prefs-template+test -f _darcs/prefs/boring+not has_template _darcs/prefs/boring # boring file is not filled with template+test -f _darcs/prefs/binaries+not has_template _darcs/prefs/binaries # binaries file not is filled with template+cd ..+++#########+## Tests for `clone` command+#++rm -rf temp1+mkdir temp1+cd temp1+darcs init+cd ..++rm -rf temp2+darcs clone temp1 temp2+cd temp2+test -f _darcs/prefs/boring+has_template _darcs/prefs/boring # by default boring file is filled with template+test -f _darcs/prefs/binaries+has_template _darcs/prefs/binaries # by default binaries file is filled with template+cd ..++rm -rf temp2+darcs clone --with-prefs-template temp1 temp2+cd temp2+test -f _darcs/prefs/boring+has_template _darcs/prefs/boring # boring file is filled with template+test -f _darcs/prefs/binaries+has_template _darcs/prefs/binaries # binaries file is filled with template+cd ..++rm -rf temp2+darcs clone --no-prefs-template temp1 temp2+cd temp2+test -f _darcs/prefs/boring+not has_template _darcs/prefs/boring # boring file is not filled with template+test -f _darcs/prefs/binaries+not has_template _darcs/prefs/binaries # binaries file not is filled with template+cd ..++++rm -rf temp1 temp2
tests/nodeps.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  # Test the --no-deps option with Send, Push, Pull, Obliterate and Unrecord. #@@ -13,7 +13,6 @@ cd tmp1 darcs init echo 'record no-ask-deps' >> _darcs/prefs/defaults-echo 'record ignore-times' >> _darcs/prefs/defaults echo 'a' > f darcs add f darcs rec -am 'fa' f
tests/nonewline.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 temp2 mkdir temp1 temp2@@ -7,9 +7,7 @@ darcs init echo -n zig > foo darcs add foo-sleep 1 darcs record -a -m add_foo -A x-#sleep 1 echo -n zag >> foo darcs record --ignore-time -a -m mod_foo -A x cd ../temp2
− tests/obliterate-add.sh 
@@ -1,19 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo foo > foo-darcs add foo--darcs record -a -m 'addfoo'--darcs obliterate -a--not darcs whatsnew--cd ..-rm -rf temp1
− tests/obliterate-formerly-pl.sh 
@@ -1,32 +0,0 @@-#!/usr/bin/env bash-# Some tests for 'darcs obliterate'--. lib--rm -rf temp1--# set up the repository-mkdir temp1-cd temp1-darcs init-cd ..--cd temp1-touch a.txt-darcs add a.txt-darcs record -a -m 'adding a' a.txt-touch b.txt-darcs add b.txt-darcs record -a -m 'adding b' b.txt-# extra confirmation for --all-echo an | darcs obliterate -p add | grep -i "really obliterate"-# --last=1-echo n  | darcs obliterate --last 1 | grep -i adding-# automatically getting dependencies-date >> a.txt-darcs record -a -m 'modifying a' a.txt-echo n | darcs obliterate -p 'adding a' > log-grep -i "modifying a" log-grep -i "No patches selected" log-cd ..-rm -rf temp1
tests/obliterate.sh view
@@ -1,51 +1,135 @@ #!/usr/bin/env bash-set -ev+. ./lib -rm -rf tempA-mkdir tempA-cd tempA-darcs initialize-echo hello world > foo-darcs add foo-darcs record -a -m hellofoo+# Part 1 +rm -rf temp1+darcs initialize temp1+cd temp1++echo hello world > foo+darcs record -l -a -m hellofoo echo goodbye world >> foo darcs record -a -m goodbyefoo- darcs replace world bar foo echo Hi there foo > bar-darcs add bar-darcs record -a -m addbar-+darcs record -l -a -m addbar darcs mv bar baz darcs replace bar baz foo darcs record -a -m bar2baz- echo Do not love the baz, or anything in the baz. >> foo darcs record -a -m nolove- darcs mv baz world darcs replace baz world foo darcs record -a -m baz2world -darcs whatsnew | grep 'No changes'+not darcs whatsnew  grep 'love the world' foo -echo y | darcs obliterate -p baz2world+echo yy | darcs obliterate -p baz2world -darcs whatsnew | grep 'No changes'+not darcs whatsnew  grep 'love the baz' foo -echo y | darcs obliterate -p bar2baz+echo yy | darcs obliterate -p bar2baz  grep 'love the bar' foo -echo y | darcs obliterate -p nolove+echo yy | darcs obliterate -p nolove  grep 'love' foo && exit 1 || true  cd ..-rm -rf tempA+rm -rf temp1 +# Part 2++darcs init temp1+cd temp1++touch a.txt+darcs add a.txt+darcs record -a -m 'adding a' a.txt+touch b.txt+darcs add b.txt+darcs record -a -m 'adding b' b.txt+# extra confirmation for --all+echo an | darcs obliterate -p add | grep -i "really obliterate"+# --last=1+echo nyy | darcs obliterate --last 1 | grep -i adding+# automatically getting dependencies+date >> a.txt+darcs record -a -m 'modifying a' a.txt+echo ny | darcs obliterate -p 'adding a' > log+grep -i "modifying a" log+grep -i "No patches selected" log+cd ..+rm -rf temp1++# Part 3++darcs init temp1+cd temp1++echo foo > foo+darcs record -l -a -m 'addfoo'++darcs obliterate -a++not darcs whatsnew++cd ..+rm -rf temp1++# Part 4++darcs init temp1+cd temp1++cat > f <<EOF+one+two+three+EOF+darcs rec -Ax -alm init+cp f g+cat > f <<EOF+three+one+EOF+darcs rec -Ax -am foo+echo yy | darcs unpull -p foo+cmp f g+cd ..+rm -rf temp1++# Part 4: obliterate with conflicting unrecorded changes++rm -rf R+darcs init R+cd R+echo orig > file+darcs record -lam thepatch+darcs replace -f changed orig file+echo changed > file+darcs whatsnew > ../whatsnew.orig+# make sure we have a change in the pending patch as well+grep replace ../whatsnew.orig++# non-interactive mode: should fail+not darcs obliterate -p thepatch -a 2>ERR+grep "Can't obliterate .* without reverting" ERR+darcs whatsnew > ../whatsnew.failed+diff ../whatsnew.orig ../whatsnew.failed++# interactive mode: user gets prompted+# first y to select patch, second y to confirm selection, n to refuse revert+echo yyn | darcs obliterate -p thepatch+darcs whatsnew > ../whatsnew.refuse+diff ../whatsnew.orig ../whatsnew.refuse+# first y to select patch, second y to confirm selection, third y to accept revert+echo yyy | darcs obliterate -p thepatch+# all unrecorded changes are reverted now+not darcs whatsnew
+ tests/oldfashioned.sh view
@@ -0,0 +1,117 @@+#!/usr/bin/env bash++## Test that darcs refuses to work on old-fashioned repositories+## for certain commands.+##+## Copyright (C) 2011 Guillaume Hoffmann+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.++rm -rf old hashed+unpack_testdata many-files--old-fashioned-inventory+mv many-files--old-fashioned-inventory old++find old | sort > untouched_old++cd old+not darcs add+not darcs amend+not darcs annotate+not darcs apply+not darcs check+not darcs diff+not darcs dist+not darcs mark+not darcs move+not darcs pull+not darcs push+not darcs record+not darcs remove+not darcs repair+not darcs replace+not darcs revert+not darcs rollback+not darcs send+not darcs setpref+not darcs tag+not darcs test+not darcs unrecord+not darcs unrevert+cd ..++find old | sort > touched_old+diff untouched_old touched_old++## test that darcs can clone, pull and send (from, to) a remote+## old-fashioned repository.++darcs clone old hashed++# check that the "trees" coincide+diff old/foo hashed/foo++cd hashed++test -e _darcs/hashed_inventory # issue1110: clone hashed+rm -rf temp1 temp2++echo "yyyd" | darcs unpull++darcs pull -a++touch tralala+darcs add tralala+darcs rec -am "patch to be sent"+darcs send -aO++cd ..++# issue2253 - darcs log FILE should not build patch index in an OF repo+darcs log x --repo=old++# note: with --no-ignore-times darcs add/rec create an index+find old | grep -v '_darcs/index' | sort > touched_old+diff untouched_old touched_old++# issue1584 - darcs optimize --upgrade++cd old+echo x > foo # Unrecorded change+darcs optimize upgrade+darcs check+grep hashed _darcs/format+not grep darcs-2 _darcs/format+darcs whatsnew | grep 'hunk ./foo 1'+cd ..++rm -rf old hashed++## issue1248 - darcs doesn't handle darcs 1 repos with compressed+## inventories++unpack_testdata oldfashioned-compressed+cd oldfashioned-compressed+darcs optimize upgrade+darcs check+cd ..+rm -rf oldfashioned-compressed
− tests/oldfashioned_refusal.sh 
@@ -1,58 +0,0 @@-#!/usr/bin/env bash--## Test that darcs refuses to work on old-fashioned repositories-## for certain commands.-##-## Copyright (C) 2011 Guillaume Hoffmann-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.--rm -rf old-gunzip -c $TESTDATA/many-files--old-fashioned-inventory.tgz | tar xf --mv many-files--old-fashioned-inventory old--cd old-not darcs add-not darcs amend-not darcs annotate-not darcs apply-not darcs check-not darcs diff-not darcs dist-not darcs mark-not darcs move-not darcs pull-not darcs push-not darcs put-not darcs record-not darcs remove-not darcs repair-not darcs replace-not darcs revert-not darcs rollback-not darcs send-not darcs setpref-not darcs tag-not darcs trackdown-not darcs unrecord-not darcs unrevert
− tests/oldfashioned_support.sh 
@@ -1,44 +0,0 @@-#!/usr/bin/env bash--## Test that darcs can get, pull and send (from, to) a remote-## old-fashioned repository.-##-## Copyright (C) 2011 Guillaume Hoffmann-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.--rm -rf old hashed-gunzip -c $TESTDATA/many-files--old-fashioned-inventory.tgz | tar xf --mv many-files--old-fashioned-inventory old--darcs get old hashed-cd hashed--echo "yyyd" | darcs unpull--darcs pull -a--touch tralala-darcs add tralala-darcs rec -am "patch to be sent"-darcs send -aO
tests/optimize.sh view
@@ -1,16 +1,86 @@ #!/usr/bin/env bash-set -ev+. ./lib  # tests for "darcs optimize" -rm -rf temp1-mkdir temp1-cd temp1+## test that darcs optimize reorder works++rm -rf test1 test1a+mkdir test1+cd test1 darcs init touch foo-darcs add foo-darcs record -a -m add_foo-darcs optimize --reorder-patches| grep -i "done optimizing"+darcs record -a -m add_foo -l foo+darcs tag foo_tag+# check tag is initially clean+grep 'Starting with inventory' _darcs/hashed_inventory+touch bar+darcs record -a -m add_bar -l bar+# make the tag unclean+echo y | darcs amend -p foo_tag -a --author me+not grep 'Starting with inventory' _darcs/hashed_inventory+# save repo for next test+darcs clone . ../test1a+# the actual test+darcs optimize reorder | grep -i "done"+# check it is again clean+grep 'Starting with inventory' _darcs/hashed_inventory cd .. -rm -rf temp1+## optimize reorder --deep++cd test1a+# we have an unclean tag foo_tag; add another tag+darcs tag bar_tag+darcs optimize reorder | grep -i "done"+# this makes bar_tag clean:+# neither foo_tag nor add_foo are in the head inventory+not grep add_foo _darcs/hashed_inventory+not grep foo_tag _darcs/hashed_inventory+# but foo_tag remains dirty+# (this greps for a lone inventory hash)+grep -E '^[0-9]+-[0-9a-f]+$' _darcs/hashed_inventory > ihash+zgrep add_foo _darcs/inventories/$(cat ihash)+# now do the deep reorder+darcs optimize reorder --deep+# add_foo is not in the parent inventory+grep -E '^[0-9]+-[0-9a-f]+$' _darcs/hashed_inventory > ihash+not zgrep add_foo _darcs/inventories/$(cat ihash)+# but instead in the grandparent+zgrep -E '^[0-9]+-[0-9a-f]+$' _darcs/inventories/$(cat ihash) > ihash2+zgrep add_foo _darcs/inventories/$(cat ihash2)+cd ..++## issue2388 - optimize fails if no patches have been recorded++rm -rf test2+darcs init test2+cd test2+darcs optimize clean+cd ..++## optimize compress/uncompress++find_hashed_files() {+  find _darcs | grep -E '([0-9]{10}-)?[0-9a-f]{64}'+}++rm -rf test3+darcs init test3+cd test3+echo one > file+darcs record -lam one+darcs tag mytag # so we get a hashed inventory file+# check all hashed files are compressed+find_hashed_files | xargs gunzip -t+# uncompress+darcs optimize uncompress+# check all hashed files are uncompressed+find_hashed_files | while read f; do+  not gunzip -t $f+done+# compress+darcs optimize compress+# check all hashed files are compressed+find_hashed_files | xargs gunzip -t+cd ..
tests/optimize_relink.sh view
@@ -3,7 +3,7 @@  # For issue600, testing optimize --relink  -set -ev+. ./lib  ## We don't support hard links on Windows. @@ -47,11 +47,11 @@  ## Now try relinking using darcs. rm -rf z-darcs optimize --verbose --relink --repodir x --sibling y+darcs optimize relink --verbose --repodir x --sibling y rm -rf x/_darcs/patches/pend* y/_darcs/patches/pend* if compare x/_darcs/patches y/_darcs/patches-then echo darcs --relink is working, hard links were done.-else echo darcs --relink is not working, it did not make any hard links.+then echo darcs optimize relink is working, hard links were done.+else echo darcs optimize relink is not working, it did not make any hard links.      exit 2 fi
+ tests/order_of_resolutions.sh view
@@ -0,0 +1,76 @@+#!/usr/bin/env bash++. lib++rm -rf B R S S1 S2 C1 C2++darcs init B+cd B+echo '++n S' > ./a+darcs record -l ./a -am base+cd ..++darcs clone B R+cd R+darcs replace K u ./a+darcs record -am p1+echo 'u+Q L+P n++n S' > ./a+darcs record -am p2+cd ..++darcs clone B S1+cd S1+echo 'i d+n S' > ./a+darcs record -am p3+cd ..++darcs clone B S2+cd S2+echo '+C+h Z' > ./a+darcs record -am p4+cd ..++darcs clone S1 S+cd S+darcs pull --allow -a ../S2+echo '++ll+G z+h Z' >./a+darcs record -am p5+cd ..++darcs clone B C1+cd C1+darcs pull --allow -a -p p2 ../R+darcs pull --allow -a -p p1 ../R+darcs pull --allow -a -p p3 ../S+darcs pull --allow -a -p p4 ../S+darcs pull --allow -a -p p5 ../S+darcs mark+cd ..++darcs clone B C2+cd C2+darcs pull --allow -a -p p1 ../R+darcs pull --allow -a -p p3 ../S+darcs pull --allow -a -p p2 ../R+darcs pull --allow -a -p p4 ../S+darcs pull --allow -a -p p5 ../S+darcs mark+cd ..++darcs whatsnew --repo C1 > markup-C1+darcs whatsnew --repo C2 > markup-C2++diff markup-C1 markup-C2
tests/output.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 temp2 temp3 mkdir temp2@@ -13,24 +13,24 @@ touch foo bar darcs add foo bar darcs record -a -m foobar -A author-darcs send -a --dont-edit-description -o ../temp3 ../temp2+darcs send --no-minimize -a --dont-edit-description -o ../temp3 ../temp2 test -f ../temp3 -darcs send -a --dont-edit-description -o ../temp2/patchfile ../temp2+darcs send --no-minimize -a --dont-edit-description -o ../temp2/patchfile ../temp2 test -f ../temp2/patchfile  mkdir subdir-darcs send -a --dont-edit-description -o subdir/../../temp2/patchfile1 ../temp2+darcs send --no-minimize -a --dont-edit-description -o subdir/../../temp2/patchfile1 ../temp2 test -f ../temp2/patchfile1  cp ../temp3 correct  cd subdir-darcs send -a --dont-edit-description -o ../patchfile ../../temp2+darcs send --no-minimize -a --dont-edit-description -o ../patchfile ../../temp2 diff -u ../patchfile ../correct  rm ../patchfile-darcs send -a --set-default --dont-edit-description -o - ../../temp2 > ../patchfile+darcs send --no-minimize -a --set-default --dont-edit-description -o - ../../temp2 > ../patchfile grep -v Creating ../patchfile | diff -u ../correct -  darcs apply --repodir=../../temp2 --dry-run ../patchfile > out
tests/overriding-defaults.sh view
@@ -9,21 +9,22 @@ darcs setpref test false darcs record --no-test -a -m 'add failing test' -# should pass with --no-test-darcs check --no-test- # should fail when test is run-not darcs check --test+not darcs test  # should pass with --no-test in defaults-echo check --no-test > _darcs/prefs/defaults-darcs check-not darcs check --test+echo record --no-test > _darcs/prefs/defaults+touch a+darcs record -alm a+touch b+not darcs record --test -alm b  # should fail with --test in defaults-echo check --test > _darcs/prefs/defaults-not darcs check-darcs check --no-test+echo record --test > _darcs/prefs/defaults+touch c+not darcs record -alm c+touch d+darcs record --no-test -alm d  # check global defaults cp ~/.darcs/defaults defaults.backup@@ -31,28 +32,36 @@ rm _darcs/prefs/defaults  # --no-test works in global defaults-echo check --no-test > ~/.darcs/defaults-darcs check-not darcs check --test+echo record --no-test > ~/.darcs/defaults+touch e+darcs record -alm e+touch f+not darcs record --test -alm f  # --test works in global defaults-echo check --test > ~/.darcs/defaults-not darcs check-darcs check --no-test+echo record --test > ~/.darcs/defaults+touch g+not darcs record -alm g+touch h+darcs record --no-test -alm h  # Verify that per-repository defaults override global defaults  # --no-test in repository defaults overrides global --test-echo check --test > ~/.darcs/defaults-echo check --no-test > _darcs/prefs/defaults-darcs check-not darcs check --test+echo record --test > ~/.darcs/defaults+echo record --no-test > _darcs/prefs/defaults+touch i+darcs record -alm i+touch j+not darcs record --test -alm j  # --test in repository defaults overrides global --no-test-echo check --no-test > ~/.darcs/defaults-echo check --test > _darcs/prefs/defaults-not darcs check-darcs check --no-test+echo record --no-test > ~/.darcs/defaults+echo record --test > _darcs/prefs/defaults+touch k+not darcs record -alm k+touch l+darcs record --no-test -alm l  trap - EXIT cp defaults.backup ~/.darcs/defaults
+ tests/patch-index-annotate.sh view
@@ -0,0 +1,46 @@+. lib+rm -rf R+darcs init --repo R+cd R++echo 'revision 1' > f+darcs record -lam 'p1'++echo 'revision 2' > f+darcs record -am 'p2'++echo 'revision 3' > f+darcs record -am 'p3'+++darcs annotate f > out   # creates patch index on annotate+grep p3 out+not grep p2 out+not grep p1 out++darcs annotate f --patch 'p2' > out+grep p2 out+not grep p3 out+not grep p1 out++darcs annotate f --patch 'p1' > out+grep p1 out+not grep p2 out+not grep p3 out++darcs optimize disable-patch-index++darcs annotate f > out+grep p3 out+not grep p2 out+not grep p1 out++darcs annotate f --patch 'p2' > out+grep p2 out+not grep p3 out+not grep p1 out++darcs annotate f --patch 'p1' > out+grep p1 out+not grep p2 out+not grep p3 out
+ tests/patch-index-creation.sh view
@@ -0,0 +1,94 @@+#!/usr/bin/env bash+## Test for patch index automation - Patch index should+## be recreated when running:+## * annotate on a file or directory+## * non-interative log on a file+## * init, clone and convert with flag --with-patch-index+##+## It should NOT be created when running:+## * annotate or log with --no-patch-index+## * init, clone and convert, without flags+##+## Copyright (C) 2012  BSRK Aditya, Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+darcs init --repo R+cd R+darcs show patch-index | grep 'Patch Index is not yet created.' # init+cd ..++rm -rf R+darcs init --repo R --with-patch-index+cd R+darcs show patch-index | grep 'Patch Index is in sync with repo.' # init --patch-index+cd ..++rm -rf S+darcs clone R S+cd S+darcs show patch-index | grep 'Patch Index is not yet created.' # clone+cd ..++rm -rf S+darcs clone R S --with-patch-index+cd S+darcs show patch-index | grep 'Patch Index is in sync with repo.' # clone --patch-index+cd ..++rm -rf repo repo2+unpack_testdata simple-v1+echo 'yes' | darcs convert darcs-2 repo repo2 +cd repo2+darcs show patch-index | grep 'Patch Index is not yet created.' # convert+cd ..++rm -rf repo repo2+unpack_testdata simple-v1+echo 'yes' | darcs convert darcs-2 repo repo2 --with-patch-index+cd repo2+darcs show patch-index | grep 'Patch Index is in sync with repo.' # convert --patch-index++cd ../R++mkdir d+echo 'New line.' >> d/f+darcs record -lam "Change d/f"+rm -rf _darcs/patch_index+darcs annotate d/f+darcs show patch-index | grep 'Patch Index is in sync with repo.' # annotate++rm -rf _darcs/patch_index+darcs annotate d/f --no-patch-index+darcs show patch-index | grep 'Patch Index is not yet created.' # annotate --no-patch-index++rm -rf _darcs/patch_index+darcs log -a d/f+darcs show patch-index | grep 'Patch Index is in sync with repo.' # log -a file++rm -rf _darcs/patch_index+darcs log -a d/f --no-patch-index+darcs show patch-index | grep 'Patch Index is not yet created.' # log -a file --no-patch-index++cd ..
+ tests/patch-index-enabled-and-disabled.sh view
@@ -0,0 +1,62 @@+#!/usr/bin/env bash+## Test for patch index self-healing after used non-patch-index-enabled darcs+## Copyright (C) 2012  Mark Stosberg+##+## 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+## SOFTWARE.++. lib+rm -rf R+darcs init --repo R --with-patch-index+cd R++#Record some example content+echo 'Example content.' > f+darcs record -lam 'create file.'++# Simulate use by an older darcs binary, by backup in the index and disabling patch index.+mv _darcs/patch_index _darcs/patch_index.bak+touch _darcs/no_patch_index++# Now record Some new changes.+echo 'Example content updated.' > f+echo 'Example content updated.' > f2+darcs record -lam 'Update by older darcs.'++# Now return the repo to the state that the patch-index-enabled darcs would see it.+rm _darcs/no_patch_index+mv _darcs/patch_index.bak _darcs/patch_index++# Now, perform an action with the this darcs. ( and make sure we see the changes  from the older darcs. ) +darcs changes f | grep 'older darcs'++# Now, check: Did the patch-index self heal?+darcs show patch-index | grep 'Patch Index is in sync with repo.'++# Another check, just to be sure.+echo 'Example content updated again.' > f+darcs record -lam 'Another update by newer darcs'++# Still good?+darcs show patch-index | grep 'Patch Index is in sync with repo.'++# Clean up.+cd ..+rm -rf R
+ tests/patch-index-log.sh view
@@ -0,0 +1,77 @@+. lib                         +rm -rf R+darcs init --repo R+cd R++[[ $(darcs log FOO --count | tail -n 1) -eq 0 ]]++touch f0+darcs record -lam 'p0'++mkdir d1+darcs record -lam 'p1'++touch d1/f1+darcs record -lam 'p2'++darcs move f0 d1/f0+darcs record -am 'p3'++touch d1/f2+darcs record -lam 'p4'++rm d1/f1+darcs record -am 'p5'++darcs move d1/f0 f0+darcs record -am 'p6'++darcs move d1 d2+darcs record -am 'p7'++mkdir d1+darcs record -lam 'p8'++touch d1/f3+darcs record -lam 'p9'++echo "f0" > f0+darcs record -am 'p10'++# log on directories gives all patches+# that touched any sub path (including itself)++# Note that the path of the directory varies+# as you move backward in history.++# The sub path comparision is with the path+# the directory had when the patch which is is being+# tested has been just applied.++# d1 <-> p8-p9+[[ $(darcs log d1 --count | tail -n 1) -eq 2 ]]+for i in 8 9+do+   darcs log d1 | grep p$i+done+++# d2 <-> p1-p7+[[ $(darcs log d2 --count | tail -n 1) -eq 7 ]]+for i in {1..7}+do+   darcs log d2 | grep p$i+done++darcs optimize disable-patch-index+[[ $(darcs log FOO --count | tail -n 1) -eq 0 ]]+[[ $(darcs log d1 --count | tail -n 1) -eq 2 ]]+for i in 8 9+do+   darcs log d1 | grep p$i+done+[[ $(darcs log d2 --count | tail -n 1) -eq 7 ]]+for i in {1..7}+do+   darcs log d2 | grep p$i+done
+ tests/patch-index-released.sh view
@@ -0,0 +1,40 @@+#!/usr/bin/env bash++# Check that the latest darcs can still use the patch index+# produced by released versions.++. lib++# A tarball of a repo with a v2 patch index, which at the+# time of writing was the version in use in the last released+# version of darcs.++unpack_testdata patch-index-v2++cd pi++# If darcs can't read the index but thinks it can, this will crash.+# If there's a new patch index format and the format version has+# been properly bumped, then darcs will simply delete and replace it+# and this command will work.+darcs annotate file1.txt++# It would be nice to check that the released version of darcs also+# correctly handles any changes we make, but it's much harder to write+# a test that relies on the released version.++# When a change is made to the patch index format, the+# format version should be bumped and a new sample repo should be+# added to this test, to ensure that the new format is properly+# covered by the tests as soon as it is released.++# The "released" version above should be kept to maintain the+# guard against regressions.++# If further changes to the format are made before the next release,+# it should be ok to keep the same (new) version, though it might+# mean developers/people using the bleeding edge see some breakage.++# Once the release happens, it should be ok to delete the test for+# the old format, on the assumption we are unlikely to make a gross+# mistake like decrementing the format version.
+ tests/patch-index-rename.sh view
@@ -0,0 +1,38 @@+#!/usr/bin/env bash+## Test that the patch index passes its self-test on a repository+## with a rename.+##+## Copyright (C) 2014 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++mkdir R+cd R+darcs init --with-patch-index+echo initial contents > file1+darcs rec -lam "initial"+darcs mv file1 file2+darcs rec -am "move"++darcs show patch-index --verbose+
+ tests/patch-index-spans.sh view
@@ -0,0 +1,69 @@+#!/usr/bin/env bash+## Test for patch index integrity of spans - <SYNOPSIS: Test correctness+## of fid_map, fp_map>+##+## Copyright (C) YEAR  AUTHOR+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+darcs init --repo R --with-patch-index # Create our test repos.++cd R+mkdir d e                       # Change the working tree.+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'+darcs show patch-index --verbose > pi++grep -F "./d -> 1#./d" pi+grep -F "./d/f -> 1#./d/f" pi+grep -F "./e -> 1#./e" pi+grep -F "1#./d -> ./d" pi+grep -F "1#./d/f -> ./d/f" pi+grep -F "1#./e -> ./e" pi++darcs mv d/f e/+darcs record -am 'Move d/f to e/f.'+darcs show patch-index --verbose > pi++grep -F "./d -> 1#./d" pi+grep -F "./d/f -> 1#./d/f" pi+grep -F "./e -> 1#./e" pi+grep -F "./e/f -> 1#./d/f" pi+grep -F "1#./d -> ./d" pi+grep -F "1#./d/f -> ./e/f" pi+grep -F "1#./d/f -> ./d/f" pi+grep -F "1#./e -> ./e" pi++echo 'File 2' > d/f+darcs record -lam 'Add d/f'+darcs show patch-index --verbose > pi++grep -F "./d -> 1#./d" pi+grep -F "./d/f -> 2#./d/f" pi+grep -F "./d/f -> 1#./d/f" pi+grep -F "./e -> 1#./e" pi+grep -F "./e/f -> 1#./d/f" pi+grep -F "1#./d -> ./d" pi+grep -F "1#./d/f -> ./e/f" pi+grep -F "1#./d/f -> ./d/f" pi+grep -F "2#./d/f -> ./d/f" pi+grep -F "1#./e -> ./e" pi
+ tests/patch-index-sync.sh view
@@ -0,0 +1,70 @@+#!/usr/bin/env bash+## Test for patch index automation - <SYNOPSIS: Patch index should+## always be in sync with repo after execution of any command.>+##+## Copyright (C) 2012  BSRK Aditya+##+## 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+## SOFTWARE.++. lib+rm -rf R S+darcs init --repo R --with-patch-index+darcs init --repo S --with-patch-index+cd R+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test init++mkdir d e+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test record+echo 'New line.' >> d/f+echo "y" | darcs amend-record -p 'Add d/f and e.' -a+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test amend-record++darcs push -a ../S+cd ../S+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test push++echo 'Changed Content' > d/f+darcs record -am 'Change d/f'+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test record 2+darcs send -ao test.dpatch  ../R++cd ..+darcs clone R T --with-patch-index+cd T+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test clone++darcs pull -a ../S+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test pull+darcs obliterate -p 'Add d/f and e.' -a+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test obliterate++cd ../R+darcs apply -a ../S/test.dpatch+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test apply+darcs unrecord -a -p 'Change d/f'+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test unrecord+darcs tag -m 'tag R'+darcs show patch-index | grep 'Patch Index is in sync with repo.' # test tag++cd ..+rm -rf R S T
tests/pending.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp temp_0 mkdir temp
− tests/pending_has_conflicts.sh 
@@ -1,55 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init--date > date.t-date > date_moved.t--write_buggy_pending () {-cat > _darcs/patches/pending <<EOF-{-addfile ./date.t-addfile ./date_moved.t-move ./date.t ./date_moved.t-}-EOF-}-write_buggy_pending--echo now watch the fireworks as all sorts of things fail-not darcs whatsnew 2>&1 | tee out-grep 'pending has conflicts' out--echo pending should now be fixed but there are no changes-not darcs whatsnew--write_buggy_pending--darcs revert -a 2>&1 | tee out-grep 'pending has conflicts' out--echo pending should now be emptied-darcs revert -a--write_buggy_pending--not darcs record -a -m foo 2>&1 | tee out-grep 'pending has conflicts' out--darcs changes -v--darcs repair 2>&1 | tee out-grep 'The repository is already consistent' out--write_buggy_pending--darcs repair 2>&1 | tee out-grep 'The repository is already consistent' out--cd ..-rm -rf temp1
tests/perms.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  uname | grep "MINGW" > /dev/null && exit 0 @@ -10,7 +10,6 @@ echo record author me > _darcs/prefs/defaults echo ALL all >> _darcs/prefs/defaults echo ALL verbose >> _darcs/prefs/defaults-echo ALL ignore-times >> _darcs/prefs/defaults touch foo darcs add foo darcs record -m add_foo
tests/posthook.sh view
@@ -1,8 +1,6 @@ #!/usr/bin/env bash -set -ev--. lib+. ./lib  rm -rf temp1 mkdir temp1@@ -25,27 +23,14 @@ cd .. rm -rf temp1 -# POSIX-only section-# -----------------------------------------------------------------------# Things below this section do not appear to work on Windows.-# Pending further investigation at http://bugs.darcs.net/issue1813--if echo $OS | grep -i windows; then-  exit 0-fi- # Check that DARCS_PATCHES_XML works rm -rf R S                      # another script may have left a mess darcs init      --repo R        # Create our test repos. darcs init      --repo S        # Create our test repos.  cd R-echo 'echo $DARCS_PATCHES_XML' > hook-darcs record -lam 'hook'-chmod u+x hook cat > _darcs/prefs/defaults << END-apply run-posthook-apply posthook ./hook+apply posthook printenv DARCS_PATCHES_XML END cd ..
tests/prefs.sh view
@@ -1,11 +1,10 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 temp2 mkdir temp1 cd temp1 darcs initialize-echo ALL ignore-times >> _darcs/prefs/defaults cp _darcs/prefs/boring .boring darcs add .boring darcs setpref boringfile .boring
tests/prefs_binary.sh view
@@ -12,11 +12,11 @@ darcs add d/t.t darcs record -am "initial record" echo 'some change' >> d/t.t-echo n | darcs record --interactive > log+echo ny | darcs record --interactive > log # pre-test: plain text files are not binary not grep binary log echo 'd/t' >>  _darcs/prefs/binaries-echo n | darcs record --interactive > log+echo ny | darcs record --interactive > log grep binary log cd ..
tests/prehook.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib  rm -rf temp1 mkdir temp1
tests/printer.sh view
@@ -4,7 +4,6 @@  . lib -rm -rf temp1 mkdir temp1 cd temp1 darcs init@@ -15,7 +14,7 @@ env # clear all output formating environment variables for e in DARCS_DONT_ESCAPE_ISPRINT DARCS_USE_ISPRINT\-         DARCS_DONT_ESCAPE_8BIT\+         DARCS_ESCAPE_8BIT\          DARCS_DONT_ESCAPE_EXTRA DARCS_ESCAPE_EXTRA\          DARCS_DONT_ESCAPE_TRAILING_SPACES\          DARCS_DONT_COLOR DARCS_ALWAYS_COLOR DARCS_ALTERNATIVE_COLOR\@@ -30,7 +29,7 @@ test_line () {     rm -f a     echo $1 > a-    darcs whatsnew | fgrep $2+    darcs whatsnew | grep -F $2 }  @@ -53,8 +52,12 @@ # skip ^@ and ^Z since they make darcs treat the file as binary # don't put any space control chars at end of line # ascii control chars are escaped with ^-test_line $(printf '\x01\x02\x03\x04\x05\x06\x07\x08\x0B\x0C\x0D\x0E')\-          '[_^A_][_^B_][_^C_][_^D_][_^E_][_^F_][_^G_][_^H_][_^K_][_^L_][_^M_][_^N_]'+test_line $(printf '\x01\x02\x03\x04\x05\x06\x07\x08\x0B\x0C\x0E')\+          '[_^A_][_^B_][_^C_][_^D_][_^E_][_^F_][_^G_][_^H_][_^K_][_^L_][_^N_]'+# this doesn't seem to work on windows, no idea why:+if ! os_is_windows; then+  test_line $(printf '\x0D') '[_^M_]'+fi test_line $(printf '\x0F\x10\x11\x12\x13\x14\x15\x16\x17\x18\x19')\           '[_^O_][_^P_][_^Q_][_^R_][_^S_][_^T_][_^U_][_^V_][_^W_][_^X_][_^Y_]' test_line $(printf '\x1B') '[_^[_]'@@ -62,6 +65,11 @@ test_line $(printf '\x1D') '[_^]_]' test_line $(printf '\x1E') '[_^^_]' test_line $(printf '\x1F') '[_^__]'++# everything up to here is escaped by default;+# for the rest we must explicitly set it:+export DARCS_ESCAPE_8BIT=1+ test_line $(printf '\x7F') '[_^?_]' # other chars are escaped with <U+XXXX> test_line $(printf '\x80\x81\x82\x83\x84\x85\x86\x87\x88\x89\x8A\x8B\x8C\x8D\x8E\x8F')\@@ -80,4 +88,3 @@           '[_<U+00E0>_][_<U+00E1>_][_<U+00E2>_][_<U+00E3>_][_<U+00E4>_][_<U+00E5>_][_<U+00E6>_][_<U+00E7>_][_<U+00E8>_][_<U+00E9>_][_<U+00EA>_][_<U+00EB>_][_<U+00EC>_][_<U+00ED>_][_<U+00EE>_][_<U+00EF>_]' test_line $(printf '\xF0\xF1\xF2\xF3\xF4\xF5\xF6\xF7\xF8\xF9\xFA\xFB\xFC\xFD\xFE\xFF')\           '[_<U+00F0>_][_<U+00F1>_][_<U+00F2>_][_<U+00F3>_][_<U+00F4>_][_<U+00F5>_][_<U+00F6>_][_<U+00F7>_][_<U+00F8>_][_<U+00F9>_][_<U+00FA>_][_<U+00FB>_][_<U+00FC>_][_<U+00FD>_][_<U+00FE>_][_<U+00FF>_]'-rm -rf temp1
tests/pull-dont-prompt-deps.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib  # Check that the right patches get pulled using --dont-prompt-for-dependencies @@ -22,12 +22,12 @@ echo bar2 > b darcs record -Ax -alm bar2 cd ../temp2-echo y | darcs pull ../temp1 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto+echo yy | darcs pull ../temp1 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto #on the previous line, we get asked about foo2, and we take it grep foo2 toto | wc -l | grep 2 #we don't get asked about foo1, but we take it anyway, so  grep foo1 toto | wc -l | grep 1 #and we don't send bar-grep bar toto | wc -l | grep 0+not grep bar toto cd .. rm -rf temp1 temp2
+ tests/pull-reorder.sh view
@@ -0,0 +1,66 @@+#!/usr/bin/env bash++## Test that pull --reorder moves to the top the uncommon set of patches between+## the current repository and remote repository which we are pulling.++. lib                  # Load some portability helpers.++check_patches_order () {+    darcs changes | tr -d "\n" | grep $1.*$2.*$3+}++test_init () {+    rm -rf R1 R2+    +    darcs init "R1"+    cd R1++    touch "r1_0"+    darcs add "r1_0"+    darcs record -a --author=me -m "Adding r1_0" "r1_0"++    cd ..++    darcs clone "R1" "R2"++    cd R2++    touch "r2_0"+    darcs add "r2_0"+    darcs record -a --author=me -m "Adding r2_0" "r2_0"++    cd ..++    cd R1++    touch "r1_1"+    darcs add "r1_1"+    darcs record -a --author=me -m "Adding r1_1" "r1_1"+    +    cd ..+}+++test_init++cd R1++darcs pull -a -p "r2_0" "../R2"+# Without reorder the expected order is r2_0, r1_1, r1_0 .+check_patches_order r2_0 r1_1 r1_0++# Test that pull --reorder reorders even if there is nothing to pull.+darcs pull -a --reorder -p "r2_0" "../R2"+check_patches_order r1_1 r2_0 r1_0++cd ..++test_init++cd R1++darcs pull -a --reorder -p "r2_0" "../R2"+# With reorder the expected order is r1_1, r2_0, r1_0 .+check_patches_order r1_1 r2_0 r1_0++cd ..
− tests/pull-union.sh 
@@ -1,42 +0,0 @@-#!/usr/bin/env bash--. lib--# This test script is in the public domain.---rm -rf temp1 temp2 temp3--mkdir temp1-cd temp1-darcs initialize-echo A > A-darcs add A-darcs record -a -m A-echo B > B-darcs add B-darcs record -a -m B--cd ..-darcs get temp1 temp2--cd temp2-darcs obliterate --last 1 -a-echo C > C-darcs add C-darcs record -a -m C-cd ..--mkdir temp3-cd temp3-darcs init-darcs pull -a -v ../temp1 ../temp2--darcs changes > out-cat out-grep A out-grep B out-grep C out-cd ..--rm -rf temp1 temp2 temp3
tests/pull.sh view
@@ -4,23 +4,21 @@  rm -rf temp1 temp2 -mkdir temp1+darcs init temp1 cd temp1-darcs init  cd ..-mkdir temp2+darcs init temp2 cd temp2-darcs init  mkdir one cd one 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 should work relative to the current directory+darcs pull -a ../../../temp1 | grep -i 'No remote patches to pull in' -echo -- darcs pull should pull into repo specified with --repo+# darcs pull should pull into repo specified with --repo cd ../..  # now in temp2 darcs add one; darcs record --name uno --all@@ -33,16 +31,12 @@ darcs record --repodir ./temp2 -a -m foo  # set up client repo for failure-if echo $OS | grep -i windows; then-    echo this test does not work on windows because it-    echo is not possible to chmod -r-elif whoami | grep root; then-    echo root never gets permission denied-else+if ! os_is_windows; then     chmod a-rwx ./temp1/one # remove all permissions-    not darcs pull --repodir ./temp1 -a 2> err+    # this fails only with --ignore-times because otherwise the index+    # will be used+    not darcs pull --repodir ./temp1 -a --ignore-times 2> err     chmod u+rwx temp1/one # restore permission-    cat err     grep 'permission denied' err     rm -rf temp1/one fi@@ -55,11 +49,9 @@ #return special message when you try to pull from yourself DIR="`pwd`" not darcs pull --debug -a "$DIR" 2> out-cat out grep 'Can.t pull from current repository' out  not darcs pull --debug -a . 2> out-cat out grep 'Can.t pull from current repository' out  # and do not update the default repo to be the current di@@ -73,7 +65,6 @@ grep 'Can.t pull from current repository' err  not darcs pull --debug ../* 2> out-cat out not grep 'Can.t pull from current repository' out cd .. # now outside of any repo @@ -84,14 +75,14 @@ darcs record -lam BB echo c > foo darcs record -lam CC-darcs rollback -p CC -a -m unC+darcs rollback -p CC -a+darcs record -am unC cd .. rm -rf temp2 darcs get --to-patch B temp1 temp2 cd temp2-sleep 1 # So that rollback won't have same timestamp as get.-darcs rollback -p BB -a -m unB-darcs revert -a+darcs rollback -p BB -a+darcs record -am unB darcs pull -a ../temp1 2> err2 not grep 'Error applying patch' err2 cd ..@@ -120,7 +111,6 @@ cd ../temp2 mkdir newdir darcs pull -a --set-default ../temp1 &> out2-cat out grep Backing out2 grep 'Finished pulling' out2 grep newdir out2@@ -129,26 +119,226 @@ rm -rf temp1 temp2  -# A test for issue662, which triggered:+# issue662, which triggered: #  darcs failed:  Error applying hunk to file ./t.t-#  Error applying patch to the working directory.+#  Error applying patch to the working tree. -rm -rf tmp;-darcs init --hashed --repodir=tmp-touch tmp/t.t-cd tmp-darcs add t.t-echo 'content'>t.t-darcs record -am 'initial add' --ignore-echo 'content: remote change'>t.t+darcs init temp1+cd temp1++touch t.t+echo 'content'> t.t+darcs record -lam 'initial add'+echo 'content: remote change'> t.t darcs record -am 'remote change' --ignore-darcs put tmp2-cd tmp2-darcs obliterate --last 1 --all;+cd ..+darcs clone temp1 temp2+cd temp2+darcs obliterate --last 1 --all echo 'content: local change'> t.t-darcs pull -a ../+# this is now recognized as a conflict with working:+echo y | darcs pull -a ../temp1 darcs w -s darcs revert -a+cd ..+rm -rf temp1 temp2 -cd ../..-rm -rf tmp+# pull with conflicts++darcs initialize temp1+cd temp1+echo foo > bar+darcs record -lam addbar++cd ..+darcs clone temp1 temp2+cd temp1+date > bar+darcs record -a -m datebar+cd ../temp2+echo aack >> bar+darcs record -a -m aackbar+darcs pull -a+darcs check++cd ..+rm -rf temp1 temp2++# pull --union++rm -rf temp1 temp2 temp3++darcs init temp1+cd temp1+echo A > A+darcs record -lam A+echo B > B+darcs record -lam B++cd ..+darcs clone temp1 temp2++cd temp2+darcs obliterate --last 1 -a+echo C > C+darcs record -lam C+cd ..++darcs init temp3+cd temp3+darcs pull -a ../temp1 ../temp2++darcs log > out+grep A out+grep B out+grep C out++cd ..+rm -rf temp1 temp2 temp3++# pull --intersection++darcs init temp1+cd temp1+echo A > A+darcs record -lam Aismyname+echo B > B+darcs record -lam Bismyname++cd ..+darcs clone temp1 temp2+cd temp2+darcs obliterate --last 1 -a+echo C > C+darcs record -lam Cismyname++cd ..+darcs init temp3+cd temp3+darcs pull -a --intersection ../temp1 ../temp2+darcs log > out+grep Aismyname out+not grep Bismyname out+not grep Cismyname out++cd ..+rm -rf temp1 temp2 temp3+++# pull --skip-conflicts+rm -rf R S+darcs init R+cd R+echo 'foo' > foo+echo 'bar' > bar+darcs rec -lam 'Add foo and bar'+cd ..++darcs clone R S++cd R+echo 'foo2' > foo+darcs rec -lam 'Change foo (2)'+echo 'bar2' > bar+darcs rec -lam 'Change bar (2)'+cd ..++cd S+echo 'foo3' > foo+darcs rec -lam 'Change foo (3)'+darcs pull --skip-conflicts -a ../R+test `darcs log --count` -eq 3+cd ..++cd S+darcs pull -a ../R+test `darcs log --count` -eq 4+cd ..+rm -rf R S++# bad pending after pull++rm -fr temp1 temp2++darcs init temp1+cd temp1+echo abc > A+echo def > B1+darcs record -lam patch1+darcs mv B1 B2+darcs record -am patch2+cd ..++darcs init temp2+cd temp2+darcs pull -a ../temp1+not darcs whatsnew+cd ..++rm -fr temp1 temp2++# issue494: note that in this test, we deliberately select filenames+# with a backwards sorting order+darcs init temp1+cd temp1+echo abc > b+darcs record -lam patch1+darcs mv b a+echo def > a+darcs record -am patch2+cd ..++darcs init temp2+cd temp2+darcs pull --all ../temp1+not darcs whatsnew+cd ..++rm -fr temp1 temp2++# pull binary++rm -rf temp1 temp2++darcs init temp1+cd temp1+printf "%01048576d" 0 > foo+darcs record -l -a -m xx+rm foo+darcs record -a -m yy+cd ..++darcs init temp2+cd temp2+echo yny | darcs pull --set-default ../temp1+rm foo+# for darcs-1 and darcs-3 this pull conflicts with unrecorded changes+# (which is correct, whereas darcs-2 is buggy)+if test "$format" != "darcs-2"; then+  echo y | darcs pull -a+else+  darcs pull -a+fi+cd ..++rm -rf temp1 temp2++# pull --matches+darcs init temp1+cd temp1+echo first > a+darcs record -lam 'first'+firsthash=`darcs log --xml | grep 'hash=' | sed -e "s/.*hash='//" -e "s/'>//"`+echo second > b+darcs record -lam 'second'+cd ..++darcs init temp2+darcs pull --repodir temp2 -a --match "hash $firsthash" temp1+test $(darcs log --count --repodir temp2) -eq 1++darcs init temp3+darcs pull --repodir temp3 -a --hash $firsthash temp1+test $(darcs log --count --repodir temp3) -eq 1++rm -rf temp1 temp2 temp3
− tests/pull_binary.sh 
@@ -1,50 +0,0 @@-#!/usr/bin/env bash--# This test script, originally written by David Roundy and Ian Lynagh is in-# the public domain.-#-# This file is included as part of the Darcs test distribution,-# which is licensed to you under the following terms:-#-## 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-## SOFTWARE.--set -ev--rm -rf temp1 temp2--mkdir temp1-cd temp1-darcs init-printf "%01048576d" 0 > foo-darcs record -l -a -A author -m xx-rm foo-darcs record -a -A author -m yy-cd ..--mkdir temp2-cd temp2-darcs init-echo yn | darcs pull --set-default ../temp1-rm foo-darcs pull -a-cd ..--rm -rf temp1 temp2
− tests/pull_compl.sh 
@@ -1,145 +0,0 @@-#!/usr/bin/env bash--## Public domain 2007  Kevin Quick-##-## This file is included as part of the Darcs test distribution,-## which is licensed to you under the following terms:-##-## 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-## SOFTWARE.---set -ev--rm -rf temp1 temp2 temp3 temp4 temp5--mkdir temp1-cd temp1-cat > foo <<EOF-line1-line2-line3-line4-line5-line6-line7-EOF-darcs initialize-darcs add foo-darcs record -a -m addfoo--cd ..-darcs get temp1 temp4--chgrec () {-    set -ev-    sed -e "$1" foo > foo.tmp-    mv foo.tmp foo-    darcs record -a --ignore-times -m "$2"-}--cd temp1-chgrec 's/line2/line2\nline2.1\nline2.2/' inssub2-chgrec 's/line4/Line 4/' Line4--darcs changes | grep ' \*'-echo done with changes on temp1 > /dev/null--cd ..-darcs get temp1 temp2-darcs get temp1 temp3-cd temp1--chgrec 's/line1/line0\nline1/' line0-chgrec 's/Line 4/LINE FOUR/' LINE4-chgrec 's/line7/line7\nLastLine/' LastLine-chgrec 's/LINE FOUR/LINE FOUR\nline4.1/' line4.1--darcs changes | grep ' \*'-echo done with changes on temp1 > /dev/null--cd ../temp3-darcs pull -p LastLine -av-chgrec 's/line1$/FirstLine/' FirstLine--cd ../temp4--darcs changes | grep ' \*'-echo done with changes on temp4 > /dev/null--darcs pull ../temp1 --dry-run | grep ' \*'-darcs pull ../temp1 --dry-run | grep ' \*' > p1.out-cat > p1.req <<EOF-  * inssub2-  * Line4-  * line0-  * LINE4-  * LastLine-  * line4.1-EOF-diff p1.req p1.out--darcs pull ../temp1 --dry-run --complement | grep ' \*' > p2.out-diff p1.out p2.out--darcs pull --dry-run --complement ../temp1 ../temp2 | grep ' \*' > p3.out-cat > p3.req <<EOF-  * line0-  * LastLine-EOF-diff p3.req p3.out--darcs pull --dry-run --complement ../temp1 ../temp3 | grep ' \*' > p4.out-cat > p4.req <<EOF-  * line0-EOF-diff p3.req p3.out--darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 | grep ' \*' > p5.out-diff p4.out p5.out--darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 ../temp2 ../temp2 ../temp3 ../temp3 ../temp2 | grep ' \*' > p6.out-diff p4.out p6.out--darcs pull --dry-run --complement ../temp3 ../temp2 | grep ' \*' > p7.out-cat > p7.req <<EOF-  * LastLine-EOF--darcs pull --dry-run --complement ../temp2 ../temp3 > p8.out-grep "No remote changes to pull in!" p8.out--# because duplicates are stripped before performing action,-# this is the same as: darcs pull ../temp1-darcs pull --dry-run --complement ../temp1 ../temp1 > fooout-cat fooout-grep ' \*' fooout > p9.out-diff p1.req p9.out--# 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--darcs pull -av --complement ../temp1 ../temp3-darcs check--cd ..-rm -rf temp1 temp2 temp3 temp4 temp5
+ tests/pull_complement.sh view
@@ -0,0 +1,145 @@+#!/usr/bin/env bash++## Public domain 2007  Kevin Quick+##+## This file is included as part of the Darcs test distribution,+## which is licensed to you under the following terms:+##+## 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+## SOFTWARE.+++. ./lib++rm -rf temp1 temp2 temp3 temp4 temp5++mkdir temp1+cd temp1+cat > foo <<EOF+line1+line2+line3+line4+line5+line6+line7+EOF+darcs initialize+darcs add foo+darcs record -a -m addfoo++cd ..+darcs get temp1 temp4++chgrec () {+    set -ev+    sed -e "$1" foo > foo.tmp+    mv foo.tmp foo+    darcs record -a -m "$2"+}++cd temp1+chgrec 's/line2/line2\nline2.1\nline2.2/' inssub2+chgrec 's/line4/Line 4/' Line4++darcs changes | grep ' \*'+echo done with changes on temp1 > /dev/null++cd ..+darcs get temp1 temp2+darcs get temp1 temp3+cd temp1++chgrec 's/line1/line0\nline1/' line0+chgrec 's/Line 4/LINE FOUR/' LINE4+chgrec 's/line7/line7\nLastLine/' LastLine+chgrec 's/LINE FOUR/LINE FOUR\nline4.1/' line4.1++darcs changes | grep ' \*'+echo done with changes on temp1 > /dev/null++cd ../temp3+darcs pull -p LastLine -av+chgrec 's/line1$/FirstLine/' FirstLine++cd ../temp4++darcs changes | grep ' \*'+echo done with changes on temp4 > /dev/null++darcs pull ../temp1 --dry-run | grep ' \*'+darcs pull ../temp1 --dry-run | grep ' \*' > p1.out+cat > p1.req <<EOF+  * inssub2+  * Line4+  * line0+  * LINE4+  * LastLine+  * line4.1+EOF+diff p1.req p1.out++darcs pull ../temp1 --dry-run --complement | grep ' \*' > p2.out+diff p1.out p2.out++darcs pull --dry-run --complement ../temp1 ../temp2 | grep ' \*' > p3.out+cat > p3.req <<EOF+  * line0+  * LastLine+EOF+diff p3.req p3.out++darcs pull --dry-run --complement ../temp1 ../temp3 | grep ' \*' > p4.out+cat > p4.req <<EOF+  * line0+EOF+diff p3.req p3.out++darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 | grep ' \*' > p5.out+diff p4.out p5.out++darcs pull --dry-run --complement ../temp1 ../temp2 ../temp3 ../temp2 ../temp2 ../temp3 ../temp3 ../temp2 | grep ' \*' > p6.out+diff p4.out p6.out++darcs pull --dry-run --complement ../temp3 ../temp2 | grep ' \*' > p7.out+cat > p7.req <<EOF+  * LastLine+EOF++darcs pull --dry-run --complement ../temp2 ../temp3 > 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+darcs pull --dry-run --complement ../temp1 ../temp1 > fooout+cat fooout+grep ' \*' fooout > p9.out+diff p1.req p9.out++# 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 patches to pull in!" p9.out++darcs pull -av --complement ../temp1 ../temp3+darcs check++cd ..+rm -rf temp1 temp2 temp3 temp4 temp5
− tests/pull_conflicts.sh 
@@ -1,57 +0,0 @@-#!/usr/bin/env bash-## Test that pull --skip-conflicts filters the conflicts-## appropriately.-##-## Copyright (C) 2009 Ganesh Sittampalam-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.--mkdir R-cd R-darcs init-echo 'foo' > foo-echo 'bar' > bar-darcs rec -lam 'Add foo and bar'-cd ..--darcs get R S--cd R-echo 'foo2' > foo-darcs rec -lam 'Change foo (2)'-echo 'bar2' > bar-darcs rec -lam 'Change bar (2)'-cd ..--cd S-echo 'foo3' > foo-darcs rec -lam 'Change foo (3)'-darcs pull --skip-conflicts -a ../R-test `darcs changes --count` -eq 3-cd ..--cd S-darcs pull -a ../R-test `darcs changes --count` -eq 4-cd ..
− tests/pull_many_files.sh 
@@ -1,27 +0,0 @@-#!/usr/bin/env bash-. lib--rm -rf temp1 temp2--if grep old-fashioned .darcs/defaults; then-format=old-fashioned-inventory-elif grep darcs-2 .darcs/defaults; then-format=darcs-2-else format=hashed; fi--mkdir temp2-cd temp2-gunzip -c $TESTDATA/many-files--${format}.tgz | tar xf --cd ..--mkdir temp1-cd temp1-darcs init-darcs pull -a ../temp2/many-files--${format} > log-grep -i 'finished pulling' log-cd ..-rm -rf temp1--# put things back how we found them.--rm -rf temp1 temp2
− tests/pull_two.sh 
@@ -1,34 +0,0 @@-#!/usr/bin/env bash--# This test script, originally written by David Roundy is in the public-# domain.--set -ev--rm -rf temp1 temp2--mkdir temp1-cd temp1-echo foo > bar-darcs initialize-echo record author me > _darcs/prefs/defaults-darcs add bar-darcs record -a -m addbar--cd ..-darcs get temp1 temp2-cd temp1-date > bar-darcs record -a -m datebar--cd ../temp1-echo aack >> bar-darcs record -a -m aackbar--cd ../temp2--darcs pull -av-darcs check--cd ..-rm -rf temp1 temp2
− tests/push-dont-prompt-deps.sh 
@@ -1,32 +0,0 @@-#!/usr/bin/env bash--set -ev--# Check that the right patches get pushed using --dont-prompt-for-dependencies--rm -rf temp1-rm -rf temp2-mkdir temp2-mkdir temp1-cd temp2-darcs init-cd ..-cd temp1-darcs init-echo foo > f-darcs record -Ax -alm foo1-echo bar > b-darcs rec -Ax -alm bar1-echo foo2 > f-darcs record -Ax -alm foo2-echo bar2 > b-darcs record -Ax -alm bar2-echo y | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run -i > toto-#on the previous line, we get asked about foo2, and we take it-grep foo2 toto | wc -l | grep 2-#we don't get asked about foo1, but we take it anyway, so -grep foo1 toto | wc -l | grep 1-#and we don't send bar-grep bar toto | wc -l | grep 0-cd ..-rm -rf temp1 temp2
tests/push-dry-run.sh view
@@ -1,19 +1,14 @@ #!/usr/bin/env bash-set -ev+. ./lib  # For issue855: wish: avoid taking lock if using --dry-run chmod -R u+w temp2 || : rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-cd ..-mkdir temp2+darcs init temp1+darcs init temp2 cd temp2-darcs init touch x-darcs add x-darcs record -am "test"+darcs record -lam test cd .. chmod -R u-w temp2 cd temp2
− tests/push-formerly-pl.sh 
@@ -1,57 +0,0 @@-#!/usr/bin/env bash--# Some tests for 'darcs push'--. lib--slash() {-if echo $OS | grep -q -i windows; then-    echo -n \\-else-    echo -n /-fi-}--DIR="`pwd`"--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-cd ..-mkdir temp2-cd temp2-darcs init-cd ..--# push without a repo gives an error-cd temp1-not darcs push -p 123 2> log-grep -i 'missing argument' log-cd ..--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'-cd ../../../--# darcs push should push into repo specified with --repo-cd temp2-darcs add one-darcs record --name uno --all-cd ..--darcs push --repodir temp2 --all temp1 | grep -i 'Finished apply'--cd temp1-# Before trying to pull from self, defaultrepo does not exist-test ! -e _darcs/prefs/defaultrepo-# return special message when you try to push to yourself-not darcs push -a "$DIR`slash`temp1" 2> log-grep -i "cannot push from repository to itself" log-# and don't update the default repo to be the current dir-test ! -e _darcs/prefs/defaultrepo-cd ..--rm -rf temp1 temp2
tests/push.sh view
@@ -1,21 +1,91 @@ #!/usr/bin/env bash-set -ev -rm -rf temp temp_0-mkdir temp-cd temp+# Some tests for 'darcs push'++. lib++rm -rf temp1 temp2+mkdir temp1+cd temp1 darcs init-echo tester > _darcs/prefs/author-date > bla-darcs add bla-darcs record -a --name=11 cd ..-darcs get temp-cd temp-date > bla2-darcs add bla2-darcs record -a --name=22-darcs push -a ../temp_0+mkdir temp2+cd temp2+darcs init cd .. -rm -rf temp temp_0+# push without a repo gives an error+cd temp1+not darcs push -p 123 2> log+grep -i 'No default repository to push to' log+cd ..++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 patches to push'+cd ../../../++# darcs push should push into repo specified with --repo+cd temp2+darcs add one+darcs record --name uno --all+cd ..++darcs push --repodir temp2 --all temp1 | grep -i 'Finished apply'++cd temp1+# Before trying to pull from self, defaultrepo does not exist+test ! -e _darcs/prefs/defaultrepo+# return special message when you try to push to yourself+not darcs push -a ../temp1 2> log+grep -i "cannot push from repository to itself" log+# and don't update the default repo to be the current dir+test ! -e _darcs/prefs/defaultrepo+cd ..++rm -rf temp1 temp2++# Check that the right patches get pushed using --dont-prompt-for-dependencies++rm -rf temp1 temp2+darcs init temp2+darcs init temp1++cd temp1+echo foo > f+darcs record -alm foo1+echo bar > b+darcs rec -alm bar1+echo foo2 > f+darcs record -alm foo2+echo bar2 > b+darcs record -alm bar2+echo yy | darcs push ../temp2 --dont-prompt-for-dependencies -p foo2 --dry-run -i > toto+#on the previous line, we get asked about foo2, and we take it+grep foo2 toto | wc -l | grep 2+#we don't get asked about foo1, but we take it anyway, so +grep foo1 toto | wc -l | grep 1+#and we don't send bar+not grep bar toto+cd ..+rm -rf temp1 temp2++# For issue257: push => incorrect return code when couldn't get lock++rm -rf temp1 temp2+darcs init temp1+cd temp1+echo foo > foo.c+darcs rec -alm init+cd ..+darcs clone temp1 temp2+cd temp2+echo server >> foo.c+darcs rec -alm server+cd ../temp1+echo client >> foo.c+darcs rec -alm client+not darcs push -a ../temp2+cd ..+rm -rf temp1 temp2
− tests/push_conflicts.sh 
@@ -1,59 +0,0 @@-#!/usr/bin/env bash-## Test that apply --skip-conflicts filters the conflicts-## appropriately.-##-## Copyright (C) 2009 Ganesh Sittampalam-##-## 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-## SOFTWARE.--. lib                  # Load some portability helpers.-rm -rf R S                      # Another script may have left a mess.--mkdir R-cd R-darcs init-echo 'foo' > foo-echo 'bar' > bar-darcs rec -lam 'Add foo and bar'-cd ..--darcs get R S--cd R-echo 'foo2' > foo-darcs rec -lam 'Change foo (2)'-echo 'bar2' > bar-darcs rec -lam 'Change bar (2)'-cd ..--cd S-echo 'foo3' > foo-darcs rec -lam 'Change foo (3)'-cd ..--cd R-darcs send -a ../S -o ../S/applyme.dpatch-cd ..--cd S-darcs apply --skip-conflicts applyme.dpatch-test `darcs changes --count` -eq 3-cd ..
− tests/push_lock.sh 
@@ -1,26 +0,0 @@-#!/usr/bin/env bash--# For issue257: push => incorrect return code when couldn't get lock--set -ev--rm -rf tempc-mkdir tempc-cd tempc-darcs init-echo foo > foo.c-darcs rec -Ax -alm init-cd ..-rm -rf temps-darcs get tempc temps-cd temps-echo server >> foo.c-darcs rec -Ax -alm server-cd ../tempc-echo client >> foo.c-darcs rec -Ax -alm client-if darcs push -a ../temps; then-        false-fi-cd ..-rm -rf tempc temps
− tests/put.sh 
@@ -1,30 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1 temp2-mkdir temp1-cd temp1-darcs init-cd ..--# put should not set default repo-cd temp1-touch 1.txt-darcs add 1.txt-darcs record -a -m foo 1.txt-darcs put ../temp2-test ! -e _darcs/prefs/defaultrepo-cd ..--# put to self-cd temp1-not grep temp1 _darcs/prefs/defaultrepo-DIR=`pwd`-# return special message when you try to put put yourself-not darcs put "$DIR" 2> log-not grep temp1 _darcs/prefs/defaultrepo-grep -i "Can't put.*current repository" log-cd ..--rm -rf temp1 temp2
− tests/query_manifest.sh 
@@ -1,91 +0,0 @@-#!/usr/bin/env bash-set -ev--check_manifest () {-    : > files.tmp-    echo . > dirs.tmp-    echo . > files-dirs.tmp-    for x in $1 ; do-	echo "./$x" >> files.tmp-	echo "./$x" >> files-dirs.tmp-    done-    for x in $2 ; do-	echo "./$x" >> dirs.tmp-	echo "./$x" >> files-dirs.tmp-    done-    darcs query manifest $3 --files --no-directories > darcsraw-files.tmp-    darcs query manifest $3 --no-files --directories > darcsraw-dirs.tmp-    darcs query manifest $3 --files --directories > darcsraw-files-dirs.tmp-    for x in files dirs files-dirs ; do-        sort $x.tmp | sed -e 's,\\,/,' > expected-$x.tmp-        sort darcsraw-$x.tmp | sed -e 's,\\,/,' > darcs-$x.tmp-        diff -u expected-$x.tmp darcs-$x.tmp-    done }--rm -rf temp-mkdir temp-cd temp-darcs init--check_manifest "" "" "--no-pending"-check_manifest "" "" "--pending"-touch a b-darcs add a-check_manifest "" "" "--no-pending"-check_manifest "a" "" "--pending"-darcs add b-mkdir c-check_manifest "" "" "--no-pending"-check_manifest "a b" "" "--pending"-darcs add c-touch c/1 c/2-check_manifest "" "" "--no-pending"-check_manifest "a b" "c" "--pending"-darcs add c/1 c/2-check_manifest "" "" "--no-pending"-check_manifest "a b c/1 c/2" "c" "--pending"-mkdir d-touch d/3 d/4-darcs add d/3 d/4-check_manifest "" "" "--no-pending"-check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending"-darcs record -A test --all --name "patch 1" --skip-long-comment-check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"-check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending"--darcs mv d e-check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"-check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending"-rm c/1-check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"-check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending"-darcs remove c/1-check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"-check_manifest "a b c/2 e/3 e/4" "c e" "--pending"-darcs mv c/2 c/1-check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"-check_manifest "a b c/1 e/3 e/4" "c e" "--pending"-darcs record -A test --all --name "patch 2" --skip-long-comment-check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending"-check_manifest "a b c/1 e/3 e/4" "c e" "--pending"--darcs remove c/1-check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending"-check_manifest "a b e/3 e/4" "c e" "--pending"-darcs remove c-check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending"-check_manifest "a b e/3 e/4" "e" "--pending"-darcs record -A test --all --name "patch 3" --skip-long-comment-check_manifest "a b e/3 e/4" "e" "--no-pending"-check_manifest "a b e/3 e/4" "e" "--pending"--darcs mv b b2-darcs mv b2 b3-check_manifest "a b e/3 e/4" "e" "--no-pending"-check_manifest "a b3 e/3 e/4" "e" "--pending"-darcs record -A test --all --name "patch 3" --skip-long-comment-check_manifest "a b3 e/3 e/4" "e" "--no-pending"-check_manifest "a b3 e/3 e/4" "e" "--pending"--cd ..-rm -rf temp
+ tests/rebase-0.0-compat.sh view
@@ -0,0 +1,54 @@+#!/usr/bin/env bash++## Test that we can upgrade rebase format 0.0 repos++. lib++rm -rf R log+unpack_testdata rebase-0.0++cd R+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log++darcs rebase unsuspend -a++cat > file.expected << END+v v v v v v v+change 1+=============+change 2+*************+initial content+^ ^ ^ ^ ^ ^ ^+END++diff -u file.expected file++cd ..++# In format 0.0 it is legal to store a suspended patch containing a conflict,+# whereas the plan for future formats is to unwind the conflict.+# So make sure that old repos can be updated successfully.++rm -rf R log+unpack_testdata rebase-0.0-conflict++cd R+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log++darcs rebase unsuspend -a+cat > file.expected << END+v v v v v v v+initial content+=============+content A+*************+content B+^ ^ ^ ^ ^ ^ ^+END++diff -u file.expected file++cd ..
+ tests/rebase-0.2-compat.sh view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash++## Test that we can upgrade rebase format 0.2 repos++. lib++rm -rf R log+unpack_testdata rebase-0.2++cd R+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log++darcs rebase unsuspend -a++cat > file.expected << END+v v v v v v v+change 1+=============+change 2+*************+initial content+^ ^ ^ ^ ^ ^ ^+END++diff -u file.expected file++cd ..
+ tests/rebase-amend.sh view
@@ -0,0 +1,45 @@+#!/bin/sh -e+##+## Test that amend doesn't leave the rebase in a bad state+##+## Copyright (C) 2012 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init++echo 'wibble' > wibble+darcs rec -lam 'wibble'++echo 'wobble' > wibble+darcs rec -am 'wobble'++echo 'yd' | darcs rebase suspend++echo 'wubble' > wibble+echo 'ya' | darcs amend-record++darcs check
+ tests/rebase-apply.sh view
@@ -0,0 +1,91 @@+#!/bin/sh -e+##+## Basic test of rebase apply+##+## Copyright (C) 2011-2014 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R1 R2 R3+mkdir R1+cd R1+darcs init+echo '1' > foo+darcs rec -lam "add foo"+cd ..++darcs get R1 R2+cd R2+echo '2' > foo+darcs rec -am "2"+darcs send -a -o 2.dpatch ../R1+cd ..++darcs get R1 R3+cd R3+echo '3' > foo+darcs rec -am "3"++echo '4' > foo+darcs rec -am "4"++# TODO: figure out behaviour of --all and test it+# (should it answer 'yes' to both pulling and suspending?+echo yyy | darcs rebase apply -a ../R2/2.dpatch++darcs changes --count 2>&1 | grep "Rebase in progress: 2 suspended patches"+echo yny | darcs rebase unsuspend 2>log+grep conflicts log+cat > expected <<EOF+v v v v v v v+1+=============+2+*************+3+^ ^ ^ ^ ^ ^ ^+EOF+diff -u expected foo++echo 23 > foo+echo yyy | darcs amend --patch '3'++echo yy | darcs rebase unsuspend 2>log+grep conflicts log+cat > expected <<EOF+v v v v v v v+3+=============+23+*************+4+^ ^ ^ ^ ^ ^ ^+EOF+diff -u expected foo++echo 24 > foo+echo yyy | darcs amend --patch '4'++cd ..++
+ tests/rebase-basic.sh view
@@ -0,0 +1,39 @@+#!/bin/sh -e+##+## Basic test of rebase+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init+echo 'wibble' > wibble+darcs rec -lam "add wibble"++echo 'yy' | darcs rebase suspend 2>&1 | grep-once "Rebase in progress: 1 suspended patch"+not test -f wibble+echo 'yy' | darcs rebase unsuspend | grep-once "Rebase finished"+test -f wibble
+ tests/rebase-changes-partial-conflict.sh view
@@ -0,0 +1,47 @@+#!/bin/sh -e++# Check that rebase changes correctly identifies which+# parts of a change are in conflict and which aren't++. lib++rm -rf R+mkdir R+cd R+darcs init++echo contents1A > file1+echo contents2A > file2+echo contents3A > file3+echo contents4A > file4+darcs rec -lam "init"++echo contents1B > file1+echo contents3B > file3+darcs rec -am "change 1"++echo contents2B > file2+echo contents4B > file4+darcs rec -am "change 2"++echo contents1C > file1+echo contents2C > file2+echo contents3C > file3+echo contents4C > file4+darcs rec -am "change 3"++# suspend change 3 and obliterate change 2+# this should leave change 3 with fixups+echo "yd" | darcs rebase suspend+echo "yd" | darcs obliterate++darcs rebase changes -s | grep "M ./file1"+darcs rebase changes -s | grep "M\! ./file2"+darcs rebase changes -s | grep "M ./file3"+darcs rebase changes -s | grep "M\! ./file4"++# this is what we expect to appear in the "conflicts" section+darcs rebase changes --verbose | not grep "contents1A"+darcs rebase changes --verbose | grep "contents2A"+darcs rebase changes --verbose | not grep "contents3A"+darcs rebase changes --verbose | grep "contents4A"
+ tests/rebase-changes.sh view
@@ -0,0 +1,40 @@+#!/bin/sh -e++# Basic test for rebase changes++. lib++rm -rf R+mkdir R+cd R+darcs init++echo 'first' > file+darcs rec -lam 'change 1'++echo 'second' > file+darcs rec -am 'change 2'++echo 'third' > file+darcs rec -am 'change 3'++# suspend change 3+echo 'yd' | darcs rebase suspend++darcs rebase changes | grep "change 3"+darcs rebase changes -s | grep "M ./file"+darcs rebase changes --verbose | grep "third"+# we shouldn't see any sign of change 1 or change 2+darcs rebase changes --verbose | not grep "first"++# this turns change 2 into a fixup, so+# subsequence rebase changes should report conflicts+echo 'yd' | darcs obliterate++darcs rebase changes | grep "change 3"+darcs rebase changes -s | grep "M\! ./file"+darcs rebase changes --verbose | grep "third"+# now we should see a conflict with change 2+# which removes the line "first"+darcs rebase changes --verbose | grep "first"+darcs rebase changes --verbose | grep "conflictor"
+ tests/rebase-conflict-resolution.sh view
@@ -0,0 +1,57 @@+#!/usr/bin/env bash++# test that we can suspend a conflict plus its resolution, then unsuspend them+# and not get any conflicts+. lib++rm -rf R S R-oneatatime R-bothtogether++darcs init R++cd R+echo 'initial content' > f+darcs rec -lam "initial content"+cd ..++darcs clone R S++cd R+echo 'content1' > f+darcs rec -am "content1"+cd ..++cd S+echo 'content2' > f+darcs rec -am "content2"+cd ..++cd R+darcs pull --allow-conflicts -a ../S+echo 'content12' > f+darcs rec -am "content12 (resolution)"++echo yyd | darcs rebase suspend+cd ..++cp -r R R-oneatatime+cp -r R R-bothtogether++cat > f.expected << END+content12+END++cd R-oneatatime+echo yd | darcs rebase unsuspend+ # get rid of conflict markers, since in this case darcs hasn't seen the resolution patch yet+darcs rev -a+echo yd | darcs rebase unsuspend++diff -u ../f.expected f+cd ..++cd R-bothtogether+echo yyd | darcs rebase unsuspend+# this time there shouldn't be any conflict markers in the first place, as the resolution was+# unsuspended at the same time+diff -u ../f.expected f+cd ..
+ tests/rebase-conflict-upgrade.sh view
@@ -0,0 +1,15 @@+#!/usr/bin/env bash++## Test that we can upgrade an old-style rebase repo+## where the suspended patch had a conflict++. lib++rm -rf R log+unpack_testdata old-style-rebase-conflict++cd R+darcs rebase upgrade+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log+cd ..
+ tests/rebase-conflicting-threeeway.sh view
@@ -0,0 +1,33 @@+#!/usr/bin/env bash++. lib++rm -rf R S T++darcs init R+cd R+touch f+darcs record -l f -a -m 'baseline'+darcs clone . ../S+darcs clone . ../T+echo R > f+darcs record -l f -a -m 'hunk R'+cd ../S+echo S > f+darcs record -l f -a -m 'hunk S'+cd ../T+echo T > f+darcs record -l f -a -m 'hunk T'+cd ../R+darcs pull -a --allow-conflicts ../S ../T+# echo X > f+# darcs record -l f -a -m 'resolve conflicts'+cd ../S+darcs pull -a ../R --allow-conflicts+cd ../R+darcs log -v > ../before_rebase+darcs rebase suspend -a+cp _darcs/rebase ..+darcs rebase unsuspend -a+darcs log -v > ../after_rebase+cd ..
+ tests/rebase-count.sh view
@@ -0,0 +1,43 @@+#!/bin/sh -e+##+## Test that patches are counted properly when a rebase is in progress+##+## Copyright (C) 2015 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init++echo 'wibble' > wibble+darcs rec -lam 'wibble'++echo 'wobble' > wibble+darcs rec -am 'wobble'++echo 'yd' | darcs rebase suspend++darcs log --last 1 | grep wibble+
+ tests/rebase-keeps-deps-on-amend.sh view
@@ -0,0 +1,68 @@+#!/usr/bin/env bash+##+## Check that explicit dependencies are preserved during rebase+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init++echo 'A' > A+darcs add A+darcs rec -am"A"++echo 'B' > B+darcs add B+darcs rec -am"B"++echo 'C' > C+darcs add C+echo 'yyy' | darcs rec -am"C" --ask-deps++echo 'yyd' | darcs rebase suspend++echo 'A2' > A+echo 'y' | darcs amend -a++echo 'yyy' | darcs rebase unsuspend+darcs unpull --patch 'A' --no-deps | grep "No patches selected"+darcs unpull --patch 'B' --no-deps | grep "No patches selected"++# repeat the test with a tag+darcs unpull --patch 'C' -a+darcs tag T++# two stages because suspend stops at clean tags+# might need to change back to one stage if this changes+echo 'yy' | darcs rebase suspend+echo 'yd' | darcs rebase suspend++echo 'yyy' | darcs rebase unsuspend+# this offers 'T', seems to be a bug in darcs unpull --no-deps+# darcs unpull --patch 'A' --no-deps | grep "No patches selected"+darcs unpull --match 'not name T' | grep "No patches selected"+darcs unpull --patch 'B' --no-deps | grep "No patches selected"
+ tests/rebase-keeps-deps.sh view
@@ -0,0 +1,65 @@+#!/usr/bin/env bash+##+## Check that explicit dependencies are preserved during rebase+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init++echo 'A' > A+darcs add A+darcs rec -am"A"++echo 'B' > B+darcs add B+darcs rec -am"B"++echo 'C' > C+darcs add C+echo 'yyy' | darcs rec -am"C" --ask-deps++echo 'yydy' | darcs rebase suspend++echo 'yyy' | darcs rebase unsuspend+darcs unpull --patch 'A' --no-deps | grep "No patches selected"+darcs unpull --patch 'B' --no-deps | grep "No patches selected"++# repeat the test with a tag+darcs unpull --patch 'C' -a+darcs tag T++# two stages because suspend stops at clean tags+# might need to change back to one stage if this changes+echo 'yy' | darcs rebase suspend+echo 'yd' | darcs rebase suspend++echo 'yyy' | darcs rebase unsuspend+# this offers 'T', seems to be a bug in darcs unpull --no-deps+# darcs unpull --patch 'A' --no-deps | grep "No patches selected"+darcs unpull --match 'not name T' | grep "No patches selected"+darcs unpull --patch 'B' --no-deps | grep "No patches selected"
+ tests/rebase-move-2.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+##+## Check that rebase handles amended-in moves+##+## Copyright (C) 2012 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.++rm -rf R++darcs init --repo R++cd R++echo 'wibble' > wibble+darcs rec -lam "add"++darcs mv wibble wobble+darcs rec -am "rename"++echo 'wobble' > wobble+darcs rec -am "edit"++echo 'yyd' | darcs rebase suspend++darcs mv wibble wobble+echo 'yyy' | darcs amend++echo 'yd' | darcs rebase obliterate++echo 'yy' | darcs rebase unsuspend+not darcs wh+
+ tests/rebase-move.sh view
@@ -0,0 +1,49 @@+#!/usr/bin/env bash+##+## Check that rebase merges moves without conflicts+##+## Copyright (C) 2010 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init+echo 'wibble' > wibble+darcs add wibble+darcs rec -am"wibble"+echo 'wobble' > wibble+darcs rec -am"wobble"++echo 'yd' | darcs rebase suspend+darcs mv wibble wobble+echo 'y' | darcs amend -a --patch 'wibble'+# there shouldn't be any conflicts+echo 'yy' | darcs rebase unsuspend 2>&1 | not grep conflicts+# we expect the only file to be wobble, containing 'wobble'.+not darcs wh+not test -f wibble+echo wobble > wobble.expected+diff -u wobble.expected wobble+
+ tests/rebase-new-style.sh view
@@ -0,0 +1,75 @@+#!/usr/bin/env bash+## Test that all operations except 'rebase upgrade' on old-style+## rebase-in-progress repos fail++. lib++rm -rf R S T log+unpack_testdata old-style-rebase+darcs init S+echo ../S > R/_darcs/prefs/defaultrepo++not darcs clone R T 2>&1 | tee log+grep 'clone a repository with an old-style rebase' log++# TODO for this test I need a tar ball with a darcs-1 repo in it+# not darcs convert darcs-2 R T 2>&1 | tee log+# grep 'old-style rebase is in progress' log++# init, help, and convert import are not an issue++IFS='+'+commands='+record+push+pull+log+diff+show contents f1+show dependencies+show files+show index+show pristine+show repo+show authors+show tags+show patch-index+amend+rebase pull+rebase apply+rebase suspend+rebase unsuspend+rebase obliterate+rebase log+rebase reify+rebase inject+rebase changes+unrecord+obliterate+tag+send+apply+optimize clean+optimize http+optimize reorder+optimize enable-patch-index+optimize disable-patch-index+optimize compress+optimize uncompress+optimize relink+mark-conflicts+repair+convert export+fetch'++cd R+for cmd in $commands; do+  unset IFS+  not darcs $cmd 2>&1 | tee ../log+  grep 'old-style rebase is in progress' ../log+done+darcs rebase upgrade+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log+cd ..
+ tests/rebase-nochanges.sh view
@@ -0,0 +1,62 @@+#!/bin/sh -e+##+## Test that having a rebase in progress doesn't impact+## the UI of other darcs commands.+##+## At the time of writing, rebase was represented by+## a special internal patch and so this test is specifically+## aimed at checked that this patch is not presented in the UI+## Even if this changes, it is still worth having tests of+## the general principle that normal commands should still+## work as usual.+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init+echo 'wibble' > wibble+darcs rec -lam "add wibble"++echo 'yy' | darcs rebase suspend++darcs changes --count | grep 0+darcs unpull --dry-run | grep "No patches selected!"++echo 'wobble' > wobble+darcs rec -lam "add wobble" -A tester++darcs changes --count | grep 1+cat > expected <<EOF+  * add wobble++Making no changes: this is a dry run.+EOF+darcs unpull --dry-run | tail -n+5 | grep -v tester | diff -u expected -+++echo 'yy' | darcs rebase unsuspend 2>&1 | grep "Rebase finished"+test -f wibble
+ tests/rebase-obliterate.sh view
@@ -0,0 +1,43 @@+#!/bin/sh -e+##+## Test of rebase obliterate+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init+echo 'wibble' > wibble+darcs rec -lam "add wibble"++echo 'wobble' > wobble+darcs rec -lam "add wobble"++echo 'yyy' | darcs rebase suspend+echo 'yd' | darcs rebase obliterate+echo 'yy' | darcs rebase unsuspend | grep 'Rebase finished'+test -f wobble+not test -f wibble
+ tests/rebase-old-style-not-head.sh view
@@ -0,0 +1,30 @@+#!/usr/bin/env bash++## Test that we can upgrade an old-style rebase repo where the+## special rebase container patch is not at the head of the repo++. lib++rm -rf R log+unpack_testdata old-style-rebase-not-head++cd R+darcs rebase upgrade+darcs rebase log 2>../log+grep 'Rebase in progress: 1 suspended patch' ../log+echo yd | darcs rebase unsuspend++# check that the suspended patch was properly commuted+# with the patch that was added after it was suspended+cat > file.expected << EOF+1+2+3+A+B+C2+D+EOF+diff -u file.expected file++cd ..
+ tests/rebase-pull-reorder.sh view
@@ -0,0 +1,48 @@+#!/usr/bin/env bash++. lib                  # Load some portability helpers.++check_patches_order () {+    darcs changes | tr -d "\n" | grep $1.*$2.*$3+}++test_init () {+    rm -rf R1 R2+    +    darcs init "R1"+    cd R1++    touch "r1_0"+    darcs add "r1_0"+    darcs record -a --author=me -m "Adding r1_0" "r1_0"++    cd ..++    darcs clone "R1" "R2"++    cd R2++    touch "r2_0"+    darcs add "r2_0"+    darcs record -a --author=me -m "Adding r2_0" "r2_0"+    darcs send --author=me -a --no-edit-description -o ../R1/P ++    cd ..++    cd R1++    touch "r1_1"+    darcs add "r1_1"+    darcs record -a --author=me -m "Adding r1_1" "r1_1"+    +    cd ..+}++test_init++cd R1++darcs rebase pull -a --reorder ../R2+check_patches_order r1_1 r2_0 r1_0++cd ..
+ tests/rebase-pull-tag.sh view
@@ -0,0 +1,50 @@+#!/usr/bin/env bash+##+## Check that you can pull tags into a repo with rebase in progress+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init+touch a+darcs add a+darcs rec -am"a"+darcs tag a+cd ..++rm -rf t2+mkdir t2+cd t2+darcs init+touch b+darcs add b+darcs rec -am"b"+echo 'yy' | darcs rebase suspend+darcs pull -a ../t1++darcs check+darcs changes # because darcs check doesn't complain about a corrupt rebase state :-(
+ tests/rebase-pull.sh view
@@ -0,0 +1,90 @@+#!/bin/sh -e+##+## Basic test of rebase pull+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R1 R2 R3+mkdir R1+cd R1+darcs init+echo '1' > foo+darcs rec -lam "add foo"+cd ..++darcs get R1 R2+cd R2+echo '2' > foo+darcs rec -am "2"+cd ..++darcs get R1 R3+cd R3+echo '3' > foo+darcs rec -am "3"++echo '4' > foo+darcs rec -am "4"++# TODO: figure out behaviour of --all and test it+# (should it answer 'yes' to both pulling and suspending?+echo yyy | darcs rebase pull -a ../R2++darcs changes --count 2>&1 | grep "Rebase in progress: 2 suspended patches"+echo yny | darcs rebase unsuspend 2>log+grep conflicts log+cat > expected <<EOF+v v v v v v v+1+=============+2+*************+3+^ ^ ^ ^ ^ ^ ^+EOF+diff -u expected foo++echo 23 > foo+echo yyy | darcs amend --patch '3'++echo yy | darcs rebase unsuspend 2>log+grep conflicts log+cat > expected <<EOF+v v v v v v v+3+=============+23+*************+4+^ ^ ^ ^ ^ ^ ^+EOF+diff -u expected foo++echo 24 > foo+echo yyy | darcs amend --patch '4'++cd ..++
+ tests/rebase-remote.sh view
@@ -0,0 +1,71 @@+#!/bin/sh -e+##+## Test that remote operations on rebase-in-progress repos do /not/ fail+## but ignore the rebase patch+##+## Copyright (C) 2012-3 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R1 R2 R3 R4+mkdir R1+cd R1+darcs init+echo '1' > foo+darcs rec -lam "normal patch"+echo '2' > foo+darcs rec -am "suspended patch"+echo yny | darcs rebase suspend+cd ..++darcs get R1 R2+cd R2+# this fails because there is no rebase in progress+not darcs rebase unsuspend+cd ..++mkdir R3+cd R3+darcs init+darcs pull -a ../R1 2>&1+cd ..++mkdir R4+cd R4+darcs init+cd ../R1+darcs push -a ../R4+cd ../R4+# this fails because there is no rebase in progress+not darcs rebase unsuspend+cd ..++mkdir R5+cd R5+darcs init+cd ../R1+darcs send -a ../R5 -o bundle.dpatch+not grep "DO NOT TOUCH" bundle.dpatch+grep "normal patch" bundle.dpatch+not grep "suspended patch" bundle.dpatch+cd ..
+ tests/rebase-repull.sh view
@@ -0,0 +1,78 @@+#!/bin/sh -e+##+## Repulling a suspended patch+##+## Copyright (C) 2012 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init+echo 'wibble' > wibble+darcs rec -lam "add wibble"+darcs tag bla+cd ..++# suspend, repull, rebase obliterate++rm -rf R1+darcs get R R1++cd R1+echo yy | darcs rebase suspend+echo yy | darcs rebase suspend+echo yd | darcs pull ../R+echo yd | darcs rebase obliterate+echo yd | darcs rebase obliterate+cd ..++# issue2445: suspend, repull, unsuspend++rm -rf R2+darcs get R R2++cd R2+echo yy | darcs rebase suspend+echo yy | darcs rebase suspend+echo yd | darcs pull -a ../R+echo yd | darcs rebase unsuspend --allow-conflicts+echo yd | darcs pull -a ../R+echo yd | darcs rebase unsuspend+cd ..++# suspend, repull, suspend again, unsuspend++rm -rf R3+darcs get R R3++cd R3+echo yy | darcs rebase suspend+echo yy | darcs rebase suspend+echo yd | darcs pull -a ../R+echo yd | darcs pull -a ../R+echo yy | darcs rebase suspend+echo yy | darcs rebase suspend+echo wwyd | darcs rebase unsuspend+cd ..
+ tests/rebase-simple-conflict.sh view
@@ -0,0 +1,36 @@+#!/usr/bin/env bash++# Test for rebasing a conflict where we don't remove+# patches that are part of the conflict++. ./lib++rm -rf R S+darcs init R+cd R++echo 'initial' > file+darcs rec -lam 'initial'++cd ..+darcs clone R S+cd R++echo 'contentsA' > file+darcs rec -lam 'A'++cd ../S+echo 'contentsB' > file+darcs rec -lam 'B'++cd ../R+darcs pull ../S --mark-conflicts -a+# save the expected conflict markup+cp file file.expected+darcs rev -a # get rid of the markup+echo 'ydy' | darcs rebase suspend+echo 'yd' | darcs rebase unsuspend++diff -u file.expected file++
+ tests/rebase-skip-conflicts.sh view
@@ -0,0 +1,81 @@+#!/bin/sh -e+##+## Test of rebase unsuspend --skip-conflicts+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init++cat > foo <<EOF+1+2+3+4+5+EOF+darcs rec -lam "initial foo"++cat > foo <<EOF+1+2A+3+4+5+EOF+darcs rec -am "change 2A"++cat > foo <<EOF+1+2A+3+4A+5+EOF+darcs rec -am "change 4A"++echo 'yyd' | darcs rebase suspend++cat > foo <<EOF+1+2B+3+4+5+EOF+darcs rec -am "change 2B"++echo 'yy' | darcs rebase unsuspend --skip-conflicts++cat > foo-expected <<EOF+1+2B+3+4A+5+EOF+diff -u foo-expected foo
+ tests/rebase-successive-amends.sh view
@@ -0,0 +1,25 @@+#!/usr/bin/env bash++. lib++rm -rf R+darcs init R+cd R+echo A > file+darcs add file+darcs record file -am A+echo B > file+darcs record file -am B+echo C > file+darcs record file -am C+darcs rebase suspend -a -p C+echo B1 > file+echo yd | darcs amend -am B1+echo B2 > file+echo yd | darcs amend -am B2+echo B3 > file+echo yd | darcs amend -am B3+cp _darcs/rebase ../1-before-unsuspend+darcs rebase unsuspend -a 2>../log+grep conflicts ../log+cd ..
+ tests/rebase-suspend-from-patch.sh view
@@ -0,0 +1,46 @@+#!/bin/sh -e+##+## Test rebase suspend --from-patch+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init+touch foo+darcs rec -lam 'add foo'++touch bar+darcs rec -lam 'add bar'++touch baz+darcs rec -lam 'add baz'++darcs rebase suspend --from-patch 'bar' -a++darcs changes | grep 'add foo'+darcs changes | not grep 'add bar'+darcs changes | not grep 'add baz'
+ tests/rebase-tag.sh view
@@ -0,0 +1,39 @@+#!/usr/bin/env bash+##+## Check that you can't tag a rebase patch+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init+echo 'wibble' > wibble+darcs add wibble+darcs rec -am"wibble"+echo 'yy' | darcs rebase suspend+darcs tag 'ugh'+darcs check+darcs changes # because darcs check doesn't complain about a corrupt rebase state :-(
+ tests/rebase-unsuspend-quit.sh view
@@ -0,0 +1,45 @@+#!/bin/sh -e+##+## Test rebase unsuspend, with quit+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init+touch foo+darcs rec -lam 'add foo'++touch bar+darcs rec -lam 'add bar'++touch baz+darcs rec -lam 'add baz'++echo 'yyyy' | darcs rebase suspend++echo yyq | darcs rebase unsuspend 2> log+grep "3 suspended patches" log
+ tests/rebase-unsuspend-to-patch.sh view
@@ -0,0 +1,48 @@+#!/bin/sh -e+##+## Test rebase unsuspend --to-patch+##+## Copyright (C) 2011 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R+darcs init+touch foo+darcs rec -lam 'add foo'++touch bar+darcs rec -lam 'add bar'++touch baz+darcs rec -lam 'add baz'++echo 'yyyy' | darcs rebase suspend++darcs rebase unsuspend --to-patch 'bar' -a 2>log+darcs changes | grep 'add foo'+darcs changes | grep 'add bar'+darcs changes | not grep 'add baz'+grep "1 suspended patch" log
+ tests/rebase-warns-lost-deps.sh view
@@ -0,0 +1,54 @@+#!/usr/bin/env bash+##+## Check that lost explicit dependencies are reported on during rebase+##+## Copyright (C) 2015 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib                  # Load some portability helpers.++rm -rf t1+mkdir t1+cd t1+darcs init++echo 'A' > A+darcs add A+darcs rec -am"patch A"++echo 'B' > B+darcs add B+darcs rec -am"patch B"++echo 'C' > C+darcs add C+echo 'yyy' | darcs rec -am"patch C" --ask-deps++echo 'ydy' | darcs rebase suspend++darcs unpull -a -p 'patch A'++echo 'ydy' | darcs rebase unsuspend > unsuspend-output.txt++grep "following explicit dependency" unsuspend-output.txt+grep "patch A" unsuspend-output.txt+not grep "patch B" unsuspend-output.txt
+ tests/rebase-with-conflicting-unrecorded.sh view
@@ -0,0 +1,32 @@+#!/usr/bin/env bash+# rebase with conflicting unrecorded changes+# TODO repeat test for rebase pull and rebase apply++. lib++rm -rf R+darcs init R+cd R+echo orig > file+darcs record -lam thepatch+darcs replace -f changed orig file+echo changed > file+darcs whatsnew > ../whatsnew.orig+# make sure we have a change in the pending patch as well+grep replace ../whatsnew.orig++# non-interactive mode: should fail+not darcs rebase suspend -p thepatch -a 2>ERR+grep "Can't suspend .* without reverting" ERR+darcs whatsnew > ../whatsnew.failed+diff ../whatsnew.orig ../whatsnew.failed++# interactive mode: user gets prompted+# first y to select patch, second y to confirm selection, n to refuse revert+echo yyn | darcs rebase suspend -p thepatch+darcs whatsnew > ../whatsnew.refuse+diff ../whatsnew.orig ../whatsnew.refuse+# first y to select patch, second y to confirm selection, third y to accept revert+echo yyy | darcs rebase suspend -p thepatch+# all unrecorded changes are reverted now+not darcs whatsnew
− tests/record-interactive.sh 
@@ -1,27 +0,0 @@-#!/usr/bin/env bash--. lib---rm -rf temp1-mkdir temp1-cd temp1-darcs init--touch foo-darcs add foo-darcs record -a -m addfoo--darcs replace one two foo-darcs replace three four foo-darcs replace five six foo--echo sa | darcs record -m cancelled--darcs whatsnew--darcs changes > ch-not grep cancelled ch--cd ..-rm -rf temp1
tests/record.sh view
@@ -13,24 +13,22 @@ darcs record -am foo --ask-deps | grep -i "Ok, if you don't want to record anything, that's fine!"  # RT#476 - --ask-deps works when there are no patches-if echo $OS | grep -i windows; then-  echo This test does not work on Windows-else-  touch t.f-  darcs add t.f-  darcs record  -am add-  echo a | darcs record  -am foo --ask-deps | grep -i 'finished recording'-fi+touch t.f+darcs add t.f+darcs record -am add+echo a | darcs record  -am foo --ask-deps | grep -i 'finished recording'  # RT#231 - special message is given for nonexistent directories-not darcs record -am foo not_there.txt > log-grep -i 'not exist' log+not darcs record -am foo not_there.txt > log 2>&1+grep -i 'non-existing' log  # RT#231 - a nonexistent file before an existing file is handled correctly-touch b.t-darcs record  -lam foo a.t b.t > log-grep -i 'WARNING:.*a.t' log-grep -iv 'WARNING:.*b.t' log+# test disabled, see tests/issue2494-output-of-record-with-file-arguments.sh+# which contains an updated test+# touch b.t+# darcs record  -lam foo a.t b.t > log+# grep -i 'WARNING:.*a.t' log+# grep -iv 'WARNING:.*b.t' log  DIR="`pwd`" touch date.t@@ -50,5 +48,190 @@ echo "second record\n" >> log.txt darcs record  -a -m 'second record' --logfile=log.txt  date.t | grep -i 'finished recording' +echo text > file+darcs add file++# refuse empty patch name++# true command outputs nothing & ignores its arguments+DARCS_EDITOR=true not darcs record -a --edit-long-comment+# cat command reproduces its input unchanged+DARCS_EDITOR=cat not darcs record -a -m "" --edit-long-comment+not darcs record -a -m ""++# refuse patch name starting with "TAG "++# editor output will be "echo TAG _darcs/patch_description.txt"+DARCS_EDITOR='echo TAG ' not darcs record -a --edit-long-comment+# cat command reproduces its input unchanged+DARCS_EDITOR=cat not darcs record -a -m "TAG fake" --edit-long-comment+not darcs record -a -m "TAG fake"+ cd ..+++# record race++rm -rf foo1 foo2+mkdir foo1 foo2+cd foo1+darcs init+echo zig > foo+darcs add foo+darcs record -a -m add_foo -A x+echo zag >> foo+darcs record --ignore-time -a -m mod_foo -A x+cd ../foo2+darcs init+darcs pull -a ../foo1+cd ..+cmp foo1/foo foo2/foo++# record interactive++ rm -rf temp1+mkdir temp1+cd temp1+darcs init++touch foo+darcs add foo+darcs record -a -m addfoo++darcs replace one two foo+darcs replace three four foo+darcs replace five six foo++echo sa | darcs record -m cancelled++darcs whatsnew++darcs changes > ch+not grep cancelled ch++cd ..+++# Some tests for 'darcs rec --edit-long-comment'++rm -rf temp1++export DARCS_EDITOR="cat -n"+# editor: space in command+rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch file.t+darcs add file.t+echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter'+cd ..++# editor: space in path+rm -rf temp2\ dir+mkdir temp2\ dir+cd temp2\ dir+darcs init+touch file.t+darcs add file.t+echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter'+cd ..++# make sure summaries are coalesced+rm -rf temp3+mkdir temp3+cd temp3+darcs init+cat > file <<EOF+1+2+3+4+EOF+darcs add file+darcs rec -a -m "init" file+cat > file <<EOF+A+2+3+B+EOF+echo y | darcs record --edit-long-comment -a -m edit | grep -c "./file" | grep 1+cd ..++export DARCS_EDITOR='grep "# Please enter"'+# editor: quoting in command+rm -rf temp1+mkdir temp1+cd temp1+darcs init+touch file.t+darcs add file.t+echo y | darcs record --edit-long-comment -a -m foo file.t | grep '# Please enter'+cd ..++export DARCS_EDITOR='echo'+# editor: evil filename+rm -rf temp1+darcs init temp1+cd temp1+touch file.t+darcs add file.t+touch '; test-command'+echo > test-command << FOO+#!/bin/sh+echo EVIL+FOO+chmod u+x test-command+echo y | darcs record --logfile='; test-command' --edit-long-comment -a -m foo file.t > log+not grep EVIL log+cd ..++## Test for issue142 - darcs record --logfile foo should not++rm -rf temp1+darcs init temp1+cd temp1+touch f g+touch log+darcs     record -alm f --logfile log     f+not darcs record -alm g --logfile missing g+cd ..++## Test for issue1845 - darcs record f, for f a removed file should work+## Public domain - 2010 Petr Rockai++rm -rf temp1+darcs init temp1+cd temp1++echo 'Example content.' > f+darcs rec -lam "first"+rm -f f+echo ny | darcs record f 2>&1 | tee log+not grep "None of the files" log+cd ..++# issue1472 - "darcs record ./foo" shouldn't even TRY to read ./bar++rm -rf temp1+darcs init temp1+mkdir temp1/d/+echo 'Example content.' >temp1/f+echo 'Similar content.' >temp1/d/f+chmod 0 temp1/f # Make temp1/f unreadable+darcs record    --repo temp1 -lam 'Only changes to temp1/d/.' d++# issue1871 - `darcs record .` should work for tracked changes+# in a subdirectory even if the subdirectory itself is not known yet.+rm -rf temp1+darcs init temp1+cd temp1+mkdir d+echo 'Example content.' > d/f+darcs add d/f+echo ny | darcs record+echo ny | darcs record . > log+not grep "None of the files" log+cd ..
− tests/record_editor.sh 
@@ -1,81 +0,0 @@-#!/usr/bin/env bash--# Some tests for 'darcs rec --edit-long-comment'--. lib--abort_windows--rm -rf temp1--export DARCS_EDITOR="cat -n"-# editor: space in command-mkdir temp1-cd temp1-darcs init-touch file.t-darcs add file.t-echo y | darcs record --edit-long-comment -a -m foo file.t | grep '2.*END OF DESCRIPTION'-cd ..-rm -rf temp1--# editor: space in path-mkdir temp2\ dir-cd temp2\ dir-darcs init-touch file.t-darcs add file.t-echo y | darcs record --edit-long-comment -a -m foo file.t | grep '2.*END OF DESCRIPTION'-cd ..-rm -rf temp2\ dir--# make sure summaries are coalesced-mkdir temp3-cd temp3-darcs init-cat > file <<EOF-1-2-3-4-EOF-darcs add file-darcs rec -a -m "init" file-cat > file <<EOF-A-2-3-B-EOF-echo y | darcs record --edit-long-comment -a -m edit | grep -c "./file" | grep 1-cd ..-rm -rf temp2\ dir--export DARCS_EDITOR='grep "END OF"'-# editor: quoting in command-mkdir temp1-cd temp1-darcs init-touch file.t-darcs add file.t-echo y | darcs record --edit-long-comment -a -m foo file.t | grep 'END OF'-cd ..-rm -rf temp1--export DARCS_EDITOR='echo'-# editor: evil filename-mkdir temp1-cd temp1-darcs init-touch file.t-darcs add file.t-touch '; test-command'-echo > test-command << FOO-#!/bin/sh-echo EVIL-FOO-chmod u+x test-command-echo y | darcs record --logfile='; test-command' --edit-long-comment -a -m foo file.t > log-not grep EVIL log-cd ..-rm -rf temp1
− tests/recordrace.sh 
@@ -1,21 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf foo1 foo2-mkdir foo1 foo2-cd foo1-darcs init-echo zig > foo-darcs add foo-sleep 1-darcs record -a -m add_foo -A x-#sleep 1-echo zag >> foo-darcs record --ignore-time -a -m mod_foo -A x-cd ../foo2-darcs init-darcs pull -a ../foo1-cd ..-cmp foo1/foo foo2/foo-rm -rf foo1 foo2-
tests/remove.sh view
@@ -48,3 +48,29 @@ not grep -i d/f/1.txt after.lst  cd ..+rm -rf temp1++# issue1765 recursive remove on root++darcs init temp1+cd temp1++mkdir d e                       # Change the working tree.+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'+darcs remove * -r++cd ..++# but never allow to remove the root directory itself++rm -rf temp1+darcs init temp1+cd temp1+not darcs remove .+mkdir x+darcs add x+cd x+not darcs remove ..+cd ..+cd ..
tests/rename_shouldnt_affect_prefixes.sh view
@@ -39,7 +39,7 @@ darcs move a b darcs rec -am 'Move a -> b' -darcs cha --xml b bb > changes.xml+darcs changes --xml b bb > changes.xml  grep "original_name='./a'" < changes.xml # Ensure we've not used a prefix of the filename for the move.
+ tests/renames.sh view
@@ -0,0 +1,29 @@+#!/usr/bin/env bash+## Test various renames+##+## 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++. lib++rm -rf R && darcs init --repo R+cd R+runghc $TESTBIN/renameHelper.hs
− tests/repair-clean.sh 
@@ -1,25 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1-mkdir temp1-cd temp1--darcs init-touch baz-darcs add baz-darcs record -m moo -a--cat _darcs/patches/pending--darcs changes -v--darcs check--# check that repair doesn't do anything to a clean repository-darcs repair > out-cat out-grep 'already consistent' out--cd ..-rm -rf temp1
− tests/repair-corrupt-add.sh 
@@ -1,56 +0,0 @@-#!/usr/bin/env bash-## Test that we can repair incorrect adds-##-## Copyright (C) 2012 Ganesh Sittampalam-##-## 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-## SOFTWARE.--. lib--rm -rf bad-mkdir bad-cd bad-darcs init--echo foo > file-darcs add file-mkdir dir-darcs add dir--darcs rec -a -m 'initial'--darcs changes --verbose --patch 'initial'--# produce a corrupt addfile patch-echo 'addfile ./file' > _darcs/patches/pending-echo 'yny' | darcs rec -m 're-add file'--not darcs check-darcs repair-darcs check--# produce a corrupt adddir patch-echo 'adddir ./dir' > _darcs/patches/pending-echo 'yy' | darcs rec -m 're-add dir'--not darcs check-darcs repair-darcs check
− tests/repair-corrupt.sh 
@@ -1,68 +0,0 @@-. lib--rm -rf bad-mkdir bad-cd bad-darcs init--echo foo > bar-darcs add bar-darcs rec -a -m 'foo'--echo hey > foo-darcs add foo-darcs rec -a -m 'more foo'--hashed=false-test -e _darcs/hashed_inventory && hashed=true-cp -R _darcs _clean_darcs--# produce a corrupt patch-echo 'rmfile foo' > _darcs/patches/pending-$hashed || echo -n > _darcs/pristine/foo-darcs rec -a -m 'remove foo'--not darcs check # unapplicable patch!-cp -R _darcs/ _backup_darcs-darcs repair # repairs the patch-darcs check-rm -rf _darcs-mv _backup_darcs _darcs # get the bad patch back--# stash away contents of _darcs-cp -R _darcs/ _backup_darcs--echo here > bar-darcs rec -a -m 'here'--# corrupt pristine content-corrupt_pristine() {-    $hashed && inv=`grep ^pristine _darcs/hashed_inventory`-    cp _backup_darcs/patches/* _darcs/patches/-    cp _backup_darcs/*inventory* _darcs/-    if $hashed; then-        cp _darcs/hashed_inventory hashed.tmp-        sed -e "s,^pristine:.*$,$inv," < hashed.tmp > _darcs/hashed_inventory-        rm hashed.tmp-    fi-}--corrupt_pristine-not darcs check # just a little paranoia--darcs repair # repair succeeds-darcs check # and the resulting repo is consistent--# *AND* it contains what we expect...-darcs show contents bar > foobar-echo foo > foobar1-diff foobar foobar1--rm -rf _backup_darcs-mv _clean_darcs _backup_darcs-corrupt_pristine # without the unapplicable patch-not darcs check-darcs repair-darcs check--cd ..
tests/repair.sh view
@@ -1,22 +1,17 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1-mkdir temp1+darcs init temp1 cd temp1-darcs initialize-echo ALL ignore-times >> _darcs/prefs/defaults echo A1 > foo mkdir d echo A2 > d/bar-darcs add foo-darcs add d-darcs add d/bar-darcs record -a -m AA -A x+darcs record -lam AA echo B > foo-darcs record -a -m BB -A x+darcs record -lam BB echo C > foo-darcs record -a -m CC -A x+darcs record -lam CC  for i in _darcs/pristine*; do   echo Empty the pristine directory: $i@@ -26,5 +21,161 @@  darcs repair +# remove each hashed pristine file one at a time+for f in $(ls _darcs/pristine.hashed/*); do+  rm $f+  not darcs check --no-cache+  darcs repair --no-cache | grep -i "fixing pristine"+done+ cd ..++# issue1977: repair complains when there is no pristine.hashed directory+ rm -rf temp1+darcs init temp1+cd temp1+echo "a" > a+darcs rec -lam a+rm -rf _darcs/pristine.hashed/+darcs repair+cd ..++# check that repair doesn't do anything to a clean repository++rm -rf temp1+darcs init temp1+cd temp1+touch baz+darcs record -lam moo+darcs repair | grep 'already consistent'+cd ..++# We cannot currently implement repair for the darcs-3 format+# because that risks inconsistencies in conflictors that refer+# to removed or added prims. Fixing this requires refactoring+# the API for patch repair and is therefore postponed.++# START DISABLED TESTS for darcs-3+if test "$format" != darcs-3; then++# test that we can repair incorrect adds++rm -rf temp1+darcs init temp1+cd temp1++echo foo > file+mkdir dir+darcs rec -lam 'initial'++# produce a corrupt addfile patch+echo 'addfile ./file' > _darcs/patches/pending+echo 'yny' | darcs rec -m 're-add file'++not darcs check+darcs repair+darcs check++# produce a corrupt adddir patch+echo 'adddir ./dir' > _darcs/patches/pending+echo 'yy' | darcs rec -m 're-add dir'++not darcs check+darcs repair+darcs check+cd ..++# END DISABLED TESTS for darcs-3+fi++# These tests should be fixed but this is hard, since 'darcs record'+# no longer allows recording patches with invalid file paths.++# START DISABLED TESTS+if false; then++# test for repair of a corrupt repository ++rm -rf temp1+darcs init temp1+cd temp1++echo foo > bar+darcs rec -lam 'foo'++echo hey > foo+darcs rec -lam 'more foo'++hashed=false+test -e _darcs/hashed_inventory && hashed=true+cp -R _darcs _clean_darcs++# produce a corrupt patch+echo 'rmfile foo' > _darcs/patches/pending+$hashed || echo -n > _darcs/pristine/foo+darcs rec -a -m 'remove foo'++not darcs check # unapplicable patch!+cp -R _darcs/ _backup_darcs+darcs repair # repairs the patch+darcs check+rm -rf _darcs+mv _backup_darcs _darcs # get the bad patch back++# stash away contents of _darcs+cp -R _darcs/ _backup_darcs++echo here > bar+darcs rec -a -m 'here'++# corrupt pristine content+corrupt_pristine() {+    $hashed && inv=`grep ^pristine _darcs/hashed_inventory`+    cp _backup_darcs/patches/* _darcs/patches/+    cp _backup_darcs/*inventory* _darcs/+    if $hashed; then+        cp _darcs/hashed_inventory hashed.tmp+        sed -e "s,^pristine:.*$,$inv," < hashed.tmp > _darcs/hashed_inventory+        rm hashed.tmp+    fi+}++corrupt_pristine+not darcs check # just a little paranoia++darcs repair # repair succeeds+darcs check # and the resulting repo is consistent++# *AND* it contains what we expect...+darcs show contents bar > foobar+echo foo > foobar1+diff foobar foobar1++rm -rf _backup_darcs+mv _clean_darcs _backup_darcs+corrupt_pristine # without the unapplicable patch+not darcs check+darcs repair+darcs check++cd ..++# END DISABLED TESTS+fi++# issue2001: check (alias for repair --dry-run) is not read-only ++rm -rf temp1+darcs init temp1+cd temp1+mkdir d e+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'+darcs mv d/f e/+darcs record -am 'Move d/f to e/f.'+rm _darcs/pristine.hashed/*     # Make the repository bogus+cp -r _darcs archive+not darcs check --no-cache+diff -r _darcs archive+cd ..
tests/replace.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp mkdir temp@@ -9,15 +9,24 @@  echo "X X X" > foo echo $'A A,A\tA,A\vA' >> foo+echo "aä" >> foo+echo $'\02' >> foo darcs rec -alm "Added"  # These should fail until replace handles tokens and # token-chars with leteral spaces in them-darcs replace ' X ' ' XX ' --token-chars '[ X]' foo && exit 1 || true-darcs replace $'A A'  'aaa' --token-chars '[^,]' foo && exit 1 || true-darcs replace $'A\tA' 'aaa' --token-chars '[^,]' foo && exit 1 || true-darcs replace $'A\vA' 'aaa' --token-chars '[^,]' foo && exit 1 || true+not darcs replace ' X ' ' XX ' --token-chars '[ X]' foo+not darcs replace $'A A'  'aaa' --token-chars '[^,]' foo+not darcs replace $'A\tA' 'aaa' --token-chars '[^,]' foo+not darcs replace $'A\vA' 'aaa' --token-chars '[^,]' foo +# These should fail since darcs cannot handle non-ASCII token chars+# nor non-printable ones+not darcs replace 'X' 'ä' --token-chars '[Xä]' foo+not darcs replace 'ä' 'X' --token-chars '[ä]' foo+not darcs replace $'\02' 'X' --token-chars $'[X\02]' foo+not darcs replace 'X' $'\02' --token-chars $'[X\02]' foo+ # Check that replace is not fooled by duplicate file names # (i.e. not trying to performe the replace twice in the same file) darcs replace X Y foo foo@@ -38,7 +47,7 @@ echo "x" > foo darcs rec -am xx echo "y" > foo-darcs replace --ignore-times x y foo+darcs replace x y foo  # this fails echo "hej" > foo@@ -59,3 +68,34 @@  cd .. rm -rf temp++# replace after pending add++mkdir temp1+cd temp1+darcs init++echo a b a b a b > A+darcs add A+darcs replace a c A > LOG+not grep Skipping LOG+cd ..++rm -fr temp1++# replace after pending mv++mkdir temp1+cd temp1+darcs init++echo a b a b a b > A+darcs add A+darcs record --all --name=p1+darcs mv A B+darcs replace a c B > LOG+not grep Skipping LOG+cd ..++rm -fr temp1+
− tests/replace_after_pending_add.sh 
@@ -1,21 +0,0 @@-#!/usr/bin/env bash--set -ev--rm -fr temp1--mkdir temp1-cd temp1-darcs --version--darcs init--echo a b a b a b > A-darcs add A-if darcs replace a c A | grep Skipping; then-    exit 1-fi-cd ..--rm -fr temp1-
− tests/replace_after_pending_mv.sh 
@@ -1,21 +0,0 @@-#!/usr/bin/env bash--set -ev--rm -fr temp1--mkdir temp1-cd temp1-darcs init--echo a b a b a b > A-darcs add A-darcs record --all --name=p1-darcs mv A B-if darcs replace a c B | grep Skipping; then-    exit 1-fi-cd ..--rm -fr temp1-
tests/repoformat.sh view
@@ -2,44 +2,47 @@  . lib -rm -rf garbage future+rm -rf garbage mkdir garbage cd garbage-darcs  init-echo gobbledygook > _darcs/format+darcs init+echo gobbledygook >> _darcs/format cd .. +rm -rf future mkdir future cd future-darcs  init+darcs init touch titi darcs add titi darcs record -am titi-cat > _darcs/format <<EOF-hashed|gobbledygook-darcs-2-EOF+sed -i 's/hashed/hashed|gobbledygook/' _darcs/format cd .. +corrupt_format_file() {+  # mimic format file corruption as in issue2650+  sed -i 's/gobbledygook/Unknown format: gobbledygook/' $1/_darcs/format+}  # check the rules for reading and writing +test_garbage() { ## garbage repo: we don't understand anything-# get garbage repo+rm -rf temp1 not darcs get garbage temp1 2> log-grep -i "can't understand repository format" log-rm -rf temp1 log+grep -i "read repository.*unknown format" log  # pull from garbage repo+rm -rf temp1 mkdir temp1 cd temp1 darcs init not darcs pull ../garbage 2> log-grep -i "can't understand repository format" log+grep -i "read repository.*unknown format" log cd ..-rm -rf temp1  # apply in garbage repo+rm -rf temp1 mkdir temp1 cd temp1 darcs init@@ -48,53 +51,71 @@ darcs send -a --context=empty-context -o ../bundle.dpatch . cd ../garbage not darcs apply ../bundle.dpatch 2> log-grep -i "can't understand repository format" log+grep -i "read repository.*unknown format" log cd ..-rm -rf temp1 bundle.dpatch  # add in garbage repo cd garbage touch toto++cp _darcs/format before not darcs add toto 2> log-grep -i "can't understand repository format" log+grep -i "read repository.*unknown format" log+diff before _darcs/format # issue2650 cd .. -rm -rf garbage+# rebase suspend in garbage repo+cd garbage+cp _darcs/format before+not darcs rebase suspend --last=1 2> log+grep -i "read repository.*unknown format" log+diff before _darcs/format # issue2650+cd ..+} +test_garbage -## future repo: we don't understand one-#  alternative of a line of format-#  only look at future vs darcs2+# corrupt once+corrupt_format_file garbage+test_garbage+# corrupt multiple times+corrupt_format_file garbage+corrupt_format_file garbage+test_garbage -if grep 'old-fashioned' .darcs/defaults; then-    exit 200-fi -if grep hashed .darcs/defaults; then-    exit 200-fi+## future repo: we don't understand one+#  alternative of a line of format +test_future () { # get future repo: ok # --to-match is needed because of bug###+rm -rf temp1 darcs get future temp1 --to-match "name titi"+# fresh clone should fix corrupt format cd temp1+not grep 'Unknown format' _darcs/format # issue2650 darcs changes+not grep 'Unknown format' _darcs/format # issue2650 touch toto darcs add toto+not grep 'Unknown format' _darcs/format # issue2650 darcs record -am 'blah'+not grep 'Unknown format' _darcs/format # issue2650 cd ..-rm -rf temp1  # pull from future repo: ok+rm -rf temp1 mkdir temp1 cd temp1 darcs init darcs pull ../future -a-darcs cha | grep titi+darcs changes | grep titi+not grep 'Unknown format' _darcs/format # issue2650 cd ..-rm -rf temp1  # apply in future repo: !ok+rm -rf temp1 mkdir temp1 cd temp1 darcs init@@ -102,17 +123,35 @@ darcs tag -m "just a patch" darcs send -a --context=empty-context -o ../bundle.dpatch . cd ../future+cp _darcs/format before not darcs apply ../bundle.dpatch 2> log cat log-grep -i "can't write repository format" log+grep -i "write repository.*unknown format" log+diff before _darcs/format # issue2650 cd ..-rm -rf temp1 bundle.dpatch  # record in future repo: !ok cd future touch toto not darcs add toto 2> log-grep -i "can't write repository format" log+grep -i "write repository.*unknown format" log cd .. -rm -rf future #No future!+# rebase suspend in future repo+cd future+cp _darcs/format before+not darcs rebase suspend --last=1 2> log+grep -i "write repository.*unknown format" log+diff before _darcs/format # issue2650+cd ..+}++test_future++# corrupt once+corrupt_format_file future+test_future+# corrupt multiple times+corrupt_format_file future+corrupt_format_file future+test_future
+ tests/resolve-conflicts-explicitly.sh view
@@ -0,0 +1,68 @@+#!/usr/bin/env bash+# Test that we can resolve a conflict by explicitly depending on+# the conflicting patches, thereby accepting the "default" resolution+# (i.e. not to apply both) as correctly resolving the conflict.++. lib++rm -rf R S+darcs init R+cd R+touch file+darcs record -lam baseline+echo one > file+darcs record -a -m one+darcs clone . ../S+echo two > file+echo y | darcs amend -a -m two+darcs pull -a --allow-conflicts ../S+# make sure we have none of the changes:+test -z "$(cat file)"+# resolve by depending on the last two patches:+echo yyd | darcs record --ask-deps -m resolve_explicitly+darcs mark-conflicts > LOG 2>&1+grep "No conflicts" LOG+not darcs whatsnew+cd ..++# Test that an explicit dependency on a patch containing a+# partial conflict resolution does not turn it into a resolution+# of an unrelated conflict contained the same patch.++rm -rf R S+darcs init R+cd R+touch file1+touch file2+darcs record -lam baseline+echo one > file1+echo one > file2+darcs record -am one+darcs clone . ../S+echo two > file1+echo two > file2+echo y | darcs amend -a -m two+darcs pull -a --allow-conflicts ../S+# make sure we have none of the changes:+test -z "$(cat file1)"+test -z "$(cat file2)"+# resolve (only) the conflict in file1+echo three > file1+darcs record -a -m resolve_file1+# test this indeed resolves only the conflict in file1+darcs mark-conflicts > LOG 2>&1+grep 'Marking conflicts' LOG+grep 'file2' LOG+not grep 'file1' LOG+not darcs whatsnew file1+# remove the markup+darcs revert -a+# explicitly depend on the partial resolution+echo yyd | darcs record --ask-deps -m explicit+# test resolution is still only partial+darcs mark-conflicts > LOG 2>&1+grep 'Marking conflicts' LOG+grep 'file2' LOG+not grep 'file1' LOG+not darcs whatsnew file1+cd ..
+ tests/revert.sh view
@@ -0,0 +1,88 @@+#!/usr/bin/env bash+. ./lib++rm -rf temp1+mkdir temp1+cd temp1+darcs init+echo hello world > foo+darcs add foo+darcs record -lam add+echo goodbye world >> foo+darcs revert -a+darcs show contents foo | cmp foo -++# Now let's test a trickier revert where changes commute nontrivially.++cat > foo <<EOF+a+b+c+d+e+EOF++darcs record -am cleanup++mv foo foo.tmp+cat foo.tmp | grep -v b | grep -v d > foo++echo "nyy" | darcs revert++darcs wh > whatsnew+cat > correct <<EOF+hunk ./foo 2+-b+EOF+diff -c correct whatsnew++# Try a situation where earlier (kept) changes are depended upon by the+# changes we want to revert:++darcs record -am cleanup++echo hello world > bar+echo hello world > foo+darcs add bar+darcs replace hello goodbye bar foo++# revert only the last of 4 changes which is the replace in ./foo+echo "nnnyy" | darcs revert++darcs wh > whatsnew+cat > correct <<EOF+addfile ./bar+hunk ./bar 1++goodbye world+hunk ./foo 1+-a+-c+-d+-e++hello world+EOF+diff -c correct whatsnew++cd ..+rm -rf temp1++# test for reverting removed directory++darcs init temp1+cd temp1+mkdir d+darcs add d+darcs record -lam 'add dir'+rmdir d+darcs revert -a d+cd ..+rm -rf temp1++# revert unrecorded add++darcs init temp1+cd temp1+echo stuff > foo+darcs add foo+darcs revert -a+
− tests/revert_interactive.sh 
@@ -1,67 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo hello world > foo-darcs add foo-darcs record -a -m add -A x-echo goodbye world >> foo-echo y/y | tr / \\012 | darcs revert-darcs show contents foo | cmp foo ---# Now let's test a trickier revert where changes commute nontrivially.--cat > foo <<EOF-a-b-c-d-e-EOF--darcs record -a -A me -m cleanup--mv foo foo.tmp-cat foo.tmp | grep -v b | grep -v d > foo--echo "nyy" | darcs revert--DARCS_DONT_COLOR=1 darcs wh > whatsnew-cat > correct <<EOF-hunk ./foo 2--b-EOF-diff -c correct whatsnew--# Try a situation where earlier (kept) changes are depended upon by the-# changes we want to revert:--darcs record -a -A me -m cleanup--echo hello world > bar-echo hello world > foo-darcs add bar-darcs replace hello goodbye bar foo--echo "cnnnyy/y" | tr / \\012 | darcs revert--DARCS_DONT_COLOR=1 darcs wh > whatsnew-cat > correct <<EOF-addfile ./bar-hunk ./bar 1-+goodbye world-hunk ./foo 1--a--c--d--e-+hello world-EOF-diff -c correct whatsnew--cd ..-rm -rf temp1-
− tests/revert_unrecorded_add.sh 
@@ -1,13 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp-mkdir temp-cd temp--darcs init--echo stuff > foo-darcs add foo--darcs revert -a
tests/rmconflict.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf tempA tempB mkdir tempA tempB
− tests/rmdir-formerly-pl.sh 
@@ -1,32 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init-mkdir foo-echo hello world > foo/bar-echo hello world > foo/baz-mkdir foo/dir-darcs add foo foo/bar foo/dir foo/baz-darcs record -a -m add-rm -rf  foo-darcs show files --no-pending --no-dir > log-grep 'foo/baz' log-grep 'foo/bar' log-darcs show files --no-pending --no-fil > log-grep 'foo/dir' log-grep 'foo$'    log-# now without...-darcs record -a -m del-darcs show files --no-pending --no-dir > log-not grep 'foo/baz' log-not grep 'foo/bar' log-darcs show files --no-pending --no-fil > log-not grep 'foo/dir' log-not grep 'foo$'    log-cd ..--rm -rf temp1
tests/rmdir.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 temp2 temp3 @@ -36,7 +36,7 @@ grep foo dirs cd .. -darcs pull -a --repodir=temp2 > pullresult+darcs pull -a --repodir=temp2 2> pullresult cat pullresult grep 'Warning: .ot deleting' pullresult @@ -63,3 +63,18 @@ test ! -s pullresult  rm -rf temp1 temp2 temp3+++# issue1749 - darcs remove <dir> corrupts the patch sequence+darcs init temp1+cd temp1+mkdir dir+touch dir/file+darcs rec -lam "add dir and file"+not darcs remove dir+# removed dir but not file - should be nothing to add+not darcs rec -a -m"remove dir"+darcs obliterate -a --patch "remove dir" | grep 'No patches selected!'+darcs check+cd ..+rm -rf temp1
− tests/rollback-no-record.sh 
@@ -1,67 +0,0 @@-#!/usr/bin/env bash-## Test for rollback --no-record-##-## Copyright (C) 2010 Florent Becker-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.-darcs init      --repo S--cd R-mkdir d e-echo 'Example content.' > d/f-darcs record -lam 'Add d/f and e.'-darcs mv d/f e/-darcs replace Example Kestatepa e/f-echo "Blih blah bloh" >> e/f-darcs record -am 'Some changes.'--cat <<EOF >> e/f--Kestatepa--EOF--cat e/f-darcs record -am 'one more line in f'-darcs changes --context > context-darcs rollback -a -p 'Some changes' -m 'rollback'-darcs send -a -o rollback.dpatch --context context ../S-darcs obliterate -a -p rollback-darcs rollback -a -p 'Some changes' --no-record-darcs record -am 'rollback'-darcs send -a -o rollback2.dpatch --context context ../S--#check the effects-not ls e/f-ls d/f-grep Example d/f-not grep "Blih" d/f--#check the content of the patches-#"diff rollback.dpatch rollback2.dpatch" fails because of-#the order of the hunks.-grep "replace .* Kestatepa Example" rollback2.dpatch-grep "move ./e/f ./d/f" rollback2.dpatch-grep -e "-Blih blah bloh" rollback2.dpatch-
− tests/rollback-nothing.sh 
@@ -1,16 +0,0 @@-#!/usr/bin/env bash--set -ev--rm -rf temp-mkdir temp-cd temp-darcs init-date > file1-darcs add file1-darcs record -am "test"-rm file1-darcs record -am "rm"-echo yd | darcs rollback --last=1 -m 'oops' | grep 'No changes selected'-cd ..-rm -rf temp
tests/rollback.sh view
@@ -1,34 +1,51 @@-#!/bin/bash+#!/usr/bin/env bash -set -ev+. ./lib -range="0 1 2"+# rollback nothing -rm -rf temp1 temp2              # clean up when previous run crashed-mkdir temp1 && cd temp1 && darcs init-touch f && darcs add f-for i in $range-do-  echo $i > f && darcs record -A me --ignore-time -m p$i --all f-done+rm -rf temp1+darcs init temp1+cd temp1+date > file1+darcs record -lam "test"+rm file1+darcs record -am "rm"+echo yYd | tr [A-Z] [a-z] | darcs rollback --last=1 | grep 'No changes selected'+cd ..+rm -rf temp1 -cd .. && mkdir temp2 && cd temp2 && darcs init+# issue1848 - interactive selection of primitive patches+# should still work with rollback -p -set -x+darcs init temp1+cd temp1+echo 'f' > f+echo 'g' > g+darcs record -lam 'Add f and g'+echo ynq | darcs rollback -p 'f and g'+cd ..+rm -rf temp1 -: Demonstrate problem with regrem-for i in $range-do-  darcs pull --patch p$i ../temp1 --all-  if darcs whatsnew ; then-      : Resolve conflict - rollback our patch-      darcs revert --all-      darcs rollback -a --name x0-      darcs revert --all-  fi-  : Create local change and record it-  echo X$i > f && darcs record -l -A me --ignore-time -m x$i --all f-done+# issue2242 - rollback of a mv patch generates bogus changes +darcs init temp1+cd temp1++# Setup dir with empty file in it+mkdir A+touch A/foo+darcs rec -alm 'Add A'++# Mv dir and add content to file+darcs mv A B+echo -e 'line1\nline2' > B/foo+darcs rec -alm 'Move A -> B and change foo'++# Rollback everything in the move/change patch+echo ynya | darcs roll++# We shouldn't see any rm'd dirs/files (just a move and line removal hunk)+darcs wh | not grep rm cd ..-rm -rf temp1 temp2+rm -rf temp1
tests/sametwice.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 temp2 mkdir temp1@@ -8,7 +8,6 @@ echo record author me > _darcs/prefs/defaults echo ALL all >> _darcs/prefs/defaults echo ALL verbose >> _darcs/prefs/defaults-echo ALL ignore-times >> _darcs/prefs/defaults touch foo darcs add foo darcs whatsnew
tests/send-dont-prompt-deps.sh view
@@ -1,6 +1,6 @@ #!/usr/bin/env bash -set -ev+. ./lib  # Check that the right patches get sent using --dont-prompt-for-dependencies @@ -21,12 +21,12 @@ darcs record -Ax -alm foo2 echo bar2 > b darcs record -Ax -alm bar2-echo y | darcs send ../temp2 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto+echo yy | darcs send ../temp2 -i --dont-prompt-for-dependencies -p foo2 --dry-run > toto #on the previous line, we get asked about foo2, and we take it grep foo2 toto | wc -l | grep 2 #we don't get asked about foo1, but we take it anyway, so  grep foo1 toto | wc -l | grep 1 #and we don't send bar-grep bar toto | wc -l | grep 0+not grep bar toto cd .. rm -rf temp1 temp2
tests/send-encoding.sh view
@@ -37,6 +37,6 @@ darcs record -lam 'file1'  LANG=en_GB.UTF-8 \- EDITOR='echo Non-ASCII chars: é è ề Ψ ޡ ߐ ह ჴ Ᏻ ‱ ⁂ ∰ ✈ ⢅ .. >' \+ DARCS_EDITOR='echo Non-ASCII chars: é è ề Ψ ޡ ߐ ह ჴ Ᏻ ‱ ⁂ ∰ ✈ ⢅ .. >' \    darcs send -a ../empty --to=invalid@invalid --edit \       --sendmail-command='grep "Content-Type: text/plain; charset=\"utf-8\"" %<'
tests/send-external.sh view
@@ -1,8 +1,5 @@ #!/usr/bin/env bash-set -ev--DARCS_EDITOR=echo-export DARCS_EDITOR+. ./lib  rm -rf temp1 temp2 mkdir temp1 temp2@@ -17,38 +14,14 @@ darcs add foobar darcs rec -a -m add-foobar -cat > saveit.sh <<EOF-#!/bin/sh-# send-mail1.sh: Test sendmail command for darcs send 1-# 2008-Oct-06 22.25 / TN-set -ev-echo all: \$0 "\$@" >>saved.out-echo \$6 contains: >>saved.out-ls -ltr >>saved.out-cat "\$6" >>saved.out-echo End of \$6 contents >>saved.out-grep add-foobar \$6-CNT=0-while [ "\$#" != "0" ]; do-  CNT=`expr \$CNT + 1`-  echo \$0: arg[\$CNT] = \"\$1\" >>saved.out-  shift-done-echo \$0: Total \$CNT arguments >>saved.out-echo \$0: Input: >>saved.out-cat >>saved.out-echo \$0: End of input: >>saved.out-EOF--chmod +x saveit.sh+cp $TESTBIN/sendmail.hs . -# foobar-darcs send --author=me -a --to=random@random \-    --sendmail-command='bash ./saveit.sh %s %t %c %b %f %a %S %t %C %B %F %A something' ../temp2+darcs send --mail \+    --author=me -a --to=random@random \+    --sendmail-command="runghc sendmail.hs %s %t %c %b %f %a %S %T %C %B %F %A something" ../temp2  cat saved.out grep add-foobar saved.out grep 'addfile ./foobar' saved.out  cd ..-rm -rf temp1 temp2
tests/send-output-v1.sh view
@@ -26,7 +26,7 @@  . lib                  # Load some portability helpers. -grep old-fashioned $HOME/.darcs/defaults || grep hashed $HOME/.darcs/defaults || exit 200+only-format darcs-1  rm -rf empty mkdir empty@@ -35,19 +35,18 @@ cd ..  rm -rf repo-gunzip -c $TESTDATA/simple-v1.tgz | tar xf -+unpack_testdata simple-v1 cd repo-darcs send -o repo.dpatch -a ../empty+darcs send --no-minimize -o repo.dpatch -a ../empty -day=$(grep "<.*@.*>" $TESTDATA/simple-v1.dpatch | head -n 1 | cut -f1-3 -d' ')-diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/simple-v1.dpatch repo.dpatch+compare_bundles $TESTDATA/simple-v1.dpatch repo.dpatch cd ..  # context-v1 tests that we are including some context lines in hunk patches rm -rf repo-gunzip -c $TESTDATA/context-v1.tgz | tar xf -+unpack_testdata context-v1 cd repo-darcs send -o repo.dpatch -a ../empty-day=$(grep "<.*@.*>" $TESTDATA/context-v1.dpatch | head -n 1 | cut -f1-3 -d' ')-diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/context-v1.dpatch repo.dpatch+darcs send --no-minimize -o repo.dpatch -a ../empty++compare_bundles $TESTDATA/context-v1.dpatch repo.dpatch cd ..
tests/send-output-v2.sh view
@@ -26,7 +26,7 @@  . lib                  # Load some portability helpers. -grep darcs-2 $HOME/.darcs/defaults || exit 200+only-format darcs-2  rm -rf empty mkdir empty@@ -35,20 +35,17 @@ cd ..  rm -rf repo-gunzip -c $TESTDATA/simple-v2.tgz | tar xf -+unpack_testdata simple-v2 cd repo-darcs send -o repo.dpatch -a ../empty+darcs send --no-minimize -o repo.dpatch -a ../empty -day=$(grep "<.*@.*>" $TESTDATA/simple-v2.dpatch | head -n 1 | cut -f1-3 -d' ')-diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/simple-v2.dpatch repo.dpatch+compare_bundles $TESTDATA/simple-v2.dpatch repo.dpatch cd .. -# context-v1 tests that we are including some context lines in hunk patches+# context-v2 tests that we are including some context lines in hunk patches rm -rf repo-gunzip -c $TESTDATA/context-v2.tgz | tar xf -+unpack_testdata context-v2 cd repo-darcs send -o repo.dpatch -a ../empty--day=$(grep "<.*@.*>" $TESTDATA/context-v2.dpatch | head -n 1 | cut -f1-3 -d' ')-diff -u -I'1 patch for repository ' -I'patches for repository ' -I"$day" $TESTDATA/context-v2.dpatch repo.dpatch+darcs send --no-minimize -o repo.dpatch -a ../empty+compare_bundles $TESTDATA/context-v2.dpatch repo.dpatch cd ..
tests/send.sh view
@@ -1,8 +1,5 @@ #!/usr/bin/env bash-set -ev--DARCS_EDITOR=echo-export DARCS_EDITOR+. ./lib  rm -rf temp1 temp2 mkdir temp1 temp2@@ -33,20 +30,26 @@  # Test that the --output-auto-name parameter outputs what we expect darcs send --author=me -a --subject="it works" --output test1.dpatch ../temp2-darcs send --author=me -a --subject="it works" --output-auto-name ../temp2-cmp test1.dpatch add_foo_bar.dpatch+# explicitly given output filename overwrites an existing file+darcs send --author=me -a --subject="it works" --output test1.dpatch ../temp2 > LOG+grep "Wrote patch to" LOG | grep -F test1.dpatch+# but --output-auto-name never does+darcs send --author=me -a --subject="it works" --output-auto-name ../temp2 > LOG+name=$(grep "Wrote patch to" LOG | grep -ho 'add_foo_bar.*\.dpatch')+cmp test1.dpatch "$name"  # test --output-auto-name works with optional argument. mkdir patchdir-darcs send --author=me -a --subject="it works" --output-auto-name=patchdir ../temp2-cmp test1.dpatch patchdir/add_foo_bar.dpatch+darcs send --author=me -a --subject="it works" --output-auto-name=patchdir ../temp2 > LOG+name=$(grep "Wrote patch to" LOG | grep -ho 'patchdir/add_foo_bar.*\.dpatch')+cmp test1.dpatch "$name"  # checking --output-auto-name=dir when run in different directory cd patchdir-rm add_foo_bar.dpatch-darcs send --author=me -a --subject="it works" --output-auto-name=. ../../temp2-cmp ../test1.dpatch add_foo_bar.dpatch+rm add_foo_bar*.dpatch+darcs send --author=me -a --subject="it works" --output-auto-name=. ../../temp2 > LOG+name=$(grep "Wrote patch to" LOG | grep -ho 'add_foo_bar.*\.dpatch')+cmp ../test1.dpatch "$name" cd ..  cd ..-rm -rf temp1 temp2
tests/send_apply.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 temp2 mkdir temp1 temp2
tests/set-default-hint.sh view
@@ -35,17 +35,20 @@ cd R3 for command in pull push send do+   opt=+   test "$command" = "send" && opt=-O+    # R1 should be the default for R3-   darcs $command ../R1 | not grep "$HINTSTRING"-   darcs $command ../R2 | grep "$HINTSTRING"+   darcs $command $opt ../R1 | not grep "$HINTSTRING"+   darcs $command $opt ../R2 | grep "$HINTSTRING"     # can disable message on the command-line-   darcs $command --no-set-default ../R2 | not grep "$HINTSTRING"+   darcs $command $opt --no-set-default ../R2 | not grep "$HINTSTRING"     # or using defaults    echo "$command no-set-default" >> ../.darcs/defaults-   darcs $command ../R2 | not grep "$HINTSTRING"+   darcs $command $opt ../R2 | not grep "$HINTSTRING" -   darcs $command --set-default ../R2 | not grep "$HINTSTRING"-   darcs $command --set-default ../R1 | not grep "$HINTSTRING"+   darcs $command $opt --set-default ../R2 | not grep "$HINTSTRING"+   darcs $command $opt --set-default ../R1 | not grep "$HINTSTRING" done
− tests/several_commands.sh 
@@ -1,25 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo hello world > foo-darcs add foo-darcs record -a -m add -A x-echo goodbye world >> foo-darcs diff-darcs diff -u-darcs whatsnew-darcs whatsnew --summary-echo y | darcs revert -a-darcs show contents foo | cmp foo --mkdir d-darcs add d-darcs record -a -m 'add dir' -A x-rmdir d-darcs revert -a d-cd ..-rm -rf temp1-
tests/show-authors.sh view
@@ -1,23 +1,26 @@ #!/usr/bin/env bash-set -ev+. ./lib -darcs init+rm -rf R++darcs init --repo R+cd R+ echo zig > foo darcs add foo darcs record -a -m add_foo -A x+ echo zag >> foo darcs record -a -m mod_foo -A y+ echo bar > foo darcs record -a -m mod2 -A y  darcs show authors > authors-grep x authors-grep y authors+grep "#1	2	y" authors+grep "#2	1	x" authors -head -1 authors > first-author-grep y first-author+head -1 authors | grep y  darcs show authors --verbose-darcs show authors --verbose | grep y | wc -l > num-patches-cat num-patches-grep 2 num-patches+[[ $(darcs show authors --verbose | grep y | wc -l) -eq 2 ]]
− tests/show-bug.sh 
@@ -1,22 +0,0 @@-#!/usr/bin/env bash--## All these commands SHOULD fail (hence leading NOTs).-. lib--darcs show bug --debug 1> stdout 2> stderr || true--cat stdout-cat stderr--echo The following test will fail if this version of darcs is marked as-echo obsolete.-echo ==================================================================--not grep 'please do not' stderr--# The following test fails if HTTP isn't present, but would be a nice test-# to have in place.--#not grep unable stderr--grep 'fake bug' stderr
+ tests/show-removed-file.sh view
@@ -0,0 +1,53 @@+#!/usr/bin/env bash+## Test that 'show files --hash' acts as expected+## when selecting changes up to a given patch+##+## Copyright (C) 2015  Ben Franksen+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+darcs init      --repo R        # Create our test repos.++cd R++touch f+darcs add f+darcs record -am 'add f'+hash1=$(darcs log --last=1 | grep '^patch' | cut -d ' ' -f 2)+darcs show files > add-f.1++rm f+darcs record -am 'removed f'+darcs show files --hash $hash1 --no-pending > add-f.2+diff add-f.1 add-f.2++mkdir d+touch d/f+darcs add d/f+darcs record -am 'add d/f'+hash2=$(darcs log --last=1 | grep '^patch' | cut -d ' ' -f 2)+darcs show files > add-df.1++rm -rf d+darcs record -am 'removed d and d/f'+darcs show files --hash $hash2 --no-pending > add-df.2+diff add-df.1 add-df.2
tests/show_contents.sh view
@@ -22,8 +22,46 @@ darcs show contents foo --match="author author1" first | grep first darcs show contents foo --tag t1 | grep second not darcs show contents foo --match "hash bla" 2>&1 | tee out-grep "Couldn't match pattern" out+grep '"hash bla"' out darcs show contents -n 2 foo | grep third cd .. +rm -rf temp1++## issue1705 - darcs show contents --index=1 => darcs failed:  Pattern not specified in get_nonrange_match++darcs init temp1+cd temp1+echo 111 > 1+darcs record -lam 'add file 1'+darcs show contents --index=1 1+cd ..+rm -rf temp1++## issue2447 - get contents of deleted file ++darcs init temp1+cd temp1++echo 'example content' > f+darcs record -lam 'add f'+hash1=$(darcs log --last=1 | grep '^patch' | cut -d ' ' -f 2)+rm f+darcs record -am 'removed f'+darcs show contents --hash $hash1 f | grep 'example content'++mkdir d+echo 'example content' > d/f+darcs record -lam 'add d/f'+hash2=$(darcs log --last=1 | grep '^patch' | cut -d ' ' -f 2)+rm d/f+darcs record -am 'removed d/f'+darcs show contents --hash $hash2 d/f | grep 'example content'++darcs obliterate -a --last=1++rm -rf d+darcs record -am 'removed d and d/f'+darcs show contents --hash $hash2 d/f | grep 'example content'+cd .. rm -rf temp1
+ tests/show_files.sh view
@@ -0,0 +1,115 @@+#!/usr/bin/env bash+. ./lib++check_manifest () {+    : > files.tmp+    echo . > dirs.tmp+    echo . > files-dirs.tmp+    for x in $1 ; do+	echo "./$x" >> files.tmp+	echo "./$x" >> files-dirs.tmp+    done+    for x in $2 ; do+	echo "./$x" >> dirs.tmp+	echo "./$x" >> files-dirs.tmp+    done+    darcs show files $3 --files --no-directories > darcsraw-files.tmp+    darcs show files $3 --no-files --directories > darcsraw-dirs.tmp+    darcs show files $3 --files --directories > darcsraw-files-dirs.tmp+    for x in files dirs files-dirs ; do+        sort $x.tmp | sed -e 's,\\,/,' > expected-$x.tmp+        sort darcsraw-$x.tmp | sed -e 's,\\,/,' > darcs-$x.tmp+        diff -u expected-$x.tmp darcs-$x.tmp+    done }++rm -rf temp+mkdir temp+cd temp+darcs init++check_manifest "" "" "--no-pending"+check_manifest "" "" "--pending"+touch a b+darcs add a+check_manifest "" "" "--no-pending"+check_manifest "a" "" "--pending"+darcs add b+mkdir c+check_manifest "" "" "--no-pending"+check_manifest "a b" "" "--pending"+darcs add c+touch c/1 c/2+check_manifest "" "" "--no-pending"+check_manifest "a b" "c" "--pending"+darcs add c/1 c/2+check_manifest "" "" "--no-pending"+check_manifest "a b c/1 c/2" "c" "--pending"+mkdir d+touch d/3 d/4+darcs add d/3 d/4+check_manifest "" "" "--no-pending"+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending"+darcs record --all --name "patch 1" --skip-long-comment+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--pending"++darcs mv d e+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending"+rm c/1+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/1 c/2 e/3 e/4" "c e" "--pending"+darcs remove c/1+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/2 e/3 e/4" "c e" "--pending"+darcs mv c/2 c/1+check_manifest "a b c/1 c/2 d/3 d/4" "c d" "--no-pending"+check_manifest "a b c/1 e/3 e/4" "c e" "--pending"+darcs record --all --name "patch 2" --skip-long-comment+check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending"+check_manifest "a b c/1 e/3 e/4" "c e" "--pending"++darcs remove c/1+check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending"+check_manifest "a b e/3 e/4" "c e" "--pending"+darcs remove c+check_manifest "a b c/1 e/3 e/4" "c e" "--no-pending"+check_manifest "a b e/3 e/4" "e" "--pending"+darcs record --all --name "patch 3" --skip-long-comment+check_manifest "a b e/3 e/4" "e" "--no-pending"+check_manifest "a b e/3 e/4" "e" "--pending"++darcs mv b b2+darcs mv b2 b3+check_manifest "a b e/3 e/4" "e" "--no-pending"+check_manifest "a b3 e/3 e/4" "e" "--pending"+darcs record --all --name "patch 3" --skip-long-comment+check_manifest "a b3 e/3 e/4" "e" "--no-pending"+check_manifest "a b3 e/3 e/4" "e" "--pending"++cd ..++rm -rf R+darcs init --repo R+cd R++for file in foo bar baz quux+do+    touch "$file"+    darcs add "$file"+    darcs record --all --name "Add $file"+done++darcs unrecord --all --patches "quux"+darcs rebase suspend --all --patches "foo"++# (pending, match): (False, False)+check_manifest "bar baz" "" "--no-pending"+# (pending, match): (False, True)+check_manifest "bar" "" "--no-pending --patch bar"+# (pending, match): (True, False)+check_manifest "bar baz quux" "" "--pending"+# (pending, match): (True, True)+not darcs show files --pending --patch "bar"++cd ..
− tests/show_tags-remote.sh 
@@ -1,46 +0,0 @@-#!/usr/bin/env bash-## Test for show tags --repo-##-## Copyright (C) 2010 Eric Kow-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-darcs init      --repo R        # Create our test repos.-darcs init      --repo S--cd R-echo 'Example content.' > f-darcs record -lam 'Add f'-darcs tag 't0'-darcs tag 't1'-darcs show tags | grep t0-cd ..-serve_http # sets baseurl--cd S-darcs changes --repo ../R-darcs show tags --repo ../R | grep t0-darcs show tags --repo $baseurl/R | grep t0-cd ..--darcs show tags --repo R | grep t0-darcs show tags --repo $baseurl/R | grep t0
tests/show_tags.sh view
@@ -1,11 +1,10 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 mkdir temp1 cd temp1 darcs initialize-echo ALL ignore-times >> _darcs/prefs/defaults echo A > foo darcs add foo darcs record -a -m AA -A x@@ -29,7 +28,7 @@ 1.0 EOF -cmp my ref+diff --strip-trailing-cr my ref cd ..  rm -rf temp1
− tests/sigPIPE.sh 
@@ -1,34 +0,0 @@-#!/usr/bin/env bash-set -ev--DARCS_EDITOR=echo-export DARCS_EDITOR--rm -rf temp1-mkdir temp1--cd temp1-darcs init--echo hello world > foo-darcs add foo-darcs record -a --author=me -m "First patch"-i=1-while test $i -le 100; do-  echo foo $i > foo;-  darcs record --ignore-times -a --author=me -m "Patch $i" > bar-  i=`expr $i + 1`-done-darcs tag --author=me -m 'silly tag'-i=1000-while test $i -le 1096; do-  echo foo $i > foo;-  darcs record --ignore-times -a --author=me -m "Patch $i" > bar-  i=`expr $i + 1`-done--darcs --version-darcs changes | head--cd ..-# rm -rf temp1
tests/split-patches.sh view
@@ -26,19 +26,16 @@  . lib                  # Load some portability helpers. -if grep old-fashioned .darcs/defaults; then-format=old-fashioned-inventory-patchtype=darcs-1-elif grep darcs-2 .darcs/defaults; then+if grep darcs-2 .darcs/defaults; then format=darcs-2 patchtype=darcs-2-elif grep hashed .darcs/defaults; then+elif grep darcs-1 .darcs/defaults; then format=hashed patchtype=darcs-1 else exit 200; fi  rm -rf split--${format}-gunzip -c $TESTDATA/split--${format}.tgz | tar xf -+unpack_testdata split--${format} cd split--${format} darcs check cd ..
− tests/steve_and_monica_rollback.sh 
@@ -1,38 +0,0 @@-#!/bin/bash--#  Issue578: A conflict rollback case for Darcs2--set -ev--rm -rf tmp_steve tmp_monica--mkdir tmp_steve-mkdir tmp_monica--cd tmp_steve-darcs init  --darcs-2-echo A >foo-darcs add foo-darcs record -Asteve -am 'Anote'--echo B >foo-darcs record -Asteve -am 'Bnote'--# Show the history as Steve sees it.-darcs changes -s-echo "######"--cd ../tmp_monica-darcs init --darcs-2-echo A>foo-darcs add foo-echo Z>bar-darcs add bar-darcs record -Amonica -am 'AZnote'-darcs pull -a ../tmp_steve-darcs changes-echo "######"-darcs rollback -a -m newpatch -A me --match 'exact Anote'--# previous failure result: darcs failed:  cannot roll back a 'rollback' patch.-
+ tests/switch-encoding.sh view
@@ -0,0 +1,89 @@+. lib++switch_to_utf8_locale+lc_utf8=$LC_ALL++rm -rf E U++darcs init E+darcs clone E U++cd U+mkdir Texte+echo 'Müßiggang' > 'Texte/böse Zeichen'+darcs record -lam 'Erste Änderung'+darcs log -v+darcs send -ao bundle+tail -n+7 bundle > u_bundle++LC_ALL=C++darcs log -v+darcs send -ao bundle+tail -n+7 bundle > c_bundle++diff u_bundle c_bundle++darcs apply u_bundle | grep 'already .*applied'+darcs obliterate -a+darcs apply u_bundle | grep 'Finished applying'+darcs unrecord -a+darcs revert -a+darcs apply u_bundle | grep 'Finished applying'+++LC_ALL=$lc_utf8++darcs apply c_bundle | grep 'already .*applied'+darcs obliterate -a+darcs apply c_bundle | grep 'Finished applying'+darcs unrecord -a+darcs revert -a+darcs apply c_bundle | grep 'Finished applying'++LC_ALL=C++cd ..++darcs clone U C+diff -r U/Texte C/Texte++cd C+darcs pull ../E --set-default++darcs apply ../U/u_bundle | grep 'already .*applied'+diff -r ../U/Texte Texte+darcs obliterate -ao ou_bundle+diff ../U/u_bundle ou_bundle+darcs apply ou_bundle | grep 'Finished applying'+diff -r ../U/Texte Texte+darcs unrecord -a+darcs revert -a+darcs pull ../U -a+diff -r ../U/Texte Texte+darcs send -ao bundle+tail -n+7 bundle > c_bundle++LC_ALL=$lc_utf8++darcs send -ao bundle+tail -n+7 bundle > u_bundle+diff u_bundle c_bundle++darcs apply c_bundle | grep 'already .*applied'+diff -r ../U/Texte Texte+darcs obliterate -ao oc_bundle+diff c_bundle oc_bundle+darcs apply c_bundle | grep 'Finished applying'+diff -r ../U/Texte Texte+darcs unrecord -a+darcs revert -a+darcs pull ../U -a+diff -r ../U/Texte Texte+darcs send -ao bundle+tail -n+7 bundle > c_bundle++cd ..++diff U/u_bundle C/u_bundle+diff -r U/Texte C/Texte
+ tests/tag-ask-deps.sh view
@@ -0,0 +1,51 @@+#!/bin/sh -e+##+## Basic test of tag --ask-deps+##+## Copyright (C) 2014 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R S++mkdir R+cd R++darcs init++touch file1+darcs rec -lam 'file1'++touch file2+darcs rec -lam 'file2'++echo 'nyy' | darcs tag --ask-deps file1++cd ..++darcs get --tag file1 R S++cd S+test -f file1+test ! -f file2+
tests/tag.sh view
@@ -17,3 +17,12 @@ grep tagged log cd .. rm -rf temp1 log++# issue2244: warn about duplicate tags++darcs init temp1+cd temp1+darcs tag shouldbeunique+darcs tag shouldbeunique | grep 'WARNING'+cd ..+rm -rf temp1
tests/tentative_revert.sh view
@@ -23,8 +23,7 @@ ## CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE ## SOFTWARE. -set -ev-. lib+. ./lib rm -rf R darcs init      --repo R touch R/foo
+ tests/test-untestable.sh view
@@ -0,0 +1,81 @@+#!/bin/sh -e+##+## Tests with untestable states+##+## Copyright (C) 2015 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++cat > runtest.hs <<END+import Control.Monad+import System.Exit+import System.IO+import System.Directory+main = do+  exists <- doesFileExist "teststatus"+  when exists $ do+    n <- liftM read (readFile "teststatus")+    when (n /= 0) (exitWith (ExitFailure n))+END++ghc $GHC_FLAGS --make -o runtest runtest.hs++export RUNTEST=`pwd`/runtest++mkdir R+cd R+darcs init++echo 0 > teststatus+darcs add teststatus+darcs rec -am "teststatus=0"++echo 125 > teststatus+darcs rec -am "teststatus=125"++echo 1 > teststatus+darcs rec -am "teststatus=1"++darcs test --linear "$RUNTEST" > results++grep -A10 "These patches jointly trigger the failure" results > patchlist++grep "teststatus=1" patchlist+grep "teststatus=125" patchlist+not grep "teststatus=0" patchlist++darcs test --backoff "$RUNTEST" > results++grep -A10 "These patches jointly trigger the failure" results > patchlist++grep "teststatus=1" patchlist+grep "teststatus=125" patchlist+not grep "teststatus=0" patchlist++darcs test --bisect "$RUNTEST" > results++grep -A10 "These patches jointly trigger the failure" results > patchlist++grep "teststatus=1" patchlist+grep "teststatus=125" patchlist+not grep "teststatus=0" patchlist
+ tests/test.sh view
@@ -0,0 +1,42 @@+#!/usr/bin/env bash+## Ensure that "darcs test" succeeds when run in a complete+## repository with a dummy test that always succeeds.+##+## Copyright (C) 2008  David Roundy+##+## 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+## SOFTWARE.++. lib                           # Load some portability helpers.+rm -rf R                        # Another script may have left a mess.+darcs init      --repo R+darcs setpref   --repo R test 'grep hello f'+not darcs record    --repo R -am 'true test' --test+darcs record    --repo R -am 'true test' --no-test++touch R/f+darcs record    --repo R -lam 'added foo' --no-test+darcs tag       --repo R -m 'got f?'++echo hello > R/f+darcs record    --repo R -lam 'hellofoo' --test+darcs test      --repo R++rm -rf R                        # Clean up after ourselves.
tests/three_way_conflict.sh view
@@ -1,5 +1,5 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1 temp2 temp3 mkdir -p temp1 temp2 temp3@@ -25,10 +25,10 @@ echo C > foo darcs record -a -A author -m CC -darcs pull -a ../temp2-darcs pull -a ../temp3+darcs pull -a ../temp2 --allow-conflicts+darcs pull -a ../temp3 --allow-conflicts  cd ../temp2-darcs pull -a ../temp3-darcs pull -a ../temp1+darcs pull -a ../temp3 --allow-conflicts+darcs pull -a ../temp1 --allow-conflicts rm -rf temp1 temp2 temp3
− tests/toolbox.sh 
@@ -1,19 +0,0 @@-#!/usr/bin/env bash--. lib--DIR="`pwd`"--abort_windows--# set up the repository-rm -rf temp1                    # another script may have left a mess.-mkdir temp1-cd temp1-darcs init-touch foo-darcs add foo-# trick: hitting 'enter' in interactive darcs record-echo n/ | tr / \\012 | darcs record-cd ..-rm -rf temp1
tests/trackdown-bisect.sh view
@@ -1,21 +1,19 @@-#!/bin/env bash-# A test for trackdown --bisect option.+#!/usr/bin/env bash+# A test for test --linear, test --bisect and test --backoff. # In general it construct various repositories and try # to find the last recent failing patch and match it with # expected position.-#-# It runs the same tests also for the trackdown without-# the --bisect. ################################################################ -set -ev+. ./lib  if echo $OS | grep -i windows; then     echo I do not know how to run a test program under windows     exit 0 fi -ghc -o trackdown-bisect-helper $TESTBIN/trackdown-bisect-helper.hs+cp $TESTBIN/trackdown-bisect-helper.hs .+ghc $GHC_FLAGS -o trackdown-bisect-helper trackdown-bisect-helper.hs  function make_repo_with_test {     rm -fr temp1@@ -32,15 +30,15 @@     rm -fr temp1 } -# You can remove --bisect for compare with linear trackdown-trackdown_args='--bisect' +# You can replace --bisect by --linear for compare with linear trackdown+test_args='--bisect'   # Function return true if given patch was found. # It expects that last line has finish with <SPACE><patchname> # For the linear it is second last from the end, and last line-# is sentence if trackdown failed or succeed.+# is sentence if test failed or succeed. function is_found_good_patch  {-    if [ -z "$trackdown_args" ]; then+    if [ "$test_args" == "--linear" ]; then     tail -n 2 | grep " $1\$"     else      tail -n 1 | grep " $1\$"@@ -55,10 +53,9 @@ # Section with test-cases ############################################################################# -# TEST01: Repo with success in the half testTrackdown() { make_repo_with_test $1-if darcs trackdown $trackdown_args "$test_cmd" | is_found_good_patch $2; then+if darcs test $test_args "$test_cmd" | is_found_good_patch $2; then     echo "ok 1" else     echo "not ok 1. the trackdown should find last failing patch = $2."@@ -67,75 +64,56 @@ cleanup_repo_after } +testTrackdownNoPasses() {+make_repo_with_test $1+if darcs test $test_args "$test_cmd" | grep "Noone passed the test"; then+    echo "ok 1"+else+    echo "not ok 1. The trackdown should report 'Noone passed the test'."+    exit 1+fi+cleanup_repo_after+}+ # TEST01: Repo with success in the half test01() { testTrackdown '[1,1,0,0,0]' 3 } -# TEST02: Repo with without success condition+# TEST02: Repo without success condition test02() { -testTrackdown '[0,0,0,0,0]' 1+testTrackdownNoPasses '[0,0,0,0,0]' } -# TEST03: Repo with with success condition at before last patch+# TEST03: Repo with success condition at before last patch test03() { testTrackdown '[1,1,1,1,0]' 5 } -# TEST04: Repo with with success condition as first patch ever+# TEST04: Repo with success condition as first patch ever test04() { testTrackdown '[1,0,0,0,0]' 2 } -# TEST05: Long repo with with success condition as first patch ever-test05() {-testTrackdown '[1,0,0,0,0,0,0,0,0,0,0]' 2-}--# TEST06: Long repo with with success condition as sixth patch-test06() {-testTrackdown '[1,1,1,1,1,1,0,0,0,0,0,0,0,0,0,0,0,0,0,0]' 7-}--# TEST07: Long repo with with success condition very nead the head-test07() {-testTrackdown '[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0,0]' 54-}--# TEST08: Long repo with with success condition very nead the head-test08() {-testTrackdown '[1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,0,0]' 55-}--# TEST09: Long repo with non-monotone errors / success distribution-# This test only tests that it will not crash... -test09() {-testTrackdown '[1,1,1,1,1,1,0,0,0,0,1,0,0,1,0,0,0,0,0,0]' 7-}- #############################################-# call test-cases for trackdown linear+# call test-cases for linear trackdown #############################################-trackdown_args=''+test_args='--linear' test01 test02+#############################################+# Call test-cases for bisect trackdown+#############################################+test_args='--bisect' +test01+test02 test03 test04-test05-test06-test07-test08 #############################################-# Call test-cases for trackdown bisect+# Call test-cases for backoff trackdown #############################################-trackdown_args='--bisect' +test_args='--backoff' test01 test02 test03 test04-test05-test06-test07-test08-test09 # only for --bisect-
− tests/tricky_unrecord.sh 
@@ -1,27 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp-mkdir temp-cd temp-darcs init-date > temp.c-darcs add temp.c-darcs record --all -A test --name=hi--mkdir d-darcs add d-darcs mv temp.c d/-darcs record --all -A test --name=mvetc-darcs show contents d/temp.c | cmp d/temp.c ---echo y/d/y | tr / \\012 | darcs unrecord-darcs whatsnew-# darcs show contents d/temp.c | cmp d/temp.c ---darcs record --all -A test --name=again-darcs show contents d/temp.c | cmp d/temp.c ---cd ..-rm -rf temp-
tests/uniqueoptions.sh view
@@ -1,21 +1,14 @@ #!/usr/bin/env bash-echo-echo Checking that each command expects each option only once-echo--set -ev+# Check that each command expects each option only once -if echo $OS | grep -i windows; then-    echo Noone knows how to handle newlines under cygwin, so we skip this test-    exit 0-fi+. ./lib  rm -rf temp1 mkdir temp1 cd temp1  for i in `darcs --commands | grep -v -- -- | xargs echo`; do-    echo -n Checking $i... ' '+    echo -n "Checking $i... "     # only output actual command options, i.e. lines that contain a --     darcs $i --help | grep -- "--" | sort > $i     uniq $i > uni$i@@ -29,5 +22,3 @@ done  cd ..-rm -rf temp1-
− tests/unpull-formerly-pl.sh 
@@ -1,51 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf tempA-mkdir tempA-cd tempA-darcs initialize-echo hello world > foo-darcs add foo-darcs record -a -m hellofoo--echo goodbye world >> foo-darcs record -a -m goodbyefoo--darcs replace world bar foo-echo Hi there foo > bar-darcs add bar-darcs record -a -m addbar--darcs mv bar baz-darcs replace bar baz foo-darcs record -a -m bar2baz--echo Do not love the baz, or anything in the baz. >> foo-darcs record -a -m nolove--darcs mv baz world-darcs replace baz world foo-darcs record -a -m baz2world--darcs whatsnew | grep 'No changes'--grep 'love the world' foo--echo y | darcs unpull -p baz2world--darcs whatsnew | grep 'No changes'--grep 'love the baz' foo--echo y | darcs unpull -p bar2baz--grep 'love the bar' foo--echo y | darcs unpull -p nolove--grep 'love' foo && exit 1 || true--cd ..-rm -rf tempA-
− tests/unpull.sh 
@@ -1,23 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init-cat > f <<EOF-one-two-three-EOF-darcs rec -Ax -alm init-cp f g-cat > f <<EOF-three-one-EOF-darcs rec -Ax -am foo-echo y | darcs unpull -p foo-cmp f g-cd ..-rm -rf temp1
− tests/unrecord-add.sh 
@@ -1,23 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo foo > foo-darcs add foo-darcs whatsnew > correct-cat correct--darcs record -a -m 'addfoo'--darcs unrecord -a--darcs whatsnew > unrecorded-cat unrecorded--diff -u correct unrecorded--cd ..-rm -rf temp1
− tests/unrecord-dont-prompt.sh 
@@ -1,28 +0,0 @@-#!/usr/bin/env bash--set -ev--# Check that the right patches get unrecorded using --dont-prompt-for-dependencies--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo foo > f-darcs record -Ax -alm foo1-echo bar > b-darcs rec -Ax -alm bar1-echo foo2 > f-darcs record -Ax -alm foo2-echo bar2 > b-darcs record -Ax -alm bar2-darcs unrec --no-deps -p foo1-darcs changes -p foo --count | grep 2-#foo1 is depended upon, we don't unpull it-echo y | darcs unrec --dont-prompt-for-dependencies -p foo1-#on the previous line, we don't get asked about foo2.-darcs changes -p foo --count | grep 0-#yet, it is unrecorded.-darcs changes -p bar --count | grep 2-cd ..-rm -rf temp1
− tests/unrecord-remove.sh 
@@ -1,28 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo foo > foo-darcs add foo--darcs record -a -m 'addfoo'--darcs remove foo--darcs whatsnew > correct-cat correct--darcs record -a -m 'rmfoo'--darcs unrecord -a --last 1--darcs whatsnew > unrecorded-cat unrecorded--diff -u correct unrecorded--cd ..-rm -rf temp1
− tests/unrecord-setpref.sh 
@@ -1,24 +0,0 @@-#!/usr/bin/env bash-set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init--darcs setpref boringfile foobar--darcs whatsnew > correct-cat correct--darcs record -a -m 'boringfoobar'--darcs unrecord -a--darcs whatsnew > unrecorded-cat unrecorded--diff -u correct unrecorded--cd ..-rm -rf temp1
+ tests/unrecord.sh view
@@ -0,0 +1,126 @@+#!/usr/bin/env bash+. ./lib++# unrecord remove++rm -rf temp1+darcs init temp1+cd temp1++echo foo > foo+darcs record -lam 'addfoo'+darcs remove foo+darcs whatsnew > correct+darcs record -a -m 'rmfoo'+darcs unrecord -a --last 1+darcs whatsnew > unrecorded+diff -u correct unrecorded++cd ..+rm -rf temp1++# unrecord setpref++darcs init temp1+cd temp1++darcs setpref boringfile foobar++darcs whatsnew > correct+cat correct++darcs record -a -m 'boringfoobar'+darcs unrecord -a++darcs whatsnew > unrecorded+cat unrecorded++diff -u correct unrecorded++cd ..+rm -rf temp1++# unrecord add++darcs init temp1+cd temp1++echo foo > foo+darcs add foo+darcs whatsnew > correct+cat correct++darcs record -a -m 'addfoo'++darcs unrecord -a++darcs whatsnew > unrecorded+cat unrecorded++diff -u correct unrecorded++cd ..+rm -rf temp1++# tricky unrecord++darcs init temp1+cd temp1++date > temp.c+darcs record -lam hi++mkdir d+darcs add d+darcs mv temp.c d/+darcs record -am mvetc+darcs show contents d/temp.c | cmp d/temp.c -++echo y/d/y | tr / \\012 | darcs unrecord+darcs whatsnew++darcs record -a -m again+darcs show contents d/temp.c | cmp d/temp.c -++cd ..+rm -rf temp1++# Check that the right patches get unrecorded using --dont-prompt-for-dependencies++darcs init temp1+cd temp1++echo foo > f+darcs record -Ax -alm foo1+echo bar > b+darcs rec -Ax -alm bar1+echo foo2 > f+darcs record -Ax -alm foo2+echo bar2 > b+darcs record -Ax -alm bar2+darcs unrec --no-deps -p foo1+darcs changes -p foo --count | grep 2+#foo1 is depended upon, we don't unpull it+echo yy | darcs unrec --dont-prompt-for-dependencies -p foo1+#on the previous line, we don't get asked about foo2.+darcs changes -p foo --count | grep 0+#yet, it is unrecorded.+darcs changes -p bar --count | grep 2+cd ..+rm -rf temp1+++# issue1012: rm/record/unrecord/record => inconsistent repository++darcs init temp1+cd temp1++echo temp1 >File.hs+darcs add File.hs+darcs record File.hs -a -m "add File"+rm File.hs+darcs record -a -m "rm File"+darcs unrecord -p "rm File" -a+darcs record -a -m "re-rm File"+cd ..+rm -rf temp1
− tests/unrevert-add.sh 
@@ -1,26 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo foo > foo-darcs add foo-darcs whatsnew > correct-cat correct--darcs revert -a--not darcs whatsnew--darcs unrevert -a--darcs whatsnew > unrecorded-cat unrecorded--diff -u correct unrecorded--cd ..-rm -rf temp1
+ tests/unrevert-may-conflict.sh view
@@ -0,0 +1,23 @@+#!/usr/bin/env bash++# 'darcs unrevert' may result in a conflict: revert a change,+# record another change that conflicts with what was reverted,+# then unrevert.+# This was originally thought to be a bug (issue2609) but really+# is normal, expected behavior.++. lib++rm -rf R++darcs init R+cd R+echo A > f+darcs record -lam A f+echo V > f+darcs revert -a+echo B > f+darcs record -lam B f+darcs unrevert -a 2>&1 | tee unrevert_log+grep conflicts unrevert_log+cd ..
− tests/unrevert-replace-moved.sh 
@@ -1,36 +0,0 @@-#!/usr/bin/env bash--. lib--rm -rf temp1-mkdir temp1-cd temp1-darcs init-echo hello world > foo-darcs add foo--darcs record -a -m 'addfoo'--darcs replace hello goodbye foo--darcs revert -a--not darcs whatsnew--darcs mv foo bar--echo hello my good friends >> bar--darcs unrevert -a--darcs whatsnew > unrecorded-cat unrecorded--grep 'bar .* hello goodbye' unrecorded--cat bar-grep 'goodbye world' bar-grep 'goodbye my good friends' bar--cd ..-rm -rf temp1
tests/unrevert.sh view
@@ -1,13 +1,12 @@ #!/usr/bin/env bash-set -ev+. ./lib  rm -rf temp1-mkdir temp1+darcs init temp1 cd temp1-darcs init+ echo hello world > foo-darcs add foo-darcs record -a -m add -A x+darcs record -lam add echo goodbye world >> foo cp foo bar darcs revert -a@@ -19,3 +18,116 @@ cd .. rm -rf temp1 +# unrevert replace moved++darcs init temp1+cd temp1++echo hello world > foo+darcs record -lam 'addfoo'+darcs replace hello goodbye foo+darcs revert -a++not darcs whatsnew++darcs mv foo bar++echo hello my good friends >> bar++darcs unrevert -a++darcs whatsnew > unrecorded+cat unrecorded++grep 'bar .* hello goodbye' unrecorded++cat bar+grep 'goodbye world' bar+grep 'goodbye my good friends' bar++cd ..+rm -rf temp1++# unrevert cancel+# From issue366 bug report++darcs init temp1+cd temp1++touch a b +darcs record -lam init+echo plim >> a+echo plim >> b+echo yyyy | darcs revert+echo ploum >> a +echo nyyy | darcs unrevert++cd ..+rm -rf temp1++# unrevert add++darcs init temp1+cd temp1++echo foo > foo+darcs add foo+darcs whatsnew > correct+cat correct++darcs revert -a++not darcs whatsnew++darcs unrevert -a++darcs whatsnew > unrecorded+cat unrecorded++diff -u correct unrecorded++cd ..+rm -rf temp1++# double unrevert+# This demonstrates a bug that happens if you revert followed by+# a partial unrevert and a full unrevert.  It requires that+# the second unrevert is working with patches who's contents need+# to be modified by the commute in the first unrevert.++darcs init temp1+cd temp1++echo line1 >> A+echo line2 >> A+echo line3 >> A+echo line4 >> A+echo line5 >> A+echo line6 >> A+darcs add A+darcs record -am A+sed 's/line2/Line2/' A  > A1; rm A; mv A1 A+sed '4d' A > A1; rm A; mv A1 A+sed 's/line6/Line6/' A > A1; rm A; mv A1 A+darcs revert -a+echo nyny | darcs unrev+darcs unrev -a++cd ..+rm -rf temp1++# impossible unrevert++darcs init temp1+cd temp1++echo a > foo+darcs record -lam aa+echo b > foo+echo yy | darcs revert -a+echo ydyy | darcs unrecord+# since the unrevert is impossible, we should fail if it succeeds...+echo yy | darcs unrevert && exit 1 || true++cd ..+rm -rf temp1
− tests/unrevert_cancel.sh 
@@ -1,22 +0,0 @@-#!/usr/bin/env bash--# From issue366 bug report--set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init-touch a -touch b-darcs add *-darcs record -A moi -am init-echo plim >> a-echo plim >> b-echo y/y/y/ | tr / \\012 | darcs revert-echo ploum >> a -echo nyy | tr / \\012 | darcs unrevert--cd ..-rm -rf temp1
+ tests/utf8-display.sh view
@@ -0,0 +1,45 @@+#!/bin/sh -e+##+## Basic test of displaying metadata in the UTF8 locale+##+## Copyright (C) 2014 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++switch_to_utf8_locale++#is now the default, must use DARCS_ESCAPE_8BIT to disable+#export DARCS_DONT_ESCAPE_8BIT=1++rm -rf R+mkdir R+cd R++darcs init+echo 'Société nationale des chemins de fer français' > f+darcs rec -lam 'creació de a i b' | grep 'creació de a i b'++darcs changes | grep 'creació de a i b'++darcs annotate f | grep 'creació de a i b'+darcs annotate f | grep 'Société nationale des chemins de fer français'
− tests/utf8.sh 
@@ -1,193 +0,0 @@-#!/usr/bin/env bash-## Test for issue64 - Should store patch metadata in UTF-8-##-## Copyright (C) 2009  Reinier Lamers-##-## 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-## SOFTWARE.--. lib --# Helper function: do a darcs changes --xml and grep the result for the first-# argument. If it is not found, exit with status 1. Otherwise, continue. The-# second argument is a text that describes what we're grepping for.-# If a third argument is given, it is used as the value for a --last option for-# darcs changes.-grep_changes () {-    if [ -z "$3" ]; then-            last=""-    else-            last="--last $3"-    fi--    darcs changes $last --xml > changes.xml-    if grep "$1" changes.xml ; then-        echo "$2 OK"-    else-        cat changes.xml-        echo "$2 not UTF-8-encoded!"-        exit 1-    fi-}---# This file is encoded in ISO-8859-15 aka latin9. It was crafted with a hex editor.-# Please leave it this way :-)-switch_to_latin9_locale--rm -rf temp1-mkdir temp1-cd temp1--darcs init--# Test recording non-UTF-8-encoded non-latin1 ("funny") metadata from-# interactive input--echo 'Selbstverständlich überraschend' > something.txt-darcs add something.txt--echo 'l33tking¸0r@example.org' > interaction_script.txt-echo y >> interaction_script.txt-echo y >> interaction_script.txt-echo '¤uroh4xx0rz' >> interaction_script.txt-echo n >> interaction_script.txt--unset DARCSEMAIL-unset EMAIL-set-darcs record -i < interaction_script.txt-grep_changes 'l33tkingž0r@example.org' 'patch author from interactive prompt'-grep_changes '€uroh4xx0rz' 'patch name from interactive prompt'--# Test recording funny metadata from command line --echo 'Sogar überraschender' >> something.txt--darcs record -a -A 'Jérôme Leb½uf' -m 'that will be ¤ 15, sir'--grep_changes 'that will be € 15, sir' 'patch name from command line'-grep_changes 'Jérôme Lebœuf' 'patch author from command line'--# Test recording funny metadata from a log file--echo 'Am allerüberraschendsten' >> something.txt--echo 'darcs is soms wat naïef aangaande tekstcodering' > log.txt-echo 'en zulke naïviteit is tegenwoordig passé, aldus ´i¸ek' >> log.txt-darcs record -a -A 'Jérôme Leb½uf' --logfile=log.txt--grep_changes 'darcs is soms wat naïef aangaande tekstcodering' 'patch name from log file'-grep_changes 'en zulke naïviteit is tegenwoordig passé, aldus Žižek' 'patch log from log file'--# Test recording funny metadata from environment, -export EMAIL='Slavoj ´i¸ek <zizek@example.edu>'-rm _darcs/prefs/author-echo 'La la la, the more lines the better!' >> something.txt-darcs record -a -m 'Patch names are overrated'--grep_changes 'Slavoj Žižek' 'author name from environment'--# Test recording funny metadata from prefs files-echo '´ed is dead' > _darcs/prefs/author-echo '483 bottles of beer on the wall' >> something.txt-darcs record -a -m 'Patch by ´ed'--grep_changes 'Žed is dead' 'author name from prefs file'--# Test amend-recording funny metadata-echo 'No, it is really 484' >> something.txt-echo y | darcs amend-record -p 'Patch by ' -A '´ed is even deader' -a-grep_changes 'Žed is even deader' 'author name from amend-record command line flag'--cat <<FAKE > editor.hs # create an 'editor' that writes latin9-import System.Environment-import qualified Data.ByteString as B-str = B.pack [65,108,108,32,109,121,32,164,115,32,97,114,101,32,103,111,110,101]-main = getArgs >>= \[x] -> B.writeFile x str-FAKE-ghc --make -o editor editor.hs-export EDITOR="`pwd`/editor"-printf "y\ny\n" | darcs amend --edit -p 'Patch by '-grep_changes 'All my €s are gone' 'description edited from amend-record'-grep_changes 'Žed is even deader' 'author name taken from draft in amend'--# Test rollback recording funny metadata-printf "y\ny\n" | darcs rollback -p 's are gone' -A '´ee´ee' -m "No patch¤s by ´ed!"-grep_changes 'ŽeeŽee' 'Author name from rollback command line'-grep_changes 'No patch€s by Žed' 'Patch name from rollback command line'-grep_changes 'All my €s are gone' 'Patch name of rolled back patch' 1-grep_changes 'Žed is even deader' 'Author name of rolled back patch' 1--# Test tag recording funny metadata-rm _darcs/prefs/author # Make tag be taken from EMAIL env variable-darcs tag -m '´ is my favorite letter'-grep_changes 'Slavoj Žižek' 'author name from environment with tag command' 1-grep_changes 'Ž is my favorite letter' 'Tag name from command line'--unset EMAIL-printf "´ors\ninitialcomment\n" | darcs tag --edit-long-comment-grep_changes Žors 'Author name from interactive prompt from tag command'-grep_changes 'All my €s are gone' 'Tag name from editor from tag command' 1--if grep ´ors _darcs/prefs/author ; then-    echo 'Author name stored locale-encoded in prefs file after tag command, OK'-else-    echo 'No locale-encoded author in prefs file after tag command!'-    exit 1-fi--darcs tag -A Ad¸e -m 'La¸t call'-grep_changes Adže 'Author name from tag command line' 1-grep_changes 'Lažt call' 'Tag name from tag command line (take 2)' 1--cd ..--# test that UTF-8 metadata doesn't get mangled on get-rm -rf temp2-darcs get temp1 temp2-darcs changes --repodir temp1 --xml > temp1/changes.xml-darcs changes --repodir temp2 --xml > temp2/changes.xml-diff temp1/changes.xml temp2/changes.xml--# and that it doesn't get mangled on push-rm -rf temp2-mkdir temp2; darcs init --repodir temp2-darcs push --repodir temp1 -a temp2 --set-default-darcs changes --repodir temp1 --xml > temp1/changes.xml-darcs changes --repodir temp2 --xml > temp2/changes.xml-diff temp1/changes.xml temp2/changes.xml--# and that it doesn't get mangled on pull-rm -rf temp2-mkdir temp2; darcs init --repodir temp2-darcs pull --repodir temp2 -a temp1-darcs changes --repodir temp1 --xml > temp1/changes.xml-darcs changes --repodir temp2 --xml > temp2/changes.xml-diff temp1/changes.xml temp2/changes.xml--# and that it doesn't get mangled on send-rm -rf temp2-mkdir temp2; darcs init --repodir temp2-darcs send --repodir temp1 -a -o temp2/patch.dpatch-darcs apply --repodir temp2 -a temp2/patch.dpatch-darcs changes --repodir temp1 --xml > temp1/changes.xml-darcs changes --repodir temp2 --xml > temp2/changes.xml-diff temp1/changes.xml temp2/changes.xml
tests/v1-braced.sh view
@@ -26,10 +26,10 @@  . lib                  # Load some portability helpers. -grep hashed $HOME/.darcs/defaults || exit 200+only-format darcs-1  rm -rf braced-gunzip -c $TESTDATA/braced.tgz | tar xf -+unpack_testdata braced cd braced darcs check cd ..@@ -42,7 +42,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'
− tests/what_sl.sh 
@@ -1,19 +0,0 @@-#!/usr/bin/env bash--set -ev--rm -rf temp1-mkdir temp1-cd temp1-darcs init-touch foo-darcs add foo-darcs rec -m t1 -a -A tester-echo 1 >> foo-darcs what -s | grep -v No\ changes-darcs what -l | grep -v No\ changes-darcs what -sl | grep -v No\ changes--cd ..-rm -rf temp1-
+ tests/whatsnew-adds-no-summary.sh view
@@ -0,0 +1,51 @@+#!/bin/sh -e+##+## Test for the interaction of --look-for-adds and --no-summary in darcs whatsnew+##+## Copyright (C) 2017 Ganesh Sittampalam+##+## 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+## SOFTWARE.++. lib++rm -rf R+mkdir R+cd R++darcs init++echo A > A+echo B > B++darcs add A+darcs rec -am "add A"++echo "A 2" > A++darcs whatsnew --look-for-adds --no-summary > output.txt++grep "hunk \./A 1" output.txt+grep "\-A" output.txt+grep "+A 2" output.txt+grep "addfile \./B" output.txt+grep "hunk \./B 1" output.txt+grep "+B" output.txt+
− tests/whatsnew-file.sh 
@@ -1,61 +0,0 @@-#!/usr/bin/env bash--. lib--# Some tests for 'darcs whatsnew '--rm -rf temp1--mkdir temp1-cd temp1--darcs init-date > foo-mkdir bar-echo hello world > bar/baz--darcs record -la -m "add foo"--echo goodbye world >> bar/baz--# goodbye should show up precisely once--darcs wh > out-cat out-grep goodbye out | wc -l | grep 1--darcs wh bar bar/baz > out-cat out-grep goodbye out | wc -l | grep 1--darcs mv foo bar-echo not date > bar/foo--darcs wh bar bar/baz > out-cat out-grep date out | wc -l | grep 1--darcs wh foo > out-cat out-grep date out | wc -l | grep 1--darcs wh foo foo foo > out-cat out-grep date out | wc -l | grep 1--darcs wh foo ./foo ../temp1/foo > out-cat out-grep date out | wc -l | grep 1--darcs wh foo bar/../foo > out-cat out-grep date out | wc -l | grep 1--# This one fails actually, but it's not my fault. Filed as issue1196.-#darcs wh foo foo/../foo/. > out-#cat out-#grep date out | wc -l | grep 1--cd ..--rm -rf temp1
− tests/whatsnew-pending.sh 
@@ -1,38 +0,0 @@-#!/usr/bin/env bash-## Ensure that darcs whatsnew <paths> only lists relevant bits.-## Public Domain, 2010, Petr Rockai-##-## This file is included as part of the Darcs test distribution,-## which is licensed to you under the following terms:-##-## 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-## SOFTWARE.--. lib                           # Load some portability helpers.-rm -rf R                        # Another script may have left a mess.-darcs init      --repo R        # Create our test repos.--cd R-mkdir d e                       # Change the working tree.-echo 'Example content.' > d/f-darcs record -lam 'Add d/f and e.'-darcs remove d/f-not darcs wh e # | not grep f-cd ..
tests/whatsnew.sh view
@@ -4,7 +4,7 @@  # Some tests for 'darcs whatsnew ' -rm -rf temp1 temp2+rm -rf temp1  mkdir temp1 cd temp1@@ -21,7 +21,8 @@ touch look_summary.txt darcs whatsnew -l | grep -i "a ./look_summary.txt" -#whatsnew works with uncommon file names+# whatsnew works with uncommon file names and does NOT display+# the internal "white space encoded" filename if echo $OS | grep -i windows; then   echo  test does not work on windows   exit 0;@@ -29,13 +30,13 @@   echo foo > \\   darcs add \\   darcs whatsnew | tee log-  grep 'hunk ./\\92\\' log+  grep 'hunk ./\\' log fi  echo foo > "foo bar" darcs add "foo bar" darcs wh | tee log-grep 'hunk ./foo\\32\\bar' log+grep 'hunk ./foo bar' log  # check that filename encoding does not botch up the index darcs rec -am "weird filenames"@@ -51,3 +52,115 @@ cd ..  rm -rf temp1+++## Part 2+## This tests the basic fascilities of `whatsnew --interactive`+## Copyright (C) 2014 Daniil Frumin++rm -rf wn-i++darcs init --repo wn-i+cd wn-i++echo lolz > foo+darcs add foo++echo n | darcs whatsnew -i > what+grep "Will not ask whether to view 1" what+rm what++echo yxgq | darcs whatsnew -i > what2+grep "M ./foo +1" what2+addfileCount=`grep -c "addfile" what2`+if [ "$addfileCount" -ne 3 ]; then+    exit 1+fi;+cd ..++## Part 3+## Ensure that darcs whatsnew <paths> only lists relevant bits.+## Public Domain, 2010, Petr Rockai++rm -rf R                        # Another script may have left a mess.+darcs init      --repo R        # Create our test repos.++cd R+mkdir d e                       # Change the working tree.+echo 'Example content.' > d/f+darcs record -lam 'Add d/f and e.'+darcs remove d/f+not darcs wh e # | not grep f+cd ..++## Part 4+# Some tests for 'darcs whatsnew '++rm -rf temp1++darcs init temp1+cd temp1++date > foo+mkdir bar+echo hello world > bar/baz++darcs record -la -m "add foo"++echo goodbye world >> bar/baz++# goodbye should show up precisely once++darcs wh > out+cat out+grep goodbye out | wc -l | grep 1++darcs wh bar bar/baz > out+cat out+grep goodbye out | wc -l | grep 1++darcs mv foo bar+echo not date > bar/foo++darcs wh bar bar/baz > out+cat out+grep date out | wc -l | grep 1++darcs wh foo > out+cat out+grep date out | wc -l | grep 1++darcs wh foo foo foo > out+cat out+grep date out | wc -l | grep 1++darcs wh foo ./foo ../temp1/foo > out+cat out+grep date out | wc -l | grep 1++darcs wh foo bar/../foo > out+cat out+grep date out | wc -l | grep 1++darcs wh foo foo/../foo/. > out+cat out+grep date out | wc -l | grep 1++cd ..+rm -rf temp1++## Part 5++darcs init temp1+cd temp1+touch foo+darcs add foo+darcs rec -m t1 -a+echo 1 >> foo+darcs what -s | grep -v No\ changes+darcs what -l | grep -v No\ changes+darcs what -sl | grep -v No\ changes++cd ..+rm -rf temp1+
tests/workingdir.sh view
@@ -30,6 +30,7 @@ # try to move a file that we don't have the right to do darcs get temp1 temp2 --to-patch aa cd temp2+trap "test -d $PWD/a && chmod u+w $PWD/a" EXIT chmod u-w a darcs pull -a test -e b@@ -58,7 +59,7 @@ darcs get temp1 temp2 --tag 1 cd temp2 echo 2-b2 > b-darcs pull -a+echo y | darcs pull -a grep "v v v" b grep "2-b2"  b.~0~ not grep "v v v" b.~0~